diff options
128 files changed, 1694 insertions, 1429 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index b1709e1921..18ea50d77b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -461,7 +461,7 @@ pkg:nix:deploy:channel: script: - echo "$CACHIX_DEPLOYMENT_KEY" | tr -d '\r' | ssh-add - > /dev/null # Remove all pr branches because they could be missing when we run git fetch --unshallow - - git branch --list 'pr-*' | xargs -r git branch -d + - git branch --list 'pr-*' | xargs -r git branch -D - git fetch --unshallow - git branch -v - git push git@github.com:coq/coq-on-cachix "${CI_COMMIT_SHA}":"refs/heads/${CI_COMMIT_REF_NAME}" diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index ef606c9a75..7bb714aa17 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -104,7 +104,7 @@ let check_kelim k1 k2 = Sorts.family_leq k1 k2 let eq_nested_types ty1 ty2 = match ty1, ty2 with | NestedInd ind1, NestedInd ind2 -> eq_ind_chk ind1 ind2 | NestedInd _, _ -> false -| NestedPrimitive c1, NestedPrimitive c2 -> Names.Constant.equal c1 c2 +| NestedPrimitive c1, NestedPrimitive c2 -> Names.Constant.CanOrd.equal c1 c2 | NestedPrimitive _, _ -> false let eq_recarg a1 a2 = match a1, a2 with diff --git a/clib/cList.ml b/clib/cList.ml index 057200f83e..6b13fac48c 100644 --- a/clib/cList.ml +++ b/clib/cList.ml @@ -1019,20 +1019,12 @@ let rec factorize_left cmp = function module Smart = struct - let rec map_loop f p = function - | [] -> () - | x :: l' as l -> - let x' = f x in - map_loop f p l'; - if x' == x && !p == l' then p := l else p := x' :: !p - - let map f = function - | [] -> [] - | x :: l' as l -> - let p = ref [] in - let x' = f x in - map_loop f p l'; - if x' == x && !p == l' then l else x' :: !p + let rec map f l = match l with + | [] -> l + | h :: tl -> + let h' = f h in + let tl' = map f tl in + if h' == h && tl' == tl then l else h' :: tl' end diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 5e3199e8a6..83929bd030 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -469,7 +469,7 @@ let rec parse_symb self = function | Uentryl (e, l) -> assert (e = "tactic"); if l = 5 then SymbEntry ("Pltac.binder_tactic", None) - else SymbEntry ("Pltac.tactic_expr", Some (string_of_int l)) + else SymbEntry ("Pltac.ltac_expr", Some (string_of_int l)) let parse_token self = function | ExtTerminal s -> (terminal s, None) diff --git a/dev/ci/user-overlays/13075-ppedrot-explicit-names-quotient.sh b/dev/ci/user-overlays/13075-ppedrot-explicit-names-quotient.sh new file mode 100644 index 0000000000..8b223719ea --- /dev/null +++ b/dev/ci/user-overlays/13075-ppedrot-explicit-names-quotient.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "13075" ] || [ "$CI_BRANCH" = "explicit-names-quotient" ]; then + + elpi_CI_REF=explicit-names-quotient + elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi + + coq_dpdgraph_CI_REF=explicit-names-quotient + coq_dpdgraph_CI_GITURL=https://github.com/ppedrot/coq-dpdgraph + +fi diff --git a/dev/doc/parsing.md b/dev/doc/parsing.md index 4982e3e94d..4956b91d01 100644 --- a/dev/doc/parsing.md +++ b/dev/doc/parsing.md @@ -210,7 +210,7 @@ command. The first square bracket around a nonterminal definition is for groupi level definitions, which are separated with `|`, for example: ``` - tactic_expr: + ltac_expr: [ "5" RIGHTA [ te = binder_tactic -> { te } ] | "4" LEFTA @@ -220,8 +220,8 @@ level definitions, which are separated with `|`, for example: Grammar extensions can specify what level they are modifying, for example: ``` - tactic_expr: LEVEL "1" [ RIGHTA - [ tac = tactic_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } + ltac_expr: LEVEL "1" [ RIGHTA + [ tac = ltac_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } ] ]; ``` diff --git a/doc/changelog/02-specification-language/12768-master+warn-non-underscore-catch-all-pattern-matching.rst b/doc/changelog/02-specification-language/12768-master+warn-non-underscore-catch-all-pattern-matching.rst new file mode 100644 index 0000000000..c9e941743c --- /dev/null +++ b/doc/changelog/02-specification-language/12768-master+warn-non-underscore-catch-all-pattern-matching.rst @@ -0,0 +1,7 @@ +- **Added:** + Warning on unused variables in pattern-matching branches of + :n:`match` serving as catch-all branches for at least two distinct + patterns. + (`#12768 <https://github.com/coq/coq/pull/12768>`_, + fixes `#12762 <https://github.com/coq/coq/issues/12762>`_, + by Hugo Herbelin). diff --git a/doc/sphinx/language/core/inductive.rst b/doc/sphinx/language/core/inductive.rst index 122b0f5dfb..ba0ec28f8b 100644 --- a/doc/sphinx/language/core/inductive.rst +++ b/doc/sphinx/language/core/inductive.rst @@ -342,9 +342,9 @@ Recursive functions: fix .. insertprodn term_fix fixannot .. prodn:: - term_fix ::= let fix @fix_body in @term - | fix @fix_body {? {+ with @fix_body } for @ident } - fix_body ::= @ident {* @binder } {? @fixannot } {? : @type } := @term + term_fix ::= let fix @fix_decl in @term + | fix @fix_decl {? {+ with @fix_decl } for @ident } + fix_decl ::= @ident {* @binder } {? @fixannot } {? : @type } := @term fixannot ::= %{ struct @ident %} | %{ wf @one_term @ident %} | %{ measure @one_term {? @ident } {? @one_term } %} diff --git a/doc/sphinx/language/extensions/match.rst b/doc/sphinx/language/extensions/match.rst index 561262262b..3c1983ee97 100644 --- a/doc/sphinx/language/extensions/match.rst +++ b/doc/sphinx/language/extensions/match.rst @@ -290,6 +290,43 @@ This example emphasizes what the printing settings offer. Print snd. +Conventions about unused pattern-matching variables +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Pattern-matching variables that are not used on the right-hand side of ``=>`` are +considered the sign of a potential error. For instance, it could +result from an undetected mispelled constant constructor. By default, +a warning is issued in such situations. + +.. warn:: Unused variable @ident catches more than one case. + + This indicates that an unused pattern variable :token:`ident` + occurs in a pattern-matching clause used to complete at least two + cases of the pattern-matching problem. + + The warning can be deactivated by using a variable name starting + with ``_`` or by setting ``Set Warnings + "-unused-pattern-matching-variable"``. + + Here is an example where the warning is activated. + + .. example:: + + .. coqtop:: none + + Set Warnings "-unused-pattern-matching-variable". + + .. coqtop:: all + + Definition is_zero (o : option nat) := match o with + | Some 0 => true + | x => false + end. + + .. coqtop:: none + + Set Warnings "+unused-pattern-matching-variable". + Patterns -------- diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 5c091f04ac..8663ac646b 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -161,7 +161,7 @@ Syntactic values Provides a way to use the syntax and semantics of a grammar nonterminal as a value in an :token:`ltac_expr`. The table below describes the most useful of these. You can see the others by running ":cmd:`Print Grammar` `tactic`" and -examining the part at the end under "Entry tactic:tactic_arg". +examining the part at the end under "Entry tactic:tactic_value". :token:`ident` name of a grammar nonterminal listed in the table diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 770de9a6c3..cdbae8ade1 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -5724,11 +5724,11 @@ respectively. local function definition -.. tacv:: pose fix @fix_body +.. tacv:: pose fix @fix_decl local fix definition -.. tacv:: pose cofix @fix_body +.. tacv:: pose cofix @fix_decl local cofix definition diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 0c51361b64..06018304ab 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -444,7 +444,7 @@ Displaying information about notations This command doesn't display all nonterminals of the grammar. For example, productions shown by `Print Grammar tactic` refer to nonterminals `tactic_then_locality` - and `tactic_then_gen` which are not shown and can't be printed. + and `for_each_goal` which are not shown and can't be printed. Most of the grammar in the documentation was updated in 8.12 to make it accurate and readable. This was done using a new developer tool that extracts the grammar from the @@ -477,16 +477,16 @@ Displaying information about notations such as `1+2*3` in the usual way as `1+(2*3)`. However, most nonterminals have a single level. For example, this output from `Print Grammar tactic` shows the first 3 levels for - `tactic_expr`, designated as "5", "4" and "3". Level 3 is right-associative, + `ltac_expr`, designated as "5", "4" and "3". Level 3 is right-associative, which applies to the productions within it, such as the `try` construct:: - Entry tactic_expr is + Entry ltac_expr is [ "5" RIGHTA [ binder_tactic ] | "4" LEFTA [ SELF; ";"; binder_tactic | SELF; ";"; SELF - | SELF; ";"; tactic_then_locality; tactic_then_gen; "]" ] + | SELF; ";"; tactic_then_locality; for_each_goal; "]" ] | "3" RIGHTA [ IDENT "try"; SELF : @@ -510,7 +510,7 @@ Displaying information about notations The output for `Print Grammar constr` includes :cmd:`Notation` definitions, which are dynamically added to the grammar at run time. - For example, in the definition for `operconstr`, the production on the second line shown + For example, in the definition for `term`, the production on the second line shown here is defined by a :cmd:`Reserved Notation` command in `Notations.v`:: | "50" LEFTA diff --git a/doc/tools/docgram/README.md b/doc/tools/docgram/README.md index 4d38955fa8..dbb04bb6a6 100644 --- a/doc/tools/docgram/README.md +++ b/doc/tools/docgram/README.md @@ -42,7 +42,7 @@ for documentation purposes: First, nonterminals that use levels (`"5" RIGHTA` below) are modified, for example: ``` - tactic_expr: + ltac_expr: [ "5" RIGHTA [ te = binder_tactic -> { te } ] [ "4" ... diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index f9aba5b1e1..f6a684bbd7 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -28,15 +28,15 @@ strategy_level_or_var: [ | strategy_level ] -operconstr0: [ -| "ltac" ":" "(" tactic_expr5 ")" +term0: [ +| "ltac" ":" "(" ltac_expr5 ")" ] EXTRAARGS_natural: [ | DELETENT ] EXTRAARGS_lconstr: [ | DELETENT ] EXTRAARGS_strategy_level: [ | DELETENT ] G_LTAC_hint: [ | DELETENT ] -G_LTAC_operconstr0: [ | DELETENT ] +G_LTAC_term0: [ | DELETENT ] G_REWRITE_binders: [ | DELETE Pcoq.Constr.binders @@ -86,7 +86,7 @@ RENAME: [ | G_LTAC2_eqn_ipat ltac2_eqn_ipat | G_LTAC2_conversion ltac2_conversion | G_LTAC2_oriented_rewriter ltac2_oriented_rewriter -| G_LTAC2_tactic_then_gen ltac2_tactic_then_gen +| G_LTAC2_for_each_goal ltac2_for_each_goal | G_LTAC2_tactic_then_last ltac2_tactic_then_last | G_LTAC2_as_name ltac2_as_name | G_LTAC2_as_ipat ltac2_as_ipat @@ -94,18 +94,22 @@ RENAME: [ | G_LTAC2_match_list ltac2_match_list ] -(* renames to eliminate qualified names - put other renames at the end *) +(* Renames to eliminate qualified names. + Put other renames at the end *) RENAME: [ (* map missing names for rhs *) | Constr.constr term | Constr.global global | Constr.lconstr lconstr -| Constr.lconstr_pattern cpattern +| Constr.cpattern cpattern | G_vernac.query_command query_command | G_vernac.section_subset_expr section_var_expr | Prim.ident ident | Prim.reference reference +| Prim.string string +| Prim.integer integer +| Prim.qualid qualid +| Prim.natural natural | Pvernac.Vernac_.main_entry vernac_control | Tactic.tactic tactic @@ -117,7 +121,7 @@ RENAME: [ | Prim.identref ident | Prim.natural natural *) -| Vernac.rec_definition rec_definition +| Vernac.fix_definition fix_definition (* todo: hmm, rename adds 1 prodn to closed_binder?? *) | Constr.closed_binder closed_binder ] @@ -183,19 +187,19 @@ DELETE: [ (* additional nts to be spliced *) tactic_then_last: [ -| REPLACE "|" LIST0 ( OPT tactic_expr5 ) SEP "|" -| WITH LIST0 ( "|" ( OPT tactic_expr5 ) ) +| REPLACE "|" LIST0 ( OPT ltac_expr5 ) SEP "|" +| WITH LIST0 ( "|" ( OPT ltac_expr5 ) ) ] goal_tactics: [ -| LIST0 ( OPT tactic_expr5 ) SEP "|" +| LIST0 ( OPT ltac_expr5 ) SEP "|" ] -tactic_then_gen: [ | DELETENT ] +for_each_goal: [ | DELETENT ] -tactic_then_gen: [ +for_each_goal: [ | goal_tactics -| OPT ( goal_tactics "|" ) OPT tactic_expr5 ".." OPT ( "|" goal_tactics ) +| OPT ( goal_tactics "|" ) OPT ltac_expr5 ".." OPT ( "|" goal_tactics ) ] tactic_then_last: [ @@ -203,19 +207,19 @@ tactic_then_last: [ ] ltac2_tactic_then_last: [ -| REPLACE "|" LIST0 ( OPT tac2expr6 ) SEP "|" (* Ltac2 plugin *) -| WITH LIST0 ( "|" OPT tac2expr6 ) TAG Ltac2 +| REPLACE "|" LIST0 ( OPT ltac2_expr6 ) SEP "|" (* Ltac2 plugin *) +| WITH LIST0 ( "|" OPT ltac2_expr6 ) TAG Ltac2 ] ltac2_goal_tactics: [ -| LIST0 ( OPT tac2expr6 ) SEP "|" TAG Ltac2 +| LIST0 ( OPT ltac2_expr6 ) SEP "|" TAG Ltac2 ] -ltac2_tactic_then_gen: [ | DELETENT ] +ltac2_for_each_goal: [ | DELETENT ] -ltac2_tactic_then_gen: [ +ltac2_for_each_goal: [ | ltac2_goal_tactics TAG Ltac2 -| OPT ( ltac2_goal_tactics "|" ) OPT tac2expr6 ".." OPT ( "|" ltac2_goal_tactics ) TAG Ltac2 +| OPT ( ltac2_goal_tactics "|" ) OPT ltac2_expr6 ".." OPT ( "|" ltac2_goal_tactics ) TAG Ltac2 ] ltac2_tactic_then_last: [ @@ -257,45 +261,40 @@ let_type_cstr: [ | type_cstr ] -(* rename here because we want to use "return_type" for something else *) -RENAME: [ -| return_type as_return_type -] - case_item: [ -| REPLACE operconstr100 OPT [ "as" name ] OPT [ "in" pattern200 ] -| WITH operconstr100 OPT ("as" name) OPT [ "in" pattern200 ] +| REPLACE term100 OPT [ "as" name ] OPT [ "in" pattern200 ] +| WITH term100 OPT ("as" name) OPT [ "in" pattern200 ] ] binder_constr: [ -| MOVETO term_forall_or_fun "forall" open_binders "," operconstr200 -| MOVETO term_forall_or_fun "fun" open_binders "=>" operconstr200 -| MOVETO term_let "let" name binders let_type_cstr ":=" operconstr200 "in" operconstr200 -| MOVETO term_if "if" operconstr200 as_return_type "then" operconstr200 "else" operconstr200 -| MOVETO term_fix "let" "fix" fix_decl "in" operconstr200 -| MOVETO term_cofix "let" "cofix" cofix_decl "in" operconstr200 -| MOVETO term_let "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" operconstr200 "in" operconstr200 -| MOVETO term_let "let" "'" pattern200 ":=" operconstr200 "in" operconstr200 -| MOVETO term_let "let" "'" pattern200 ":=" operconstr200 case_type "in" operconstr200 -| MOVETO term_let "let" "'" pattern200 "in" pattern200 ":=" operconstr200 case_type "in" operconstr200 +| MOVETO term_forall_or_fun "forall" open_binders "," term200 +| MOVETO term_forall_or_fun "fun" open_binders "=>" term200 +| MOVETO term_let "let" name binders let_type_cstr ":=" term200 "in" term200 +| MOVETO term_if "if" term200 as_return_type "then" term200 "else" term200 +| MOVETO term_fix "let" "fix" fix_decl "in" term200 +| MOVETO term_cofix "let" "cofix" cofix_body "in" term200 +| MOVETO term_let "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" term200 "in" term200 +| MOVETO term_let "let" "'" pattern200 ":=" term200 "in" term200 +| MOVETO term_let "let" "'" pattern200 ":=" term200 case_type "in" term200 +| MOVETO term_let "let" "'" pattern200 "in" pattern200 ":=" term200 case_type "in" term200 | MOVETO term_fix "fix" fix_decls | MOVETO term_cofix "cofix" cofix_decls ] term_let: [ -| REPLACE "let" name binders let_type_cstr ":=" operconstr200 "in" operconstr200 -| WITH "let" name let_type_cstr ":=" operconstr200 "in" operconstr200 -| "let" name LIST1 binder let_type_cstr ":=" operconstr200 "in" operconstr200 +| REPLACE "let" name binders let_type_cstr ":=" term200 "in" term200 +| WITH "let" name let_type_cstr ":=" term200 "in" term200 +| "let" name LIST1 binder let_type_cstr ":=" term200 "in" term200 (* Don't need to document that "( )" is equivalent to "()" *) -| REPLACE "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" operconstr200 "in" operconstr200 -| WITH "let" "(" LIST0 name SEP "," ")" as_return_type ":=" operconstr200 "in" operconstr200 -| REPLACE "let" "'" pattern200 ":=" operconstr200 "in" operconstr200 -| WITH "let" "'" pattern200 ":=" operconstr200 OPT case_type "in" operconstr200 -| DELETE "let" "'" pattern200 ":=" operconstr200 case_type "in" operconstr200 +| REPLACE "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" term200 "in" term200 +| WITH "let" "(" LIST0 name SEP "," ")" as_return_type ":=" term200 "in" term200 +| REPLACE "let" "'" pattern200 ":=" term200 "in" term200 +| WITH "let" "'" pattern200 ":=" term200 OPT case_type "in" term200 +| DELETE "let" "'" pattern200 ":=" term200 case_type "in" term200 ] atomic_constr: [ -| MOVETO qualid_annotated global univ_instance +| MOVETO qualid_annotated global univ_annot | MOVETO primitive_notations NUMBER | MOVETO primitive_notations string | MOVETO term_evar "_" @@ -308,9 +307,9 @@ atomic_constr: [ | MOVETO term_evar pattern_ident evar_instance ] -tactic_expr0: [ -| REPLACE "[" ">" tactic_then_gen "]" -| WITH "[>" tactic_then_gen "]" +ltac_expr0: [ +| REPLACE "[" ">" for_each_goal "]" +| WITH "[>" for_each_goal "]" ] (* lexer token *) @@ -337,68 +336,68 @@ scope_delimiter: [ ] type: [ -| operconstr200 +| term200 ] -operconstr100: [ -| REPLACE operconstr99 "<:" operconstr200 -| WITH operconstr99 "<:" type -| MOVETO term_cast operconstr99 "<:" type -| REPLACE operconstr99 "<<:" operconstr200 -| WITH operconstr99 "<<:" type -| MOVETO term_cast operconstr99 "<<:" type -| REPLACE operconstr99 ":" operconstr200 -| WITH operconstr99 ":" type -| MOVETO term_cast operconstr99 ":" type -| MOVETO term_cast operconstr99 ":>" +term100: [ +| REPLACE term99 "<:" term200 +| WITH term99 "<:" type +| MOVETO term_cast term99 "<:" type +| REPLACE term99 "<<:" term200 +| WITH term99 "<<:" type +| MOVETO term_cast term99 "<<:" type +| REPLACE term99 ":" term200 +| WITH term99 ":" type +| MOVETO term_cast term99 ":" type +| MOVETO term_cast term99 ":>" ] constr: [ -| REPLACE "@" global univ_instance +| REPLACE "@" global univ_annot | WITH "@" qualid_annotated | MOVETO term_explicit "@" qualid_annotated ] -operconstr10: [ +term10: [ (* Separate this LIST0 in the nonempty and the empty case *) (* The empty case is covered by constr *) -| REPLACE "@" global univ_instance LIST0 operconstr9 -| WITH "@" qualid_annotated LIST1 operconstr9 -| REPLACE operconstr9 +| REPLACE "@" global univ_annot LIST0 term9 +| WITH "@" qualid_annotated LIST1 term9 +| REPLACE term9 | WITH constr -| MOVETO term_application operconstr9 LIST1 appl_arg -| MOVETO term_application "@" qualid_annotated LIST1 operconstr9 +| MOVETO term_application term9 LIST1 arg +| MOVETO term_application "@" qualid_annotated LIST1 term9 (* fixme: add in as a prodn somewhere *) | MOVETO dangling_pattern_extension_rule "@" pattern_ident LIST1 identref | DELETE dangling_pattern_extension_rule ] -operconstr9: [ +term9: [ (* @Zimmi48: Special token .. is for use in the Notation command. (see bug_3304.v) *) -| DELETE ".." operconstr0 ".." +| DELETE ".." term0 ".." ] -operconstr1: [ -| REPLACE operconstr0 ".(" global LIST0 appl_arg ")" -| WITH operconstr0 ".(" global LIST0 appl_arg ")" (* huh? *) -| REPLACE operconstr0 "%" IDENT -| WITH operconstr0 "%" scope_key -| MOVETO term_scope operconstr0 "%" scope_key -| MOVETO term_projection operconstr0 ".(" global LIST0 appl_arg ")" -| MOVETO term_projection operconstr0 ".(" "@" global LIST0 ( operconstr9 ) ")" +term1: [ +| REPLACE term0 ".(" global LIST0 arg ")" +| WITH term0 ".(" global LIST0 arg ")" (* huh? *) +| REPLACE term0 "%" IDENT +| WITH term0 "%" scope_key +| MOVETO term_scope term0 "%" scope_key +| MOVETO term_projection term0 ".(" global LIST0 arg ")" +| MOVETO term_projection term0 ".(" "@" global LIST0 ( term9 ) ")" ] -operconstr0: [ +term0: [ (* @Zimmi48: This rule is a hack, according to Hugo, and should not be shown in the manual. *) | DELETE "{" binder_constr "}" | REPLACE "{|" record_declaration bar_cbrace | WITH "{|" LIST0 field_def SEP ";" OPT ";" bar_cbrace | MOVETO term_record "{|" LIST0 field_def SEP ";" OPT ";" bar_cbrace -| MOVETO term_generalizing "`{" operconstr200 "}" -| MOVETO term_generalizing "`(" operconstr200 ")" -| MOVETO term_ltac "ltac" ":" "(" tactic_expr5 ")" -| REPLACE "[" "|" array_elems "|" lconstr type_cstr "|" "]" univ_instance -| WITH "[|" array_elems "|" lconstr type_cstr "|]" univ_instance +| MOVETO term_generalizing "`{" term200 "}" +| MOVETO term_generalizing "`(" term200 ")" +| MOVETO term_ltac "ltac" ":" "(" ltac_expr5 ")" +| REPLACE "[" "|" array_elems "|" lconstr type_cstr "|" "]" univ_annot +| WITH "[|" array_elems "|" lconstr type_cstr "|]" univ_annot ] fix_decls: [ @@ -408,9 +407,9 @@ fix_decls: [ ] cofix_decls: [ -| DELETE cofix_decl -| REPLACE cofix_decl "with" LIST1 cofix_decl SEP "with" "for" identref -| WITH cofix_decl OPT ( LIST1 ( "with" cofix_decl ) "for" identref ) +| DELETE cofix_body +| REPLACE cofix_body "with" LIST1 cofix_body SEP "with" "for" identref +| WITH cofix_body OPT ( LIST1 ( "with" cofix_body ) "for" identref ) ] fields_def: [ @@ -481,11 +480,11 @@ name_colon: [ ] typeclass_constraint: [ -| EDIT ADD_OPT "!" operconstr200 -| REPLACE "{" name "}" ":" [ "!" | ] operconstr200 -| WITH "{" name "}" ":" OPT "!" operconstr200 -| REPLACE name ":" [ "!" | ] operconstr200 -| WITH name ":" OPT "!" operconstr200 +| EDIT ADD_OPT "!" term200 +| REPLACE "{" name "}" ":" [ "!" | ] term200 +| WITH "{" name "}" ":" OPT "!" term200 +| REPLACE name ":" [ "!" | ] term200 +| WITH name ":" OPT "!" term200 ] (* ?? From the grammar, Prim.name seems to be only "_" but ident is also accepted "*) @@ -566,14 +565,14 @@ gallina: [ | [ "Record" | "Structure" ] record_definition LIST0 ( "with" record_definition ) | "Class" record_definition | "Class" singleton_class_definition -| REPLACE "Fixpoint" LIST1 rec_definition SEP "with" -| WITH "Fixpoint" rec_definition LIST0 ( "with" rec_definition ) -| REPLACE "Let" "Fixpoint" LIST1 rec_definition SEP "with" -| WITH "Let" "Fixpoint" rec_definition LIST0 ( "with" rec_definition ) -| REPLACE "CoFixpoint" LIST1 corec_definition SEP "with" -| WITH "CoFixpoint" corec_definition LIST0 ( "with" corec_definition ) -| REPLACE "Let" "CoFixpoint" LIST1 corec_definition SEP "with" -| WITH "Let" "CoFixpoint" corec_definition LIST0 ( "with" corec_definition ) +| REPLACE "Fixpoint" LIST1 fix_definition SEP "with" +| WITH "Fixpoint" fix_definition LIST0 ( "with" fix_definition ) +| REPLACE "Let" "Fixpoint" LIST1 fix_definition SEP "with" +| WITH "Let" "Fixpoint" fix_definition LIST0 ( "with" fix_definition ) +| REPLACE "CoFixpoint" LIST1 cofix_definition SEP "with" +| WITH "CoFixpoint" cofix_definition LIST0 ( "with" cofix_definition ) +| REPLACE "Let" "CoFixpoint" LIST1 cofix_definition SEP "with" +| WITH "Let" "CoFixpoint" cofix_definition LIST0 ( "with" cofix_definition ) | REPLACE "Scheme" LIST1 scheme SEP "with" | WITH "Scheme" scheme LIST0 ( "with" scheme ) ] @@ -582,7 +581,7 @@ finite_token: [ | DELETENT ] -constructor_list_or_record_decl: [ +constructors_or_record: [ | OPTINREF ] @@ -604,7 +603,7 @@ inline: [ | OPTINREF ] -univ_instance: [ +univ_annot: [ | OPTINREF ] @@ -613,15 +612,15 @@ univ_decl: [ | WITH "@{" LIST0 identref OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" ] -of_type_with_opt_coercion: [ +of_type: [ | DELETENT ] -of_type_with_opt_coercion: [ +of_type: [ | [ ":" | ":>" ] type ] -attribute_value: [ +attr_value: [ | OPTINREF ] @@ -657,14 +656,6 @@ ltac2_branches: [ | OPTINREF ] -RENAME: [ -| red_flag ltac2_red_flag -| red_flags red_flag -] - -RENAME: [ -] - strategy_flag: [ | REPLACE OPT delta_flag | WITH delta_flag @@ -697,8 +688,8 @@ is_module_type: [ ] gallina_ext: [ -| REPLACE "Arguments" smart_global LIST0 argument_spec_block OPT [ "," LIST1 [ LIST0 more_implicits_block ] SEP "," ] OPT [ ":" LIST1 arguments_modifier SEP "," ] -| WITH "Arguments" smart_global LIST0 argument_spec_block LIST0 [ "," LIST0 more_implicits_block ] OPT [ ":" LIST1 arguments_modifier SEP "," ] +| REPLACE "Arguments" smart_global LIST0 arg_specs OPT [ "," LIST1 [ LIST0 implicits_alt ] SEP "," ] OPT [ ":" LIST1 args_modifier SEP "," ] +| WITH "Arguments" smart_global LIST0 arg_specs LIST0 [ "," LIST0 implicits_alt ] OPT [ ":" LIST1 args_modifier SEP "," ] | REPLACE "Implicit" "Type" reserv_list | WITH "Implicit" [ "Type" | "Types" ] reserv_list | DELETE "Implicit" "Types" reserv_list @@ -727,11 +718,11 @@ gallina_ext: [ | WITH "Generalizable" [ [ "Variable" | "Variables" ] LIST1 identref | "All" "Variables" | "No" "Variables" ] (* don't show Export for Set, Unset *) -| REPLACE "Export" "Set" option_table option_setting -| WITH "Set" option_table option_setting -| REPLACE "Export" "Unset" option_table -| WITH "Unset" option_table -| REPLACE "Instance" instance_name ":" operconstr200 hint_info [ ":=" "{" record_declaration "}" | ":=" lconstr | ] +| REPLACE "Export" "Set" setting_name option_setting +| WITH "Set" setting_name option_setting +| REPLACE "Export" "Unset" setting_name +| WITH "Unset" setting_name +| REPLACE "Instance" instance_name ":" term200 hint_info [ ":=" "{" record_declaration "}" | ":=" lconstr | ] | WITH "Instance" instance_name ":" type hint_info OPT [ ":=" "{" record_declaration "}" | ":=" lconstr ] | REPLACE "From" global "Require" export_token LIST1 global @@ -822,92 +813,92 @@ DELETE: [ | tactic_then_locality ] -tactic_expr5: [ -(* make these look consistent with use of binder_tactic in other tactic_expr* *) +ltac_expr5: [ +(* make these look consistent with use of binder_tactic in other ltac_expr* *) | DELETE binder_tactic -| DELETE tactic_expr4 -| [ tactic_expr4 | binder_tactic ] +| DELETE ltac_expr4 +| [ ltac_expr4 | binder_tactic ] ] ltac_constructs: [ (* repeated in main ltac grammar - need to create a COPY edit *) -| tactic_expr3 ";" [ tactic_expr3 | binder_tactic ] -| tactic_expr3 ";" "[" tactic_then_gen "]" +| ltac_expr3 ";" [ ltac_expr3 | binder_tactic ] +| ltac_expr3 ";" "[" for_each_goal "]" -| tactic_expr1 "+" [ tactic_expr2 | binder_tactic ] -| tactic_expr1 "||" [ tactic_expr2 | binder_tactic ] +| ltac_expr1 "+" [ ltac_expr2 | binder_tactic ] +| ltac_expr1 "||" [ ltac_expr2 | binder_tactic ] -(* | qualid LIST0 tactic_arg add later due renaming tactic_arg *) +(* | qualid LIST0 tactic_value add later due renaming tactic_value *) -| "[>" tactic_then_gen "]" -| toplevel_selector tactic_expr5 +| "[>" for_each_goal "]" +| toplevel_selector ltac_expr5 ] -tactic_expr4: [ -| REPLACE tactic_expr3 ";" tactic_then_gen "]" -| WITH tactic_expr3 ";" "[" tactic_then_gen "]" -| REPLACE tactic_expr3 ";" binder_tactic -| WITH tactic_expr3 ";" [ tactic_expr3 | binder_tactic ] -| DELETE tactic_expr3 ";" tactic_expr3 +ltac_expr4: [ +| REPLACE ltac_expr3 ";" for_each_goal "]" +| WITH ltac_expr3 ";" "[" for_each_goal "]" +| REPLACE ltac_expr3 ";" binder_tactic +| WITH ltac_expr3 ";" [ ltac_expr3 | binder_tactic ] +| DELETE ltac_expr3 ";" ltac_expr3 ] l3_tactic: [ ] -tactic_expr3: [ -| DELETE "abstract" tactic_expr2 -| REPLACE "abstract" tactic_expr2 "using" ident -| WITH "abstract" tactic_expr2 OPT ( "using" ident ) +ltac_expr3: [ +| DELETE "abstract" ltac_expr2 +| REPLACE "abstract" ltac_expr2 "using" ident +| WITH "abstract" ltac_expr2 OPT ( "using" ident ) | l3_tactic | MOVEALLBUT ltac_builtins | l3_tactic -| tactic_expr2 +| ltac_expr2 ] l2_tactic: [ ] -tactic_expr2: [ -| REPLACE tactic_expr1 "+" binder_tactic -| WITH tactic_expr1 "+" [ tactic_expr2 | binder_tactic ] -| DELETE tactic_expr1 "+" tactic_expr2 -| REPLACE tactic_expr1 "||" binder_tactic -| WITH tactic_expr1 "||" [ tactic_expr2 | binder_tactic ] -| DELETE tactic_expr1 "||" tactic_expr2 -| MOVETO ltac_builtins "tryif" tactic_expr5 "then" tactic_expr5 "else" tactic_expr2 +ltac_expr2: [ +| REPLACE ltac_expr1 "+" binder_tactic +| WITH ltac_expr1 "+" [ ltac_expr2 | binder_tactic ] +| DELETE ltac_expr1 "+" ltac_expr2 +| REPLACE ltac_expr1 "||" binder_tactic +| WITH ltac_expr1 "||" [ ltac_expr2 | binder_tactic ] +| DELETE ltac_expr1 "||" ltac_expr2 +| MOVETO ltac_builtins "tryif" ltac_expr5 "then" ltac_expr5 "else" ltac_expr2 | l2_tactic | DELETE ltac_builtins ] l1_tactic: [ ] -tactic_expr1: [ +ltac_expr1: [ | EDIT match_key ADD_OPT "reverse" "goal" "with" match_context_list "end" | MOVETO simple_tactic match_key OPT "reverse" "goal" "with" match_context_list "end" -| MOVETO simple_tactic match_key tactic_expr5 "with" match_list "end" +| MOVETO simple_tactic match_key ltac_expr5 "with" match_list "end" | REPLACE failkw [ int_or_var | ] LIST0 message_token | WITH failkw OPT int_or_var LIST0 message_token -| REPLACE reference LIST0 tactic_arg_compat -| WITH reference LIST1 tactic_arg_compat +| REPLACE reference LIST0 tactic_arg +| WITH reference LIST1 tactic_arg | l1_tactic | DELETE simple_tactic | MOVEALLBUT ltac_builtins | l1_tactic -| tactic_arg -| reference LIST1 tactic_arg_compat -| tactic_expr0 +| tactic_value +| reference LIST1 tactic_arg +| ltac_expr0 ] (* split match_context_rule *) goal_pattern: [ -| LIST0 match_hyps SEP "," "|-" match_pattern -| "[" LIST0 match_hyps SEP "," "|-" match_pattern "]" +| LIST0 match_hyp SEP "," "|-" match_pattern +| "[" LIST0 match_hyp SEP "," "|-" match_pattern "]" | "_" ] match_context_rule: [ -| DELETE LIST0 match_hyps SEP "," "|-" match_pattern "=>" tactic_expr5 -| DELETE "[" LIST0 match_hyps SEP "," "|-" match_pattern "]" "=>" tactic_expr5 -| DELETE "_" "=>" tactic_expr5 -| goal_pattern "=>" tactic_expr5 +| DELETE LIST0 match_hyp SEP "," "|-" match_pattern "=>" ltac_expr5 +| DELETE "[" LIST0 match_hyp SEP "," "|-" match_pattern "]" "=>" ltac_expr5 +| DELETE "_" "=>" ltac_expr5 +| goal_pattern "=>" ltac_expr5 ] match_context_list: [ @@ -920,10 +911,10 @@ match_list: [ match_rule: [ (* redundant; match_pattern -> term -> _ *) -| DELETE "_" "=>" tactic_expr5 +| DELETE "_" "=>" ltac_expr5 ] -selector_body: [ +selector: [ | REPLACE range_selector_or_nth (* depends on whether range_selector_or_nth is deleted first *) | WITH LIST1 range_selector SEP "," ] @@ -1091,7 +1082,7 @@ simple_tactic: [ | EDIT "psatz_Q" ADD_OPT int_or_var tactic | EDIT "psatz_Z" ADD_OPT int_or_var tactic | REPLACE "subst" LIST1 hyp -| WITH "subst" OPT ( LIST1 hyp ) +| WITH "subst" LIST0 hyp | DELETE "subst" | DELETE "congruence" | DELETE "congruence" natural @@ -1102,18 +1093,18 @@ simple_tactic: [ | REPLACE "show" "ltac" "profile" "cutoff" integer | WITH "show" "ltac" "profile" OPT [ "cutoff" integer | string ] | DELETE "show" "ltac" "profile" string -(* perversely, the mlg uses "tactic3" instead of "tactic_expr3" *) +(* perversely, the mlg uses "tactic3" instead of "ltac_expr3" *) | DELETE "transparent_abstract" tactic3 | REPLACE "transparent_abstract" tactic3 "using" ident -| WITH "transparent_abstract" tactic_expr3 OPT ( "using" ident ) -| REPLACE "typeclasses" "eauto" "bfs" OPT int_or_var "with" LIST1 preident -| WITH "typeclasses" "eauto" OPT "bfs" OPT int_or_var OPT ( "with" LIST1 preident ) +| WITH "transparent_abstract" ltac_expr3 OPT ( "using" ident ) +| "typeclasses" "eauto" OPT "bfs" OPT int_or_var OPT ( "with" LIST1 preident ) +| DELETE "typeclasses" "eauto" "bfs" OPT int_or_var "with" LIST1 preident | DELETE "typeclasses" "eauto" OPT int_or_var "with" LIST1 preident | DELETE "typeclasses" "eauto" "bfs" OPT int_or_var | DELETE "typeclasses" "eauto" OPT int_or_var (* in Tactic Notation: *) | "setoid_replace" constr "with" constr OPT ( "using" "relation" constr ) OPT ( "in" hyp ) - OPT ( "at" LIST1 int_or_var ) OPT ( "by" tactic_expr3 ) + OPT ( "at" LIST1 int_or_var ) OPT ( "by" ltac_expr3 ) ] (* todo: don't use DELETENT for this *) @@ -1168,8 +1159,8 @@ command: [ | "SubClass" ident_decl def_body | REPLACE "Ltac" LIST1 ltac_tacdef_body SEP "with" | WITH "Ltac" ltac_tacdef_body LIST0 ( "with" ltac_tacdef_body ) -| REPLACE "Function" LIST1 function_rec_definition_loc SEP "with" (* funind plugin *) -| WITH "Function" function_rec_definition_loc LIST0 ( "with" function_rec_definition_loc ) (* funind plugin *) +| REPLACE "Function" LIST1 function_fix_definition SEP "with" (* funind plugin *) +| WITH "Function" function_fix_definition LIST0 ( "with" function_fix_definition ) (* funind plugin *) | REPLACE "Functional" "Scheme" LIST1 fun_scheme_arg SEP "with" (* funind plugin *) | WITH "Functional" "Scheme" fun_scheme_arg LIST0 ( "with" fun_scheme_arg ) (* funind plugin *) | DELETE "Cd" @@ -1180,16 +1171,16 @@ command: [ | WITH "Back" OPT natural | REPLACE "Load" [ "Verbose" | ] [ ne_string | IDENT ] | WITH "Load" OPT "Verbose" [ ne_string | IDENT ] -| DELETE "Unset" option_table -| REPLACE "Set" option_table option_setting -| WITH OPT "Export" "Set" option_table (* set flag *) -| REPLACE "Test" option_table "for" LIST1 table_value -| WITH "Test" option_table OPT ( "for" LIST1 table_value ) -| DELETE "Test" option_table +| DELETE "Unset" setting_name +| REPLACE "Set" setting_name option_setting +| WITH OPT "Export" "Set" setting_name (* set flag *) +| REPLACE "Test" setting_name "for" LIST1 table_value +| WITH "Test" setting_name OPT ( "for" LIST1 table_value ) +| DELETE "Test" setting_name (* hide the fact that table names are limited to 2 IDENTs *) | REPLACE "Add" IDENT IDENT LIST1 table_value -| WITH "Add" option_table LIST1 table_value +| WITH "Add" setting_name LIST1 table_value | DELETE "Add" IDENT LIST1 table_value | DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "as" ident | DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "as" ident @@ -1247,7 +1238,7 @@ command: [ (* hide the fact that table names are limited to 2 IDENTs *) | REPLACE "Remove" IDENT IDENT LIST1 table_value -| WITH "Remove" option_table LIST1 table_value +| WITH "Remove" setting_name LIST1 table_value | DELETE "Remove" IDENT LIST1 table_value | DELETE "Restore" "State" IDENT | DELETE "Restore" "State" ne_string @@ -1294,10 +1285,10 @@ command: [ | WITH "Declare" "Scope" scope_name (* odd that these are in command while other notation-related ones are in syntax *) -| REPLACE "Numeral" "Notation" reference reference reference ":" ident numnotoption -| WITH "Numeral" "Notation" reference reference reference ":" scope_name numnotoption -| REPLACE "Number" "Notation" reference reference reference ":" ident numnotoption -| WITH "Number" "Notation" reference reference reference ":" scope_name numnotoption +| REPLACE "Numeral" "Notation" reference reference reference ":" ident numeral_modifier +| WITH "Numeral" "Notation" reference reference reference ":" scope_name numeral_modifier +| REPLACE "Number" "Notation" reference reference reference ":" ident numeral_modifier +| WITH "Number" "Notation" reference reference reference ":" scope_name numeral_modifier | REPLACE "String" "Notation" reference reference reference ":" ident | WITH "String" "Notation" reference reference reference ":" scope_name @@ -1357,7 +1348,7 @@ syntax_modifier: [ | WITH LIST1 IDENT SEP "," "at" level ] -syntax_extension_type: [ +explicit_subentry: [ | REPLACE "strict" "pattern" "at" "level" natural | WITH "strict" "pattern" OPT ( "at" "level" natural ) | DELETE "strict" "pattern" @@ -1367,31 +1358,31 @@ syntax_extension_type: [ | DELETE "constr" (* covered by another prod *) ] -numnotoption: [ +numeral_modifier: [ | OPTINREF ] binder_tactic: [ -| REPLACE "let" [ "rec" | ] LIST1 let_clause SEP "with" "in" tactic_expr5 -| WITH "let" OPT "rec" let_clause LIST0 ( "with" let_clause ) "in" tactic_expr5 +| REPLACE "let" [ "rec" | ] LIST1 let_clause SEP "with" "in" ltac_expr5 +| WITH "let" OPT "rec" let_clause LIST0 ( "with" let_clause ) "in" ltac_expr5 | MOVEALLBUT ltac_builtins ] -record_binder_body: [ -| REPLACE binders of_type_with_opt_coercion lconstr -| WITH binders of_type_with_opt_coercion -| REPLACE binders of_type_with_opt_coercion lconstr ":=" lconstr -| WITH binders of_type_with_opt_coercion ":=" lconstr +field_body: [ +| REPLACE binders of_type lconstr +| WITH binders of_type +| REPLACE binders of_type lconstr ":=" lconstr +| WITH binders of_type ":=" lconstr ] -simple_assum_coe: [ -| REPLACE LIST1 ident_decl of_type_with_opt_coercion lconstr -| WITH LIST1 ident_decl of_type_with_opt_coercion +assumpt: [ +| REPLACE LIST1 ident_decl of_type lconstr +| WITH LIST1 ident_decl of_type ] constructor_type: [ -| REPLACE binders [ of_type_with_opt_coercion lconstr | ] -| WITH binders OPT of_type_with_opt_coercion +| REPLACE binders [ of_type lconstr | ] +| WITH binders OPT of_type ] (* todo: is this really correct? Search for "Pvernac.register_proof_mode" *) @@ -1435,12 +1426,12 @@ legacy_attr: [ sentence: [ ] (* productions defined below *) -rec_definition: [ +fix_definition: [ | REPLACE ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notations | WITH ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notations ] -corec_definition: [ +cofix_definition: [ | REPLACE ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notations | WITH ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notations ] @@ -1457,7 +1448,7 @@ inductive_definition: [ ] (* note that constructor -> identref constructor_type *) -constructor_list_or_record_decl: [ +constructors_or_record: [ | DELETE "|" LIST1 constructor SEP "|" | REPLACE identref constructor_type "|" LIST1 constructor SEP "|" | WITH OPT "|" LIST1 constructor SEP "|" @@ -1468,8 +1459,8 @@ constructor_list_or_record_decl: [ ] record_binder: [ -| REPLACE name record_binder_body -| WITH name OPT record_binder_body +| REPLACE name field_body +| WITH name OPT field_body | DELETE name ] @@ -1636,7 +1627,7 @@ ltac2_rewriter: [ | OPT natural OPT [ "?" | "!" ] ltac2_constr_with_bindings ] -tac2expr0: [ +ltac2_expr0: [ | DELETE "(" ")" ] @@ -1813,9 +1804,9 @@ input_fun: [ ] let_clause: [ -| DELETE identref ":=" tactic_expr5 -| REPLACE "_" ":=" tactic_expr5 -| WITH name ":=" tactic_expr5 +| DELETE identref ":=" ltac_expr5 +| REPLACE "_" ":=" ltac_expr5 +| WITH name ":=" ltac_expr5 ] tactic_mode: [ @@ -1837,11 +1828,11 @@ tactic_mode: [ tactic_mode: [ | DELETENT ] -sexpr: [ +ltac2_scope: [ | REPLACE syn_node (* Ltac2 plugin *) | WITH name TAG Ltac2 -| REPLACE syn_node "(" LIST1 sexpr SEP "," ")" (* Ltac2 plugin *) -| WITH name "(" LIST1 sexpr SEP "," ")" TAG Ltac2 +| REPLACE syn_node "(" LIST1 ltac2_scope SEP "," ")" (* Ltac2 plugin *) +| WITH name "(" LIST1 ltac2_scope SEP "," ")" TAG Ltac2 ] syn_node: [ | DELETENT ] @@ -1851,7 +1842,7 @@ RENAME: [ ] toplevel_selector: [ -| selector_body +| selector | "all" | "!" (* par is accepted even though it's not in the .mlg *) @@ -1859,7 +1850,7 @@ toplevel_selector: [ ] toplevel_selector_temp: [ -| DELETE selector_body ":" +| DELETE selector ":" | DELETE "all" ":" | DELETE "!" ":" | toplevel_selector ":" @@ -1900,7 +1891,7 @@ query_command: [ ] (* re-add as a placeholder *) sentence: [ | OPT attributes command "." | OPT attributes OPT ( natural ":" ) query_command "." -| OPT attributes OPT ( toplevel_selector ":" ) tactic_expr5 [ "." | "..." ] +| OPT attributes OPT ( toplevel_selector ":" ) ltac_expr5 [ "." | "..." ] | control_command ] @@ -1924,18 +1915,18 @@ ltac_defined_tactics: [ | "split_Rabs" | "split_Rmult" | "tauto" -| "time_constr" tactic_expr5 +| "time_constr" ltac_expr5 | "zify" ] (* todo: need careful review; assume that "[" ... "]" are literals *) tactic_notation_tactics: [ -| "assert_fails" tactic_expr3 -| "assert_succeeds" tactic_expr3 +| "assert_fails" ltac_expr3 +| "assert_succeeds" ltac_expr3 | "field" OPT ( "[" LIST1 constr "]" ) | "field_simplify" OPT ( "[" LIST1 constr "]" ) LIST1 constr OPT ( "in" ident ) | "field_simplify_eq" OPT ( "[" LIST1 constr "]" ) OPT ( "in" ident ) -| "intuition" OPT tactic_expr5 +| "intuition" OPT ltac_expr5 | "nsatz" OPT ( "with" "radicalmax" ":=" constr "strategy" ":=" constr "parameters" ":=" constr "variables" ":=" constr ) | "psatz" constr OPT int_or_var | "ring" OPT ( "[" LIST1 constr "]" ) @@ -1943,8 +1934,8 @@ tactic_notation_tactics: [ ] (* defined in OCaml outside of mlgs *) -tactic_arg: [ -| "uconstr" ":" "(" operconstr200 ")" +tactic_value: [ +| "uconstr" ":" "(" term200 ")" | MOVEALLBUT simple_tactic ] @@ -1952,10 +1943,6 @@ nonterminal: [ ] value_tactic: [ ] -RENAME: [ -| tactic_arg tactic_value -] - syn_value: [ | IDENT; ":" "(" nonterminal ")" ] @@ -1974,8 +1961,8 @@ ltac2_match_key: [ ] ltac2_constructs: [ -| ltac2_match_key tac2expr6 "with" ltac2_match_list "end" -| ltac2_match_key OPT "reverse" "goal" "with" gmatch_list "end" +| ltac2_match_key ltac2_expr6 "with" ltac2_match_list "end" +| ltac2_match_key OPT "reverse" "goal" "with" goal_match_list "end" ] simple_tactic: [ @@ -1987,9 +1974,9 @@ simple_tactic: [ ] tacdef_body: [ -| REPLACE global LIST1 input_fun ltac_def_kind tactic_expr5 -| WITH global LIST0 input_fun ltac_def_kind tactic_expr5 -| DELETE global ltac_def_kind tactic_expr5 +| REPLACE global LIST1 input_fun ltac_def_kind ltac_expr5 +| WITH global LIST0 input_fun ltac_def_kind ltac_expr5 +| DELETE global ltac_def_kind ltac_expr5 ] tac2def_typ: [ @@ -2071,7 +2058,7 @@ atomic_tac2pat: [ | OPTINREF ] -tac2expr0: [ +ltac2_expr0: [ (* | DELETE "(" ")" (* covered by "()" prodn *) | REPLACE "{" [ | LIST1 tac2rec_fieldexpr OPT ";" ] "}" @@ -2084,13 +2071,13 @@ tac2expr0: [ use LIST1? *) SPLICE: [ -| tac2expr4 +| ltac2_expr4 ] -tac2expr3: [ -| REPLACE tac2expr2 "," LIST1 tac2expr2 SEP "," (* Ltac2 plugin *) -| WITH LIST1 tac2expr2 SEP "," TAG Ltac2 -| DELETE tac2expr2 (* Ltac2 plugin *) +ltac2_expr3: [ +| REPLACE ltac2_expr2 "," LIST1 ltac2_expr2 SEP "," (* Ltac2 plugin *) +| WITH LIST1 ltac2_expr2 SEP "," TAG Ltac2 +| DELETE ltac2_expr2 (* Ltac2 plugin *) ] tac2rec_fieldexprs: [ @@ -2171,7 +2158,7 @@ ltac2_entry: [ | WITH "Ltac2" tac2def_val | REPLACE tac2def_ext (* Ltac2 plugin *) | WITH "Ltac2" tac2def_ext -| "Ltac2" "Notation" [ string | lident ] ":=" tac2expr6 TAG Ltac2 (* variant *) +| "Ltac2" "Notation" [ string | lident ] ":=" ltac2_expr6 TAG Ltac2 (* variant *) | MOVEALLBUT command (* todo: MOVEALLBUT should ignore tag on "but" prodns *) ] @@ -2207,21 +2194,14 @@ SPLICE: [ | anti ] -tac2expr5: [ -| REPLACE "let" OPT "rec" LIST1 ltac2_let_clause SEP "with" "in" tac2expr6 (* Ltac2 plugin *) -| WITH "let" OPT "rec" ltac2_let_clause LIST0 ( "with" ltac2_let_clause ) "in" tac2expr6 TAG Ltac2 -| MOVETO simple_tactic "match" tac2expr5 "with" OPT ltac2_branches "end" (* Ltac2 plugin *) +ltac2_expr5: [ +| REPLACE "let" OPT "rec" LIST1 ltac2_let_clause SEP "with" "in" ltac2_expr6 (* Ltac2 plugin *) +| WITH "let" OPT "rec" ltac2_let_clause LIST0 ( "with" ltac2_let_clause ) "in" ltac2_expr6 TAG Ltac2 +| MOVETO simple_tactic "match" ltac2_expr5 "with" OPT ltac2_branches "end" (* Ltac2 plugin *) | DELETE simple_tactic ] -RENAME: [ -| Prim.string string -| Prim.integer integer -| Prim.qualid qualid -| Prim.natural natural -] - -gmatch_list: [ +goal_match_list: [ | EDIT ADD_OPT "|" LIST1 gmatch_rule SEP "|" (* Ltac2 plugin *) ] @@ -2290,6 +2270,10 @@ subprf: [ | "{" (* should be removed. See https://github.com/coq/coq/issues/12004 *) ] +ltac2_expr: [ +| DELETE _ltac2_expr +] + SPLICE: [ | clause | noedit_mode @@ -2309,10 +2293,10 @@ SPLICE: [ | ltac_selector | Constr.ident | attribute_list -| operconstr99 -| operconstr90 -| operconstr9 -| operconstr8 +| term99 +| term90 +| term9 +| term8 | pattern200 | pattern99 | pattern90 @@ -2363,7 +2347,7 @@ SPLICE: [ | check_module_types | constr_pattern | decl_sep -| function_rec_definition_loc (* loses funind annotation *) +| function_fix_definition (* loses funind annotation *) | glob | glob_constr_with_bindings | id_or_meta @@ -2381,7 +2365,6 @@ SPLICE: [ | decorated_vernac | ext_module_expr | ext_module_type -| pattern_ident | test | binder_constr | atomic_constr @@ -2449,7 +2432,6 @@ SPLICE: [ | intropatterns | instance_name | failkw -| selector | ne_in_or_out_modules | search_queries | locatable @@ -2472,7 +2454,6 @@ SPLICE: [ | refglobals (* Ltac2 *) | syntax_modifiers | array_elems -| ltac2_expr | G_LTAC2_input_fun | ltac2_simple_intropattern_closed | ltac2_with_bindings @@ -2489,81 +2470,33 @@ RENAME: [ | tactic3 ltac_expr3 (* todo: can't figure out how this gets mapped by coqpp *) | tactic1 ltac_expr1 (* todo: can't figure out how this gets mapped by coqpp *) | tactic0 ltac_expr0 (* todo: can't figure out how this gets mapped by coqpp *) -| ltac1_expr ltac_expr -| tactic_expr5 ltac_expr -| tactic_expr4 ltac_expr4 -| tactic_expr3 ltac_expr3 -| tactic_expr2 ltac_expr2 -| tactic_expr1 ltac_expr1 -| tactic_expr0 ltac_expr0 +| ltac_expr5 ltac_expr (* | nonsimple_intropattern intropattern (* ltac2 *) *) -| operconstr200 term (* historical name *) -| operconstr100 term100 -| operconstr10 term10 -| operconstr1 term1 -| operconstr0 term0 +| term200 term | pattern100 pattern -| match_constr term_match (*| impl_ident_tail impl_ident*) | ssexpr50 section_var_expr50 | ssexpr0 section_var_expr0 | section_subset_expr section_var_expr | fun_scheme_arg func_scheme_def -| tactic_then_gen for_each_goal -| ltac2_tactic_then_gen ltac2_for_each_goal -| selector_body selector -| match_hyps match_hyp - | BULLET bullet -| fix_decl fix_body -| cofix_decl cofix_body -(* todo: it's confusing that Constr.constr and constr mean different things *) -| constr one_term -| appl_arg arg -| rec_definition fix_definition -| corec_definition cofix_definition -| univ_instance univ_annot -| simple_assum_coe assumpt -| of_type_with_opt_coercion of_type -| attribute_value attr_value -| constructor_list_or_record_decl constructors_or_record -| record_binder_body field_body -| class_rawexpr class -| smart_global reference +| constr one_term (* many, many, many *) +| class_rawexpr class (* OCaml reserved word *) +| smart_global reference (* many, many *) (* | searchabout_query search_item *) -| option_table setting_name -| argument_spec_block arg_specs -| more_implicits_block implicits_alt -| arguments_modifier args_modifier -| constr_as_binder_kind binder_interp -| syntax_extension_type explicit_subentry -| numnotoption numeral_modifier -| tactic_arg_compat tactic_arg -| lconstr_pattern cpattern -| Pltac.tactic ltac_expr -| sexpr ltac2_scope -| tac2type5 ltac2_type -| tac2type2 ltac2_type2 -| tac2type1 ltac2_type1 -| tac2type0 ltac2_type0 -| typ_param ltac2_typevar -| tac2expr6 ltac2_expr -| tac2expr5 ltac2_expr5 -| tac2expr3 ltac2_expr3 -| tac2expr2 ltac2_expr2 -| tac2expr1 ltac2_expr1 -| tac2expr0 ltac2_expr0 -| gmatch_list goal_match_list +| Pltac.tactic ltac_expr (* many uses in EXTENDs *) +| ltac2_type5 ltac2_type +| ltac2_expr6 ltac2_expr | starredidentref starred_ident_ref ] simple_tactic: [ -(* due to renaming of tactic_arg; Use LIST1 for function application *) +(* due to renaming of tactic_value; Use LIST1 for function application *) | qualid LIST1 tactic_arg ] @@ -2585,7 +2518,7 @@ SPLICE: [ | ltac_defined_tactics | tactic_notation_tactics ] -(* todo: ssrreflect*.rst ref to fix_body is incorrect *) +(* todo: ssrreflect*.rst ref to fix_decl is incorrect *) REACHABLE: [ | command @@ -2624,17 +2557,7 @@ NOTINRSTS: [ | q_constr_matching | q_goal_matching -(* todo: figure these out -(*Warning: editedGrammar: Undefined symbol 'ltac1_expr' *) -| dangling_pattern_extension_rule -| vernac_aux -| subprf -| tactic_mode -| tac2expr_in_env (* no refs *) -| tac2mode (* no refs *) -| ltac_use_default (* from tac2mode *) -| tacticals -*) + ] REACHABLE: [ diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index d3148b5e3a..c764cb6f37 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -17,7 +17,7 @@ constr_pattern: [ | constr ] -lconstr_pattern: [ +cpattern: [ | lconstr ] @@ -58,67 +58,67 @@ universe: [ ] lconstr: [ -| operconstr200 +| term200 ] constr: [ -| operconstr8 -| "@" global univ_instance +| term8 +| "@" global univ_annot ] -operconstr200: [ +term200: [ | binder_constr -| operconstr100 +| term100 ] -operconstr100: [ -| operconstr99 "<:" operconstr200 -| operconstr99 "<<:" operconstr200 -| operconstr99 ":" operconstr200 -| operconstr99 ":>" -| operconstr99 +term100: [ +| term99 "<:" term200 +| term99 "<<:" term200 +| term99 ":" term200 +| term99 ":>" +| term99 ] -operconstr99: [ -| operconstr90 +term99: [ +| term90 ] -operconstr90: [ -| operconstr10 +term90: [ +| term10 ] -operconstr10: [ -| operconstr9 LIST1 appl_arg -| "@" global univ_instance LIST0 operconstr9 +term10: [ +| term9 LIST1 arg +| "@" global univ_annot LIST0 term9 | "@" pattern_ident LIST1 identref -| operconstr9 +| term9 ] -operconstr9: [ -| ".." operconstr0 ".." -| operconstr8 +term9: [ +| ".." term0 ".." +| term8 ] -operconstr8: [ -| operconstr1 +term8: [ +| term1 ] -operconstr1: [ -| operconstr0 ".(" global LIST0 appl_arg ")" -| operconstr0 ".(" "@" global LIST0 ( operconstr9 ) ")" -| operconstr0 "%" IDENT -| operconstr0 +term1: [ +| term0 ".(" global LIST0 arg ")" +| term0 ".(" "@" global LIST0 ( term9 ) ")" +| term0 "%" IDENT +| term0 ] -operconstr0: [ +term0: [ | atomic_constr -| match_constr -| "(" operconstr200 ")" +| term_match +| "(" term200 ")" | "{|" record_declaration bar_cbrace | "{" binder_constr "}" -| "`{" operconstr200 "}" -| test_array_opening "[" "|" array_elems "|" lconstr type_cstr test_array_closing "|" "]" univ_instance -| "`(" operconstr200 ")" +| "`{" term200 "}" +| test_array_opening "[" "|" array_elems "|" lconstr type_cstr test_array_closing "|" "]" univ_annot +| "`(" term200 ")" ] array_elems: [ @@ -140,27 +140,27 @@ field_def: [ ] binder_constr: [ -| "forall" open_binders "," operconstr200 -| "fun" open_binders "=>" operconstr200 -| "let" name binders let_type_cstr ":=" operconstr200 "in" operconstr200 -| "let" "fix" fix_decl "in" operconstr200 -| "let" "cofix" cofix_decl "in" operconstr200 -| "let" [ "(" LIST0 name SEP "," ")" | "()" ] return_type ":=" operconstr200 "in" operconstr200 -| "let" "'" pattern200 ":=" operconstr200 "in" operconstr200 -| "let" "'" pattern200 ":=" operconstr200 case_type "in" operconstr200 -| "let" "'" pattern200 "in" pattern200 ":=" operconstr200 case_type "in" operconstr200 -| "if" operconstr200 return_type "then" operconstr200 "else" operconstr200 +| "forall" open_binders "," term200 +| "fun" open_binders "=>" term200 +| "let" name binders let_type_cstr ":=" term200 "in" term200 +| "let" "fix" fix_decl "in" term200 +| "let" "cofix" cofix_body "in" term200 +| "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" term200 "in" term200 +| "let" "'" pattern200 ":=" term200 "in" term200 +| "let" "'" pattern200 ":=" term200 case_type "in" term200 +| "let" "'" pattern200 "in" pattern200 ":=" term200 case_type "in" term200 +| "if" term200 as_return_type "then" term200 "else" term200 | "fix" fix_decls | "cofix" cofix_decls ] -appl_arg: [ +arg: [ | test_lpar_id_coloneq "(" identref ":=" lconstr ")" -| operconstr9 +| term9 ] atomic_constr: [ -| global univ_instance +| global univ_annot | sort | NUMBER | string @@ -179,7 +179,7 @@ evar_instance: [ | ] -univ_instance: [ +univ_annot: [ | "@{" LIST0 universe_level "}" | ] @@ -198,31 +198,31 @@ fix_decls: [ ] cofix_decls: [ -| cofix_decl -| cofix_decl "with" LIST1 cofix_decl SEP "with" "for" identref +| cofix_body +| cofix_body "with" LIST1 cofix_body SEP "with" "for" identref ] fix_decl: [ -| identref binders_fixannot type_cstr ":=" operconstr200 +| identref binders_fixannot type_cstr ":=" term200 ] -cofix_decl: [ -| identref binders type_cstr ":=" operconstr200 +cofix_body: [ +| identref binders type_cstr ":=" term200 ] -match_constr: [ +term_match: [ | "match" LIST1 case_item SEP "," OPT case_type "with" branches "end" ] case_item: [ -| operconstr100 OPT [ "as" name ] OPT [ "in" pattern200 ] +| term100 OPT [ "as" name ] OPT [ "in" pattern200 ] ] case_type: [ -| "return" operconstr100 +| "return" term100 ] -return_type: [ +as_return_type: [ | OPT [ OPT [ "as" name ] case_type ] ] @@ -253,7 +253,7 @@ pattern200: [ ] pattern100: [ -| pattern99 ":" operconstr200 +| pattern99 ":" term200 | pattern99 ] @@ -335,10 +335,10 @@ closed_binder: [ ] typeclass_constraint: [ -| "!" operconstr200 -| "{" name "}" ":" [ "!" | ] operconstr200 -| test_name_colon name ":" [ "!" | ] operconstr200 -| operconstr200 +| "!" term200 +| "{" name "}" ":" [ "!" | ] term200 +| test_name_colon name ":" [ "!" | ] term200 +| term200 ] type_cstr: [ @@ -506,7 +506,7 @@ command: [ | "Remove" "Hints" LIST1 global opt_hintbases | "Hint" hint opt_hintbases | "Comments" LIST0 comment -| "Declare" "Instance" ident_decl binders ":" operconstr200 hint_info +| "Declare" "Instance" ident_decl binders ":" term200 hint_info | "Declare" "Scope" IDENT | "Pwd" | "Cd" @@ -525,13 +525,13 @@ command: [ | "Print" "Namespace" dirpath | "Inspect" natural | "Add" "ML" "Path" ne_string -| "Set" option_table option_setting -| "Unset" option_table -| "Print" "Table" option_table +| "Set" setting_name option_setting +| "Unset" setting_name +| "Print" "Table" setting_name | "Add" IDENT IDENT LIST1 table_value | "Add" IDENT LIST1 table_value -| "Test" option_table "for" LIST1 table_value -| "Test" option_table +| "Test" setting_name "for" LIST1 table_value +| "Test" setting_name | "Remove" IDENT IDENT LIST1 table_value | "Remove" IDENT LIST1 table_value | "Write" "State" IDENT @@ -569,7 +569,7 @@ command: [ | "Show" "Extraction" (* extraction plugin *) | "Set" "Firstorder" "Solver" tactic | "Print" "Firstorder" "Solver" -| "Function" LIST1 function_rec_definition_loc SEP "with" (* funind plugin *) +| "Function" LIST1 function_fix_definition SEP "with" (* funind plugin *) | "Functional" "Scheme" LIST1 fun_scheme_arg SEP "with" (* funind plugin *) | "Functional" "Case" fun_scheme_arg (* funind plugin *) | "Generate" "graph" "for" reference (* funind plugin *) @@ -686,11 +686,11 @@ command: [ | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" constr OPT field_mods (* ring plugin *) | "Print" "Fields" (* ring plugin *) -| "Number" "Notation" reference reference reference ":" ident numnotoption -| "Numeral" "Notation" reference reference reference ":" ident numnotoption +| "Number" "Notation" reference reference reference ":" ident numeral_modifier +| "Numeral" "Notation" reference reference reference ":" ident numeral_modifier | "String" "Notation" reference reference reference ":" ident | "Ltac2" ltac2_entry (* Ltac2 plugin *) -| "Ltac2" "Eval" ltac2_expr (* Ltac2 plugin *) +| "Ltac2" "Eval" ltac2_expr6 (* Ltac2 plugin *) | "Print" "Ltac2" reference (* Ltac2 plugin *) ] @@ -745,10 +745,10 @@ attribute_list: [ ] attribute: [ -| ident attribute_value +| ident attr_value ] -attribute_value: [ +attr_value: [ | "=" string | "(" attribute_list ")" | @@ -795,10 +795,10 @@ gallina: [ | def_token ident_decl def_body | "Let" ident_decl def_body | finite_token LIST1 inductive_definition SEP "with" -| "Fixpoint" LIST1 rec_definition SEP "with" -| "Let" "Fixpoint" LIST1 rec_definition SEP "with" -| "CoFixpoint" LIST1 corec_definition SEP "with" -| "Let" "CoFixpoint" LIST1 corec_definition SEP "with" +| "Fixpoint" LIST1 fix_definition SEP "with" +| "Let" "Fixpoint" LIST1 fix_definition SEP "with" +| "CoFixpoint" LIST1 cofix_definition SEP "with" +| "Let" "CoFixpoint" LIST1 cofix_definition SEP "with" | "Scheme" LIST1 scheme SEP "with" | "Combined" "Scheme" identref "from" LIST1 identref SEP "," | "Register" global "as" qualid @@ -897,7 +897,7 @@ decl_notations: [ ] opt_constructors_or_fields: [ -| ":=" constructor_list_or_record_decl +| ":=" constructors_or_record | ] @@ -905,7 +905,7 @@ inductive_definition: [ | opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notations ] -constructor_list_or_record_decl: [ +constructors_or_record: [ | "|" LIST1 constructor SEP "|" | identref constructor_type "|" LIST1 constructor SEP "|" | identref constructor_type @@ -919,11 +919,11 @@ opt_coercion: [ | ] -rec_definition: [ +fix_definition: [ | ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notations ] -corec_definition: [ +cofix_definition: [ | ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notations ] @@ -950,39 +950,39 @@ record_fields: [ | ] -record_binder_body: [ -| binders of_type_with_opt_coercion lconstr -| binders of_type_with_opt_coercion lconstr ":=" lconstr +field_body: [ +| binders of_type lconstr +| binders of_type lconstr ":=" lconstr | binders ":=" lconstr ] record_binder: [ | name -| name record_binder_body +| name field_body ] assum_list: [ | LIST1 assum_coe -| simple_assum_coe +| assumpt ] assum_coe: [ -| "(" simple_assum_coe ")" +| "(" assumpt ")" ] -simple_assum_coe: [ -| LIST1 ident_decl of_type_with_opt_coercion lconstr +assumpt: [ +| LIST1 ident_decl of_type lconstr ] constructor_type: [ -| binders [ of_type_with_opt_coercion lconstr | ] +| binders [ of_type lconstr | ] ] constructor: [ | identref constructor_type ] -of_type_with_opt_coercion: [ +of_type: [ | ":>" | ":" ">" | ":" @@ -1011,16 +1011,16 @@ gallina_ext: [ | "Coercion" global ":" class_rawexpr ">->" class_rawexpr | "Coercion" by_notation ":" class_rawexpr ">->" class_rawexpr | "Context" LIST1 binder -| "Instance" instance_name ":" operconstr200 hint_info [ ":=" "{" record_declaration "}" | ":=" lconstr | ] +| "Instance" instance_name ":" term200 hint_info [ ":=" "{" record_declaration "}" | ":=" lconstr | ] | "Existing" "Instance" global hint_info | "Existing" "Instances" LIST1 global OPT [ "|" natural ] | "Existing" "Class" global -| "Arguments" smart_global LIST0 argument_spec_block OPT [ "," LIST1 [ LIST0 more_implicits_block ] SEP "," ] OPT [ ":" LIST1 arguments_modifier SEP "," ] +| "Arguments" smart_global LIST0 arg_specs OPT [ "," LIST1 [ LIST0 implicits_alt ] SEP "," ] OPT [ ":" LIST1 args_modifier SEP "," ] | "Implicit" "Type" reserv_list | "Implicit" "Types" reserv_list | "Generalizable" [ "All" "Variables" | "No" "Variables" | [ "Variable" | "Variables" ] LIST1 identref ] -| "Export" "Set" option_table option_setting -| "Export" "Unset" option_table +| "Export" "Set" setting_name option_setting +| "Export" "Unset" setting_name ] filtered_import: [ @@ -1142,7 +1142,7 @@ ssexpr0: [ | "(" ssexpr35 ")" "*" ] -arguments_modifier: [ +args_modifier: [ | "simpl" "nomatch" | "simpl" "never" | "default" "implicits" @@ -1164,7 +1164,7 @@ argument_spec: [ | OPT "!" name OPT scope_delimiter ] -argument_spec_block: [ +arg_specs: [ | argument_spec | "/" | "&" @@ -1173,7 +1173,7 @@ argument_spec_block: [ | "{" LIST1 argument_spec "}" OPT scope_delimiter ] -more_implicits_block: [ +implicits_alt: [ | name | "[" LIST1 name "]" | "{" LIST1 name "}" @@ -1282,7 +1282,7 @@ table_value: [ | STRING ] -option_table: [ +setting_name: [ | LIST1 IDENT ] @@ -1391,9 +1391,9 @@ syntax_modifier: [ | "only" "parsing" | "format" STRING OPT STRING | IDENT; "," LIST1 IDENT SEP "," "at" level -| IDENT; "at" level OPT constr_as_binder_kind -| IDENT constr_as_binder_kind -| IDENT syntax_extension_type +| IDENT; "at" level OPT binder_interp +| IDENT binder_interp +| IDENT explicit_subentry ] syntax_modifiers: [ @@ -1401,19 +1401,19 @@ syntax_modifiers: [ | ] -syntax_extension_type: [ +explicit_subentry: [ | "ident" | "global" | "bigint" | "binder" | "constr" -| "constr" at_level_opt OPT constr_as_binder_kind +| "constr" at_level_opt OPT binder_interp | "pattern" | "pattern" "at" "level" natural | "strict" "pattern" | "strict" "pattern" "at" "level" natural | "closed" "binder" -| "custom" IDENT at_level_opt OPT constr_as_binder_kind +| "custom" IDENT at_level_opt OPT binder_interp ] at_level_opt: [ @@ -1421,7 +1421,7 @@ at_level_opt: [ | ] -constr_as_binder_kind: [ +binder_interp: [ | "as" "ident" | "as" "pattern" | "as" "strict" "pattern" @@ -1789,8 +1789,8 @@ auto_using': [ | (* funind plugin *) ] -function_rec_definition_loc: [ -| Vernac.rec_definition (* funind plugin *) +function_fix_definition: [ +| Vernac.fix_definition (* funind plugin *) ] fun_scheme_arg: [ @@ -1923,16 +1923,16 @@ eauto_search_strategy: [ ] tactic_then_last: [ -| "|" LIST0 ( OPT tactic_expr5 ) SEP "|" +| "|" LIST0 ( OPT ltac_expr5 ) SEP "|" | ] -tactic_then_gen: [ -| tactic_expr5 "|" tactic_then_gen -| tactic_expr5 ".." tactic_then_last +for_each_goal: [ +| ltac_expr5 "|" for_each_goal +| ltac_expr5 ".." tactic_then_last | ".." tactic_then_last -| tactic_expr5 -| "|" tactic_then_gen +| ltac_expr5 +| "|" for_each_goal | ] @@ -1940,60 +1940,60 @@ tactic_then_locality: [ | "[" OPT ">" ] -tactic_expr5: [ +ltac_expr5: [ | binder_tactic -| tactic_expr4 -] - -tactic_expr4: [ -| tactic_expr3 ";" binder_tactic -| tactic_expr3 ";" tactic_expr3 -| tactic_expr3 ";" tactic_then_locality tactic_then_gen "]" -| tactic_expr3 -] - -tactic_expr3: [ -| "try" tactic_expr3 -| "do" int_or_var tactic_expr3 -| "timeout" int_or_var tactic_expr3 -| "time" OPT string tactic_expr3 -| "repeat" tactic_expr3 -| "progress" tactic_expr3 -| "once" tactic_expr3 -| "exactly_once" tactic_expr3 -| "infoH" tactic_expr3 -| "abstract" tactic_expr2 -| "abstract" tactic_expr2 "using" ident -| selector tactic_expr3 -| tactic_expr2 -] - -tactic_expr2: [ -| tactic_expr1 "+" binder_tactic -| tactic_expr1 "+" tactic_expr2 -| "tryif" tactic_expr5 "then" tactic_expr5 "else" tactic_expr2 -| tactic_expr1 "||" binder_tactic -| tactic_expr1 "||" tactic_expr2 -| tactic_expr1 -] - -tactic_expr1: [ +| ltac_expr4 +] + +ltac_expr4: [ +| ltac_expr3 ";" binder_tactic +| ltac_expr3 ";" ltac_expr3 +| ltac_expr3 ";" tactic_then_locality for_each_goal "]" +| ltac_expr3 +] + +ltac_expr3: [ +| "try" ltac_expr3 +| "do" int_or_var ltac_expr3 +| "timeout" int_or_var ltac_expr3 +| "time" OPT string ltac_expr3 +| "repeat" ltac_expr3 +| "progress" ltac_expr3 +| "once" ltac_expr3 +| "exactly_once" ltac_expr3 +| "infoH" ltac_expr3 +| "abstract" ltac_expr2 +| "abstract" ltac_expr2 "using" ident +| "only" selector ":" ltac_expr3 +| ltac_expr2 +] + +ltac_expr2: [ +| ltac_expr1 "+" binder_tactic +| ltac_expr1 "+" ltac_expr2 +| "tryif" ltac_expr5 "then" ltac_expr5 "else" ltac_expr2 +| ltac_expr1 "||" binder_tactic +| ltac_expr1 "||" ltac_expr2 +| ltac_expr1 +] + +ltac_expr1: [ | match_key "goal" "with" match_context_list "end" | match_key "reverse" "goal" "with" match_context_list "end" -| match_key tactic_expr5 "with" match_list "end" -| "first" "[" LIST0 tactic_expr5 SEP "|" "]" -| "solve" "[" LIST0 tactic_expr5 SEP "|" "]" +| match_key ltac_expr5 "with" match_list "end" +| "first" "[" LIST0 ltac_expr5 SEP "|" "]" +| "solve" "[" LIST0 ltac_expr5 SEP "|" "]" | "idtac" LIST0 message_token | failkw [ int_or_var | ] LIST0 message_token | simple_tactic -| tactic_arg -| reference LIST0 tactic_arg_compat -| tactic_expr0 +| tactic_value +| reference LIST0 tactic_arg +| ltac_expr0 ] -tactic_expr0: [ -| "(" tactic_expr5 ")" -| "[" ">" tactic_then_gen "]" +ltac_expr0: [ +| "(" ltac_expr5 ")" +| "[" ">" for_each_goal "]" | tactic_atom ] @@ -2003,17 +2003,17 @@ failkw: [ ] binder_tactic: [ -| "fun" LIST1 input_fun "=>" tactic_expr5 -| "let" [ "rec" | ] LIST1 let_clause SEP "with" "in" tactic_expr5 +| "fun" LIST1 input_fun "=>" ltac_expr5 +| "let" [ "rec" | ] LIST1 let_clause SEP "with" "in" ltac_expr5 ] -tactic_arg_compat: [ -| tactic_arg +tactic_arg: [ +| tactic_value | Constr.constr | "()" ] -tactic_arg: [ +tactic_value: [ | constr_eval | "fresh" LIST0 fresh_id | "type_term" uconstr @@ -2054,26 +2054,26 @@ input_fun: [ ] let_clause: [ -| identref ":=" tactic_expr5 -| "_" ":=" tactic_expr5 -| identref LIST1 input_fun ":=" tactic_expr5 +| identref ":=" ltac_expr5 +| "_" ":=" ltac_expr5 +| identref LIST1 input_fun ":=" ltac_expr5 ] match_pattern: [ -| "context" OPT Constr.ident "[" Constr.lconstr_pattern "]" -| Constr.lconstr_pattern +| "context" OPT Constr.ident "[" Constr.cpattern "]" +| Constr.cpattern ] -match_hyps: [ +match_hyp: [ | name ":" match_pattern | name ":=" "[" match_pattern "]" ":" match_pattern | name ":=" match_pattern ] match_context_rule: [ -| LIST0 match_hyps SEP "," "|-" match_pattern "=>" tactic_expr5 -| "[" LIST0 match_hyps SEP "," "|-" match_pattern "]" "=>" tactic_expr5 -| "_" "=>" tactic_expr5 +| LIST0 match_hyp SEP "," "|-" match_pattern "=>" ltac_expr5 +| "[" LIST0 match_hyp SEP "," "|-" match_pattern "]" "=>" ltac_expr5 +| "_" "=>" ltac_expr5 ] match_context_list: [ @@ -2082,8 +2082,8 @@ match_context_list: [ ] match_rule: [ -| match_pattern "=>" tactic_expr5 -| "_" "=>" tactic_expr5 +| match_pattern "=>" ltac_expr5 +| "_" "=>" ltac_expr5 ] match_list: [ @@ -2103,12 +2103,12 @@ ltac_def_kind: [ ] tacdef_body: [ -| Constr.global LIST1 input_fun ltac_def_kind tactic_expr5 -| Constr.global ltac_def_kind tactic_expr5 +| Constr.global LIST1 input_fun ltac_def_kind ltac_expr5 +| Constr.global ltac_def_kind ltac_expr5 ] tactic: [ -| tactic_expr5 +| ltac_expr5 ] range_selector: [ @@ -2121,17 +2121,13 @@ range_selector_or_nth: [ | natural OPT [ "," LIST1 range_selector SEP "," ] ] -selector_body: [ +selector: [ | range_selector_or_nth | test_bracket_ident "[" ident "]" ] -selector: [ -| "only" selector_body ":" -] - toplevel_selector: [ -| selector_body ":" +| selector ":" | "!" ":" | "all" ":" ] @@ -2147,8 +2143,8 @@ G_LTAC_hint: [ | "Extern" natural OPT Constr.constr_pattern "=>" Pltac.tactic ] -G_LTAC_operconstr0: [ -| "ltac" ":" "(" Pltac.tactic_expr ")" +G_LTAC_term0: [ +| "ltac" ":" "(" Pltac.ltac_expr ")" ] ltac_selector: [ @@ -2327,7 +2323,7 @@ intropattern: [ ] simple_intropattern: [ -| simple_intropattern_closed LIST0 [ "%" operconstr0 ] +| simple_intropattern_closed LIST0 [ "%" term0 ] ] simple_intropattern_closed: [ @@ -2356,7 +2352,7 @@ with_bindings: [ | ] -red_flags: [ +red_flag: [ | "beta" | "iota" | "match" @@ -2373,7 +2369,7 @@ delta_flag: [ ] strategy_flag: [ -| LIST1 red_flags +| LIST1 red_flag | delta_flag ] @@ -2500,7 +2496,7 @@ as_name: [ ] by_tactic: [ -| "by" tactic_expr3 +| "by" ltac_expr3 | ] @@ -2553,7 +2549,7 @@ field_mods: [ | "(" LIST1 field_mod SEP "," ")" (* ring plugin *) ] -numnotoption: [ +numeral_modifier: [ | | "(" "warning" "after" bignat ")" | "(" "abstract" "after" bignat ")" @@ -2576,50 +2572,50 @@ tac2pat0: [ atomic_tac2pat: [ | (* Ltac2 plugin *) -| tac2pat1 ":" tac2type5 (* Ltac2 plugin *) +| tac2pat1 ":" ltac2_type5 (* Ltac2 plugin *) | tac2pat1 "," LIST0 tac2pat1 SEP "," (* Ltac2 plugin *) | tac2pat1 (* Ltac2 plugin *) ] -tac2expr6: [ -| tac2expr5 ";" tac2expr6 (* Ltac2 plugin *) -| tac2expr5 (* Ltac2 plugin *) +ltac2_expr6: [ +| ltac2_expr5 ";" ltac2_expr6 (* Ltac2 plugin *) +| ltac2_expr5 (* Ltac2 plugin *) ] -tac2expr5: [ -| "fun" LIST1 G_LTAC2_input_fun "=>" tac2expr6 (* Ltac2 plugin *) -| "let" rec_flag LIST1 G_LTAC2_let_clause SEP "with" "in" tac2expr6 (* Ltac2 plugin *) -| "match" tac2expr5 "with" G_LTAC2_branches "end" (* Ltac2 plugin *) -| tac2expr4 (* Ltac2 plugin *) +ltac2_expr5: [ +| "fun" LIST1 G_LTAC2_input_fun "=>" ltac2_expr6 (* Ltac2 plugin *) +| "let" rec_flag LIST1 G_LTAC2_let_clause SEP "with" "in" ltac2_expr6 (* Ltac2 plugin *) +| "match" ltac2_expr5 "with" G_LTAC2_branches "end" (* Ltac2 plugin *) +| ltac2_expr4 (* Ltac2 plugin *) ] -tac2expr4: [ -| tac2expr3 (* Ltac2 plugin *) +ltac2_expr4: [ +| ltac2_expr3 (* Ltac2 plugin *) ] -tac2expr3: [ -| tac2expr2 "," LIST1 tac2expr2 SEP "," (* Ltac2 plugin *) -| tac2expr2 (* Ltac2 plugin *) +ltac2_expr3: [ +| ltac2_expr2 "," LIST1 ltac2_expr2 SEP "," (* Ltac2 plugin *) +| ltac2_expr2 (* Ltac2 plugin *) ] -tac2expr2: [ -| tac2expr1 "::" tac2expr2 (* Ltac2 plugin *) -| tac2expr1 (* Ltac2 plugin *) +ltac2_expr2: [ +| ltac2_expr1 "::" ltac2_expr2 (* Ltac2 plugin *) +| ltac2_expr1 (* Ltac2 plugin *) ] -tac2expr1: [ -| tac2expr0 LIST1 tac2expr0 (* Ltac2 plugin *) -| tac2expr0 ".(" Prim.qualid ")" (* Ltac2 plugin *) -| tac2expr0 ".(" Prim.qualid ")" ":=" tac2expr5 (* Ltac2 plugin *) -| tac2expr0 (* Ltac2 plugin *) +ltac2_expr1: [ +| ltac2_expr0 LIST1 ltac2_expr0 (* Ltac2 plugin *) +| ltac2_expr0 ".(" Prim.qualid ")" (* Ltac2 plugin *) +| ltac2_expr0 ".(" Prim.qualid ")" ":=" ltac2_expr5 (* Ltac2 plugin *) +| ltac2_expr0 (* Ltac2 plugin *) ] -tac2expr0: [ -| "(" tac2expr6 ")" (* Ltac2 plugin *) -| "(" tac2expr6 ":" tac2type5 ")" (* Ltac2 plugin *) +ltac2_expr0: [ +| "(" ltac2_expr6 ")" (* Ltac2 plugin *) +| "(" ltac2_expr6 ":" ltac2_type5 ")" (* Ltac2 plugin *) | "()" (* Ltac2 plugin *) | "(" ")" (* Ltac2 plugin *) -| "[" LIST0 tac2expr5 SEP ";" "]" (* Ltac2 plugin *) +| "[" LIST0 ltac2_expr5 SEP ";" "]" (* Ltac2 plugin *) | "{" tac2rec_fieldexprs "}" (* Ltac2 plugin *) | G_LTAC2_tactic_atom (* Ltac2 plugin *) ] @@ -2631,7 +2627,7 @@ G_LTAC2_branches: [ ] branch: [ -| tac2pat1 "=>" tac2expr6 (* Ltac2 plugin *) +| tac2pat1 "=>" ltac2_expr6 (* Ltac2 plugin *) ] rec_flag: [ @@ -2644,7 +2640,7 @@ mut_flag: [ | (* Ltac2 plugin *) ] -typ_param: [ +ltac2_typevar: [ | "'" Prim.ident (* Ltac2 plugin *) ] @@ -2658,48 +2654,48 @@ G_LTAC2_tactic_atom: [ | "constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) | "open_constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) | "ident" ":" "(" lident ")" (* Ltac2 plugin *) -| "pattern" ":" "(" Constr.lconstr_pattern ")" (* Ltac2 plugin *) +| "pattern" ":" "(" Constr.cpattern ")" (* Ltac2 plugin *) | "reference" ":" "(" globref ")" (* Ltac2 plugin *) | "ltac1" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) | "ltac1val" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) ] ltac1_expr_in_env: [ -| test_ltac1_env LIST0 locident "|-" ltac1_expr (* Ltac2 plugin *) -| ltac1_expr (* Ltac2 plugin *) +| test_ltac1_env LIST0 locident "|-" ltac_expr5 (* Ltac2 plugin *) +| ltac_expr5 (* Ltac2 plugin *) ] tac2expr_in_env: [ -| test_ltac1_env LIST0 locident "|-" tac2expr6 (* Ltac2 plugin *) -| tac2expr6 (* Ltac2 plugin *) +| test_ltac1_env LIST0 locident "|-" ltac2_expr6 (* Ltac2 plugin *) +| ltac2_expr6 (* Ltac2 plugin *) ] G_LTAC2_let_clause: [ -| let_binder ":=" tac2expr6 (* Ltac2 plugin *) +| let_binder ":=" ltac2_expr6 (* Ltac2 plugin *) ] let_binder: [ | LIST1 G_LTAC2_input_fun (* Ltac2 plugin *) ] -tac2type5: [ -| tac2type2 "->" tac2type5 (* Ltac2 plugin *) -| tac2type2 (* Ltac2 plugin *) +ltac2_type5: [ +| ltac2_type2 "->" ltac2_type5 (* Ltac2 plugin *) +| ltac2_type2 (* Ltac2 plugin *) ] -tac2type2: [ -| tac2type1 "*" LIST1 tac2type1 SEP "*" (* Ltac2 plugin *) -| tac2type1 (* Ltac2 plugin *) +ltac2_type2: [ +| ltac2_type1 "*" LIST1 ltac2_type1 SEP "*" (* Ltac2 plugin *) +| ltac2_type1 (* Ltac2 plugin *) ] -tac2type1: [ -| tac2type0 Prim.qualid (* Ltac2 plugin *) -| tac2type0 (* Ltac2 plugin *) +ltac2_type1: [ +| ltac2_type0 Prim.qualid (* Ltac2 plugin *) +| ltac2_type0 (* Ltac2 plugin *) ] -tac2type0: [ -| "(" LIST1 tac2type5 SEP "," ")" OPT Prim.qualid (* Ltac2 plugin *) -| typ_param (* Ltac2 plugin *) +ltac2_type0: [ +| "(" LIST1 ltac2_type5 SEP "," ")" OPT Prim.qualid (* Ltac2 plugin *) +| ltac2_typevar (* Ltac2 plugin *) | "_" (* Ltac2 plugin *) | Prim.qualid (* Ltac2 plugin *) ] @@ -2718,7 +2714,7 @@ G_LTAC2_input_fun: [ ] tac2def_body: [ -| G_LTAC2_binder LIST0 G_LTAC2_input_fun ":=" tac2expr6 (* Ltac2 plugin *) +| G_LTAC2_binder LIST0 G_LTAC2_input_fun ":=" ltac2_expr6 (* Ltac2 plugin *) ] tac2def_val: [ @@ -2726,11 +2722,11 @@ tac2def_val: [ ] tac2def_mut: [ -| "Set" Prim.qualid OPT [ "as" locident ] ":=" tac2expr6 (* Ltac2 plugin *) +| "Set" Prim.qualid OPT [ "as" locident ] ":=" ltac2_expr6 (* Ltac2 plugin *) ] tac2typ_knd: [ -| tac2type5 (* Ltac2 plugin *) +| ltac2_type5 (* Ltac2 plugin *) | "[" ".." "]" (* Ltac2 plugin *) | "[" tac2alg_constructors "]" (* Ltac2 plugin *) | "{" tac2rec_fields "}" (* Ltac2 plugin *) @@ -2743,7 +2739,7 @@ tac2alg_constructors: [ tac2alg_constructor: [ | Prim.ident (* Ltac2 plugin *) -| Prim.ident "(" LIST0 tac2type5 SEP "," ")" (* Ltac2 plugin *) +| Prim.ident "(" LIST0 ltac2_type5 SEP "," ")" (* Ltac2 plugin *) ] tac2rec_fields: [ @@ -2754,7 +2750,7 @@ tac2rec_fields: [ ] tac2rec_field: [ -| mut_flag Prim.ident ":" tac2type5 (* Ltac2 plugin *) +| mut_flag Prim.ident ":" ltac2_type5 (* Ltac2 plugin *) ] tac2rec_fieldexprs: [ @@ -2765,13 +2761,13 @@ tac2rec_fieldexprs: [ ] tac2rec_fieldexpr: [ -| Prim.qualid ":=" tac2expr1 (* Ltac2 plugin *) +| Prim.qualid ":=" ltac2_expr1 (* Ltac2 plugin *) ] tac2typ_prm: [ | (* Ltac2 plugin *) -| typ_param (* Ltac2 plugin *) -| "(" LIST1 typ_param SEP "," ")" (* Ltac2 plugin *) +| ltac2_typevar (* Ltac2 plugin *) +| "(" LIST1 ltac2_typevar SEP "," ")" (* Ltac2 plugin *) ] tac2typ_def: [ @@ -2789,7 +2785,7 @@ tac2def_typ: [ ] tac2def_ext: [ -| "@" "external" locident ":" tac2type5 ":=" Prim.string Prim.string (* Ltac2 plugin *) +| "@" "external" locident ":" ltac2_type5 ":=" Prim.string Prim.string (* Ltac2 plugin *) ] syn_node: [ @@ -2797,11 +2793,11 @@ syn_node: [ | Prim.ident (* Ltac2 plugin *) ] -sexpr: [ +ltac2_scope: [ | Prim.string (* Ltac2 plugin *) | Prim.integer (* Ltac2 plugin *) | syn_node (* Ltac2 plugin *) -| syn_node "(" LIST1 sexpr SEP "," ")" (* Ltac2 plugin *) +| syn_node "(" LIST1 ltac2_scope SEP "," ")" (* Ltac2 plugin *) ] syn_level: [ @@ -2810,7 +2806,7 @@ syn_level: [ ] tac2def_syn: [ -| "Notation" LIST1 sexpr syn_level ":=" tac2expr6 (* Ltac2 plugin *) +| "Notation" LIST1 ltac2_scope syn_level ":=" ltac2_expr6 (* Ltac2 plugin *) ] lident: [ @@ -3028,28 +3024,28 @@ q_rewriting: [ ] G_LTAC2_tactic_then_last: [ -| "|" LIST0 ( OPT tac2expr6 ) SEP "|" (* Ltac2 plugin *) +| "|" LIST0 ( OPT ltac2_expr6 ) SEP "|" (* Ltac2 plugin *) | (* Ltac2 plugin *) ] -G_LTAC2_tactic_then_gen: [ -| tac2expr6 "|" G_LTAC2_tactic_then_gen (* Ltac2 plugin *) -| tac2expr6 ".." G_LTAC2_tactic_then_last (* Ltac2 plugin *) +G_LTAC2_for_each_goal: [ +| ltac2_expr6 "|" G_LTAC2_for_each_goal (* Ltac2 plugin *) +| ltac2_expr6 ".." G_LTAC2_tactic_then_last (* Ltac2 plugin *) | ".." G_LTAC2_tactic_then_last (* Ltac2 plugin *) -| tac2expr6 (* Ltac2 plugin *) -| "|" G_LTAC2_tactic_then_gen (* Ltac2 plugin *) +| ltac2_expr6 (* Ltac2 plugin *) +| "|" G_LTAC2_for_each_goal (* Ltac2 plugin *) | (* Ltac2 plugin *) ] q_dispatch: [ -| G_LTAC2_tactic_then_gen (* Ltac2 plugin *) +| G_LTAC2_for_each_goal (* Ltac2 plugin *) ] q_occurrences: [ | G_LTAC2_occs (* Ltac2 plugin *) ] -red_flag: [ +ltac2_red_flag: [ | "beta" (* Ltac2 plugin *) | "iota" (* Ltac2 plugin *) | "match" (* Ltac2 plugin *) @@ -3080,7 +3076,7 @@ G_LTAC2_delta_flag: [ ] G_LTAC2_strategy_flag: [ -| LIST1 red_flag (* Ltac2 plugin *) +| LIST1 ltac2_red_flag (* Ltac2 plugin *) | G_LTAC2_delta_flag (* Ltac2 plugin *) ] @@ -3098,12 +3094,12 @@ q_hintdb: [ ] G_LTAC2_match_pattern: [ -| "context" OPT Prim.ident "[" Constr.lconstr_pattern "]" (* Ltac2 plugin *) -| Constr.lconstr_pattern (* Ltac2 plugin *) +| "context" OPT Prim.ident "[" Constr.cpattern "]" (* Ltac2 plugin *) +| Constr.cpattern (* Ltac2 plugin *) ] G_LTAC2_match_rule: [ -| G_LTAC2_match_pattern "=>" tac2expr6 (* Ltac2 plugin *) +| G_LTAC2_match_pattern "=>" ltac2_expr6 (* Ltac2 plugin *) ] G_LTAC2_match_list: [ @@ -3124,16 +3120,16 @@ gmatch_pattern: [ ] gmatch_rule: [ -| gmatch_pattern "=>" tac2expr6 (* Ltac2 plugin *) +| gmatch_pattern "=>" ltac2_expr6 (* Ltac2 plugin *) ] -gmatch_list: [ +goal_match_list: [ | LIST1 gmatch_rule SEP "|" (* Ltac2 plugin *) | "|" LIST1 gmatch_rule SEP "|" (* Ltac2 plugin *) ] q_goal_matching: [ -| gmatch_list (* Ltac2 plugin *) +| goal_match_list (* Ltac2 plugin *) ] move_location: [ @@ -3167,7 +3163,7 @@ G_LTAC2_as_ipat: [ ] G_LTAC2_by_tactic: [ -| "by" tac2expr6 (* Ltac2 plugin *) +| "by" ltac2_expr6 (* Ltac2 plugin *) | (* Ltac2 plugin *) ] @@ -3190,11 +3186,11 @@ ltac2_entry: [ ] ltac2_expr: [ -| tac2expr6 (* Ltac2 plugin *) +| _ltac2_expr (* Ltac2 plugin *) ] tac2mode: [ -| ltac2_expr ltac_use_default (* Ltac2 plugin *) +| ltac2_expr6 ltac_use_default (* Ltac2 plugin *) | G_vernac.query_command (* Ltac2 plugin *) ] diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index ff1efa5375..12a7bc684d 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -320,11 +320,11 @@ univ_constraint: [ ] term_fix: [ -| "let" "fix" fix_body "in" term -| "fix" fix_body OPT ( LIST1 ( "with" fix_body ) "for" ident ) +| "let" "fix" fix_decl "in" term +| "fix" fix_decl OPT ( LIST1 ( "with" fix_decl ) "for" ident ) ] -fix_body: [ +fix_decl: [ | ident LIST0 binder OPT fixannot OPT ( ":" type ) ":=" term ] @@ -885,6 +885,7 @@ command: [ | "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* ring plugin *) | "Print" "Fields" (* ring plugin *) | "Number" "Notation" qualid qualid qualid ":" scope_name OPT numeral_modifier +| "Numeral" "Notation" qualid qualid qualid ":" scope_name OPT numeral_modifier | "Hint" "Cut" "[" hints_path "]" OPT ( ":" LIST1 ident ) | "Typeclasses" "Transparent" LIST1 qualid | "Typeclasses" "Opaque" LIST1 qualid @@ -909,7 +910,6 @@ command: [ | "Derive" "Dependent" "Inversion_clear" ident "with" one_term "Sort" sort_family | "Declare" "Left" "Step" one_term | "Declare" "Right" "Step" one_term -| "Numeral" "Notation" qualid qualid qualid ":" scope_name OPT numeral_modifier | "String" "Notation" qualid qualid qualid ":" scope_name | "SubClass" ident_decl def_body | thm_token ident_decl LIST0 binder ":" type LIST0 [ "with" ident_decl LIST0 binder ":" type ] @@ -1435,7 +1435,7 @@ simple_tactic: [ | "notypeclasses" "refine" one_term | "simple" "notypeclasses" "refine" one_term | "solve_constraints" -| "subst" OPT ( LIST1 ident ) +| "subst" LIST0 ident | "simple" "subst" | "evar" "(" ident ":" term ")" | "evar" one_term diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 5136e153ca..bb2873b486 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -127,9 +127,9 @@ let isRef sigma c = match kind sigma c with let isRefX sigma x c = let open GlobRef in match x, kind sigma c with - | ConstRef c, Const (c', _) -> Constant.equal c c' - | IndRef i, Ind (i', _) -> eq_ind i i' - | ConstructRef i, Construct (i', _) -> eq_constructor i i' + | ConstRef c, Const (c', _) -> Constant.CanOrd.equal c c' + | IndRef i, Ind (i', _) -> Ind.CanOrd.equal i i' + | ConstructRef i, Construct (i', _) -> Construct.CanOrd.equal i i' | VarRef id, Var id' -> Id.equal id id' | _ -> false @@ -514,7 +514,7 @@ let compare_head_gen_proj env sigma equ eqs eqc' nargs m n = | Proj (p, c), App (f, args) | App (f, args), Proj (p, c) -> (match kind f with - | Const (p', u) when Constant.equal (Projection.constant p) p' -> + | Const (p', u) when Environ.QConstant.equal env (Projection.constant p) p' -> let npars = Projection.npars p in if Array.length args == npars + 1 then eqc' 0 c args.(npars) diff --git a/engine/termops.ml b/engine/termops.ml index 467b269e37..693945d5ac 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -1145,9 +1145,9 @@ let compare_constr_univ sigma f cv_pb t1 t2 = Sort s1, Sort s2 -> base_sort_cmp cv_pb (ESorts.kind sigma s1) (ESorts.kind sigma s2) | Prod (_,t1,c1), Prod (_,t2,c2) -> f Reduction.CONV t1 t2 && f cv_pb c1 c2 - | Const (c, u), Const (c', u') -> Constant.equal c c' - | Ind (i, _), Ind (i', _) -> eq_ind i i' - | Construct (i, _), Construct (i', _) -> eq_constructor i i' + | Const (c, u), Const (c', u') -> Constant.CanOrd.equal c c' + | Ind (i, _), Ind (i', _) -> Ind.CanOrd.equal i i' + | Construct (i, _), Construct (i', _) -> Construct.CanOrd.equal i i' | _ -> EConstr.compare_constr sigma (fun t1 t2 -> f Reduction.CONV t1 t2) t1 t2 let constr_cmp sigma cv_pb t1 t2 = diff --git a/ide/coqide/idetop.ml b/ide/coqide/idetop.ml index 297dc3a706..ddfa3a80bd 100644 --- a/ide/coqide/idetop.ml +++ b/ide/coqide/idetop.ml @@ -317,7 +317,7 @@ let pattern_of_string ?env s = | None -> Global.env () | Some e -> e in - let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in + let constr = Pcoq.parse_string Pcoq.Constr.cpattern s in let (_, pat) = Constrintern.intern_constr_pattern env (Evd.from_env env) constr in pat diff --git a/interp/notation.ml b/interp/notation.ml index d57c4f3abf..269e20c16e 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -323,7 +323,7 @@ type key = | Oth let key_compare k1 k2 = match k1, k2 with -| RefKey gr1, RefKey gr2 -> GlobRef.Ordered.compare gr1 gr2 +| RefKey gr1, RefKey gr2 -> GlobRef.CanOrd.compare gr1 gr2 | RefKey _, Oth -> -1 | Oth, RefKey _ -> 1 | Oth, Oth -> 0 diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 354809252e..fe874cd01d 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -58,7 +58,7 @@ match t1, t2 with (eq_notation_constr vars) t1 t2 in let eqf (t1, (na1, o1)) (t2, (na2, o2)) = - let eq (i1, n1) (i2, n2) = eq_ind i1 i2 && List.equal Name.equal n1 n2 in + let eq (i1, n1) (i2, n2) = Ind.CanOrd.equal i1 i2 && List.equal Name.equal n1 n2 in (eq_notation_constr vars) t1 t2 && Name.equal na1 na2 && Option.equal eq o1 o2 in Option.equal (eq_notation_constr vars) o1 o2 && @@ -801,7 +801,7 @@ let rec fold_cases_pattern_eq f x p p' = let loc = p.CAst.loc in match DAst.get p, DAst.get p' with | PatVar na, PatVar na' -> let x,na = f x na na' in x, DAst.make ?loc @@ PatVar na - | PatCstr (c,l,na), PatCstr (c',l',na') when eq_constructor c c' -> + | PatCstr (c,l,na), PatCstr (c',l',na') when Construct.CanOrd.equal c c' -> let x,l = fold_cases_pattern_list_eq f x l l' in let x,na = f x na na' in x, DAst.make ?loc @@ PatCstr (c,l,na) @@ -818,7 +818,7 @@ and fold_cases_pattern_list_eq f x pl pl' = match pl, pl' with let rec cases_pattern_eq p1 p2 = match DAst.get p1, DAst.get p2 with | PatVar na1, PatVar na2 -> Name.equal na1 na2 | PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> - eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && + Construct.CanOrd.equal c1 c2 && List.equal cases_pattern_eq pl1 pl2 && Name.equal na1 na2 | _ -> false @@ -1041,7 +1041,7 @@ let rec match_cases_pattern_binders allow_catchall metas (alp,sigma as acc) pat1 | PatVar na1, PatVar na2 -> match_names metas acc na1 na2 | _, PatVar Anonymous when allow_catchall -> acc | PatCstr (c1,patl1,na1), PatCstr (c2,patl2,na2) - when eq_constructor c1 c2 && Int.equal (List.length patl1) (List.length patl2) -> + when Construct.CanOrd.equal c1 c2 && Int.equal (List.length patl1) (List.length patl2) -> List.fold_left2 (match_cases_pattern_binders false metas) (match_names metas acc na1 na2) patl1 patl2 | _ -> raise No_match @@ -1391,11 +1391,11 @@ let rec match_cases_pattern metas (terms,termlists,(),() as sigma) a1 a2 = match DAst.get a1, a2 with | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(false,0,[]) | PatVar Anonymous, NHole _ -> sigma,(false,0,[]) - | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (GlobRef.ConstructRef r2) when eq_constructor r1 r2 -> + | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (GlobRef.ConstructRef r2) when Construct.CanOrd.equal r1 r2 -> let l = try add_patterns_for_params_remove_local_defs (Global.env ()) r1 largs with Not_found -> raise No_match in sigma,(false,0,l) | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (GlobRef.ConstructRef r2),l2) - when eq_constructor r1 r2 -> + when Construct.CanOrd.equal r1 r2 -> let l1 = try add_patterns_for_params_remove_local_defs (Global.env()) r1 args1 with Not_found -> raise No_match in let le2 = List.length l2 in if le2 > List.length l1 @@ -1418,10 +1418,10 @@ and match_cases_pattern_no_more_args metas sigma a1 a2 = let match_ind_pattern metas sigma ind pats a2 = match a2 with - | NRef (GlobRef.IndRef r2) when eq_ind ind r2 -> + | NRef (GlobRef.IndRef r2) when Ind.CanOrd.equal ind r2 -> sigma,(false,0,pats) | NApp (NRef (GlobRef.IndRef r2),l2) - when eq_ind ind r2 -> + when Ind.CanOrd.equal ind r2 -> let le2 = List.length l2 in if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length pats then diff --git a/interp/reserve.ml b/interp/reserve.ml index 4418a32645..1d5af3ff39 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -28,7 +28,7 @@ type key = (** TODO: share code from Notation *) let key_compare k1 k2 = match k1, k2 with -| RefKey gr1, RefKey gr2 -> GlobRef.Ordered.compare gr1 gr2 +| RefKey gr1, RefKey gr2 -> GlobRef.CanOrd.compare gr1 gr2 | RefKey _, Oth -> -1 | Oth, RefKey _ -> 1 | Oth, Oth -> 0 diff --git a/kernel/constr.ml b/kernel/constr.ml index 1837a39764..3157ec9f57 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -353,9 +353,9 @@ let isRef c = match kind c with let isRefX x c = let open GlobRef in match x, kind c with - | ConstRef c, Const (c', _) -> Constant.equal c c' - | IndRef i, Ind (i', _) -> eq_ind i i' - | ConstructRef i, Construct (i', _) -> eq_constructor i i' + | ConstRef c, Const (c', _) -> Constant.CanOrd.equal c c' + | IndRef i, Ind (i', _) -> Ind.CanOrd.equal i i' + | ConstructRef i, Construct (i', _) -> Construct.CanOrd.equal i i' | VarRef id, Var id' -> Id.equal id id' | _ -> false @@ -950,14 +950,14 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t let len = Array.length l1 in Int.equal len (Array.length l2) && leq (nargs+len) c1 c2 && Array.equal_norefl (eq 0) l1 l2 - | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq 0 c1 c2 + | Proj (p1,c1), Proj (p2,c2) -> Projection.CanOrd.equal p1 p2 && eq 0 c1 c2 | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && List.equal (eq 0) l1 l2 | Const (c1,u1), Const (c2,u2) -> (* The args length currently isn't used but may as well pass it. *) - Constant.equal c1 c2 && leq_universes (Some (GlobRef.ConstRef c1, nargs)) u1 u2 - | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && leq_universes (Some (GlobRef.IndRef c1, nargs)) u1 u2 + Constant.CanOrd.equal c1 c2 && leq_universes (Some (GlobRef.ConstRef c1, nargs)) u1 u2 + | Ind (c1,u1), Ind (c2,u2) -> Ind.CanOrd.equal c1 c2 && leq_universes (Some (GlobRef.IndRef c1, nargs)) u1 u2 | Construct (c1,u1), Construct (c2,u2) -> - eq_constructor c1 c2 && leq_universes (Some (GlobRef.ConstructRef c1, nargs)) u1 u2 + Construct.CanOrd.equal c1 c2 && leq_universes (Some (GlobRef.ConstructRef c1, nargs)) u1 u2 | Case (_,p1,iv1,c1,bl1), Case (_,p2,iv2,c2,bl2) -> eq 0 p1 p2 && eq_invert (eq 0) (leq_universes None) iv1 iv2 && eq 0 c1 c2 && Array.equal (eq 0) bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> @@ -1139,9 +1139,9 @@ let constr_ord_int f t1 t2 = | App _, _ -> -1 | _, App _ -> 1 | Const (c1,_u1), Const (c2,_u2) -> Constant.CanOrd.compare c1 c2 | Const _, _ -> -1 | _, Const _ -> 1 - | Ind (ind1, _u1), Ind (ind2, _u2) -> ind_ord ind1 ind2 + | Ind (ind1, _u1), Ind (ind2, _u2) -> Ind.CanOrd.compare ind1 ind2 | Ind _, _ -> -1 | _, Ind _ -> 1 - | Construct (ct1,_u1), Construct (ct2,_u2) -> constructor_ord ct1 ct2 + | Construct (ct1,_u1), Construct (ct2,_u2) -> Construct.CanOrd.compare ct1 ct2 | Construct _, _ -> -1 | _, Construct _ -> 1 | Case (_,p1,iv1,c1,bl1), Case (_,p2,iv2,c2,bl2) -> let c = f p1 p2 in @@ -1158,7 +1158,7 @@ let constr_ord_int f t1 t2 = ((Int.compare =? (Array.compare f)) ==? (Array.compare f)) ln1 ln2 tl1 tl2 bl1 bl2 | CoFix _, _ -> -1 | _, CoFix _ -> 1 - | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2 + | Proj (p1,c1), Proj (p2,c2) -> (Projection.CanOrd.compare =? f) p1 p2 c1 c2 | Proj _, _ -> -1 | _, Proj _ -> 1 | Int i1, Int i2 -> Uint63.compare i1 i2 | Int _, _ -> -1 | _, Int _ -> 1 @@ -1331,11 +1331,11 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = | Ind (ind,u) -> let u', hu = sh_instance u in (Ind (sh_ind ind, u'), - combinesmall 10 (combine (ind_syntactic_hash ind) hu)) + combinesmall 10 (combine (Ind.SyntacticOrd.hash ind) hu)) | Construct (c,u) -> let u', hu = sh_instance u in (Construct (sh_construct c, u'), - combinesmall 11 (combine (constructor_syntactic_hash c) hu)) + combinesmall 11 (combine (Construct.SyntacticOrd.hash c) hu)) | Case (ci,p,iv,c,bl) -> let p, hp = sh_rec p and iv, hiv = sh_invert iv @@ -1442,11 +1442,11 @@ let rec hash t = | Evar (e,l) -> combinesmall 8 (combine (Evar.hash e) (hash_term_list l)) | Const (c,u) -> - combinesmall 9 (combine (Constant.hash c) (Instance.hash u)) + combinesmall 9 (combine (Constant.CanOrd.hash c) (Instance.hash u)) | Ind (ind,u) -> - combinesmall 10 (combine (ind_hash ind) (Instance.hash u)) + combinesmall 10 (combine (Ind.CanOrd.hash ind) (Instance.hash u)) | Construct (c,u) -> - combinesmall 11 (combine (constructor_hash c) (Instance.hash u)) + combinesmall 11 (combine (Construct.CanOrd.hash c) (Instance.hash u)) | Case (_ , p, iv, c, bl) -> combinesmall 12 (combine4 (hash c) (hash p) (hash_invert iv) (hash_term_array bl)) | Fix (_ln ,(_, tl, bl)) -> @@ -1456,7 +1456,7 @@ let rec hash t = | Meta n -> combinesmall 15 n | Rel n -> combinesmall 16 n | Proj (p,c) -> - combinesmall 17 (combine (Projection.hash p) (hash c)) + combinesmall 17 (combine (Projection.CanOrd.hash p) (hash c)) | Int i -> combinesmall 18 (Uint63.hash i) | Float f -> combinesmall 19 (Float64.hash f) | Array(u,t,def,ty) -> @@ -1503,7 +1503,7 @@ struct let h3 = Array.fold_left hash_bool_list 0 info.cstr_tags in combine3 h1 h2 h3 let hash ci = - let h1 = ind_hash ci.ci_ind in + let h1 = Ind.CanOrd.hash ci.ci_ind in let h2 = Int.hash ci.ci_npar in let h3 = Array.fold_left combine 0 ci.ci_cstr_ndecls in let h4 = Array.fold_left combine 0 ci.ci_cstr_nargs in diff --git a/kernel/cooking.ml b/kernel/cooking.ml index fdcf44c943..3707a75157 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -38,14 +38,14 @@ struct type t = my_global_reference let equal gr1 gr2 = match gr1, gr2 with | ConstRef c1, ConstRef c2 -> Constant.SyntacticOrd.equal c1 c2 - | IndRef i1, IndRef i2 -> eq_syntactic_ind i1 i2 - | ConstructRef c1, ConstructRef c2 -> eq_syntactic_constructor c1 c2 + | IndRef i1, IndRef i2 -> Ind.SyntacticOrd.equal i1 i2 + | ConstructRef c1, ConstructRef c2 -> Construct.SyntacticOrd.equal c1 c2 | _ -> false open Hashset.Combine let hash = function | ConstRef c -> combinesmall 1 (Constant.SyntacticOrd.hash c) - | IndRef i -> combinesmall 2 (ind_syntactic_hash i) - | ConstructRef c -> combinesmall 3 (constructor_syntactic_hash c) + | IndRef i -> combinesmall 2 (Ind.SyntacticOrd.hash i) + | ConstructRef c -> combinesmall 3 (Construct.SyntacticOrd.hash c) end module RefTable = Hashtbl.Make(RefHash) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index b9f434f179..8de7123fee 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -157,15 +157,15 @@ let hcons_const_body cb = (** {6 Inductive types } *) let eq_nested_type t1 t2 = match t1, t2 with -| NestedInd ind1, NestedInd ind2 -> Names.eq_ind ind1 ind2 +| NestedInd ind1, NestedInd ind2 -> Names.Ind.CanOrd.equal ind1 ind2 | NestedInd _, _ -> false -| NestedPrimitive c1, NestedPrimitive c2 -> Names.Constant.equal c1 c2 +| NestedPrimitive c1, NestedPrimitive c2 -> Names.Constant.CanOrd.equal c1 c2 | NestedPrimitive _, _ -> false let eq_recarg r1 r2 = match r1, r2 with | Norec, Norec -> true | Norec, _ -> false -| Mrec i1, Mrec i2 -> Names.eq_ind i1 i2 +| Mrec i1, Mrec i2 -> Names.Ind.CanOrd.equal i1 i2 | Mrec _, _ -> false | Nested ty1, Nested ty2 -> eq_nested_type ty1 ty2 | Nested _, _ -> false diff --git a/kernel/environ.ml b/kernel/environ.ml index dec9e1deb8..17c5a02e2b 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -832,3 +832,66 @@ let set_retroknowledge env r = { env with retroknowledge = r } let set_native_symbols env native_symbols = { env with native_symbols } let add_native_symbols dir syms env = { env with native_symbols = DPmap.add dir syms env.native_symbols } + +module type QNameS = +sig + type t + val equal : env -> t -> t -> bool + val compare : env -> t -> t -> int + val hash : env -> t -> int +end + +module QConstant = +struct + type t = Constant.t + let equal _env c1 c2 = Constant.CanOrd.equal c1 c2 + let compare _env c1 c2 = Constant.CanOrd.compare c1 c2 + let hash _env c = Constant.CanOrd.hash c +end + +module QMutInd = +struct + type t = MutInd.t + let equal _env c1 c2 = MutInd.CanOrd.equal c1 c2 + let compare _env c1 c2 = MutInd.CanOrd.compare c1 c2 + let hash _env c = MutInd.CanOrd.hash c +end + +module QInd = +struct + type t = Ind.t + let equal _env c1 c2 = Ind.CanOrd.equal c1 c2 + let compare _env c1 c2 = Ind.CanOrd.compare c1 c2 + let hash _env c = Ind.CanOrd.hash c +end + +module QConstruct = +struct + type t = Construct.t + let equal _env c1 c2 = Construct.CanOrd.equal c1 c2 + let compare _env c1 c2 = Construct.CanOrd.compare c1 c2 + let hash _env c = Construct.CanOrd.hash c +end + +module QProjection = +struct + type t = Projection.t + let equal _env c1 c2 = Projection.CanOrd.equal c1 c2 + let compare _env c1 c2 = Projection.CanOrd.compare c1 c2 + let hash _env c = Projection.CanOrd.hash c + module Repr = + struct + type t = Projection.Repr.t + let equal _env c1 c2 = Projection.Repr.CanOrd.equal c1 c2 + let compare _env c1 c2 = Projection.Repr.CanOrd.compare c1 c2 + let hash _env c = Projection.Repr.CanOrd.hash c + end +end + +module QGlobRef = +struct + type t = GlobRef.t + let equal _env c1 c2 = GlobRef.CanOrd.equal c1 c2 + let compare _env c1 c2 = GlobRef.CanOrd.compare c1 c2 + let hash _env c = GlobRef.CanOrd.hash c +end diff --git a/kernel/environ.mli b/kernel/environ.mli index f443ba38e1..f0b40e6492 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -284,6 +284,32 @@ val template_polymorphic_ind : inductive -> env -> bool val template_polymorphic_variables : inductive -> env -> Univ.Level.t list val template_polymorphic_pind : pinductive -> env -> bool +(** {6 Name quotients} *) + +module type QNameS = +sig + type t + val equal : env -> t -> t -> bool + val compare : env -> t -> t -> int + val hash : env -> t -> int +end + +module QConstant : QNameS with type t = Constant.t + +module QMutInd : QNameS with type t = MutInd.t + +module QInd : QNameS with type t = Ind.t + +module QConstruct : QNameS with type t = Construct.t + +module QProjection : +sig + include QNameS with type t = Projection.t + module Repr : QNameS with type t = Projection.Repr.t +end + +module QGlobRef : QNameS with type t = GlobRef.t + (** {5 Modules } *) val add_modtype : module_type_body -> env -> env diff --git a/kernel/inductive.ml b/kernel/inductive.ml index d751d9875a..e34b3c0b47 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -404,7 +404,7 @@ let type_case_branches env (pind,largs) pj c = let check_case_info env (indsp,u) r ci = let (mib,mip as spec) = lookup_mind_specif env indsp in if - not (eq_ind indsp ci.ci_ind) || + not (Ind.CanOrd.equal indsp ci.ci_ind) || not (Int.equal mib.mind_nparams ci.ci_npar) || not (Array.equal Int.equal mip.mind_consnrealdecls ci.ci_cstr_ndecls) || not (Array.equal Int.equal mip.mind_consnrealargs ci.ci_cstr_nargs) || @@ -467,12 +467,12 @@ let inter_recarg r1 r2 = match r1, r2 with | Norec, _ -> None | Mrec i1, Mrec i2 | Nested (NestedInd i1), Nested (NestedInd i2) -| Mrec i1, (Nested (NestedInd i2)) -> if Names.eq_ind i1 i2 then Some r1 else None +| Mrec i1, (Nested (NestedInd i2)) -> if Names.Ind.CanOrd.equal i1 i2 then Some r1 else None | Mrec _, _ -> None -| Nested (NestedInd i1), Mrec i2 -> if Names.eq_ind i1 i2 then Some r2 else None +| Nested (NestedInd i1), Mrec i2 -> if Names.Ind.CanOrd.equal i1 i2 then Some r2 else None | Nested (NestedInd _), _ -> None | Nested (NestedPrimitive c1), Nested (NestedPrimitive c2) -> - if Names.Constant.equal c1 c2 then Some r1 else None + if Names.Constant.CanOrd.equal c1 c2 then Some r1 else None | Nested (NestedPrimitive _), _ -> None let inter_wf_paths = Rtree.inter Declareops.eq_recarg inter_recarg Norec @@ -556,7 +556,7 @@ let lookup_subterms env ind = let match_inductive ind ra = match ra with - | Mrec i | Nested (NestedInd i) -> eq_ind ind i + | Mrec i | Nested (NestedInd i) -> Ind.CanOrd.equal ind i | Norec | Nested (NestedPrimitive _) -> false (* In {match c as z in ci y_s return P with |C_i x_s => t end} @@ -644,7 +644,7 @@ let abstract_mind_lc ntyps npars lc = let is_primitive_positive_container env c = match env.retroknowledge.Retroknowledge.retro_array with - | Some c' when Constant.equal c c' -> true + | Some c' when QConstant.equal env c c' -> true | _ -> false (* [get_recargs_approx env tree ind args] builds an approximation of the recargs @@ -667,13 +667,13 @@ let get_recargs_approx env tree ind args = (* When the inferred tree allows it, we consider that we have a potential nested inductive type *) begin match dest_recarg tree with - | Nested (NestedInd kn') | Mrec kn' when eq_ind (fst ind_kn) kn' -> + | Nested (NestedInd kn') | Mrec kn' when Ind.CanOrd.equal (fst ind_kn) kn' -> build_recargs_nested ienv tree (ind_kn, largs) | _ -> mk_norec end | Const (c,_) when is_primitive_positive_container env c -> begin match dest_recarg tree with - | Nested (NestedPrimitive c') when Constant.equal c c' -> + | Nested (NestedPrimitive c') when QConstant.equal env c c' -> build_recargs_nested_primitive ienv tree (c, largs) | _ -> mk_norec end diff --git a/kernel/names.ml b/kernel/names.ml index 592b5e65f7..5b6064fa9f 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -447,6 +447,22 @@ module KNset = KNmap.Set (** {6 Kernel pairs } *) +module type EqType = +sig + type t + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int +end + +module type QNameS = +sig + type t + module CanOrd : EqType with type t = t + module UserOrd : EqType with type t = t + module SyntacticOrd : EqType with type t = t +end + (** For constant and inductive names, we use a kernel name couple (kn1,kn2) where kn1 corresponds to the name used at toplevel (i.e. what the user see) and kn2 corresponds to the canonical kernel name i.e. in the environment @@ -529,6 +545,7 @@ module KerPair = struct end module SyntacticOrd = struct + type t = kernel_pair let compare x y = match x, y with | Same knx, Same kny -> KerName.compare knx kny | Dual (knux,kncx), Dual (knuy,kncy) -> @@ -599,100 +616,147 @@ module Mindmap = HMap.Make(MutInd.CanOrd) module Mindset = Mindmap.Set module Mindmap_env = HMap.Make(MutInd.UserOrd) +module Ind = +struct + (** Designation of a (particular) inductive type. *) + type t = MutInd.t (* the name of the inductive type *) + * int (* the position of this inductive type + within the block of mutually-recursive inductive types. + BEWARE: indexing starts from 0. *) + let modpath (mind, _) = MutInd.modpath mind + + module CanOrd = + struct + type nonrec t = t + let equal (m1, i1) (m2, i2) = Int.equal i1 i2 && MutInd.CanOrd.equal m1 m2 + let compare (m1, i1) (m2, i2) = + let c = Int.compare i1 i2 in + if Int.equal c 0 then MutInd.CanOrd.compare m1 m2 else c + let hash (m, i) = + Hashset.Combine.combine (MutInd.CanOrd.hash m) (Int.hash i) + end + + module UserOrd = + struct + type nonrec t = t + let equal (m1, i1) (m2, i2) = + Int.equal i1 i2 && MutInd.UserOrd.equal m1 m2 + let compare (m1, i1) (m2, i2) = + let c = Int.compare i1 i2 in + if Int.equal c 0 then MutInd.UserOrd.compare m1 m2 else c + let hash (m, i) = + Hashset.Combine.combine (MutInd.UserOrd.hash m) (Int.hash i) + end + + module SyntacticOrd = + struct + type nonrec t = t + let equal (m1, i1) (m2, i2) = + Int.equal i1 i2 && MutInd.SyntacticOrd.equal m1 m2 + + let compare (m1, i1) (m2, i2) = + let c = Int.compare i1 i2 in + if Int.equal c 0 then MutInd.SyntacticOrd.compare m1 m2 else c + + let hash (m, i) = + Hashset.Combine.combine (MutInd.SyntacticOrd.hash m) (Int.hash i) + end + +end + +module Construct = +struct + (** Designation of a (particular) constructor of a (particular) inductive type. *) + type t = Ind.t (* designates the inductive type *) + * int (* the index of the constructor + BEWARE: indexing starts from 1. *) + + let modpath (ind, _) = Ind.modpath ind + + module CanOrd = + struct + type nonrec t = t + let equal (ind1, j1) (ind2, j2) = Int.equal j1 j2 && Ind.CanOrd.equal ind1 ind2 + let compare (ind1, j1) (ind2, j2) = + let c = Int.compare j1 j2 in + if Int.equal c 0 then Ind.CanOrd.compare ind1 ind2 else c + let hash (ind, i) = + Hashset.Combine.combine (Ind.CanOrd.hash ind) (Int.hash i) + end + + module UserOrd = + struct + type nonrec t = t + let equal (ind1, j1) (ind2, j2) = + Int.equal j1 j2 && Ind.UserOrd.equal ind1 ind2 + let compare (ind1, j1) (ind2, j2) = + let c = Int.compare j1 j2 in + if Int.equal c 0 then Ind.UserOrd.compare ind1 ind2 else c + let hash (ind, i) = + Hashset.Combine.combine (Ind.UserOrd.hash ind) (Int.hash i) + end + + module SyntacticOrd = + struct + type nonrec t = t + let equal (ind1, j1) (ind2, j2) = + Int.equal j1 j2 && Ind.SyntacticOrd.equal ind1 ind2 + let compare (ind1, j1) (ind2, j2) = + let c = Int.compare j1 j2 in + if Int.equal c 0 then Ind.SyntacticOrd.compare ind1 ind2 else c + let hash (ind, i) = + Hashset.Combine.combine (Ind.SyntacticOrd.hash ind) (Int.hash i) + end + +end + (** Designation of a (particular) inductive type. *) -type inductive = MutInd.t (* the name of the inductive type *) - * int (* the position of this inductive type - within the block of mutually-recursive inductive types. - BEWARE: indexing starts from 0. *) +type inductive = Ind.t (** Designation of a (particular) constructor of a (particular) inductive type. *) -type constructor = inductive (* designates the inductive type *) - * int (* the index of the constructor - BEWARE: indexing starts from 1. *) +type constructor = Construct.t -let ind_modpath (mind,_) = MutInd.modpath mind -let constr_modpath (ind,_) = ind_modpath ind +let ind_modpath = Ind.modpath +let constr_modpath = Construct.modpath let ith_mutual_inductive (mind, _) i = (mind, i) let ith_constructor_of_inductive ind i = (ind, i) let inductive_of_constructor (ind, _i) = ind let index_of_constructor (_ind, i) = i -let eq_ind (m1, i1) (m2, i2) = Int.equal i1 i2 && MutInd.equal m1 m2 -let eq_user_ind (m1, i1) (m2, i2) = - Int.equal i1 i2 && MutInd.UserOrd.equal m1 m2 -let eq_syntactic_ind (m1, i1) (m2, i2) = - Int.equal i1 i2 && MutInd.SyntacticOrd.equal m1 m2 - -let ind_ord (m1, i1) (m2, i2) = - let c = Int.compare i1 i2 in - if Int.equal c 0 then MutInd.CanOrd.compare m1 m2 else c -let ind_user_ord (m1, i1) (m2, i2) = - let c = Int.compare i1 i2 in - if Int.equal c 0 then MutInd.UserOrd.compare m1 m2 else c -let ind_syntactic_ord (m1, i1) (m2, i2) = - let c = Int.compare i1 i2 in - if Int.equal c 0 then MutInd.SyntacticOrd.compare m1 m2 else c - -let ind_hash (m, i) = - Hashset.Combine.combine (MutInd.hash m) (Int.hash i) -let ind_user_hash (m, i) = - Hashset.Combine.combine (MutInd.UserOrd.hash m) (Int.hash i) -let ind_syntactic_hash (m, i) = - Hashset.Combine.combine (MutInd.SyntacticOrd.hash m) (Int.hash i) - -let eq_constructor (ind1, j1) (ind2, j2) = Int.equal j1 j2 && eq_ind ind1 ind2 -let eq_user_constructor (ind1, j1) (ind2, j2) = - Int.equal j1 j2 && eq_user_ind ind1 ind2 -let eq_syntactic_constructor (ind1, j1) (ind2, j2) = - Int.equal j1 j2 && eq_syntactic_ind ind1 ind2 - -let constructor_ord (ind1, j1) (ind2, j2) = - let c = Int.compare j1 j2 in - if Int.equal c 0 then ind_ord ind1 ind2 else c -let constructor_user_ord (ind1, j1) (ind2, j2) = - let c = Int.compare j1 j2 in - if Int.equal c 0 then ind_user_ord ind1 ind2 else c -let constructor_syntactic_ord (ind1, j1) (ind2, j2) = - let c = Int.compare j1 j2 in - if Int.equal c 0 then ind_syntactic_ord ind1 ind2 else c - -let constructor_hash (ind, i) = - Hashset.Combine.combine (ind_hash ind) (Int.hash i) -let constructor_user_hash (ind, i) = - Hashset.Combine.combine (ind_user_hash ind) (Int.hash i) -let constructor_syntactic_hash (ind, i) = - Hashset.Combine.combine (ind_syntactic_hash ind) (Int.hash i) - -module InductiveOrdered = struct - type t = inductive - let compare = ind_ord -end +let eq_ind = Ind.CanOrd.equal +let eq_user_ind = Ind.UserOrd.equal +let eq_syntactic_ind = Ind.SyntacticOrd.equal -module InductiveOrdered_env = struct - type t = inductive - let compare = ind_user_ord -end +let ind_ord = Ind.CanOrd.compare +let ind_user_ord = Ind.UserOrd.compare +let ind_syntactic_ord = Ind.SyntacticOrd.compare -module Indset = Set.Make(InductiveOrdered) -module Indset_env = Set.Make(InductiveOrdered_env) -module Indmap = Map.Make(InductiveOrdered) -module Indmap_env = Map.Make(InductiveOrdered_env) +let ind_hash = Ind.CanOrd.hash +let ind_user_hash = Ind.UserOrd.hash +let ind_syntactic_hash = Ind.SyntacticOrd.hash -module ConstructorOrdered = struct - type t = constructor - let compare = constructor_ord -end +let eq_constructor = Construct.CanOrd.equal +let eq_user_constructor = Construct.UserOrd.equal +let eq_syntactic_constructor = Construct.SyntacticOrd.equal -module ConstructorOrdered_env = struct - type t = constructor - let compare = constructor_user_ord -end +let constructor_ord = Construct.CanOrd.compare +let constructor_user_ord = Construct.UserOrd.compare +let constructor_syntactic_ord = Construct.SyntacticOrd.compare + +let constructor_hash = Construct.CanOrd.hash +let constructor_user_hash = Construct.UserOrd.hash +let constructor_syntactic_hash = Construct.SyntacticOrd.hash + +module Indset = Set.Make(Ind.CanOrd) +module Indset_env = Set.Make(Ind.UserOrd) +module Indmap = Map.Make(Ind.CanOrd) +module Indmap_env = Map.Make(Ind.UserOrd) -module Constrset = Set.Make(ConstructorOrdered) -module Constrset_env = Set.Make(ConstructorOrdered_env) -module Constrmap = Map.Make(ConstructorOrdered) -module Constrmap_env = Map.Make(ConstructorOrdered_env) +module Constrset = Set.Make(Construct.CanOrd) +module Constrset_env = Set.Make(Construct.UserOrd) +module Constrmap = Map.Make(Construct.CanOrd) +module Constrmap_env = Map.Make(Construct.UserOrd) (** {6 Hash-consing of name objects } *) @@ -786,6 +850,8 @@ struct Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) module SyntacticOrd = struct + type nonrec t = t + let compare a b = let c = ind_syntactic_ord a.proj_ind b.proj_ind in if c == 0 then Int.compare a.proj_arg b.proj_arg @@ -798,6 +864,8 @@ struct Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) end module CanOrd = struct + type nonrec t = t + let compare a b = let c = ind_ord a.proj_ind b.proj_ind in if c == 0 then Int.compare a.proj_arg b.proj_arg @@ -810,6 +878,8 @@ struct Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) end module UserOrd = struct + type nonrec t = t + let compare a b = let c = ind_user_ord a.proj_ind b.proj_ind in if c == 0 then Int.compare a.proj_arg b.proj_arg @@ -876,6 +946,7 @@ struct let hash (c, b) = (if b then 0 else 1) + Repr.hash c module SyntacticOrd = struct + type nonrec t = t let compare (c, b) (c', b') = if b = b' then Repr.SyntacticOrd.compare c c' else -1 let equal (c, b as x) (c', b' as x') = @@ -883,12 +954,21 @@ struct let hash (c, b) = (if b then 0 else 1) + Repr.SyntacticOrd.hash c end module CanOrd = struct + type nonrec t = t let compare (c, b) (c', b') = if b = b' then Repr.CanOrd.compare c c' else -1 let equal (c, b as x) (c', b' as x') = x == x' || b = b' && Repr.CanOrd.equal c c' let hash (c, b) = (if b then 0 else 1) + Repr.CanOrd.hash c end + module UserOrd = struct + type nonrec t = t + let compare (c, b) (c', b') = + if b = b' then Repr.UserOrd.compare c c' else -1 + let equal (c, b as x) (c', b' as x') = + x == x' || b = b' && Repr.UserOrd.equal c c' + let hash (c, b) = (if b then 0 else 1) + Repr.UserOrd.hash c + end module Self_Hashcons = struct @@ -982,31 +1062,36 @@ module GlobRef = struct (* By default, [global_reference] are ordered on their canonical part *) - module Ordered = struct - open Constant.CanOrd + module CanOrd = struct type t = GlobRefInternal.t let compare gr1 gr2 = - GlobRefInternal.global_ord_gen compare ind_ord constructor_ord gr1 gr2 - let equal gr1 gr2 = GlobRefInternal.global_eq_gen equal eq_ind eq_constructor gr1 gr2 - let hash gr = GlobRefInternal.global_hash_gen hash ind_hash constructor_hash gr + GlobRefInternal.global_ord_gen Constant.CanOrd.compare Ind.CanOrd.compare Construct.CanOrd.compare gr1 gr2 + let equal gr1 gr2 = GlobRefInternal.global_eq_gen Constant.CanOrd.equal Ind.CanOrd.equal Construct.CanOrd.equal gr1 gr2 + let hash gr = GlobRefInternal.global_hash_gen Constant.CanOrd.hash Ind.CanOrd.hash Construct.CanOrd.hash gr end - module Ordered_env = struct - open Constant.UserOrd + module UserOrd = struct + type t = GlobRefInternal.t + let compare gr1 gr2 = + GlobRefInternal.global_ord_gen Constant.UserOrd.compare Ind.UserOrd.compare Construct.UserOrd.compare gr1 gr2 + let equal gr1 gr2 = GlobRefInternal.global_eq_gen Constant.UserOrd.equal Ind.UserOrd.equal Construct.UserOrd.equal gr1 gr2 + let hash gr = GlobRefInternal.global_hash_gen Constant.UserOrd.hash Ind.UserOrd.hash Construct.UserOrd.hash gr + end + + module SyntacticOrd = struct type t = GlobRefInternal.t let compare gr1 gr2 = - GlobRefInternal.global_ord_gen compare ind_user_ord constructor_user_ord gr1 gr2 - let equal gr1 gr2 = - GlobRefInternal.global_eq_gen equal eq_user_ind eq_user_constructor gr1 gr2 - let hash gr = GlobRefInternal.global_hash_gen hash ind_user_hash constructor_user_hash gr + GlobRefInternal.global_ord_gen Constant.SyntacticOrd.compare Ind.SyntacticOrd.compare Construct.SyntacticOrd.compare gr1 gr2 + let equal gr1 gr2 = GlobRefInternal.global_eq_gen Constant.SyntacticOrd.equal Ind.SyntacticOrd.equal Construct.SyntacticOrd.equal gr1 gr2 + let hash gr = GlobRefInternal.global_hash_gen Constant.SyntacticOrd.hash Ind.SyntacticOrd.hash Construct.SyntacticOrd.hash gr end - module Map = HMap.Make(Ordered) + module Map = HMap.Make(CanOrd) module Set = Map.Set (* Alternative sets and maps indexed by the user part of the kernel names *) - module Map_env = HMap.Make(Ordered_env) + module Map_env = HMap.Make(UserOrd) module Set_env = Map_env.Set end diff --git a/kernel/names.mli b/kernel/names.mli index ea137ad1f4..9a4ceef802 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -307,6 +307,60 @@ module KNset : CSig.SetS with type elt = KerName.t module KNpred : Predicate.S with type elt = KerName.t module KNmap : Map.ExtS with type key = KerName.t and module Set := KNset +(** {6 Signature for quotiented names} *) + +module type EqType = +sig + type t + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int +end + +module type QNameS = +sig + type t + (** A type of reference that implements an implicit quotient by containing + two different names. The first one is the user name, i.e. what the user + sees when printing. The second one is the canonical name, which is the + actual absolute name of the reference. + + This mechanism is fundamentally tied to the module system of Coq. Functor + application and module inclusion are the typical ways to introduce names + where the canonical and user components differ. In particular, the two + components should be undistinguishable from the point of view of typing, + i.e. from a "kernel" ground. This aliasing only makes sense inside an + environment, but at this point this notion is not even defined so, this + dual name trick is fragile. One has to ensure many invariants when + creating such names, but the kernel is quite lenient when it comes to + checking that these invariants hold. (Read: there are soundness bugs + lurking in the module system.) + + One could enforce the invariants by splitting the names and storing that + information in the environment instead, but unfortunately, this wreaks + havoc in the upper layers. The latter are infamously not stable by + syntactic equality, in particular they might observe the difference + between canonical and user names if not packed together. + + For this reason, it is discouraged to use the canonical-accessing API + in the upper layers, notably the [CanOrd] module below. Instead, one + should use their quotiented versions defined in the [Environ] module. + Eventually all uses to [CanOrd] outside of the kernel should be removed. + + CAVEAT: name sets and maps are still exposing a canonical-accessing API + surreptitiously. *) + + module CanOrd : EqType with type t = t + (** Equality functions over the canonical name. Their use should be + restricted to the kernel. *) + + module UserOrd : EqType with type t = t + (** Equality functions over the user name. *) + + module SyntacticOrd : EqType with type t = t + (** Equality functions using both names, for low-level uses. *) +end + (** {6 Constant Names } *) module Constant: @@ -340,28 +394,12 @@ sig (** Comparisons *) - module CanOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - - module UserOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end + include QNameS with type t := t - module SyntacticOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - - val equal : t -> t -> bool + val equal : t -> t -> bool [@@ocaml.deprecated "Use QConstant.equal"] (** Default comparison, alias for [CanOrd.equal] *) - val hash : t -> int + val hash : t -> int [@@ocaml.deprecated "Use QConstant.hash"] (** Hashing function *) val change_label : t -> Label.t -> t @@ -430,28 +468,12 @@ sig (** Comparisons *) - module CanOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - - module UserOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - - module SyntacticOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end + include QNameS with type t := t - val equal : t -> t -> bool - (** Default comparison, alias for [CanOrd.equal] *) + val equal : t -> t -> bool [@@ocaml.deprecated "Use QMutInd.equal"] + (** Default comparison, alias for [CanOrd.equal] *) - val hash : t -> int + val hash : t -> int [@@ocaml.deprecated "Use QMutInd.hash"] (** Displaying *) @@ -473,16 +495,35 @@ module Mindset : CSig.SetS with type elt = MutInd.t module Mindmap : Map.ExtS with type key = MutInd.t and module Set := Mindset module Mindmap_env : CMap.ExtS with type key = MutInd.t -(** Designation of a (particular) inductive type. *) -type inductive = MutInd.t (* the name of the inductive type *) - * int (* the position of this inductive type - within the block of mutually-recursive inductive types. - BEWARE: indexing starts from 0. *) +module Ind : +sig + (** Designation of a (particular) inductive type. *) + type t = MutInd.t (* the name of the inductive type *) + * int (* the position of this inductive type + within the block of mutually-recursive inductive types. + BEWARE: indexing starts from 0. *) + val modpath : t -> ModPath.t + + include QNameS with type t := t + +end + +type inductive = Ind.t -(** Designation of a (particular) constructor of a (particular) inductive type. *) -type constructor = inductive (* designates the inductive type *) - * int (* the index of the constructor - BEWARE: indexing starts from 1. *) +module Construct : +sig + (** Designation of a (particular) constructor of a (particular) inductive type. *) + type t = Ind.t (* designates the inductive type *) + * int (* the index of the constructor + BEWARE: indexing starts from 1. *) + + val modpath : t -> ModPath.t + + include QNameS with type t := t + +end + +type constructor = Construct.t module Indset : CSet.S with type elt = inductive module Constrset : CSet.S with type elt = constructor @@ -494,30 +535,51 @@ module Indmap_env : CMap.ExtS with type key = inductive and module Set := Indset module Constrmap_env : CMap.ExtS with type key = constructor and module Set := Constrset_env val ind_modpath : inductive -> ModPath.t +[@@ocaml.deprecated "Use the Ind module"] + val constr_modpath : constructor -> ModPath.t +[@@ocaml.deprecated "Use the Construct module"] val ith_mutual_inductive : inductive -> int -> inductive val ith_constructor_of_inductive : inductive -> int -> constructor val inductive_of_constructor : constructor -> inductive val index_of_constructor : constructor -> int val eq_ind : inductive -> inductive -> bool +[@@ocaml.deprecated "Use the Ind module"] val eq_user_ind : inductive -> inductive -> bool +[@@ocaml.deprecated "Use the Ind module"] val eq_syntactic_ind : inductive -> inductive -> bool +[@@ocaml.deprecated "Use the Ind module"] val ind_ord : inductive -> inductive -> int +[@@ocaml.deprecated "Use the Ind module"] val ind_hash : inductive -> int +[@@ocaml.deprecated "Use the Ind module"] val ind_user_ord : inductive -> inductive -> int +[@@ocaml.deprecated "Use the Ind module"] val ind_user_hash : inductive -> int +[@@ocaml.deprecated "Use the Ind module"] val ind_syntactic_ord : inductive -> inductive -> int +[@@ocaml.deprecated "Use the Ind module"] val ind_syntactic_hash : inductive -> int +[@@ocaml.deprecated "Use the Ind module"] val eq_constructor : constructor -> constructor -> bool +[@@ocaml.deprecated "Use the Construct module"] val eq_user_constructor : constructor -> constructor -> bool +[@@ocaml.deprecated "Use the Construct module"] val eq_syntactic_constructor : constructor -> constructor -> bool +[@@ocaml.deprecated "Use the Construct module"] val constructor_ord : constructor -> constructor -> int +[@@ocaml.deprecated "Use the Construct module"] val constructor_hash : constructor -> int +[@@ocaml.deprecated "Use the Construct module"] val constructor_user_ord : constructor -> constructor -> int +[@@ocaml.deprecated "Use the Construct module"] val constructor_user_hash : constructor -> int +[@@ocaml.deprecated "Use the Construct module"] val constructor_syntactic_ord : constructor -> constructor -> int +[@@ocaml.deprecated "Use the Construct module"] val constructor_syntactic_hash : constructor -> int +[@@ocaml.deprecated "Use the Construct module"] (** {6 Hash-consing } *) @@ -558,21 +620,7 @@ module Projection : sig val make : inductive -> proj_npars:int -> proj_arg:int -> Label.t -> t - module SyntacticOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - module CanOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - module UserOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end + include QNameS with type t := t val constant : t -> Constant.t (** Don't use this if you don't have to. *) @@ -583,9 +631,9 @@ module Projection : sig val arg : t -> int val label : t -> Label.t - val equal : t -> t -> bool - val hash : t -> int - val compare : t -> t -> int + val equal : t -> t -> bool [@@ocaml.deprecated "Use QProjection.equal"] + val hash : t -> int [@@ocaml.deprecated "Use QProjection.hash"] + val compare : t -> t -> int [@@ocaml.deprecated "Use QProjection.compare"] val map : (MutInd.t -> MutInd.t) -> t -> t val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t @@ -602,16 +650,7 @@ module Projection : sig val make : Repr.t -> bool -> t val repr : t -> Repr.t - module SyntacticOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - module CanOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end + include QNameS with type t := t val constant : t -> Constant.t val mind : t -> MutInd.t @@ -623,14 +662,18 @@ module Projection : sig val unfold : t -> t val equal : t -> t -> bool + [@@ocaml.deprecated "Use QProjection.equal"] val hash : t -> int + [@@ocaml.deprecated "Use QProjection.hash"] val hcons : t -> t (** Hashconsing of projections. *) val repr_equal : t -> t -> bool + [@@ocaml.deprecated "Use an explicit projection of Repr"] (** Ignoring the unfolding boolean. *) val compare : t -> t -> int + [@@ocaml.deprecated "Use QProjection.compare"] val map : (MutInd.t -> MutInd.t) -> t -> t val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t @@ -656,19 +699,7 @@ module GlobRef : sig val equal : t -> t -> bool - module Ordered : sig - type nonrec t = t - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - - module Ordered_env : sig - type nonrec t = t - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end + include QNameS with type t := t module Set_env : CSig.SetS with type elt = t module Map_env : Map.ExtS diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index ae070e6f8e..b5c4d6416a 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -65,11 +65,11 @@ type gname = let eq_gname gn1 gn2 = match gn1, gn2 with | Gind (s1, ind1), Gind (s2, ind2) -> - String.equal s1 s2 && eq_ind ind1 ind2 + String.equal s1 s2 && Ind.CanOrd.equal ind1 ind2 | Gconstant (s1, c1), Gconstant (s2, c2) -> - String.equal s1 s2 && Constant.equal c1 c2 + String.equal s1 s2 && Constant.CanOrd.equal c1 c2 | Gproj (s1, ind1, i1), Gproj (s2, ind2, i2) -> - String.equal s1 s2 && eq_ind ind1 ind2 && Int.equal i1 i2 + String.equal s1 s2 && Ind.CanOrd.equal ind1 ind2 && Int.equal i1 i2 | Gcase (None, i1), Gcase (None, i2) -> Int.equal i1 i2 | Gcase (Some l1, i1), Gcase (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2 | Gpred (None, i1), Gpred (None, i2) -> Int.equal i1 i2 @@ -96,9 +96,9 @@ open Hashset.Combine let gname_hash gn = match gn with | Gind (s, ind) -> - combinesmall 1 (combine (String.hash s) (ind_hash ind)) + combinesmall 1 (combine (String.hash s) (Ind.CanOrd.hash ind)) | Gconstant (s, c) -> - combinesmall 2 (combine (String.hash s) (Constant.hash c)) + combinesmall 2 (combine (String.hash s) (Constant.CanOrd.hash c)) | Gcase (l, i) -> combinesmall 3 (combine (Option.hash Label.hash l) (Int.hash i)) | Gpred (l, i) -> combinesmall 4 (combine (Option.hash Label.hash l) (Int.hash i)) | Gfixtype (l, i) -> combinesmall 5 (combine (Option.hash Label.hash l) (Int.hash i)) @@ -107,7 +107,7 @@ let gname_hash gn = match gn with | Ginternal s -> combinesmall 8 (String.hash s) | Grel i -> combinesmall 9 (Int.hash i) | Gnamed id -> combinesmall 10 (Id.hash id) -| Gproj (s, p, i) -> combinesmall 11 (combine (String.hash s) (combine (ind_hash p) i)) +| Gproj (s, p, i) -> combinesmall 11 (combine (String.hash s) (combine (Ind.CanOrd.hash p) i)) let case_ctr = ref (-1) @@ -148,13 +148,13 @@ let eq_symbol sy1 sy2 = | SymbValue v1, SymbValue v2 -> (=) v1 v2 (** FIXME: how is this even valid? *) | SymbSort s1, SymbSort s2 -> Sorts.equal s1 s2 | SymbName n1, SymbName n2 -> Name.equal n1 n2 - | SymbConst kn1, SymbConst kn2 -> Constant.equal kn1 kn2 + | SymbConst kn1, SymbConst kn2 -> Constant.CanOrd.equal kn1 kn2 | SymbMatch sw1, SymbMatch sw2 -> eq_annot_sw sw1 sw2 - | SymbInd ind1, SymbInd ind2 -> eq_ind ind1 ind2 + | SymbInd ind1, SymbInd ind2 -> Ind.CanOrd.equal ind1 ind2 | SymbMeta m1, SymbMeta m2 -> Int.equal m1 m2 | SymbEvar evk1, SymbEvar evk2 -> Evar.equal evk1 evk2 | SymbLevel l1, SymbLevel l2 -> Univ.Level.equal l1 l2 - | SymbProj (i1, k1), SymbProj (i2, k2) -> eq_ind i1 i2 && Int.equal k1 k2 + | SymbProj (i1, k1), SymbProj (i2, k2) -> Ind.CanOrd.equal i1 i2 && Int.equal k1 k2 | _, _ -> false let hash_symbol symb = @@ -162,13 +162,13 @@ let hash_symbol symb = | SymbValue v -> combinesmall 1 (Hashtbl.hash v) (** FIXME *) | SymbSort s -> combinesmall 2 (Sorts.hash s) | SymbName name -> combinesmall 3 (Name.hash name) - | SymbConst c -> combinesmall 4 (Constant.hash c) + | SymbConst c -> combinesmall 4 (Constant.CanOrd.hash c) | SymbMatch sw -> combinesmall 5 (hash_annot_sw sw) - | SymbInd ind -> combinesmall 6 (ind_hash ind) + | SymbInd ind -> combinesmall 6 (Ind.CanOrd.hash ind) | SymbMeta m -> combinesmall 7 m | SymbEvar evk -> combinesmall 8 (Evar.hash evk) | SymbLevel l -> combinesmall 9 (Univ.Level.hash l) - | SymbProj (i, k) -> combinesmall 10 (combine (ind_hash i) k) + | SymbProj (i, k) -> combinesmall 10 (combine (Ind.CanOrd.hash i) k) module HashedTypeSymbol = struct type t = symbol @@ -438,7 +438,7 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = eq_mllam_branches gn1 gn2 n env1 env2 br1 br2 | MLconstruct (pf1, ind1, tag1, args1), MLconstruct (pf2, ind2, tag2, args2) -> String.equal pf1 pf2 && - eq_ind ind1 ind2 && + Ind.CanOrd.equal ind1 ind2 && Int.equal tag1 tag2 && Array.equal (eq_mllambda gn1 gn2 n env1 env2) args1 args2 | MLint i1, MLint i2 -> @@ -457,7 +457,7 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = Array.equal (eq_mllambda gn1 gn2 n env1 env2) arr1 arr2 | MLisaccu (s1, ind1, ml1), MLisaccu (s2, ind2, ml2) -> - String.equal s1 s2 && eq_ind ind1 ind2 && + String.equal s1 s2 && Ind.CanOrd.equal ind1 ind2 && eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 | (MLlocal _ | MLglobal _ | MLprimitive _ | MLlam _ | MLletrec _ | MLlet _ | MLapp _ | MLif _ | MLmatch _ | MLconstruct _ | MLint _ | MLuint _ | @@ -527,7 +527,7 @@ let rec hash_mllambda gn n env t = combinesmall 9 (hash_mllam_branches gn n env (combine3 hannot hc haccu) br) | MLconstruct (pf, ind, tag, args) -> let hpf = String.hash pf in - let hcs = ind_hash ind in + let hcs = Ind.CanOrd.hash ind in let htag = Int.hash tag in combinesmall 10 (hash_mllambda_array gn n env (combine3 hpf hcs htag) args) | MLint i -> @@ -545,7 +545,7 @@ let rec hash_mllambda gn n env t = | MLarray arr -> combinesmall 15 (hash_mllambda_array gn n env 1 arr) | MLisaccu (s, ind, c) -> - combinesmall 16 (combine (String.hash s) (combine (ind_hash ind) (hash_mllambda gn n env c))) + combinesmall 16 (combine (String.hash s) (combine (Ind.CanOrd.hash ind) (hash_mllambda gn n env c))) | MLfloat f -> combinesmall 17 (Float64.hash f) @@ -689,7 +689,7 @@ let eq_global g1 g2 = eq_mllambda gn1 gn2 (Array.length lns1) env1 env2 t1 t2 | Gopen s1, Gopen s2 -> String.equal s1 s2 | Gtype (ind1, arr1), Gtype (ind2, arr2) -> - eq_ind ind1 ind2 && + Ind.CanOrd.equal ind1 ind2 && Array.equal (fun (tag1,ar1) (tag2,ar2) -> Int.equal tag1 tag2 && Int.equal ar1 ar2) arr1 arr2 | Gcomment s1, Gcomment s2 -> String.equal s1 s2 | _, _ -> false @@ -720,7 +720,7 @@ let hash_global g = let hash_aux acc (tag,ar) = combine3 acc (Int.hash tag) (Int.hash ar) in - combinesmall 6 (combine (ind_hash ind) (Array.fold_left hash_aux 0 arr)) + combinesmall 6 (combine (Ind.CanOrd.hash ind) (Array.fold_left hash_aux 0 arr)) | Gcomment s -> combinesmall 7 (String.hash s) let global_stack = ref ([] : global list) diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index fc6afb79d4..76215b4386 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -80,17 +80,17 @@ and conv_atom env pb lvl a1 a2 cu = | Arel i1, Arel i2 -> if Int.equal i1 i2 then cu else raise NotConvertible | Aind (ind1,u1), Aind (ind2,u2) -> - if eq_ind ind1 ind2 then convert_instances ~flex:false u1 u2 cu + if Ind.CanOrd.equal ind1 ind2 then convert_instances ~flex:false u1 u2 cu else raise NotConvertible | Aconstant (c1,u1), Aconstant (c2,u2) -> - if Constant.equal c1 c2 then convert_instances ~flex:true u1 u2 cu + if Constant.CanOrd.equal c1 c2 then convert_instances ~flex:true u1 u2 cu else raise NotConvertible | Asort s1, Asort s2 -> sort_cmp_universes env pb s1 s2 cu | Avar id1, Avar id2 -> if Id.equal id1 id2 then cu else raise NotConvertible | Acase(a1,ac1,p1,bs1), Acase(a2,ac2,p2,bs2) -> - if not (eq_ind a1.asw_ind a2.asw_ind) then raise NotConvertible; + if not (Ind.CanOrd.equal a1.asw_ind a2.asw_ind) then raise NotConvertible; let cu = conv_accu env CONV lvl ac1 ac2 cu in let tbl = a1.asw_reloc in let len = Array.length tbl in @@ -124,7 +124,7 @@ and conv_atom env pb lvl a1 a2 cu = let v = mk_rel_accu lvl in conv_val env pb (lvl + 1) (d1 v) (d2 v) cu | Aproj((ind1, i1), ac1), Aproj((ind2, i2), ac2) -> - if not (eq_ind ind1 ind2 && Int.equal i1 i2) then raise NotConvertible + if not (Ind.CanOrd.equal ind1 ind2 && Int.equal i1 i2) then raise NotConvertible else conv_accu env CONV lvl ac1 ac2 cu | Arel _, _ | Aind _, _ | Aconstant _, _ | Asort _, _ | Avar _, _ | Acase _, _ | Afix _, _ | Acofix _, _ | Acofixe _, _ | Aprod _, _ diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 99090f0147..e98e97907a 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -433,8 +433,8 @@ module Cache = module ConstrHash = struct type t = constructor - let equal = eq_constructor - let hash = constructor_hash + let equal = Construct.CanOrd.equal + let hash = Construct.CanOrd.hash end module ConstrTable = Hashtbl.Make(ConstrHash) diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 05c98e4b87..bd6241ae67 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -36,13 +36,13 @@ type annot_sw = { (* We compare only what is relevant for generation of ml code *) let eq_annot_sw asw1 asw2 = - eq_ind asw1.asw_ind asw2.asw_ind && + Ind.CanOrd.equal asw1.asw_ind asw2.asw_ind && String.equal asw1.asw_prefix asw2.asw_prefix open Hashset.Combine let hash_annot_sw asw = - combine (ind_hash asw.asw_ind) (String.hash asw.asw_prefix) + combine (Ind.CanOrd.hash asw.asw_ind) (String.hash asw.asw_prefix) type sort_annot = string * int diff --git a/kernel/primred.ml b/kernel/primred.ml index f158cfacea..f0b4d6d362 100644 --- a/kernel/primred.ml +++ b/kernel/primred.ml @@ -12,11 +12,11 @@ type _ action_kind = type exn += IncompatibleDeclarations : 'a action_kind * 'a * 'a -> exn let check_same_types typ c1 c2 = - if not (Constant.equal c1 c2) + if not (Constant.CanOrd.equal c1 c2) then raise (IncompatibleDeclarations (IncompatTypes typ, c1, c2)) let check_same_inds ind i1 i2 = - if not (eq_ind i1 i2) + if not (Ind.CanOrd.equal i1 i2) then raise (IncompatibleDeclarations (IncompatInd ind, i1, i2)) let add_retroknowledge retro action = diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 96bf370342..5589ae3483 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -283,7 +283,7 @@ let convert_constructors ctor nargs u1 u2 (s, check) = let conv_table_key infos k1 k2 cuniv = if k1 == k2 then cuniv else match k1, k2 with - | ConstKey (cst, u), ConstKey (cst', u') when Constant.equal cst cst' -> + | ConstKey (cst, u), ConstKey (cst', u') when Constant.CanOrd.equal cst cst' -> if Univ.Instance.equal u u' then cuniv else let flex = evaluable_constant cst (info_env infos) @@ -441,7 +441,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | Some s2 -> eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv | None -> - if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) + if Projection.Repr.CanOrd.equal (Projection.repr p1) (Projection.repr p2) && compare_stack_shape v1 v2 then let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in @@ -568,7 +568,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* Inductive types: MutInd MutConstruct Fix Cofix *) | (FInd (ind1,u1 as pind1), FInd (ind2,u2 as pind2)) -> - if eq_ind ind1 ind2 then + if Ind.CanOrd.equal ind1 ind2 then if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then let cuniv = convert_instances ~flex:false u1 u2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv @@ -588,7 +588,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = else raise NotConvertible | (FConstruct ((ind1,j1),u1 as pctor1), FConstruct ((ind2,j2),u2 as pctor2)) -> - if Int.equal j1 j2 && eq_ind ind1 ind2 then + if Int.equal j1 j2 && Ind.CanOrd.equal ind1 ind2 then if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then let cuniv = convert_instances ~flex:false u1 u2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv @@ -669,7 +669,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = else raise NotConvertible | FCaseInvert (ci1,p1,_,_,br1,e1), FCaseInvert (ci2,p2,_,_,br2,e2) -> - (if not (eq_ind ci1.ci_ind ci2.ci_ind) then raise NotConvertible); + (if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then raise NotConvertible); let el1 = el_stack lft1 v1 and el2 = el_stack lft2 v2 in let ccnv = ccnv CONV l2r infos el1 el2 in let cuniv = ccnv (mk_clos e1 p1) (mk_clos e2 p2) cuniv in @@ -704,14 +704,14 @@ and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = | (Zlapp a1,Zlapp a2) -> Array.fold_right2 f a1 a2 cu1 | (Zlproj (c1,_l1),Zlproj (c2,_l2)) -> - if not (Projection.Repr.equal c1 c2) then + if not (Projection.Repr.CanOrd.equal c1 c2) then raise NotConvertible else cu1 | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> let cu2 = f fx1 fx2 cu1 in cmp_rec a1 a2 cu2 | (Zlcase(ci1,l1,p1,br1,e1),Zlcase(ci2,l2,p2,br2,e2)) -> - if not (eq_ind ci1.ci_ind ci2.ci_ind) then + if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then raise NotConvertible; let cu2 = f (l1, mk_clos e1 p1) (l2, mk_clos e2 p2) cu1 in convert_branches l2r infos ci1 e1 e2 l1 l2 br1 br2 cu2 diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 76a1c190be..1a4c786e43 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -182,7 +182,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 begin let kn2' = kn_of_delta reso2 kn2 in if KerName.equal kn2 kn2' || - MutInd.equal (mind_of_delta_kn reso1 kn1) + MutInd.CanOrd.equal (mind_of_delta_kn reso1 kn1) (subst_mind subst2 (MutInd.make kn2 kn2')) then () else error NotEqualInductiveAliases diff --git a/kernel/typeops.ml b/kernel/typeops.ml index f86c12e1f1..85e24f87b7 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -413,7 +413,7 @@ let type_of_projection env p c ct = try find_rectype env ct with Not_found -> error_case_not_inductive env (make_judge c ct) in - assert(eq_ind (Projection.inductive p) ind); + assert(Ind.CanOrd.equal (Projection.inductive p) ind); let ty = Vars.subst_instance_constr u pty in substl (c :: CList.rev args) ty diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 948195797e..1432fb9310 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -95,7 +95,7 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = (* Pp.(msg_debug (str "conv_atom(" ++ pr_atom a1 ++ str ", " ++ pr_atom a2 ++ str ")")) ; *) match a1, a2 with | Aind ((mi,_i) as ind1) , Aind ind2 -> - if eq_ind ind1 ind2 && compare_stack stk1 stk2 then + if Ind.CanOrd.equal ind1 ind2 && compare_stack stk1 stk2 then let ulen = Univ.AUContext.size (Environ.mind_context env mi) in if ulen = 0 then conv_stack env k stk1 stk2 cu @@ -141,7 +141,7 @@ and conv_stack env k stk1 stk2 cu = conv_stack env k stk1 stk2 !rcu else raise NotConvertible | Zproj p1 :: stk1, Zproj p2 :: stk2 -> - if Projection.Repr.equal p1 p2 then conv_stack env k stk1 stk2 cu + if Projection.Repr.CanOrd.equal p1 p2 then conv_stack env k stk1 stk2 cu else raise NotConvertible | [], _ | Zapp _ :: _, _ | Zfix _ :: _, _ | Zswitch _ :: _, _ | Zproj _ :: _, _ -> raise NotConvertible diff --git a/kernel/vmemitcodes.ml b/kernel/vmemitcodes.ml index ec8601edc9..babc57794b 100644 --- a/kernel/vmemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -36,9 +36,9 @@ let eq_reloc_info r1 r2 = match r1, r2 with | Reloc_annot _, _ -> false | Reloc_const c1, Reloc_const c2 -> eq_structured_constant c1 c2 | Reloc_const _, _ -> false -| Reloc_getglobal c1, Reloc_getglobal c2 -> Constant.equal c1 c2 +| Reloc_getglobal c1, Reloc_getglobal c2 -> Constant.CanOrd.equal c1 c2 | Reloc_getglobal _, _ -> false -| Reloc_proj_name p1, Reloc_proj_name p2 -> Projection.Repr.equal p1 p2 +| Reloc_proj_name p1, Reloc_proj_name p2 -> Projection.Repr.CanOrd.equal p1 p2 | Reloc_proj_name _, _ -> false | Reloc_caml_prim p1, Reloc_caml_prim p2 -> CPrimitives.equal p1 p2 | Reloc_caml_prim _, _ -> false @@ -48,8 +48,8 @@ let hash_reloc_info r = match r with | Reloc_annot sw -> combinesmall 1 (hash_annot_switch sw) | Reloc_const c -> combinesmall 2 (hash_structured_constant c) - | Reloc_getglobal c -> combinesmall 3 (Constant.hash c) - | Reloc_proj_name p -> combinesmall 4 (Projection.Repr.hash p) + | Reloc_getglobal c -> combinesmall 3 (Constant.CanOrd.hash c) + | Reloc_proj_name p -> combinesmall 4 (Projection.Repr.CanOrd.hash p) | Reloc_caml_prim p -> combinesmall 5 (CPrimitives.hash p) module RelocTable = Hashtbl.Make(struct diff --git a/kernel/vmsymtable.ml b/kernel/vmsymtable.ml index 9d80dc578b..ae0fa38571 100644 --- a/kernel/vmsymtable.ml +++ b/kernel/vmsymtable.ml @@ -85,7 +85,7 @@ module AnnotTable = Hashtbl.Make (struct let hash = hash_annot_switch end) -module ProjNameTable = Hashtbl.Make (Projection.Repr) +module ProjNameTable = Hashtbl.Make (Projection.Repr.CanOrd) let str_cst_tbl : int SConstTable.t = SConstTable.create 31 diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 2068133b10..7b4101b9d0 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -96,7 +96,7 @@ let hash_structured_values (v : structured_values) = let eq_structured_constant c1 c2 = match c1, c2 with | Const_sort s1, Const_sort s2 -> Sorts.equal s1 s2 | Const_sort _, _ -> false -| Const_ind i1, Const_ind i2 -> eq_ind i1 i2 +| Const_ind i1, Const_ind i2 -> Ind.CanOrd.equal i1 i2 | Const_ind _, _ -> false | Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2 | Const_b0 _, _ -> false @@ -113,7 +113,7 @@ let hash_structured_constant c = let open Hashset.Combine in match c with | Const_sort s -> combinesmall 1 (Sorts.hash s) - | Const_ind i -> combinesmall 2 (ind_hash i) + | Const_ind i -> combinesmall 2 (Ind.CanOrd.hash i) | Const_b0 t -> combinesmall 3 (Int.hash t) | Const_univ_level l -> combinesmall 4 (Univ.Level.hash l) | Const_val v -> combinesmall 5 (hash_structured_values v) @@ -250,7 +250,7 @@ type id_key = | EvarKey of Evar.t let eq_id_key (k1 : id_key) (k2 : id_key) = match k1, k2 with -| ConstKey c1, ConstKey c2 -> Constant.equal c1 c2 +| ConstKey c1, ConstKey c2 -> Constant.CanOrd.equal c1 c2 | VarKey id1, VarKey id2 -> Id.equal id1 id2 | RelKey n1, RelKey n2 -> Int.equal n1 n2 | EvarKey evk1, EvarKey evk2 -> Evar.equal evk1 evk2 @@ -469,7 +469,7 @@ struct let equal = eq_id_key open Hashset.Combine let hash : t -> tag = function - | ConstKey c -> combinesmall 1 (Constant.hash c) + | ConstKey c -> combinesmall 1 (Constant.CanOrd.hash c) | VarKey id -> combinesmall 2 (Id.hash id) | RelKey i -> combinesmall 3 (Int.hash i) | EvarKey evk -> combinesmall 4 (Evar.hash evk) diff --git a/lib/genarg.mli b/lib/genarg.mli index 88e9ff13e8..aac43db672 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -11,7 +11,7 @@ (** Generic arguments used by the extension mechanisms of several Coq ASTs. *) (** The route of a generic argument, from parsing to evaluation. -In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc. +In the following diagram, "object" can be ltac_expr, constr, tactic_value, etc. {% \begin{verbatim} %} parsing in_raw out_raw diff --git a/library/coqlib.ml b/library/coqlib.ml index 04a6e159eb..82d1ecacb5 100644 --- a/library/coqlib.ml +++ b/library/coqlib.ml @@ -45,7 +45,7 @@ let has_ref s = CString.Map.mem s !table let check_ind_ref s ind = match CString.Map.find s !table with - | GlobRef.IndRef r -> eq_ind r ind + | GlobRef.IndRef r -> Ind.CanOrd.equal r ind | _ -> false | exception Not_found -> false @@ -84,7 +84,7 @@ let gen_reference_in_modules locstr dirs s = let dirs = List.map make_dir dirs in let qualid = qualid_of_string s in let all = Nametab.locate_all qualid in - let all = List.sort_uniquize GlobRef.Ordered_env.compare all in + let all = List.sort_uniquize GlobRef.UserOrd.compare all in let these = List.filter (has_suffix_in_dirs dirs) all in match these with | [x] -> x diff --git a/library/globnames.ml b/library/globnames.ml index bc24fbf096..654349dea0 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -98,14 +98,14 @@ module ExtRefOrdered = struct let equal x y = x == y || match x, y with - | TrueGlobal rx, TrueGlobal ry -> GlobRef.Ordered_env.equal rx ry + | TrueGlobal rx, TrueGlobal ry -> GlobRef.UserOrd.equal rx ry | SynDef knx, SynDef kny -> KerName.equal knx kny | (TrueGlobal _ | SynDef _), _ -> false let compare x y = if x == y then 0 else match x, y with - | TrueGlobal rx, TrueGlobal ry -> GlobRef.Ordered_env.compare rx ry + | TrueGlobal rx, TrueGlobal ry -> GlobRef.UserOrd.compare rx ry | SynDef knx, SynDef kny -> KerName.compare knx kny | TrueGlobal _, SynDef _ -> -1 | SynDef _, TrueGlobal _ -> 1 @@ -113,7 +113,7 @@ module ExtRefOrdered = struct open Hashset.Combine let hash = function - | TrueGlobal gr -> combinesmall 1 (GlobRef.Ordered_env.hash gr) + | TrueGlobal gr -> combinesmall 1 (GlobRef.UserOrd.hash gr) | SynDef kn -> combinesmall 2 (KerName.hash kn) end diff --git a/library/lib.ml b/library/lib.ml index 830777003b..fa0a95d366 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -525,8 +525,8 @@ let init () = let mp_of_global = let open GlobRef in function | VarRef id -> !lib_state.path_prefix.Nametab.obj_mp | ConstRef cst -> Names.Constant.modpath cst - | IndRef ind -> Names.ind_modpath ind - | ConstructRef constr -> Names.constr_modpath constr + | IndRef ind -> Names.Ind.modpath ind + | ConstructRef constr -> Names.Construct.modpath constr let rec dp_of_mp = function |Names.MPfile dp -> dp diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 644493a010..349e14bba3 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -80,11 +80,11 @@ let test_array_closing = } GRAMMAR EXTEND Gram - GLOBAL: binder_constr lconstr constr operconstr + GLOBAL: binder_constr lconstr constr term universe_level universe_name sort sort_family - global constr_pattern lconstr_pattern Constr.ident + global constr_pattern cpattern Constr.ident closed_binder open_binders binder binders binders_fixannot - record_declaration typeclass_constraint pattern appl_arg type_cstr; + record_declaration typeclass_constraint pattern arg type_cstr; Constr.ident: [ [ id = Prim.ident -> { id } ] ] ; @@ -97,7 +97,7 @@ GRAMMAR EXTEND Gram constr_pattern: [ [ c = constr -> { c } ] ] ; - lconstr_pattern: + cpattern: [ [ c = lconstr -> { c } ] ] ; sort: @@ -131,48 +131,48 @@ GRAMMAR EXTEND Gram | u = universe_expr -> { [u] } ] ] ; lconstr: - [ [ c = operconstr LEVEL "200" -> { c } ] ] + [ [ c = term LEVEL "200" -> { c } ] ] ; constr: - [ [ c = operconstr LEVEL "8" -> { c } - | "@"; f=global; i = univ_instance -> { CAst.make ~loc @@ CAppExpl((None,f,i),[]) } ] ] + [ [ c = term LEVEL "8" -> { c } + | "@"; f=global; i = univ_annot -> { CAst.make ~loc @@ CAppExpl((None,f,i),[]) } ] ] ; - operconstr: + term: [ "200" RIGHTA [ c = binder_constr -> { c } ] | "100" RIGHTA - [ c1 = operconstr; "<:"; c2 = operconstr LEVEL "200" -> + [ c1 = term; "<:"; c2 = term LEVEL "200" -> { CAst.make ~loc @@ CCast(c1, CastVM c2) } - | c1 = operconstr; "<<:"; c2 = operconstr LEVEL "200" -> + | c1 = term; "<<:"; c2 = term LEVEL "200" -> { CAst.make ~loc @@ CCast(c1, CastNative c2) } - | c1 = operconstr; ":"; c2 = operconstr LEVEL "200" -> + | c1 = term; ":"; c2 = term LEVEL "200" -> { CAst.make ~loc @@ CCast(c1, CastConv c2) } - | c1 = operconstr; ":>" -> + | c1 = term; ":>" -> { CAst.make ~loc @@ CCast(c1, CastCoerce) } ] | "99" RIGHTA [ ] | "90" RIGHTA [ ] | "10" LEFTA - [ f = operconstr; args = LIST1 appl_arg -> { CAst.make ~loc @@ CApp((None,f),args) } - | "@"; f = global; i = univ_instance; args = LIST0 NEXT -> { CAst.make ~loc @@ CAppExpl((None,f,i),args) } + [ f = term; args = LIST1 arg -> { CAst.make ~loc @@ CApp((None,f),args) } + | "@"; f = global; i = univ_annot; args = LIST0 NEXT -> { CAst.make ~loc @@ CAppExpl((None,f,i),args) } | "@"; lid = pattern_ident; args = LIST1 identref -> { let { CAst.loc = locid; v = id } = lid in let args = List.map (fun x -> CAst.make @@ CRef (qualid_of_ident ?loc:x.CAst.loc x.CAst.v, None), None) args in CAst.make ~loc @@ CApp((None, CAst.make ?loc:locid @@ CPatVar id),args) } ] | "9" - [ ".."; c = operconstr LEVEL "0"; ".." -> + [ ".."; c = term LEVEL "0"; ".." -> { CAst.make ~loc @@ CAppExpl ((None, (qualid_of_ident ~loc ldots_var), None),[c]) } ] | "8" [ ] | "1" LEFTA - [ c = operconstr; ".("; f = global; args = LIST0 appl_arg; ")" -> + [ c = term; ".("; f = global; args = LIST0 arg; ")" -> { CAst.make ~loc @@ CApp((Some (List.length args+1), CAst.make @@ CRef (f,None)),args@[c,None]) } - | c = operconstr; ".("; "@"; f = global; - args = LIST0 (operconstr LEVEL "9"); ")" -> + | c = term; ".("; "@"; f = global; + args = LIST0 (term LEVEL "9"); ")" -> { CAst.make ~loc @@ CAppExpl((Some (List.length args+1),f,None),args@[c]) } - | c = operconstr; "%"; key = IDENT -> { CAst.make ~loc @@ CDelimiters (key,c) } ] + | c = term; "%"; key = IDENT -> { CAst.make ~loc @@ CDelimiters (key,c) } ] | "0" [ c = atomic_constr -> { c } - | c = match_constr -> { c } - | "("; c = operconstr LEVEL "200"; ")" -> + | c = term_match -> { c } + | "("; c = term LEVEL "200"; ")" -> { (* Preserve parentheses around numerals so that constrintern does not collapse -(3) into the numeral -3. *) (match c.CAst.v with @@ -182,14 +182,14 @@ GRAMMAR EXTEND Gram | "{|"; c = record_declaration; bar_cbrace -> { c } | "{"; c = binder_constr ; "}" -> { CAst.make ~loc @@ CNotation(None,(InConstrEntry,"{ _ }"),([c],[],[],[])) } - | "`{"; c = operconstr LEVEL "200"; "}" -> + | "`{"; c = term LEVEL "200"; "}" -> { CAst.make ~loc @@ CGeneralization (MaxImplicit, None, c) } - | test_array_opening; "["; "|"; ls = array_elems; "|"; def = lconstr; ty = type_cstr; test_array_closing; "|"; "]"; u = univ_instance -> + | test_array_opening; "["; "|"; ls = array_elems; "|"; def = lconstr; ty = type_cstr; test_array_closing; "|"; "]"; u = univ_annot -> { let t = Array.make (List.length ls) def in List.iteri (fun i e -> t.(i) <- e) ls; CAst.make ~loc @@ CArray(u, t, def, ty) } - | "`("; c = operconstr LEVEL "200"; ")" -> + | "`("; c = term LEVEL "200"; ")" -> { CAst.make ~loc @@ CGeneralization (Explicit, None, c) } ] ] ; array_elems: @@ -208,55 +208,55 @@ GRAMMAR EXTEND Gram { (id, mkLambdaCN ~loc bl c) } ] ] ; binder_constr: - [ [ "forall"; bl = open_binders; ","; c = operconstr LEVEL "200" -> + [ [ "forall"; bl = open_binders; ","; c = term LEVEL "200" -> { mkProdCN ~loc bl c } - | "fun"; bl = open_binders; "=>"; c = operconstr LEVEL "200" -> + | "fun"; bl = open_binders; "=>"; c = term LEVEL "200" -> { mkLambdaCN ~loc bl c } | "let"; id=name; bl = binders; ty = let_type_cstr; ":="; - c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> + c1 = term LEVEL "200"; "in"; c2 = term LEVEL "200" -> { let ty,c1 = match ty, c1 with | (_,None), { CAst.v = CCast(c, CastConv t) } -> (Loc.tag ?loc:(constr_loc t) @@ Some t), c (* Tolerance, see G_vernac.def_body *) | _, _ -> ty, c1 in CAst.make ~loc @@ CLetIn(id,mkLambdaCN ?loc:(constr_loc c1) bl c1, Option.map (mkProdCN ?loc:(fst ty) bl) (snd ty), c2) } - | "let"; "fix"; fx = fix_decl; "in"; c = operconstr LEVEL "200" -> + | "let"; "fix"; fx = fix_decl; "in"; c = term LEVEL "200" -> { let {CAst.loc=locf;CAst.v=({CAst.loc=li;CAst.v=id} as lid,_,_,_,_ as dcl)} = fx in let fix = CAst.make ?loc:locf @@ CFix (lid,[dcl]) in CAst.make ~loc @@ CLetIn( CAst.make ?loc:li @@ Name id,fix,None,c) } - | "let"; "cofix"; fx = cofix_decl; "in"; c = operconstr LEVEL "200" -> + | "let"; "cofix"; fx = cofix_body; "in"; c = term LEVEL "200" -> { let {CAst.loc=locf;CAst.v=({CAst.loc=li;CAst.v=id} as lid,_,_,_ as dcl)} = fx in let cofix = CAst.make ?loc:locf @@ CCoFix (lid,[dcl]) in CAst.make ~loc @@ CLetIn( CAst.make ?loc:li @@ Name id,cofix,None,c) } | "let"; lb = ["("; l=LIST0 name SEP ","; ")" -> { l } | "()" -> { [] } ]; - po = return_type; ":="; c1 = operconstr LEVEL "200"; "in"; - c2 = operconstr LEVEL "200" -> + po = as_return_type; ":="; c1 = term LEVEL "200"; "in"; + c2 = term LEVEL "200" -> { CAst.make ~loc @@ CLetTuple (lb,po,c1,c2) } - | "let"; "'"; p = pattern LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; - "in"; c2 = operconstr LEVEL "200" -> + | "let"; "'"; p = pattern LEVEL "200"; ":="; c1 = term LEVEL "200"; + "in"; c2 = term LEVEL "200" -> { CAst.make ~loc @@ CCases (LetPatternStyle, None, [c1, None, None], [CAst.make ~loc ([[p]], c2)]) } - | "let"; "'"; p = pattern LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; - rt = case_type; "in"; c2 = operconstr LEVEL "200" -> + | "let"; "'"; p = pattern LEVEL "200"; ":="; c1 = term LEVEL "200"; + rt = case_type; "in"; c2 = term LEVEL "200" -> { CAst.make ~loc @@ CCases (LetPatternStyle, Some rt, [c1, aliasvar p, None], [CAst.make ~loc ([[p]], c2)]) } | "let"; "'"; p = pattern LEVEL "200"; "in"; t = pattern LEVEL "200"; - ":="; c1 = operconstr LEVEL "200"; rt = case_type; - "in"; c2 = operconstr LEVEL "200" -> + ":="; c1 = term LEVEL "200"; rt = case_type; + "in"; c2 = term LEVEL "200" -> { CAst.make ~loc @@ CCases (LetPatternStyle, Some rt, [c1, aliasvar p, Some t], [CAst.make ~loc ([[p]], c2)]) } - | "if"; c = operconstr LEVEL "200"; po = return_type; - "then"; b1 = operconstr LEVEL "200"; - "else"; b2 = operconstr LEVEL "200" -> + | "if"; c = term LEVEL "200"; po = as_return_type; + "then"; b1 = term LEVEL "200"; + "else"; b2 = term LEVEL "200" -> { CAst.make ~loc @@ CIf (c, po, b1, b2) } | "fix"; c = fix_decls -> { let (id,dcls) = c in CAst.make ~loc @@ CFix (id,dcls) } | "cofix"; c = cofix_decls -> { let (id,dcls) = c in CAst.make ~loc @@ CCoFix (id,dcls) } ] ] ; - appl_arg: + arg: [ [ test_lpar_id_coloneq; "("; id = identref; ":="; c = lconstr; ")" -> { (c,Some (CAst.make ?loc:id.CAst.loc @@ ExplByName id.CAst.v)) } - | c=operconstr LEVEL "9" -> { (c,None) } ] ] + | c=term LEVEL "9" -> { (c,None) } ] ] ; atomic_constr: - [ [ g = global; i = univ_instance -> { CAst.make ~loc @@ CRef (g,i) } + [ [ g = global; i = univ_annot -> { CAst.make ~loc @@ CRef (g,i) } | s = sort -> { CAst.make ~loc @@ CSort s } | n = NUMBER-> { CAst.make ~loc @@ CPrim (Numeral (NumTok.SPlus,n)) } | s = string -> { CAst.make ~loc @@ CPrim (String s) } @@ -272,7 +272,7 @@ GRAMMAR EXTEND Gram [ [ "@{"; l = LIST1 inst SEP ";"; "}" -> { l } | -> { [] } ] ] ; - univ_instance: + univ_annot: [ [ "@{"; l = LIST0 universe_level; "}" -> { Some l } | -> { None } ] ] ; @@ -290,34 +290,34 @@ GRAMMAR EXTEND Gram { (id,List.map (fun x -> x.CAst.v) (dcl::dcls)) } ] ] ; cofix_decls: - [ [ dcl = cofix_decl -> { let (id,_,_,_) = dcl.CAst.v in (id,[dcl.CAst.v]) } - | dcl = cofix_decl; "with"; dcls = LIST1 cofix_decl SEP "with"; "for"; id = identref -> + [ [ dcl = cofix_body -> { let (id,_,_,_) = dcl.CAst.v in (id,[dcl.CAst.v]) } + | dcl = cofix_body; "with"; dcls = LIST1 cofix_body SEP "with"; "for"; id = identref -> { (id,List.map (fun x -> x.CAst.v) (dcl::dcls)) } ] ] ; fix_decl: [ [ id = identref; bl = binders_fixannot; ty = type_cstr; ":="; - c = operconstr LEVEL "200" -> + c = term LEVEL "200" -> { CAst.make ~loc (id,snd bl,fst bl,ty,c) } ] ] ; - cofix_decl: + cofix_body: [ [ id = identref; bl = binders; ty = type_cstr; ":="; - c = operconstr LEVEL "200" -> + c = term LEVEL "200" -> { CAst.make ~loc (id,bl,ty,c) } ] ] ; - match_constr: + term_match: [ [ "match"; ci = LIST1 case_item SEP ","; ty = OPT case_type; "with"; br = branches; "end" -> { CAst.make ~loc @@ CCases(RegularStyle,ty,ci,br) } ] ] ; case_item: - [ [ c = operconstr LEVEL "100"; + [ [ c = term LEVEL "100"; ona = OPT ["as"; id = name -> { id } ]; ty = OPT ["in"; t = pattern LEVEL "200" -> { t } ] -> { (c,ona,ty) } ] ] ; case_type: - [ [ "return"; ty = operconstr LEVEL "100" -> { ty } ] ] + [ [ "return"; ty = term LEVEL "100" -> { ty } ] ] ; - return_type: + as_return_type: [ [ a = OPT [ na = OPT["as"; na = name -> { na } ]; ty = case_type -> { (na,ty) } ] -> { match a with @@ -345,7 +345,7 @@ GRAMMAR EXTEND Gram pattern: [ "200" RIGHTA [ ] | "100" RIGHTA - [ p = pattern; ":"; ty = operconstr LEVEL "200" -> + [ p = pattern; ":"; ty = term LEVEL "200" -> { CAst.make ~loc @@ CPatCast (p, ty) } ] | "99" RIGHTA [ ] | "90" RIGHTA [ ] @@ -447,12 +447,12 @@ GRAMMAR EXTEND Gram [CLocalPattern (CAst.make ~loc (p, ty))] } ] ] ; typeclass_constraint: - [ [ "!" ; c = operconstr LEVEL "200" -> { (CAst.make ~loc Anonymous), true, c } - | "{"; id = name; "}"; ":" ; expl = [ "!" -> { true } | -> { false } ] ; c = operconstr LEVEL "200" -> + [ [ "!" ; c = term LEVEL "200" -> { (CAst.make ~loc Anonymous), true, c } + | "{"; id = name; "}"; ":" ; expl = [ "!" -> { true } | -> { false } ] ; c = term LEVEL "200" -> { id, expl, c } - | test_name_colon; iid = name; ":" ; expl = [ "!" -> { true } | -> { false } ] ; c = operconstr LEVEL "200" -> + | test_name_colon; iid = name; ":" ; expl = [ "!" -> { true } | -> { false } ] ; c = term LEVEL "200" -> { iid, expl, c } - | c = operconstr LEVEL "200" -> + | c = term LEVEL "200" -> { (CAst.make ~loc Anonymous), false, c } ] ] ; type_cstr: diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 996aa0925c..22b5e70311 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -308,7 +308,8 @@ module Constr = (* Entries that can be referred via the string -> Entry.t table *) let constr = Entry.create "constr" - let operconstr = Entry.create "operconstr" + let term = Entry.create "term" + let operconstr = term let constr_eoi = eoi_entry constr let lconstr = Entry.create "lconstr" let binder_constr = Entry.create "binder_constr" @@ -320,7 +321,8 @@ module Constr = let sort_family = Entry.create "sort_family" let pattern = Entry.create "pattern" let constr_pattern = Entry.create "constr_pattern" - let lconstr_pattern = Entry.create "lconstr_pattern" + let cpattern = Entry.create "cpattern" + let lconstr_pattern = cpattern let closed_binder = Entry.create "closed_binder" let binder = Entry.create "binder" let binders = Entry.create "binders" @@ -328,7 +330,8 @@ module Constr = let binders_fixannot = Entry.create "binders_fixannot" let typeclass_constraint = Entry.create "typeclass_constraint" let record_declaration = Entry.create "record_declaration" - let appl_arg = Entry.create "appl_arg" + let arg = Entry.create "arg" + let appl_arg = arg let type_cstr = Entry.create "type_cstr" end diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 8e60bbf504..ce4c91d51f 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -185,7 +185,9 @@ module Constr : val constr_eoi : constr_expr Entry.t val lconstr : constr_expr Entry.t val binder_constr : constr_expr Entry.t + val term : constr_expr Entry.t val operconstr : constr_expr Entry.t + [@@deprecated "Deprecated in 8.13; use 'term' instead"] val ident : Id.t Entry.t val global : qualid Entry.t val universe_name : Glob_term.glob_sort_name Entry.t @@ -194,7 +196,9 @@ module Constr : val sort_family : Sorts.family Entry.t val pattern : cases_pattern_expr Entry.t val constr_pattern : constr_expr Entry.t + val cpattern : constr_expr Entry.t val lconstr_pattern : constr_expr Entry.t + [@@deprecated "Deprecated in 8.13; use 'cpattern' instead"] val closed_binder : local_binder_expr list Entry.t val binder : local_binder_expr list Entry.t (* closed_binder or variable *) val binders : local_binder_expr list Entry.t (* list of binder *) @@ -202,7 +206,9 @@ module Constr : val binders_fixannot : (local_binder_expr list * recursion_order_expr option) Entry.t val typeclass_constraint : (lname * bool * constr_expr) Entry.t val record_declaration : constr_expr Entry.t + val arg : (constr_expr * explicitation CAst.t option) Entry.t val appl_arg : (constr_expr * explicitation CAst.t option) Entry.t + [@@deprecated "Deprecated in 8.13; use 'arg' instead"] val type_cstr : constr_expr Entry.t end diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 23f8fe04a3..ac2058ba1b 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -115,7 +115,7 @@ module Bool = struct | Case (info, r, _iv, arg, pats) -> let is_bool = let i = info.ci_ind in - Names.eq_ind i (Lazy.force ind) + Names.Ind.CanOrd.equal i (Lazy.force ind) in if is_bool then Ifb ((aux arg), (aux pats.(0)), (aux pats.(1))) diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 6f5c910297..129b220680 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -145,7 +145,7 @@ let rec term_equal t1 t2 = | Appli (t1, u1), Appli (t2, u2) -> term_equal t1 t2 && term_equal u1 u2 | Constructor {ci_constr=(c1,u1); ci_arity=i1; ci_nhyps=j1}, Constructor {ci_constr=(c2,u2); ci_arity=i2; ci_nhyps=j2} -> - Int.equal i1 i2 && Int.equal j1 j2 && eq_constructor c1 c2 (* FIXME check eq? *) + Int.equal i1 i2 && Int.equal j1 j2 && Construct.CanOrd.equal c1 c2 (* FIXME check eq? *) | _ -> false open Hashset.Combine @@ -155,7 +155,7 @@ let rec hash_term = function | Product (s1, s2) -> combine3 2 (Sorts.hash s1) (Sorts.hash s2) | Eps i -> combine 3 (Id.hash i) | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2) - | Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (constructor_hash c) i j + | Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (Construct.CanOrd.hash c) i j type ccpattern = PApp of term * ccpattern list (* arguments are reversed *) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 2dca1d5e49..6869f9c47e 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -741,7 +741,7 @@ and extract_cst_app env sg mle mlt kn args = (* Can we instantiate types variables for this constant ? *) (* In Ocaml, inside the definition of this constant, the answer is no. *) let instantiated = - if lang () == Ocaml && List.mem_f Constant.equal kn !current_fixpoints + if lang () == Ocaml && List.mem_f Constant.CanOrd.equal kn !current_fixpoints then var2var' (snd schema) else instantiation schema in diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index b1ce10985a..21ec80abbc 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -685,7 +685,7 @@ let is_regular_match br = | _ -> raise Impossible in let is_ref i tr = match get_r tr with - | GlobRef.ConstructRef (ind', j) -> eq_ind ind ind' && Int.equal j (i + 1) + | GlobRef.ConstructRef (ind', j) -> Ind.CanOrd.equal ind ind' && Int.equal j (i + 1) | _ -> false in Array.for_all_i is_ref 0 br diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index f8449bcda1..e56d66ca2d 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -32,7 +32,7 @@ module Refset' = GlobRef.Set_env let occur_kn_in_ref kn = let open GlobRef in function | IndRef (kn',_) - | ConstructRef ((kn',_),_) -> MutInd.equal kn kn' + | ConstructRef ((kn',_),_) -> MutInd.CanOrd.equal kn kn' | ConstRef _ | VarRef _ -> false let repr_of_r = let open GlobRef in function diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index f13901c36d..4adad53899 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -38,7 +38,7 @@ let compare_gr id1 id2 = if id1==id2 then 0 else if id1==dummy_id then 1 else if id2==dummy_id then -1 - else GlobRef.Ordered.compare id1 id2 + else GlobRef.CanOrd.compare id1 id2 module OrderedInstance= struct diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index db3631daa4..99c5f85125 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -62,7 +62,7 @@ module Hitem= struct type t = h_item let compare (id1,co1) (id2,co2)= - let c = GlobRef.Ordered.compare id1 id2 in + let c = GlobRef.CanOrd.compare id1 id2 in if c = 0 then let cmp (i1, c1) (i2, c2) = let c = Int.compare i1 i2 in diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index e50c6087bb..73eb943418 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -674,7 +674,7 @@ let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos |Prod _ -> let new_infos = {dyn_infos with info = (f, args)} in build_proof_args env sigma do_finalize new_infos - | Const (c, _) when not (List.mem_f Constant.equal c fnames) -> + | Const (c, _) when not (List.mem_f Constant.CanOrd.equal c fnames) -> let new_infos = {dyn_infos with info = (f, args)} in (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) build_proof_args env sigma do_finalize new_infos diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 1ab747ca09..0ab9ac65d7 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -100,8 +100,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match Constr.kind c with - | Ind ((u, _), _) -> MutInd.equal u rel_as_kn - | Construct (((u, _), _), _) -> MutInd.equal u rel_as_kn + | Ind ((u, _), _) -> Environ.QMutInd.equal env u rel_as_kn + | Construct (((u, _), _), _) -> Environ.QMutInd.equal env u rel_as_kn | _ -> false in let get_fun_num c = diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index bbc4df7dde..ca6ae150a7 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -147,19 +147,19 @@ END module Vernac = Pvernac.Vernac_ module Tactic = Pltac -let (wit_function_rec_definition_loc : Vernacexpr.fixpoint_expr Loc.located Genarg.uniform_genarg_type) = - Genarg.create_arg "function_rec_definition_loc" +let (wit_function_fix_definition : Vernacexpr.fixpoint_expr Loc.located Genarg.uniform_genarg_type) = + Genarg.create_arg "function_fix_definition" -let function_rec_definition_loc = - Pcoq.create_generic_entry2 "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) +let function_fix_definition = + Pcoq.create_generic_entry2 "function_fix_definition" (Genarg.rawwit wit_function_fix_definition) } GRAMMAR EXTEND Gram - GLOBAL: function_rec_definition_loc ; + GLOBAL: function_fix_definition ; - function_rec_definition_loc: - [ [ g = Vernac.rec_definition -> { Loc.tag ~loc g } ]] + function_fix_definition: + [ [ g = Vernac.fix_definition -> { Loc.tag ~loc g } ]] ; END @@ -168,7 +168,7 @@ END let () = let raw_printer env sigma _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in - Pptactic.declare_extra_vernac_genarg_pprule wit_function_rec_definition_loc raw_printer + Pptactic.declare_extra_vernac_genarg_pprule wit_function_fix_definition raw_printer let is_proof_termination_interactively_checked recsl = List.exists (function @@ -196,7 +196,7 @@ let is_interactive recsl = } VERNAC COMMAND EXTEND Function STATE CUSTOM -| ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] +| ["Function" ne_function_fix_definition_list_sep(recsl,"with")] => { classify_funind recsl } -> { if is_interactive recsl then diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 012fcee486..314c8abcaf 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -1316,9 +1316,9 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : _ list = let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + let eq c1 c2 = Environ.QConstant.equal env c1 c2 in List.map - (function - | cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) + (function cst -> List.assoc_f eq (fst cst) this_block_funs_indexes) funs in let ind_list = @@ -2228,7 +2228,8 @@ let build_case_scheme fa = let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in - List.assoc_f Constant.equal funs this_block_funs_indexes + let eq c1 c2 = Environ.QConstant.equal env c1 c2 in + List.assoc_f eq funs this_block_funs_indexes in let ind, sf = let ind = (first_fun_kn, funs_indexes) in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 6ed61043f9..767a9ec39b 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -332,7 +332,7 @@ let add_pat_variables sigma pat typ env : Environ.env = let constructors = Inductiveops.get_constructors env indf in let constructor : Inductiveops.constructor_summary = List.find - (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) + (fun cs -> Construct.CanOrd.equal c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in let cs_args_types : types list = @@ -402,7 +402,8 @@ let rec pattern_to_term_and_type env typ = let constructors = Inductiveops.get_constructors env indf in let constructor = List.find - (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) + (fun cs -> + Construct.CanOrd.equal (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in let cs_args_types : types list = diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 8e1331ace9..164a446fe3 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -444,7 +444,8 @@ let rec are_unifiable_aux = function match (DAst.get l, DAst.get r) with | PatVar _, _ | _, PatVar _ -> are_unifiable_aux eqs | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> - if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + if not (Construct.CanOrd.equal constructor2 constructor1) then + raise NotUnifiable else let eqs' = try List.combine cpl1 cpl2 @ eqs @@ -464,7 +465,8 @@ let rec eq_cases_pattern_aux = function match (DAst.get l, DAst.get r) with | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> - if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + if not (Construct.CanOrd.equal constructor2 constructor1) then + raise NotUnifiable else let eqs' = try List.combine cpl1 cpl2 @ eqs diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 5d631aac84..118a917381 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -27,12 +27,13 @@ open Indfun_common *) let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> + let env = Proofview.Goal.env gl in let sigma = project gl in let typ = pf_get_hyp_typ hid gl in match EConstr.kind sigma typ with | App (i, args) when isInd sigma i -> let ((kn', num) as ind'), u = destInd sigma i in - if MutInd.equal kn kn' then + if Environ.QMutInd.equal env kn kn' then (* We have generated a graph hypothesis so that we must change it if we can *) let info = match find_Function_of_graph ind' with diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index ad4374dba3..ff4a82f864 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -41,7 +41,7 @@ let () = create_generic_quotation "ipattern" Pltac.simple_intropattern wit_simpl let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Stdarg.wit_open_constr let () = let inject (loc, v) = Tacexpr.Tacexp v in - Tacentries.create_ltac_quotation "ltac" inject (Pltac.tactic_expr, Some 5) + Tacentries.create_ltac_quotation "ltac" inject (Pltac.ltac_expr, Some 5) (** Backward-compatible tactic notation entry names *) diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 6cf5d30a95..c38a4dcd90 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -74,22 +74,22 @@ let hint = G_proofs.hint } GRAMMAR EXTEND Gram - GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint + GLOBAL: tactic tacdef_body ltac_expr binder_tactic tactic_value command hint tactic_mode constr_may_eval constr_eval toplevel_selector - operconstr; + term; tactic_then_last: - [ [ "|"; lta = LIST0 (OPT tactic_expr) SEP "|" -> + [ [ "|"; lta = LIST0 (OPT ltac_expr) SEP "|" -> { Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) } | -> { [||] } ] ] ; - tactic_then_gen: - [ [ ta = tactic_expr; "|"; tg = tactic_then_gen -> { let (first,last) = tg in (ta::first, last) } - | ta = tactic_expr; ".."; l = tactic_then_last -> { ([], Some (ta, l)) } + for_each_goal: + [ [ ta = ltac_expr; "|"; tg = for_each_goal -> { let (first,last) = tg in (ta::first, last) } + | ta = ltac_expr; ".."; l = tactic_then_last -> { ([], Some (ta, l)) } | ".."; l = tactic_then_last -> { ([], Some (TacId [], l)) } - | ta = tactic_expr -> { ([ta], None) } - | "|"; tg = tactic_then_gen -> { let (first,last) = tg in (TacId [] :: first, last) } + | ta = ltac_expr -> { ([ta], None) } + | "|"; tg = for_each_goal -> { let (first,last) = tg in (TacId [] :: first, last) } | -> { ([TacId []], None) } ] ] ; @@ -97,13 +97,13 @@ GRAMMAR EXTEND Gram for [TacExtend] *) [ [ "[" ; l = OPT">" -> { if Option.is_empty l then true else false } ] ] ; - tactic_expr: + ltac_expr: [ "5" RIGHTA [ te = binder_tactic -> { te } ] | "4" LEFTA - [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> { TacThen (ta0, ta1) } - | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> { TacThen (ta0,ta1) } - | ta0 = tactic_expr; ";"; l = tactic_then_locality; tg = tactic_then_gen; "]" -> { + [ ta0 = ltac_expr; ";"; ta1 = binder_tactic -> { TacThen (ta0, ta1) } + | ta0 = ltac_expr; ";"; ta1 = ltac_expr -> { TacThen (ta0,ta1) } + | ta0 = ltac_expr; ";"; l = tactic_then_locality; tg = for_each_goal; "]" -> { let (first,tail) = tg in match l , tail with | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) @@ -111,51 +111,51 @@ GRAMMAR EXTEND Gram | false , None -> TacThen (ta0,TacDispatch first) | true , None -> TacThens (ta0,first) } ] | "3" RIGHTA - [ IDENT "try"; ta = tactic_expr -> { TacTry ta } - | IDENT "do"; n = int_or_var; ta = tactic_expr -> { TacDo (n,ta) } - | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> { TacTimeout (n,ta) } - | IDENT "time"; s = OPT string; ta = tactic_expr -> { TacTime (s,ta) } - | IDENT "repeat"; ta = tactic_expr -> { TacRepeat ta } - | IDENT "progress"; ta = tactic_expr -> { TacProgress ta } - | IDENT "once"; ta = tactic_expr -> { TacOnce ta } - | IDENT "exactly_once"; ta = tactic_expr -> { TacExactlyOnce ta } - | IDENT "infoH"; ta = tactic_expr -> { TacShowHyps ta } + [ IDENT "try"; ta = ltac_expr -> { TacTry ta } + | IDENT "do"; n = int_or_var; ta = ltac_expr -> { TacDo (n,ta) } + | IDENT "timeout"; n = int_or_var; ta = ltac_expr -> { TacTimeout (n,ta) } + | IDENT "time"; s = OPT string; ta = ltac_expr -> { TacTime (s,ta) } + | IDENT "repeat"; ta = ltac_expr -> { TacRepeat ta } + | IDENT "progress"; ta = ltac_expr -> { TacProgress ta } + | IDENT "once"; ta = ltac_expr -> { TacOnce ta } + | IDENT "exactly_once"; ta = ltac_expr -> { TacExactlyOnce ta } + | IDENT "infoH"; ta = ltac_expr -> { TacShowHyps ta } (*To do: put Abstract in Refiner*) | IDENT "abstract"; tc = NEXT -> { TacAbstract (tc,None) } | IDENT "abstract"; tc = NEXT; "using"; s = ident -> { TacAbstract (tc,Some s) } - | sel = selector; ta = tactic_expr -> { TacSelect (sel, ta) } ] + | IDENT "only"; sel = selector; ":"; ta = ltac_expr -> { TacSelect (sel, ta) } ] (*End of To do*) | "2" RIGHTA - [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> { TacOr (ta0,ta1) } - | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> { TacOr (ta0,ta1) } - | IDENT "tryif" ; ta = tactic_expr ; - "then" ; tat = tactic_expr ; - "else" ; tae = tactic_expr -> { TacIfThenCatch(ta,tat,tae) } - | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> { TacOrelse (ta0,ta1) } - | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> { TacOrelse (ta0,ta1) } ] + [ ta0 = ltac_expr; "+"; ta1 = binder_tactic -> { TacOr (ta0,ta1) } + | ta0 = ltac_expr; "+"; ta1 = ltac_expr -> { TacOr (ta0,ta1) } + | IDENT "tryif" ; ta = ltac_expr ; + "then" ; tat = ltac_expr ; + "else" ; tae = ltac_expr -> { TacIfThenCatch(ta,tat,tae) } + | ta0 = ltac_expr; "||"; ta1 = binder_tactic -> { TacOrelse (ta0,ta1) } + | ta0 = ltac_expr; "||"; ta1 = ltac_expr -> { TacOrelse (ta0,ta1) } ] | "1" RIGHTA [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> { TacMatchGoal (b,false,mrl) } | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; mrl = match_context_list; "end" -> { TacMatchGoal (b,true,mrl) } - | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> + | b = match_key; c = ltac_expr; "with"; mrl = match_list; "end" -> { TacMatch (b,c,mrl) } - | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + | IDENT "first" ; "["; l = LIST0 ltac_expr SEP "|"; "]" -> { TacFirst l } - | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + | IDENT "solve" ; "["; l = LIST0 ltac_expr SEP "|"; "]" -> { TacSolve l } | IDENT "idtac"; l = LIST0 message_token -> { TacId l } | g=failkw; n = [ n = int_or_var -> { n } | -> { fail_default_value } ]; l = LIST0 message_token -> { TacFail (g,n,l) } | st = simple_tactic -> { st } - | a = tactic_arg -> { TacArg(CAst.make ~loc a) } - | r = reference; la = LIST0 tactic_arg_compat -> + | a = tactic_value -> { TacArg(CAst.make ~loc a) } + | r = reference; la = LIST0 tactic_arg -> { TacArg(CAst.make ~loc @@ TacCall (CAst.make ~loc (r,la))) } ] | "0" - [ "("; a = tactic_expr; ")" -> { a } - | "["; ">"; tg = tactic_then_gen; "]" -> { + [ "("; a = ltac_expr; ")" -> { a } + | "["; ">"; tg = for_each_goal; "]" -> { let (tf,tail) = tg in begin match tail with | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) @@ -166,24 +166,24 @@ GRAMMAR EXTEND Gram failkw: [ [ IDENT "fail" -> { TacLocal } | IDENT "gfail" -> { TacGlobal } ] ] ; - (* binder_tactic: level 5 of tactic_expr *) + (* binder_tactic: level 5 of ltac_expr *) binder_tactic: [ RIGHTA - [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> + [ "fun"; it = LIST1 input_fun ; "=>"; body = ltac_expr LEVEL "5" -> { TacFun (it,body) } | "let"; isrec = [IDENT "rec" -> { true } | -> { false } ]; llc = LIST1 let_clause SEP "with"; "in"; - body = tactic_expr LEVEL "5" -> { TacLetIn (isrec,llc,body) } ] ] + body = ltac_expr LEVEL "5" -> { TacLetIn (isrec,llc,body) } ] ] ; (* Tactic arguments to the right of an application *) - tactic_arg_compat: - [ [ a = tactic_arg -> { a } + tactic_arg: + [ [ a = tactic_value -> { a } | c = Constr.constr -> { (match c with { CAst.v = CRef (r,None) } -> Reference r | c -> ConstrMayEval (ConstrTerm c)) } (* Unambiguous entries: tolerated w/o "ltac:" modifier *) | "()" -> { TacGeneric (None, genarg_of_unit ()) } ] ] ; (* Can be used as argument and at toplevel in tactic expressions. *) - tactic_arg: + tactic_value: [ [ c = constr_eval -> { ConstrMayEval c } | IDENT "fresh"; l = LIST0 fresh_id -> { TacFreshId l } | IDENT "type_term"; c=uconstr -> { TacPretype c } @@ -223,20 +223,20 @@ GRAMMAR EXTEND Gram | l = ident -> { Name.Name l } ] ] ; let_clause: - [ [ idr = identref; ":="; te = tactic_expr -> + [ [ idr = identref; ":="; te = ltac_expr -> { (CAst.map (fun id -> Name id) idr, arg_of_expr te) } - | na = ["_" -> { CAst.make ~loc Anonymous } ]; ":="; te = tactic_expr -> + | na = ["_" -> { CAst.make ~loc Anonymous } ]; ":="; te = ltac_expr -> { (na, arg_of_expr te) } - | idr = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> + | idr = identref; args = LIST1 input_fun; ":="; te = ltac_expr -> { (CAst.map (fun id -> Name id) idr, arg_of_expr (TacFun(args,te))) } ] ] ; match_pattern: [ [ IDENT "context"; oid = OPT Constr.ident; - "["; pc = Constr.lconstr_pattern; "]" -> + "["; pc = Constr.cpattern; "]" -> { Subterm (oid, pc) } - | pc = Constr.lconstr_pattern -> { Term pc } ] ] + | pc = Constr.cpattern -> { Term pc } ] ] ; - match_hyps: + match_hyp: [ [ na = name; ":"; mp = match_pattern -> { Hyp (na, mp) } | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> { Def (na, mpv, mpt) } | na = name; ":="; mpv = match_pattern -> @@ -250,19 +250,19 @@ GRAMMAR EXTEND Gram ] ] ; match_context_rule: - [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "=>"; te = tactic_expr -> { Pat (largs, mp, te) } - | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "]"; "=>"; te = tactic_expr -> { Pat (largs, mp, te) } - | "_"; "=>"; te = tactic_expr -> { All te } ] ] + [ [ largs = LIST0 match_hyp SEP ","; "|-"; mp = match_pattern; + "=>"; te = ltac_expr -> { Pat (largs, mp, te) } + | "["; largs = LIST0 match_hyp SEP ","; "|-"; mp = match_pattern; + "]"; "=>"; te = ltac_expr -> { Pat (largs, mp, te) } + | "_"; "=>"; te = ltac_expr -> { All te } ] ] ; match_context_list: [ [ mrl = LIST1 match_context_rule SEP "|" -> { mrl } | "|"; mrl = LIST1 match_context_rule SEP "|" -> { mrl } ] ] ; match_rule: - [ [ mp = match_pattern; "=>"; te = tactic_expr -> { Pat ([],mp,te) } - | "_"; "=>"; te = tactic_expr -> { All te } ] ] + [ [ mp = match_pattern; "=>"; te = ltac_expr -> { Pat ([],mp,te) } + | "_"; "=>"; te = ltac_expr -> { All te } ] ] ; match_list: [ [ mrl = LIST1 match_rule SEP "|" -> { mrl } @@ -282,13 +282,13 @@ GRAMMAR EXTEND Gram (* Definitions for tactics *) tacdef_body: [ [ name = Constr.global; it=LIST1 input_fun; - redef = ltac_def_kind; body = tactic_expr -> + redef = ltac_def_kind; body = ltac_expr -> { if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) else let id = reference_to_id name in Tacexpr.TacticDefinition (id, TacFun (it, body)) } | name = Constr.global; redef = ltac_def_kind; - body = tactic_expr -> + body = ltac_expr -> { if redef then Tacexpr.TacticRedefinition (name, body) else let id = reference_to_id name in @@ -296,7 +296,7 @@ GRAMMAR EXTEND Gram ] ] ; tactic: - [ [ tac = tactic_expr -> { tac } ] ] + [ [ tac = ltac_expr -> { tac } ] ] ; range_selector: @@ -314,15 +314,12 @@ GRAMMAR EXTEND Gram { let open Goal_select in Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l } ] ] ; - selector_body: + selector: [ [ l = range_selector_or_nth -> { l } | test_bracket_ident; "["; id = ident; "]" -> { Goal_select.SelectId id } ] ] ; - selector: - [ [ IDENT "only"; sel = selector_body; ":" -> { sel } ] ] - ; toplevel_selector: - [ [ sel = selector_body; ":" -> { sel } + [ [ sel = selector; ":" -> { sel } | "!"; ":" -> { Goal_select.SelectAlreadyFocused } | IDENT "all"; ":" -> { Goal_select.SelectAll } ] ] ; @@ -343,8 +340,8 @@ GRAMMAR EXTEND Gram tac = Pltac.tactic -> { Vernacexpr.HintsExtern (n,c, in_tac tac) } ] ] ; - operconstr: LEVEL "0" - [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> + term: LEVEL "0" + [ [ IDENT "ltac"; ":"; "("; tac = Pltac.ltac_expr; ")" -> { let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in CAst.make ~loc @@ CHole (None, IntroAnonymous, Some arg) } ] ] ; @@ -402,7 +399,7 @@ VERNAC { tactic_mode } EXTEND VernacSolve STATE proof { classify_as_proofstep } -> { let g = Option.default (Goal_select.get_default_goal_selector ()) g in let global = match g with Goal_select.SelectAll | Goal_select.SelectList _ -> true | _ -> false in - let t = ComTactic.I (Tacinterp.hide_interp, { Tacinterp.global; ast = t; }) in + let t = Tacinterp.hide_interp { Tacinterp.global; ast = t; } in ComTactic.solve g ~info t ~with_end_tac } END @@ -415,7 +412,7 @@ VERNAC { tactic_mode } EXTEND VernacSolveParallel STATE proof VtProofStep{ proof_block_detection = pbr } } -> { let t, abstract = rm_abstract t in - let t = ComTactic.I (Tacinterp.hide_interp, { Tacinterp.global = true; ast = t; }) in + let t = Tacinterp.hide_interp { Tacinterp.global = true; ast = t; } in ComTactic.solve_parallel ~info t ~abstract ~with_end_tac } END diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index c186a83a5c..97d75261c5 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -291,7 +291,7 @@ GRAMMAR EXTEND Gram ; simple_intropattern: [ [ pat = simple_intropattern_closed; - l = LIST0 ["%"; c = operconstr LEVEL "0" -> { c } ] -> + l = LIST0 ["%"; c = term LEVEL "0" -> { c } ] -> { let {CAst.loc=loc0;v=pat} = pat in let f c pat = let loc1 = Constrexpr_ops.constr_loc c in @@ -320,7 +320,7 @@ GRAMMAR EXTEND Gram with_bindings: [ [ "with"; bl = bindings -> { bl } | -> { NoBindings } ] ] ; - red_flags: + red_flag: [ [ IDENT "beta" -> { [FBeta] } | IDENT "iota" -> { [FMatch;FFix;FCofix] } | IDENT "match" -> { [FMatch] } @@ -337,7 +337,7 @@ GRAMMAR EXTEND Gram ] ] ; strategy_flag: - [ [ s = LIST1 red_flags -> { Redops.make_red_flag (List.flatten s) } + [ [ s = LIST1 red_flag -> { Redops.make_red_flag (List.flatten s) } | d = delta_flag -> { all_with d } ] ] ; @@ -460,7 +460,7 @@ GRAMMAR EXTEND Gram [ [ "as"; id = ident -> { Names.Name.Name id } | -> { Names.Name.Anonymous } ] ] ; by_tactic: - [ [ "by"; tac = tactic_expr LEVEL "3" -> { Some tac } + [ [ "by"; tac = ltac_expr LEVEL "3" -> { Some tac } | -> { None } ] ] ; rewriter : diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index b7b54143df..94e398fe5d 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -37,8 +37,10 @@ let clause_dft_concl = (* Main entries for ltac *) -let tactic_arg = Entry.create "tactic_arg" -let tactic_expr = Entry.create "tactic_expr" +let tactic_value = Entry.create "tactic_value" +let tactic_arg = tactic_value +let ltac_expr = Entry.create "ltac_expr" +let tactic_expr = ltac_expr let binder_tactic = Entry.create "binder_tactic" let tactic = Entry.create "tactic" diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index 8565c4b4d6..3a4a081c93 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -31,8 +31,12 @@ val simple_tactic : raw_tactic_expr Entry.t val simple_intropattern : constr_expr intro_pattern_expr CAst.t Entry.t val in_clause : Names.lident Locus.clause_expr Entry.t val clause_dft_concl : Names.lident Locus.clause_expr Entry.t +val tactic_value : raw_tactic_arg Entry.t val tactic_arg : raw_tactic_arg Entry.t + [@@deprecated "Deprecated in 8.13; use 'tactic_value' instead"] +val ltac_expr : raw_tactic_expr Entry.t val tactic_expr : raw_tactic_expr Entry.t + [@@deprecated "Deprecated in 8.13; use 'ltac_expr' instead"] val binder_tactic : raw_tactic_expr Entry.t val tactic : raw_tactic_expr Entry.t val tactic_eoi : raw_tactic_expr Entry.t diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index fe896f9351..87da304330 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -1334,8 +1334,8 @@ let () = ; Genprint.register_print0 wit_constr - (lift_env Ppconstr.pr_lconstr_expr) - (lift_env (fun env sigma (c, _) -> pr_lglob_constr_pptac env sigma c)) + (lift_env Ppconstr.pr_constr_expr) + (lift_env (fun env sigma (c, _) -> pr_glob_constr_pptac env sigma c)) (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 6a9fb5c2ea..5e199dad62 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** This module implements pretty-printers for tactic_expr syntactic +(** This module implements pretty-printers for ltac_expr syntactic objects and their subcomponents. *) open Genarg diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 9bb435f4dc..a1970cbce2 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -968,7 +968,7 @@ let fold_match ?(force=false) env sigma c = let unfold_match env sigma sk app = match EConstr.kind sigma app with - | App (f', args) when Constant.equal (fst (destConst sigma f')) sk -> + | App (f', args) when QConstant.equal env (fst (destConst sigma f')) sk -> let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in let v = EConstr.of_constr v in Reductionops.whd_beta env sigma (mkApp (v, args)) diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 6823b6411f..a05b36c1b4 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -33,7 +33,7 @@ type argument = Genarg.ArgT.any Extend.user_symbol let atactic n = if n = 5 then Pcoq.Symbol.nterm Pltac.binder_tactic - else Pcoq.Symbol.nterml Pltac.tactic_expr (string_of_int n) + else Pcoq.Symbol.nterml Pltac.ltac_expr (string_of_int n) type entry_name = EntryName : 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, _, 'a) Pcoq.Symbol.t -> entry_name @@ -116,7 +116,7 @@ let get_tactic_entry n = else if Int.equal n 5 then Pltac.binder_tactic, None else if 1<=n && n<5 then - Pltac.tactic_expr, Some (Gramlib.Gramext.Level (string_of_int n)) + Pltac.ltac_expr, Some (Gramlib.Gramext.Level (string_of_int n)) else user_err Pp.(str ("Invalid Tactic Notation level: "^(string_of_int n)^".")) @@ -383,7 +383,7 @@ let add_ml_tactic_notation name ~level ?deprecation prods = in List.iteri iter (List.rev prods); (* We call [extend_atomic_tactic] only for "basic tactics" (the ones - at tactic_expr level 0) *) + at ltac_expr level 0) *) if Int.equal level 0 then extend_atomic_tactic name prods (**********************************************************************) @@ -420,7 +420,7 @@ let create_ltac_quotation name cast (e, l) = in let action _ v _ _ _ loc = cast (Some loc, v) in let gram = (level, assoc, [Pcoq.Production.make rule action]) in - Pcoq.grammar_extend Pltac.tactic_arg {pos=None; data=[gram]} + Pcoq.grammar_extend Pltac.tactic_value {pos=None; data=[gram]} (** Command *) @@ -555,10 +555,10 @@ let print_located_tactic qid = let () = let entries = [ - AnyEntry Pltac.tactic_expr; + AnyEntry Pltac.ltac_expr; AnyEntry Pltac.binder_tactic; AnyEntry Pltac.simple_tactic; - AnyEntry Pltac.tactic_arg; + AnyEntry Pltac.tactic_value; ] in register_grammars_by_name "tactic" entries diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 12bfb4d09e..7728415ddd 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1997,7 +1997,7 @@ let interp_tac_gen lfun avoid_ids debug t = let interp t = interp_tac_gen Id.Map.empty Id.Set.empty (get_debug()) t (* MUST be marshallable! *) -type tactic_expr = { +type ltac_expr = { global: bool; ast: Tacexpr.raw_tactic_expr; } @@ -2019,7 +2019,7 @@ let hide_interp {global;ast} = hide_interp (Proofview.Goal.env gl) end -let hide_interp = ComTactic.register_tactic_interpreter "ltac1" hide_interp +let ComTactic.Interpreter hide_interp = ComTactic.register_tactic_interpreter "ltac1" hide_interp (***************************************************************************) (** Register standard arguments *) diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index 01d7306c9d..fe3079198c 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -126,12 +126,12 @@ val interp_tac_gen : value Id.Map.t -> Id.Set.t -> val interp : raw_tactic_expr -> unit Proofview.tactic (** Hides interpretation for pretty-print *) -type tactic_expr = { +type ltac_expr = { global: bool; ast: Tacexpr.raw_tactic_expr; } -val hide_interp : tactic_expr ComTactic.tactic_interpreter +val hide_interp : ltac_expr -> ComTactic.interpretable (** Internals that can be useful for syntax extensions. *) diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index d464ec4c06..61f90608b1 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -100,7 +100,7 @@ let rec make_form env sigma atom_env term = | Cast(a,_,_) -> make_form env sigma atom_env a | Ind (ind, _) -> - if Names.eq_ind ind (fst (Lazy.force li_False)) then + if Names.Ind.CanOrd.equal ind (fst (Lazy.force li_False)) then Bot else make_atom atom_env (normalize term) @@ -108,11 +108,11 @@ let rec make_form env sigma atom_env term = begin try let ind, _ = destInd sigma hd in - if Names.eq_ind ind (fst (Lazy.force li_and)) then + if Names.Ind.CanOrd.equal ind (fst (Lazy.force li_and)) then let fa = make_form env sigma atom_env argv.(0) in let fb = make_form env sigma atom_env argv.(1) in Conjunct (fa,fb) - else if Names.eq_ind ind (fst (Lazy.force li_or)) then + else if Names.Ind.CanOrd.equal ind (fst (Lazy.force li_or)) then let fa = make_form env sigma atom_env argv.(0) in let fb = make_form env sigma atom_env argv.(1) in Disjunct (fa,fb) diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 38b26d06b9..a7ebd5f9f5 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -240,7 +240,7 @@ let strip_unfold_term _ ((sigma, t) as p) kt = match EConstr.kind sigma t with let same_proj sigma t1 t2 = match EConstr.kind sigma t1, EConstr.kind sigma t2 with - | Proj(c1,_), Proj(c2, _) -> Projection.equal c1 c2 + | Proj(c1,_), Proj(c2, _) -> Projection.CanOrd.equal c1 c2 | _ -> false let all_ok _ _ = true diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 7b584b5159..35fecfb0a5 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -100,7 +100,7 @@ ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY { pr_ssrtacarg env sigma } END GRAMMAR EXTEND Gram GLOBAL: ssrtacarg; - ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> { tac } ]]; + ssrtacarg: [[ tac = ltac_expr LEVEL "5" -> { tac } ]]; END (* Copy of ssrtacarg with LEVEL "3", useful for: "under ... do ..." *) @@ -108,7 +108,7 @@ ARGUMENT EXTEND ssrtac3arg TYPED AS tactic PRINTED BY { pr_ssrtacarg env sigma } END GRAMMAR EXTEND Gram GLOBAL: ssrtac3arg; - ssrtac3arg: [[ tac = tactic_expr LEVEL "3" -> { tac } ]]; + ssrtac3arg: [[ tac = ltac_expr LEVEL "3" -> { tac } ]]; END { @@ -1337,7 +1337,7 @@ ARGUMENT EXTEND ssrbinder TYPED AS (ssrfwdfmt * constr) PRINTED BY { pr_ssrbinde GRAMMAR EXTEND Gram GLOBAL: ssrbinder; ssrbinder: [ - [ ["of" -> { () } | "&" -> { () } ]; c = operconstr LEVEL "99" -> { + [ ["of" -> { () } | "&" -> { () } ]; c = term LEVEL "99" -> { (FwdPose, [BFvar]), CAst.make ~loc @@ CLambdaN ([CLocalAssum ([CAst.make ~loc Anonymous],Default Glob_term.Explicit,c)],mkCHole (Some loc)) } ] ]; @@ -1594,18 +1594,18 @@ GRAMMAR EXTEND Gram | n = Prim.natural -> { ArgArg (check_index ~loc n) } ] ]; ssrswap: [[ IDENT "first" -> { loc, true } | IDENT "last" -> { loc, false } ]]; - ssrorelse: [[ "||"; tac = tactic_expr LEVEL "2" -> { tac } ]]; + ssrorelse: [[ "||"; tac = ltac_expr LEVEL "2" -> { tac } ]]; ssrseqarg: [ [ arg = ssrswap -> { noindex, swaptacarg arg } | i = ssrseqidx; tac = ssrortacarg; def = OPT ssrorelse -> { i, (tac, def) } | i = ssrseqidx; arg = ssrswap -> { i, swaptacarg arg } - | tac = tactic_expr LEVEL "3" -> { noindex, (mk_hint tac, None) } + | tac = ltac_expr LEVEL "3" -> { noindex, (mk_hint tac, None) } ] ]; END { -let tactic_expr = Pltac.tactic_expr +let ltac_expr = Pltac.ltac_expr } @@ -1688,9 +1688,9 @@ let tclintros_expr ?loc tac ipats = } GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; - tactic_expr: LEVEL "1" [ RIGHTA - [ tac = tactic_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } + GLOBAL: ltac_expr; + ltac_expr: LEVEL "1" [ RIGHTA + [ tac = ltac_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } ] ]; END @@ -1704,9 +1704,9 @@ END (* (Removing user-specified parentheses is dubious anyway). *) GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; - ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> { CAst.make ~loc (Tacexp tac) } ]]; - tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> { TacArg arg } ]]; + GLOBAL: ltac_expr; + ssrparentacarg: [[ "("; tac = ltac_expr; ")" -> { CAst.make ~loc (Tacexp tac) } ]]; + ltac_expr: LEVEL "0" [[ arg = ssrparentacarg -> { TacArg arg } ]]; END (** The internal "done" and "ssrautoprop" tactics. *) @@ -1741,7 +1741,7 @@ let tclBY tac = Tacticals.New.tclTHEN tac (donetac ~-1) (* The latter two are used in forward-chaining tactics (have, suffice, wlog) *) (* and subgoal reordering tacticals (; first & ; last), respectively. *) -(* Force use of the tactic_expr parsing entry, to rule out tick marks. *) +(* Force use of the ltac_expr parsing entry, to rule out tick marks. *) (** The "by" tactical. *) @@ -1782,12 +1782,12 @@ let ssrdotac_expr ?loc n m tac clauses = } GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; + GLOBAL: ltac_expr; ssrdotac: [ - [ tac = tactic_expr LEVEL "3" -> { mk_hint tac } + [ tac = ltac_expr LEVEL "3" -> { mk_hint tac } | tacs = ssrortacarg -> { tacs } ] ]; - tactic_expr: LEVEL "3" [ RIGHTA + ltac_expr: LEVEL "3" [ RIGHTA [ IDENT "do"; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> { ssrdotac_expr ~loc noindex m tac clauses } | IDENT "do"; tac = ssrortacarg; clauses = ssrclauses -> @@ -1833,20 +1833,20 @@ let tclseq_expr ?loc tac dir arg = } GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; + GLOBAL: ltac_expr; ssr_first: [ [ tac = ssr_first; ipats = ssrintros_ne -> { tclintros_expr ~loc tac ipats } - | "["; tacl = LIST0 tactic_expr SEP "|"; "]" -> { TacFirst tacl } + | "["; tacl = LIST0 ltac_expr SEP "|"; "]" -> { TacFirst tacl } ] ]; ssr_first_else: [ [ tac1 = ssr_first; tac2 = ssrorelse -> { TacOrelse (tac1, tac2) } | tac = ssr_first -> { tac } ]]; - tactic_expr: LEVEL "4" [ LEFTA - [ tac1 = tactic_expr; ";"; IDENT "first"; tac2 = ssr_first_else -> + ltac_expr: LEVEL "4" [ LEFTA + [ tac1 = ltac_expr; ";"; IDENT "first"; tac2 = ssr_first_else -> { TacThen (tac1, tac2) } - | tac = tactic_expr; ";"; IDENT "first"; arg = ssrseqarg -> + | tac = ltac_expr; ";"; IDENT "first"; arg = ssrseqarg -> { tclseq_expr ~loc tac L2R arg } - | tac = tactic_expr; ";"; IDENT "last"; arg = ssrseqarg -> + | tac = ltac_expr; ";"; IDENT "last"; arg = ssrseqarg -> { tclseq_expr ~loc tac R2L arg } ] ]; END @@ -1894,7 +1894,8 @@ let has_occ ((_, occ), _) = occ <> None let gens_sep = function [], [] -> mt | _ -> spc let pr_dgens pr_gen (gensl, clr) = - let prgens s gens = str s ++ pr_list spc pr_gen gens in + let prgens s gens = + if CList.is_empty gens then mt () else str s ++ pr_list spc pr_gen gens in let prdeps deps = prgens ": " deps ++ spc () ++ str "/" in match gensl with | [deps; []] -> prdeps deps ++ pr_clear pr_spc clr @@ -2194,7 +2195,7 @@ END let pr_ssrcongrarg _ _ _ ((n, f), dgens) = (if n <= 0 then mt () else str " " ++ int n) ++ - str " " ++ pr_term f ++ pr_dgens pr_gen dgens + pr_term f ++ pr_dgens pr_gen dgens } @@ -2447,8 +2448,8 @@ END (* The standard TACTIC EXTEND does not work for abstract *) GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; - tactic_expr: LEVEL "3" + GLOBAL: ltac_expr; + ltac_expr: LEVEL "3" [ RIGHTA [ IDENT "abstract"; gens = ssrdgens -> { ssrtac_expr ~loc "abstract" [Tacexpr.TacGeneric (None, Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] } ]]; diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index e231ab1f87..ab36d4fc7c 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -75,11 +75,14 @@ let pr_hyp (SsrHyp (_, id)) = Id.print id let pr_hyps = pr_list pr_spc pr_hyp let pr_occ = function - | Some (true, occ) -> str "{-" ++ pr_list pr_spc int occ ++ str "}" - | Some (false, occ) -> str "{+" ++ pr_list pr_spc int occ ++ str "}" + | Some (true, occ) -> + if CList.is_empty occ then mt () else str "{-" ++ pr_list pr_spc int occ ++ str "}" + | Some (false, occ) -> + if CList.is_empty occ then mt () else str "{+" ++ pr_list pr_spc int occ ++ str "}" | None -> str "{}" -let pr_clear_ne clr = str "{" ++ pr_hyps clr ++ str "}" +let pr_clear_ne clr = + if CList.is_empty clr then mt () else str "{" ++ pr_hyps clr ++ str "}" let pr_clear sep clr = sep () ++ pr_clear_ne clr let pr_dir = function L2R -> str "->" | R2L -> str "<-" diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 4a907b2795..a49a5e8b28 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -85,7 +85,7 @@ let mk_pat c (na, t) = (c, na, t) GRAMMAR EXTEND Gram GLOBAL: binder_constr; - ssr_rtype: [[ "return"; t = operconstr LEVEL "100" -> { mk_rtype t } ]]; + ssr_rtype: [[ "return"; t = term LEVEL "100" -> { mk_rtype t } ]]; ssr_mpat: [[ p = pattern -> { [[p]] } ]]; ssr_dpat: [ [ mp = ssr_mpat; "in"; t = pattern; rt = ssr_rtype -> { mp, mk_ctype mp t, rt } @@ -96,9 +96,9 @@ GRAMMAR EXTEND Gram ssr_elsepat: [[ "else" -> { [[CAst.make ~loc @@ CPatAtom None]] } ]]; ssr_else: [[ mp = ssr_elsepat; c = lconstr -> { CAst.make ~loc (mp, c) } ]]; binder_constr: [ - [ "if"; c = operconstr LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> + [ "if"; c = term LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> { let b1, ct, rt = db1 in CAst.make ~loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) } - | "if"; c = operconstr LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> + | "if"; c = term LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> { let b1, ct, rt = db1 in let b1, b2 = let open CAst in let {loc=l1; v=(p1, r1)}, {loc=l2; v=(p2, r2)} = b1, b2 in @@ -119,7 +119,7 @@ END GRAMMAR EXTEND Gram GLOBAL: closed_binder; closed_binder: [ - [ ["of" -> { () } | "&" -> { () } ]; c = operconstr LEVEL "99" -> + [ ["of" -> { () } | "&" -> { () } ]; c = term LEVEL "99" -> { [CLocalAssum ([CAst.make ~loc Anonymous], Default Explicit, c)] } ] ]; END @@ -309,9 +309,15 @@ END ~category:"deprecated" ~default:CWarnings.Enabled (fun () -> (Pp.strbrk - "SSReflect's Search command has been moved to the \ - ssrsearch module; please Require that module if you \ - still want to use SSReflect's Search command")) + "In previous versions of Coq, loading SSReflect had the effect of \ + replacing the built-in 'Search' command with an SSReflect version \ + of that command. \ + Coq's own search feature was still available via 'SearchAbout' \ + (but that alias is deprecated). \ + This replacement no longer happens; now 'Search' calls Coq's own search \ + feature even when SSReflect is loaded. \ + If you want to use SSReflect's deprecated Search command \ + instead of the built-in one, please Require the ssrsearch module.")) open G_vernac } diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index cdd15acb0d..bd514f15d5 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -463,8 +463,8 @@ let nb_cs_proj_args pc f u = try match kind f with | Prod _ -> na Prod_cs | Sort s -> na (Sort_cs (Sorts.family s)) - | Const (c',_) when Constant.equal c' pc -> nargs_of_proj u.up_f - | Proj (c',_) when Constant.equal (Projection.constant c') pc -> nargs_of_proj u.up_f + | Const (c',_) when Constant.CanOrd.equal c' pc -> nargs_of_proj u.up_f + | Proj (c',_) when Constant.CanOrd.equal (Projection.constant c') pc -> nargs_of_proj u.up_f | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (fst @@ destRef f)) | _ -> -1 with Not_found -> -1 @@ -508,7 +508,7 @@ let filter_upat i0 f n u fpats = let () = if !i0 < np then i0 := n in (u, np) :: fpats let eq_prim_proj c t = match kind t with - | Proj(p,_) -> Constant.equal (Projection.constant p) c + | Proj(p,_) -> Constant.CanOrd.equal (Projection.constant p) c | _ -> false let filter_upat_FO i0 f n u fpats = diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index c030925ea9..93d91abea3 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -31,7 +31,7 @@ let warn_deprecated_numeral_notation = } -VERNAC ARGUMENT EXTEND numnotoption +VERNAC ARGUMENT EXTEND numeral_modifier PRINTED BY { pr_numnot_option } | [ ] -> { Nop } | [ "(" "warning" "after" bignat(waft) ")" ] -> { Warning (NumTok.UnsignedNat.of_string waft) } @@ -40,11 +40,11 @@ END VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF | #[ locality = Attributes.locality; ] [ "Number" "Notation" reference(ty) reference(f) reference(g) ":" - ident(sc) numnotoption(o) ] -> + ident(sc) numeral_modifier(o) ] -> { vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" - ident(sc) numnotoption(o) ] -> + ident(sc) numeral_modifier(o) ] -> { warn_deprecated_numeral_notation (); vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } diff --git a/pretyping/cases.ml b/pretyping/cases.ml index a459229256..4a29db0dcf 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -128,7 +128,8 @@ type 'a equation = rhs : 'a rhs; alias_stack : Name.t list; eqn_loc : Loc.t option; - used : bool ref } + used : int ref; + catch_all_vars : Id.t CAst.t list ref } type 'a matrix = 'a equation list @@ -514,7 +515,7 @@ let check_and_adjust_constructor env ind cstrs pat = match DAst.get pat with let loc = pat.CAst.loc in (* Check it is constructor of the right type *) let ind' = inductive_of_constructor cstr in - if eq_ind ind' ind then + if Ind.CanOrd.equal ind' ind then (* Check the constructor has the right number of args *) let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in @@ -543,11 +544,34 @@ let check_all_variables env sigma typ mat = error_bad_pattern ?loc env sigma cstr_sp typ) mat +let set_pattern_catch_all_var ?loc eqn = function + | Name id when not (Id.Set.mem id eqn.rhs.rhs_vars) -> + eqn.catch_all_vars := CAst.make ?loc id :: !(eqn.catch_all_vars) + | _ -> () + +let warn_named_multi_catch_all = + CWarnings.create ~name:"unused-pattern-matching-variable" ~category:"pattern-matching" + (fun id -> + strbrk "Unused variable " ++ Id.print id ++ strbrk " catches more than one case.") + +let wildcard_id = Id.of_string "wildcard'" + +let is_wildcard id = + Id.equal (Id.of_string (Nameops.atompart_of_id id)) wildcard_id + let check_unused_pattern env eqn = - if not !(eqn.used) then - raise_pattern_matching_error ?loc:eqn.eqn_loc (env, Evd.empty, UnusedClause eqn.patterns) + match !(eqn.used) with + | 0 -> raise_pattern_matching_error ?loc:eqn.eqn_loc (env, Evd.empty, UnusedClause eqn.patterns) + | 1 -> () + | _ -> + let warn {CAst.v = id; loc} = + (* Convention: Names starting with `_` and derivatives of Program's + "wildcard'" internal name deactivate the warning *) + if (Id.to_string id).[0] <> '_' && not (is_wildcard id) + then warn_named_multi_catch_all ?loc id in + List.iter warn !(eqn.catch_all_vars) -let set_used_pattern eqn = eqn.used := true +let set_used_pattern eqn = eqn.used := !(eqn.used) + 1 let extract_rhs pb = match pb.mat with @@ -1017,7 +1041,8 @@ let add_assert_false_case pb tomatch = it = None }; alias_stack = Anonymous::aliasnames; eqn_loc = None; - used = ref false } ] + used = ref 0; + catch_all_vars = ref [] } ] let adjust_impossible_cases sigma pb pred tomatch submat = match submat with @@ -1235,6 +1260,7 @@ let group_equations pb ind current cstrs mat = let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in brs.(i-1) <- (args, name, rest) :: brs.(i-1) done; + set_pattern_catch_all_var ?loc:pat.CAst.loc eqn name; if !only_default == None then only_default := Some true | PatCstr (((_,i)),args,name) -> (* This is a regular clause *) @@ -1602,7 +1628,8 @@ let matx_of_eqns env eqns = { patterns = initial_lpat; alias_stack = []; eqn_loc = loc; - used = ref false; + used = ref 0; + catch_all_vars = ref []; rhs = rhs } in List.map build_eqn eqns @@ -1859,7 +1886,8 @@ let build_inversion_problem ~program_mode loc env sigma tms t = { patterns = patl; alias_stack = []; eqn_loc = None; - used = ref false; + used = ref 0; + catch_all_vars = ref []; rhs = { rhs_env = pb_env; (* we assume all vars are used; in practice we discard dependent vars so that the field rhs_vars is normally not used *) @@ -1879,7 +1907,8 @@ let build_inversion_problem ~program_mode loc env sigma tms t = [ { patterns = List.map (fun _ -> DAst.make @@ PatVar Anonymous) patl; alias_stack = []; eqn_loc = None; - used = ref false; + used = ref 0; + catch_all_vars = ref []; rhs = { rhs_env = pb_env; rhs_vars = Id.Set.empty; avoid_ids = avoid0; @@ -1936,7 +1965,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let realnal = match t with | Some {CAst.loc;v=(ind',realnal)} -> - if not (eq_ind ind ind') then + if not (Ind.CanOrd.equal ind ind') then user_err ?loc (str "Wrong inductive type."); if not (Int.equal nrealargs_ctxt (List.length realnal)) then anomaly (Pp.str "Ill-formed 'in' clause in cases."); @@ -2149,7 +2178,7 @@ let constr_of_pat env sigma arsign pat avoid = let name, avoid = match name with Name n -> name, avoid | Anonymous -> - let previd, id = prime avoid (Name (Id.of_string "wildcard")) in + let id = next_ident_away wildcard_id avoid in Name id, Id.Set.add id avoid in let r = Sorts.Relevant in (* TODO relevance *) @@ -2164,7 +2193,7 @@ let constr_of_pat env sigma arsign pat avoid = in let (ind,u), params = dest_ind_family indf in let params = List.map EConstr.of_constr params in - if not (eq_ind ind cind) then error_bad_constructor ?loc env cstr ind; + if not (Ind.CanOrd.equal ind cind) then error_bad_constructor ?loc env cstr ind; let cstrs = get_constructors env indf in let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 8b1ec3aba0..9a986bc14c 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -68,7 +68,8 @@ type 'a equation = rhs : 'a rhs; alias_stack : Name.t list; eqn_loc : Loc.t option; - used : bool ref } + used : int ref; + catch_all_vars : Id.t CAst.t list ref } type 'a matrix = 'a equation list diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index d759f82d35..6e6189796e 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -119,7 +119,7 @@ let disc_subset sigma x = Ind (i,_) -> let len = Array.length l in let sigty = delayed_force sig_typ in - if Int.equal len 2 && eq_ind i (Globnames.destIndRef sigty) + if Int.equal len 2 && Ind.CanOrd.equal i (Globnames.destIndRef sigty) then let (a, b) = pair_of_array l in Some (a, b) @@ -240,10 +240,10 @@ let coerce ?loc env sigma (x : EConstr.constr) (y : EConstr.constr) let sigT = delayed_force sigT_typ in let prod = delayed_force prod_typ in (* Sigma types *) - if Int.equal len (Array.length l') && Int.equal len 2 && eq_ind i i' - && (eq_ind i (destIndRef sigT) || eq_ind i (destIndRef prod)) + if Int.equal len (Array.length l') && Int.equal len 2 && Ind.CanOrd.equal i i' + && (Ind.CanOrd.equal i (destIndRef sigT) || Ind.CanOrd.equal i (destIndRef prod)) then - if eq_ind i (destIndRef sigT) + if Ind.CanOrd.equal i (destIndRef sigT) then begin let (a, pb), (a', pb') = @@ -303,7 +303,7 @@ let coerce ?loc env sigma (x : EConstr.constr) (y : EConstr.constr) papp sigma prod_intro [| a'; b'; x ; y |]) end else - if eq_ind i i' && Int.equal len (Array.length l') then + if Ind.CanOrd.equal i i' && Int.equal len (Array.length l') then (try subco sigma with NoSubtacCoercion -> let sigma, typ = Typing.type_of env sigma c in diff --git a/pretyping/coercionops.ml b/pretyping/coercionops.ml index 0c3eaa1da9..8ddc576d83 100644 --- a/pretyping/coercionops.ml +++ b/pretyping/coercionops.ml @@ -57,7 +57,7 @@ let cl_typ_ord t1 t2 = match t1, t2 with | CL_SECVAR v1, CL_SECVAR v2 -> Id.compare v1 v2 | CL_CONST c1, CL_CONST c2 -> Constant.CanOrd.compare c1 c2 | CL_PROJ c1, CL_PROJ c2 -> Projection.Repr.CanOrd.compare c1 c2 - | CL_IND i1, CL_IND i2 -> ind_ord i1 i2 + | CL_IND i1, CL_IND i2 -> Ind.CanOrd.compare i1 i2 | _ -> pervasives_compare t1 t2 (** OK *) module ClTyp = struct diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 419eeaa92a..a3f1c0b004 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -244,9 +244,9 @@ let matches_core env sigma allow_bound_rels let open GlobRef in match ref, EConstr.kind sigma c with | VarRef id, Var id' -> Names.Id.equal id id' - | 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' + | ConstRef c, Const (c',_) -> Environ.QConstant.equal env c c' + | IndRef i, Ind (i', _) -> Names.Ind.CanOrd.equal i i' + | ConstructRef c, Construct (c',u) -> Names.Construct.CanOrd.equal c c' | _, _ -> false in let rec sorec ctx env subst p t = @@ -307,11 +307,11 @@ let matches_core env sigma allow_bound_rels | PApp (c1,arg1), App (c2,arg2) -> (match c1, EConstr.kind sigma c2 with - | PRef (GlobRef.ConstRef r), Proj (pr,c) when not (Constant.equal r (Projection.constant pr)) + | PRef (GlobRef.ConstRef r), Proj (pr,c) when not (Environ.QConstant.equal env r (Projection.constant pr)) || Projection.unfolded pr -> raise PatternMatchingFailure | PProj (pr1,c1), Proj (pr,c) -> - if Projection.equal pr1 pr then + if Environ.QProjection.equal env pr1 pr then try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c) arg1 arg2 with Invalid_argument _ -> raise PatternMatchingFailure else raise PatternMatchingFailure @@ -324,7 +324,7 @@ let matches_core env sigma allow_bound_rels with Invalid_argument _ -> raise PatternMatchingFailure) | PApp (PRef (GlobRef.ConstRef c1), _), Proj (pr, c2) - when Projection.unfolded pr || not (Constant.equal c1 (Projection.constant pr)) -> + when Projection.unfolded pr || not (Environ.QConstant.equal env c1 (Projection.constant pr)) -> raise PatternMatchingFailure | PApp (c, args), Proj (pr, c2) -> @@ -332,7 +332,7 @@ let matches_core env sigma allow_bound_rels sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) - | PProj (p1,c1), Proj (p2,c2) when Projection.equal p1 p2 -> + | PProj (p1,c1), Proj (p2,c2) when Environ.QProjection.equal env p1 p2 -> sorec ctx env subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> @@ -374,7 +374,7 @@ let matches_core env sigma allow_bound_rels | Some ind1 -> (* ppedrot: Something spooky going here. The comparison used to be the generic one, so I may have broken something. *) - if not (eq_ind ind1 ci2.ci_ind) then raise PatternMatchingFailure + if not (Ind.CanOrd.equal ind1 ci2.ci_ind) then raise PatternMatchingFailure in let () = if not ci1.cip_extensible && not (Int.equal (List.length br1) n2) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index a5311e162d..90af143a2d 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -387,7 +387,7 @@ let ise_stack2 no_app env evd f sk1 sk2 = | UnifFailure _ as x -> fail x) | UnifFailure _ as x -> fail x) | Stack.Proj (p1)::q1, Stack.Proj (p2)::q2 -> - if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) + if QProjection.Repr.equal env (Projection.repr p1) (Projection.repr p2) then ise_stack2 true i q1 q2 else fail (UnifFailure (i, NotSameHead)) | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1)::q1, @@ -429,7 +429,7 @@ let exact_ise_stack2 env evd f sk1 sk2 = (fun i -> ise_stack2 i a1 a2)] else UnifFailure (i,NotSameHead) | Stack.Proj (p1)::q1, Stack.Proj (p2)::q2 -> - if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) + if QProjection.Repr.equal env (Projection.repr p1) (Projection.repr p2) then ise_stack2 i q1 q2 else (UnifFailure (i, NotSameHead)) | Stack.App _ :: _, Stack.App _ :: _ -> @@ -566,11 +566,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in let compare_heads evd = match EConstr.kind evd term, EConstr.kind evd term' with - | Const (c, u), Const (c', u') when Constant.equal c c' -> + | Const (c, u), Const (c', u') when QConstant.equal env c c' -> let u = EInstance.kind evd u and u' = EInstance.kind evd u' in check_strict evd u u' | Const _, Const _ -> UnifFailure (evd, NotSameHead) - | Ind ((mi,i) as ind , u), Ind (ind', u') when Names.eq_ind ind ind' -> + | Ind ((mi,i) as ind , u), Ind (ind', u') when Names.Ind.CanOrd.equal ind ind' -> if EInstance.is_empty u && EInstance.is_empty u' then Success evd else let u = EInstance.kind evd u and u' = EInstance.kind evd u' in @@ -589,7 +589,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty end | Ind _, Ind _ -> UnifFailure (evd, NotSameHead) | Construct (((mi,ind),ctor as cons), u), Construct (cons', u') - when Names.eq_constructor cons cons' -> + when Names.Construct.CanOrd.equal cons cons' -> if EInstance.is_empty u && EInstance.is_empty u' then Success evd else let u = EInstance.kind evd u and u' = EInstance.kind evd u' in @@ -831,7 +831,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in ise_try evd [f1; f2] - | Proj (p, c), Proj (p', c') when Projection.repr_equal p p' -> + | Proj (p, c), Proj (p', c') when QProjection.Repr.equal env (Projection.repr p) (Projection.repr p') -> let f1 i = ise_and i [(fun i -> evar_conv_x flags env i CONV c c'); @@ -844,7 +844,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty ise_try evd [f1; f2] (* Catch the p.c ~= p c' cases *) - | Proj (p,c), Const (p',u) when Constant.equal (Projection.constant p) p' -> + | Proj (p,c), Const (p',u) when QConstant.equal env (Projection.constant p) p' -> let res = try Some (destApp evd (Retyping.expand_projection env evd p c [])) with Retyping.RetypeError _ -> None @@ -855,7 +855,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty appr2 | None -> UnifFailure (evd,NotSameHead)) - | Const (p,u), Proj (p',c') when Constant.equal p (Projection.constant p') -> + | Const (p,u), Proj (p',c') when QConstant.equal env p (Projection.constant p') -> let res = try Some (destApp evd (Retyping.expand_projection env evd p' c' [])) with Retyping.RetypeError _ -> None diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index eaf8c65811..13abf47413 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -206,7 +206,7 @@ let is_array_const env sigma c = | Const (cst,_) -> (match env.Environ.retroknowledge.Retroknowledge.retro_array with | None -> false - | Some cst' -> Constant.equal cst cst') + | Some cst' -> Environ.QConstant.equal env cst cst') | _ -> false let split_as_array env sigma0 = function diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index dc5fd80f9e..bdf3495479 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -91,7 +91,7 @@ let case_style_eq s1 s2 = let open Constr in match s1, s2 with let rec cases_pattern_eq p1 p2 = match DAst.get p1, DAst.get p2 with | PatVar na1, PatVar na2 -> Name.equal na1 na2 | PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> - eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && + Construct.CanOrd.equal c1 c2 && List.equal cases_pattern_eq pl1 pl2 && Name.equal na1 na2 | (PatVar _ | PatCstr _), _ -> false @@ -109,7 +109,7 @@ let matching_var_kind_eq k1 k2 = match k1, k2 with let tomatch_tuple_eq f (c1, p1) (c2, p2) = let eqp {CAst.v=(i1, na1)} {CAst.v=(i2, na2)} = - eq_ind i1 i2 && List.equal Name.equal na1 na2 + Ind.CanOrd.equal i1 i2 && List.equal Name.equal na1 na2 in let eq_pred (n1, o1) (n2, o2) = Name.equal n1 n2 && Option.equal eqp o1 o2 in f c1 c2 && eq_pred p1 p2 diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 5be8f9f83c..5ffd919312 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -584,7 +584,7 @@ let build_mutual_induction_scheme env sigma ?(force_mutual=false) = function (List.map (function ((mind',u'),dep',s') -> let (sp',_) = mind' in - if MutInd.equal sp sp' then + if QMutInd.equal env sp sp' then let (mibi',mipi') = lookup_mind_specif env mind' in ((mind',u'),mibi',mipi',dep',s') else diff --git a/pretyping/keys.ml b/pretyping/keys.ml index 7a7099c195..dd3488c1df 100644 --- a/pretyping/keys.ml +++ b/pretyping/keys.ml @@ -34,7 +34,7 @@ module KeyOrdered = struct let hash gr = match gr with - | KGlob gr -> 9 + GlobRef.Ordered.hash gr + | KGlob gr -> 9 + GlobRef.CanOrd.hash gr | KLam -> 0 | KLet -> 1 | KProd -> 2 @@ -49,14 +49,14 @@ module KeyOrdered = struct let compare gr1 gr2 = match gr1, gr2 with - | KGlob gr1, KGlob gr2 -> GlobRef.Ordered.compare gr1 gr2 + | KGlob gr1, KGlob gr2 -> GlobRef.CanOrd.compare gr1 gr2 | _, KGlob _ -> -1 | KGlob _, _ -> 1 | k, k' -> Int.compare (hash k) (hash k') let equal k1 k2 = match k1, k2 with - | KGlob gr1, KGlob gr2 -> GlobRef.Ordered.equal gr1 gr2 + | KGlob gr1, KGlob gr2 -> GlobRef.CanOrd.equal gr1 gr2 | _, KGlob _ -> false | KGlob _, _ -> false | k, k' -> k == k' diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 8c3d624f0f..b259945d9e 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -23,7 +23,7 @@ open Environ let case_info_pattern_eq i1 i2 = i1.cip_style == i2.cip_style && - Option.equal eq_ind i1.cip_ind i2.cip_ind && + Option.equal Ind.CanOrd.equal i1.cip_ind i2.cip_ind && Option.equal (List.equal (==)) i1.cip_ind_tags i2.cip_ind_tags && i1.cip_extensible == i2.cip_extensible @@ -59,7 +59,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with | PCoFix (i1,f1), PCoFix (i2,f2) -> Int.equal i1 i2 && rec_declaration_eq f1 f2 | PProj (p1, t1), PProj (p2, t2) -> - Projection.equal p1 p2 && constr_pattern_eq t1 t2 + Projection.CanOrd.equal p1 p2 && constr_pattern_eq t1 t2 | PInt i1, PInt i2 -> Uint63.equal i1 i2 | PFloat f1, PFloat f2 -> @@ -547,7 +547,7 @@ and pats_of_glob_branches loc metas vars ind brs = true, [] (* ends with _ => _ *) | PatCstr((indsp,j),lv,_), _, _ -> let () = match ind with - | Some sp when eq_ind sp indsp -> () + | Some sp when Ind.CanOrd.equal sp indsp -> () | _ -> err ?loc (Pp.str "All constructors must be in the same inductive type.") in diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 268ad2ae56..06f7d92e62 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -813,7 +813,7 @@ struct try let IndType (indf, args) = find_rectype !!env sigma ty in let ((ind',u'),pars) = dest_ind_family indf in - if eq_ind ind ind' then List.map EConstr.of_constr pars + if Ind.CanOrd.equal ind ind' then List.map EConstr.of_constr pars else (* Let the usual code throw an error *) [] with Not_found -> [] else [] diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 9d15e98373..9cf7119709 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -82,7 +82,7 @@ type evaluable_reference = | EvalEvar of EConstr.existential let evaluable_reference_eq sigma r1 r2 = match r1, r2 with -| EvalConst c1, EvalConst c2 -> Constant.equal c1 c2 +| EvalConst c1, EvalConst c2 -> Constant.CanOrd.equal c1 c2 | EvalVar id1, EvalVar id2 -> Id.equal id1 id2 | EvalRel i1, EvalRel i2 -> Int.equal i1 i2 | EvalEvar (e1, ctx1), EvalEvar (e2, ctx2) -> @@ -995,7 +995,7 @@ let whd_simpl_orelse_delta_but_fix env sigma c = | CoFix _ | Fix _ -> s' | Proj (p,t) when (match EConstr.kind sigma constr with - | Const (c', _) -> Constant.equal (Projection.constant p) c' + | Const (c', _) -> Constant.CanOrd.equal (Projection.constant p) c' | _ -> false) -> let npars = Projection.npars p in if List.length stack <= npars then @@ -1101,7 +1101,7 @@ let contextually byhead occs f env sigma t = let match_constr_evaluable_ref sigma c evref = match EConstr.kind sigma c, evref with - | Const (c,u), EvalConstRef c' when Constant.equal c c' -> Some u + | Const (c,u), EvalConstRef c' when Constant.CanOrd.equal c c' -> Some u | Var id, EvalVarRef id' when Id.equal id id' -> Some EInstance.empty | _, _ -> None @@ -1324,7 +1324,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = if isIndRef ref then let ((mind,u),t) = reduce_to_ind_gen allow_product env sigma t in begin match ref with - | GlobRef.IndRef mind' when eq_ind mind mind' -> t + | GlobRef.IndRef mind' when Ind.CanOrd.equal mind mind' -> t | _ -> error_cannot_recognize ref end else diff --git a/pretyping/unification.ml b/pretyping/unification.ml index ccfb508964..4d37c0ef60 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -547,10 +547,10 @@ let oracle_order env cf1 cf2 = | Some k2 -> match k1, k2 with | IsProj (p, _), IsKey (ConstKey (p',_)) - when Constant.equal (Projection.constant p) p' -> + when Environ.QConstant.equal env (Projection.constant p) p' -> Some (not (Projection.unfolded p)) | IsKey (ConstKey (p,_)), IsProj (p', _) - when Constant.equal p (Projection.constant p') -> + when Environ.QConstant.equal env p (Projection.constant p') -> Some (Projection.unfolded p') | _ -> Some (Conv_oracle.oracle_order (fun x -> x) @@ -796,7 +796,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e | _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb opt substn cM (subst1 a c) (* Fast path for projections. *) - | Proj (p1,c1), Proj (p2,c2) when Constant.equal + | Proj (p1,c1), Proj (p2,c2) when Environ.QConstant.equal env (Projection.constant p1) (Projection.constant p2) -> (try unify_same_proj curenvnb cv_pb {opt with at_top = true} substn c1 c2 @@ -844,7 +844,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e | Case (ci1,p1,_,c1,cl1), Case (ci2,p2,_,c2,cl2) -> (try - if not (eq_ind ci1.ci_ind ci2.ci_ind) then error_cannot_unify curenv sigma (cM,cN); + if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then error_cannot_unify curenv sigma (cM,cN); let opt' = {opt with at_top = true; with_types = false} in Array.fold_left2 (unirec_rec curenvnb CONV {opt with at_top = true}) (unirec_rec curenvnb CONV opt' @@ -914,7 +914,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e match EConstr.kind sigma c' with | Meta _ -> true | Evar _ -> true - | Const (c, u) -> Constant.equal c (Projection.constant p) + | Const (c, u) -> Environ.QConstant.equal env c (Projection.constant p) | _ -> false in let expand_proj c c' l = diff --git a/printing/printer.ml b/printing/printer.ml index bc26caefbe..be1cc0d64a 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -884,7 +884,7 @@ struct MutInd.CanOrd.compare m1 m2 | Guarded k1 , Guarded k2 | TypeInType k1, TypeInType k2 -> - GlobRef.Ordered.compare k1 k2 + GlobRef.CanOrd.compare k1 k2 | Constant _, _ -> -1 | _, Constant _ -> 1 | Positive _, _ -> -1 diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index f721e9956b..af0ca22868 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -27,7 +27,7 @@ type term_label = | SortLabel let compare_term_label t1 t2 = match t1, t2 with -| GRLabel gr1, GRLabel gr2 -> GlobRef.Ordered.compare gr1 gr2 +| GRLabel gr1, GRLabel gr2 -> GlobRef.CanOrd.compare gr1 gr2 | _ -> pervasives_compare t1 t2 (** OK *) type 'res lookup_res = 'res Dn.lookup_res = Label of 'res | Nothing | Everything diff --git a/tactics/cbn.ml b/tactics/cbn.ml index 0b13f4763a..31873ea6b0 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -225,8 +225,8 @@ struct 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 - | Cst_proj p1, Cst_proj p2 -> Projection.repr_equal p1 p2 + Constant.CanOrd.equal c1 c2 && Univ.Instance.equal u1 u2 + | Cst_proj p1, Cst_proj p2 -> Projection.Repr.CanOrd.equal (Projection.repr p1) (Projection.repr p2) | _, _ -> false in let rec equal_rec sk1 sk2 = @@ -239,7 +239,7 @@ struct | Case (_,t1,_,a1,_) :: s1, Case (_,t2,_,a2,_) :: s2 -> f t1 t2 && CArray.equal (fun x y -> f x y) a1 a2 && equal_rec s1 s2 | (Proj (p,_)::s1, Proj(p2,_)::s2) -> - Projection.Repr.equal (Projection.repr p) (Projection.repr p2) + Projection.Repr.CanOrd.equal (Projection.repr p) (Projection.repr p2) && equal_rec s1 s2 | Fix (f1,s1,_) :: s1', Fix (f2,s2,_) :: s2' -> f_fix f1 f2 diff --git a/tactics/elim.ml b/tactics/elim.ml index 49437a2aef..9a55cabc86 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -193,7 +193,7 @@ let head_in indl t gl = let sigma = Tacmach.New.project gl in try let ity,_ = extract_mrectype sigma t in - List.exists (fun i -> eq_ind (fst i) (fst ity)) indl + List.exists (fun i -> Ind.CanOrd.equal (fst i) (fst ity)) indl with Not_found -> false let decompose_these c l = diff --git a/tactics/equality.ml b/tactics/equality.ml index 60e2db4dce..486575d229 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -768,7 +768,7 @@ let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = in (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) - if eq_constructor sp1 sp2 then + if Construct.CanOrd.equal sp1 sp2 then let nparams = inductive_nparams env ind1 in let params1,rargs1 = List.chop nparams args1 in let _,rargs2 = List.chop nparams args2 in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index a607c09010..f3ecc2a9f0 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -540,7 +540,7 @@ let mutual_fix f n rest j = Proofview.Goal.enter begin fun gl -> | (f, n, ar) :: oth -> let open Context.Named.Declaration in let (sp', u') = check_mutind env sigma n ar in - if not (MutInd.equal sp sp') then + if not (QMutInd.equal env sp sp') then error "Fixpoints should be on the same mutual inductive declaration."; if mem_named_context_val f sign then user_err ~hdr:"Logic.prim_refiner" diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index 3bcd235b41..df07dcbca7 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -91,7 +91,7 @@ struct | DArray (t,def,ty) -> DArray(Array.map f t, f def, f ty) let compare_ci ci1 ci2 = - let c = ind_ord ci1.ci_ind ci2.ci_ind in + let c = Ind.CanOrd.compare ci1.ci_ind ci2.ci_ind in if c = 0 then let c = Int.compare ci1.ci_npar ci2.ci_npar in if c = 0 then @@ -107,7 +107,7 @@ struct | DRel, _ -> -1 | _, DRel -> 1 | DSort, DSort -> 0 | DSort, _ -> -1 | _, DSort -> 1 - | DRef gr1, DRef gr2 -> GlobRef.Ordered.compare gr1 gr2 + | DRef gr1, DRef gr2 -> GlobRef.CanOrd.compare gr1 gr2 | DRef _, _ -> -1 | _, DRef _ -> 1 | DCtx (tl1, tr1), DCtx (tl2, tr2) diff --git a/test-suite/misc/quotation_token/src/quotation.mlg b/test-suite/misc/quotation_token/src/quotation.mlg index 961b170a0d..ba0bcb1b3c 100644 --- a/test-suite/misc/quotation_token/src/quotation.mlg +++ b/test-suite/misc/quotation_token/src/quotation.mlg @@ -2,9 +2,9 @@ open Pcoq.Constr } GRAMMAR EXTEND Gram - GLOBAL: operconstr; + GLOBAL: term; - operconstr: LEVEL "0" + term: LEVEL "0" [ [ s = QUOTATION "foobar:" -> { CAst.make ~loc Constrexpr.(CSort Glob_term.(UNamed [GProp,0])) } ] ] diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index da2fc90fc3..01564e7f25 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -178,3 +178,6 @@ match N with | _ => Node end : Tree -> Tree +File "stdin", line 253, characters 4-5: +Warning: Unused variable B catches more than one case. +[unused-pattern-matching-variable,pattern-matching] diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 262ec2b677..2d8a8b359c 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -242,3 +242,15 @@ end. Print stray. End Bug11231. + +Module Wish12762. + +Inductive foo := a | b | c. + +Definition bar (f : foo) := + match f with + | a => 0 + | B => 1 + end. + +End Wish12762. diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index a42518822f..fa0c20bf73 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -8,7 +8,7 @@ Entry custom:myconstr is | "4" RIGHTA [ SELF; "*"; NEXT ] | "3" RIGHTA - [ "<"; operconstr LEVEL "10"; ">" ] ] + [ "<"; term LEVEL "10"; ">" ] ] [< b > + < b > * < 2 >] : nat @@ -77,7 +77,7 @@ The command has indeed failed with message: The format is not the same on the right- and left-hand sides of the special token "..". Entry custom:expr is [ "201" RIGHTA - [ "{"; operconstr LEVEL "200"; "}" ] ] + [ "{"; term LEVEL "200"; "}" ] ] fun x : nat => [ x ] : nat -> nat diff --git a/test-suite/output/bug_13238.out b/test-suite/output/bug_13238.out new file mode 100644 index 0000000000..bda21aa9e3 --- /dev/null +++ b/test-suite/output/bug_13238.out @@ -0,0 +1,4 @@ +Ltac bug_13238.t1 x := replace (x x) with (x x) +Ltac bug_13238.t2 x := case : x +Ltac bug_13238.t3 := by move -> +Ltac bug_13238.t4 := congr True diff --git a/test-suite/output/bug_13238.v b/test-suite/output/bug_13238.v new file mode 100644 index 0000000000..9b8063bf13 --- /dev/null +++ b/test-suite/output/bug_13238.v @@ -0,0 +1,13 @@ +Require Import ssreflect. + +Ltac t1 x := replace (x x) with (x x). +Print t1. + +Ltac t2 x := case: x. +Print t2. + +Ltac t3 := by move->. +Print t3. + +Ltac t4 := congr True. +Print t4. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index c3c6c96997..02f408fd85 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -139,8 +139,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. | xH => match m with | Leaf => Leaf - | Node Leaf o Leaf => Leaf - | Node l o r => Node l None r + | Node Leaf _ Leaf => Leaf + | Node l _ r => Node l None r end | xO ii => match m with diff --git a/theories/Strings/ByteVector.v b/theories/Strings/ByteVector.v index ac0323442a..144ffd59e0 100644 --- a/theories/Strings/ByteVector.v +++ b/theories/Strings/ByteVector.v @@ -42,7 +42,7 @@ Fixpoint to_Bvector {n : nat} (v : ByteVector n) : Bvector (n * 8) := Fixpoint of_Bvector {n : nat} : Bvector (n * 8) -> ByteVector n := match n with | 0 => fun _ => [] - | S n' => + | S _ => fun v => let (b0, v1) := uncons v in let (b1, v2) := uncons v1 in diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v index adffa1ded4..382538875d 100644 --- a/theories/Structures/OrdersEx.v +++ b/theories/Structures/OrdersEx.v @@ -138,12 +138,12 @@ Module PositiveOrderedTypeBits <: UsualOrderedType. Fixpoint compare x y := match x, y with | x~1, y~1 => compare x y - | x~1, _ => Gt + | _~1, _ => Gt | x~0, y~0 => compare x y - | x~0, _ => Lt - | 1, y~1 => Lt + | _~0, _ => Lt + | 1, _~1 => Lt | 1, 1 => Eq - | 1, y~0 => Gt + | 1, _~0 => Gt end. Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). diff --git a/theories/micromega/RingMicromega.v b/theories/micromega/RingMicromega.v index fb7fbcf80b..f7a848d7a5 100644 --- a/theories/micromega/RingMicromega.v +++ b/theories/micromega/RingMicromega.v @@ -1122,8 +1122,8 @@ Definition simpl_cone (e:Psatz) : Psatz := end | PsatzMulE t1 t2 => match t1 , t2 with - | PsatzZ , x => PsatzZ - | x , PsatzZ => PsatzZ + | PsatzZ , _ => PsatzZ + | _ , PsatzZ => PsatzZ | PsatzC c , PsatzC c' => PsatzC (ctimes c c') | PsatzC p1 , PsatzMulE (PsatzC p2) x => PsatzMulE (PsatzC (ctimes p1 p2)) x | PsatzC p1 , PsatzMulE x (PsatzC p2) => PsatzMulE (PsatzC (ctimes p1 p2)) x diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 5ae8f4ae6e..6749169e8c 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -71,8 +71,9 @@ let test_ltac1_env = lk_ident_list >> lk_kw "|-" end -let tac2expr = Tac2entries.Pltac.tac2expr -let tac2type = Entry.create "tac2type" +let ltac2_expr = Tac2entries.Pltac.ltac2_expr +let _ltac2_expr = ltac2_expr +let ltac2_type = Entry.create "ltac2_type" let tac2def_val = Entry.create "tac2def_val" let tac2def_typ = Entry.create "tac2def_typ" let tac2def_ext = Entry.create "tac2def_ext" @@ -80,7 +81,7 @@ let tac2def_syn = Entry.create "tac2def_syn" let tac2def_mut = Entry.create "tac2def_mut" let tac2mode = Entry.create "ltac2_command" -let ltac1_expr = Pltac.tactic_expr +let ltac_expr = Pltac.ltac_expr let tac2expr_in_env = Tac2entries.Pltac.tac2expr_in_env let inj_wit wit loc x = CAst.make ~loc @@ CTacExt (wit, x) @@ -101,7 +102,7 @@ let pattern_of_qualid qid = } GRAMMAR EXTEND Gram - GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn + GLOBAL: ltac2_expr ltac2_type tac2def_val tac2def_typ tac2def_ext tac2def_syn tac2def_mut tac2expr_in_env; tac2pat: [ "1" LEFTA @@ -125,7 +126,7 @@ GRAMMAR EXTEND Gram atomic_tac2pat: [ [ -> { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } - | p = tac2pat; ":"; t = tac2type -> + | p = tac2pat; ":"; t = ltac2_type -> { CAst.make ~loc @@ CPatCnv (p, t) } | p = tac2pat; ","; pl = LIST0 tac2pat SEP "," -> { let pl = p :: pl in @@ -133,17 +134,17 @@ GRAMMAR EXTEND Gram | p = tac2pat -> { p } ] ] ; - tac2expr: + ltac2_expr: [ "6" RIGHTA [ e1 = SELF; ";"; e2 = SELF -> { CAst.make ~loc @@ CTacSeq (e1, e2) } ] | "5" - [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "6" -> + [ "fun"; it = LIST1 input_fun ; "=>"; body = ltac2_expr LEVEL "6" -> { CAst.make ~loc @@ CTacFun (it, body) } | "let"; isrec = rec_flag; lc = LIST1 let_clause SEP "with"; "in"; - e = tac2expr LEVEL "6" -> + e = ltac2_expr LEVEL "6" -> { CAst.make ~loc @@ CTacLet (isrec, lc, e) } - | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> + | "match"; e = ltac2_expr LEVEL "5"; "with"; bl = branches; "end" -> { CAst.make ~loc @@ CTacCse (e, bl) } ] | "4" LEFTA [ ] @@ -151,25 +152,25 @@ GRAMMAR EXTEND Gram { let el = e0 :: el in CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ] | "2" RIGHTA - [ e1 = tac2expr; "::"; e2 = tac2expr -> + [ e1 = ltac2_expr; "::"; e2 = ltac2_expr -> { CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) } ] | "1" LEFTA - [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> + [ e = ltac2_expr; el = LIST1 ltac2_expr LEVEL "0" -> { CAst.make ~loc @@ CTacApp (e, el) } | e = SELF; ".("; qid = Prim.qualid; ")" -> { CAst.make ~loc @@ CTacPrj (e, RelId qid) } - | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> + | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = ltac2_expr LEVEL "5" -> { CAst.make ~loc @@ CTacSet (e, RelId qid, r) } ] | "0" [ "("; a = SELF; ")" -> { a } - | "("; a = SELF; ":"; t = tac2type; ")" -> + | "("; a = SELF; ":"; t = ltac2_type; ")" -> { CAst.make ~loc @@ CTacCnv (a, t) } | "()" -> { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } | "("; ")" -> { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } - | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> + | "["; a = LIST0 ltac2_expr LEVEL "5" SEP ";"; "]" -> { Tac2quote.of_list ~loc (fun x -> x) a } | "{"; a = tac2rec_fieldexprs; "}" -> { CAst.make ~loc @@ CTacRec a } @@ -183,7 +184,7 @@ GRAMMAR EXTEND Gram ] ; branch: - [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "6" -> { (pat, e) } ] ] + [ [ pat = tac2pat LEVEL "1"; "=>"; e = ltac2_expr LEVEL "6" -> { (pat, e) } ] ] ; rec_flag: [ [ IDENT "rec" -> { true } @@ -193,7 +194,7 @@ GRAMMAR EXTEND Gram [ [ IDENT "mutable" -> { true } | -> { false } ] ] ; - typ_param: + ltac2_typevar: [ [ "'"; id = Prim.ident -> { id } ] ] ; tactic_atom: @@ -210,19 +211,19 @@ GRAMMAR EXTEND Gram | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_constr c } | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_open_constr c } | IDENT "ident"; ":"; "("; c = lident; ")" -> { Tac2quote.of_ident c } - | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> { inj_pattern loc c } + | IDENT "pattern"; ":"; "("; c = Constr.cpattern; ")" -> { inj_pattern loc c } | IDENT "reference"; ":"; "("; c = globref; ")" -> { inj_reference loc c } | IDENT "ltac1"; ":"; "("; qid = ltac1_expr_in_env; ")" -> { inj_ltac1 loc qid } | IDENT "ltac1val"; ":"; "("; qid = ltac1_expr_in_env; ")" -> { inj_ltac1val loc qid } ] ] ; ltac1_expr_in_env: - [ [ test_ltac1_env; ids = LIST0 locident; "|-"; e = ltac1_expr -> { ids, e } - | e = ltac1_expr -> { [], e } + [ [ test_ltac1_env; ids = LIST0 locident; "|-"; e = ltac_expr -> { ids, e } + | e = ltac_expr -> { [], e } ] ] ; tac2expr_in_env : - [ [ test_ltac1_env; ids = LIST0 locident; "|-"; e = tac2expr -> + [ [ test_ltac1_env; ids = LIST0 locident; "|-"; e = ltac2_expr -> { let check { CAst.v = id; CAst.loc = loc } = if Tac2env.is_constructor (Libnames.qualid_of_ident ?loc id) then CErrors.user_err ?loc Pp.(str "Invalid bound Ltac2 identifier " ++ Id.print id) @@ -230,11 +231,11 @@ GRAMMAR EXTEND Gram let () = List.iter check ids in (ids, e) } - | tac = tac2expr -> { [], tac } + | tac = ltac2_expr -> { [], tac } ] ] ; let_clause: - [ [ binder = let_binder; ":="; te = tac2expr -> + [ [ binder = let_binder; ":="; te = ltac2_expr -> { let (pat, fn) = binder in let te = match fn with | None -> te @@ -252,23 +253,23 @@ GRAMMAR EXTEND Gram | _ -> CErrors.user_err ~loc (str "Invalid pattern") } ] ] ; - tac2type: + ltac2_type: [ "5" RIGHTA - [ t1 = tac2type; "->"; t2 = tac2type -> { CAst.make ~loc @@ CTypArrow (t1, t2) } ] + [ t1 = ltac2_type; "->"; t2 = ltac2_type -> { CAst.make ~loc @@ CTypArrow (t1, t2) } ] | "2" - [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> + [ t = ltac2_type; "*"; tl = LIST1 ltac2_type LEVEL "1" SEP "*" -> { let tl = t :: tl in CAst.make ~loc @@ CTypRef (AbsKn (Tuple (List.length tl)), tl) } ] | "1" LEFTA [ t = SELF; qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, [t]) } ] | "0" - [ "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = OPT Prim.qualid -> + [ "("; p = LIST1 ltac2_type LEVEL "5" SEP ","; ")"; qid = OPT Prim.qualid -> { match p, qid with | [t], None -> t | _, None -> CErrors.user_err ~loc (Pp.str "Syntax error") | ts, Some qid -> CAst.make ~loc @@ CTypRef (RelId qid, p) } - | id = typ_param -> { CAst.make ~loc @@ CTypVar (Name id) } + | id = ltac2_typevar -> { CAst.make ~loc @@ CTypVar (Name id) } | "_" -> { CAst.make ~loc @@ CTypVar Anonymous } | qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, []) } ] @@ -284,7 +285,7 @@ GRAMMAR EXTEND Gram [ [ b = tac2pat LEVEL "0" -> { b } ] ] ; tac2def_body: - [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> + [ [ name = binder; it = LIST0 input_fun; ":="; e = ltac2_expr -> { let e = if List.is_empty it then e else CAst.make ~loc @@ CTacFun (it, e) in (name, e) } ] ] @@ -295,10 +296,10 @@ GRAMMAR EXTEND Gram ] ] ; tac2def_mut: - [ [ "Set"; qid = Prim.qualid; old = OPT [ "as"; id = locident -> { id } ]; ":="; e = tac2expr -> { StrMut (qid, old, e) } ] ] + [ [ "Set"; qid = Prim.qualid; old = OPT [ "as"; id = locident -> { id } ]; ":="; e = ltac2_expr -> { StrMut (qid, old, e) } ] ] ; tac2typ_knd: - [ [ t = tac2type -> { CTydDef (Some t) } + [ [ t = ltac2_type -> { CTydDef (Some t) } | "["; ".."; "]" -> { CTydOpn } | "["; t = tac2alg_constructors; "]" -> { CTydAlg t } | "{"; t = tac2rec_fields; "}"-> { CTydRec t } ] ] @@ -309,7 +310,7 @@ GRAMMAR EXTEND Gram ; tac2alg_constructor: [ [ c = Prim.ident -> { (c, []) } - | c = Prim.ident; "("; args = LIST0 tac2type SEP ","; ")"-> { (c, args) } ] ] + | c = Prim.ident; "("; args = LIST0 ltac2_type SEP ","; ")"-> { (c, args) } ] ] ; tac2rec_fields: [ [ f = tac2rec_field; ";"; l = tac2rec_fields -> { f :: l } @@ -318,7 +319,7 @@ GRAMMAR EXTEND Gram | -> { [] } ] ] ; tac2rec_field: - [ [ mut = mut_flag; id = Prim.ident; ":"; t = tac2type -> { (id, mut, t) } ] ] + [ [ mut = mut_flag; id = Prim.ident; ":"; t = ltac2_type -> { (id, mut, t) } ] ] ; tac2rec_fieldexprs: [ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> { f :: l } @@ -327,12 +328,12 @@ GRAMMAR EXTEND Gram | -> { [] } ] ] ; tac2rec_fieldexpr: - [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> { RelId qid, e } ] ] + [ [ qid = Prim.qualid; ":="; e = ltac2_expr LEVEL "1" -> { RelId qid, e } ] ] ; tac2typ_prm: [ [ -> { [] } - | id = typ_param -> { [CAst.make ~loc id] } - | "("; ids = LIST1 [ id = typ_param -> { CAst.make ~loc id } ] SEP "," ;")" -> { ids } + | id = ltac2_typevar -> { [CAst.make ~loc id] } + | "("; ids = LIST1 [ id = ltac2_typevar -> { CAst.make ~loc id } ] SEP "," ;")" -> { ids } ] ] ; tac2typ_def: @@ -350,7 +351,7 @@ GRAMMAR EXTEND Gram ] ] ; tac2def_ext: - [ [ "@"; IDENT "external"; id = locident; ":"; t = tac2type LEVEL "5"; ":="; + [ [ "@"; IDENT "external"; id = locident; ":"; t = ltac2_type LEVEL "5"; ":="; plugin = Prim.string; name = Prim.string -> { let ml = { mltac_plugin = plugin; mltac_tactic = name } in StrPrm (id, t, ml) } @@ -361,11 +362,11 @@ GRAMMAR EXTEND Gram | id = Prim.ident -> { CAst.make ~loc (Some id) } ] ] ; - sexpr: + ltac2_scope: [ [ s = Prim.string -> { SexprStr (CAst.make ~loc s) } | n = Prim.integer -> { SexprInt (CAst.make ~loc n) } | id = syn_node -> { SexprRec (loc, id, []) } - | id = syn_node; "("; tok = LIST1 sexpr SEP "," ; ")" -> + | id = syn_node; "("; tok = LIST1 ltac2_scope SEP "," ; ")" -> { SexprRec (loc, id, tok) } ] ] ; @@ -375,8 +376,8 @@ GRAMMAR EXTEND Gram ] ] ; tac2def_syn: - [ [ "Notation"; toks = LIST1 sexpr; n = syn_level; ":="; - e = tac2expr -> + [ [ "Notation"; toks = LIST1 ltac2_scope; n = syn_level; ":="; + e = ltac2_expr -> { StrSyn (toks, n, e) } ] ] ; @@ -497,7 +498,7 @@ GRAMMAR EXTEND Gram ; simple_intropattern: [ [ pat = simple_intropattern_closed -> -(* l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> *) +(* l = LIST0 ["%"; c = term LEVEL "0" -> c] -> *) (** TODO: handle %pat *) { pat } ] ] @@ -654,26 +655,26 @@ GRAMMAR EXTEND Gram [ [ r = oriented_rewriter -> { r } ] ] ; tactic_then_last: - [ [ "|"; lta = LIST0 (OPT tac2expr LEVEL "6") SEP "|" -> { lta } + [ [ "|"; lta = LIST0 (OPT ltac2_expr LEVEL "6") SEP "|" -> { lta } | -> { [] } ] ] ; - tactic_then_gen: - [ [ ta = tac2expr; "|"; tg = tactic_then_gen -> { let (first,last) = tg in (Some ta :: first, last) } - | ta = tac2expr; ".."; l = tactic_then_last -> { ([], Some (Some ta, l)) } + for_each_goal: + [ [ ta = ltac2_expr; "|"; tg = for_each_goal -> { let (first,last) = tg in (Some ta :: first, last) } + | ta = ltac2_expr; ".."; l = tactic_then_last -> { ([], Some (Some ta, l)) } | ".."; l = tactic_then_last -> { ([], Some (None, l)) } - | ta = tac2expr -> { ([Some ta], None) } - | "|"; tg = tactic_then_gen -> { let (first,last) = tg in (None :: first, last) } + | ta = ltac2_expr -> { ([Some ta], None) } + | "|"; tg = for_each_goal -> { let (first,last) = tg in (None :: first, last) } | -> { ([None], None) } ] ] ; q_dispatch: - [ [ d = tactic_then_gen -> { CAst.make ~loc d } ] ] + [ [ d = for_each_goal -> { CAst.make ~loc d } ] ] ; q_occurrences: [ [ occs = occs -> { occs } ] ] ; - red_flag: + ltac2_red_flag: [ [ IDENT "beta" -> { CAst.make ~loc @@ QBeta } | IDENT "iota" -> { CAst.make ~loc @@ QIota } | IDENT "match" -> { CAst.make ~loc @@ QMatch } @@ -702,7 +703,7 @@ GRAMMAR EXTEND Gram ] ] ; strategy_flag: - [ [ s = LIST1 red_flag -> { CAst.make ~loc s } + [ [ s = LIST1 ltac2_red_flag -> { CAst.make ~loc s } | d = delta_flag -> { CAst.make ~loc [CAst.make ~loc QBeta; CAst.make ~loc QIota; CAst.make ~loc QZeta; d] } @@ -721,11 +722,11 @@ GRAMMAR EXTEND Gram ; match_pattern: [ [ IDENT "context"; id = OPT Prim.ident; - "["; pat = Constr.lconstr_pattern; "]" -> { CAst.make ~loc @@ QConstrMatchContext (id, pat) } - | pat = Constr.lconstr_pattern -> { CAst.make ~loc @@ QConstrMatchPattern pat } ] ] + "["; pat = Constr.cpattern; "]" -> { CAst.make ~loc @@ QConstrMatchContext (id, pat) } + | pat = Constr.cpattern -> { CAst.make ~loc @@ QConstrMatchPattern pat } ] ] ; match_rule: - [ [ mp = match_pattern; "=>"; tac = tac2expr -> + [ [ mp = match_pattern; "=>"; tac = ltac2_expr -> { CAst.make ~loc @@ (mp, tac) } ] ] ; @@ -748,16 +749,16 @@ GRAMMAR EXTEND Gram ] ] ; gmatch_rule: - [ [ mp = gmatch_pattern; "=>"; tac = tac2expr -> + [ [ mp = gmatch_pattern; "=>"; tac = ltac2_expr -> { CAst.make ~loc @@ (mp, tac) } ] ] ; - gmatch_list: + goal_match_list: [ [ mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } | "|"; mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] ; q_goal_matching: - [ [ m = gmatch_list -> { m } ] ] + [ [ m = goal_match_list -> { m } ] ] ; move_location: [ [ "at"; IDENT "top" -> { CAst.make ~loc @@ QMoveFirst } @@ -789,7 +790,7 @@ GRAMMAR EXTEND Gram ] ] ; by_tactic: - [ [ "by"; tac = tac2expr -> { Some tac } + [ [ "by"; tac = ltac2_expr -> { Some tac } | -> { None } ] ] ; @@ -812,8 +813,8 @@ END (* GRAMMAR EXTEND Gram - Pcoq.Constr.operconstr: LEVEL "0" - [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> + Pcoq.Constr.term: LEVEL "0" + [ [ IDENT "ltac2"; ":"; "("; tac = ltac2_expr; ")" -> { let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } | test_ampersand_ident; "&"; id = Prim.ident -> @@ -858,7 +859,7 @@ let rules = [ Pcoq.( Production.make (Rule.stop ++ Symbol.token (PIDENT (Some "ltac2")) ++ Symbol.token (PKEYWORD ":") ++ - Symbol.token (PKEYWORD "(") ++ Symbol.nterm tac2expr ++ Symbol.token (PKEYWORD ")")) + Symbol.token (PKEYWORD "(") ++ Symbol.nterm ltac2_expr ++ Symbol.token (PKEYWORD ")")) begin fun _ tac _ _ _ loc -> let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) @@ -867,7 +868,7 @@ let rules = [ ] in Hook.set Tac2entries.register_constr_quotations begin fun () -> - Pcoq.grammar_extend Pcoq.Constr.operconstr {pos=Some (Gramlib.Gramext.Level "0"); data=[(None, None, rules)]} + Pcoq.grammar_extend Pcoq.Constr.term {pos=Some (Gramlib.Gramext.Level "0"); data=[(None, None, rules)]} end } @@ -890,7 +891,7 @@ END VERNAC ARGUMENT EXTEND ltac2_expr PRINTED BY { pr_ltac2expr } -| [ tac2expr(e) ] -> { e } +| [ _ltac2_expr(e) ] -> { e } END { @@ -920,10 +921,10 @@ open Vernacextend } VERNAC { tac2mode } EXTEND VernacLtac2 -| ![proof] [ ltac2_expr(t) ltac_use_default(default) ] => +| ![proof] [ ltac2_expr(t) ltac_use_default(with_end_tac) ] => { classify_as_proofstep } -> { (* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) - fun ~pstate -> Tac2entries.call ~pstate ~default t } + fun ~pstate -> Tac2entries.call ~pstate ~with_end_tac t } END GRAMMAR EXTEND Gram diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 3ce50865c0..5d49d1635c 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1541,12 +1541,12 @@ end let () = add_scope "tactic" begin function | [] -> (* Default to level 5 parsing *) - let scope = Pcoq.Symbol.nterml tac2expr "5" in + let scope = Pcoq.Symbol.nterml ltac2_expr "5" in let act tac = tac in Tac2entries.ScopeRule (scope, act) | [SexprInt {loc;v=n}] as arg -> let () = if n < 0 || n > 6 then scope_fail "tactic" arg in - let scope = Pcoq.Symbol.nterml tac2expr (string_of_int n) in + let scope = Pcoq.Symbol.nterml ltac2_expr (string_of_int n) in let act tac = tac in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "tactic" arg diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 30340cd632..eebd6635fa 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -24,7 +24,8 @@ open Tac2intern module Pltac = struct -let tac2expr = Pcoq.Entry.create "tac2expr" +let ltac2_expr = Pcoq.Entry.create "ltac2_expr" +let tac2expr = ltac2_expr let tac2expr_in_env = Pcoq.Entry.create "tac2expr_in_env" let q_ident = Pcoq.Entry.create "q_ident" @@ -643,7 +644,7 @@ let perform_notation syn st = | Some lev -> Some (string_of_int lev) in let rule = (lev, None, [rule]) in - ([Pcoq.ExtendRule (Pltac.tac2expr, {Pcoq.pos=None; data=[rule]})], st) + ([Pcoq.ExtendRule (Pltac.ltac2_expr, {Pcoq.pos=None; data=[rule]})], st) let ltac2_notation = Pcoq.create_grammar_command "ltac2-notation" perform_notation @@ -911,25 +912,19 @@ let print_ltac qid = (** Calling tactics *) -let solve ~pstate default tac = - let pstate, status = Declare.Proof.map_fold_endline pstate ~f:(fun etac p -> - let with_end_tac = if default then Some etac else None in - let g = Goal_select.get_default_goal_selector () in - let (p, status) = Proof.solve g None tac ?with_end_tac p in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p, status) - in - if not status then Feedback.feedback Feedback.AddedAxiom; - pstate - -let call ~pstate ~default e = +let ltac2_interp e = let loc = e.loc in let (e, t) = intern ~strict:false [] e in let () = check_unit ?loc t in let tac = Tac2interp.interp Tac2interp.empty_environment e in - solve ~pstate default (Proofview.tclIGNORE tac) + Proofview.tclIGNORE tac + +let ComTactic.Interpreter ltac2_interp = ComTactic.register_tactic_interpreter "ltac2" ltac2_interp + +let call ~pstate ~with_end_tac tac = + ComTactic.solve ~pstate ~with_end_tac + (Goal_select.get_default_goal_selector()) + ~info:None (ltac2_interp tac) (** Primitive algebraic types than can't be defined Coq-side *) diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli index fc56a54e3a..782968c6e1 100644 --- a/user-contrib/Ltac2/tac2entries.mli +++ b/user-contrib/Ltac2/tac2entries.mli @@ -53,7 +53,7 @@ val print_ltac : Libnames.qualid -> unit (** {5 Eval loop} *) (** Evaluate a tactic expression in the current environment *) -val call : pstate:Declare.Proof.t -> default:bool -> raw_tacexpr -> Declare.Proof.t +val call : pstate:Declare.Proof.t -> with_end_tac:bool -> raw_tacexpr -> Declare.Proof.t (** {5 Toplevel exceptions} *) @@ -63,7 +63,9 @@ val backtrace : backtrace Exninfo.t module Pltac : sig +val ltac2_expr : raw_tacexpr Pcoq.Entry.t val tac2expr : raw_tacexpr Pcoq.Entry.t + [@@deprecated "Deprecated in 8.13; use 'ltac2_expr' instead"] val tac2expr_in_env : (Id.t CAst.t list * raw_tacexpr) Pcoq.Entry.t (** Quoted entries. To be used for complex notations. *) diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 7a7e7d6e35..f715459616 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -145,7 +145,7 @@ let build_beq_scheme_deps kn = | Cast (x,_,_) -> aux accu (Term.applist (x,a)) | App _ -> assert false | Ind ((kn', _), _) -> - if MutInd.equal kn kn' then accu + if Environ.QMutInd.equal env kn kn' then accu else let eff = SchemeMutualDep (kn', !beq_scheme_kind_aux ()) in List.fold_left aux (eff :: accu) a @@ -253,7 +253,7 @@ let build_beq_scheme mode kn = | Cast (x,_,_) -> aux (Term.applist (x,a)) | App _ -> assert false | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> - if MutInd.equal kn kn' then mkRel(eqA-nlist-i+nb_ind-1) + if Environ.QMutInd.equal env kn kn' then mkRel(eqA-nlist-i+nb_ind-1) else begin try let eq = match lookup_scheme (!beq_scheme_kind_aux()) ind' with @@ -496,7 +496,7 @@ let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let u,v = try destruct_ind env sigma tt1 (* trick so that the good sequence is returned*) with e when CErrors.noncritical e -> indu,[||] - in if eq_ind (fst u) ind + in if Ind.CanOrd.equal (fst u) ind then Tacticals.New.tclTHENLIST [Equality.replace t1 t2; Auto.default_auto ; aux q1 q2 ] else ( find_scheme bl_scheme_key (fst u) (*FIXME*) >>= fun c -> @@ -539,7 +539,8 @@ let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = with DestKO -> Tacticals.New.tclZEROMSG (str "The expected type is an inductive one.") end end >>= fun (sp2,i2) -> - if not (MutInd.equal sp1 sp2) || not (Int.equal i1 i2) + Proofview.tclENV >>= fun env -> + if not (Environ.QMutInd.equal env sp1 sp2) || not (Int.equal i1 i2) then Tacticals.New.tclZEROMSG (str "Eq should be on the same type") else aux (Array.to_list ca1) (Array.to_list ca2) diff --git a/vernac/comTactic.ml b/vernac/comTactic.ml index 8a9a412362..2252d46e58 100644 --- a/vernac/comTactic.ml +++ b/vernac/comTactic.ml @@ -16,13 +16,13 @@ module DMap = Dyn.Map(struct type 'a t = 'a -> unit Proofview.tactic end) let interp_map = ref DMap.empty -type 'a tactic_interpreter = 'a Dyn.tag -type interpretable = I : 'a tactic_interpreter * 'a -> interpretable +type interpretable = I : 'a Dyn.tag * 'a -> interpretable +type 'a tactic_interpreter = Interpreter of ('a -> interpretable) let register_tactic_interpreter na f = let t = Dyn.create na in interp_map := DMap.add t f !interp_map; - t + Interpreter (fun x -> I (t,x)) let interp_tac (I (tag,t)) = let f = DMap.find tag !interp_map in diff --git a/vernac/comTactic.mli b/vernac/comTactic.mli index f1a75e1b6a..72e71d013a 100644 --- a/vernac/comTactic.mli +++ b/vernac/comTactic.mli @@ -9,10 +9,13 @@ (************************************************************************) (** Tactic interpreters have to register their interpretation function *) -type 'a tactic_interpreter -type interpretable = I : 'a tactic_interpreter * 'a -> interpretable +type interpretable -(** ['a] should be marshallable if ever used with [par:] *) +type 'a tactic_interpreter = private Interpreter of ('a -> interpretable) + +(** ['a] should be marshallable if ever used with [par:]. Must be + called no more than once per process with a particular string: make + sure to use partial application. *) val register_tactic_interpreter : string -> ('a -> unit Proofview.tactic) -> 'a tactic_interpreter diff --git a/vernac/declare.ml b/vernac/declare.ml index 5274a6da3b..3a8ceb0e0f 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -162,7 +162,7 @@ let cache_constant ((sp,kn), obj) = then Constant.make1 kn else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(Libnames.basename sp) ++ str".") in - assert (Constant.equal kn' (Constant.make1 kn)); + assert (Environ.QConstant.equal (Global.env ()) kn' (Constant.make1 kn)); Nametab.push (Nametab.Until 1) sp (GlobRef.ConstRef (Constant.make1 kn)); Dumpglob.add_constant_kind (Constant.make1 kn) obj.cst_kind @@ -2206,26 +2206,60 @@ let warn_solve_errored = ; fnl () ; str "This will become an error in the future" ]) -let solve_by_tac ?loc name evi t ~poly ~uctx = - (* the status is dropped. *) +let solve_by_tac prg obls i tac = + let obl = obls.(i) in + let obl = subst_deps_obl obls obl in + let tac = Option.(default !default_tactic (append tac obl.obl_tac)) in + let uctx = Internal.get_uctx prg in + let uctx = UState.update_sigma_univs uctx (Global.universes ()) in + let poly = Internal.get_poly prg in + let evi = evar_of_obligation obl in + (* the status of [build_by_tactic] is dropped. *) try let env = Global.env () in let body, types, _univs, _, uctx = - build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl t in + build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl tac in Inductiveops.control_only_guard env (Evd.from_ctx uctx) (EConstr.of_constr body); Some (body, types, uctx) with | Tacticals.FailError (_, s) as exn -> let _ = Exninfo.capture exn in + let loc = fst obl.obl_location in CErrors.user_err ?loc ~hdr:"solve_obligation" (Lazy.force s) (* If the proof is open we absorb the error and leave the obligation open *) | Proof_.OpenProof _ -> None | e when CErrors.noncritical e -> let err = CErrors.print e in + let loc = fst obl.obl_location in warn_solve_errored ?loc err; None +let solve_and_declare_by_tac prg obls i tac = + match solve_by_tac prg obls i tac with + | None -> None + | Some (t, ty, uctx) -> + let obl = obls.(i) in + let poly = Internal.get_poly prg in + let prg = ProgramDecl.Internal.set_uctx ~uctx prg in + let def, obl', _cst = declare_obligation prg obl ~body:t ~types:ty ~uctx in + obls.(i) <- obl'; + if def && not poly then ( + (* Declare the term constraints with the first obligation only *) + let uctx_global = UState.from_env (Global.env ()) in + let uctx = UState.merge_subst uctx_global (UState.subst uctx) in + Some (ProgramDecl.Internal.set_uctx ~uctx prg)) + else Some prg + +let solve_obligation_by_tac prg obls i tac = + let obl = obls.(i) in + match obl.obl_body with + | Some _ -> None + | None -> + if List.is_empty (deps_remaining obls obl.obl_deps) + then solve_and_declare_by_tac prg obls i tac + else None + let get_unique_prog ~pm prg = match State.get_unique_open_prog pm prg with | Ok prg -> prg @@ -2263,49 +2297,6 @@ let rec solve_obligation prg num tac = let lemma = Option.cata (fun tac -> Proof.set_endline_tactic tac lemma) lemma tac in lemma -and obligation (user_num, name, typ) ~pm tac = - let num = pred user_num in - let prg = get_unique_prog ~pm name in - let { obls; remaining } = Internal.get_obligations prg in - if num >= 0 && num < Array.length obls then - let obl = obls.(num) in - match obl.obl_body with - | None -> solve_obligation prg num tac - | Some r -> Error.already_solved num - else Error.unknown_obligation num - -and solve_obligation_by_tac prg obls i tac = - let obl = obls.(i) in - match obl.obl_body with - | Some _ -> None - | None -> - if List.is_empty (deps_remaining obls obl.obl_deps) then - let obl = subst_deps_obl obls obl in - let tac = - match tac with - | Some t -> t - | None -> - match obl.obl_tac with - | Some t -> t - | None -> !default_tactic - in - let uctx = Internal.get_uctx prg in - let uctx = UState.update_sigma_univs uctx (Global.universes ()) in - let poly = Internal.get_poly prg in - match solve_by_tac ?loc:(fst obl.obl_location) obl.obl_name (evar_of_obligation obl) tac ~poly ~uctx with - | None -> None - | Some (t, ty, uctx) -> - let prg = ProgramDecl.Internal.set_uctx ~uctx prg in - let def, obl', _cst = declare_obligation prg obl ~body:t ~types:ty ~uctx in - obls.(i) <- obl'; - if def && not poly then ( - (* Declare the term constraints with the first obligation only *) - let uctx_global = UState.from_env (Global.env ()) in - let uctx = UState.merge_subst uctx_global (UState.subst uctx) in - Some (ProgramDecl.Internal.set_uctx ~uctx prg)) - else Some prg - else None - and solve_prg_obligations ~pm prg ?oblset tac = let { obls; remaining } = Internal.get_obligations prg in let rem = ref remaining in @@ -2332,15 +2323,21 @@ and solve_prg_obligations ~pm prg ?oblset tac = in update_obls ~pm prg obls' !rem -and solve_obligations ~pm n tac = +and auto_solve_obligations ~pm n ?oblset tac : State.t * progress = + Flags.if_verbose Feedback.msg_info + (str "Solving obligations automatically..."); + let prg = get_unique_prog ~pm n in + solve_prg_obligations ~pm prg ?oblset tac + +let solve_obligations ~pm n tac = let prg = get_unique_prog ~pm n in solve_prg_obligations ~pm prg tac -and solve_all_obligations ~pm tac = +let solve_all_obligations ~pm tac = State.fold pm ~init:pm ~f:(fun k v pm -> solve_prg_obligations ~pm v tac |> fst) -and try_solve_obligation ~pm n prg tac = +let try_solve_obligation ~pm n prg tac = let prg = get_unique_prog ~pm prg in let {obls; remaining} = Internal.get_obligations prg in let obls' = Array.copy obls in @@ -2350,14 +2347,19 @@ and try_solve_obligation ~pm n prg tac = pm | None -> pm -and try_solve_obligations ~pm n tac = +let try_solve_obligations ~pm n tac = solve_obligations ~pm n tac |> fst -and auto_solve_obligations ~pm n ?oblset tac : State.t * progress = - Flags.if_verbose Feedback.msg_info - (str "Solving obligations automatically..."); - let prg = get_unique_prog ~pm n in - solve_prg_obligations ~pm prg ?oblset tac +let obligation (user_num, name, typ) ~pm tac = + let num = pred user_num in + let prg = get_unique_prog ~pm name in + let { obls; remaining } = Internal.get_obligations prg in + if num >= 0 && num < Array.length obls then + let obl = obls.(num) in + match obl.obl_body with + | None -> solve_obligation prg num tac + | Some r -> Error.already_solved num + else Error.unknown_obligation num let show_single_obligation i n obls x = let x = subst_deps_obl obls x in diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index b134f7b82b..123ea2c24e 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -300,13 +300,13 @@ let interp_constr_entry_key : type r. _ -> r target -> int -> r Entry.t * int op match forpat with | ForConstr -> if level = 200 then Constr.binder_constr, None - else Constr.operconstr, Some level + else Constr.term, Some level | ForPattern -> Constr.pattern, Some level let target_entry : type s. notation_entry -> s target -> s Entry.t = function | InConstrEntry -> (function - | ForConstr -> Constr.operconstr + | ForConstr -> Constr.term | ForPattern -> Constr.pattern) | InCustomEntry s -> let (entry_for_constr, entry_for_patttern) = find_custom_entry s in diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index dfc7b05b51..3d6a93c888 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -48,7 +48,7 @@ let assumption_token = Entry.create "assumption_token" let def_body = Entry.create "def_body" let decl_notations = Entry.create "decl_notations" let record_field = Entry.create "record_field" -let of_type_with_opt_coercion = Entry.create "of_type_with_opt_coercion" +let of_type = Entry.create "of_type" let section_subset_expr = Entry.create "section_subset_expr" let scope_delimiter = Entry.create "scope_delimiter" let syntax_modifiers = Entry.create "syntax_modifiers" @@ -113,10 +113,10 @@ GRAMMAR EXTEND Gram ] ; attribute: - [ [ k = ident ; v = attribute_value -> { Names.Id.to_string k, v } ] + [ [ k = ident ; v = attr_value -> { Names.Id.to_string k, v } ] ] ; - attribute_value: + attr_value: [ [ "=" ; v = string -> { VernacFlagLeaf v } | "(" ; a = attribute_list ; ")" -> { VernacFlagList a } | -> { VernacFlagEmpty } ] @@ -196,8 +196,8 @@ let name_of_ident_decl : ident_decl -> name_decl = (* Gallina declarations *) GRAMMAR EXTEND Gram - GLOBAL: gallina gallina_ext thm_token def_token assumption_token def_body of_type_with_opt_coercion - record_field decl_notations rec_definition ident_decl univ_decl; + GLOBAL: gallina gallina_ext thm_token def_token assumption_token def_body of_type + record_field decl_notations fix_definition ident_decl univ_decl; gallina: (* Definition, Theorem, Variable, Axiom, ... *) @@ -219,13 +219,13 @@ GRAMMAR EXTEND Gram (* Gallina inductive declarations *) | f = finite_token; indl = LIST1 inductive_definition SEP "with" -> { VernacInductive (f, indl) } - | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> + | "Fixpoint"; recs = LIST1 fix_definition SEP "with" -> { VernacFixpoint (NoDischarge, recs) } - | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> + | IDENT "Let"; "Fixpoint"; recs = LIST1 fix_definition SEP "with" -> { VernacFixpoint (DoDischarge, recs) } - | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> + | "CoFixpoint"; corecs = LIST1 cofix_definition SEP "with" -> { VernacCoFixpoint (NoDischarge, corecs) } - | IDENT "Let"; "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> + | IDENT "Let"; "CoFixpoint"; corecs = LIST1 cofix_definition SEP "with" -> { VernacCoFixpoint (DoDischarge, corecs) } | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> { VernacScheme l } | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; @@ -339,7 +339,7 @@ GRAMMAR EXTEND Gram ; (* Inductives and records *) opt_constructors_or_fields: - [ [ ":="; lc = constructor_list_or_record_decl -> { lc } + [ [ ":="; lc = constructors_or_record -> { lc } | -> { RecordDecl (None, []) } ] ] ; inductive_definition: @@ -349,7 +349,7 @@ GRAMMAR EXTEND Gram lc=opt_constructors_or_fields; ntn = decl_notations -> { (((oc,id),(indpar,extrapar),c,lc),ntn) } ] ] ; - constructor_list_or_record_decl: + constructors_or_record: [ [ "|"; l = LIST1 constructor SEP "|" -> { Constructors l } | id = identref ; c = constructor_type; "|"; l = LIST1 constructor SEP "|" -> { Constructors ((c id)::l) } @@ -369,7 +369,7 @@ GRAMMAR EXTEND Gram | -> { false } ] ] ; (* (co)-fixpoints *) - rec_definition: + fix_definition: [ [ id_decl = ident_decl; bl = binders_fixannot; rtype = type_cstr; @@ -378,7 +378,7 @@ GRAMMAR EXTEND Gram {fname = fst id_decl; univs = snd id_decl; rec_order; binders; rtype; body_def; notations} } ] ] ; - corec_definition: + cofix_definition: [ [ id_decl = ident_decl; binders = binders; rtype = type_cstr; body_def = OPT [":="; def = lconstr -> { def }]; notations = decl_notations -> { {fname = fst id_decl; univs = snd id_decl; rec_order = (); binders; rtype; body_def; notations} @@ -427,10 +427,10 @@ GRAMMAR EXTEND Gram | -> { [] } ] ] ; - record_binder_body: - [ [ l = binders; oc = of_type_with_opt_coercion; + field_body: + [ [ l = binders; oc = of_type; t = lconstr -> { fun id -> (oc,AssumExpr (id,l,t)) } - | l = binders; oc = of_type_with_opt_coercion; + | l = binders; oc = of_type; t = lconstr; ":="; b = lconstr -> { fun id -> (oc,DefExpr (id,l,b,Some t)) } | l = binders; ":="; b = lconstr -> { fun id -> @@ -442,22 +442,22 @@ GRAMMAR EXTEND Gram ; record_binder: [ [ id = name -> { (NoInstance,AssumExpr(id, [], CAst.make ~loc @@ CHole (None, IntroAnonymous, None))) } - | id = name; f = record_binder_body -> { f id } ] ] + | id = name; f = field_body -> { f id } ] ] ; assum_list: - [ [ bl = LIST1 assum_coe -> { bl } | b = simple_assum_coe -> { [b] } ] ] + [ [ bl = LIST1 assum_coe -> { bl } | b = assumpt -> { [b] } ] ] ; assum_coe: - [ [ "("; a = simple_assum_coe; ")" -> { a } ] ] + [ [ "("; a = assumpt; ")" -> { a } ] ] ; - simple_assum_coe: - [ [ idl = LIST1 ident_decl; oc = of_type_with_opt_coercion; c = lconstr -> + assumpt: + [ [ idl = LIST1 ident_decl; oc = of_type; c = lconstr -> { (oc <> NoInstance,(idl,c)) } ] ] ; constructor_type: [[ l = binders; - t= [ coe = of_type_with_opt_coercion; c = lconstr -> + t= [ coe = of_type; c = lconstr -> { fun l id -> (coe <> NoInstance,(id,mkProdCN ~loc l c)) } | -> { fun l id -> (false,(id,mkProdCN ~loc l (CAst.make ~loc @@ CHole (None, IntroAnonymous, None)))) } ] @@ -468,7 +468,7 @@ GRAMMAR EXTEND Gram constructor: [ [ id = identref; c=constructor_type -> { c id } ] ] ; - of_type_with_opt_coercion: + of_type: [ [ ":>" -> { BackInstance } | ":"; ">" -> { BackInstance } | ":" -> { NoInstance } ] ] @@ -687,7 +687,7 @@ GRAMMAR EXTEND Gram { VernacContext (List.flatten c) } | IDENT "Instance"; namesup = instance_name; ":"; - t = operconstr LEVEL "200"; + t = term LEVEL "200"; info = hint_info ; props = [ ":="; "{"; r = record_declaration; "}" -> { Some (true,r) } | ":="; c = lconstr -> { Some (false,c) } | -> { None } ] -> @@ -707,13 +707,13 @@ GRAMMAR EXTEND Gram (* Arguments *) | IDENT "Arguments"; qid = smart_global; - args = LIST0 argument_spec_block; + args = LIST0 arg_specs; more_implicits = OPT [ ","; impl = LIST1 - [ impl = LIST0 more_implicits_block -> { List.flatten impl } ] + [ impl = LIST0 implicits_alt -> { List.flatten impl } ] SEP "," -> { impl } ]; - mods = OPT [ ":"; l = LIST1 arguments_modifier SEP "," -> { l } ] -> + mods = OPT [ ":"; l = LIST1 args_modifier SEP "," -> { l } ] -> { let mods = match mods with None -> [] | Some l -> List.flatten l in let more_implicits = Option.default [] more_implicits in VernacArguments (qid, List.flatten args, more_implicits, mods) } @@ -732,7 +732,7 @@ GRAMMAR EXTEND Gram idl = LIST1 identref -> { Some idl } ] -> { VernacGeneralizable gen } ] ] ; - arguments_modifier: + args_modifier: [ [ IDENT "simpl"; IDENT "nomatch" -> { [`ReductionDontExposeCase] } | IDENT "simpl"; IDENT "never" -> { [`ReductionNeverUnfold] } | IDENT "default"; IDENT "implicits" -> { [`DefaultImplicits] } @@ -757,7 +757,7 @@ GRAMMAR EXTEND Gram ] ]; (* List of arguments implicit status, scope, modifiers *) - argument_spec_block: [ + arg_specs: [ [ item = argument_spec -> { let name, recarg_like, notation_scope = item in [RealArg { name=name; recarg_like=recarg_like; @@ -791,8 +791,8 @@ GRAMMAR EXTEND Gram implicit_status = MaxImplicit}) items } ] ]; - (* Same as [argument_spec_block], but with only implicit status and names *) - more_implicits_block: [ + (* Same as [arg_specs], but with only implicit status and names *) + implicits_alt: [ [ name = name -> { [(name.CAst.v, Explicit)] } | "["; items = LIST1 name; "]" -> { List.map (fun name -> (name.CAst.v, NonMaxImplicit)) items } @@ -826,9 +826,9 @@ GRAMMAR EXTEND Gram GLOBAL: command query_command class_rawexpr gallina_ext search_query search_queries; gallina_ext: - [ [ IDENT "Export"; "Set"; table = option_table; v = option_setting -> + [ [ IDENT "Export"; "Set"; table = setting_name; v = option_setting -> { VernacSetOption (true, table, v) } - | IDENT "Export"; IDENT "Unset"; table = option_table -> + | IDENT "Export"; IDENT "Unset"; table = setting_name -> { VernacSetOption (true, table, OptionUnset) } ] ]; @@ -837,7 +837,7 @@ GRAMMAR EXTEND Gram (* Hack! Should be in grammar_ext, but camlp5 factorizes badly *) | IDENT "Declare"; IDENT "Instance"; id = ident_decl; bl = binders; ":"; - t = operconstr LEVEL "200"; + t = term LEVEL "200"; info = hint_info -> { VernacDeclareInstance (id, bl, t, info) } @@ -885,12 +885,12 @@ GRAMMAR EXTEND Gram { VernacAddMLPath dir } (* For acting on parameter tables *) - | "Set"; table = option_table; v = option_setting -> + | "Set"; table = setting_name; v = option_setting -> { VernacSetOption (false, table, v) } - | IDENT "Unset"; table = option_table -> + | IDENT "Unset"; table = setting_name -> { VernacSetOption (false, table, OptionUnset) } - | IDENT "Print"; IDENT "Table"; table = option_table -> + | IDENT "Print"; IDENT "Table"; table = setting_name -> { VernacPrintOption table } | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 table_value @@ -902,9 +902,9 @@ GRAMMAR EXTEND Gram | IDENT "Add"; table = IDENT; v = LIST1 table_value -> { VernacAddOption ([table], v) } - | IDENT "Test"; table = option_table; "for"; v = LIST1 table_value + | IDENT "Test"; table = setting_name; "for"; v = LIST1 table_value -> { VernacMemOption (table, v) } - | IDENT "Test"; table = option_table -> + | IDENT "Test"; table = setting_name -> { VernacPrintOption table } | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 table_value @@ -1006,7 +1006,7 @@ GRAMMAR EXTEND Gram [ [ id = global -> { Goptions.QualidRefValue id } | s = STRING -> { Goptions.StringRefValue s } ] ] ; - option_table: + setting_name: [ [ fl = LIST1 [ x = IDENT -> { x } ] -> { fl } ]] ; ne_in_or_out_modules: @@ -1191,10 +1191,10 @@ GRAMMAR EXTEND Gram | s, None -> SetFormat ("text",s) end } | x = IDENT; ","; l = LIST1 [id = IDENT -> { id } ] SEP ","; "at"; lev = level -> { SetItemLevel (x::l,None,lev) } - | x = IDENT; "at"; lev = level; b = OPT constr_as_binder_kind -> + | x = IDENT; "at"; lev = level; b = OPT binder_interp -> { SetItemLevel ([x],b,lev) } - | x = IDENT; b = constr_as_binder_kind -> { SetItemLevel ([x],Some b,DefaultLevel) } - | x = IDENT; typ = syntax_extension_type -> { SetEntryType (x,typ) } + | x = IDENT; b = binder_interp -> { SetItemLevel ([x],Some b,DefaultLevel) } + | x = IDENT; typ = explicit_subentry -> { SetEntryType (x,typ) } ] ] ; syntax_modifiers: @@ -1202,18 +1202,18 @@ GRAMMAR EXTEND Gram | -> { [] } ] ] ; - syntax_extension_type: + explicit_subentry: [ [ IDENT "ident" -> { ETIdent } | IDENT "global" -> { ETGlobal } | IDENT "bigint" -> { ETBigint } | IDENT "binder" -> { ETBinder true } | IDENT "constr" -> { ETConstr (InConstrEntry,None,DefaultLevel) } - | IDENT "constr"; n = at_level_opt; b = OPT constr_as_binder_kind -> { ETConstr (InConstrEntry,b,n) } + | IDENT "constr"; n = at_level_opt; b = OPT binder_interp -> { ETConstr (InConstrEntry,b,n) } | IDENT "pattern" -> { ETPattern (false,None) } | IDENT "pattern"; "at"; IDENT "level"; n = natural -> { ETPattern (false,Some n) } | IDENT "strict"; IDENT "pattern" -> { ETPattern (true,None) } | IDENT "strict"; IDENT "pattern"; "at"; IDENT "level"; n = natural -> { ETPattern (true,Some n) } | IDENT "closed"; IDENT "binder" -> { ETBinder false } - | IDENT "custom"; x = IDENT; n = at_level_opt; b = OPT constr_as_binder_kind -> + | IDENT "custom"; x = IDENT; n = at_level_opt; b = OPT binder_interp -> { ETConstr (InCustomEntry x,b,n) } ] ] ; @@ -1221,7 +1221,7 @@ GRAMMAR EXTEND Gram [ [ "at"; n = level -> { n } | -> { DefaultLevel } ] ] ; - constr_as_binder_kind: + binder_interp: [ [ "as"; IDENT "ident" -> { Notation_term.AsIdent } | "as"; IDENT "pattern" -> { Notation_term.AsIdentOrPattern } | "as"; IDENT "strict"; IDENT "pattern" -> { Notation_term.AsStrictPattern } ] ] diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 5f7eb78a40..bef9e29ac2 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -656,7 +656,7 @@ let explain_evar_not_found env sigma id = let explain_wrong_case_info env (ind,u) ci = let pi = pr_inductive env ind in - if eq_ind ci.ci_ind ind then + if Ind.CanOrd.equal ci.ci_ind ind then str "Pattern-matching expression on an object of inductive type" ++ spc () ++ pi ++ spc () ++ str "has invalid information." else @@ -1232,7 +1232,7 @@ let error_not_allowed_dependent_analysis env isrec i = pr_inductive env i ++ str "." let error_not_mutual_in_scheme env ind ind' = - if eq_ind ind ind' then + if Ind.CanOrd.equal ind ind' then str "The inductive type " ++ pr_inductive env ind ++ str " occurs twice." else diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 356ccef06b..de72a30f18 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -405,7 +405,7 @@ let do_mutual_induction_scheme ?(force_mutual=false) lnamedepindsort = let get_common_underlying_mutual_inductive env = function | [] -> assert false | (id,(mind,i as ind))::l as all -> - match List.filter (fun (_,(mind',_)) -> not (MutInd.equal mind mind')) l with + match List.filter (fun (_,(mind',_)) -> not (Environ.QMutInd.equal env mind mind')) l with | (_,ind')::_ -> raise (RecursionSchemeError (env, NotMutualInScheme (ind,ind'))) | [] -> diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 8ce59c40c3..185abcf35b 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -61,15 +61,15 @@ let pr_registered_grammar name = prlist pr_one entries let pr_grammar = function - | "constr" | "operconstr" | "binder_constr" -> + | "constr" | "term" | "binder_constr" -> str "Entry constr is" ++ fnl () ++ pr_entry Pcoq.Constr.constr ++ str "and lconstr is" ++ fnl () ++ pr_entry Pcoq.Constr.lconstr ++ str "where binder_constr is" ++ fnl () ++ pr_entry Pcoq.Constr.binder_constr ++ - str "and operconstr is" ++ fnl () ++ - pr_entry Pcoq.Constr.operconstr + str "and term is" ++ fnl () ++ + pr_entry Pcoq.Constr.term | "pattern" -> pr_entry Pcoq.Constr.pattern | "vernac" -> diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index c9f68eed57..a7de34dd09 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -43,7 +43,8 @@ module Vernac_ = let command = Entry.create "command" let syntax = Entry.create "syntax_command" let vernac_control = Entry.create "Vernac.vernac_control" - let rec_definition = Entry.create "Vernac.rec_definition" + let fix_definition = Entry.create "Vernac.fix_definition" + let rec_definition = fix_definition let red_expr = Entry.create "red_expr" let hint_info = Entry.create "hint_info" (* Main vernac entry *) diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index 8ab4af7d48..dac6877cb3 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -25,7 +25,9 @@ module Vernac_ : val command : vernac_expr Entry.t val syntax : vernac_expr Entry.t val vernac_control : vernac_control Entry.t + val fix_definition : fixpoint_expr Entry.t val rec_definition : fixpoint_expr Entry.t + [@@deprecated "Deprecated in 8.13; use 'fix_definition' instead"] val noedit_mode : vernac_expr Entry.t val command_entry : vernac_expr Entry.t val main_entry : vernac_control option Entry.t diff --git a/vernac/recLemmas.ml b/vernac/recLemmas.ml index 534c358a3f..af72c01758 100644 --- a/vernac/recLemmas.ml +++ b/vernac/recLemmas.ml @@ -44,7 +44,7 @@ let find_mutually_recursive_statements sigma thms = [] in ind_hyps,ind_ccl) thms in let inds_hyps,ind_ccls = List.split inds in - let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> Names.MutInd.equal kn kn' in + let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> Environ.QMutInd.equal (Global.env ()) kn kn' in (* Check if all conclusions are coinductive in the same type *) (* (degenerated cartesian product since there is at most one coind ccl) *) let same_indccl = @@ -70,7 +70,7 @@ let find_mutually_recursive_statements sigma thms = | [], _::_ -> let () = match same_indccl with | ind :: _ -> - if List.distinct_f Names.ind_ord (List.map pi1 ind) + if List.distinct_f Names.Ind.CanOrd.compare (List.map pi1 ind) then Flags.if_verbose Feedback.msg_info (Pp.strbrk |