coq-8.6/0000755000175000017500000000000013022274260011457 5ustar mdenesmdenescoq-8.6/dev/0000755000175000017500000000000013022274260012235 5ustar mdenesmdenescoq-8.6/dev/vm_printers.ml0000644000175000017500000000457413022274260015151 0ustar mdenesmdenesopen Format open Term open Names open Cbytecodes open Cemitcodes open Vm let ppripos (ri,pos) = (match ri with | Reloc_annot a -> let sp,i = a.ci.ci_ind in print_string ("annot : MutInd("^(string_of_mind sp)^","^(string_of_int i)^")\n") | Reloc_const _ -> print_string "structured constant\n" | Reloc_getglobal kn -> print_string ("getglob "^(string_of_con kn)^"\n")); print_flush () let print_vfix () = print_string "vfix" let print_vfix_app () = print_string "vfix_app" let print_vswith () = print_string "switch" let ppsort = function | Prop(Pos) -> print_string "Set" | Prop(Null) -> print_string "Prop" | Type u -> print_string "Type" let print_idkey idk = match idk with | ConstKey sp -> print_string "Cons("; print_string (string_of_con sp); print_string ")" | VarKey id -> print_string (Id.to_string id) | RelKey i -> print_string "~";print_int i let rec ppzipper z = match z with | Zapp args -> let n = nargs args in open_hbox (); for i = 0 to n-2 do ppvalues (arg args i);print_string ";";print_space() done; if n-1 >= 0 then ppvalues (arg args (n-1)); close_box() | Zfix _ -> print_string "Zfix" | Zswitch _ -> print_string "Zswitch" | Zproj _ -> print_string "Zproj" and ppstack s = open_hovbox 0; print_string "["; List.iter (fun z -> ppzipper z;print_string " | ") s; print_string "]"; close_box() and ppatom a = match a with | Aid idk -> print_idkey idk | Atype u -> print_string "Type(...)" | Aind(sp,i) -> print_string "Ind("; print_string (string_of_mind sp); print_string ","; print_int i; print_string ")" and ppwhd whd = match whd with | Vsort s -> ppsort s | Vprod _ -> print_string "product" | Vfun _ -> print_string "function" | Vfix _ -> print_vfix() | Vcofix _ -> print_string "cofix" | Vconstr_const i -> print_string "C(";print_int i;print_string")" | Vconstr_block b -> ppvblock b | Vatom_stk(a,s) -> open_hbox();ppatom a;close_box(); print_string"@";ppstack s | Vuniv_level lvl -> Feedback.msg_notice (Univ.Level.pr lvl) and ppvblock b = open_hbox(); print_string "Cb(";print_int (btag b); let n = bsize b in for i = 0 to n -1 do print_string ",";ppvalues (bfield b i) done; print_string")"; close_box() and ppvalues v = open_hovbox 0;ppwhd (whd_val v);close_box(); print_flush() coq-8.6/dev/v8-syntax/0000755000175000017500000000000013022274260014116 5ustar mdenesmdenescoq-8.6/dev/v8-syntax/syntax-v8.tex0000644000175000017500000011637513022274260016536 0ustar mdenesmdenes \documentclass{article} \usepackage{verbatim} \usepackage{amsmath} \usepackage{amssymb} \usepackage{array} \usepackage{fullpage} \author{B.~Barras} \title{Syntax of Coq V8} %% Le _ est un caractère normal \catcode`\_=13 \let\subscr=_ \def_{\ifmmode\sb\else\subscr\fi} \def\bfbar{\ensuremath{|\hskip -0.22em{}|\hskip -0.24em{}|}} \def\TERMbar{\bfbar} \def\TERMbarbar{\bfbar\bfbar} \def\notv{\text{_}} \def\infx#1{\notv#1\notv} %% Macros pour les grammaires \def\GR#1{\text{\large(}#1\text{\large)}} \def\NT#1{\langle\textit{#1}\rangle} \def\NTL#1#2{\langle\textit{#1}\rangle_{#2}} \def\TERM#1{{\bf\textrm{\bf #1}}} %\def\TERM#1{{\bf\textsf{#1}}} \def\KWD#1{\TERM{#1}} \def\ETERM#1{\TERM{#1}} \def\CHAR#1{\TERM{#1}} \def\STAR#1{#1*} \def\STARGR#1{\GR{#1}*} \def\PLUS#1{#1+} \def\PLUSGR#1{\GR{#1}+} \def\OPT#1{#1?} \def\OPTGR#1{\GR{#1}?} %% Tableaux de definition de non-terminaux \newenvironment{cadre} {\begin{array}{|c|}\hline\\} {\\\\\hline\end{array}} \newenvironment{rulebox} {$$\begin{cadre}\begin{array}{r@{~}c@{~}l@{}l@{}r}} {\end{array}\end{cadre}$$} \def\DEFNT#1{\NT{#1} & ::= &} \def\EXTNT#1{\NT{#1} & ::= & ... \\&|&} \def\RNAME#1{(\textsc{#1})} \def\SEPDEF{\\\\} \def\nlsep{\\&|&} \def\nlcont{\\&&} \newenvironment{rules} {\begin{center}\begin{rulebox}} {\end{rulebox}\end{center}} \begin{document} \maketitle \section{Meta notations used in this document} Non-terminals are printed between angle brackets (e.g. $\NT{non-terminal}$) and terminal symbols are printed in bold font (e.g. $\ETERM{terminal}$). Lexemes are displayed as non-terminals. The usual operators on regular expressions: \begin{center} \begin{tabular}{l|l} \hfil notation & \hfil meaning \\ \hline $\STAR{regexp}$ & repeat $regexp$ 0 or more times \\ $\PLUS{regexp}$ & repeat $regexp$ 1 or more times \\ $\OPT{regexp}$ & $regexp$ is optional \\ $regexp_1~\mid~regexp_2$ & alternative \end{tabular} \end{center} Parenthesis are used to group regexps. Beware to distinguish this operator $\GR{~}$ from the terminals $\ETERM{( )}$, and $\mid$ from terminal \TERMbar. Rules are optionally annotated in the right margin with: \begin{itemize} \item a precedence and associativity (L for left, R for right and N for no associativity), indicating how to solve conflicts; lower levels are tighter; \item a rule name. \end{itemize} In order to solve some conflicts, a non-terminal may be invoked with a precedence (notation: $\NTL{entry}{prec}$), meaning that rules with higher precedence do not apply. \section{Lexical conventions} Lexical categories are: \begin{rules} \DEFNT{ident} \STARGR{\NT{letter}\mid\CHAR{_}} \STARGR{\NT{letter}\mid \NT{digit} \mid \CHAR{'} \mid \CHAR{_}} \SEPDEF \DEFNT{field} \CHAR{.}\NT{ident} \SEPDEF \DEFNT{meta-ident} \CHAR{?}\NT{ident} \SEPDEF \DEFNT{num} \PLUS{\NT{digit}} \SEPDEF \DEFNT{int} \NT{num} \mid \CHAR{-}\NT{num} \SEPDEF \DEFNT{digit} \CHAR{0}-\CHAR{9} \SEPDEF \DEFNT{letter} \CHAR{a}-\CHAR{z}\mid\CHAR{A}-\CHAR{Z} \mid\NT{unicode-letter} \SEPDEF \DEFNT{string} \CHAR{"}~\STARGR{\CHAR{""}\mid\NT{unicode-char-but-"}}~\CHAR{"} \end{rules} Reserved identifiers for the core syntax are: \begin{quote} \KWD{as}, \KWD{cofix}, \KWD{else}, \KWD{end}, \KWD{fix}, \KWD{for}, \KWD{forall}, \KWD{fun}, \KWD{if}, \KWD{in}, \KWD{let}, \KWD{match}, \KWD{Prop}, \KWD{return}, \KWD{Set}, \KWD{then}, \KWD{Type}, \KWD{with} \end{quote} Symbols used in the core syntax: $$ \KWD{(} ~~ \KWD{)} ~~ \KWD{\{} ~~ \KWD{\}} ~~ \KWD{:} ~~ \KWD{,} ~~ \Rightarrow ~~ \rightarrow ~~ \KWD{:=} ~~ \KWD{_} ~~ \TERMbar ~~ \KWD{@} ~~ \KWD{\%} ~~ \KWD{.(} $$ Note that \TERM{struct} is not a reserved identifier. \section{Syntax of terms} \subsection{Core syntax} The main entry point of the term grammar is $\NTL{constr}{9}$. When no conflict can appear, $\NTL{constr}{200}$ is also used as entry point. \begin{rules} \DEFNT{constr} \NT{binder-constr} &200R~~ &\RNAME{binders} \nlsep \NT{constr}~\KWD{:}~\NT{constr} &100R &\RNAME{cast} \nlsep \NT{constr}~\KWD{:}~\NT{binder-constr} &100R &\RNAME{cast'} \nlsep \NT{constr}~\KWD{$\rightarrow$}~\NT{constr} &80R &\RNAME{arrow} \nlsep \NT{constr}~\KWD{$\rightarrow$}~\NT{binder-constr} &80R &\RNAME{arrow'} \nlsep \NT{constr}~\PLUS{\NT{appl-arg}} &10L &\RNAME{apply} \nlsep \KWD{@}~\NT{reference}~\STAR{\NTL{constr}{9}} &10L &\RNAME{expl-apply} \nlsep \NT{constr}~\KWD{.(} ~\NT{reference}~\STAR{\NT{appl-arg}}~\TERM{)} &1L & \RNAME{proj} \nlsep \NT{constr}~\KWD{.(}~\TERM{@} ~\NT{reference}~\STAR{\NTL{constr}{9}}~\TERM{)} &1L & \RNAME{expl-proj} \nlsep \NT{constr} ~ \KWD{\%} ~ \NT{ident} &1L &\RNAME{scope-chg} \nlsep \NT{atomic-constr} &0 \nlsep \NT{match-expr} &0 \nlsep \KWD{(}~\NT{constr}~\KWD{)} &0 \SEPDEF \DEFNT{binder-constr} \KWD{forall}~\NT{binder-list}~\KWD{,}~\NTL{constr}{200} &&\RNAME{prod} \nlsep \KWD{fun} ~\NT{binder-list} ~\KWD{$\Rightarrow$}~\NTL{constr}{200} &&\RNAME{lambda} \nlsep \NT{fix-expr} \nlsep \KWD{let}~\NT{ident-with-params} ~\KWD{:=}~\NTL{constr}{200} ~\KWD{in}~\NTL{constr}{200} &&\RNAME{let} \nlsep \KWD{let}~\NT{single-fix} ~\KWD{in}~\NTL{constr}{200} &&\RNAME{rec-let} \nlsep \KWD{let}~\KWD{(}~\OPT{\NT{let-pattern}}~\KWD{)}~\OPT{\NT{return-type}} ~\KWD{:=}~\NTL{constr}{200}~\KWD{in}~\NTL{constr}{200} &&\RNAME{let-case} \nlsep \KWD{if}~\NT{if-item} ~\KWD{then}~\NTL{constr}{200}~\KWD{else}~\NTL{constr}{200} &&\RNAME{if-case} \SEPDEF \DEFNT{appl-arg} \KWD{(}~\NT{ident}~\!\KWD{:=}~\NTL{constr}{200}~\KWD{)} &&\RNAME{impl-arg} \nlsep \KWD{(}~\NT{num}~\!\KWD{:=}~\NTL{constr}{200}~\KWD{)} &&\RNAME{impl-arg} \nlsep \NTL{constr}{9} \SEPDEF \DEFNT{atomic-constr} \NT{reference} && \RNAME{variables} \nlsep \NT{sort} && \RNAME{CIC-sort} \nlsep \NT{num} && \RNAME{number} \nlsep \KWD{_} && \RNAME{hole} \nlsep \NT{meta-ident} && \RNAME{meta/evar} \end{rules} \begin{rules} \DEFNT{ident-with-params} \NT{ident}~\STAR{\NT{binder-let}}~\NT{type-cstr} \SEPDEF \DEFNT{binder-list} \NT{binder}~\STAR{\NT{binder-let}} \nlsep \PLUS{\NT{name}}~\KWD{:}~\NT{constr} \SEPDEF \DEFNT{binder} \NT{name} &&\RNAME{infer} \nlsep \KWD{(}~\PLUS{\NT{name}}~\KWD{:}~\NT{constr} ~\KWD{)} &&\RNAME{binder} \SEPDEF \DEFNT{binder-let} \NT{binder} \nlsep \KWD{(}~\NT{name}~\NT{type-cstr}~\KWD{:=}~\NT{constr}~\KWD{)} \SEPDEF \DEFNT{let-pattern} \NT{name} \nlsep \NT{name} ~\KWD{,} ~\NT{let-pattern} \SEPDEF \DEFNT{type-cstr} \OPTGR{\KWD{:}~\NT{constr}} \SEPDEF \DEFNT{reference} \NT{ident} && \RNAME{short-ident} \nlsep \NT{ident}~\PLUS{\NT{field}} && \RNAME{qualid} \SEPDEF \DEFNT{sort} \KWD{Prop} ~\mid~ \KWD{Set} ~\mid~ \KWD{Type} \SEPDEF \DEFNT{name} \NT{ident} ~\mid~ \KWD{_} \end{rules} \begin{rules} \DEFNT{fix-expr} \NT{single-fix} \nlsep \NT{single-fix}~\PLUSGR{\KWD{with}~\NT{fix-decl}} ~\KWD{for}~\NT{ident} \SEPDEF \DEFNT{single-fix} \NT{fix-kw}~\NT{fix-decl} \SEPDEF \DEFNT{fix-kw} \KWD{fix} ~\mid~ \KWD{cofix} \SEPDEF \DEFNT{fix-decl} \NT{ident}~\STAR{\NT{binder-let}}~\OPT{\NT{annot}}~\NT{type-cstr} ~\KWD{:=}~\NTL{constr}{200} \SEPDEF \DEFNT{annot} \KWD{\{}~\TERM{struct}~\NT{ident}~\KWD{\}} \end{rules} \begin{rules} \DEFNT{match-expr} \KWD{match}~\NT{match-items}~\OPT{\NT{return-type}}~\KWD{with} ~\OPT{\TERMbar}~\OPT{\NT{branches}}~\KWD{end} &&\RNAME{match} \SEPDEF \DEFNT{match-items} \NT{match-item} ~\KWD{,} ~\NT{match-items} \nlsep \NT{match-item} \SEPDEF \DEFNT{match-item} \NTL{constr}{100}~\OPTGR{\KWD{as}~\NT{name}} ~\OPTGR{\KWD{in}~\NTL{constr}{100}} \SEPDEF \DEFNT{return-type} \KWD{return}~\NTL{constr}{100} \SEPDEF \DEFNT{if-item} \NT{constr}~\OPTGR{\OPTGR{\KWD{as}~\NT{name}}~\NT{return-type}} \SEPDEF \DEFNT{branches} \NT{eqn}~\TERMbar~\NT{branches} \nlsep \NT{eqn} \SEPDEF \DEFNT{eqn} \NT{pattern} ~\STARGR{\KWD{,}~\NT{pattern}} ~\KWD{$\Rightarrow$}~\NT{constr} \SEPDEF \DEFNT{pattern} \NT{reference}~\PLUS{\NT{pattern}} &1L~~ & \RNAME{constructor} \nlsep \NT{pattern}~\KWD{as}~\NT{ident} &1L & \RNAME{alias} \nlsep \NT{pattern}~\KWD{\%}~\NT{ident} &1L & \RNAME{scope-change} \nlsep \NT{reference} &0 & \RNAME{pattern-var} \nlsep \KWD{_} &0 & \RNAME{hole} \nlsep \NT{num} &0 \nlsep \KWD{(}~\NT{tuple-pattern}~\KWD{)} \SEPDEF \DEFNT{tuple-pattern} \NT{pattern} \nlsep \NT{tuple-pattern}~\KWD{,}~\NT{pattern} && \RNAME{pair} \end{rules} \subsection{Notations of the prelude (logic and basic arithmetic)} Reserved notations: $$ \begin{array}{l|c} \text{Symbol} & \text{precedence} \\ \hline \infx{,} & 250L \\ \KWD{IF}~\notv~\KWD{then}~\notv~\KWD{else}~\notv & 200R \\ \infx{:} & 100R \\ \infx{\leftrightarrow} & 95N \\ \infx{\rightarrow} & 90R \\ \infx{\vee} & 85R \\ \infx{\wedge} & 80R \\ \tilde{}\notv & 75R \\ \begin{array}[c]{@{}l@{}} \infx{=}\quad \infx{=}\KWD{$:>$}\notv \quad \infx{=}=\notv \quad \infx{\neq} \quad \infx{\neq}\KWD{$:>$}\notv \\ \infx{<}\quad\infx{>} \quad \infx{\leq}\quad\infx{\geq} \quad \infx{<}<\notv \quad \infx{<}\leq\notv \quad \infx{\leq}<\notv \quad \infx{\leq}\leq\notv \end{array} & 70N \\ \infx{+}\quad\infx{-}\quad -\notv & 50L \\ \infx{*}\quad\infx{/}\quad /\notv & 40L \\ \end{array} $$ Existential quantifiers follows the \KWD{forall} notation (with same precedence 200), but only one quantified variable is allowed. \begin{rules} \EXTNT{binder-constr} \NT{quantifier-kwd}~\NT{name}~\NT{type-cstr}~\KWD{,}~\NTL{constr}{200} \\ \SEPDEF \DEFNT{quantifier-kwd} \TERM{exists} && \RNAME{ex} \nlsep \TERM{exists2} && \RNAME{ex2} \end{rules} $$ \begin{array}{l|c|l} \text{Symbol} & \text{precedence} \\ \hline \notv+\{\notv\} & 50 & \RNAME{sumor} \\ \{\notv:\notv~|~\notv\} & 0 & \RNAME{sig} \\ \{\notv:\notv~|~\notv \& \notv \} & 0 & \RNAME{sig2} \\ \{\notv:\notv~\&~\notv \} & 0 & \RNAME{sigS} \\ \{\notv:\notv~\&~\notv \& \notv \} & 0 & \RNAME{sigS2} \\ \{\notv\}+\{\notv\} & 0 & \RNAME{sumbool} \\ \end{array} $$ %% Strange: nat + {x:nat|x=x} * nat == ( + ) * \section{Grammar of tactics} \def\tacconstr{\NTL{constr}{9}} \def\taclconstr{\NTL{constr}{200}} Additional symbols are: $$ \TERM{'} ~~ \KWD{;} ~~ \TERM{()} ~~ \TERMbarbar ~~ \TERM{$\vdash$} ~~ \TERM{[} ~~ \TERM{]} ~~ \TERM{$\leftarrow$} $$ Additional reserved keywords are: $$ \KWD{at} ~~ \TERM{using} $$ \subsection{Basic tactics} \begin{rules} \DEFNT{simple-tactic} \TERM{intros}~\TERM{until}~\NT{quantified-hyp} \nlsep \TERM{intros}~\NT{intro-patterns} \nlsep \TERM{intro}~\OPT{\NT{ident}}~\OPTGR{\TERM{after}~\NT{ident}} %% \nlsep \TERM{assumption} \nlsep \TERM{exact}~\tacconstr %% \nlsep \TERM{apply}~\NT{constr-with-bindings} \nlsep \TERM{elim}~\NT{constr-with-bindings}~\OPT{\NT{eliminator}} \nlsep \TERM{elimtype}~\tacconstr \nlsep \TERM{case}~\NT{constr-with-bindings} \nlsep \TERM{casetype}~\tacconstr \nlsep \KWD{fix}~\OPT{\NT{ident}}~\NT{num} \nlsep \KWD{fix}~\NT{ident}~\NT{num}~\KWD{with}~\PLUS{\NT{fix-spec}} \nlsep \KWD{cofix}~\OPT{\NT{ident}} \nlsep \KWD{cofix}~\NT{ident}~\PLUS{\NT{fix-spec}} %% \nlsep \TERM{cut}~\tacconstr \nlsep \TERM{assert}~\tacconstr \nlsep \TERM{assert}~ \TERM{(}~\NT{ident}~\KWD{:}~\taclconstr~\TERM{)} \nlsep \TERM{assert}~ \TERM{(}~\NT{ident}~\KWD{:=}~\taclconstr~\TERM{)} \nlsep \TERM{pose}~\tacconstr \nlsep \TERM{pose}~ \TERM{(}~\NT{ident}~\KWD{:=}~\taclconstr~\TERM{)} \nlsep \TERM{generalize}~\PLUS{\tacconstr} \nlsep \TERM{generalize}~\TERM{dependent}~\tacconstr \nlsep \TERM{set}~\tacconstr~\OPT{\NT{clause}} \nlsep \TERM{set}~ \TERM{(}~\NT{ident}~\KWD{:=}~\taclconstr~\TERM{)}~\OPT{\NT{clause}} \nlsep \TERM{instantiate}~ \TERM{(}~\NT{num}~\TERM{:=}~\taclconstr~\TERM{)}~\OPT{\NT{clause}} %% \nlsep \TERM{specialize}~\OPT{\NT{num}}~\NT{constr-with-bindings} \nlsep \TERM{lapply}~\tacconstr %% \nlsep \TERM{simple}~\TERM{induction}~\NT{quantified-hyp} \nlsep \TERM{induction}~\NT{induction-arg}~\OPT{\NT{with-names}} ~\OPT{\NT{eliminator}} \nlsep \TERM{double}~\TERM{induction}~\NT{quantified-hyp}~\NT{quantified-hyp} \nlsep \TERM{simple}~\TERM{destruct}~\NT{quantified-hyp} \nlsep \TERM{destruct}~\NT{induction-arg}~\OPT{\NT{with-names}} ~\OPT{\NT{eliminator}} \nlsep \TERM{decompose}~\TERM{record}~\tacconstr \nlsep \TERM{decompose}~\TERM{sum}~\tacconstr \nlsep \TERM{decompose}~\TERM{[}~\PLUS{\NT{reference}}~\TERM{]} ~\tacconstr %% \nlsep ... \end{rules} \begin{rules} \EXTNT{simple-tactic} \TERM{trivial}~\OPT{\NT{hint-bases}} \nlsep \TERM{auto}~\OPT{\NT{num}}~\OPT{\NT{hint-bases}} %% %%\nlsep \TERM{autotdb}~\OPT{\NT{num}} %%\nlsep \TERM{cdhyp}~\NT{ident} %%\nlsep \TERM{dhyp}~\NT{ident} %%\nlsep \TERM{dconcl} %%\nlsep \TERM{superauto}~\NT{auto-args} \nlsep \TERM{auto}~\OPT{\NT{num}}~\TERM{decomp}~\OPT{\NT{num}} %% \nlsep \TERM{clear}~\PLUS{\NT{ident}} \nlsep \TERM{clearbody}~\PLUS{\NT{ident}} \nlsep \TERM{move}~\NT{ident}~\TERM{after}~\NT{ident} \nlsep \TERM{rename}~\NT{ident}~\TERM{into}~\NT{ident} %% \nlsep \TERM{left}~\OPT{\NT{with-binding-list}} \nlsep \TERM{right}~\OPT{\NT{with-binding-list}} \nlsep \TERM{split}~\OPT{\NT{with-binding-list}} \nlsep \TERM{exists}~\OPT{\NT{binding-list}} \nlsep \TERM{constructor}~\NT{num}~\OPT{\NT{with-binding-list}} \nlsep \TERM{constructor}~\OPT{\NT{tactic}} %% \nlsep \TERM{reflexivity} \nlsep \TERM{symmetry}~\OPTGR{\KWD{in}~\NT{ident}} \nlsep \TERM{transitivity}~\tacconstr %% \nlsep \NT{inversion-kwd}~\NT{quantified-hyp}~\OPT{\NT{with-names}}~\OPT{\NT{clause}} \nlsep \TERM{dependent}~\NT{inversion-kwd}~\NT{quantified-hyp} ~\OPT{\NT{with-names}}~\OPTGR{\KWD{with}~\tacconstr} \nlsep \TERM{inversion}~\NT{quantified-hyp}~\TERM{using}~\tacconstr~\OPT{\NT{clause}} %% \nlsep \NT{red-expr}~\OPT{\NT{clause}} \nlsep \TERM{change}~\NT{conversion}~\OPT{\NT{clause}} \SEPDEF \DEFNT{red-expr} \TERM{red} ~\mid~ \TERM{hnf} ~\mid~ \TERM{compute} \nlsep \TERM{simpl}~\OPT{\NT{pattern-occ}} \nlsep \TERM{cbv}~\PLUS{\NT{red-flag}} \nlsep \TERM{lazy}~\PLUS{\NT{red-flag}} \nlsep \TERM{unfold}~\NT{unfold-occ}~\STARGR{\KWD{,}~\NT{unfold-occ}} \nlsep \TERM{fold}~\PLUS{\tacconstr} \nlsep \TERM{pattern}~\NT{pattern-occ}~\STARGR{\KWD{,}~\NT{pattern-occ}} \SEPDEF \DEFNT{conversion} \NT{pattern-occ}~\KWD{with}~\tacconstr \nlsep \tacconstr \SEPDEF \DEFNT{inversion-kwd} \TERM{inversion} ~\mid~ \TERM{invesion_clear} ~\mid~ \TERM{simple}~\TERM{inversion} \end{rules} Conflicts exists between integers and constrs. \begin{rules} \DEFNT{quantified-hyp} \NT{int}~\mid~\NT{ident} \SEPDEF \DEFNT{induction-arg} \NT{int}~\mid~\tacconstr \SEPDEF \DEFNT{fix-spec} \KWD{(}~\NT{ident}~\STAR{\NT{binder}}~\OPT{\NT{annot}} ~\KWD{:}~\taclconstr~\KWD{)} \SEPDEF \DEFNT{intro-patterns} \STAR{\NT{intro-pattern}} \SEPDEF \DEFNT{intro-pattern} \NT{name} \nlsep \TERM{[}~\NT{intro-patterns}~\STARGR{\TERMbar~\NT{intro-patterns}} ~\TERM{]} \nlsep \KWD{(}~\NT{intro-pattern}~\STARGR{\KWD{,}~\NT{intro-pattern}} ~\KWD{)} \SEPDEF \DEFNT{with-names} % \KWD{as}~\TERM{[}~\STAR{\NT{ident}}~\STARGR{\TERMbar~\STAR{\NT{ident}}} % ~\TERM{]} \KWD{as}~\NT{intro-pattern} \SEPDEF \DEFNT{eliminator} \TERM{using}~\NT{constr-with-bindings} \SEPDEF \DEFNT{constr-with-bindings} % dangling ``with'' of ``fix'' can conflict with ``with'' \tacconstr~\OPT{\NT{with-binding-list}} \SEPDEF \DEFNT{with-binding-list} \KWD{with}~\NT{binding-list} \SEPDEF \DEFNT{binding-list} \PLUS{\tacconstr} \nlsep \PLUS{\NT{simple-binding}} \SEPDEF \DEFNT{simple-binding} \KWD{(}~\NT{quantified-hyp}~\KWD{:=}~\taclconstr~\KWD{)} \SEPDEF \DEFNT{red-flag} \TERM{beta} ~\mid~ \TERM{iota} ~\mid~ \TERM{zeta} ~\mid~ \TERM{delta} ~\mid~ \TERM{delta}~\OPT{\TERM{-}}~\TERM{[}~\PLUS{\NT{reference}}~\TERM{]} \SEPDEF \DEFNT{clause} \KWD{in}~\TERM{*} \nlsep \KWD{in}~\TERM{*}~\KWD{$\vdash$}~\OPT{\NT{concl-occ}} \nlsep \KWD{in}~\OPT{\NT{hyp-ident-list}} ~\KWD{$\vdash$} ~\OPT{\NT{concl-occ}} \nlsep \KWD{in}~\OPT{\NT{hyp-ident-list}} \SEPDEF \DEFNT{hyp-ident-list} \NT{hyp-ident} \nlsep \NT{hyp-ident}~\KWD{,}~\NT{hyp-ident-list} \SEPDEF \DEFNT{hyp-ident} \NT{ident} \nlsep \KWD{(}~\TERM{type}~\TERM{of}~\NT{ident}~\KWD{)} \nlsep \KWD{(}~\TERM{value}~\TERM{of}~\NT{ident}~\KWD{)} \SEPDEF \DEFNT{concl-occ} \TERM{*} ~\NT{occurrences} \SEPDEF \DEFNT{pattern-occ} \tacconstr ~\NT{occurrences} \SEPDEF \DEFNT{unfold-occ} \NT{reference}~\NT{occurrences} \SEPDEF \DEFNT{occurrences} ~\OPTGR{\KWD{at}~\PLUS{\NT{int}}} \SEPDEF \DEFNT{hint-bases} \KWD{with}~\TERM{*} \nlsep \KWD{with}~\PLUS{\NT{ident}} \SEPDEF \DEFNT{auto-args} \OPT{\NT{num}}~\OPTGR{\TERM{adding}~\TERM{[}~\PLUS{\NT{reference}} ~\TERM{]}}~\OPT{\TERM{destructuring}}~\OPTGR{\TERM{using}~\TERM{tdb}} \end{rules} \subsection{Ltac} %% Currently, there are conflicts with keyword \KWD{in}: in the following, %% has the keyword to be associated to \KWD{let} or to tactic \TERM{simpl} ? %% \begin{center} %% \texttt{let x := simpl in ...} %% \end{center} \begin{rules} \DEFNT{tactic} \NT{tactic} ~\KWD{;} ~\NT{tactic} &5 &\RNAME{Then} \nlsep \NT{tactic} ~\KWD{;}~\TERM{[} ~\OPT{\NT{tactic-seq}} ~\TERM{]} &5 &\RNAME{Then-seq} %% \nlsep \TERM{try} ~\NT{tactic} &3R &\RNAME{Try} \nlsep \TERM{do} ~\NT{int-or-var} ~\NT{tactic} \nlsep \TERM{repeat} ~\NT{tactic} \nlsep \TERM{progress} ~\NT{tactic} \nlsep \TERM{info} ~\NT{tactic} \nlsep \TERM{abstract}~\NTL{tactic}{2}~\OPTGR{\TERM{using}~\NT{ident}} %% \nlsep \NT{tactic} ~\TERMbarbar ~\NT{tactic} &2R &\RNAME{Orelse} %% \nlsep \KWD{fun} ~\PLUS{\NT{name}} ~\KWD{$\Rightarrow$} ~\NT{tactic} &1 &\RNAME{Fun-tac} \nlsep \KWD{let} ~\NT{let-clauses} ~\KWD{in} ~\NT{tactic} \nlsep \KWD{let} ~\TERM{rec} ~\NT{rec-clauses} ~\KWD{in} ~\NT{tactic} \nlsep \KWD{match}~\OPT{\TERM{reverse}}~\TERM{goal}~\KWD{with} ~\OPT{\TERMbar}~\OPT{\NT{match-goal-rules}} ~\KWD{end} \nlsep \KWD{match} ~\NT{tactic} ~\KWD{with} ~\OPT{\TERMbar}~\OPT{\NT{match-rules}} ~\KWD{end} \nlsep \TERM{first}~\TERM{[} ~\NT{tactic-seq} ~\TERM{]} \nlsep \TERM{solve}~\TERM{[} ~\NT{tactic-seq} ~\TERM{]} \nlsep \TERM{idtac} \nlsep \TERM{fail} ~\OPT{\NT{num}} ~\OPT{\NT{string}} \nlsep \TERM{constr}~\KWD{:}~\tacconstr \nlsep \TERM{ipattern}~\KWD{:}~\NT{intro-pattern} \nlsep \NT{term-ltac} \nlsep \NT{reference}~\STAR{\NT{tactic-arg}} &&\RNAME{call-tactic} \nlsep \NT{simple-tactic} %% \nlsep \NT{tactic-atom} &0 &\RNAME{atomic} \nlsep \KWD{(} ~\NT{tactic} ~\KWD{)} \SEPDEF \DEFNT{tactic-arg} \TERM{ltac}~\KWD{:}~\NTL{tactic}{0} \nlsep \TERM{ipattern}~\KWD{:}~\NT{intro-pattern} \nlsep \NT{term-ltac} \nlsep \NT{tactic-atom} \nlsep \tacconstr \SEPDEF \DEFNT{term-ltac} \TERM{fresh} ~\OPT{\NT{string}} \nlsep \TERM{context} ~\NT{ident} ~\TERM{[} ~\taclconstr ~\TERM{]} \nlsep \TERM{eval} ~\NT{red-expr} ~\KWD{in} ~\tacconstr \nlsep \TERM{type} ~\tacconstr \SEPDEF \DEFNT{tactic-atom} \NT{reference} \nlsep \TERM{()} \SEPDEF \DEFNT{tactic-seq} \NT{tactic} ~\TERMbar ~\NT{tactic-seq} \nlsep \NT{tactic} \end{rules} \begin{rules} \DEFNT{let-clauses} \NT{let-clause} ~\STARGR{\KWD{with}~\NT{let-clause}} \SEPDEF \DEFNT{let-clause} \NT{ident} ~\STAR{\NT{name}} ~\KWD{:=} ~\NT{tactic} \SEPDEF \DEFNT{rec-clauses} \NT{rec-clause} ~\KWD{with} ~\NT{rec-clauses} \nlsep \NT{rec-clause} \SEPDEF \DEFNT{rec-clause} \NT{ident} ~\PLUS{\NT{name}} ~\KWD{:=} ~\NT{tactic} \SEPDEF \DEFNT{match-goal-rules} \NT{match-goal-rule} \nlsep \NT{match-goal-rule} ~\TERMbar ~\NT{match-goal-rules} \SEPDEF \DEFNT{match-goal-rule} \NT{match-hyps-list} ~\TERM{$\vdash$} ~\NT{match-pattern} ~\KWD{$\Rightarrow$} ~\NT{tactic} \nlsep \KWD{[}~\NT{match-hyps-list} ~\TERM{$\vdash$} ~\NT{match-pattern} ~\KWD{]}~\KWD{$\Rightarrow$} ~\NT{tactic} \nlsep \KWD{_} ~\KWD{$\Rightarrow$} ~\NT{tactic} \SEPDEF \DEFNT{match-hyps-list} \NT{match-hyps} ~\KWD{,} ~\NT{match-hyps-list} \nlsep \NT{match-hyps} \SEPDEF \DEFNT{match-hyps} \NT{name} ~\KWD{:} ~\NT{match-pattern} \SEPDEF \DEFNT{match-rules} \NT{match-rule} \nlsep \NT{match-rule} ~\TERMbar ~\NT{match-rules} \SEPDEF \DEFNT{match-rule} \NT{match-pattern} ~\KWD{$\Rightarrow$} ~\NT{tactic} \nlsep \KWD{_} ~\KWD{$\Rightarrow$} ~\NT{tactic} \SEPDEF \DEFNT{match-pattern} \TERM{context}~\OPT{\NT{ident}} ~\TERM{[} ~\NT{constr-pattern} ~\TERM{]} &&\RNAME{subterm} \nlsep \NT{constr-pattern} \SEPDEF \DEFNT{constr-pattern} \tacconstr \end{rules} \subsection{Other tactics} \begin{rules} \EXTNT{simple-tactic} \TERM{rewrite} ~\NT{orient} ~\NT{constr-with-bindings} ~\OPTGR{\KWD{in}~\NT{ident}} \nlsep \TERM{replace} ~\tacconstr ~\KWD{with} ~\tacconstr ~\OPTGR{\KWD{in}~\NT{ident}} \nlsep \TERM{replace} ~\OPT{\NT{orient}} ~\tacconstr ~\OPTGR{\KWD{in}~\NT{ident}} \nlsep \TERM{symplify_eq} ~\OPT{\NT{quantified-hyp}} \nlsep \TERM{discriminate} ~\OPT{\NT{quantified-hyp}} \nlsep \TERM{injection} ~\OPT{\NT{quantified-hyp}} \nlsep \TERM{conditional}~\NT{tactic}~\TERM{rewrite}~\NT{orient} ~\NT{constr-with-bindings}~\OPTGR{\KWD{in}~\NT{ident}} \nlsep \TERM{dependent}~\TERM{rewrite}~\NT{orient}~\NT{ident} \nlsep \TERM{cutrewrite}~\NT{orient}~\tacconstr ~\OPTGR{\KWD{in}~\NT{ident}} \nlsep \TERM{absurd} ~\tacconstr \nlsep \TERM{contradiction} \nlsep \TERM{autorewrite}~\NT{hint-bases}~\OPTGR{\KWD{using}~\NT{tactic}} \nlsep \TERM{refine}~\tacconstr \nlsep \TERM{setoid_replace} ~\tacconstr ~\KWD{with} ~\tacconstr \nlsep \TERM{setoid_rewrite} ~\NT{orient} ~\tacconstr \nlsep \TERM{subst} ~\STAR{\NT{ident}} %% eqdecide.ml4 \nlsep \TERM{decide}~\TERM{equality} ~\OPTGR{\tacconstr~\tacconstr} \nlsep \TERM{compare}~\tacconstr~\tacconstr %% eauto \nlsep \TERM{eexact}~\tacconstr \nlsep \TERM{eapply}~\NT{constr-with-bindings} \nlsep \TERM{prolog}~\TERM{[}~\STAR{\tacconstr}~\TERM{]} ~\NT{quantified-hyp} \nlsep \TERM{eauto}~\OPT{\NT{quantified-hyp}}~\OPT{\NT{quantified-hyp}} ~\NT{hint-bases} \nlsep \TERM{eautod}~\OPT{\NT{quantified-hyp}}~\OPT{\NT{quantified-hyp}} ~\NT{hint-bases} %% tauto \nlsep \TERM{tauto} \nlsep \TERM{simplif} \nlsep \TERM{intuition}~\OPT{\NTL{tactic}{0}} \nlsep \TERM{linearintuition}~\OPT{\NT{num}} %% plugins/cc \nlsep \TERM{cc} %% plugins/field \nlsep \TERM{field}~\STAR{\tacconstr} %% plugins/firstorder \nlsep \TERM{ground}~\OPT{\NTL{tactic}{0}} \nlsep \TERM{ground}~\OPT{\NTL{tactic}{0}}~\KWD{with}~\PLUS{\NT{reference}} \nlsep \TERM{ground}~\OPT{\NTL{tactic}{0}}~\KWD{using}~\PLUS{\NT{ident}} %%\nlsep \TERM{gtauto} \nlsep \TERM{gintuition}~\OPT{\NTL{tactic}{0}} %% plugins/fourier \nlsep \TERM{fourierZ} %% plugins/funind \nlsep \TERM{functional}~\TERM{induction}~\tacconstr~\PLUS{\tacconstr} %% plugins/jprover \nlsep \TERM{jp}~\OPT{\NT{num}} %% plugins/omega \nlsep \TERM{omega} %% plugins/ring \nlsep \TERM{quote}~\NT{ident}~\OPTGR{\KWD{[}~\PLUS{\NT{ident}}~\KWD{]}} \nlsep \TERM{ring}~\STAR{\tacconstr} %% plugins/romega \nlsep \TERM{romega} \SEPDEF \DEFNT{orient} \KWD{$\rightarrow$}~\mid~\KWD{$\leftarrow$} \end{rules} \section{Grammar of commands} New symbols: $$ \TERM{.} ~~ \TERM{..} ~~ \TERM{\tt >->} ~~ \TERM{:$>$} ~~ \TERM{$<$:} $$ New keyword: $$ \KWD{where} $$ \subsection{Classification of commands} \begin{rules} \DEFNT{vernac} \TERM{Time}~\NT{vernac} &2~~ &\RNAME{Timing} %% \nlsep \NT{gallina}~\TERM{.} &1 \nlsep \NT{command}~\TERM{.} \nlsep \NT{syntax}~\TERM{.} \nlsep \TERM{[}~\PLUS{\NT{vernac}}~\TERM{]}~\TERM{.} %% \nlsep \OPTGR{\NT{num}~\KWD{:}}~\NT{subgoal-command}~\TERM{.} ~~~&0 \SEPDEF \DEFNT{subgoal-command} \NT{check-command} \nlsep %\OPT{\TERM{By}}~ \NT{tactic}~\OPT{\KWD{..}} \end{rules} \subsection{Gallina and extensions} \begin{rules} \DEFNT{gallina} \NT{thm-token}~\NT{ident}~\STAR{\NT{binder-let}}~\KWD{:}~\NT{constr} \nlsep \NT{def-token}~\NT{ident}~\NT{def-body} \nlsep \NT{assum-token}~\NT{assum-list} \nlsep \NT{finite-token}~\NT{inductive-definition} ~\STARGR{\KWD{with}~\NT{inductive-definition}} \nlsep \TERM{Fixpoint}~\NT{fix-decl}~\STARGR{\KWD{with}~\NT{fix-decl}} \nlsep \TERM{CoFixpoint}~\NT{fix-decl}~\STARGR{\KWD{with}~\NT{fix-decl}} \nlsep \TERM{Scheme}~\NT{scheme}~\STARGR{\KWD{with}~\NT{scheme}} %% Extension: record \nlsep \NT{record-tok}~\OPT{\TERM{$>$}}~\NT{ident}~\STAR{\NT{binder-let}} ~\KWD{:}~\NT{constr}~\KWD{:=} ~\OPT{\NT{ident}}~\KWD{\{}~\NT{field-list}~\KWD{\}} \nlsep \TERM{Ltac}~\NT{ltac-def}~\STARGR{~\TERM{with}~\NT{ltac-def}} \end{rules} \begin{rules} \DEFNT{thm-token} \TERM{Theorem} ~\mid~ \TERM{Lemma} ~\mid~ \TERM{Fact} ~\mid~ \TERM{Remark} \SEPDEF \DEFNT{def-token} \TERM{Definition} ~\mid~ \TERM{Let} ~\mid~ \OPT{\TERM{Local}}~\TERM{SubClass} \SEPDEF \DEFNT{assum-token} \TERM{Hypothesis} ~\mid~ \TERM{Variable} ~\mid~ \TERM{Axiom} ~\mid~ \TERM{Parameter} \SEPDEF \DEFNT{finite-token} \TERM{Inductive} ~\mid~ \TERM{CoInductive} \SEPDEF \DEFNT{record-tok} \TERM{Record} ~\mid~ \TERM{Structure} \end{rules} \begin{rules} \DEFNT{def-body} \STAR{\NT{binder-let}}~\NT{type-cstr}~\KWD{:=} ~\OPT{\NT{reduce}}~\NT{constr} \nlsep \STAR{\NT{binder-let}}~\KWD{:}~\NT{constr} \SEPDEF \DEFNT{reduce} \TERM{Eval}~\NT{red-expr}~\KWD{in} \SEPDEF \DEFNT{ltac-def} \NT{ident}~\STAR{\NT{name}}~\KWD{:=}~\NT{tactic} \SEPDEF \DEFNT{rec-definition} \NT{fix-decl}~\OPT{\NT{decl-notation}} \SEPDEF \DEFNT{inductive-definition} \OPT{\NT{string}}~\NT{ident}~\STAR{\NT{binder-let}}~\KWD{:} ~\NT{constr}~\KWD{:=} ~\OPT{\TERMbar}~\OPT{\NT{constructor-list}} ~\OPT{\NT{decl-notation}} \SEPDEF \DEFNT{constructor-list} \NT{constructor}~\TERMbar~\NT{constructor-list} \nlsep \NT{constructor} \SEPDEF \DEFNT{constructor} \NT{ident}~\STAR{\NT{binder-let}}\OPTGR{\NT{coerce-kwd}~\NT{constr}} \SEPDEF \DEFNT{decl-notation} \TERM{where}~\NT{string}~\TERM{:=}~\NT{constr} \SEPDEF \DEFNT{field-list} \NT{field}~\KWD{;}~\NT{field-list} \nlsep \NT{field} \SEPDEF \DEFNT{field} \NT{ident}~\OPTGR{\NT{coerce-kwd}~\NT{constr}} \nlsep \NT{ident}~\NT{type-cstr-coe}~\KWD{:=}~\NT{constr} \SEPDEF \DEFNT{assum-list} \PLUS{\GR{\KWD{(}~\NT{simple-assum-coe}~\KWD{)}}} \nlsep \NT{simple-assum-coe} \SEPDEF \DEFNT{simple-assum-coe} \PLUS{\NT{ident}}~\NT{coerce-kwd}~\NT{constr} \SEPDEF \DEFNT{coerce-kwd} \TERM{:$>$} ~\mid~ \KWD{:} \SEPDEF \DEFNT{type-cstr-coe} \OPTGR{\NT{coerce-kwd}~\NT{constr}} \SEPDEF \DEFNT{scheme} \NT{ident}~\KWD{:=}~\NT{dep-scheme}~\KWD{for}~\NT{reference} ~\TERM{Sort}~\NT{sort} \SEPDEF \DEFNT{dep-scheme} \TERM{Induction}~\mid~\TERM{Minimality} \end{rules} \subsection{Modules and sections} \begin{rules} \DEFNT{gallina} \TERM{Module}~\NT{ident}~\STAR{\NT{mbinder}}~\OPT{\NT{of-mod-type}} ~\OPTGR{\KWD{:=}~\NT{mod-expr}} \nlsep \TERM{Module}~\KWD{Type}~\NT{ident}~\STAR{\NT{mbinder}} ~\OPTGR{\KWD{:=}~\NT{mod-type}} \nlsep \TERM{Declare}~\TERM{Module}~\NT{ident}~\STAR{\NT{mbinder}} ~\OPT{\NT{of-mod-type}} ~\OPTGR{\KWD{:=}~\NT{mod-expr}} \nlsep \TERM{Section}~\NT{ident} \nlsep \TERM{Chapter}~\NT{ident} \nlsep \TERM{End}~\NT{ident} %% \nlsep \TERM{Require}~\OPT{\NT{export-token}}~\OPT{\NT{specif-token}} ~\PLUS{\NT{reference}} \nlsep \TERM{Require}~\OPT{\NT{export-token}}~\OPT{\NT{specif-token}} ~\NT{string} \nlsep \TERM{Import}~\PLUS{\NT{reference}} \nlsep \TERM{Export}~\PLUS{\NT{reference}} \SEPDEF \DEFNT{export-token} \TERM{Import} ~\mid~ \TERM{Export} \SEPDEF \DEFNT{specif-token} \TERM{Implementation} ~\mid~ \TERM{Specification} \SEPDEF \DEFNT{mod-expr} \NT{reference} \nlsep \NT{mod-expr}~\NT{mod-expr} & L \nlsep \KWD{(}~\NT{mod-expr}~\KWD{)} \SEPDEF \DEFNT{mod-type} \NT{reference} \nlsep \NT{mod-type}~\KWD{with}~\NT{with-declaration} \SEPDEF \DEFNT{with-declaration} %on forcera les ( ) %si exceptionnellemt %un fixpoint ici \TERM{Definition}~\NT{ident}~\KWD{:=}~\NTL{constr}{} %{100} \nlsep \TERM{Module}~\NT{ident}~\KWD{:=}~\NT{reference} \SEPDEF \DEFNT{of-mod-type} \KWD{:}~\NT{mod-type} \nlsep \TERM{$<$:}~\NT{mod-type} \SEPDEF \DEFNT{mbinder} \KWD{(}~\PLUS{\NT{ident}}~\KWD{:}~\NT{mod-type}~\KWD{)} \end{rules} \begin{rules} \DEFNT{gallina} \TERM{Transparent}~\PLUS{\NT{reference}} \nlsep \TERM{Opaque}~\PLUS{\NT{reference}} \nlsep \TERM{Canonical}~\TERM{Structure}~\NT{reference}~\OPT{\NT{def-body}} \nlsep \TERM{Coercion}~\OPT{\TERM{Local}}~\NT{reference}~\NT{def-body} \nlsep \TERM{Coercion}~\OPT{\TERM{Local}}~\NT{reference}~\KWD{:} ~\NT{class-rawexpr}~\TERM{$>->$}~\NT{class-rawexpr} \nlsep \TERM{Identity}~\TERM{Coercion}~\OPT{\TERM{Local}}~\NT{ident}~\KWD{:} ~\NT{class-rawexpr}~\TERM{$>->$}~\NT{class-rawexpr} \nlsep \TERM{Implicit}~\TERM{Arguments}~\NT{reference}~\TERM{[}~\STAR{\NT{num}}~\TERM{]} \nlsep \TERM{Implicit}~\TERM{Arguments}~\NT{reference} \nlsep \TERM{Implicit}~\KWD{Type}~\PLUS{\NT{ident}}~\KWD{:}~\NT{constr} \SEPDEF \DEFNT{command} \TERM{Comments}~\STAR{\NT{comment}} \nlsep \TERM{Pwd} \nlsep \TERM{Cd}~\OPT{\NT{string}} \nlsep \TERM{Drop} ~\mid~ \TERM{ProtectedLoop} ~\mid~\TERM{Quit} %% \nlsep \TERM{Load}~\OPT{\TERM{Verbose}}~\NT{ident} \nlsep \TERM{Load}~\OPT{\TERM{Verbose}}~\NT{string} \nlsep \TERM{Declare}~\TERM{ML}~\TERM{Module}~\PLUS{\NT{string}} \nlsep \TERM{Locate}~\NT{locatable} \nlsep \TERM{Add}~\OPT{\TERM{Rec}}~\TERM{LoadPath}~\NT{string}~\OPT{\NT{as-dirpath}} \nlsep \TERM{Remove}~\TERM{LoadPath}~\NT{string} \nlsep \TERM{Add}~\OPT{\TERM{Rec}}~\TERM{ML}~\TERM{Path}~\NT{string} %% \nlsep \KWD{Type}~\NT{constr} \nlsep \TERM{Print}~\NT{printable} \nlsep \TERM{Print}~\NT{reference} \nlsep \TERM{Inspect}~\NT{num} \nlsep \TERM{About}~\NT{reference} %% \nlsep \TERM{Search}~\NT{reference}~\OPT{\NT{in-out-modules}} \nlsep \TERM{SearchPattern}~\NT{constr-pattern}~\OPT{\NT{in-out-modules}} \nlsep \TERM{SearchRewrite}~\NT{constr-pattern}~\OPT{\NT{in-out-modules}} \nlsep \TERM{SearchAbout}~\NT{reference}~\OPT{\NT{in-out-modules}} \nlsep \TERM{SearchAbout}~\TERM{[}~\STAR{\NT{ref-or-string}}~\TERM{]}\OPT{\NT{in-out-modules}} \nlsep \KWD{Set}~\NT{ident}~\OPT{\NT{opt-value}} \nlsep \TERM{Unset}~\NT{ident} \nlsep \KWD{Set}~\NT{ident}~\NT{ident}~\OPT{\NT{opt-value}} \nlsep \KWD{Set}~\NT{ident}~\NT{ident}~\PLUS{\NT{opt-ref-value}} \nlsep \TERM{Unset}~\NT{ident}~\NT{ident}~\STAR{\NT{opt-ref-value}} %% \nlsep \TERM{Print}~\TERM{Table}~\NT{ident}~\NT{ident} \nlsep \TERM{Print}~\TERM{Table}~\NT{ident} \nlsep \TERM{Add}~\NT{ident}~\OPT{\NT{ident}}~\PLUS{\NT{opt-ref-value}} %% \nlsep \TERM{Test}~\NT{ident}~\OPT{\NT{ident}}~\STAR{\NT{opt-ref-value}} %% \nlsep \TERM{Remove}~\NT{ident}~\OPT{\NT{ident}}~\PLUS{\NT{opt-ref-value}} \SEPDEF \DEFNT{check-command} \TERM{Eval}~\NT{red-expr}~\KWD{in}~\NT{constr} \nlsep \TERM{Check}~\NT{constr} \SEPDEF \DEFNT{ref-or-string} \NT{reference} \nlsep \NT{string} \end{rules} \begin{rules} \DEFNT{printable} \TERM{Term}~\NT{reference} \nlsep \TERM{All} \nlsep \TERM{Section}~\NT{reference} \nlsep \TERM{Grammar}~\NT{ident} \nlsep \TERM{LoadPath} \nlsep \TERM{Module}~\OPT{\KWD{Type}}~\NT{reference} \nlsep \TERM{Modules} \nlsep \TERM{ML}~\TERM{Path} \nlsep \TERM{ML}~\TERM{Modules} \nlsep \TERM{Graph} \nlsep \TERM{Classes} \nlsep \TERM{Coercions} \nlsep \TERM{Coercion}~\TERM{Paths}~\NT{class-rawexpr}~\NT{class-rawexpr} \nlsep \TERM{Tables} % \nlsep \TERM{Proof}~\NT{reference} % Obsolete, useful in V6.3 ?? \nlsep \TERM{Hint}~\OPT{\NT{reference}} \nlsep \TERM{Hint}~\TERM{*} \nlsep \TERM{HintDb}~\NT{ident} \nlsep \TERM{Scopes} \nlsep \TERM{Scope}~\NT{ident} \nlsep \TERM{Visibility}~\OPT{\NT{ident}} \nlsep \TERM{Implicit}~\NT{reference} \SEPDEF \DEFNT{class-rawexpr} \TERM{Funclass}~\mid~\TERM{Sortclass}~\mid~\NT{reference} \SEPDEF \DEFNT{locatable} \NT{reference} \nlsep \TERM{File}~\NT{string} \nlsep \TERM{Library}~\NT{reference} \nlsep \NT{string} \SEPDEF \DEFNT{opt-value} \NT{ident} ~\mid~ \NT{string} \SEPDEF \DEFNT{opt-ref-value} \NT{reference} ~\mid~ \NT{string} \SEPDEF \DEFNT{as-dirpath} \KWD{as}~\NT{reference} \SEPDEF \DEFNT{in-out-modules} \TERM{inside}~\PLUS{\NT{reference}} \nlsep \TERM{outside}~\PLUS{\NT{reference}} \SEPDEF \DEFNT{comment} \NT{constr} \nlsep \NT{string} \end{rules} \subsection{Other commands} %% TODO: min/maj pas a jour \begin{rules} \EXTNT{command} \TERM{Debug}~\TERM{On} \nlsep \TERM{Debug}~\TERM{Off} %% TODO: vernac \nlsep \TERM{Add}~\TERM{setoid}~\tacconstr~\tacconstr~\tacconstr \nlsep \TERM{Add}~\TERM{morphism}~\tacconstr~\KWD{:}~\NT{ident} \nlsep \TERM{Derive}~\TERM{inversion_clear} ~\OPT{\NT{num}}~\NT{ident}~\NT{ident} \nlsep \TERM{Derive}~\TERM{inversion_clear} ~\NT{ident}~\KWD{with}~\tacconstr~\OPTGR{\TERM{Sort}~\NT{sort}} \nlsep \TERM{Derive}~\TERM{inversion} ~\OPT{\NT{num}}~\NT{ident}~\NT{ident} \nlsep \TERM{Derive}~\TERM{inversion} ~\NT{ident}~\KWD{with}~\tacconstr~\OPTGR{\TERM{Sort}~\NT{sort}} \nlsep \TERM{Derive}~\TERM{dependent}~\TERM{inversion_clear} ~\NT{ident}~\KWD{with}~\tacconstr~\OPTGR{\TERM{Sort}~\NT{sort}} \nlsep \TERM{Derive}~\TERM{dependent}~\TERM{inversion} ~\NT{ident}~\KWD{with}~\tacconstr~\OPTGR{\TERM{Sort}~\NT{sort}} %% Correctness: obsolete ? %\nlsep Correctness %\nlsep Global Variable %% TODO: extraction \nlsep Extraction ... %% field \nlsep \TERM{Add}~\TERM{Field}~\tacconstr~\tacconstr~\tacconstr ~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr~\tacconstr~\OPT{\NT{minus-div}} %% funind \nlsep \TERM{Functional}~\TERM{Scheme}~\NT{ident}~\KWD{:=} ~\TERM{Induction}~\KWD{for}~\tacconstr ~\OPTGR{\KWD{with}~\PLUS{\tacconstr}} %% ring \nlsep \TERM{Add}~\TERM{Ring}~\tacconstr~\tacconstr~\tacconstr ~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr~\tacconstr~\KWD{[}~\PLUS{\tacconstr}~\KWD{]} \nlsep \TERM{Add}~\TERM{Semi}~\TERM{Ring}~\tacconstr~\tacconstr~\tacconstr ~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr~\KWD{[}~\PLUS{\tacconstr}~\KWD{]} \nlsep \TERM{Add}~\TERM{Abstract}~\TERM{Ring}~\tacconstr~\tacconstr~\tacconstr ~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr~\tacconstr \nlsep \TERM{Add}~\TERM{Abstract}~\TERM{Semi}~\TERM{Ring}~\tacconstr ~\tacconstr~\tacconstr~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr \nlsep \TERM{Add}~\TERM{Setoid}~\TERM{Ring}~\tacconstr~\tacconstr~\tacconstr ~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr~\tacconstr~\tacconstr~\tacconstr~\tacconstr~\tacconstr ~\tacconstr~\KWD{[}~\PLUS{\tacconstr}~\KWD{]} \nlsep \TERM{Add}~\TERM{Setoid}~\TERM{Semi}~\TERM{Ring}~\tacconstr~\tacconstr ~\tacconstr~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr~\tacconstr~\tacconstr~\tacconstr~\tacconstr ~\KWD{[}~\PLUS{tacconstr}~\KWD{]} \SEPDEF \DEFNT{minus-div} \KWD{with}~\NT{minus-arg}~\NT{div-arg} \nlsep \KWD{with}~\NT{div-arg}~\NT{minus-arg} \SEPDEF \DEFNT{minus-arg} \TERM{minus}~\KWD{:=}~\tacconstr \SEPDEF \DEFNT{div-arg} \TERM{div}~\KWD{:=}~\tacconstr \end{rules} \begin{rules} \EXTNT{command} \TERM{Write}~\TERM{State}~\NT{ident} \nlsep \TERM{Write}~\TERM{State}~\NT{string} \nlsep \TERM{Restore}~\TERM{State}~\NT{ident} \nlsep \TERM{Restore}~\TERM{State}~\NT{string} \nlsep \TERM{Reset}~\NT{ident} \nlsep \TERM{Reset}~\TERM{Initial} \nlsep \TERM{Back}~\OPT{\NT{num}} \end{rules} \subsection{Proof-editing commands} \begin{rules} \EXTNT{command} \TERM{Goal}~\NT{constr} \nlsep \TERM{Proof}~\OPT{\NT{constr}} \nlsep \TERM{Proof}~\KWD{with}~\NT{tactic} \nlsep \TERM{Abort}~\OPT{\TERM{All}} \nlsep \TERM{Abort}~\NT{ident} \nlsep \TERM{Existential}~\NT{num}~\KWD{:=}~\NT{constr-body} \nlsep \TERM{Qed} \nlsep \TERM{Save}~\OPTGR{\NT{thm-token}~\NT{ident}} \nlsep \TERM{Defined}~\OPT{\NT{ident}} \nlsep \TERM{Suspend} \nlsep \TERM{Resume}~\OPT{\NT{ident}} \nlsep \TERM{Restart} \nlsep \TERM{Undo}~\OPT{\NT{num}} \nlsep \TERM{Focus}~\OPT{\NT{num}} \nlsep \TERM{Unfocus} \nlsep \TERM{Show}~\OPT{\NT{num}} \nlsep \TERM{Show}~\TERM{Implicit}~\TERM{Arguments}~\OPT{\NT{num}} \nlsep \TERM{Show}~\TERM{Node} \nlsep \TERM{Show}~\TERM{Script} \nlsep \TERM{Show}~\TERM{Existentials} \nlsep \TERM{Show}~\TERM{Tree} \nlsep \TERM{Show}~\TERM{Conjecture} \nlsep \TERM{Show}~\TERM{Proof} \nlsep \TERM{Show}~\TERM{Intro} \nlsep \TERM{Show}~\TERM{Intros} %% Correctness: obsolete ? %%\nlsep \TERM{Show}~\TERM{Programs} \nlsep \TERM{Hint}~\OPT{\TERM{Local}}~\NT{hint}~\OPT{\NT{inbases}} %% PrintConstr not documented \end{rules} \begin{rules} \DEFNT{constr-body} \NT{type-cstr}~\KWD{:=}~\NT{constr} \SEPDEF \DEFNT{hint} \TERM{Resolve}~\PLUS{\NTL{constr}{9}} \nlsep \TERM{Immediate}~\PLUS{\NTL{constr}{9}} \nlsep \TERM{Unfold}~\PLUS{\NT{reference}} \nlsep \TERM{Constructors}~\PLUS{\NT{reference}} \nlsep \TERM{Extern}~\NT{num}~\NT{constr}~\KWD{$\Rightarrow$}~\NT{tactic} \nlsep \TERM{Destruct}~\NT{ident}~\KWD{:=}~\NT{num}~\NT{destruct-loc} ~\NT{constr}~\KWD{$\Rightarrow$}~\NT{tactic} \nlsep \TERM{Rewrite}~\NT{orient}~\PLUS{\NTL{constr}{9}} ~\OPTGR{\KWD{using}~\NT{tactic}} \SEPDEF \DEFNT{inbases} \KWD{:}~\PLUS{\NT{ident}} \SEPDEF \DEFNT{destruct-loc} \TERM{Conclusion} \nlsep \OPT{\TERM{Discardable}}~\TERM{Hypothesis} \end{rules} \subsection{Syntax extensions} \begin{rules} \DEFNT{syntax} \TERM{Open}~\TERM{Scope}~\NT{ident} \nlsep \TERM{Close}~\TERM{Scope}~\NT{ident} \nlsep \TERM{Delimit}~\TERM{Scope}~\NT{ident}~\KWD{with}~\NT{ident} \nlsep \TERM{Bind}~\TERM{Scope}~\NT{ident}~\KWD{with}~\PLUS{\NT{class-rawexpr}} \nlsep \TERM{Arguments}~\TERM{Scope}~\NT{reference} ~\TERM{[}~\PLUS{\NT{name}}~\TERM{]} \nlsep \TERM{Infix}~\OPT{\TERM{Local}} %%% ~\NT{prec}~\OPT{\NT{num}} ~\NT{string}~\KWD{:=}~\NT{reference}~\OPT{\NT{modifiers}} ~\OPT{\NT{in-scope}} \nlsep \TERM{Notation}~\OPT{\TERM{Local}}~\NT{string}~\KWD{:=}~\NT{constr} ~\OPT{\NT{modifiers}}~\OPT{\NT{in-scope}} \nlsep \TERM{Notation}~\OPT{\TERM{Local}}~\NT{ident}~\KWD{:=}~\NT{constr} ~\OPT{\KWD{(}\TERM{only~\TERM{parsing}\KWD{)}}} \nlsep \TERM{Reserved}~\TERM{Notation}~\OPT{\TERM{Local}}~\NT{string} ~\OPT{\NT{modifiers}} \nlsep \TERM{Tactic}~\TERM{Notation}~\NT{string}~\STAR{\NT{tac-production}} ~\KWD{:=}~\NT{tactic} \SEPDEF \DEFNT{modifiers} \KWD{(}~\NT{mod-list}~\KWD{)} \SEPDEF \DEFNT{mod-list} \NT{modifier} \nlsep \NT{modifier}~\KWD{,}~\NT{mod-list} \SEPDEF \DEFNT{modifier} \NT{ident}~\KWD{at}~\NT{num} \nlsep \NT{ident}~\STARGR{\KWD{,}~\NT{ident}}~\KWD{at}~\NT{num} \nlsep \KWD{at}~\TERM{next}~\TERM{level} \nlsep \KWD{at}~\TERM{level}~\NT{num} \nlsep \TERM{left}~\TERM{associativity} \nlsep \TERM{right}~\TERM{associativity} \nlsep \TERM{no}~\TERM{associativity} \nlsep \NT{ident}~\NT{syntax-entry} \nlsep \TERM{only}~\TERM{parsing} \nlsep \TERM{format}~\NT{string} \SEPDEF \DEFNT{in-scope} \KWD{:}~\NT{ident} \SEPDEF \DEFNT{syntax-entry} \TERM{ident}~\mid~\TERM{global}~\mid~\TERM{bigint} \SEPDEF \DEFNT{tac-production} \NT{string} \nlsep \NT{ident}~\TERM{(}~\NT{ident}~\TERM{)} %%% \SEPDEF %%% \DEFNT{prec} %%% \TERM{LeftA}~\mid~\TERM{RightA}~\mid~\TERM{NonA} \end{rules} \end{document} coq-8.6/dev/v8-syntax/memo-v8.tex0000644000175000017500000002305313022274260016133 0ustar mdenesmdenes \documentclass{article} \usepackage{verbatim} \usepackage{amsmath} \usepackage{amssymb} \usepackage{array} \usepackage{fullpage} \author{B.~Barras} \title{An introduction to syntax of Coq V8} %% Le _ est un caractère normal \catcode`\_=13 \let\subscr=_ \def_{\ifmmode\sb\else\subscr\fi} \def\NT#1{\langle\textit{#1}\rangle} \def\NTL#1#2{\langle\textit{#1}\rangle_{#2}} \def\TERM#1{\textsf{\bf #1}} \newenvironment{transbox} {\begin{center}\tt\begin{tabular}{l|ll} \hfil\textrm{V7} & \hfil\textrm{V8} \\ \hline} {\end{tabular}\end{center}} \def\TRANS#1#2 {\begin{tabular}[t]{@{}l@{}}#1\end{tabular} & \begin{tabular}[t]{@{}l@{}}#2\end{tabular} \\} \def\TRANSCOM#1#2#3 {\begin{tabular}[t]{@{}l@{}}#1\end{tabular} & \begin{tabular}[t]{@{}l@{}}#2\end{tabular} & #3 \\} \begin{document} \maketitle The goal of this document is to introduce by example to the new syntax of Coq. It is strongly recommended to read first the definition of the new syntax, but this document should also be useful for the eager user who wants to start with the new syntax quickly. \section{Changes in lexical conventions w.r.t. V7} \subsection{Identifiers} The lexical conventions changed: \TERM{_} is not a regular identifier anymore. It is used in terms as a placeholder for subterms to be inferred at type-checking, and in patterns as a non-binding variable. Furthermore, only letters (unicode letters), digits, single quotes and _ are allowed after the first character. \subsection{Quoted string} Quoted strings are used typically to give a filename (which may not be a regular identifier). As before they are written between double quotes ("). Unlike for V7, there is no escape character: characters are written normaly but the double quote which is doubled. \section{Main changes in terms w.r.t. V7} \subsection{Precedence of application} In the new syntax, parentheses are not really part of the syntax of application. The precedence of application (10) is tighter than all prefix and infix notations. It makes it possible to remove parentheses in many contexts. \begin{transbox} \TRANS{(A x)->(f x)=(g y)}{A x -> f x = g y} \TRANS{(f [x]x)}{f (fun x => x)} \end{transbox} \subsection{Arithmetics and scopes} The specialized notation for \TERM{Z} and \TERM{R} (introduced by symbols \TERM{`} and \TERM{``}) have disappeared. They have been replaced by the general notion of scope. \begin{center} \begin{tabular}{l|l|l} type & scope name & delimiter \\ \hline types & type_scope & \TERM{T} \\ \TERM{bool} & bool_scope & \\ \TERM{nat} & nat_scope & \TERM{nat} \\ \TERM{Z} & Z_scope & \TERM{Z} \\ \TERM{R} & R_scope & \TERM{R} \\ \TERM{positive} & positive_scope & \TERM{P} \end{tabular} \end{center} In order to use notations of arithmetics on \TERM{Z}, its scope must be opened with command \verb+Open Scope Z_scope.+ Another possibility is using the scope change notation (\TERM{\%}). The latter notation is to be used when notations of several scopes appear in the same expression. In examples below, scope changes are not needed if the appropriate scope has been opened. Scope nat_scope is opened in the initial state of Coq. \begin{transbox} \TRANSCOM{`0+x=x+0`}{0+x=x+0}{\textrm{Z_scope}} \TRANSCOM{``0 + [if b then ``1`` else ``2``]``}{0 + if b then 1 else 2}{\textrm{R_scope}} \TRANSCOM{(0)}{0}{\textrm{nat_scope}} \end{transbox} Below is a table that tells which notation is available in which scope. The relative precedences and associativity of operators is the same as in usual mathematics. See the reference manual for more details. However, it is important to remember that unlike V7, the type operators for product and sum are left associative, in order not to clash with arithmetic operators. \begin{center} \begin{tabular}{l|l} scope & notations \\ \hline nat_scope & $+ ~- ~* ~< ~\leq ~> ~\geq$ \\ Z_scope & $+ ~- ~* ~/ ~\TERM{mod} ~< ~\leq ~> ~\geq ~?=$ \\ R_scope & $+ ~- ~* ~/ ~< ~\leq ~> ~\geq$ \\ type_scope & $* ~+$ \\ bool_scope & $\TERM{\&\&} ~\TERM{$||$} ~\TERM{-}$ \\ list_scope & $\TERM{::} ~\TERM{++}$ \end{tabular} \end{center} (Note: $\leq$ is written \TERM{$<=$}) \subsection{Notation for implicit arguments} The explicitation of arguments is closer to the \emph{bindings} notation in tactics. Argument positions follow the argument names of the head constant. \begin{transbox} \TRANS{f 1!t1 2!t2}{f (x:=t1) (y:=t2)} \TRANS{!f t1 t2}{@f t1 t2} \end{transbox} \subsection{Universal quantification} The universal quantification and dependent product types are now materialized with the \TERM{forall} keyword before the binders and a comma after the binders. The syntax of binders also changed significantly. A binder can simply be a name when its type can be inferred. In other cases, the name and the type of the variable are put between parentheses. When several consecutive variables have the same type, they can be grouped. Finally, if all variables have the same type parentheses can be omitted. \begin{transbox} \TRANS{(x:A)B}{forall (x:~A), B ~~\textrm{or}~~ forall x:~A, B} \TRANS{(x,y:nat)P}{forall (x y :~nat), P ~~\textrm{or}~~ forall x y :~nat, P} \TRANS{(x,y:nat;z:A)P}{forall (x y :~nat) (z:A), P} \TRANS{(x,y,z,t:?)P}{forall x y z t, P} \TRANS{(x,y:nat;z:?)P}{forall (x y :~nat) z, P} \end{transbox} \subsection{Abstraction} The notation for $\lambda$-abstraction follows that of universal quantification. The binders are surrounded by keyword \TERM{fun} and $\Rightarrow$ (\verb+=>+ in ascii). \begin{transbox} \TRANS{[x,y:nat; z](f a b c)}{fun (x y:nat) z => f a b c} \end{transbox} \subsection{Pattern-matching} Beside the usage of the keyword pair \TERM{match}/\TERM{with} instead of \TERM{Cases}/\TERM{of}, the main change is the notation for the type of branches and return type. It is no longer written between \TERM{$<$ $>$} before the \TERM{Cases} keyword, but interleaved with the destructured objects. The idea is that for each destructured object, one may specify a variable name to tell how the branches types depend on this destructured objects (case of a dependent elimination), and also how they depend on the value of the arguments of the inductive type of the destructured objects. The type of branches is then given after the keyword \TERM{return}, unless it can be inferred. Moreover, when the destructured object is a variable, one may use this variable in the return type. \begin{transbox} \TRANS{Cases n of\\~~ O => O \\| (S k) => (1) end}{match n with\\~~ 0 => 0 \\| (S k) => 1 end} \TRANS{Cases m n of \\~~0 0 => t \\| ... end}{match m, n with \\~~0, 0 => t \\| .. end} \TRANS{<[n:nat](P n)>Cases T of ... end}{match T as n return P n with ... end} \TRANS{<[n:nat][p:(even n)]\~{}(odd n)>Cases p of\\~~ ... \\end}{match p in even n return \~{} odd n with\\~~ ...\\end} \end{transbox} \subsection{Fixpoints and cofixpoints} An easier syntax for non-mutual fixpoints is provided, making it very close to the usual notation for non-recursive functions. The decreasing argument is now indicated by an annotation between curly braces, regardless of the binders grouping. The annotation can be omitted if the binders introduce only one variable. The type of the result can be omitted if inferable. \begin{transbox} \TRANS{Fix plus\{plus [n:nat] : nat -> nat :=\\~~ [m]...\}}{fix plus (n m:nat) \{struct n\}: nat := ...} \TRANS{Fix fact\{fact [n:nat]: nat :=\\ ~~Cases n of\\~~~~ O => (1) \\~~| (S k) => (mult n (fact k)) end\}}{fix fact (n:nat) :=\\ ~~match n with \\~~~~0 => 1 \\~~| (S k) => n * fact k end} \end{transbox} There is a syntactic sugar for mutual fixpoints associated to a local definition: \begin{transbox} \TRANS{let f := Fix f \{f [x:A] : T := M\} in\\(g (f y))}{let fix f (x:A) : T := M in\\g (f x)} \end{transbox} The same applies to cofixpoints, annotations are not allowed in that case. \subsection{Notation for type cast} \begin{transbox} \TRANS{O :: nat}{0 : nat} \end{transbox} \section{Main changes in tactics w.r.t. V7} The main change is that all tactic names are lowercase. This also holds for Ltac keywords. \subsection{Ltac} Definitions of macros are introduced by \TERM{Ltac} instead of \TERM{Tactic Definition}, \TERM{Meta Definition} or \TERM{Recursive Definition}. Rules of a match command are not between square brackets anymore. Context (understand a term with a placeholder) instantiation \TERM{inst} became \TERM{context}. Syntax is unified with subterm matching. \begin{transbox} \TRANS{match t with [C[x=y]] => inst C[y=x]}{match t with context C[x=y] => context C[y=x]} \end{transbox} \subsection{Named arguments of theorems} \begin{transbox} \TRANS{Apply thm with x:=t 1:=u}{apply thm with (x:=t) (1:=u)} \end{transbox} \subsection{Occurrences} To avoid ambiguity between a numeric literal and the optionnal occurrence numbers of this term, the occurrence numbers are put after the term itself. This applies to tactic \TERM{pattern} and also \TERM{unfold} \begin{transbox} \TRANS{Pattern 1 2 (f x) 3 4 d y z}{pattern (f x at 1 2) (d at 3 4) y z} \end{transbox} \section{Main changes in vernacular commands w.r.t. V7} \subsection{Binders} The binders of vernacular commands changed in the same way as those of fixpoints. This also holds for parameters of inductive definitions. \begin{transbox} \TRANS{Definition x [a:A] : T := M}{Definition x (a:A) : T := M} \TRANS{Inductive and [A,B:Prop]: Prop := \\~~conj : A->B->(and A B)}% {Inductive and (A B:Prop): Prop := \\~~conj : A -> B -> and A B} \end{transbox} \subsection{Hints} The syntax of \emph{extern} hints changed: the pattern and the tactic to be applied are separated by a \TERM{$\Rightarrow$}. \begin{transbox} \TRANS{Hint Extern 4 (toto ?) Apply lemma}{Hint Extern 4 (toto _) => apply lemma} \end{transbox} \end{document} coq-8.6/dev/v8-syntax/check-grammar0000755000175000017500000000227113022274260016547 0ustar mdenesmdenes#!/bin/sh # This scripts checks that the new grammar of Coq as defined in syntax-v8.tex # is consistent in the sense that all invoked non-terminals are defined defined_nt() { grep "\\DEFNT{.*}" syntax-v8.tex | sed -e "s|.*DEFNT{\([^}]*\)}.*|\1|"|\ sort | sort -u } used_nt() { cat syntax-v8.tex | tr \\\\ \\n | grep "^NT{.*}" |\ sed -e "s|^NT{\([^}]*\)}.*|\1|" | egrep -v ^\#1\|non-terminal | sort -u } used_term() { cat syntax-v8.tex | tr \\\\ \\n | grep "^TERM{.*}" |\ sed -e "s|^TERM{\([^}]*\)}.*|\1|" -e "s|\\$||g" | egrep -v ^\#1\|terminal | sort -u } used_kwd() { cat syntax-v8.tex | tr \\\\ \\n | grep "^KWD{.*}" |\ sed -e "s|^KWD{\([^}]*\)}.*|\1|" -e "s|\\$||g" | egrep -v ^\#1 | sort -u } defined_nt > def used_nt > use used_term > use-t used_kwd > use-k diff def use > df ############################### echo if grep ^\> df > /dev/null 2>&1 ; then echo Undefined non-terminals: echo ======================== echo grep ^\> df | sed -e "s|^> ||" echo fi if grep ^\< df > /dev/null 2>&1 ; then echo Unused non-terminals: echo ===================== echo grep ^\< df | sed -e "s|^< ||" echo fi #echo Used terminals: #echo =============== #echo #cat use-tcoq-8.6/dev/TODO0000644000175000017500000000141013022274260012721 0ustar mdenesmdenes o options de la ligne de commande - reporter les options de l'ancien script coqtop sur le nouveau coqtop.ml o arguments implicites - les calculer une fois pour toutes à la déclaration (dans Declare) et stocker cette information dans le in_variable, in_constant, etc. o Environnements compilés (type Environ.compiled_env) - pas de timestamp mais plutôt un checksum avec Digest (mais comment ?) o Efficacité - utiliser DOPL plutôt que DOPN (sauf pour Case) - batch mode => pas de undo, ni de reset - conversion : déplier la constante la plus récente - un cache pour type_of_const, type_of_inductive, type_of_constructor, lookup_mind_specif o Toplevel - parsing de la ligne de commande : utiliser Arg ??? coq-8.6/dev/dynlink.ml0000644000175000017500000000331413022274260014240 0ustar mdenesmdenes (** Some architectures may have a native ocaml compiler but no native dynlink.cmxa (e.g. ARM). If you still want to build a native coqtop there, you'll need this dummy implementation of Dynlink. Compile it and install with: ocamlopt -a -o dynlink.cmxa dynlink.ml sudo cp -i dynlink.cmxa `ocamlopt -where` Then build coq this way: ./configure -natdynlink no && make world *) let is_native = true (* This file will only be given to the native compiler *) type linking_error = | Undefined_global of string | Unavailable_primitive of string | Uninitialized_global of string type error = | Not_a_bytecode_file of string | Inconsistent_import of string | Unavailable_unit of string | Unsafe_file | Linking_error of string * linking_error | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string | Inconsistent_implementation of string exception Error of error let error_message = function | Not_a_bytecode_file s -> "Native dynamic link not supported (module "^s^")" | _ -> "Native dynamic link not supported" let loadfile : string -> unit = fun s -> raise (Error (Not_a_bytecode_file s)) let loadfile_private = loadfile let adapt_filename s = s let init () = () let allow_only : string list -> unit = fun _ -> () let prohibit : string list -> unit = fun _ -> () let default_available_units : unit -> unit = fun _ -> () let allow_unsafe_modules : bool -> unit = fun _ -> () let add_interfaces : string list -> string list -> unit = fun _ _ -> () let add_available_units : (string * Digest.t) list -> unit = fun _ -> () let clear_available_units : unit -> unit = fun _ -> () let digest_interface : string -> string list -> Digest.t = fun _ _ -> failwith "digest_interface" coq-8.6/dev/header0000644000175000017500000000101513022274260013405 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* raise Not_found) (* std_ppcmds *) let pp x = Pp.pp_with !Pp_control.std_ft x (** Future printer *) let ppfuture kx = pp (Future.print (fun _ -> str "_") kx) (* name printers *) let ppid id = pp (pr_id id) let pplab l = pp (pr_lab l) let ppmbid mbid = pp (str (MBId.debug_to_string mbid)) let ppdir dir = pp (pr_dirpath dir) let ppmp mp = pp(str (ModPath.debug_to_string mp)) let ppcon con = pp(debug_pr_con con) let ppproj con = pp(debug_pr_con (Projection.constant con)) let ppkn kn = pp(str (KerName.to_string kn)) let ppmind kn = pp(debug_pr_mind kn) let ppind (kn,i) = pp(debug_pr_mind kn ++ str"," ++int i) let ppsp sp = pp(pr_path sp) let ppqualid qid = pp(pr_qualid qid) let ppclindex cl = pp(Classops.pr_cl_index cl) let ppscheme k = pp (Ind_tables.pr_scheme_kind k) let pprecarg = function | Declarations.Norec -> str "Norec" | Declarations.Mrec (mind,i) -> str "Mrec[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]" | Declarations.Imbr (mind,i) -> str "Imbr[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]" let ppwf_paths x = pp (Rtree.pp_tree pprecarg x) let pprecarg = function | Declarations.Norec -> str "Norec" | Declarations.Mrec (mind,i) -> str "Mrec[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]" | Declarations.Imbr (mind,i) -> str "Imbr[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]" let ppwf_paths x = pp (Rtree.pp_tree pprecarg x) (* term printers *) let rawdebug = ref false let ppevar evk = pp (str (Evd.string_of_existential evk)) let ppconstr x = pp (Termops.print_constr x) let ppconstr_expr x = pp (Ppconstr.pr_constr_expr x) let ppconstrdb x = pp(Flags.with_option rawdebug Termops.print_constr x) let ppterm = ppconstr let ppsconstr x = ppconstr (Mod_subst.force_constr x) let ppconstr_univ x = Constrextern.with_universes ppconstr x let ppglob_constr = (fun x -> pp(pr_lglob_constr x)) let pppattern = (fun x -> pp(pr_constr_pattern x)) let pptype = (fun x -> try pp(pr_ltype x) with e -> pp (str (Printexc.to_string e))) let ppfconstr c = ppconstr (CClosure.term_of_fconstr c) let ppbigint n = pp (str (Bigint.to_string n));; let prset pr l = str "[" ++ hov 0 (prlist_with_sep spc pr l) ++ str "]" let ppintset l = pp (prset int (Int.Set.elements l)) let ppidset l = pp (prset pr_id (Id.Set.elements l)) let prset' pr l = str "[" ++ hov 0 (prlist_with_sep pr_comma pr l) ++ str "]" let pridmap pr l = let pr (id,b) = pr_id id ++ str "=>" ++ pr id b in prset' pr (Id.Map.fold (fun a b l -> (a,b)::l) l []) let ppidmap pr l = pp (pridmap pr l) let ppevarsubst = ppidmap (fun id0 -> prset (fun (c,copt,id) -> hov 0 (Termops.print_constr c ++ (match copt with None -> mt () | Some c -> spc () ++ str "") ++ (if id = id0 then mt () else spc () ++ str "")))) let prididmap = pridmap (fun _ -> pr_id) let ppididmap = ppidmap (fun _ -> pr_id) let prconstrunderbindersidmap = pridmap (fun _ (l,c) -> hov 1 (str"[" ++ prlist_with_sep spc Id.print l ++ str"]") ++ str "," ++ spc () ++ Termops.print_constr c) let ppconstrunderbindersidmap l = pp (prconstrunderbindersidmap l) let ppunbound_ltac_var_map l = ppidmap (fun _ arg -> str"") open Glob_term let rec pr_closure {idents=idents;typed=typed;untyped=untyped} = hov 1 (str"{idents=" ++ prididmap idents ++ str";" ++ spc() ++ str"typed=" ++ prconstrunderbindersidmap typed ++ str";" ++ spc() ++ str"untyped=" ++ pr_closed_glob_constr_idmap untyped ++ str"}") and pr_closed_glob_constr_idmap x = pridmap (fun _ -> pr_closed_glob_constr) x and pr_closed_glob_constr {closure=closure;term=term} = pr_closure closure ++ pr_lglob_constr term let ppclosure x = pp (pr_closure x) let ppclosedglobconstr x = pp (pr_closed_glob_constr x) let ppclosedglobconstridmap x = pp (pr_closed_glob_constr_idmap x) let pP s = pp (hov 0 s) let safe_pr_global = function | ConstRef kn -> pp (str "CONSTREF(" ++ debug_pr_con kn ++ str ")") | IndRef (kn,i) -> pp (str "INDREF(" ++ debug_pr_mind kn ++ str "," ++ int i ++ str ")") | ConstructRef ((kn,i),j) -> pp (str "INDREF(" ++ debug_pr_mind kn ++ str "," ++ int i ++ str "," ++ int j ++ str ")") | VarRef id -> pp (str "VARREF(" ++ pr_id id ++ str ")") let ppglobal x = try pp(pr_global x) with _ -> safe_pr_global x let ppconst (sp,j) = pp (str"#" ++ pr_kn sp ++ str"=" ++ pr_lconstr j.uj_val) let ppvar ((id,a)) = pp (str"#" ++ pr_id id ++ str":" ++ pr_lconstr a) let genppj f j = let (c,t) = f j in (c ++ str " : " ++ t) let ppj j = pp (genppj pr_ljudge j) let prsubst s = pp (Mod_subst.debug_pr_subst s) let prdelta s = pp (Mod_subst.debug_pr_delta s) let pp_idpred s = pp (pr_idpred s) let pp_cpred s = pp (pr_cpred s) let pp_transparent_state s = pp (pr_transparent_state s) let pp_stack_t n = pp (Reductionops.Stack.pr Termops.print_constr n) let pp_cst_stack_t n = pp (Reductionops.Cst_stack.pr n) let pp_state_t n = pp (Reductionops.pr_state n) (* proof printers *) let pr_evar ev = Pp.int (Evar.repr ev) let ppmetas metas = pp(pr_metaset metas) let ppevm evd = pp(pr_evar_map ~with_univs:!Flags.univ_print (Some 2) evd) let ppevmall evd = pp(pr_evar_map ~with_univs:!Flags.univ_print None evd) let pr_existentialset evars = prlist_with_sep spc pr_evar (Evar.Set.elements evars) let ppexistentialset evars = pp (pr_existentialset evars) let ppexistentialfilter filter = match Evd.Filter.repr filter with | None -> pp (Pp.str "ø") | Some f -> pp (prlist_with_sep spc bool f) let ppclenv clenv = pp(pr_clenv clenv) let ppgoalgoal gl = pp(Goal.pr_goal gl) let ppgoal g = pp(Printer.pr_goal g) let ppgoalsigma g = pp(Printer.pr_goal g ++ pr_evar_map None (Refiner.project g)) let pphintdb db = pp(Hints.pr_hint_db db) let ppproofview p = let gls,sigma = Proofview.proofview p in pp(pr_enum Goal.pr_goal gls ++ fnl () ++ pr_evar_map (Some 1) sigma) let ppopenconstr (x : Evd.open_constr) = let (evd,c) = x in pp (pr_evar_map (Some 2) evd ++ pr_constr c) (* spiwack: deactivated until a replacement is found let pppftreestate p = pp(print_pftreestate p) *) (* let ppgoal g = pp(db_pr_goal g) *) (* let pr_gls gls = *) (* hov 0 (pr_evar_defs (sig_sig gls) ++ fnl () ++ db_pr_goal (sig_it gls)) *) (* let pr_glls glls = *) (* hov 0 (pr_evar_defs (sig_sig glls) ++ fnl () ++ *) (* prlist_with_sep fnl db_pr_goal (sig_it glls)) *) (* let ppsigmagoal g = pp(pr_goal (sig_it g)) *) (* let prgls gls = pp(pr_gls gls) *) (* let prglls glls = pp(pr_glls glls) *) (* let pproof p = pp(print_proof Evd.empty empty_named_context p) *) let ppuni u = pp(pr_uni u) let ppuni_level u = pp (Level.pr u) let ppuniverse u = pp (str"[" ++ Universe.pr u ++ str"]") let prlev = Universes.pr_with_global_universes let ppuniverse_set l = pp (LSet.pr prlev l) let ppuniverse_instance l = pp (Instance.pr prlev l) let ppuniverse_context l = pp (pr_universe_context prlev l) let ppuniverse_context_set l = pp (pr_universe_context_set prlev l) let ppuniverse_subst l = pp (Univ.pr_universe_subst l) let ppuniverse_opt_subst l = pp (Universes.pr_universe_opt_subst l) let ppuniverse_level_subst l = pp (Univ.pr_universe_level_subst l) let ppevar_universe_context l = pp (Evd.pr_evar_universe_context l) let ppconstraints c = pp (pr_constraints Level.pr c) let ppuniverseconstraints c = pp (Universes.Constraints.pr c) let ppuniverse_context_future c = let ctx = Future.force c in ppuniverse_context ctx let ppuniverses u = pp (UGraph.pr_universes Level.pr u) let ppnamedcontextval e = pp (pr_named_context (Global.env ()) Evd.empty (named_context_of_val e)) let ppenv e = pp (str "[" ++ pr_named_context_of e Evd.empty ++ str "]" ++ spc() ++ str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]") let ppenvwithcst e = pp (str "[" ++ pr_named_context_of e Evd.empty ++ str "]" ++ spc() ++ str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]" ++ spc() ++ str "{" ++ Cmap_env.fold (fun a _ s -> pr_con a ++ spc () ++ s) (Obj.magic e).Pre_env.env_globals.Pre_env.env_constants (mt ()) ++ str "}") let pptac = (fun x -> pp(Pptactic.pr_glob_tactic (Global.env()) x)) let ppobj obj = Format.print_string (Libobject.object_tag obj) let cnt = ref 0 let cast_kind_display k = match k with | VMcast -> "VMcast" | DEFAULTcast -> "DEFAULTcast" | REVERTcast -> "REVERTcast" | NATIVEcast -> "NATIVEcast" let constr_display csr = let rec term_display c = match kind_of_term c with | Rel n -> "Rel("^(string_of_int n)^")" | Meta n -> "Meta("^(string_of_int n)^")" | Var id -> "Var("^(Id.to_string id)^")" | Sort s -> "Sort("^(sort_display s)^")" | Cast (c,k, t) -> "Cast("^(term_display c)^","^(cast_kind_display k)^","^(term_display t)^")" | Prod (na,t,c) -> "Prod("^(name_display na)^","^(term_display t)^","^(term_display c)^")\n" | Lambda (na,t,c) -> "Lambda("^(name_display na)^","^(term_display t)^","^(term_display c)^")\n" | LetIn (na,b,t,c) -> "LetIn("^(name_display na)^","^(term_display b)^"," ^(term_display t)^","^(term_display c)^")" | App (c,l) -> "App("^(term_display c)^","^(array_display l)^")\n" | Evar (e,l) -> "Evar("^(string_of_existential e)^","^(array_display l)^")" | Const (c,u) -> "Const("^(string_of_con c)^","^(universes_display u)^")" | Ind ((sp,i),u) -> "MutInd("^(string_of_mind sp)^","^(string_of_int i)^","^(universes_display u)^")" | Construct (((sp,i),j),u) -> "MutConstruct(("^(string_of_mind sp)^","^(string_of_int i)^")," ^","^(universes_display u)^(string_of_int j)^")" | Proj (p, c) -> "Proj("^(string_of_con (Projection.constant p))^","^term_display c ^")" | Case (ci,p,c,bl) -> "MutCase(,"^(term_display p)^","^(term_display c)^"," ^(array_display bl)^")" | Fix ((t,i),(lna,tl,bl)) -> "Fix(([|"^(Array.fold_right (fun x i -> (string_of_int x)^(if not(i="") then (";"^i) else "")) t "")^"|],"^(string_of_int i)^")," ^(array_display tl)^",[|" ^(Array.fold_right (fun x i -> (name_display x)^(if not(i="") then (";"^i) else "")) lna "")^"|]," ^(array_display bl)^")" | CoFix(i,(lna,tl,bl)) -> "CoFix("^(string_of_int i)^")," ^(array_display tl)^"," ^(Array.fold_right (fun x i -> (name_display x)^(if not(i="") then (";"^i) else "")) lna "")^"," ^(array_display bl)^")" and array_display v = "[|"^ (Array.fold_right (fun x i -> (term_display x)^(if not(i="") then (";"^i) else "")) v "")^"|]" and univ_display u = incr cnt; pp (str "with " ++ int !cnt ++ str" " ++ pr_uni u ++ fnl ()) and level_display u = incr cnt; pp (str "with " ++ int !cnt ++ str" " ++ Level.pr u ++ fnl ()) and sort_display = function | Prop(Pos) -> "Prop(Pos)" | Prop(Null) -> "Prop(Null)" | Type u -> univ_display u; "Type("^(string_of_int !cnt)^")" and universes_display l = Array.fold_right (fun x i -> level_display x; (string_of_int !cnt)^(if not(i="") then (" "^i) else "")) (Instance.to_array l) "" and name_display = function | Name id -> "Name("^(Id.to_string id)^")" | Anonymous -> "Anonymous" in pp (str (term_display csr) ++fnl ()) open Format;; let print_pure_constr csr = let rec term_display c = match kind_of_term c with | Rel n -> print_string "#"; print_int n | Meta n -> print_string "Meta("; print_int n; print_string ")" | Var id -> print_string (Id.to_string id) | Sort s -> sort_display s | Cast (c,_, t) -> open_hovbox 1; print_string "("; (term_display c); print_cut(); print_string "::"; (term_display t); print_string ")"; close_box() | Prod (Name(id),t,c) -> open_hovbox 1; print_string"("; print_string (Id.to_string id); print_string ":"; box_display t; print_string ")"; print_cut(); box_display c; close_box() | Prod (Anonymous,t,c) -> print_string"("; box_display t; print_cut(); print_string "->"; box_display c; print_string ")"; | Lambda (na,t,c) -> print_string "["; name_display na; print_string ":"; box_display t; print_string "]"; print_cut(); box_display c; | LetIn (na,b,t,c) -> print_string "["; name_display na; print_string "="; box_display b; print_cut(); print_string ":"; box_display t; print_string "]"; print_cut(); box_display c; | App (c,l) -> print_string "("; box_display c; Array.iter (fun x -> print_space (); box_display x) l; print_string ")" | Evar (e,l) -> print_string "Evar#"; print_int (Evar.repr e); print_string "{"; Array.iter (fun x -> print_space (); box_display x) l; print_string"}" | Const (c,u) -> print_string "Cons("; sp_con_display c; print_string ","; universes_display u; print_string ")" | Proj (p,c') -> print_string "Proj("; sp_con_display (Projection.constant p); print_string ","; box_display c'; print_string ")" | Ind ((sp,i),u) -> print_string "Ind("; sp_display sp; print_string ","; print_int i; print_string ","; universes_display u; print_string ")" | Construct (((sp,i),j),u) -> print_string "Constr("; sp_display sp; print_string ","; print_int i; print_string ","; print_int j; print_string ","; universes_display u; print_string ")" | Case (ci,p,c,bl) -> open_vbox 0; print_string "<"; box_display p; print_string ">"; print_cut(); print_string "Case"; print_space(); box_display c; print_space (); print_string "of"; open_vbox 0; Array.iter (fun x -> print_cut(); box_display x) bl; close_box(); print_cut(); print_string "end"; close_box() | Fix ((t,i),(lna,tl,bl)) -> print_string "Fix("; print_int i; print_string ")"; print_cut(); open_vbox 0; let print_fix () = for k = 0 to (Array.length tl) - 1 do open_vbox 0; name_display lna.(k); print_string "/"; print_int t.(k); print_cut(); print_string ":"; box_display tl.(k) ; print_cut(); print_string ":="; box_display bl.(k); close_box (); print_cut() done in print_string"{"; print_fix(); print_string"}" | CoFix(i,(lna,tl,bl)) -> print_string "CoFix("; print_int i; print_string ")"; print_cut(); open_vbox 0; let print_fix () = for k = 0 to (Array.length tl) - 1 do open_vbox 1; name_display lna.(k); print_cut(); print_string ":"; box_display tl.(k) ; print_cut(); print_string ":="; box_display bl.(k); close_box (); print_cut(); done in print_string"{"; print_fix (); print_string"}" and box_display c = open_hovbox 1; term_display c; close_box() and universes_display u = Array.iter (fun u -> print_space (); pp (Level.pr u)) (Instance.to_array u) and sort_display = function | Prop(Pos) -> print_string "Set" | Prop(Null) -> print_string "Prop" | Type u -> open_hbox(); print_string "Type("; pp (pr_uni u); print_string ")"; close_box() and name_display = function | Name id -> print_string (Id.to_string id) | Anonymous -> print_string "_" (* Remove the top names for library and Scratch to avoid long names *) and sp_display sp = (* let dir,l = decode_kn sp in let ls = match List.rev_map Id.to_string (DirPath.repr dir) with ("Top"::l)-> l | ("Coq"::_::l) -> l | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) print_string (debug_string_of_mind sp) and sp_con_display sp = (* let dir,l = decode_kn sp in let ls = match List.rev_map Id.to_string (DirPath.repr dir) with ("Top"::l)-> l | ("Coq"::_::l) -> l | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) print_string (debug_string_of_con sp) in try box_display csr; print_flush() with e -> print_string (Printexc.to_string e);print_flush (); raise e let ppfconstr c = ppconstr (CClosure.term_of_fconstr c) let pploc x = let (l,r) = Loc.unloc x in print_string"(";print_int l;print_string",";print_int r;print_string")" let pp_argument_type t = pp (pr_argument_type t) let pp_generic_argument arg = pp(str"") let prgenarginfo arg = let Geninterp.Val.Dyn (tag, _) = arg in let tpe = Geninterp.Val.pr tag in (** FIXME *) (* try *) (* let data = Pptactic.pr_top_generic (Global.env ()) arg in *) (* str "" *) (* with _any -> *) str "" let ppgenarginfo arg = pp (prgenarginfo arg) let ppgenargargt arg = pp (str (Genarg.ArgT.repr arg)) let ppist ist = let pr id arg = prgenarginfo arg in pp (pridmap pr ist.Geninterp.lfun) (**********************************************************************) (* Vernac-level debugging commands *) let in_current_context f c = let (evmap,sign) = Pfedit.get_current_context () in f (fst (Constrintern.interp_constr sign evmap c))(*FIXME*) (* We expand the result of preprocessing to be independent of camlp4 VERNAC COMMAND EXTEND PrintPureConstr | [ "PrintPureConstr" constr(c) ] -> [ in_current_context print_pure_constr c ] END VERNAC COMMAND EXTEND PrintConstr [ "PrintConstr" constr(c) ] -> [ in_current_context constr_display c ] END *) open Pcoq open Genarg open Constrarg open Egramml let _ = try Vernacinterp.vinterp_add false ("PrintConstr", 0) (function [c] when genarg_tag c = unquote (topwit wit_constr) && true -> let c = out_gen (rawwit wit_constr) c in (fun () -> in_current_context constr_display c) | _ -> failwith "Vernac extension: cannot occur") with e -> pp (CErrors.print e) let _ = extend_vernac_command_grammar ("PrintConstr", 0) None [GramTerminal "PrintConstr"; GramNonTerminal (Loc.ghost,rawwit wit_constr,Extend.Aentry Pcoq.Constr.constr)] let _ = try Vernacinterp.vinterp_add false ("PrintPureConstr", 0) (function [c] when genarg_tag c = unquote (topwit wit_constr) && true -> let c = out_gen (rawwit wit_constr) c in (fun () -> in_current_context print_pure_constr c) | _ -> failwith "Vernac extension: cannot occur") with e -> pp (CErrors.print e) let _ = extend_vernac_command_grammar ("PrintPureConstr", 0) None [GramTerminal "PrintPureConstr"; GramNonTerminal (Loc.ghost,rawwit wit_constr,Extend.Aentry Pcoq.Constr.constr)] (* Setting printer of unbound global reference *) open Names open Libnames let encode_path loc prefix mpdir suffix id = let dir = match mpdir with | None -> [] | Some (mp,dir) -> (DirPath.repr (dirpath_of_string (string_of_mp mp))@ DirPath.repr dir) in Qualid (loc, make_qualid (DirPath.make (List.rev (Id.of_string prefix::dir@suffix))) id) let raw_string_of_ref loc _ = function | ConstRef cst -> let (mp,dir,id) = repr_con cst in encode_path loc "CST" (Some (mp,dir)) [] (Label.to_id id) | IndRef (kn,i) -> let (mp,dir,id) = repr_mind kn in encode_path loc "IND" (Some (mp,dir)) [Label.to_id id] (Id.of_string ("_"^string_of_int i)) | ConstructRef ((kn,i),j) -> let (mp,dir,id) = repr_mind kn in encode_path loc "CSTR" (Some (mp,dir)) [Label.to_id id;Id.of_string ("_"^string_of_int i)] (Id.of_string ("_"^string_of_int j)) | VarRef id -> encode_path loc "SECVAR" None [] id let short_string_of_ref loc _ = function | VarRef id -> Ident (loc,id) | ConstRef cst -> Ident (loc,Label.to_id (pi3 (repr_con cst))) | IndRef (kn,0) -> Ident (loc,Label.to_id (pi3 (repr_mind kn))) | IndRef (kn,i) -> encode_path loc "IND" None [Label.to_id (pi3 (repr_mind kn))] (Id.of_string ("_"^string_of_int i)) | ConstructRef ((kn,i),j) -> encode_path loc "CSTR" None [Label.to_id (pi3 (repr_mind kn));Id.of_string ("_"^string_of_int i)] (Id.of_string ("_"^string_of_int j)) (* Anticipate that printers can be used from ocamldebug and that pretty-printer should not make calls to the global env since ocamldebug runs in a different process and does not have the proper env at hand *) let _ = Flags.in_debugger := true let _ = Constrextern.set_extern_reference (if !rawdebug then raw_string_of_ref else short_string_of_ref) coq-8.6/dev/set_raw_db0000644000175000017500000000005013022274260014264 0ustar mdenesmdenesinstall_printer Top_printers.ppconstrdb coq-8.6/dev/tools/0000755000175000017500000000000013022274260013375 5ustar mdenesmdenescoq-8.6/dev/tools/objects.el0000644000175000017500000000757013022274260015361 0ustar mdenesmdenes(defun add-survive-module nil (interactive) (query-replace-regexp " \\([ ]*\\)\\(Summary\.\\)?survive_section" " \\1\\2survive_module = false; \\1\\2survive_section") ) (global-set-key [f2] 'add-survive-module) ; functions to change old style object declaration to new style (defun repl-open nil (interactive) (query-replace-regexp "open_function\\([ ]*\\)=\\([ ]*\\)cache_\\([a-zA-Z0-9'_]*\\)\\( *\\);" "open_function\\1=\\2(fun i o -> if i=1 then cache_\\3 o)\\4;") ) (global-set-key [f6] 'repl-open) (defun repl-load nil (interactive) (query-replace-regexp "load_function\\([ ]*\\)=\\([ ]*\\)cache_\\([a-zA-Z0-9'_]*\\)\\( *\\);" "load_function\\1=\\2(fun _ -> cache_\\3)\\4;") ) (global-set-key [f7] 'repl-load) (defun repl-decl nil (interactive) (query-replace-regexp "\\(Libobject\.\\)?declare_object[ ]*([ ]*\\(.*\\)[ ]*,[ ]* \\([ ]*\\){\\([ ]*\\)\\([^ ][^}]*\\)}[ ]*)" "\\1declare_object {(\\1default_object \\2) with \\3 \\4\\5}") ; "|$1=\\1|$2=\\2|$3=\\3|$4=\\4|") ) (global-set-key [f9] 'repl-decl) ; eval the above and try f9 f6 f7 on the following: let (inThing,outThing) = declare_object ("THING", { load_function = cache_thing; cache_function = cache_thing; open_function = cache_thing; export_function = (function x -> Some x) }) ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; functions helping writing non-copying substitutions (defun make-subst (name) (interactive "s") (defun f (l) (save-excursion (query-replace-regexp (concat "\\([a-zA-z_0-9]*\\)[ ]*:[ ]*" (car l) "\\([ ]*;\\|[ ]*\}\\)") (concat "let \\1\' = " (cdr l) " " name "\\1 in")) ) ) (mapcar 'f '(("constr"."subst_mps subst") ("Coqast.t"."subst_ast subst") ("Coqast.t list"."list_smartmap (subst_ast subst)") ("'pat"."subst_pat subst") ("'pat unparsing_hunk"."subst_hunk subst_pat subst") ("'pat unparsing_hunk list"."list_smartmap (subst_hunk subst_pat subst)") ("'pat syntax_entry"."subst_syntax_entry subst_pat subst") ("'pat syntax_entry list"."list_smartmap (subst_syntax_entry subst_pat subst)") ("constr option"."option_smartmap (subst_mps subst)") ("constr list"."list_smartmap (subst_mps subst)") ("constr array"."array_smartmap (subst_mps subst)") ("constr_pattern"."subst_pattern subst") ("constr_pattern option"."option_smartmap (subst_pattern subst)") ("constr_pattern array"."array_smartmap (subst_pattern subst)") ("constr_pattern list"."list_smartmap (subst_pattern subst)") ("global_reference"."subst_global subst") ("extended_global_reference"."subst_ext subst") ("obj_typ"."subst_obj subst") ) ) ) (global-set-key [f2] 'make-subst) (defun make-if (name) (interactive "s") (save-excursion (query-replace-regexp "\\([a-zA-z_0-9]*\\)[ ]*:[ ]*['a-zA-z_. ]*\\(;\\|[ ]*\}\\)" (concat "&& \\1\' == " name "\\1") ) ) ) (global-set-key [f4] 'make-if) (defun make-record nil (interactive) (save-excursion (query-replace-regexp "\\([a-zA-z_0-9]*\\)[ ]*:[ ]*['a-zA-z_. ]*\\(;\\|[ ]*\}\\)" (concat "\\1 = \\1\' ;") ) ) ) (global-set-key [f5] 'make-record) (defun make-prim nil (interactive) (save-excursion (query-replace-regexp "\\<[a-zA-Z'_0-9]*\\>" "\\&'")) ) (global-set-key [f6] 'make-prim) ; eval the above, yank the text below and do ; paste f2 morph. ; paste f4 morph. ; paste f5 lem : constr; profil : bool list; arg_types : constr list; lem2 : constr option } ; and you almost get Setoid_replace.subst_morph :) ; and now f5 on this: (ref,(c1,c2)) coq-8.6/dev/tools/Makefile.subdir0000644000175000017500000000040013022274260016316 0ustar mdenesmdenes# if you work in a sub/sub-rectory of Coq # you should make a link to that makefile # ln -s ../../dev/tools/Makefile.subdir Makefile # in order to have all the facilities of dev/tools/Makefile.dir TOPDIR=../.. include $(TOPDIR)/dev/tools/Makefile.dir coq-8.6/dev/tools/Makefile.devel0000644000175000017500000000351113022274260016133 0ustar mdenesmdenes# to be linked to makefile (lowercase - takes precedence over Makefile) # in main directory # make devel in main directory should do this for you. TOPDIR=. BASEDIR= SOURCEDIRS=lib kernel library pretyping parsing proofs tactics toplevel default: usage noargument usage:: @echo Usage: make \ @echo Targets are: usage:: @echo " setup-devel -- set the devel makefile" setup-devel: @ln -sfv dev/tools/Makefile.devel makefile @(for i in $(SOURCEDIRS); do \ (cd $(TOPDIR)/$$i; ln -sfv ../dev/tools/Makefile.dir Makefile) \ done) usage:: @echo " clean-devel -- clear all devel files" clean-devel: echo rm -f makefile .depend.devel echo rm -f $(foreach dir,$(SOURCEDIRS), $(TOPDIR)/$(dir)/Makefile) usage:: @echo " coqtop -- make until the bytecode executable, make the link" coqtop: bin/coqtop.byte ln -sf bin/coqtop.byte coqtop usage:: @echo " quick -- make bytecode executable and states" quick: $(MAKE) states BEST=byte include Makefile include $(TOPDIR)/dev/tools/Makefile.common # this file is better described in dev/tools/Makefile.dir include .depend.devel #if dev/tools/Makefile.local exists, it is included ifneq ($(wildcard $(TOPDIR)/dev/tools/Makefile.local),) include $(TOPDIR)/dev/tools/Makefile.local endif usage:: @echo " total -- runs coqtop with all theories required" total: ledit ./bin/coqtop.byte $(foreach th,$(THEORIESVO),-require $(notdir $(basename $(th)))) usage:: @echo " run -- makes and runs bytecode coqtop using ledit and the history file" @echo " if you want to pass arguments to coqtop, use make run ARG=" run: $(TOPDIR)/coqtop ledit -h $(TOPDIR)/dev/debug_history -x $(TOPDIR)/coqtop $(ARG) $(ARGS) usage:: @echo " vars -- echos commands to set COQTOP and COQBIN variables" vars: @(cd $(TOPDIR); \ echo export COQTOP=`pwd`/ ; \ echo export COQBIN=`pwd`/bin/ ) coq-8.6/dev/tools/anomaly-traces-parser.el0000644000175000017500000000245013022274260020131 0ustar mdenesmdenes;; This Elisp snippet adds a regexp parser for the format of Anomaly ;; backtraces (coqc -bt ...), to the error parser of the Compilation ;; mode (C-c C-c: "Compile command: ..."). Once the ;; coq-change-error-alist-for-backtraces function has run, file ;; locations in traces are recognized and can be jumped from easily ;; from the *compilation* buffer. ;; You can just copy everything below to your .emacs and this will be ;; enabled from any compilation command launched from an OCaml file. (defun coq-change-error-alist-for-backtraces () "Hook to change the compilation-error-regexp-alist variable, to search the coq backtraces for error locations" (interactive) (add-to-list 'compilation-error-regexp-alist-alist '(coq-backtrace "^ *\\(?:raise\\|frame\\) @ file \\(\"?\\)\\([^,\" \n\t<>]+\\)\\1,\ lines? \\([0-9]+\\)-?\\([0-9]+\\)?\\(?:$\\|,\ \\(?: characters? \\([0-9]+\\)-?\\([0-9]+\\)?:?\\)?\\)" 2 (3 . 4) (5 . 6))) (add-to-list 'compilation-error-regexp-alist 'coq-backtrace)) ;; this Anomaly parser should be available when one is hacking ;; on the *OCaml* code of Coq (adding bugs), so we enable it ;; through the OCaml mode hooks. (add-hook 'caml-mode-hook 'coq-change-error-alist-for-backtraces) (add-hook 'tuareg-mode-hook 'coq-change-error-alist-for-backtraces) coq-8.6/dev/tools/Makefile.dir0000644000175000017500000000617113022274260015617 0ustar mdenesmdenes# make a link to this file if you are working hard in one directory of Coq # ln -s ../dev/tools/Makefile.dir Makefile # if you are working in a sub/dir/ make a link to dev/tools/Makefile.subdir instead # this Makefile provides many useful facilities to develop Coq # it is not completely compatible with .ml4 files unfortunately ifndef TOPDIR TOPDIR=.. endif # this complicated thing should work for subsubdirs as well BASEDIR=$(shell (dir=`pwd`; cd $(TOPDIR); top=`pwd`; echo $$dir | sed -e "s|$$top/||")) noargs: dir test-dir: @echo TOPDIR=$(TOPDIR) @echo BASEDIR=$(BASEDIR) include $(TOPDIR)/dev/tools/Makefile.common # make this directory dir: $(MAKE) -C $(TOPDIR) $(notdir $(BASEDIR)) # make all cmo's in this directory. Useful in case the main Makefile is not # up-to-date all: @( ( for i in *.ml; do \ echo -n $(BASEDIR)/`basename $$i .ml`.cmo "" ; \ done; \ for i in *.ml4; do \ echo -n $(BASEDIR)/`basename $$i .ml4`.cmo "" ; \ done ) \ | xargs $(MAKE) -C $(TOPDIR) ) # lists all files that should be compiled in this directory list: @(for i in *.mli; do \ ls -l `basename $$i .mli`.cmi; \ done) @(for i in *.ml; do \ ls -l `basename $$i .ml`.cmo; \ done) @(for i in *.ml4; do \ ls -l `basename $$i .ml4`.cmo; \ done) clean:: rm -f *.cmi *.cmo *.cmx *.o # if grammar.cmo files cannot be compiled and main .depend cannot be # rebuilt, this is quite useful depend: (cd $(TOPDIR); ocamldep -I $(BASEDIR) $(BASEDIR)/*.ml $(BASEDIR)/*.mli > .depend.devel) # displays the dependency graph of the current directory (vertically, # unlike in doc/) graph: (ocamldep *.ml *.mli | ocamldot | dot -Tps | gv -) & # the pretty entry draws a dependency graph marking red those nodes # which do not have their .cmo files .INTERMEDIATE: depend.dot depend.2.dot .PHONY: depend.ps depend.dot: ocamldep *.ml *.mli | ocamldot > $@ depend.2.dot: depend.dot (i=`cat $< | wc -l`; i=`expr $$i - 1`; head -n $$i $<) > $@ (for ml in *.ml; do \ base=`basename $$ml .ml`; \ fst=`echo $$base | cut -c1 | tr [:lower:] [:upper:]`; \ rest=`echo $$base | cut -c2-`; \ name=`echo $$fst $$rest | tr -d " "`; \ cmo=$$base.cmo; \ if [ ! -e $$cmo ]; then \ echo \"$$name\" [color=red]\; >> $@;\ fi;\ done;\ echo } >> $@) depend.ps: depend.2.dot dot -Tps $< > $@ clean:: rm -f depend.ps pretty: depend.ps (gv -spartan $<; rm $<) & # gv -spartan $< & # generating file.ml.mli by tricking make to pass -i to ocamlc %.ml.mli: FORCE @(cmo=`basename $@ .ml.mli`.cmo ; \ mv -f $$cmo $$cmo.tmp ; \ $(MAKE) -s -C $(TOPDIR) $(BASEDIR)/$$cmo CAMLDEBUG=-i > $@ ; \ echo Generated interface file $@ ; \ mv -f $$cmo.tmp $$cmo) %.annot: FORCE @(cmo=`basename $@ .annot`.cmo ; \ mv -f $$cmo $$cmo.tmp ; \ $(MAKE) -s -C $(TOPDIR) $(BASEDIR)/$$cmo CAMLDEBUG=-dtypes ; \ echo Generated annotation file $@ ; \ mv -f $$cmo.tmp $$cmo) FORCE: clean:: rm -f *.ml.mli # this is not perfect but mostly WORKS! It just calls the main makefile %.cmi: FORCE $(MAKE) -C $(TOPDIR) $(BASEDIR)/$@ %.cmo: FORCE $(MAKE) -C $(TOPDIR) $(BASEDIR)/$@ coqtop: $(MAKE) -C $(TOPDIR) bin/coqtop.byte coq-8.6/dev/tools/change-header0000755000175000017500000000256413022274260016005 0ustar mdenesmdenes#!/bin/sh #This script changes the header of .ml* files if [ ! $# = 2 ]; then echo Usage: change-header old-header-file new-header-file exit 1 fi oldheader=$1 newheader=$2 if [ ! -f $oldheader ]; then echo Cannot read file $oldheader; exit 1; fi if [ ! -f $newheader ]; then echo Cannot read file $newheader; exit 1; fi n=`wc -l $oldheader | sed -e "s/ *\([0-9]*\).*/\1/g"` nsucc=`expr $n + 1` linea='(* -*- coding:utf-8 -*- *)' lineb='(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *)' modified=0 kept=0 for i in `find . -name \*.mli -o -name \*.ml -o -name \*.ml4 -o -name \*.mll -o -name \*.mly -o -name \*.mlp -o -name \*.v`; do headline=`head -n 1 $i` if `echo $headline | grep "(\* -\*- .* \*)" > /dev/null`; then # Has emacs header head -n +$nsucc $i | tail -n $n > $i.head.tmp$$ hasheadline=1 nnext=`expr $nsucc + 1` else head -n +$n $i > $i.head.tmp$$ hasheadline=0 nnext=$nsucc fi if diff -a -q $oldheader $i.head.tmp$$ > /dev/null; then echo "$i: header changed" if [ $hasheadline = 1 ]; then echo $headline > $i.tmp$$ else touch $i.tmp$$ fi cat $newheader >> $i.tmp$$ tail -n +$nnext $i >> $i.tmp$$ mv $i.tmp$$ $i modified=`expr $modified + 1` else kept=`expr $kept + 1` fi rm $i.head.tmp$$ done echo $modified files updated echo $kept files unchanged coq-8.6/dev/README0000644000175000017500000000362713022274260013125 0ustar mdenesmdenesThis directory contains informations and tools to help developing the Coq system ====================== Debugging and profiling (in current directory - see doc/debugging.txt) ----------------------- ocamldebug-coq: to launch ocaml debugger db: to install pretty-printers from ocaml debugger base_db: to install raw pretty-printers from ocaml debugger include: to install pretty-printers from ocaml toplevel base_include: to install raw pretty-printers from ocaml toplevel vm_printers.ml, dev_printers.ml: ML pretty-printers for debugging Miscellaneous informations about the code (directory doc) ----------------------------------------- changes.txt: (partial) per-version summary of the evolutions of Coq ML source style.txt: a few style recommendations for writing Coq ML files debugging.txt: help for debugging or profiling universes.txt: help to debug universes translate.txt: help to use coq translator extensions.txt: some help about TACTIC EXTEND header: standard header for Coq ML files perf-analysis: analysis of perfs measured on the compilation of user contribs cic.dtd: official dtd of the calc. of ind. constr. for im/ex-portation Documentation of ML interfaces using ocamldoc (directory ocamldoc/html) ---------------------------------------- "make mli-doc" in coq root directory. Other development tools (directory tools) ----------------------- Makefile.dir: makefile dedicated to intensive work in a given directory Makefile.subdir: makefile dedicated to intensive work in a given subdirectory Makefile.devel: utilities to automatically launch coq in various states Makefile.common: used by other Makefiles objects.el: various development utilities at emacs level anomaly-traces-parser.el: a .emacs-ready elisp snippet to parse location of Anomaly backtraces and jump to them conveniently from the Emacs *compilation* output. coq-8.6/dev/macosify_accel.sh0000755000175000017500000000016413022274260015536 0ustar mdenesmdenes#!/usr/bin/sed -f s/^;\{0,1\} *\(.*\)\(.*\)$/\1\2/ s/^;\{0,1\} *\(.*\)\(.*\)$/\1\2/ coq-8.6/dev/nsis/0000755000175000017500000000000013022274260013211 5ustar mdenesmdenescoq-8.6/dev/nsis/FileAssociation.nsh0000644000175000017500000001104613022274260017001 0ustar mdenesmdenes/* _____________________________________________________________________________ File Association _____________________________________________________________________________ Based on code taken from http://nsis.sourceforge.net/File_Association Usage in script: 1. !include "FileAssociation.nsh" 2. [Section|Function] ${FileAssociationFunction} "Param1" "Param2" "..." $var [SectionEnd|FunctionEnd] FileAssociationFunction=[RegisterExtension|UnRegisterExtension] _____________________________________________________________________________ ${RegisterExtension} "[executable]" "[extension]" "[description]" "[executable]" ; executable which opens the file format ; "[extension]" ; extension, which represents the file format to open ; "[description]" ; description for the extension. This will be display in Windows Explorer. ; ${UnRegisterExtension} "[extension]" "[description]" "[extension]" ; extension, which represents the file format to open ; "[description]" ; description for the extension. This will be display in Windows Explorer. ; _____________________________________________________________________________ Macros _____________________________________________________________________________ Change log window verbosity (default: 3=no script) Example: !include "FileAssociation.nsh" !insertmacro RegisterExtension ${FileAssociation_VERBOSE} 4 # all verbosity !insertmacro UnRegisterExtension ${FileAssociation_VERBOSE} 3 # no script */ !ifndef FileAssociation_INCLUDED !define FileAssociation_INCLUDED !include Util.nsh !verbose push !verbose 3 !ifndef _FileAssociation_VERBOSE !define _FileAssociation_VERBOSE 3 !endif !verbose ${_FileAssociation_VERBOSE} !define FileAssociation_VERBOSE `!insertmacro FileAssociation_VERBOSE` !verbose pop !macro FileAssociation_VERBOSE _VERBOSE !verbose push !verbose 3 !undef _FileAssociation_VERBOSE !define _FileAssociation_VERBOSE ${_VERBOSE} !verbose pop !macroend !macro RegisterExtensionCall _EXECUTABLE _EXTENSION _DESCRIPTION !verbose push !verbose ${_FileAssociation_VERBOSE} Push `${_DESCRIPTION}` Push `${_EXTENSION}` Push `${_EXECUTABLE}` ${CallArtificialFunction} RegisterExtension_ !verbose pop !macroend !macro UnRegisterExtensionCall _EXTENSION _DESCRIPTION !verbose push !verbose ${_FileAssociation_VERBOSE} Push `${_EXTENSION}` Push `${_DESCRIPTION}` ${CallArtificialFunction} UnRegisterExtension_ !verbose pop !macroend !define RegisterExtension `!insertmacro RegisterExtensionCall` !define un.RegisterExtension `!insertmacro RegisterExtensionCall` !macro RegisterExtension !macroend !macro un.RegisterExtension !macroend !macro RegisterExtension_ !verbose push !verbose ${_FileAssociation_VERBOSE} Exch $R2 ;exe Exch Exch $R1 ;ext Exch Exch 2 Exch $R0 ;desc Exch 2 Push $0 Push $1 ReadRegStr $1 HKCR $R1 "" ; read current file association StrCmp "$1" "" NoBackup ; is it empty StrCmp "$1" "$R0" NoBackup ; is it our own WriteRegStr HKCR $R1 "backup_val" "$1" ; backup current value NoBackup: WriteRegStr HKCR $R1 "" "$R0" ; set our file association ReadRegStr $0 HKCR $R0 "" StrCmp $0 "" 0 Skip WriteRegStr HKCR "$R0" "" "$R0" WriteRegStr HKCR "$R0\shell" "" "open" WriteRegStr HKCR "$R0\DefaultIcon" "" "$R2,0" Skip: WriteRegStr HKCR "$R0\shell\open\command" "" '"$R2" "%1"' WriteRegStr HKCR "$R0\shell\edit" "" "Edit $R0" WriteRegStr HKCR "$R0\shell\edit\command" "" '"$R2" "%1"' Pop $1 Pop $0 Pop $R2 Pop $R1 Pop $R0 !verbose pop !macroend !define UnRegisterExtension `!insertmacro UnRegisterExtensionCall` !define un.UnRegisterExtension `!insertmacro UnRegisterExtensionCall` !macro UnRegisterExtension !macroend !macro un.UnRegisterExtension !macroend !macro UnRegisterExtension_ !verbose push !verbose ${_FileAssociation_VERBOSE} Exch $R1 ;desc Exch Exch $R0 ;ext Exch Push $0 Push $1 ReadRegStr $1 HKCR $R0 "" StrCmp $1 $R1 0 NoOwn ; only do this if we own it ReadRegStr $1 HKCR $R0 "backup_val" StrCmp $1 "" 0 Restore ; if backup="" then delete the whole key DeleteRegKey HKCR $R0 Goto NoOwn Restore: WriteRegStr HKCR $R0 "" $1 DeleteRegValue HKCR $R0 "backup_val" DeleteRegKey HKCR $R1 ;Delete key with association name settings NoOwn: Pop $1 Pop $0 Pop $R1 Pop $R0 !verbose pop !macroend !endif # !FileAssociation_INCLUDEDcoq-8.6/dev/nsis/coq.nsi0000755000175000017500000001514413022274260014516 0ustar mdenesmdenes; This script is used to build the Windows install program for Coq. ;NSIS Modern User Interface ;Written by Joost Verburg ;Modified by Julien Narboux and Pierre Letouzey and Enrico Tassi ;SetCompress off SetCompressor lzma ; Comment out after debuging. ; The VERSION should be passed as an argument at compile time using : ; !define MY_PRODUCT "Coq" ;Define your own software name here !define COQ_SRC_PATH "..\.." !define OUTFILE "coq-installer-${VERSION}-${ARCH}.exe" !include "MUI2.nsh" !include "FileAssociation.nsh" ;-------------------------------- ;Configuration Name "Coq" ;General OutFile "${OUTFILE}" ;Folder selection page InstallDir "C:\${MY_PRODUCT}" ;Remember install folder InstallDirRegKey HKCU "Software\${MY_PRODUCT}" "" ;-------------------------------- ;Modern UI Configuration !insertmacro MUI_PAGE_WELCOME !insertmacro MUI_PAGE_LICENSE "${COQ_SRC_PATH}/LICENSE" !insertmacro MUI_PAGE_COMPONENTS !define MUI_DIRECTORYPAGE_TEXT_TOP "Select where to install Coq. The path MUST NOT include spaces." !insertmacro MUI_PAGE_DIRECTORY !insertmacro MUI_PAGE_INSTFILES !insertmacro MUI_PAGE_FINISH !insertmacro MUI_UNPAGE_WELCOME !insertmacro MUI_UNPAGE_CONFIRM !insertmacro MUI_UNPAGE_INSTFILES !insertmacro MUI_UNPAGE_FINISH ;-------------------------------- ;Languages !insertmacro MUI_LANGUAGE "English" ;-------------------------------- ;Language Strings ;Description LangString DESC_1 ${LANG_ENGLISH} "This package contains Coq and CoqIDE." LangString DESC_2 ${LANG_ENGLISH} "This package contains the development files needed in order to build a plugin for Coq." ;-------------------------------- ; Check for white spaces Function .onVerifyInstDir StrLen $0 "$INSTDIR" StrCpy $1 0 ${While} $1 < $0 StrCpy $3 $INSTDIR 1 $1 StrCmp $3 " " SpacesInPath IntOp $1 $1 + 1 ${EndWhile} Goto done SpacesInPath: Abort done: FunctionEnd ;-------------------------------- ;Installer Sections Section "Coq" Sec1 SetOutPath "$INSTDIR\" File ${COQ_SRC_PATH}\LICENSE SetOutPath "$INSTDIR\bin" File ${COQ_SRC_PATH}\bin\*.exe ; make.exe and its dll File ${COQ_SRC_PATH}\bin\make.exe File ${COQ_SRC_PATH}\bin\libiconv2.dll File ${COQ_SRC_PATH}\bin\libintl3.dll SetOutPath "$INSTDIR\lib\theories" File /r ${COQ_SRC_PATH}\theories\*.vo File /r ${COQ_SRC_PATH}\theories\*.v File /r ${COQ_SRC_PATH}\theories\*.glob ; File /r ${COQ_SRC_PATH}\theories\*.cmi ; File /r ${COQ_SRC_PATH}\theories\*.cmxs SetOutPath "$INSTDIR\lib\plugins" File /r ${COQ_SRC_PATH}\plugins\*.vo File /r ${COQ_SRC_PATH}\plugins\*.v File /r ${COQ_SRC_PATH}\plugins\*.glob File /r ${COQ_SRC_PATH}\plugins\*.cmi File /r ${COQ_SRC_PATH}\plugins\*.cmxs SetOutPath "$INSTDIR\lib\tools\coqdoc" File ${COQ_SRC_PATH}\tools\coqdoc\coqdoc.sty File ${COQ_SRC_PATH}\tools\coqdoc\coqdoc.css SetOutPath "$INSTDIR\emacs" File ${COQ_SRC_PATH}\tools\*.el SetOutPath "$INSTDIR\man" File ${COQ_SRC_PATH}\man\*.1 SetOutPath "$INSTDIR\lib\toploop" File ${COQ_SRC_PATH}\stm\*top.cmxs File ${COQ_SRC_PATH}\ide\*top.cmxs ; CoqIDE SetOutPath "$INSTDIR\ide\" File ${COQ_SRC_PATH}\ide\*.png SetOutPath "$INSTDIR\share\gtksourceview-2.0\language-specs\" File ${COQ_SRC_PATH}\ide\*.lang File ${COQ_SRC_PATH}\ide\*.xml ; Start Menu Entries SetOutPath "$INSTDIR" CreateShortCut "$SMPROGRAMS\Coq\CoqIde.lnk" "$INSTDIR\bin\coqide.exe" ${registerExtension} "$INSTDIR\bin\coqide.exe" ".v" "Coq Script File" SetOutPath "$INSTDIR" File /r ${GTK_RUNTIME}\etc\gtk-2.0 SetOutPath "$INSTDIR\bin" File ${GTK_RUNTIME}\bin\*.dll SetOutPath "$INSTDIR\lib" File /r ${GTK_RUNTIME}\lib\gtk-2.0 ${GTK_RUNTIME}\lib\glib-2.0 SetOutPath "$INSTDIR\share" File /r ${GTK_RUNTIME}\share\themes File /r ${GTK_RUNTIME}\share\gtksourceview-2.0 ;Store install folder WriteRegStr HKCU "Software\${MY_PRODUCT}" "" $INSTDIR ;Create uninstaller WriteUninstaller "$INSTDIR\Uninstall.exe" WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ "DisplayName" "Coq Version ${VERSION}" WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ "UninstallString" '"$INSTDIR\Uninstall.exe"' WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ "DisplayVersion" "${VERSION}" WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ "NoModify" "1" WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ "NoRepair" "1" WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ "URLInfoAbout" "http://coq.inria.fr" ; Start Menu Entries ; for the path in the .lnk SetOutPath "$INSTDIR" CreateDirectory "$SMPROGRAMS\Coq" CreateShortCut "$SMPROGRAMS\Coq\Coq.lnk" "$INSTDIR\bin\coqtop.exe" WriteINIStr "$SMPROGRAMS\Coq\The Coq HomePage.url" "InternetShortcut" "URL" "http://coq.inria.fr" WriteINIStr "$SMPROGRAMS\Coq\The Coq Standard Library.url" "InternetShortcut" "URL" "http://coq.inria.fr/library" CreateShortCut "$SMPROGRAMS\Coq\Uninstall.lnk" "$INSTDIR\Uninstall.exe" "" "$INSTDIR\Uninstall.exe" 0 SectionEnd Section "Coq files for plugin developers" Sec2 SetOutPath "$INSTDIR\lib\" File /r ${COQ_SRC_PATH}\*.cmxa File /r ${COQ_SRC_PATH}\*.cmi File /r ${COQ_SRC_PATH}\*.cma File /r ${COQ_SRC_PATH}\*.cmo File /r ${COQ_SRC_PATH}\*.a File /r ${COQ_SRC_PATH}\*.o SectionEnd ;-------------------------------- ;Descriptions !insertmacro MUI_FUNCTION_DESCRIPTION_BEGIN !insertmacro MUI_DESCRIPTION_TEXT ${Sec1} $(DESC_1) !insertmacro MUI_DESCRIPTION_TEXT ${Sec2} $(DESC_2) !insertmacro MUI_FUNCTION_DESCRIPTION_END ;-------------------------------- ;Uninstaller Section Section "Uninstall" RMDir /r "$INSTDIR\bin" RMDir /r "$INSTDIR\dev" RMDir /r "$INSTDIR\etc" RMDir /r "$INSTDIR\lib" RMDir /r "$INSTDIR\share" RMDir /r "$INSTDIR\ide" Delete "$INSTDIR\man\*.1" RMDir "$INSTDIR\man" Delete "$INSTDIR\emacs\*.el" RMDir "$INSTDIR\emacs" ;; Start Menu Delete "$SMPROGRAMS\Coq\Coq.lnk" Delete "$SMPROGRAMS\Coq\CoqIde.lnk" Delete "$SMPROGRAMS\Coq\Uninstall.lnk" Delete "$SMPROGRAMS\Coq\The Coq HomePage.url" Delete "$SMPROGRAMS\Coq\The Coq Standard Library.url" Delete "$INSTDIR\Uninstall.exe" DeleteRegKey /ifempty HKCU "Software\${MY_PRODUCT}" DeleteRegKey HKEY_LOCAL_MACHINE "SOFTWARE\Coq" DeleteRegKey HKEY_LOCAL_MACHINE "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\Coq" RMDir "$INSTDIR" RMDir "$SMPROGRAMS\Coq" ${unregisterExtension} ".v" "Coq Script File" SectionEnd coq-8.6/dev/db0000644000175000017500000000407413022274260012552 0ustar mdenesmdenesload_printer "printers.cma" install_printer Top_printers.ppfuture install_printer Top_printers.ppid install_printer Top_printers.ppidset install_printer Top_printers.ppevar install_printer Top_printers.ppevarsubst install_printer Top_printers.ppexistentialfilter install_printer Top_printers.ppexistentialset install_printer Top_printers.ppintset install_printer Top_printers.pplab install_printer Top_printers.ppdir install_printer Top_printers.ppmbid install_printer Top_printers.ppmp install_printer Top_printers.ppkn install_printer Top_printers.ppcon install_printer Top_printers.ppwf_paths install_printer Top_printers.ppmind install_printer Top_printers.ppsp install_printer Top_printers.ppqualid install_printer Top_printers.ppclindex install_printer Top_printers.ppbigint install_printer Top_printers.pp_transparent_state install_printer Top_printers.pppattern install_printer Top_printers.ppglob_constr install_printer Top_printers.ppconstr install_printer Top_printers.ppuni install_printer Top_printers.ppuniverses install_printer Top_printers.ppconstraints install_printer Top_printers.pptype install_printer Top_printers.ppj install_printer Top_printers.ppenv install_printer Top_printers.ppnamedcontextval install_printer Top_printers.pp_stack_t install_printer Top_printers.pp_cst_stack_t install_printer Top_printers.ppmetas install_printer Top_printers.ppevm install_printer Top_printers.ppgoalgoal install_printer Top_printers.ppgoal install_printer Top_printers.ppproofview install_printer Top_printers.pphintdb install_printer Top_printers.pptac install_printer Top_printers.ppobj install_printer Top_printers.pploc install_printer Top_printers.prsubst install_printer Top_printers.prdelta install_printer Top_printers.ppfconstr install_printer Top_printers.ppgenarginfo install_printer Top_printers.ppgenargargt install_printer Top_printers.ppist install_printer Top_printers.ppconstrunderbindersidmap install_printer Top_printers.ppunbound_ltac_var_map install_printer Top_printers.ppididmap install_printer Top_printers.ppclosure install_printer Top_printers.ppclosedglobconstr coq-8.6/dev/base_db0000644000175000017500000000025713022274260013543 0ustar mdenesmdenesload_printer "gramlib.cma" load_printer "top_printers.cmo" install_printer Top_printers.prid install_printer Top_printers.prsp install_printer Top_printers.print_pure_constr coq-8.6/dev/ocamldebug-coq.run0000644000175000017500000000302213022274260015642 0ustar mdenesmdenes#!/bin/sh # Wrapper around ocamldebug for Coq # This file is to be launched via the generated script ocamldebug-coq, # which will set the env variables $OCAMLDEBUG, $CAMLP4LIB, $COQTOP # Anyway, just in case someone tries to use this script directly, # here are some reasonable default values [ -z "$OCAMLDEBUG" ] && OCAMLDEBUG=ocamldebug [ -z "$CAMLP4LIB" ] && CAMLP4LIB=+camlp5 [ -z "$COQTOP" -a -d "$PWD/kernel" ] && COQTOP=$PWD [ -z "$COQTOP" -a -d "$PWD/../kernel" ] && COQTOP=`dirname $PWD` exec $OCAMLDEBUG \ -I $CAMLP4LIB \ -I $COQTOP \ -I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar \ -I $COQTOP/lib -I $COQTOP/intf -I $COQTOP/kernel \ -I $COQTOP/library -I $COQTOP/engine \ -I $COQTOP/pretyping -I $COQTOP/parsing \ -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \ -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config -I $COQTOP/ltac \ -I $COQTOP/plugins/cc -I $COQTOP/plugins/dp \ -I $COQTOP/plugins/extraction -I $COQTOP/plugins/field \ -I $COQTOP/plugins/firstorder -I $COQTOP/plugins/fourier \ -I $COQTOP/plugins/funind -I $COQTOP/plugins/groebner \ -I $COQTOP/plugins/interface -I $COQTOP/plugins/micromega \ -I $COQTOP/plugins/omega -I $COQTOP/plugins/quote \ -I $COQTOP/plugins/ring -I $COQTOP/plugins/romega \ -I $COQTOP/plugins/rtauto -I $COQTOP/plugins/setoid_ring \ -I $COQTOP/plugins/subtac -I $COQTOP/plugins/syntax \ -I $COQTOP/plugins/xml \ -I $COQTOP/ide \ "$@" coq-8.6/dev/db_printers.ml0000644000175000017500000000125113022274260015101 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* $DMGDIR/.padding hdiutil create -imagekey zlib-level=9 -volname CoqIDE_$VERSION -srcfolder $DMGDIR -ov -format UDZO CoqIDE_$VERSION.dmg coq-8.6/dev/build/windows/0000755000175000017500000000000013022274260015026 5ustar mdenesmdenescoq-8.6/dev/build/windows/MakeCoq_regtest_noproxy.bat0000644000175000017500000000053013022274260022367 0ustar mdenesmdenescall MakeCoq_SetRootPath SET HTTP_PROXY= EXPORT HTTP_PROXY= MKDIR C:\Temp\srccache call MakeCoq_MinGW.bat ^ -arch=64 ^ -mode=absolute ^ -ocaml=Y ^ -make=Y ^ -coqver 8.5pl2 ^ -srccache C:\Temp\srccache ^ -cygquiet=Y ^ -destcyg %ROOTPATH%\cygwin_coq64_85pl2_abs ^ -destcoq %ROOTPATH%\coq64_85pl2_abs pausecoq-8.6/dev/build/windows/MakeCoq_MinGW.bat0000644000175000017500000002663513022274260020113 0ustar mdenesmdenes@ECHO OFF REM ========== COPYRIGHT/COPYLEFT ========== REM (C) 2016 Intel Deutschland GmbH REM Author: Michael Soegtrop REM Released to the public by Intel under the REM GNU Lesser General Public License Version 2.1 or later REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html REM ========== NOTES ========== REM For Cygwin setup command line options REM see https://cygwin.com/faq/faq.html#faq.setup.cli REM ========== DEFAULT VALUES FOR PARAMETERS ========== REM For a description of all parameters, see ReadMe.txt SET BATCHFILE=%0 SET BATCHDIR=%~dp0 REM see -arch in ReadMe.txt, but values are x86_64 or i686 (not 64 or 32) SET ARCH=x86_64 REM see -mode in ReadMe.txt SET INSTALLMODE=absolute REM see -installer in ReadMe.txt SET MAKEINSTALLER=N REM see -ocaml in ReadMe.txt SET INSTALLOCAML=N REM see -make in ReadMe.txt SET INSTALLMAKE=Y REM see -destcyg in ReadMe.txt SET DESTCYG=C:\bin\cygwin_coq REM see -destcoq in ReadMe.txt SET DESTCOQ=C:\bin\coq REM see -setup in ReadMe.txt SET SETUP=setup-x86_64.exe REM see -proxy in ReadMe.txt IF DEFINED HTTP_PROXY ( SET PROXY="%HTTP_PROXY:http://=%" ) else ( SET PROXY="" ) REM see -cygrepo in ReadMe.txt SET CYGWIN_REPOSITORY=http://ftp.inf.tu-dresden.de/software/windows/cygwin32 REM see -cygcache in ReadMe.txt SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache REM see -cyglocal in ReadMe.txt SET CYGWIN_FROM_CACHE=N REM see -cygquiet in ReadMe.txt SET CYGWIN_QUIET=Y REM see -srccache in ReadMe.txt SET SOURCE_LOCAL_CACHE_WFMT=%BATCHDIR%source_cache REM see -coqver in ReadMe.txt SET COQ_VERSION=8.5pl3 REM see -gtksrc in ReadMe.txt SET GTK_FROM_SOURCES=N REM see -threads in ReadMe.txt SET MAKE_THREADS=8 REM ========== PARSE COMMAND LINE PARAMETERS ========== SHIFT :Parse IF "%0" == "-arch" ( IF "%1" == "32" ( SET ARCH=i686 SET SETUP=setup-x86.exe ) ELSE ( IF "%1" == "64" ( SET ARCH=x86_64 SET SETUP=setup-x86_64.exe ) ELSE ( ECHO "Invalid -arch, valid are 32 and 64" GOTO :EOF ) ) SHIFT SHIFT GOTO Parse ) IF "%0" == "-mode" ( IF "%1" == "mingwincygwin" ( SET INSTALLMODE=%1 ) ELSE ( IF "%1" == "absolute" ( SET INSTALLMODE=%1 ) ELSE ( IF "%1" == "relocatable" ( SET INSTALLMODE=%1 ) ELSE ( ECHO "Invalid -mode, valid are mingwincygwin, absolute and relocatable" GOTO :EOF ) ) ) SHIFT SHIFT GOTO Parse ) IF "%0" == "-installer" ( SET MAKEINSTALLER=%1 SHIFT SHIFT GOTO Parse ) IF "%0" == "-ocaml" ( SET INSTALLOCAML=%1 SHIFT SHIFT GOTO Parse ) IF "%0" == "-make" ( SET INSTALLMAKE=%1 SHIFT SHIFT GOTO Parse ) IF "%0" == "-destcyg" ( SET DESTCYG=%1 SHIFT SHIFT GOTO Parse ) IF "%0" == "-destcoq" ( SET DESTCOQ=%1 SHIFT SHIFT GOTO Parse ) IF "%0" == "-setup" ( SET SETUP=%1 SHIFT SHIFT GOTO Parse ) IF "%0" == "-proxy" ( SET PROXY="%1" SHIFT SHIFT GOTO Parse ) IF "%0" == "-cygrepo" ( SET CYGWIN_REPOSITORY="%1" SHIFT SHIFT GOTO Parse ) IF "%0" == "-cygcache" ( SET CYGWIN_LOCAL_CACHE_WFMT="%1" SHIFT SHIFT GOTO Parse ) IF "%0" == "-cyglocal" ( SET CYGWIN_FROM_CACHE=%1 SHIFT SHIFT GOTO Parse ) IF "%0" == "-cygquiet" ( SET CYGWIN_QUIET=%1 SHIFT SHIFT GOTO Parse ) IF "%0" == "-srccache" ( SET SOURCE_LOCAL_CACHE_WFMT="%1" SHIFT SHIFT GOTO Parse ) IF "%0" == "-coqver" ( SET COQ_VERSION=%1 SHIFT SHIFT GOTO Parse ) IF "%0" == "-gtksrc" ( SET GTK_FROM_SOURCES=%1 SHIFT SHIFT GOTO Parse ) IF "%0" == "-threads" ( SET MAKE_THREADS=%1 SHIFT SHIFT GOTO Parse ) IF NOT "%0" == "" ( ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW ECHO !!! Illegal parameter %0 ECHO Usage: ECHO MakeCoq_MinGW CALL :PrintPars goto :EOF ) IF NOT EXIST %SETUP% ( ECHO The cygwin setup program %SETUP% doesn't exist. You must download it from https://cygwin.com/install.html. GOTO :EOF ) REM ========== ADJUST PARAMETERS ========== IF "%INSTALLMODE%" == "mingwincygwin" ( SET DESTCOQ=%DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw ) IF "%MAKEINSTALLER%" == "Y" ( SET INSTALLMODE=relocatable SET INSTALLOCAML=Y SET INSTALLMAKE=Y ) REM ========== CONFIRM PARAMETERS ========== CALL :PrintPars REM Note: DOS batch replaces variables on parsing, so one can't use a variable just set in an () block IF "%COQREGTESTING%"=="Y" (GOTO :DontAsk) SET /p ANSWER=Is this correct? y/n IF NOT "%ANSWER%"=="y" (GOTO :EOF) :DontAsk REM ========== DERIVED VARIABLES ========== SET CYGWIN_INSTALLDIR_WFMT=%DESTCYG% SET RESULT_INSTALLDIR_WFMT=%DESTCOQ% SET TARGET_ARCH=%ARCH%-w64-mingw32 SET BASH=%CYGWIN_INSTALLDIR_WFMT%\bin\bash REM Convert pathes to various formats REM WFMT = windows format (C:\..) Used in this batch file. REM CFMT = cygwin format (\cygdrive\c\..) Used for Cygwin PATH varible, which is : separated, so C: doesn't work. REM MFMT = MinGW format (C:/...) Used for the build, because \\ requires escaping. Mingw can handle \ and /. SET CYGWIN_INSTALLDIR_MFMT=%CYGWIN_INSTALLDIR_WFMT:\=/% SET RESULT_INSTALLDIR_MFMT=%RESULT_INSTALLDIR_WFMT:\=/% SET SOURCE_LOCAL_CACHE_MFMT=%SOURCE_LOCAL_CACHE_WFMT:\=/% SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_MFMT:C:/=/cygdrive/c/% SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_MFMT:C:/=/cygdrive/c/% SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_MFMT:C:/=/cygdrive/c/% SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:D:/=/cygdrive/d/% SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:D:/=/cygdrive/d/% SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:D:/=/cygdrive/d/% SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:E:/=/cygdrive/e/% SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:E:/=/cygdrive/e/% SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:E:/=/cygdrive/e/% ECHO CYGWIN INSTALL DIR (WIN) = %CYGWIN_INSTALLDIR_WFMT% ECHO CYGWIN INSTALL DIR (MINGW) = %CYGWIN_INSTALLDIR_MFMT% ECHO CYGWIN INSTALL DIR (CYGWIN) = %CYGWIN_INSTALLDIR_CFMT% ECHO RESULT INSTALL DIR (WIN) = %RESULT_INSTALLDIR_WFMT% ECHO RESULT INSTALL DIR (MINGW) = %RESULT_INSTALLDIR_MFMT% ECHO RESULT INSTALL DIR (CYGWIN) = %RESULT_INSTALLDIR_CFMT% REM WARNING: Add a space after the = in case you want set this to empty, otherwise the variable will be unset SET MAKE_OPT=-j %MAKE_THREADS% REM ========== DERIVED CYGWIN SETUP OPTIONS ========== REM WARNING: Add a space after the = otherwise the variable will be unset SET CYGWIN_OPT= IF "%CYGWIN_FROM_CACHE%" == "Y" ( SET CYGWIN_OPT= %CYGWIN_OPT% -L ) IF "%CYGWIN_QUIET%" == "Y" ( SET CYGWIN_OPT= %CYGWIN_OPT% -q --no-admin ) IF "%GTK_FROM_SOURCES%"=="N" ( SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk2.0,mingw64-%ARCH%-gtksourceview2.0 ) ECHO ========== INSTALL CYGWIN ========== REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES. REM Otherwise chmod won't work and e.g. the ocaml build will fail. REM Cygwin setup does not touch the ACLs of existing folders. REM => Create the setup log in a temporary location and move it later. REM Get Unique temporary file name :logfileloop SET LOGFILE=%TEMP%\CygwinSetUp%RANDOM%-%RANDOM%-%RANDOM%-%RANDOM%.log if exist "%LOGFILE%" goto :logfileloop REM Run Cygwin Setup SET RUNSETUP=Y IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" ( SET RUNSETUP=N ) IF NOT "%CYGWIN_QUIET%" == "Y" ( SET RUNSETUP=Y ) IF "%RUNSETUP%"=="Y" ( %SETUP% ^ --proxy %PROXY% ^ --site %CYGWIN_REPOSITORY% ^ --root %CYGWIN_INSTALLDIR_WFMT% ^ --local-package-dir %CYGWIN_LOCAL_CACHE_WFMT% ^ --no-shortcuts ^ %CYGWIN_OPT% ^ -P wget,curl,git,make,unzip ^ -P gcc-core,gcc-g++ ^ -P gdb,liblzma5 ^ -P patch,automake1.14,automake1.15 ^ -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-pkg-config,mingw64-%ARCH%-windows_default_manifest ^ -P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^ -P libiconv-devel,libunistring-devel,libncurses-devel ^ -P gettext-devel,libgettextpo-devel ^ -P libglib2.0-devel,libgdk_pixbuf2.0-devel ^ -P libfontconfig1 ^ -P gtk-update-icon-cache ^ -P libtool,automake ^ -P intltool ^ > "%LOGFILE%" ^ || GOTO :Error MKDIR %CYGWIN_INSTALLDIR_WFMT%\build MKDIR %CYGWIN_INSTALLDIR_WFMT%\build\buildlogs MOVE "%LOGFILE%" %CYGWIN_INSTALLDIR_WFMT%\build\buildlogs\cygwinsetup.log || GOTO :Error ) IF NOT "%CYGWIN_QUIET%" == "Y" ( REM Like most setup programs, cygwin setup starts the real setup as a separate process, so wait for it. REM This is not required with the -cygquiet=Y and the resulting --no-admin option. :waitsetup tasklist /fi "imagename eq %SETUP%" | find ":" > NUL IF ERRORLEVEL 1 GOTO waitsetup ) ECHO ========== CONFIGURE CYGWIN USER ACCOUNT ========== copy %BATCHDIR%\configure_profile.sh %CYGWIN_INSTALLDIR_WFMT%\var\tmp || GOTO :Error %BASH% --login %CYGWIN_INSTALLDIR_CFMT%\var\tmp\configure_profile.sh %PROXY% || GOTO :Error ECHO ========== BUILD COQ ========== MKDIR %CYGWIN_INSTALLDIR_WFMT%\build MKDIR %CYGWIN_INSTALLDIR_WFMT%\build\patches COPY %BATCHDIR%\makecoq_mingw.sh %CYGWIN_INSTALLDIR_WFMT%\build || GOTO :Error COPY %BATCHDIR%\patches_coq\*.* %CYGWIN_INSTALLDIR_WFMT%\build\patches || GOTO :Error %BASH% --login %CYGWIN_INSTALLDIR_CFMT%\build\makecoq_mingw.sh || GOTO :Error ECHO ========== FINISHED ========== GOTO :EOF ECHO ========== BATCH FUNCTIONS ========== :PrintPars REM 01234567890123456789012345678901234567890123456789012345678901234567890123456789 ECHO -arch ^ Set cygwin, ocaml and coq to 32 or 64 bit ECHO -mode ^ ECHO ^ ECHO ^ ECHO -installer^ create a windows installer (will be in /build/coq/dev/nsis) ECHO -ocaml ^ install OCaml in Coq folder (Y) or just in cygwin folder (N) ECHO -make ^ install GNU Make in Coq folder (Y) or not (N) ECHO -destcyg ^ ECHO -destcoq ^ ECHO -setup ^ (auto adjusted to -arch) ECHO -proxy ^ ECHO -cygrepo ^ ECHO -cygcache ^ ECHO -cyglocal ^ install cygwin from cache ECHO -cygquiet ^ install cygwin without user interaction ECHO -srccache ^ ECHO -coqver ^ ECHO -gtksrc ^ build GTK ^(90 min^) or use cygwin version ECHO -threads ^<1..N^> Number of make threads ECHO( ECHO See ReadMe.txt for a detailed description of all parameters ECHO( ECHO Parameter values (default or currently set): ECHO -arch = %ARCH% ECHO -mode = %INSTALLMODE% ECHO -ocaml = %INSTALLOCAML% ECHO -installer= %MAKEINSTALLER% ECHO -make = %INSTALLMAKE% ECHO -destcyg = %DESTCYG% ECHO -destcoq = %DESTCOQ% ECHO -setup = %SETUP% ECHO -proxy = %PROXY% ECHO -cygrepo = %CYGWIN_REPOSITORY% ECHO -cygcache = %CYGWIN_LOCAL_CACHE_WFMT% ECHO -cyglocal = %CYGWIN_FROM_CACHE% ECHO -cygquiet = %CYGWIN_QUIET% ECHO -srccache = %SOURCE_LOCAL_CACHE_WFMT% ECHO -coqver = %COQ_VERSION% ECHO -gtksrc = %GTK_FROM_SOURCES% ECHO -threads = %MAKE_THREADS% GOTO :EOF :Error ECHO Building Coq failed with error code %errorlevel% EXIT /b %errorlevel% coq-8.6/dev/build/windows/MakeCoq_86git_abs_ocaml.bat0000644000175000017500000000034013022274260022054 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -mode=absolute ^ -ocaml=Y ^ -make=Y ^ -coqver=git-v8.6 ^ -destcyg=%ROOTPATH%\cygwin_coq64_86git_abs ^ -destcoq=%ROOTPATH%\coq64_86git_abs coq-8.6/dev/build/windows/MakeCoq_86beta1_installer.bat0000644000175000017500000000031113022274260022340 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -installer=Y ^ -coqver=8.6beta1 ^ -destcyg=%ROOTPATH%\cygwin_coq64_86beta1_inst ^ -destcoq=%ROOTPATH%\coq64_86beta1_inst coq-8.6/dev/build/windows/MakeCoq_86_abs_ocaml.bat0000644000175000017500000000032513022274260021353 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -mode=absolute ^ -ocaml=Y ^ -make=Y ^ -coqver=8.6 ^ -destcyg=%ROOTPATH%\cygwin_coq64_86_abs ^ -destcoq=%ROOTPATH%\coq64_86_abs coq-8.6/dev/build/windows/MakeCoq_86beta1_installer_32.bat0000644000175000017500000000031113022274260022644 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=32 ^ -installer=Y ^ -coqver=8.6beta1 ^ -destcyg=%ROOTPATH%\cygwin_coq32_86beta1_inst ^ -destcoq=%ROOTPATH%\coq32_86beta1_inst coq-8.6/dev/build/windows/patches_coq/0000755000175000017500000000000013022274260017317 5ustar mdenesmdenescoq-8.6/dev/build/windows/patches_coq/coq-8.4pl2.patch0000644000175000017500000000102413022274260022044 0ustar mdenesmdenes--- configure 2014-04-14 22:28:39.174177924 +0200 +++ configure 2014-04-14 22:29:23.253025166 +0200 @@ -335,7 +335,7 @@ MAKEVERSION=`$MAKE -v | head -1 | cut -d" " -f3` MAKEVERSIONMAJOR=`echo $MAKEVERSION | cut -d. -f1` MAKEVERSIONMINOR=`echo $MAKEVERSION | cut -d. -f2` - if [ "$MAKEVERSIONMAJOR" -eq 3 -a "$MAKEVERSIONMINOR" -ge 81 ]; then + if [ "$MAKEVERSIONMAJOR" -eq 3 -a "$MAKEVERSIONMINOR" -ge 81 ] || [ "$MAKEVERSIONMAJOR" -ge 4 ] ; then echo "You have GNU Make $MAKEVERSION. Good!" else OK="no"coq-8.6/dev/build/windows/patches_coq/ReplaceInFile.nsh0000644000175000017500000000305213022274260022473 0ustar mdenesmdenes; From NSIS Wiki http://nsis.sourceforge.net/ReplaceInFile ; Modifications: ; - Replace only once per line ; - Don't keep original as .old ; - Use StrRep instead of StrReplace (seems to be cleaner) Function Func_ReplaceInFile ClearErrors Exch $0 ; REPLACEMENT Exch Exch $1 ; SEARCH_TEXT Exch 2 Exch $2 ; SOURCE_FILE Push $R0 ; SOURCE_FILE file handle Push $R1 ; temporary file handle Push $R2 ; unique temporary file name Push $R3 ; a line to search and replace / save Push $R4 ; shift puffer IfFileExists $2 +1 error ; Check if file exists and open it FileOpen $R0 $2 "r" GetTempFileName $R2 ; Create temporary output file FileOpen $R1 $R2 "w" loop: ; Loop over lines of file FileRead $R0 $R3 ; Read line IfErrors finished Push "$R3" ; Replacine string in line once Push "$1" Push "$0" Call Func_StrRep Pop $R3 FileWrite $R1 "$R3" ; Write result Goto loop finished: FileClose $R1 ; Close files FileClose $R0 Delete "$2" ; Delete original file and rename temporary file to target Rename "$R2" "$2" ClearErrors Goto out error: SetErrors out: Pop $R4 Pop $R3 Pop $R2 Pop $R1 Pop $R0 Pop $2 Pop $0 Pop $1 FunctionEnd !macro ReplaceInFile SOURCE_FILE SEARCH_TEXT REPLACEMENT Push "${SOURCE_FILE}" Push "${SEARCH_TEXT}" Push "${REPLACEMENT}" Call Func_ReplaceInFile !macroend coq-8.6/dev/build/windows/patches_coq/glib-2.46.0.patch0000644000175000017500000000315113022274260022002 0ustar mdenesmdenesdiff -u -r glib-2.46.0/gio/glocalfile.c glib-2.46.0.patched/gio/glocalfile.c --- glib-2.46.0/gio/glocalfile.c 2015-08-27 05:32:26.000000000 +0200 +++ glib-2.46.0.patched/gio/glocalfile.c 2016-01-27 13:08:30.059736400 +0100 @@ -2682,7 +2682,10 @@ (!g_path_is_absolute (filename) || len > g_path_skip_root (filename) - filename)) wfilename[len] = '\0'; - retval = _wstat32i64 (wfilename, &buf); + // MSoegtrop: _wstat32i64 is the wrong function for GLocalFileStat = struct _stati64 + // The correct function is _wstati64, see https://msdn.microsoft.com/en-us/library/14h5k7ff.aspx + // Also _wstat32i64 is a VC function, not a windows SDK function, see https://msdn.microsoft.com/en-us/library/aa273365(v=vs.60).aspx + retval = _wstati64 (wfilename, &buf); save_errno = errno; g_free (wfilename); diff -u -r glib-2.46.0/glib/gstdio.c glib-2.46.0.patched/glib/gstdio.c --- glib-2.46.0/glib/gstdio.c 2015-02-26 13:57:09.000000000 +0100 +++ glib-2.46.0.patched/glib/gstdio.c 2016-01-27 13:31:12.708987700 +0100 @@ -493,7 +493,10 @@ (!g_path_is_absolute (filename) || len > g_path_skip_root (filename) - filename)) wfilename[len] = '\0'; - retval = _wstat (wfilename, buf); + // MSoegtrop: _wstat32i64 is the wrong function for GLocalFileStat = struct _stati64 + // The correct function is _wstati64, see https://msdn.microsoft.com/en-us/library/14h5k7ff.aspx + // Also _wstat32i64 is a VC function, not a windows SDK function, see https://msdn.microsoft.com/en-us/library/aa273365(v=vs.60).aspx + retval = _wstati64 (wfilename, buf); save_errno = errno; g_free (wfilename); coq-8.6/dev/build/windows/patches_coq/camlp4-4.02+6.patch0000644000175000017500000000062713022274260022247 0ustar mdenesmdenes--- camlp4-4.02-6.orig/myocamlbuild.ml 2015-06-17 13:37:36.000000000 +0200 +++ camlp4-4.02+6/myocamlbuild.ml 2016-10-13 13:57:35.512213600 +0200 @@ -86,7 +86,7 @@ let dep = "camlp4"/"boot"/exe in let cmd = let ( / ) = Filename.concat in - "camlp4"/"boot"/exe + String.escaped (String.escaped ("camlp4"/"boot"/exe)) in (Some dep, cmd) in coq-8.6/dev/build/windows/patches_coq/lablgtk-2.18.3.patch0000644000175000017500000000602513022274260022512 0ustar mdenesmdenesdiff -u -r lablgtk-2.18.3/configure lablgtk-2.18.3.patched/configure --- lablgtk-2.18.3/configure 2014-10-29 08:51:05.000000000 +0100 +++ lablgtk-2.18.3.patched/configure 2015-10-29 08:58:08.543985500 +0100 @@ -2667,7 +2667,7 @@ fi -if test "`$OCAMLFIND printconf stdlib`" != "`$CAMLC -where`"; then +if test "`$OCAMLFIND printconf stdlib | tr '\\' '/'`" != "`$CAMLC -where | tr '\\' '/'`"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Ignoring ocamlfind" >&5 $as_echo "$as_me: WARNING: Ignoring ocamlfind" >&2;} OCAMLFIND=no diff -u -r lablgtk-2.18.3/src/glib.mli lablgtk-2.18.3.patched/src/glib.mli --- lablgtk-2.18.3/src/glib.mli 2014-10-29 08:51:06.000000000 +0100 +++ lablgtk-2.18.3.patched/src/glib.mli 2016-01-25 09:50:59.884715200 +0100 @@ -75,6 +75,7 @@ type condition = [ `ERR | `HUP | `IN | `NVAL | `OUT | `PRI] type id val channel_of_descr : Unix.file_descr -> channel + val channel_of_descr_socket : Unix.file_descr -> channel val add_watch : cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id val remove : id -> unit diff -u -r lablgtk-2.18.3/src/glib.ml lablgtk-2.18.3.patched/src/glib.ml --- lablgtk-2.18.3/src/glib.ml 2014-10-29 08:51:06.000000000 +0100 +++ lablgtk-2.18.3.patched/src/glib.ml 2016-01-25 09:50:59.891715900 +0100 @@ -72,6 +72,8 @@ type id external channel_of_descr : Unix.file_descr -> channel = "ml_g_io_channel_unix_new" + external channel_of_descr_socket : Unix.file_descr -> channel + = "ml_g_io_channel_unix_new_socket" external remove : id -> unit = "ml_g_source_remove" external add_watch : cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id diff -u -r lablgtk-2.18.3/src/ml_glib.c lablgtk-2.18.3.patched/src/ml_glib.c --- lablgtk-2.18.3/src/ml_glib.c 2014-10-29 08:51:06.000000000 +0100 +++ lablgtk-2.18.3.patched/src/ml_glib.c 2016-01-25 09:50:59.898716600 +0100 @@ -25,6 +25,8 @@ #include #include #ifdef _WIN32 +/* to kill a #warning: include winsock2.h before windows.h */ +#include #include "win32.h" #include #include @@ -38,6 +40,11 @@ #include #include +#ifdef _WIN32 +/* for Socket_val */ +#include +#endif + #include "wrappers.h" #include "ml_glib.h" #include "glib_tags.h" @@ -325,14 +332,23 @@ #ifndef _WIN32 ML_1 (g_io_channel_unix_new, Int_val, Val_GIOChannel_noref) +CAMLprim value ml_g_io_channel_unix_new_socket (value arg1) { + return Val_GIOChannel_noref (g_io_channel_unix_new (Int_val (arg1))); +} #else CAMLprim value ml_g_io_channel_unix_new(value wh) { return Val_GIOChannel_noref - (g_io_channel_unix_new + (g_io_channel_win32_new_fd (_open_osfhandle((long)*(HANDLE*)Data_custom_val(wh), O_BINARY))); } + +CAMLprim value ml_g_io_channel_unix_new_socket(value wh) +{ + return Val_GIOChannel_noref + (g_io_channel_win32_new_socket(Socket_val(wh))); +} #endif static gboolean ml_g_io_channel_watch(GIOChannel *s, GIOCondition c, coq-8.6/dev/build/windows/patches_coq/coq_new.nsi0000644000175000017500000002015713022274260021472 0ustar mdenesmdenes; This script is used to build the Windows install program for Coq. ; NSIS Modern User Interface ; Written by Joost Verburg ; Modified by Julien Narboux, Pierre Letouzey, Enrico Tassi and Michael Soegtrop ; The following command line defines are expected: ; VERSION Coq version, e.g. 8.5-pl2 ; ARCH The target architecture, either x86_64 or i686 ; COQ_SRC_PATH path of Coq installation in Windows or MinGW format (either \\ or /, but with drive letter) ; COQ_ICON path of Coq icon file in Windows or MinGW format ; Enable compression after debugging. ; SetCompress off SetCompressor lzma !define MY_PRODUCT "Coq" ;Define your own software name here !define OUTFILE "coq-installer-${VERSION}-${ARCH}.exe" !include "MUI2.nsh" !include "FileAssociation.nsh" !include "StrRep.nsh" !include "ReplaceInFile.nsh" !include "winmessages.nsh" Var COQ_SRC_PATH_BS ; COQ_SRC_PATH with \ instead of / Var COQ_SRC_PATH_DBS ; COQ_SRC_PATH with \\ instead of / Var INSTDIR_DBS ; INSTDIR with \\ instead of \ ;-------------------------------- ;Configuration Name "Coq" ;General OutFile "${OUTFILE}" ;Folder selection page InstallDir "C:\${MY_PRODUCT}" ;Remember install folder InstallDirRegKey HKCU "Software\${MY_PRODUCT}" "" ;-------------------------------- ;Modern UI Configuration !define MUI_ICON "${COQ_ICON}" !insertmacro MUI_PAGE_WELCOME !insertmacro MUI_PAGE_LICENSE "${COQ_SRC_PATH}/license_readme/coq/License.txt" !insertmacro MUI_PAGE_COMPONENTS !define MUI_DIRECTORYPAGE_TEXT_TOP "Select where to install Coq. The path MUST NOT include spaces." !insertmacro MUI_PAGE_DIRECTORY !insertmacro MUI_PAGE_INSTFILES !insertmacro MUI_PAGE_FINISH !insertmacro MUI_UNPAGE_WELCOME !insertmacro MUI_UNPAGE_CONFIRM !insertmacro MUI_UNPAGE_INSTFILES !insertmacro MUI_UNPAGE_FINISH ;-------------------------------- ;Languages !insertmacro MUI_LANGUAGE "English" ;-------------------------------- ;Language Strings ;Description LangString DESC_1 ${LANG_ENGLISH} "This package contains Coq and CoqIDE." LangString DESC_2 ${LANG_ENGLISH} "This package contains an OCaml compiler for Coq native compute and plugin development." LangString DESC_3 ${LANG_ENGLISH} "This package contains the development files needed in order to build a plugin for Coq." LangString DESC_4 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for the current user." LangString DESC_5 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for all users." ;-------------------------------- ; Check for white spaces Function .onVerifyInstDir StrLen $0 "$INSTDIR" StrCpy $1 0 ${While} $1 < $0 StrCpy $3 $INSTDIR 1 $1 StrCmp $3 " " SpacesInPath IntOp $1 $1 + 1 ${EndWhile} Goto done SpacesInPath: Abort done: FunctionEnd ;-------------------------------- ;Installer Sections Section "Coq" Sec1 SetOutPath "$INSTDIR\" !include "..\..\..\filelists\coq_base.nsh" ${registerExtension} "$INSTDIR\bin\coqide.exe" ".v" "Coq Script File" ;Store install folder WriteRegStr HKCU "Software\${MY_PRODUCT}" "" $INSTDIR ;Create uninstaller WriteUninstaller "$INSTDIR\Uninstall.exe" WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ "DisplayName" "Coq Version ${VERSION}" WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ "UninstallString" '"$INSTDIR\Uninstall.exe"' WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ "DisplayVersion" "${VERSION}" WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ "NoModify" "1" WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ "NoRepair" "1" WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ "URLInfoAbout" "http://coq.inria.fr" ; Create start menu entries ; SetOutPath is required for the path in the .lnk files SetOutPath "$INSTDIR" CreateDirectory "$SMPROGRAMS\Coq" ; The first shortcut set here is treated as main application by Windows 7/8. ; Use CoqIDE as main application CreateShortCut "$SMPROGRAMS\Coq\CoqIde.lnk" "$INSTDIR\bin\coqide.exe" CreateShortCut "$SMPROGRAMS\Coq\Coq.lnk" "$INSTDIR\bin\coqtop.exe" WriteINIStr "$SMPROGRAMS\Coq\The Coq HomePage.url" "InternetShortcut" "URL" "http://coq.inria.fr" WriteINIStr "$SMPROGRAMS\Coq\The Coq Standard Library.url" "InternetShortcut" "URL" "http://coq.inria.fr/library" CreateShortCut "$SMPROGRAMS\Coq\Uninstall.lnk" "$INSTDIR\Uninstall.exe" "" "$INSTDIR\Uninstall.exe" 0 SectionEnd ;OCAML Section "Ocaml for native compute and plugin development" Sec2 ;OCAML SetOutPath "$INSTDIR\" ;OCAML !include "..\..\..\filelists\ocaml.nsh" ;OCAML ;OCAML ; Create a few slash / backslash variants of the source and install path ;OCAML ; Note: NSIS has variables, written as $VAR and defines, written as ${VAR} ;OCAML !insertmacro StrRep $COQ_SRC_PATH_BS ${COQ_SRC_PATH} "/" "\" ;OCAML !insertmacro StrRep $COQ_SRC_PATH_DBS ${COQ_SRC_PATH} "/" "\\" ;OCAML !insertmacro StrRep $INSTDIR_DBS $INSTDIR "\" "\\" ;OCAML ;OCAML ; Replace absolute paths in some OCaml config files ;OCAML ; These are not all, see ReadMe.txt ;OCAML !insertmacro ReplaceInFile "$INSTDIR\libocaml\ld.conf" "/" "\" ;OCAML !insertmacro ReplaceInFile "$INSTDIR\libocaml\ld.conf" "$COQ_SRC_PATH_BS" "$INSTDIR" ;OCAML !insertmacro ReplaceInFile "$INSTDIR\etc\findlib.conf" "$COQ_SRC_PATH_DBS" "$INSTDIR_DBS" ;OCAML SectionEnd Section "Coq files for plugin developers" Sec3 SetOutPath "$INSTDIR\" !include "..\..\..\filelists\coq_plugindev.nsh" SectionEnd ;OCAML Section "OCAMLLIB current user" Sec4 ;OCAML WriteRegStr HKCU "Environment" "OCAMLLIB" "$INSTDIR\libocaml" ;OCAML ; This is required, so that a newly started shell gets the new environment variable ;OCAML ; But it really takes a few seconds ;OCAML DetailPrint "Broadcasting OCAMLLIB environment variable change (current user)" ;OCAML SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=1000 ;OCAML SectionEnd ;OCAML Section "OCAMLLIB all users" Sec5 ;OCAML WriteRegStr HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment" "OCAMLLIB" "$INSTDIR\libocaml" ;OCAML ; This is required, so that a newly started shell gets the new environment variable ;OCAML ; But it really takes a few seconds ;OCAML DetailPrint "Broadcasting OCAMLLIB environment variable change (all users)" ;OCAML SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=1000 ;OCAML SectionEnd ;-------------------------------- ;Descriptions !insertmacro MUI_FUNCTION_DESCRIPTION_BEGIN !insertmacro MUI_DESCRIPTION_TEXT ${Sec1} $(DESC_1) ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec2} $(DESC_2) !insertmacro MUI_DESCRIPTION_TEXT ${Sec3} $(DESC_3) ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec4} $(DESC_4) ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec5} $(DESC_5) !insertmacro MUI_FUNCTION_DESCRIPTION_END ;-------------------------------- ;Uninstaller Section Section "Uninstall" ; Files and folders RMDir /r "$INSTDIR\bin" RMDir /r "$INSTDIR\dev" RMDir /r "$INSTDIR\etc" RMDir /r "$INSTDIR\lib" RMDir /r "$INSTDIR\libocaml" RMDir /r "$INSTDIR\share" RMDir /r "$INSTDIR\ide" RMDir /r "$INSTDIR\gtk-2.0" RMDir /r "$INSTDIR\latex" RMDir /r "$INSTDIR\license_readme" RMDir /r "$INSTDIR\man" RMDir /r "$INSTDIR\emacs" ; Start Menu Delete "$SMPROGRAMS\Coq\Coq.lnk" Delete "$SMPROGRAMS\Coq\CoqIde.lnk" Delete "$SMPROGRAMS\Coq\Uninstall.lnk" Delete "$SMPROGRAMS\Coq\The Coq HomePage.url" Delete "$SMPROGRAMS\Coq\The Coq Standard Library.url" Delete "$INSTDIR\Uninstall.exe" ; Registry keys DeleteRegKey HKCU "Software\${MY_PRODUCT}" DeleteRegKey HKLM "SOFTWARE\Coq" DeleteRegKey HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\Coq" DeleteRegKey HKCU "Environment\OCAMLLIB" DeleteRegKey HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment\OCAMLLIB" ${unregisterExtension} ".v" "Coq Script File" ; Root folders RMDir "$INSTDIR" RMDir "$SMPROGRAMS\Coq" SectionEnd coq-8.6/dev/build/windows/patches_coq/flexdll-0.34.patch0000644000175000017500000000071713022274260022361 0ustar mdenesmdenesreloc.ml --- orig.flexdll-0.34/reloc.ml 2015-01-22 17:30:07.000000000 +0100 +++ flexdll-0.34/reloc.ml 2016-10-12 11:59:16.885829700 +0200 @@ -117,8 +117,8 @@ let new_cmdline () = let rf = match !toolchain with - | `MSVC | `MSVC64 | `LIGHTLD -> true - | `MINGW | `MINGW64 | `GNAT | `CYGWIN | `CYGWIN64 -> false + | `MSVC | `MSVC64 | `LIGHTLD | `MINGW | `MINGW64 -> true + | `GNAT | `CYGWIN | `CYGWIN64 -> false in { may_use_response_file = rf; coq-8.6/dev/build/windows/patches_coq/isl-0.14.patch0000644000175000017500000000051113022274260021504 0ustar mdenesmdenes--- orig.isl-0.14/configure 2014-10-26 08:36:32.000000000 +0100 +++ isl-0.14/configure 2016-10-10 18:16:01.430224500 +0200 @@ -8134,7 +8134,7 @@ lt_sysroot=`$CC --print-sysroot 2>/dev/null` fi ;; #( - /*) + /*|[A-Z]:\\*|[A-Z]:/*) lt_sysroot=`echo "$with_sysroot" | sed -e "$sed_quote_subst"` ;; #( no|'') coq-8.6/dev/build/windows/patches_coq/StrRep.nsh0000644000175000017500000000212313022274260021246 0ustar mdenesmdenes; From NSIS Wiki http://nsis.sourceforge.net/StrRep ; Slightly modified Function Func_StrRep Exch $R2 ;new Exch 1 Exch $R1 ;old Exch 2 Exch $R0 ;string Push $R3 Push $R4 Push $R5 Push $R6 Push $R7 Push $R8 Push $R9 StrCpy $R3 0 StrLen $R4 $R1 StrLen $R6 $R0 StrLen $R9 $R2 loop: StrCpy $R5 $R0 $R4 $R3 StrCmp $R5 $R1 found StrCmp $R3 $R6 done IntOp $R3 $R3 + 1 ;move offset by 1 to check the next character Goto loop found: StrCpy $R5 $R0 $R3 IntOp $R8 $R3 + $R4 StrCpy $R7 $R0 "" $R8 StrCpy $R0 $R5$R2$R7 StrLen $R6 $R0 IntOp $R3 $R3 + $R9 ;move offset by length of the replacement string Goto loop done: Pop $R9 Pop $R8 Pop $R7 Pop $R6 Pop $R5 Pop $R4 Pop $R3 Push $R0 Push $R1 Pop $R0 Pop $R1 Pop $R0 Pop $R2 Exch $R1 FunctionEnd !macro StrRep output string old new Push `${string}` Push `${old}` Push `${new}` Call Func_StrRep Pop ${output} !macroend coq-8.6/dev/build/windows/patches_coq/coq-8.4pl6.patch0000644000175000017500000000050613022274260022054 0ustar mdenesmdenescoq-8.4pl6.orig --- coq-8.4pl6.orig/configure 2015-04-09 15:59:35.000000000 +0200 +++ coq-8.4pl6//configure 2016-11-09 13:29:42.235319800 +0100 @@ -309,9 +309,6 @@ # executable extension case "$ARCH,$CYGWIN" in - win32,yes) - EXE=".exe" - DLLEXT=".so";; win32,*) EXE=".exe" DLLEXT=".dll";; coq-8.6/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch0000644000175000017500000002351713022274260023770 0ustar mdenesmdenesdiff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourceiter.c gtksourceview-2.11.2.patched/gtksourceview/gtksourceiter.c *** gtksourceview-2.11.2.orig/gtksourceview/gtksourceiter.c 2010-05-30 12:24:14.000000000 +0200 --- gtksourceview-2.11.2.patched/gtksourceview/gtksourceiter.c 2015-10-27 14:58:54.422888400 +0100 *************** *** 80,86 **** /* If string contains prefix, check that prefix is not followed * by a unicode mark symbol, e.g. that trailing 'a' in prefix * is not part of two-char a-with-hat symbol in string. */ ! return type != G_UNICODE_COMBINING_MARK && type != G_UNICODE_ENCLOSING_MARK && type != G_UNICODE_NON_SPACING_MARK; } --- 80,86 ---- /* If string contains prefix, check that prefix is not followed * by a unicode mark symbol, e.g. that trailing 'a' in prefix * is not part of two-char a-with-hat symbol in string. */ ! return type != G_UNICODE_SPACING_MARK && type != G_UNICODE_ENCLOSING_MARK && type != G_UNICODE_NON_SPACING_MARK; } diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.c *** gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.c 2010-05-30 12:24:14.000000000 +0200 --- gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.c 2015-10-27 14:55:30.294477600 +0100 *************** *** 274,280 **** * containg a list of language files directories. * The array is owned by @lm and must not be modified. */ ! G_CONST_RETURN gchar* G_CONST_RETURN * gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm) { g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); --- 274,280 ---- * containg a list of language files directories. * The array is owned by @lm and must not be modified. */ ! const gchar* const * gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm) { g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); *************** *** 392,398 **** * available languages or %NULL if no language is available. The array * is owned by @lm and must not be modified. */ ! G_CONST_RETURN gchar* G_CONST_RETURN * gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm) { g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); --- 392,398 ---- * available languages or %NULL if no language is available. The array * is owned by @lm and must not be modified. */ ! const gchar* const * gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm) { g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.h *** gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.h 2009-11-15 00:41:33.000000000 +0100 --- gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.h 2015-10-27 14:55:30.518500000 +0100 *************** *** 62,74 **** GtkSourceLanguageManager *gtk_source_language_manager_get_default (void); ! G_CONST_RETURN gchar* G_CONST_RETURN * gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm); void gtk_source_language_manager_set_search_path (GtkSourceLanguageManager *lm, gchar **dirs); ! G_CONST_RETURN gchar* G_CONST_RETURN * gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm); GtkSourceLanguage *gtk_source_language_manager_get_language (GtkSourceLanguageManager *lm, --- 62,74 ---- GtkSourceLanguageManager *gtk_source_language_manager_get_default (void); ! const gchar* const * gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm); void gtk_source_language_manager_set_search_path (GtkSourceLanguageManager *lm, gchar **dirs); ! const gchar* const * gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm); GtkSourceLanguage *gtk_source_language_manager_get_language (GtkSourceLanguageManager *lm, diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.c *** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.c 2010-05-30 12:24:14.000000000 +0200 --- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.c 2015-10-27 14:55:30.545502700 +0100 *************** *** 310,316 **** * * Since: 2.0 */ ! G_CONST_RETURN gchar* G_CONST_RETURN * gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme) { g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME (scheme), NULL); --- 310,316 ---- * * Since: 2.0 */ ! const gchar* const * gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme) { g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME (scheme), NULL); *************** *** 318,324 **** if (scheme->priv->authors == NULL) return NULL; ! return (G_CONST_RETURN gchar* G_CONST_RETURN *)scheme->priv->authors->pdata; } /** --- 318,324 ---- if (scheme->priv->authors == NULL) return NULL; ! return (const gchar* const *)scheme->priv->authors->pdata; } /** diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.h *** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.h 2010-03-29 15:02:56.000000000 +0200 --- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.h 2015-10-27 14:55:30.565504700 +0100 *************** *** 61,67 **** const gchar *gtk_source_style_scheme_get_name (GtkSourceStyleScheme *scheme); const gchar *gtk_source_style_scheme_get_description(GtkSourceStyleScheme *scheme); ! G_CONST_RETURN gchar* G_CONST_RETURN * gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme); const gchar *gtk_source_style_scheme_get_filename (GtkSourceStyleScheme *scheme); --- 61,67 ---- const gchar *gtk_source_style_scheme_get_name (GtkSourceStyleScheme *scheme); const gchar *gtk_source_style_scheme_get_description(GtkSourceStyleScheme *scheme); ! const gchar* const * gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme); const gchar *gtk_source_style_scheme_get_filename (GtkSourceStyleScheme *scheme); diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.c *** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.c 2010-05-30 12:24:14.000000000 +0200 --- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.c 2015-10-27 14:55:30.583506500 +0100 *************** *** 515,521 **** * of string containing the search path. * The array is owned by the @manager and must not be modified. */ ! G_CONST_RETURN gchar* G_CONST_RETURN * gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager) { g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); --- 515,521 ---- * of string containing the search path. * The array is owned by the @manager and must not be modified. */ ! const gchar* const * gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager) { g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); *************** *** 554,560 **** * of string containing the ids of the available style schemes or %NULL if no * style scheme is available. The array is owned by the @manager and must not be modified. */ ! G_CONST_RETURN gchar* G_CONST_RETURN * gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager) { g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); --- 554,560 ---- * of string containing the ids of the available style schemes or %NULL if no * style scheme is available. The array is owned by the @manager and must not be modified. */ ! const gchar* const * gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager) { g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.h *** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.h 2009-11-15 00:41:33.000000000 +0100 --- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.h 2015-10-27 14:56:24.498897500 +0100 *************** *** 73,84 **** void gtk_source_style_scheme_manager_prepend_search_path (GtkSourceStyleSchemeManager *manager, const gchar *path); ! G_CONST_RETURN gchar* G_CONST_RETURN * gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager); void gtk_source_style_scheme_manager_force_rescan (GtkSourceStyleSchemeManager *manager); ! G_CONST_RETURN gchar* G_CONST_RETURN * gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager); GtkSourceStyleScheme *gtk_source_style_scheme_manager_get_scheme (GtkSourceStyleSchemeManager *manager, --- 73,84 ---- void gtk_source_style_scheme_manager_prepend_search_path (GtkSourceStyleSchemeManager *manager, const gchar *path); ! const gchar* const * gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager); void gtk_source_style_scheme_manager_force_rescan (GtkSourceStyleSchemeManager *manager); ! const gchar* const * gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager); GtkSourceStyleScheme *gtk_source_style_scheme_manager_get_scheme (GtkSourceStyleSchemeManager *manager, coq-8.6/dev/build/windows/patches_coq/ln.c0000644000175000017500000000760213022274260020101 0ustar mdenesmdenes// (C) 2016 Intel Deutschland GmbH // Author: Michael Soegtrop // Released to the public under CC0 // See https://creativecommons.org/publicdomain/zero/1.0/ // Windows drop in repacement for Linux ln // Supports command form "ln TARGET LINK_NAME" // Supports -s and -f options // Does not support hard links to folders (but symlinks are ok) #include #include #include // Cygwin MinGW doesn't have this Vista++ function in windows.h #ifdef UNICODE WINBASEAPI BOOLEAN APIENTRY CreateSymbolicLinkW ( LPCWSTR, LPCWSTR, DWORD ); #define CreateSymbolicLink CreateSymbolicLinkW #define CommandLineToArgv CommandLineToArgvW #else WINBASEAPI BOOLEAN APIENTRY CreateSymbolicLinkA ( LPCSTR, LPCSTR, DWORD ); #define CreateSymbolicLink CreateSymbolicLinkA #define CommandLineToArgv CommandLineToArgvA #endif #define SYMBOLIC_LINK_FLAG_DIRECTORY 1 int WINAPI WinMain( HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLineA, int nShowCmd ) { int iarg; BOOL symbolic = FALSE; BOOL force = FALSE; BOOL folder; const _TCHAR *target; const _TCHAR *link; LPTSTR lpCmdLine; int argc; LPTSTR *argv; // Parse command line // This is done explicitly here for two reasons // 1.) MinGW doesn't seem to support _tmain, wWinMain and the like // 2.) We want to make sure that CommandLineToArgv is used lpCmdLine = GetCommandLine(); argv = CommandLineToArgv( lpCmdLine, &argc ); // Get target and link name if( argc<3 ) { _ftprintf( stderr, _T("Expecting at least 2 arguments, got %d\n"), argc-1 ); return 1; } target = argv[argc-2]; link = argv[argc-1]; // Parse options // The last two arguments are interpreted as file names // All other arguments must be -s or -f os multi letter options like -sf for(iarg=1; iarg '%s'!\n"), link, target ); return 1; } } else { if( folder ) { _ftprintf( stderr, _T("Cannot create hard link to folder") ); return 1; } else { if( !CreateHardLink( link, target, NULL ) ) { _ftprintf( stderr, _T("Error creating hard link '%s' -> '%s'!\n"), link, target ); return 1; } } } // Everything is fine return 0; }coq-8.6/dev/build/windows/MakeCoq_regtests.bat0000644000175000017500000000062213022274260020756 0ustar mdenesmdenesSET COQREGTESTING=Y REM Bleeding edge call MakeCoq_86git_abs_ocaml.bat call MakeCoq_86git_installer.bat call MakeCoq_86git_installer_32.bat call MakeCoq_86git_abs_ocaml_gtksrc.bat REM Current stable call MakeCoq_85pl3_abs_ocaml.bat call MakeCoq_85pl3_installer.bat call MakeCoq_85pl3_installer_32.bat REM Old but might still be used call MakeCoq_85pl2_abs_ocaml.bat call MakeCoq_84pl6_abs_ocaml.bat coq-8.6/dev/build/windows/MakeCoq_86rc1_abs_ocaml.bat0000644000175000017500000000033613022274260021763 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -mode=absolute ^ -ocaml=Y ^ -make=Y ^ -coqver=8.6rc1 ^ -destcyg=%ROOTPATH%\cygwin_coq64_86rc1_abs ^ -destcoq=%ROOTPATH%\coq64_86rc1_abs coq-8.6/dev/build/windows/MakeCoq_86_installer.bat0000644000175000017500000000027213022274260021431 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -installer=Y ^ -coqver=8.6 ^ -destcyg=%ROOTPATH%\cygwin_coq64_86_inst ^ -destcoq=%ROOTPATH%\coq64_86_inst coq-8.6/dev/build/windows/MakeCoq_SetRootPath.bat0000644000175000017500000000046513022274260021337 0ustar mdenesmdenes@ ECHO OFF REM Figure out a root path for coq and cygwin REM For the \nul trick for testing folders see REM https://support.microsoft.com/en-us/kb/65994 IF EXIST D:\bin\nul ( SET ROOTPATH=D:\bin ) else if EXIST C:\bin ( SET ROOTPATH=C:\bin ) else ( SET ROOTPATH=C: ) ECHO ROOTPATH set to %ROOTPATH% coq-8.6/dev/build/windows/MakeCoq_86git_abs_ocaml_gtksrc.bat0000644000175000017500000000037513022274260023441 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -mode=absolute ^ -ocaml=Y ^ -make=Y ^ -gtksrc=Y ^ -coqver=git-v8.6 ^ -destcyg=%ROOTPATH%\cygwin_coq64_86git_abs_gtksrc ^ -destcoq=%ROOTPATH%\coq64_86git_abs_gtksrc coq-8.6/dev/build/windows/MakeCoq_85pl3_abs_ocaml.bat0000644000175000017500000000033613022274260021773 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -mode=absolute ^ -ocaml=Y ^ -make=Y ^ -coqver=8.5pl3 ^ -destcyg=%ROOTPATH%\cygwin_coq64_85pl3_abs ^ -destcoq=%ROOTPATH%\coq64_85pl3_abs coq-8.6/dev/build/windows/configure_profile.sh0000644000175000017500000000215013022274260021061 0ustar mdenesmdenes#!/bin/bash rcfile=~/.bash_profile donefile=~/.bash_profile.upated if [ ! -f $donefile ] ; then echo >> $rcfile if [ -n "$1" ]; then echo export http_proxy="http://$1" >> $rcfile echo export https_proxy="http://$1" >> $rcfile echo export ftp_proxy="http://$1" >> $rcfile fi mkdir -p $RESULT_INSTALLDIR_CFMT/bin # A tightly controlled path helps to avoid issues # Note: the order is important: first have the cygwin binaries, then the mingw binaries in the path! # Note: /bin is mounted at /usr/bin and /lib at /usr/lib and it is common to use /usr/bin in PATH # See cat /proc/mounts echo "export PATH=/usr/local/bin:/usr/bin:$RESULT_INSTALLDIR_CFMT/bin:/usr/$TARGET_ARCH/sys-root/mingw/bin:/cygdrive/c/Windows/system32:/cygdrive/c/Windows" >> $rcfile # find and xargs complain if the environment is larger than (I think) 8k. # ORIGINAL_PATH (set by cygwin) can be a few k and exceed the limit echo unset ORIGINAL_PATH >> $rcfile # Other installations of OCaml will mess up things echo unset OCAMLLIB >> $rcfile touch $donefile ficoq-8.6/dev/build/windows/MakeCoq_86rc1_installer.bat0000644000175000017500000000030313022274260022032 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -installer=Y ^ -coqver=8.6rc1 ^ -destcyg=%ROOTPATH%\cygwin_coq64_86rc1_inst ^ -destcoq=%ROOTPATH%\coq64_86rc1_inst coq-8.6/dev/build/windows/CAVEATS.txt0000644000175000017500000000133013022274260016652 0ustar mdenesmdenes===== Environemt SIZE ===== find and xargs can fail if the environment is to large. I think the limit is 8k. xargs --show-limits shows the actual environment size The configure_profile.sh script sets ORIGINAL_PATH (set by cygwin) to "" to avoid issues ===== OCAMLLIB ===== If the environment variable OCAMLLIB is defined, it takes precedence over the internal paths of ocaml tools. This usually messes up things considerably. A typical failure is Error: Error on dynamically loaded library: .\dlllablgtk2.dll: %1 is not a valid Win32 application. The configure_profile.sh script clears OCAMLLIB, but if you use the ocaml compiler from outside the provided cygwin shell, OCAMLLIB might be defined. coq-8.6/dev/build/windows/MakeCoq_86rc1_installer_32.bat0000644000175000017500000000030313022274260022336 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=32 ^ -installer=Y ^ -coqver=8.6rc1 ^ -destcyg=%ROOTPATH%\cygwin_coq32_86rc1_inst ^ -destcoq=%ROOTPATH%\coq32_86rc1_inst coq-8.6/dev/build/windows/difftar-folder.sh0000644000175000017500000000372713022274260020263 0ustar mdenesmdenes#!/bin/bash ###################### COPYRIGHT/COPYLEFT ###################### # (C) 2016 Intel Deutschland GmbH # Author: Michael Soegtrop # # Released to the public by Intel under the # GNU Lesser General Public License Version 2.1 or later # See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html # # With very valuable help on building GTK from # https://wiki.gnome.org/Projects/GTK+/Win32/MSVCCompilationOfGTKStack # http://www.gaia-gis.it/spatialite-3.0.0-BETA/mingw64_how_to.html ###################### Script safety and debugging settings ###################### set -o nounset # Print usage if [ "$#" -lt 1 ] ; then echo 'Diff a tar (or compressed tar) file with a folder' echo 'difftar-folder.sh [] [strip]' echo default for folder is . echo default for strip is 0. echo 'strip must be 0 or 1.' exit 1 fi # Parse parameters tarfile=$1 if [ "$#" -ge 2 ] ; then folder=$2 else folder=. fi if [ "$#" -ge 3 ] ; then strip=$3 else strip=0 fi # Get path prefix if --strip is used if [ "$strip" -gt 0 ] ; then prefix=`tar -t -f $tarfile | head -1` else prefix= fi # Original folder if [ "$strip" -gt 0 ] ; then orig=${prefix%/}.orig elif [ "$folder" = "." ] ; then orig=${tarfile##*/} orig=./${orig%%.tar*}.orig elif [ "$folder" = "" ] ; then orig=${tarfile##*/} orig=${orig%%.tar*}.orig else orig=$folder.orig fi echo $orig mkdir -p "$orig" # Make sure tar uses english output (for Mod time differs) export LC_ALL=C # Search all files with a deviating modification time using tar --diff tar --diff -a -f "$tarfile" --strip $strip --directory "$folder" | grep "Mod time differs" | while read -r file ; do # Substitute ': Mod time differs' with nothing file=${file/: Mod time differs/} # Check if file exists if [ -f "$folder/$file" ] ; then # Extract original file tar -x -a -f "$tarfile" --strip $strip --directory "$orig" "$prefix$file" # Compute diff diff -u "$orig/$file" "$folder/$file" fi donecoq-8.6/dev/build/windows/makecoq_mingw.sh0000644000175000017500000012640613022274260020214 0ustar mdenesmdenes#!/bin/bash ###################### COPYRIGHT/COPYLEFT ###################### # (C) 2016 Intel Deutschland GmbH # Author: Michael Soegtrop # # Released to the public by Intel under the # GNU Lesser General Public License Version 2.1 or later # See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html # # With very valuable help on building GTK from # https://wiki.gnome.org/Projects/GTK+/Win32/MSVCCompilationOfGTKStack # http://www.gaia-gis.it/spatialite-3.0.0-BETA/mingw64_how_to.html ###################### Script safety and debugging settings ###################### set -o nounset set -o errexit set -x # Set this to 1 if all module directories shall be removed before build (no incremental make) RMDIR_BEFORE_BUILD=1 ###################### NOTES ##################### # - This file goes together with MakeCoq_ForMignGW.bat, which sets up cygwin # with all required packages and then calls this script. # # - This script uses set -o errexit, so if anything fails, the script will stop # # - cygwin provided mingw64 packages like mingw64-x86_64-zlib are installed to # /usr/$TARGET_ARCH/sys-root/mingw, so we use this as install prefix # # - if mingw64-x86_64-pkg-config is installed BEFORE building libpng or pixman, # the .pc files are properly created in /usr/$TARGET_ARCH/sys-root/mingw/lib/pkgconfig # # - pango and some others uses pkg-config executable names without path, which doesn't work in cross compile mode # There are several possible solutions # 1.) patch build files to get the prefix from pkg-config and use $prefix/bin/ as path # - doesn't work for pango because automake goes wild # - mingw tools are not able to handle cygwin path (they need absolute windows paths) # 2.) export PATH=$PATH:/usr/$TARGET_ARCH/sys-root/mingw/bin # - a bit dangerous because this exposes much more than required # - mingw tools are not able to handle cygwin path (they need absolute windows paths) # 3.) Install required tools via cygwin modules libglib2.0-devel and libgdk_pixbuf2.0-devel # - Possibly version compatibility issues # - Possibly mingw/cygwin compatibility issues, e.g. when building font or terminfo databases # 4.) Build required tools for mingw and cygwin # - Possibly mingw/cygwin compatibility issues, e.g. when building font or terminfo databases # # We use method 3 below # Method 2 can be tried by putting the cross tools in the path before the cygwin tools (in configure_profile.sh) # # - It is tricky to build 64 bit binaries with 32 bit cross tools and vice versa. # This is because the linker needs to load DLLs from C:\windows\system32, which contains # both 32 bit and 64 bit DLLs, and which one you get depends by some black magic on if the using # app is a 32 bit or 64 bit app. So better build 32 bit mingw with 32 bit cygwin and 64 with 64. # Alternatively the required 32 bit or 64 bit DLLs need to be copied with a 32 bit/64bit cp to some # folder without such black magic. # # - The file selection for the Coq Windows Installer is done with make install (unlike the original script) # Relocatble builds are first configured with prefix=./ then build and then # reconfigured with prefix= before make install. ###################### ARCHITECTURES ##################### # The OS on which the build of the tool/lib runs BUILD=`gcc -dumpmachine` # The OS on which the tool runs # "`find /bin -name "*mingw32-gcc.exe"`" -dumpmachine HOST=$TARGET_ARCH # The OS for which the tool creates code/for which the libs are TARGET=$TARGET_ARCH # Cygwin uses different arch name for 32 bit than mingw/gcc case $ARCH in x86_64) CYGWINARCH=x86_64 ;; i686) CYGWINARCH=x86 ;; *) false ;; esac ###################### PATHS ##################### # Name and create some 'global' folders PATCHES=/build/patches BUILDLOGS=/build/buildlogs FLAGFILES=/build/flagfiles TARBALLS=/build/tarballs FILELISTS=/build/filelists mkdir -p $BUILDLOGS mkdir -p $FLAGFILES mkdir -p $TARBALLS mkdir -p $FILELISTS cd /build # sysroot prefix for the above /build/host/target combination PREFIX=$CYGWIN_INSTALLDIR_MFMT/usr/$TARGET_ARCH/sys-root/mingw # Install / Prefix folder for COQ PREFIXCOQ=$RESULT_INSTALLDIR_MFMT # Install / Prefix folder for OCaml if [ "$INSTALLOCAML" == "Y" ]; then PREFIXOCAML=$PREFIXCOQ else PREFIXOCAML=$PREFIX fi mkdir -p $PREFIX/bin mkdir -p $PREFIXCOQ/bin mkdir -p $PREFIXOCAML/bin ###################### Copy Cygwin Setup Info ##################### # Copy Cygwin repo ini file and installed files db to tarballs folder. # Both files together document the exact selection and version of cygwin packages. # Do this as early as possible to avoid changes by other setups (the repo folder is shared). # Escape URL to folder name CYGWIN_REPO_FOLDER=${CYGWIN_REPOSITORY}/ CYGWIN_REPO_FOLDER=${CYGWIN_REPO_FOLDER//:/%3a} CYGWIN_REPO_FOLDER=${CYGWIN_REPO_FOLDER//\//%2f} # Copy files cp $CYGWIN_LOCAL_CACHE_WFMT/$CYGWIN_REPO_FOLDER/$CYGWINARCH/setup.ini $TARBALLS cp /etc/setup/installed.db $TARBALLS ###################### LOGGING ##################### # The folder which receives log files mkdir -p buildlogs LOGS=`pwd`/buildlogs # The current log target (first part of the log file name) LOGTARGET=other log1() { "$@" > $LOGS/$LOGTARGET-$1.log 2> $LOGS/$LOGTARGET-$1.err } log2() { "$@" > $LOGS/$LOGTARGET-$1-$2.log 2> $LOGS/$LOGTARGET-$1-$2.err } log_1_3() { "$@" > $LOGS/$LOGTARGET-$1-$3.log 2> $LOGS/$LOGTARGET-$1-$3.err } logn() { LOGTARGETEX=$1 shift "$@" > $LOGS/$LOGTARGET-$LOGTARGETEX.log 2> $LOGS/$LOGTARGET-$LOGTARGETEX.err } ###################### UTILITY FUNCTIONS ##################### # ------------------------------------------------------------------------------ # Get a source tar ball, expand and patch it # - get source archive from $SOURCE_LOCAL_CACHE_CFMT or online using wget # - create build folder # - extract source archive # - patch source file if patch exists # # Parameters # $1 file server name including protocol prefix # $2 file name (without extension) # $3 file extension # $4 number of path levels to strip from tar (usually 1) # $5 module name (if different from archive) # $6 expand folder name (if different from module name) # ------------------------------------------------------------------------------ function get_expand_source_tar { # Handle optional parameters if [ "$#" -ge 4 ] ; then strip=$4 else strip=1 fi if [ "$#" -ge 5 ] ; then name=$5 else name=$2 fi if [ "$#" -ge 6 ] ; then folder=$6 else folder=$name fi # Set logging target logtargetold=$LOGTARGET LOGTARGET=$name # Get the source archive either from the source cache or online if [ ! -f $TARBALLS/$name.$3 ] ; then if [ -f $SOURCE_LOCAL_CACHE_CFMT/$name.$3 ] ; then cp $SOURCE_LOCAL_CACHE_CFMT/$name.$3 $TARBALLS else wget $1/$2.$3 if [ ! "$2.$3" == "$name.$3" ] ; then mv $2.$3 $name.$3 fi mv $name.$3 $TARBALLS # Save the source archive in the source cache if [ -d $SOURCE_LOCAL_CACHE_CFMT ] ; then cp $TARBALLS/$name.$3 $SOURCE_LOCAL_CACHE_CFMT fi fi fi # Remove build directory (clean build) if [ $RMDIR_BEFORE_BUILD -eq 1 ] ; then rm -f -r $folder fi # Create build directory and cd mkdir -p $folder cd $folder # Extract source archive if [ "$3" == "zip" ] ; then log1 unzip $TARBALLS/$name.$3 if [ "$strip" == "1" ] ; then # Ok, this is dirty, but it works and it fails if there are name clashes mv */* . else echo "Unzip strip count not supported" return 1 fi else logn untar tar xvaf $TARBALLS/$name.$3 --strip $strip fi # Patch if patch file exists if [ -f $PATCHES/$name.patch ] ; then log1 patch -p1 -i $PATCHES/$name.patch fi # Go back to base folder cd .. LOGTARGET=$logtargetold } # ------------------------------------------------------------------------------ # Prepare a module build # - check if build is already done (name.finished file exists) - if so return 1 # - create name.started # - get source archive from $SOURCE_LOCAL_CACHE_CFMT or online using wget # - create build folder # - cd to build folder and extract source archive # - create bin_special subfolder and add it to $PATH # - remember things for build_post # # Parameters # $1 file server name including protocol prefix # $2 file name (without extension) # $3 file extension # $4 [optional] number of path levels to strip from tar (usually 1) # $5 [optional] module name (if different from archive) # ------------------------------------------------------------------------------ function build_prep { # Handle optional parameters if [ "$#" -ge 4 ] ; then strip=$4 else strip=1 fi if [ "$#" -ge 5 ] ; then name=$5 else name=$2 fi # Check if build is already done if [ ! -f flagfiles/$name.finished ] ; then BUILD_PACKAGE_NAME=$name BUILD_OLDPATH=$PATH BUILD_OLDPWD=`pwd` LOGTARGET=$name touch flagfiles/$name.started get_expand_source_tar $1 $2 $3 $strip $name cd $name # Create a folder and add it to path, where we can put special binaries # The path is restored in build_post mkdir bin_special PATH=`pwd`/bin_special:$PATH return 0 else return 1 fi } # ------------------------------------------------------------------------------ # Finalize a module build # - create name.finished # - go back to base folder # ------------------------------------------------------------------------------ function build_post { if [ ! -f flagfiles/$BUILD_PACKAGE_NAME.finished ]; then cd $BUILD_OLDPWD touch flagfiles/$BUILD_PACKAGE_NAME.finished PATH=$BUILD_OLDPATH LOGTARGET=other fi } # ------------------------------------------------------------------------------ # Build and install a module using the standard configure/make/make install process # - prepare build (as above) # - configure # - make # - make install # - finalize build (as above) # # parameters # $1 file server name including protocol prefix # $2 file name (without extension) # $3 file extension # $4 patch function to call between untar and configure (or true if none) # $5.. extra configure arguments # ------------------------------------------------------------------------------ function build_conf_make_inst { if build_prep $1 $2 $3 ; then $4 logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIX "${@:5}" log1 make $MAKE_OPT log2 make install log2 make clean build_post fi } # ------------------------------------------------------------------------------ # Install all files given by a glob pattern to a given folder # # parameters # $1 glob pattern (in '') # $2 target folder # ------------------------------------------------------------------------------ function install_glob { # Check if any files matching the pattern exist if [ "$(echo $1)" != "$1" ] ; then install -D -t $2 $1 fi } # ------------------------------------------------------------------------------ # Recursively Install all files given by a glob pattern to a given folder # # parameters # $1 source path # $2 pattern (in '') # $3 target folder # ------------------------------------------------------------------------------ function install_rec { ( cd $1 && find -type f -name "$2" -exec install -D -T $1/{} $3/{} \; ) } # ------------------------------------------------------------------------------ # Write a file list of the target folder # The file lists are used to create file lists for the windows installer # # parameters # $1 name of file list # ------------------------------------------------------------------------------ function list_files { if [ ! -e "/build/filelists/$1" ] ; then ( cd $PREFIXCOQ && find -type f | sort > /build/filelists/$1 ) fi } # ------------------------------------------------------------------------------ # Compute the set difference of two file lists # # parameters # $1 name of list A-B (set difference of set A minus set B) # $2 name of list A # $3 name of list B # ------------------------------------------------------------------------------ function diff_files { # See http://www.catonmat.net/blog/set-operations-in-unix-shell/ for file list set operations comm -23 <(sort "/build/filelists/$2") <(sort "/build/filelists/$3") > "/build/filelists/$1" } # ------------------------------------------------------------------------------ # Filter a list of files with a regular expression # # parameters # $1 name of output file list # $2 name of input file list # $3 name of filter regexp # ------------------------------------------------------------------------------ function filter_files { egrep "$3" "/build/filelists/$2" > "/build/filelists/$1" } # ------------------------------------------------------------------------------ # Convert a file list to NSIS installer format # # parameters # $1 name of file list file (output file is the same with extension .nsi) # ------------------------------------------------------------------------------ function files_to_nsis { # Split the path in the file list into path and filename and create SetOutPath and File instructions # Note: File /oname cannot be used, because it does not create the paths as SetOutPath does # Note: I didn't check if the redundant SetOutPath instructions have a bad impact on installer size or install time cat "/build/filelists/$1" | tr '/' '\\' | sed -r 's/^\.(.*)\\([^\\]+)$/SetOutPath $INSTDIR\\\1\nFile ${COQ_SRC_PATH}\\\1\\\2/' > "/build/filelists/$1.nsh" } ###################### MODULE BUILD FUNCTIONS ##################### ##### LIBPNG ##### function make_libpng { build_conf_make_inst http://prdownloads.sourceforge.net/libpng libpng-1.6.18 tar.gz true } ##### PIXMAN ##### function make_pixman { build_conf_make_inst http://cairographics.org/releases pixman-0.32.8 tar.gz true } ##### FREETYPE ##### function make_freetype { build_conf_make_inst http://sourceforge.net/projects/freetype/files/freetype2/2.6.1 freetype-2.6.1 tar.bz2 true } ##### EXPAT ##### function make_expat { build_conf_make_inst http://sourceforge.net/projects/expat/files/expat/2.1.0 expat-2.1.0 tar.gz true } ##### FONTCONFIG ##### function make_fontconfig { make_freetype make_expat # CONFIGURE PARAMETERS # build/install fails without --disable-docs build_conf_make_inst http://www.freedesktop.org/software/fontconfig/release fontconfig-2.11.94 tar.gz true --disable-docs } ##### ICONV ##### function make_libiconv { build_conf_make_inst http://ftp.gnu.org/pub/gnu/libiconv libiconv-1.14 tar.gz true } ##### UNISTRING ##### function make_libunistring { build_conf_make_inst http://ftp.gnu.org/gnu/libunistring libunistring-0.9.5 tar.xz true } ##### NCURSES ##### function make_ncurses { # NOTE: ncurses is not required below. This is just kept for documentary purposes in case I need it later. # # NOTE: make install fails building the terminfo database because # : ${TIC_PATH:=unknown} in run_tic.sh # As a result pkg-config .pc files are not generated # Also configure of gettext gives two "considers" # checking where terminfo library functions come from... not found, consider installing GNU ncurses # checking where termcap library functions come from... not found, consider installing GNU ncurses # gettext make/make install work anyway # # CONFIGURE PARAMETERS # --enable-term-driver --enable-sp-funcs is rewuired for mingw (see README.MinGW) # additional changes # ADD --with-pkg-config # ADD --enable-pc-files # ADD --without-manpages # REM --with-pthread build_conf_make_inst http://ftp.gnu.org/gnu/ncurses ncurses-5.9 tar.gz true --disable-home-terminfo --enable-reentrant --enable-sp-funcs --enable-term-driver --enable-interop --with-pkg-config --enable-pc-files --without-manpages } ##### GETTEXT ##### function make_gettext { # Cygwin packet dependencies: (not 100% sure) libiconv-devel,libunistring-devel,libncurses-devel # Cygwin packet dependencies for gettext users: (not 100% sure) gettext-devel,libgettextpo-devel # gettext configure complains that ncurses is also required, but it builds without it # Ncurses is tricky to install/configure for mingw64, so I dropped ncurses make_libiconv make_libunistring build_conf_make_inst http://ftp.gnu.org/pub/gnu/gettext gettext-0.19 tar.gz true } ##### LIBFFI ##### function make_libffi { # NOTE: The official download server is down ftp://sourceware.org/pub/libffi/libffi-3.2.1.tar.gz build_conf_make_inst http://www.mirrorservice.org/sites/sourceware.org/pub/libffi libffi-3.2.1 tar.gz true } ##### LIBEPOXY ##### function make_libepoxy { build_conf_make_inst https://github.com/anholt/libepoxy/releases/download/v1.3.1 libepoxy-1.3.1 tar.bz2 true } ##### LIBPCRE ##### function make_libpcre { build_conf_make_inst ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre pcre-8.39 tar.bz2 true } function make_libpcre2 { build_conf_make_inst ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre pcre2-10.22 tar.bz2 true } ##### GLIB ##### function make_glib { # Cygwin packet dependencies: mingw64-x86_64-zlib make_gettext make_libffi make_libpcre # build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/glib/2.46 glib-2.46.0 tar.xz true build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/glib/2.47 glib-2.47.5 tar.xz true } ##### ATK ##### function make_atk { make_gettext make_glib build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/atk/2.18 atk-2.18.0 tar.xz true } ##### PIXBUF ##### function make_gdk-pixbuf { # Cygwin packet dependencies: mingw64-x86_64-zlib make_libpng make_gettext make_glib # CONFIGURE PARAMETERS # --with-included-loaders=yes statically links the image file format handlers # This avoids "Cannot open pixbuf loader module file '/usr/x86_64-w64-mingw32/sys-root/mingw/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache': No such file or directory" build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/gdk-pixbuf/2.32 gdk-pixbuf-2.32.1 tar.xz true --with-included-loaders=yes } ##### CAIRO ##### function make_cairo { # Cygwin packet dependencies: mingw64-x86_64-zlib make_libpng make_glib make_pixman make_fontconfig build_conf_make_inst http://cairographics.org/releases cairo-1.14.2 tar.xz true } ##### PANGO ##### function make_pango { make_cairo make_glib make_fontconfig build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/pango/1.38 pango-1.38.0 tar.xz true } ##### GTK2 ##### function patch_gtk2 { rm gtk/gtk.def } function make_gtk2 { # Cygwin packet dependencies: gtk-update-icon-cache if [ "$GTK_FROM_SOURCES" == "Y" ]; then make_glib make_atk make_pango make_gdk-pixbuf make_cairo build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/2.24 gtk+-2.24.28 tar.xz patch_gtk2 fi } ##### GTK3 ##### function make_gtk3 { make_glib make_atk make_pango make_gdk-pixbuf make_cairo make_libepoxy build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/3.16 gtk+-3.16.7 tar.xz true # make all incl. tests and examples runs through fine # make install fails with issue with # # make[5]: Entering directory '/home/soegtrop/GTK/gtk+-3.16.7/demos/gtk-demo' # test -n "" || ../../gtk/gtk-update-icon-cache --ignore-theme-index --force "/usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor" # gtk-update-icon-cache.exe: Failed to open file /usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor/.icon-theme.cache : No such file or directory # Makefile:1373: recipe for target 'install-update-icon-cache' failed # make[5]: *** [install-update-icon-cache] Error 1 # make[5]: Leaving directory '/home/soegtrop/GTK/gtk+-3.16.7/demos/gtk-demo' } ##### LIBXML2 ##### function make_libxml2 { # Cygwin packet dependencies: libtool automake # Note: latest release version 2.9.2 fails during configuring lzma, so using 2.9.1 # Note: python binding requires which doesn't exist on cygwin if build_prep https://git.gnome.org/browse/libxml2/snapshot libxml2-2.9.1 tar.xz ; then # ./autogen.sh --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIX --disable-shared --without-python # shared library required by gtksourceview ./autogen.sh --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIX --without-python log1 make $MAKE_OPT all log2 make install log2 make clean build_post fi } ##### GTK-SOURCEVIEW2 ##### function make_gtk_sourceview2 { # Cygwin packet dependencies: intltool # gtksourceview-2.11.2 requires GTK2 # gtksourceview-2.91.9 requires GTK3 # => We use gtksourceview-2.11.2 which seems to be the newest GTK2 based one if [ "$GTK_FROM_SOURCES" == "Y" ]; then make_gtk2 make_libxml2 build_conf_make_inst https://download.gnome.org/sources/gtksourceview/2.11 gtksourceview-2.11.2 tar.bz2 true fi } ##### FLEXDLL FLEXLINK ##### # Note: there is a circular dependency between flexlink and ocaml (resolved in Ocaml 4.03.) # For MinGW it is not even possible to first build an Ocaml without flexlink support, # Because Makefile.nt doesn't support this. So we have to use a binary flexlink. # One could of cause do a bootstrap run ... # Install flexdll objects function install_flexdll { cp flexdll.h /usr/$TARGET_ARCH/sys-root/mingw/include if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then cp flexdll*_mingw.o /usr/$TARGET_ARCH/bin cp flexdll*_mingw.o $PREFIXOCAML/bin elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then cp flexdll*_mingw64.o /usr/$TARGET_ARCH/bin cp flexdll*_mingw64.o $PREFIXOCAML/bin else echo "Unknown target architecture" return 1 fi } # Install flexlink function install_flexlink { cp flexlink.exe /usr/$TARGET_ARCH/bin cp flexlink.exe $PREFIXOCAML/bin } # Get binary flexdll flexlink for building OCaml # An alternative is to first build an OCaml without shared library support and build flexlink with it function get_flex_dll_link_bin { if build_prep http://alain.frisch.fr/flexdll flexdll-bin-0.34 zip 1 ; then install_flexdll install_flexlink build_post fi } # Build flexdll and flexlink from sources after building OCaml function make_flex_dll_link { if build_prep http://alain.frisch.fr/flexdll flexdll-0.34 tar.gz ; then if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then log1 make $MAKE_OPT build_mingw flexlink.exe elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then log1 make $MAKE_OPT build_mingw64 flexlink.exe else echo "Unknown target architecture" return 1 fi install_flexdll install_flexlink log2 make clean build_post fi } ##### LN replacement ##### # Note: this does support symlinks, but symlinks require special user rights on Windows. # ocamlbuild uses symlinks to link the executables in the build folder to the base folder. # For this purpose hard links are better. function make_ln { if [ ! -f flagfiles/myln.finished ] ; then touch flagfiles/myln.started mkdir -p myln cd myln cp $PATCHES/ln.c . $TARGET_ARCH-gcc -DUNICODE -D_UNICODE -DIGNORE_SYMBOLIC -mconsole -o ln.exe ln.c install -D ln.exe $PREFIXCOQ/bin/ln.exe cd .. touch flagfiles/myln.finished fi } ##### OCAML ##### function make_ocaml { get_flex_dll_link_bin if build_prep http://caml.inria.fr/pub/distrib/ocaml-4.02 ocaml-4.02.3 tar.gz 1 ; then # if build_prep http://caml.inria.fr/pub/distrib/ocaml-4.01 ocaml-4.01.0 tar.gz 1 ; then # See README.win32 cp config/m-nt.h config/m.h cp config/s-nt.h config/s.h if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then cp config/Makefile.mingw config/Makefile elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then cp config/Makefile.mingw64 config/Makefile else echo "Unknown target architecture" return 1 fi # Prefix is fixed in make file - replace it with the real one sed -i "s|^PREFIX=.*|PREFIX=$PREFIXOCAML|" config/Makefile # We don't want to mess up Coq's dirctory structure so put the OCaml library in a separate folder # If we refer to the make variable ${PREFIX} below, camlp4 ends up having a wrong path: # D:\bin\coq64_buildtest_abs_ocaml4\bin>ocamlc -where => D:/bin/coq64_buildtest_abs_ocaml4/libocaml # D:\bin\coq64_buildtest_abs_ocaml4\bin>camlp4 -where => ${PREFIX}/libocaml\camlp4 # So we put an explicit path in there sed -i "s|^LIBDIR=.*|LIBDIR=$PREFIXOCAML/libocaml|" config/Makefile # Note: ocaml doesn't support -j 8, so don't pass MAKE_OPT # I verified that 4.02.3 still doesn't support parallel build log2 make world -f Makefile.nt log2 make bootstrap -f Makefile.nt log2 make opt -f Makefile.nt log2 make opt.opt -f Makefile.nt log2 make install -f Makefile.nt # TODO log2 make clean -f Makefile.nt Temporarily disabled for ocamlbuild development # Move license files and other into into special folder if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then mkdir -p $PREFIXOCAML/license_readme/ocaml # 4.01 installs these files, 4.02 doesn't. So delete them and copy them from the sources. rm -f *.txt cp LICENSE $PREFIXOCAML/license_readme/ocaml/License.txt cp INSTALL $PREFIXOCAML/license_readme/ocaml/Install.txt cp README $PREFIXOCAML/license_readme/ocaml/ReadMe.txt cp README.win32 $PREFIXOCAML/license_readme/ocaml/ReadMeWin32.txt cp VERSION $PREFIXOCAML/license_readme/ocaml/Version.txt cp Changes $PREFIXOCAML/license_readme/ocaml/Changes.txt fi build_post fi make_flex_dll_link } ##### FINDLIB Ocaml library manager ##### function make_findlib { make_ocaml if build_prep http://download.camlcity.org/download findlib-1.5.6 tar.gz 1 ; then ./configure -bindir $PREFIXOCAML\\bin -sitelib $PREFIXOCAML\\libocaml\\site-lib -config $PREFIXOCAML\\etc\\findlib.conf # Note: findlib doesn't support -j 8, so don't pass MAKE_OPT log2 make all log2 make opt log2 make install log2 make clean build_post fi } ##### MENHIR Ocaml Parser Generator ##### function make_menhir { make_ocaml make_findlib # if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20151112 tar.gz 1 ; then # For Ocaml 4.02 # if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20151012 tar.gz 1 ; then # For Ocaml 4.01 if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20140422 tar.gz 1 ; then # Note: menhir doesn't support -j 8, so don't pass MAKE_OPT log2 make all PREFIX=$PREFIXOCAML log2 make install PREFIX=$PREFIXOCAML mv $PREFIXOCAML/bin/menhir $PREFIXOCAML/bin/menhir.exe build_post fi } ##### CAMLP4 Ocaml Preprocessor ##### function make_camlp4 { # OCaml up to 4.01 includes camlp4, from 4.02 it isn't included # Check if command camlp4 exists, if not build camlp4 if ! command camlp4 ; then make_ocaml make_findlib if build_prep https://github.com/ocaml/camlp4/archive 4.02+6 tar.gz 1 camlp4-4.02+6 ; then # See https://github.com/ocaml/camlp4/issues/41#issuecomment-112018910 logn configure ./configure # Note: camlp4 doesn't support -j 8, so don't pass MAKE_OPT log2 make all log2 make install log2 make clean build_post fi fi } ##### CAMLP5 Ocaml Preprocessor ##### function make_camlp5 { make_ocaml make_findlib if build_prep http://camlp5.gforge.inria.fr/distrib/src camlp5-6.14 tgz 1 ; then logn configure ./configure # Somehow my virus scanner has the boot.new/SAVED directory locked after the move for a second => repeat until success sed -i 's/mv boot.new boot/until mv boot.new boot; do sleep 1; done/' Makefile log1 make world.opt $MAKE_OPT log2 make install # For some reason gramlib.a is not copied, but it is required by Coq cp lib/gramlib.a $PREFIXOCAML/libocaml/camlp5/ log2 make clean build_post fi } ##### LABLGTK Ocaml GTK binding ##### # Note: when rebuilding lablgtk by deleting the .finished file, # also delete \usr\x86_64-w64-mingw32\sys-root\mingw\lib\site-lib # Otherwise make install fails function make_lablgtk { make_ocaml make_findlib make_camlp4 if build_prep https://forge.ocamlcore.org/frs/download.php/1479 lablgtk-2.18.3 tar.gz 1 ; then # configure should be fixed to search for $TARGET_ARCH-pkg-config.exe cp /bin/$TARGET_ARCH-pkg-config.exe bin_special/pkg-config.exe logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIXOCAML # lablgtk shows occasional errors with -j, so don't pass $MAKE_OPT # See https://sympa.inria.fr/sympa/arc/caml-list/2015-10/msg00204.html for the make || true + strip logn make-world-pre make world || true $TARGET_ARCH-strip.exe --strip-unneeded src/dlllablgtk2.dll log2 make world log2 make install log2 make clean build_post fi } ##### Ocaml Stdint ##### function make_stdint { make_ocaml make_findlib if build_prep https://github.com/andrenth/ocaml-stdint/archive 0.3.0 tar.gz 1 Stdint-0.3.0; then # Note: the setup gets the proper install path from ocamlfind, but for whatever reason it wants # to create an empty folder in some folder which defaults to C:\Program Files. # The --preifx overrides this. Id didn't see any files created in /tmp/extra. log_1_3 ocaml setup.ml -configure --prefix /tmp/extra log_1_3 ocaml setup.ml -build log_1_3 ocaml setup.ml -install log_1_3 ocaml setup.ml -clean build_post fi } ##### COQ ##### # Copy one DLLfrom cygwin MINGW packages to Coq install folder function copy_coq_dll { if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then cp /usr/${ARCH}-w64-mingw32/sys-root/mingw/bin/$1 $PREFIXCOQ/bin/$1 fi } # Copy required DLLs from cygwin MINGW packages to Coq install folder function copy_coq_dlls { # HOW TO CREATE THE DLL LIST # With the list empty, after the build/install is finished, open coqide in dependency walker. # See http://www.dependencywalker.com/ # Make sure to use the 32 bit / 64 bit version of depends matching the target architecture. # Select all missing DLLs from the module list, right click "copy filenames" # Delay loaded DLLs from Windows can be ignored (hour-glass icon at begin of line) # Do this recursively until there are no further missing DLLs (File close + reopen) # For running this quickly, just do "cd coq- ; call copy_coq_dlls ; cd .." at the end of this script. # Do the same for coqc and ocamlc (usually doesn't result in additional files) copy_coq_dll LIBATK-1.0-0.DLL copy_coq_dll LIBCAIRO-2.DLL copy_coq_dll LIBEXPAT-1.DLL copy_coq_dll LIBFFI-6.DLL copy_coq_dll LIBFONTCONFIG-1.DLL copy_coq_dll LIBFREETYPE-6.DLL copy_coq_dll LIBGDK-WIN32-2.0-0.DLL copy_coq_dll LIBGDK_PIXBUF-2.0-0.DLL copy_coq_dll LIBGIO-2.0-0.DLL copy_coq_dll LIBGLIB-2.0-0.DLL copy_coq_dll LIBGMODULE-2.0-0.DLL copy_coq_dll LIBGOBJECT-2.0-0.DLL copy_coq_dll LIBGTK-WIN32-2.0-0.DLL copy_coq_dll LIBINTL-8.DLL copy_coq_dll LIBPANGO-1.0-0.DLL copy_coq_dll LIBPANGOCAIRO-1.0-0.DLL copy_coq_dll LIBPANGOWIN32-1.0-0.DLL copy_coq_dll LIBPIXMAN-1-0.DLL copy_coq_dll LIBPNG16-16.DLL copy_coq_dll LIBXML2-2.DLL copy_coq_dll ZLIB1.DLL # Depends on if GTK is built from sources if [ "$GTK_FROM_SOURCES" == "Y" ]; then copy_coq_dll libiconv-2.dll copy_coq_dll libpcre-1.dll else copy_coq_dll ICONV.DLL copy_coq_dll LIBBZ2-1.DLL copy_coq_dll LIBGTKSOURCEVIEW-2.0-0.DLL copy_coq_dll LIBHARFBUZZ-0.DLL copy_coq_dll LIBLZMA-5.DLL copy_coq_dll LIBPANGOFT2-1.0-0.DLL fi; # Architecture dependent files case $ARCH in x86_64) copy_coq_dll LIBGCC_S_SEH-1.DLL ;; i686) copy_coq_dll LIBGCC_S_SJLJ-1.DLL ;; *) false ;; esac # Win pthread version change copy_coq_dll LIBWINPTHREAD-1.DLL } function copy_coq_objects { # copy objects only from folders which exist in the target lib directory find . -type d | while read FOLDER ; do if [ -e $PREFIXCOQ/lib/$FOLDER ] ; then install_glob $FOLDER/'*.cmxa' $PREFIXCOQ/lib/$FOLDER install_glob $FOLDER/'*.cmi' $PREFIXCOQ/lib/$FOLDER install_glob $FOLDER/'*.cma' $PREFIXCOQ/lib/$FOLDER install_glob $FOLDER/'*.cmo' $PREFIXCOQ/lib/$FOLDER install_glob $FOLDER/'*.a' $PREFIXCOQ/lib/$FOLDER install_glob $FOLDER/'*.o' $PREFIXCOQ/lib/$FOLDER fi done } # Copy required GTK config and suport files function copq_coq_gtk { echo 'gtk-theme-name = "MS-Windows"' > $PREFIX/etc/gtk-2.0/gtkrc echo 'gtk-fallback-icon-theme = "Tango"' >> $PREFIX/etc/gtk-2.0/gtkrc if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then install_glob $PREFIX/etc/gtk-2.0/'*' $PREFIXCOQ/gtk-2.0 install_glob $PREFIX/share/gtksourceview-2.0/language-specs/'*' $PREFIXCOQ/share/gtksourceview-2.0/language-specs install_glob $PREFIX/share/gtksourceview-2.0/styles/'*' $PREFIXCOQ/share/gtksourceview-2.0/styles install_rec $PREFIX/share/themes/ '*' $PREFIXCOQ/share/themes # This below item look like a bug in make install if [[ ! $COQ_VERSION == 8.4* ]] ; then mv $PREFIXCOQ/share/coq/*.lang $PREFIXCOQ/share/gtksourceview-2.0/language-specs mv $PREFIXCOQ/share/coq/*.xml $PREFIXCOQ/share/gtksourceview-2.0/styles fi mkdir -p $PREFIXCOQ/ide mv $PREFIXCOQ/share/coq/*.png $PREFIXCOQ/ide rmdir $PREFIXCOQ/share/coq fi } # Copy license and other info files function copy_coq_license { if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then install -D doc/LICENSE $PREFIXCOQ/license_readme/coq/LicenseDoc.txt install -D LICENSE $PREFIXCOQ/license_readme/coq/License.txt install -D plugins/micromega/LICENSE.sos $PREFIXCOQ/license_readme/coq/LicenseMicromega.txt install -D README $PREFIXCOQ/license_readme/coq/ReadMe.txt || true install -D README.md $PREFIXCOQ/license_readme/coq/ReadMe.md || true install -D README.doc $PREFIXCOQ/license_readme/coq/ReadMeDoc.txt install -D CHANGES $PREFIXCOQ/license_readme/coq/Changes.txt install -D INSTALL $PREFIXCOQ/license_readme/coq/Install.txt install -D INSTALL.doc $PREFIXCOQ/license_readme/coq/InstallDoc.txt install -D INSTALL.ide $PREFIXCOQ/license_readme/coq/InstallIde.txt fi } # Main function for creating Coq function make_coq { make_ocaml make_lablgtk make_camlp5 if case $COQ_VERSION in git-*) build_prep https://github.com/coq/coq/archive ${COQ_VERSION##git-} zip 1 coq-${COQ_VERSION} ;; *) build_prep https://coq.inria.fr/distrib/V$COQ_VERSION/files coq-$COQ_VERSION tar.gz ;; esac then if [ "$INSTALLMODE" == "relocatable" ]; then # HACK: for relocatable builds, first configure with ./, then build but before install reconfigure with the real target path logn configure ./configure -debug -with-doc no -prefix ./ -libdir ./lib -mandir ./man elif [ "$INSTALLMODE" == "absolute" ]; then logn configure ./configure -debug -with-doc no -prefix $PREFIXCOQ -libdir $PREFIXCOQ/lib -mandir $PREFIXCOQ/man else logn configure ./configure -debug -with-doc no -prefix $PREFIXCOQ fi # The windows resource compiler binary name is hard coded sed -i "s/i686-w64-mingw32-windres/$TARGET_ARCH-windres/" Makefile.build sed -i "s/i686-w64-mingw32-windres/$TARGET_ARCH-windres/" Makefile.ide || true # 8.4x doesn't support parallel make if [[ $COQ_VERSION == 8.4* ]] ; then log1 make else log1 make $MAKE_OPT fi if [ "$INSTALLMODE" == "relocatable" ]; then ./configure -debug -with-doc no -prefix $PREFIXCOQ -libdir $PREFIXCOQ/lib -mandir $PREFIXCOQ/man fi log2 make install log1 copy_coq_dlls if [ "$INSTALLOCAML" == "Y" ]; then log1 copy_coq_objects fi copq_coq_gtk copy_coq_license # make clean seems to br broken for 8.5pl2 # 1.) find | xargs fails on cygwin, can be fixed by sed -i 's|\| xargs rm -f|-exec rm -fv \{\} \+|' Makefile # 2.) clean of test suites fails with "cannot run complexity tests (no bogomips found)" # make clean build_post fi } ##### GNU Make for MinGW ##### function make_mingw_make { if build_prep http://ftp.gnu.org/gnu/make make-4.2 tar.bz2 ; then # The config.h.win32 file is fine - don't edit it # We need to copy the mingw gcc here as "gcc" - then the batch file will use it cp /usr/bin/${ARCH}-w64-mingw32-gcc-5.4.0.exe ./gcc.exe # By some magic cygwin bash can run batch files logn build ./build_w32.bat gcc # Copy make to Coq folder cp GccRel/gnumake.exe $PREFIXCOQ/bin/make.exe build_post fi } ##### GNU binutils for native OCaml ##### function make_binutils { if build_prep http://ftp.gnu.org/gnu/binutils binutils-2.27 tar.gz ; then logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIXCOQ --program-prefix=$TARGET- log1 make $MAKE_OPT log2 make install # log2 make clean build_post fi } ##### GNU GCC for native OCaml ##### function make_gcc { # Note: the bz2 file is smaller, but decompressing bz2 really takes ages if build_prep ftp://ftp.fu-berlin.de/unix/languages/gcc/releases/gcc-5.4.0 gcc-5.4.0 tar.gz ; then # This is equivalent to "contrib/download_prerequisites" but uses caching # Update versions when updating gcc version get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure mpfr-2.4.2 tar.bz2 1 mpfr-2.4.2 mpfr get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure gmp-4.3.2 tar.bz2 1 gmp-4.3.2 gmp get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure mpc-0.8.1 tar.gz 1 mpc-0.8.1 mpc get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure isl-0.14 tar.bz2 1 isl-0.14 isl # For whatever reason gcc needs this (although it never puts anything into it) # Error: "The directory that should contain system headers does not exist:" # mkdir -p /mingw/include without --with-sysroot mkdir -p $PREFIXCOQ/mingw/include # See https://gcc.gnu.org/install/configure.html logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET \ --prefix=$PREFIXCOQ --program-prefix=$TARGET- --disable-win32-registry --with-sysroot=$PREFIXCOQ \ --enable-languages=c --disable-nls \ --disable-libsanitizer --disable-libssp --disable-libquadmath --disable-libgomp --disable-libvtv --disable-lto # --disable-decimal-float seems to be required # --with-sysroot=$PREFIX results in configure error that this is not an absolute path log1 make $MAKE_OPT log2 make install # log2 make clean build_post fi } ##### Get sources for Cygwin MinGW packages ##### function get_cygwin_mingw_sources { if [ ! -f flagfiles/cygwin_mingw_sources.finished ] ; then touch flagfiles/cygwin_mingw_sources.started # Find all installed files with mingw in the name and download the corresponding source code file from cygwin # Steps: # grep /etc/setup/installed.db for mingw => mingw64-x86_64-gcc-g++ mingw64-x86_64-gcc-g++-5.4.0-2.tar.bz2 1 # remove archive ending and trailing number => mingw64-x86_64-gcc-g++ mingw64-x86_64-gcc-g++-5.4.0-2 # replace space with / => ${ARCHIVE} = mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g++-5.4.0-2 # escape + signs using ${var//pattern/replace} => ${ARCHIVEESC} = mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g\+\+-5.4.0-2 # grep cygwin setup.ini for installed line + next line (the -A 1 option includes and "after context" of 1 line) # Note that the folders of the installed binaries and source are different. So we cannot grep just for the source line. # We could strip off the path and just grep for the file, though. # => install: x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g++-5.4.0-2.tar.xz 10163848 2f8cb7ba3e16ac8ce0455af01de490ded09061b1b06a9a8e367426635b5a33ce230e04005f059d4ea7b52580757da1f6d5bae88eba6b9da76d1bd95e8844b705 # source: x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-5.4.0-2-src.tar.xz 95565368 03f22997b7173b243fff65ea46a39613a2e4e75fc7e6cf0fa73b7bcb86071e15ba6d0ca29d330c047fb556a5e684cad57cd2f5adb6e794249e4b01fe27f92c95 # Take the 2nd field of the last line => ${SOURCE} = x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-5.4.0-2-src.tar.xz # Remove that path part => ${SOURCEFILE} = mingw64-x86_64-gcc-5.4.0-2-src.tar.xz grep "mingw" /etc/setup/installed.db | sed 's/\.tar\.bz2 [0-1]$//' | sed 's/ /\//' | while read ARCHIVE ; do local ARCHIVEESC=${ARCHIVE//+/\\+} local SOURCE=`egrep -A 1 "install: ($CYGWINARCH|noarch)/release/[-+_/a-z0-9]*$ARCHIVEESC" $TARBALLS/setup.ini | tail -1 | cut -d " " -f 2` local SOURCEFILE=${SOURCE##*/} # Get the source file (either from the source cache or online) if [ ! -f $TARBALLS/$SOURCEFILE ] ; then if [ -f $SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE ] ; then cp $SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE $TARBALLS else wget "$CYGWIN_REPOSITORY/$SOURCE" mv $SOURCEFILE $TARBALLS # Save the source archive in the source cache if [ -d $SOURCE_LOCAL_CACHE_CFMT ] ; then cp $TARBALLS/$SOURCEFILE $SOURCE_LOCAL_CACHE_CFMT fi fi fi done touch flagfiles/cygwin_mingw_sources.finished fi } ##### Coq Windows Installer ##### function make_coq_installer { make_coq make_mingw_make get_cygwin_mingw_sources # Prepare the file lists for the installer. We created to file list dumps of the target folder during the build: # ocaml: ocaml + menhir + camlp5 + findlib # ocal_coq: as above + coq # Create coq file list as ocaml_coq / ocaml diff_files coq ocaml_coq ocaml # Filter out object files filter_files coq_objects coq '\.(cmxa|cmi|cma|cmo|a|o)$' # Filter out plugin object files filter_files coq_objects_plugins coq_objects '/lib/plugins/.*\.(cmxa|cmi|cma|cmo|a|o)$' # Coq objects objects required for plugin development = coq objects except those for pre installed plugins diff_files coq_plugindev coq_objects coq_objects_plugins # Coq files, except objects needed only for plugin development diff_files coq_base coq coq_plugindev # Convert section files to NSIS format files_to_nsis coq_base files_to_nsis coq_plugindev files_to_nsis ocaml # Get and extract NSIS Binaries if build_prep http://downloads.sourceforge.net/project/nsis/NSIS%202/2.51 nsis-2.51 zip ; then NSIS=`pwd`/makensis.exe chmod u+x "$NSIS" # Change to Coq folder cd ../coq-${COQ_VERSION} # Copy patched nsi file cp ../patches/coq_new.nsi dev/nsis cp ../patches/StrRep.nsh dev/nsis cp ../patches/ReplaceInFile.nsh dev/nsis VERSION=`grep ^VERSION= config/Makefile | cut -d = -f 2` cd dev/nsis logn nsis-installer "$NSIS" -DVERSION=$VERSION -DARCH=$ARCH -DCOQ_SRC_PATH=$PREFIXCOQ -DCOQ_ICON=..\\..\\ide\\coq.ico coq_new.nsi build_post fi } ###################### TOP LEVEL BUILD ##################### make_gtk2 make_gtk_sourceview2 make_ocaml make_findlib make_lablgtk make_camlp4 make_camlp5 make_menhir make_stdint list_files ocaml make_coq if [ "$INSTALLMAKE" == "Y" ] ; then make_mingw_make fi list_files ocaml_coq if [ "$MAKEINSTALLER" == "Y" ] ; then make_coq_installer fi coq-8.6/dev/build/windows/MakeCoq_86beta1_abs_ocaml.bat0000644000175000017500000000034413022274260022271 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -mode=absolute ^ -ocaml=Y ^ -make=Y ^ -coqver=8.6beta1 ^ -destcyg=%ROOTPATH%\cygwin_coq64_86beta1_abs ^ -destcoq=%ROOTPATH%\coq64_86beta1_abs coq-8.6/dev/build/windows/MakeCoq_86_installer_32.bat0000644000175000017500000000027213022274260021735 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=32 ^ -installer=Y ^ -coqver=8.6 ^ -destcyg=%ROOTPATH%\cygwin_coq32_86_inst ^ -destcoq=%ROOTPATH%\coq32_86_inst coq-8.6/dev/build/windows/ReadMe.txt0000644000175000017500000004166013022274260016733 0ustar mdenesmdenes==================== Purpose / Goal ==================== The main purpose of these scripts is to build Coq for Windows in a reproducible and at least by this script documented way without using binary libraries and executables from various sources. These scripts use only MinGW libraries provided by Cygwin or compile things from sources. For some libraries there are options to build them from sources or to use the Cygwin version. Another goal (which is not yet achieved) is to have a Coq installer for Windows, which includes all tools required for native compute and Coq plugin development without Cygwin. Coq requires OCaml for this and OCaml requires binutils, gcc and a posix shell. Since the standard Windows OCaml installation requires Cygwin to deliver some of these components, you might be able to imagine that this is not so easy. These scripts can produce the following: - Coq running on MinGW - OCaml producing MinGW code and running on MinGW - GCC producing MinGW code and running on MinGW - binutils producing MinGW code and running on MinGW With "running on MinGW" I mean that the tools accept paths like "C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys DLL. The MinGW gcc and binutils provided by Cygwin produce MinGW code, but they run only on Cygwin. With "producing MinGW code" I mean that the programs created by the tools accept paths like "C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys DLL. The missing piece is a posix shell running on plain Windows (without msys or Cygwin DLL) and not beeing a binary from obscure sources. I am working on it ... Since compiling gcc and binutils takes a while and it is not of much use without a shell, the building of these components is currently disabled. OCaml is built anyway, because this MinGW/MinGW OCaml (rather than a Cygwin/MinGW OCaml) is used to compile Coq. Until the shell is there, the Cygwin created by these scripts is required to run OCaml tools. When everything is finished, this will no longer be required. ==================== Usage ==================== The Script MakeCoq_MinGW does: - download Cygwin (except the Setup.exe or Setup64.exe) - install Cygwin - either installs MinGW GTK via Cygwin or compiles it fom sources - download, compile and install OCaml, CamlP5, Menhir, lablgtk - download, compile and install Coq - create a Windows installer (NSIS based) The parameters are described below. Mostly paths and the HTTP proxy need to be set. There are two main usages: - Compile and install OCaml and Coq in a given folder This works reliably, because absolute library paths can be compiled into Coq and OCaml. WARNING: See the "Purpose / Goal" section above for status. See MakeCoq_85pl2_abs_ocaml.bat for parameters. - Create a Windows installer. This works well for Coq but not so well for OCaml. WARNING: See the "Purpose / Goal" section above for status. See MakeCoq_85pl2_installer.bat for parameters. There is also an option to compile OCaml and Coq inside Cygwin, but this is currently not recommended. The resulting Coq and OCaml work, but Coq is slow because it scans the largish Cygwin share folder. This will be fixed in a future version. Procedure: - Unzip contents of CoqSetup.zip in a folder - Adjust parameters in MakeCoq_85pl2_abs_ocaml.bat or in MakeCoq_85pl2_installer.bat. - Download Cygwin setup from https://Cygwin.com/install.html For 32 bit Coq : setup-x86.exe (https://Cygwin.com/setup-x86.exe) For 64 bit Coq : setup-x86_64.exe (https://Cygwin.com/setup-x86_64.exe) - Run MakeCoq_85pl3_abs_ocaml.bat or MakeCoq_85pl3_installer.bat - Check MakeCoq_regtests.bat to see what combinations of options are tested ==================== MakeCoq_MinGW Parameters ==================== ===== -arch ===== Set the target architecture. Possible values: 32: Install/build Cygwin, ocaml and coq for 32 bit windows 64: Install/build Cygwin, ocaml and coq for 64 bit windows Default value: 64 ===== -mode ===== Set the installation mode / target folder structure. Possible values: mingwinCygwin: Install coq in the default Cygwin mingw sysroot folder. This is %DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw. Todo: The coq share folder should be configured to e.g. /share/coq. As is, coqc scans the complete share folder, which slows it down 5x for short files. absoloute: Install coq in the absolute path given with -destcoq. The resulting Coq will not be relocatable. That is the root folder must not be renamed/moved. relocatable: Install coq in the absolute path given with -destcoq. The resulting Coq will be relocatable. That is the root folder may be renamed/moved. If OCaml is installed, please note that OCaml cannot be build really relocatable. If the root folder is moved, the environment variable OCAMLLIB must be set to the libocaml sub folder. Also the file \libocaml\ld.conf must be adjusted. Default value: absolute ===== -installer ===== Create a Windows installer (it will be in build/coq-8.xplx/dev/nsis) Possible values: Y: Create a windows installer - this forces -mode=relocatable. N: Don't create a windows installer - use the created Coq installation as is. Default value: N ===== -ocaml ===== Install OCaml for later use with Coq or just for building. Possible values: Y: Install OCaml in the same root as Coq (as given with -coqdest) This also copies all .o, .cmo, .a, .cmxa files in the lib folder required for compiling plugins. N: Install OCaml in the default Cygwin mingw sysroot folder. This is %DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw. Default value: N ===== -make ===== Build and install MinGW GNU make Possible values: Y: Install MinGW GNU make in the same root as Coq (as given with -coqdest). N: Don't build or install MinGW GNU make. For building everything always Cygwin GNU make is used. Default value: Y ===== -destcyg ===== Destination folder in which Cygwin is installed. This must be an absolute path in Windows format (with drive letter and \\). >>>>> This folder may be deleted after the Coq build is finished! <<<<< Default value: C:\bin\Cygwin_coq ===== -destcoq ===== Destination folder in which Coq is installed. This must be an absolute path in Windows format (with drive letter and \\). This option is not required if -mode mingwinCygwin is used. Default value: C:\bin\coq ===== -setup ===== Name/path of the Cygwin setup program. The Cygwin setup program is called setup-x86.exe or setup-x86_64.exe. It can be downloaded from: https://Cygwin.com/install.html. Default value: setup-x86.exe or setup-x86_64.exe, depending on -arch. ===== -proxy ===== Internet proxy setting for downloading Cygwin, ocaml and coq. The format is :, e.g. proxy.mycompany.com:911 The same proxy is used for HTTP, HTTPS and FTP. If you need separate proxies for separate protocols, you please put your proxies directly into configure_profile.sh (line 11..13). Default value: Value of HTTP_PROXY environment variable or none if this variable does not exist. ATTENTION: With the --proxy setting of the Cygwin setup, it is possible to supply a proxy server, but if this parameter is "", Cygwin setup might use proxy settings from previous setups. If you once did a Cygwin setup behind a firewall and now want to do a Cygwin setup without a firewall, use the -cygquiet=N setting to perform a GUI install, where you can adjust the proxy setting. ===== -cygrepo ===== The online repository, from which Cygwin packages are downloaded. Note: although most repositories end with Cygwin32, they are good for 32 and 64 bit Cygwin. Default value: http://ftp.inf.tu-dresden.de/software/windows/Cygwin32 >>>>> If you are not in Europe, you might want to change this! <<<<< ===== -cygcache ===== The local cache folder for Cygwin repositories. You can also copy files here from a backup/reference and set -cyglocal. The setup will then not download/update from the internet but only use the local cache. Default value: \Cygwin_cache ===== -cyglocal ===== Control if the Cygwin setup uses the latest version from the internet or the version as is in the local folder. Possible values: Y: Install exactly the Cygwin version from the local repository cache. Don't update from the internet. N: Download the latest Cygwin version from the internet. Update the local repository cache with the latest version. Default value: N ===== -cygquiet ===== Control if the Cygwin setup runs quitely or interactive. Possible values: Y: Install Cygwin quitely without user interaction. N: Install Cygwin interactively (allows to select additional packages). Default value: Y ===== -srccache ===== The local cache folder for ocaml/coq/... sources. Default value: \source_cache ===== -coqver ===== The version of Coq to download and compile. Possible values: 8.4pl6, 8.5pl2, 8.5pl3, git-v8.6 Others might work, but are untested. 8.4 is only tested in mode=absoloute Default value: 8.5pl3 If git- is prepended, the Coq sources are loaded from git. ATTENTION: with default options, the scripts cache source tar balls in two places, the /build/tarballs folder and the /source_cache folder. If you modified something in git, you need to delete the cached tar ball in both places! ===== -gtksrc ===== Control if GTK and its prerequisites are build from sources or if binary MinGW packages from Cygwin are used Possible values: Y: Build GTK from sources, takes about 90 minutes extra. This is useful, if you want to debug/fix GTK or library issues. N: Use prebuilt MinGW libraries from Cygwin ===== -threads ===== Control the maximum number of make threads for modules which support parallel make. Possible values: 1..N. Should not be more than 1.5x the number of cores. Should not be more than available RAM/2GB (e.g. 4 for 8GB) ==================== TODO ==================== - Installer doesn't remove OCAMLLIB environment variables (it is in the script, but doesn't seem to work) - CoqIDE doesn't find theme files - Finish / test mingw_in_Cygwin mode (coqide doesn't start, coqc slow cause of scanning complete share folder) - Possibly create/login as specific user to bash (not sure if it makes sense - nead to create additional bash login link then) - maybe move share/doc/menhir somehwere else (reduces coqc startup time) - Use original installed file list for removing files in uninstaller ==================== Issues with relocation ==================== Coq and OCaml are built in a specific folder and are not really intended for relocation e.g. by an installer. Some absolute paths in config files are patched in coq_new.nsi. Coq is made fairly relocatable by first configuring it with PREFIX=./ and then PREFIX=. OCaml is made relocatable mostly by defining the OCAMLLIB environment variable and by patching some files. If you have issues with one of the remaining (unpatched) files below, please let me know. Text files patched by the installer: ./ocamllib/ld.conf ./etc/findlib.conf:destdir="D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib" ./etc/findlib.conf:path="D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib" Text files containing the install folder path after install: ./bin/mkcamlp5:LIB=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5 ./bin/mkcamlp5.opt:LIB=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5 ./libocaml/Makefile.config:PREFIX=D:/bin/coq64_buildtest_reloc_ocaml20 ./libocaml/Makefile.config:LIBDIR=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml ./libocaml/site-lib/findlib/Makefile.config:OCAML_CORE_BIN=/cygdrive/d/bin/coq64_buildtest_reloc_ocaml20/bin ./libocaml/site-lib/findlib/Makefile.config:OCAML_SITELIB=D:/bin/coq64_buildtest_reloc_ocaml20\libocaml\site-lib ./libocaml/site-lib/findlib/Makefile.config:OCAMLFIND_BIN=D:/bin/coq64_buildtest_reloc_ocaml20\bin ./libocaml/site-lib/findlib/Makefile.config:OCAMLFIND_CONF=D:/bin/coq64_buildtest_reloc_ocaml20\etc\findlib.conf ./libocaml/topfind:#directory "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib";; ./libocaml/topfind: Topdirs.dir_load Format.err_formatter "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib.cma"; ./libocaml/topfind: Topdirs.dir_load Format.err_formatter "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma"; ./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib.cma";; *) ./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma";; *) ./man/man1/camlp5.1:These files are installed in the directory D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5. ./man/man1/camlp5.1:D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5 Binary files containing the build folder path after install: $ find . -type f -exec grep "Cygwin_coq64_buildtest_reloc_ocaml20" {} /dev/null \; Binary file ./bin/coqtop.byte.exe matches Binary file ./bin/coqtop.exe matches Binary file ./bin/ocamldoc.exe matches Binary file ./bin/ocamldoc.opt.exe matches Binary file ./libocaml/ocamldoc/odoc_info.a matches Binary file ./libocaml/ocamldoc/odoc_info.cma matches Binary files containing the install folder path after install: $ find . -type f -exec grep "coq64_buildtest_reloc_ocaml20" {} /dev/null \; Binary file ./bin/camlp4.exe matches Binary file ./bin/camlp4boot.exe matches Binary file ./bin/camlp4o.exe matches Binary file ./bin/camlp4o.opt.exe matches Binary file ./bin/camlp4of.exe matches Binary file ./bin/camlp4of.opt.exe matches Binary file ./bin/camlp4oof.exe matches Binary file ./bin/camlp4oof.opt.exe matches Binary file ./bin/camlp4orf.exe matches Binary file ./bin/camlp4orf.opt.exe matches Binary file ./bin/camlp4r.exe matches Binary file ./bin/camlp4r.opt.exe matches Binary file ./bin/camlp4rf.exe matches Binary file ./bin/camlp4rf.opt.exe matches Binary file ./bin/camlp5.exe matches Binary file ./bin/camlp5o.exe matches Binary file ./bin/camlp5o.opt matches Binary file ./bin/camlp5r.exe matches Binary file ./bin/camlp5r.opt matches Binary file ./bin/camlp5sch.exe matches Binary file ./bin/coqc.exe matches Binary file ./bin/coqchk.exe matches Binary file ./bin/coqdep.exe matches Binary file ./bin/coqdoc.exe matches Binary file ./bin/coqide.exe matches Binary file ./bin/coqmktop.exe matches Binary file ./bin/coqtop.byte.exe matches Binary file ./bin/coqtop.exe matches Binary file ./bin/coqworkmgr.exe matches Binary file ./bin/coq_makefile.exe matches Binary file ./bin/menhir matches Binary file ./bin/mkcamlp4.exe matches Binary file ./bin/ocaml.exe matches Binary file ./bin/ocamlbuild.byte.exe matches Binary file ./bin/ocamlbuild.exe matches Binary file ./bin/ocamlbuild.native.exe matches Binary file ./bin/ocamlc.exe matches Binary file ./bin/ocamlc.opt.exe matches Binary file ./bin/ocamldebug.exe matches Binary file ./bin/ocamldep.exe matches Binary file ./bin/ocamldep.opt.exe matches Binary file ./bin/ocamldoc.exe matches Binary file ./bin/ocamldoc.opt.exe matches Binary file ./bin/ocamlfind.exe matches Binary file ./bin/ocamlmklib.exe matches Binary file ./bin/ocamlmktop.exe matches Binary file ./bin/ocamlobjinfo.exe matches Binary file ./bin/ocamlopt.exe matches Binary file ./bin/ocamlopt.opt.exe matches Binary file ./bin/ocamlprof.exe matches Binary file ./bin/ocamlrun.exe matches Binary file ./bin/ocpp5.exe matches Binary file ./lib/config/coq_config.cmo matches Binary file ./lib/config/coq_config.o matches Binary file ./lib/grammar/grammar.cma matches Binary file ./lib/ide/ide_win32_stubs.o matches Binary file ./lib/lib/clib.a matches Binary file ./lib/lib/clib.cma matches Binary file ./lib/libcoqrun.a matches Binary file ./libocaml/camlp4/camlp4fulllib.a matches Binary file ./libocaml/camlp4/camlp4fulllib.cma matches Binary file ./libocaml/camlp4/camlp4lib.a matches Binary file ./libocaml/camlp4/camlp4lib.cma matches Binary file ./libocaml/camlp4/camlp4o.cma matches Binary file ./libocaml/camlp4/camlp4of.cma matches Binary file ./libocaml/camlp4/camlp4oof.cma matches Binary file ./libocaml/camlp4/camlp4orf.cma matches Binary file ./libocaml/camlp4/camlp4r.cma matches Binary file ./libocaml/camlp4/camlp4rf.cma matches Binary file ./libocaml/camlp5/odyl.cma matches Binary file ./libocaml/compiler-libs/ocamlcommon.a matches Binary file ./libocaml/compiler-libs/ocamlcommon.cma matches Binary file ./libocaml/dynlink.cma matches Binary file ./libocaml/expunge.exe matches Binary file ./libocaml/extract_crc.exe matches Binary file ./libocaml/libcamlrun.a matches Binary file ./libocaml/ocamlbuild/ocamlbuildlib.a matches Binary file ./libocaml/ocamlbuild/ocamlbuildlib.cma matches Binary file ./libocaml/ocamldoc/odoc_info.a matches Binary file ./libocaml/ocamldoc/odoc_info.cma matches Binary file ./libocaml/site-lib/findlib/findlib.a matches Binary file ./libocaml/site-lib/findlib/findlib.cma matches Binary file ./libocaml/site-lib/findlib/findlib.cmxs matches coq-8.6/dev/build/windows/MakeCoq_86git_installer2.bat0000644000175000017500000000030713022274260022216 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -installer=Y ^ -coqver=git-v8.6 ^ -destcyg=%ROOTPATH%\cygwin_coq64_86git_inst2 ^ -destcoq=%ROOTPATH%\coq64_86git_inst2 coq-8.6/dev/build/windows/MakeCoq_84pl6_abs_ocaml.bat0000644000175000017500000000033613022274260021775 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -mode=absolute ^ -ocaml=Y ^ -make=Y ^ -coqver=8.4pl6 ^ -destcyg=%ROOTPATH%\cygwin_coq64_84pl6_abs ^ -destcoq=%ROOTPATH%\coq64_84pl6_abs coq-8.6/dev/build/windows/MakeCoq_86git_installer.bat0000644000175000017500000000030513022274260022132 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -installer=Y ^ -coqver=git-v8.6 ^ -destcyg=%ROOTPATH%\cygwin_coq64_86git_inst ^ -destcoq=%ROOTPATH%\coq64_86git_inst coq-8.6/dev/build/windows/MakeCoq_85pl2_abs_ocaml.bat0000644000175000017500000000033613022274260021772 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -mode=absolute ^ -ocaml=Y ^ -make=Y ^ -coqver=8.5pl2 ^ -destcyg=%ROOTPATH%\cygwin_coq64_85pl2_abs ^ -destcoq=%ROOTPATH%\coq64_85pl2_abs coq-8.6/dev/build/windows/MakeCoq_85pl3_installer_32.bat0000644000175000017500000000030313022274260022346 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=32 ^ -installer=Y ^ -coqver=8.5pl3 ^ -destcyg=%ROOTPATH%\cygwin_coq32_85pl3_inst ^ -destcoq=%ROOTPATH%\coq32_85pl3_inst coq-8.6/dev/build/windows/MakeCoq_86git_installer_32.bat0000644000175000017500000000030513022274260022436 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=32 ^ -installer=Y ^ -coqver=git-v8.6 ^ -destcyg=%ROOTPATH%\cygwin_coq32_86git_inst ^ -destcoq=%ROOTPATH%\coq32_86git_inst coq-8.6/dev/build/windows/MakeCoq_85pl3_installer.bat0000644000175000017500000000030313022274260022042 0ustar mdenesmdenescall MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^ -arch=64 ^ -installer=Y ^ -coqver=8.5pl3 ^ -destcyg=%ROOTPATH%\cygwin_coq64_85pl3_inst ^ -destcoq=%ROOTPATH%\coq64_85pl3_inst coq-8.6/dev/doc/0000755000175000017500000000000013022274260013002 5ustar mdenesmdenescoq-8.6/dev/doc/build-system.txt0000644000175000017500000001251613022274260016171 0ustar mdenesmdenes This file documents what a Coq developer needs to know about the build system. If you want to enhance the build system itself (or are curious about its implementation details), see build-system.dev.txt, and in particular its initial HISTORY section. FAQ: special features used in this Makefile ------------------------------------------- * Order-only dependencies: | Dependencies placed after a bar (|) should be built before the current rule, but having one of them is out-of-date do not trigger a rebuild of the current rule. See http://www.gnu.org/software/make/manual/make.htmlPrerequisite-Types * Annotation before commands: +/-/@ a command starting by - is always successful (errors are ignored) a command starting by + is runned even if option -n is given to make a command starting by @ is not echoed before being runned * Custom functions Definition via "define foo" followed by commands (arg is $(1) etc) Call via "$(call foo,arg1)" * Useful builtin functions $(subst ...), $(patsubst ...), $(shell ...), $(foreach ...), $(if ...) * Behavior of -include If the file given to -include doesn't exist, make tries to build it, and even retries again if necessary, but doesn't care if this build finally fails. We used to rely on this "feature", but this should not be the case anymore. We kept "-include" instead of "include" for avoiding warnings about initially non-existant files. Changes (for old-timers) ------------------------ The contents of the old Makefile has been mostly split into: - variable declarations for file lists in Makefile.common. These declarations are now static (for faster Makefile execution), so their definitions are order-dependent. - actual building rules and compiler flags variables in Makefile.build The handling of globals is now: the globals of FOO.v are in FOO.glob and the global glob.dump is created by concatenation of all .glob files. In particular, .glob files are now always created. See also section "cleaning targets" Reducing build system overhead ------------------------------ When you are actively working on a file in a "make a change, make to test, make a change, make to test", etc mode, here are a few tips to save precious time: - Always ask for what you want directly (e.g. bin/coqtop, foo/bar.cmo, ...), don't do "make world" and interrupt it when it has done what you want. For example, if you only want to test whether bin/coqtop still builds (and eventually start it to test your bugfix or new feature), use "make bin/coqtop" or "make coqbinaries" or something like that. - To disable all dependency recalculation, use the NO_RECALC_DEPS=1 option. It disables REcalculation of dependencies, not calculation of dependencies. In other words, if a .d file does not exist, it is still created, but it is not updated every time the source file (e.g. .ml) is changed. Dependencies ------------ There are no dependencies in the archive anymore, they are always bootstrapped. The dependencies of a file FOO are in FOO.d . This enables partial recalculation of dependencies (only the dependencies of changed files are recomputed). If you add a dependency to a Coq camlp4 extension (grammar.cma or q_constr.cmo), then see sections ".ml4 files" and "new files". Cleaning Targets ---------------- Targets for cleaning various parts: - distclean: clean everything; must leave only what should end up in distribution tarball and/or is in a svn checkout. - clean: clean everything except effect of "./configure" and documentation. - cleanconfig: clean effect of "./configure" only - archclean: remove all architecture-dependent generated files - indepclean: remove all architecture-independent generated files (not documentation) - objclean: clean all generated files, but not Makefile meta-data (e.g. dependencies), nor debugging/development information nor other cruft (e.g. editor backup files), nor documentation - docclean: clean documentation .ml4/.mlp files --------------- There is now two kinds of preprocessed files : - a .mlp do not need grammar.cma (they are in grammar/) - a .ml4 is now always preprocessed with grammar.cma (and q_constr.cmo), except coqide_main.ml4 and its specific rule This classification replaces the old mechanism of declaring the use of a grammar extension via a line of the form: (*i camlp4deps: "grammar.cma q_constr.cmo" i*) The use of (*i camlp4use: ... i*) to mention uses of standard extension such as IFDEF has also been discontinued, the Makefile now always calls camlp4 with pa_macros.cmo and a few others by default. For debugging a Coq grammar extension, it could be interesting to use the READABLE_ML4=1 option, otherwise the generated .ml are in an internal binary format (see build-system.dev.txt). New files --------- For a new file, in most cases, you just have to add it to the proper file list(s): - For .ml, in the corresponding .mllib (e.g. kernel/kernel.mllib) These files are also used by the experimental ocamlbuild plugin, which is quite touchy about them : be careful with order, duplicated entries, whitespace errors, and do not mention .mli there. - For .v, in the corresponding vo.itarget (e.g theories/Init/vo.itarget) - The definitions in Makefile.common might have to be adapted too. - If your file needs a specific rule, add it to Makefile.build The list of all ml4 files is not handled manually anymore. coq-8.6/dev/doc/README-V1-V5.asciidoc0000644000175000017500000004241313022274260016217 0ustar mdenesmdenesNotes on the prehistory of Coq ============================== :author: Thierry Coquand, Gérard Huet & Christine Paulin-Mohring :revdate: September 2015 :toc: :toc-placement: preamble :toclevels: 1 :showtitle: This document is a copy within the Coq archive of a document written in September 2015 by Gérard Huet, Thierry Coquand and Christine Paulin to accompany their public release of the archive of versions 1.10 to 6.2 of Coq and of its CONSTR ancestor. CONSTR, then Coq, was designed and implemented in the Formel team, joint between the INRIA Rocquencourt laboratory and the Ecole Normale Supérieure of Paris, from 1984 onwards. Version 1 --------- This software is a prototype type-checker for a higher-order logical formalism known as the Theory of Constructions, presented in his PhD thesis by Thierry Coquand, with influences from Girard's system F and de Bruijn's Automath. The metamathematical analysis of the system is the PhD work of Thierry Coquand. The software is mostly the work of Gérard Huet. Most of the mathematical examples verified with the software are due to Thierry Coquand. The programming language of the CONSTR software (as it was called at the time) was a version of ML adapted from the Edinburgh LCF system and running on a LISP backend. The main improvements from the original LCF ML were that ML was compiled rather than interpreted (Gérard Huet building on the original translator by Lockwood Morris), and that it was enriched by recursively defined types (work of Guy Cousineau). This ancestor of CAML was used and improved by Larry Paulson for his implementation of Cambridge LCF. Software developments of this prototype occurred from late 1983 to early 1985. Version 1.10 was frozen on December 22nd 1984. It is the version used for the examples in Thierry Coquand's thesis, defended on January 31st 1985. There was a unique binding operator, used both for universal quantification (dependent product) at the level of types and functional abstraction (λ) at the level of terms/proofs, in the manner of Automath. Substitution (λ-reduction) was implemented using de Bruijn's indexes. Version 1.11 was frozen on February 19th, 1985. It is the version used for the examples in the paper: Th. Coquand, G. Huet. __Constructions: A Higher Order Proof System for Mechanizing Mathematics__ <>. Christine Paulin joined the team at this point, for her DEA research internship. In her DEA memoir (August 1985) she presents developments for the _lambo_ function – _lambo(f)(n)_ computes the minimal _m_ such that _f(m)_ is greater than _n_, for _f_ an increasing integer function, a challenge for constructive mathematics. She also encoded the majority voting algorithm of Boyer and Moore. Version 2 --------- The formal system, now renamed as the _Calculus of Constructions_, was presented with a proof of consistency and comparisons with proof systems of Per Martin Löf, Girard, and the Automath family of N. de Bruijn, in the paper: T. Coquand and G. Huet. __The Calculus of Constructions__ <>. An abstraction of the software design, in the form of an abstract machine for proof checking, and a fuller sequence of mathematical developments was presented in: Th. Coquand, G. Huet. __Concepts Mathématiques et Informatiques Formalisés dans le Calcul des Constructions__<>. Version 2.8 was frozen on December 16th, 1985, and served for developing the exemples in the above papers. This calculus was then enriched in version 2.9 with a cumulative hierarchy of universes. Universe levels were initially explicit natural numbers. Another improvement was the possibility of automatic synthesis of implicit type arguments, relieving the user of tedious redundant declarations. Christine Paulin wrote an article __Algorithm development in the Calculus of Constructions__ <>. Besides _lambo_ and _majority_, she presents quicksort and a text formatting algorithm. Version 2.13 of the Calculus of Constructions with universes was frozen on June 25th, 1986. A synthetic presentation of type theory along constructive lines with ML algorithms was given by Gérard Huet in his May 1986 CMU course notes _Formal Structures for Computation and Deduction_. Its chapter _Induction and Recursion in the Theory of Constructions_ was presented as an invited paper at the Joint Conference on Theory and Practice of Software Development TAPSOFT’87 at Pise in March 1987, and published as __Induction Principles Formalized in the Calculus of Constructions__ <>. Version 3 --------- This version saw the beginning of proof automation, with a search algorithm inspired from PROLOG and the applicative logic programming programs of the course notes _Formal structures for computation and deduction_. The search algorithm was implemented in ML by Thierry Coquand. The proof system could thus be used in two modes: proof verification and proof synthesis, with tactics such as `AUTO`. The implementation language was now called CAML, for Categorical Abstract Machine Language. It used as backend the LLM3 virtual machine of Le Lisp by Jérôme Chailloux. The main developers of CAML were Michel Mauny, Ascander Suarez and Pierre Weis. V3.1 was started in the summer of 1986, V3.2 was frozen at the end of November 1986. V3.4 was developed in the first half of 1987. Thierry Coquand held a post-doctoral position in Cambrige University in 1986-87, where he developed a variant implementation in SML, with which he wrote some developments on fixpoints in Scott's domains. Version 4 --------- This version saw the beginning of program extraction from proofs, with two varieties of the type `Prop` of propositions, indicating constructive intent. The proof extraction algorithms were implemented by Christine Paulin-Mohring. V4.1 was frozen on July 24th, 1987. It had a first identified library of mathematical developments (directory exemples), with libraries Logic (containing impredicative encodings of intuitionistic logic and algebraic primitives for booleans, natural numbers and list), `Peano` developing second-order Peano arithmetic, `Arith` defining addition, multiplication, euclidean division and factorial. Typical developments were the Knaster-Tarski theorem and Newman's lemma from rewriting theory. V4.2 was a joint development of a team consisting of Thierry Coquand, Gérard Huet and Christine Paulin-Mohring. A file V4.2.log records the log of changes. It was frozen on September 1987 as the last version implemented in CAML 2.3, and V4.3 followed on CAML 2.5, a more stable development system. V4.3 saw the first top-level of the system. Instead of evaluating explicit quotations, the user could develop his mathematics in a high-level language called the mathematical vernacular (following Automath terminology). The user could develop files in the vernacular notation (with .v extension) which were now separate from the `ml` sources of the implementation. Gilles Dowek joined the team to develop the vernacular language as his DEA internship research. A notion of sticky constant was introduced, in order to keep names of lemmas when local hypotheses of proofs were discharged. This gave a notion of global mathematical environment with local sections. Another significant practical change was that the system, originally developped on the VAX central computer of our lab, was transferred on SUN personal workstations, allowing a level of distributed development. The extraction algorithm was modified, with three annotations `Pos`, `Null` and `Typ` decorating the sorts `Prop` and `Type`. Version 4.3 was frozen at the end of November 1987, and was distributed to an early community of users (among those were Hugo Herbelin and Loic Colson). V4.4 saw the first version of (encoded) inductive types. Now natural numbers could be defined as: [source, coq] Inductive NAT : Prop = O : NAT | Succ : NAT->NAT. These inductive types were encoded impredicatively in the calculus, using a subsystem _rec_ due to Christine Paulin. V4.4 was frozen on March 6th 1988. Version 4.5 was the first one to support inductive types and program extraction. Its banner was _Calcul des Constructions avec Réalisations et Synthèse_. The vernacular language was enriched to accommodate extraction commands. The verification engine design was presented as: G. Huet. _The Constructive Engine_. Version 4.5. Invited Conference, 2nd European Symposium on Programming, Nancy, March 88. The final paper, describing the V4.9 implementation, appeared in: A perspective in Theoretical Computer Science, Commemorative Volume in memory of Gift Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. Version 4.5 was demonstrated in June 1988 at the YoP Institute on Logical Foundations of Functional Programming organized by Gérard Huet at Austin, Texas. Version 4.6 was started during the summer of 1988. Its main improvement was the complete rehaul of the proof synthesis engine by Thierry Coquand, with a tree structure of goals. Its source code was communicated to Randy Pollack on September 2nd 1988. It evolved progressively into LEGO, proof system for Luo's formalism of Extended Calculus of Constructions. The discharge tactic was modified by Gérard Huet to allow for inter-dependencies in discharged lemmas. Christine Paulin improved the inductive definition scheme in order to accommodate predicates of any arity. Version 4.7 was started on September 6th, 1988. This version starts exploiting the CAML notion of module in order to improve the modularity of the implementation. Now the term verifier is identified as a proper module Machine, which the structure of its internal data structures being hidden and thus accessible only through the legitimate operations. This machine (the constructive engine) was the trusted core of the implementation. The proof synthesis mechanism was a separate proof term generator. Once a complete proof term was synthesized with the help of tactics, it was entirely re-checked by the engine. Thus there was no need to certify the tactics, and the system took advantage of this fact by having tactics ignore the universe levels, universe consistency check being relegated to the final type-checking pass. This induced a certain puzzlement in early users who saw, after a successful proof search, their `QED` followed by silence, followed by a failure message due to a universe inconsistency… The set of examples comprise set theory experiments by Hugo Herbelin, and notably the Schroeder-Bernstein theorem. Version 4.8, started on October 8th, 1988, saw a major re-implementation of the abstract syntax type `constr`, separating variables of the formalism and metavariables denoting incomplete terms managed by the search mechanism. A notion of level (with three values `TYPE`, `OBJECT` and `PROOF`) is made explicit and a type judgement clarifies the constructions, whose implementation is now fully explicit. Structural equality is speeded up by using pointer equality, yielding spectacular improvements. Thierry Coquand adapts the proof synthesis to the new representation, and simplifies pattern matching to first-order predicate calculus matching, with important performance gain. A new representation of the universe hierarchy is then defined by Gérard Huet. Universe levels are now implemented implicitly, through a hidden graph of abstract levels constrained with an order relation. Checking acyclicity of the graph insures well-foundedness of the ordering, and thus consistency. This was documented in a memo _Adding Type:Type to the Calculus of Constructions_ which was never published. The development version is released as a stable 4.8 at the end of 1988. Version 4.9 is released on March 1st 1989, with the new ``elastic'' universe hierarchy. The spring of 1989 saw the first attempt at documenting the system usage, with a number of papers describing the formalism: - _Metamathematical Investigations of a Calculus of Constructions_, by Thierry Coquand <>, - _Inductive definitions in the Calculus of Constructions_, by Christine Paulin-Mohrin, - _Extracting Fω's programs from proofs in the Calculus of Constructions_, by Christine Paulin-Mohring <>, - _The Constructive Engine_, by Gérard Huet <>, as well as a number of user guides: - _A short user's guide for the Constructions_ Version 4.10, by Gérard Huet - _A Vernacular Syllabus_, by Gilles Dowek. - _The Tactics Theorem Prover, User's guide_, Version 4.10, by Thierry Coquand. Stable V4.10, released on May 1st, 1989, was then a mature system, distributed with CAML V2.6. In the mean time, Thierry Coquand and Christine Paulin-Mohring had been investigating how to add native inductive types to the Calculus of Constructions, in the manner of Per Martin-Löf's Intuitionistic Type Theory. The impredicative encoding had already been presented in: F. Pfenning and C. Paulin-Mohring. __Inductively defined types in the Calculus of Constructions__ <>. An extension of the calculus with primitive inductive types appeared in: Th. Coquand and C. Paulin-Mohring. __Inductively defined types__ <>. This led to the Calculus of Inductive Constructions, logical formalism implemented in Versions 5 upward of the system, and documented in: C. Paulin-Mohring. __Inductive Definitions in the System Coq - Rules and Properties__ <>. The last version of CONSTR is Version 4.11, which was last distributed in the spring of 1990. It was demonstrated at the first workshop of the European Basic Research Action Logical Frameworks In Sophia Antipolis in May 1990. At the end of 1989, Version 5.1 was started, and renamed as the system Coq for the Calculus of Inductive Constructions. It was then ported to the new stand-alone implementation of ML called Caml-light. In 1990 many changes occurred. Thierry Coquand left for Chalmers University in Göteborg. Christine Paulin-Mohring took a CNRS researcher position at the LIP laboratory of École Normale Supérieure de Lyon. Project Formel was terminated, and gave rise to two teams: Cristal at INRIA-Roquencourt, that continued developments in functional programming with Caml-light then Ocaml, and Coq, continuing the type theory research, with a joint team headed by Gérard Huet at INRIA-Rocquencourt and Christine Paulin-Mohring at the LIP laboratory of CNRS-ENS Lyon. Chetan Murthy joined the team in 1991 and became the main software architect of Version 5. He completely rehauled the implementation for efficiency. Versions 5.6 and 5.8 were major distributed versions, with complete documentation and a library of users' developements. The use of the RCS revision control system, and systematic ChangeLog files, allow a more precise tracking of the software developments. Developments from Version 6 upwards are documented in the credits section of Coq's Reference Manual. ==== September 2015 + Thierry Coquand, Gérard Huet and Christine Paulin-Mohring. ==== [bibliography] .Bibliographic references - [[[CH85]]] Th. Coquand, G. Huet. _Constructions: A Higher Order Proof System for Mechanizing Mathematics_. Invited paper, EUROCAL85, April 1985, Linz, Austria. Springer Verlag LNCS 203, pp. 151-184. - [[[CH88]]] T. Coquand and G. Huet. _The Calculus of Constructions_. Submitted on June 30th 1985, accepted on December 5th, 1985, Information and Computation. Preprint as Rapport de Recherche Inria n°530, Mai 1986. Final version in Information and Computation 76,2/3, Feb. 88. - [[[CH87]]] Th. Coquand, G. Huet. _Concepts Mathématiques et Informatiques Formalisés dans le Calcul des Constructions_. Invited paper, European Logic Colloquium, Orsay, July 1985. Preprint as Rapport de recherche INRIA n°463, Dec. 85. Published in Logic Colloquium 1985, North-Holland, 1987. - [[[P86]]] C. Paulin. _Algorithm development in the Calculus of Constructions_, preprint as Rapport de recherche INRIA n°497, March 86. Final version in Proceedings Symposium on Logic in Computer Science, Cambridge, MA, 1986 (IEEE Computer Society Press). - [[[H88]]] G. Huet. _Induction Principles Formalized in the Calculus of Constructions_ in Programming of Future Generation Computers, Ed. K. Fuchi and M. Nivat, North-Holland, 1988. - [[[C90]]] Th. Coquand. _Metamathematical Investigations of a Calculus of Constructions_, by INRIA Research Report N°1088, Sept. 1989, published in Logic and Computer Science, ed. P.G. Odifreddi, Academic Press, 1990. - [[[P89]]] C. Paulin. _Extracting F ω's programs from proofs in the calculus of constructions_. 16th Annual ACM Symposium on Principles of Programming Languages, Austin. 1989. - [[[H89]]] G. Huet. _The constructive engine_. A perspective in Theoretical Computer Science. Commemorative Volume for Gift Siromoney. World Scientific Publishing (1989). - [[[PP90]]] F. Pfenning and C. Paulin-Mohring. _Inductively defined types in the Calculus of Constructions_. Preprint technical report CMU-CS-89-209, final version in Proceedings of Mathematical Foundations of Programming Semantics, volume 442, Lecture Notes in Computer Science. Springer-Verlag, 1990 - [[[CP90]]] Th. Coquand and C. Paulin-Mohring. _Inductively defined types_. In P. Martin-Löf and G. Mints, editors, Proceedings of Colog'88, volume 417, Lecture Notes in Computer Science. Springer-Verlag, 1990. - [[[P93]]] C. Paulin-Mohring. _Inductive Definitions in the System Coq - Rules and Properties_. In M. Bezem and J.-F. Groote, editors, Proceedings of the conference Typed Lambda Calculi and Applications, volume 664, Lecture Notes in Computer Science, 1993. coq-8.6/dev/doc/build-system.dev.txt0000644000175000017500000001203313022274260016740 0ustar mdenesmdenes HISTORY: ------- * July 2007 (Pierre Corbineau & Lionel Elie Mamane). Inclusion of a build system with 3 explicit phases: - Makefile.stage1: ocamldep, sed, camlp4 without Coq grammar extension - Makefile.stage2: camlp4 with grammar.cma or q_constr.cmo - Makefile.stage3: coqdep (.vo) * March 2010 (Pierre Letouzey). Revised build system. In particular, no more stage1,2,3 : - Stage3 was removed some time ago when coqdep was splitted into coqdep_boot and full coqdep. - Stage1,2 were replaced by brutal inclusion of all .d at the start of Makefile.build, without trying to guess what could be done at what time. Some initial inclusions hence _fail_, but "make" tries again later and succeed. - Btw, .ml4 are explicitely turned into .ml files, which stay after build. By default, they are in binary ast format, see READABLE_ML4 option. * February 2014 (Pierre Letouzey). Another revision of the build system. We avoid relying on the awkward include-which-fails-but-works-finally-after-a-retry feature of gnu make. This was working, but was quite hard to understand. Instead, we reuse the idea of two explicit phases, but in a lighter way than in 2007. The main Makefile calls Makefile.build twice : - first for building grammar.cma (and q_constr.cmo), with a restricted set of .ml4 (see variable BUILDGRAMMAR). - then on the true target asked by the user. * June 2016 (Pierre Letouzey) The files in grammar/ are now self-contained, we could compile grammar.cma (and q_constr.cmo) directly, no need for a separate subcall to make nor awkward include-failed-and-retry. --------------------------------------------------------------------------- This file documents internals of the implementation of the build system. For what a Coq developer needs to know about the build system, see build-system.txt . .ml4 files ---------- .ml4 are converted to .ml by camlp4. By default, they are produced in the binary ast format understood by ocamlc/ocamlopt/ocamldep. Pros: - faster than parsing clear-text source file. - no risk of editing them by mistake instead of the .ml4 - the location in the binary .ml are those of the initial .ml4, hence errors are properly reported in the .ml4. Cons: - This format may depend on your ocaml version, they should be cleaned if you change your build environment. - Unreadable in case you want to inspect this generated code. For that, use make with the READABLE_ML4=1 option to switch to clear-text generated .ml. Makefiles hierachy ------------------ The Makefile is separated in several files : - Makefile: wrapper that triggers a call to Makefile.build, except for clean and a few other little things doable without dependency analysis. - Makefile.common : variable definitions (mostly lists of files or directories) - Makefile.build : contains compilation rules, and the "include" of dependencies - Makefile.doc : specific rules for compiling the documentation. FIND_VCS_CLAUSE --------------- The recommended style of using FIND_VCS_CLAUSE is for example find . $(FIND_VCS_CLAUSE) '(' -name '*.example' ')' -print find . $(FIND_VCS_CLAUSE) '(' -name '*.example' -or -name '*.foo' ')' -print 1) The parentheses even in the one-criteria case is so that if one adds other conditions, e.g. change the first example to the second find . $(FIND_VCS_CLAUSE) '(' -name '*.example' -and -not -name '*.bak.example' ')' -print one is not tempted to write find . $(FIND_VCS_CLAUSE) -name '*.example' -and -not -name '*.bak.example' -print because this will not necessarily work as expected; $(FIND_VCS_CLAUSE) ends with an -or, and how it combines with what comes later depends on operator precedence and all that. Much safer to override it with parentheses. In short, it protects against the -or one doesn't see. 2) As to the -print at the end, yes it is necessary. Here's why. You are used to write: find . -name '*.example' and it works fine. But the following will not: find . $(FIND_VCS_CLAUSE) -name '*.example' it will also list things directly matched by FIND_VCS_CLAUSE (directories we want to prune, in which we don't want to find anything). C'est subtil... Il y a effectivement un -print implicite à la fin, qui fait que la commande habituelle sans print fonctionne bien, mais dès que l'on introduit d'autres commandes dans le lot (le -prune de FIND_VCS_CLAUSE), ça se corse à cause d'histoires de parenthèses du -print implicite par rapport au parenthésage dans la forme recommandée d'utilisation: Si on explicite le -print et les parenthèses implicites, cela devient: find . '(' '(' '(' -name .git -or -name debian ')' -prune ')' -or \ '(' -name '*.example' ')' ')' -print Le print agit TOUT ce qui précède, soit sur ce qui matche "'(' -name .git -or -name debian ')'" ET sur ce qui matche "'(' -name '*.example' ')'". alors qu'ajouter le print explicite change cela en find . '(' '(' -name .git -or -name debian ')' -prune ')' -or \ '(' '(' -name '*.example' ')' -print ')' Le print n'agit plus que sur ce qui matche "'(' -name '*.example' ')'" coq-8.6/dev/doc/transition-V6-V70000644000175000017500000000061313022274260015702 0ustar mdenesmdenesThe V6 archive has been created in March 1996 with files from the former V5.10 archive and has been abandoned in 2000. A new archive named V7 has been created in August 1999 by Jean-Christophe Filliâtre with a new architecture placing the type-checking at the kernel of Coq. This new architecture came with a "cleaner" organization of files, a uniform indentation style, uniform headers, etc. coq-8.6/dev/doc/cic.dtd0000644000175000017500000001267213022274260014245 0ustar mdenesmdenes coq-8.6/dev/doc/universes.txt0000644000175000017500000000117213022274260015567 0ustar mdenesmdenesHow to debug universes? 1. There is a command Print Universes in Coq toplevel Print Universes. prints the graph of universes in the form of constraints Print Universes "file". produces the "file" containing universe constraints in the form univ1 # univ2 ; where # can be either > >= or = If "file" ends with .gv or .dot, the resulting file will be in dot format. *) for dot see http://www.research.att.com/sw/tools/graphviz/ 2. There is a printing option {Set,Unset} Printing Universes. which, when set, makes all pretty-printed Type's annotated with the name of the universe. coq-8.6/dev/doc/translate.txt0000644000175000017500000003724713022274260015555 0ustar mdenesmdenes How to use the translator ========================= (temporary version to be included in the official TeX document describing the translator) The translator is a smart, robust and powerful tool to improve the readibility of your script. The current document describes the possibilities of the translator. In case of problem recompiling the translated files, don't waste time to modify the translated file by hand, read first the following document telling on how to modify the original files to get a smooth uniform safe translation. All 60000 lines of Coq lines on our user-contributions server have been translated without any change afterwards, and 0,5 % of the lines of the original files (mainly notations) had to be modified beforehand to get this result. Table of contents ----------------- I) Implicit Arguments 1) Strict Implicit Arguments 2) Implicit Arguments in standard library II) Notations 1) Translating a V7 notation as it was 2) Translating a V7 notation which conflicts with the new syntax a) Associativity conflicts b) Conflicts with other notations b1) A notation hides another notation b2) A notation conflicts with the V8 grammar b3) My notation is already defined at another level c) How to use V8only with Distfix ? d) Can I overload a notation in V8, e.g. use "*" and "+" ? 3) Using the translator to have simplest notations 4) Setting the translator to automatically use new notations that wasn't used in old syntax 5) Defining a construction and its notation simultaneously III) Various pitfalls 1) New keywords 2) Old "Case" and "Match" 3) Change of definition or theorem names 4) Change of tactic names --------------------------------------------------------------------- I) Implicit Arguments ------------------ 1) Strict Implicit Arguments "Set Implicit Arguments" changes its meaning in V8: the default is to turn implicit only the arguments that are _strictly_ implicit (or rigid), i.e. that remains inferable whatever the other arguments are. E.g "x" inferable from "P x" is not strictly inferable since it can disappears if "P" is instanciated by a term which erase "x". To respect the old semantics, the default behaviour of the translator is to replace each occurrence "Set Implicit Arguments" by Set Implicit Arguments. Unset Strict Implicits. However, you may wish to adopt the new semantics of "Set Implicit Arguments" (for instance because you think that the choice of arguments it setsimplicit is more "natural" for you). In this case, add the option -strict-implicit to the translator. Warning: Changing the number of implicit arguments can break the notations. Then use the V8only modifier of Notations. 2) Implicit Arguments in standard library Main definitions of standard library have now implicit arguments. These arguments are dropped in the translated files. This can exceptionally be a source of incompatibilities which has to be solved by hand (it typically happens for polymorphic functions applied to "nil" or "None"). II) Notations --------- Grammar (on constr) and Syntax are no longer supported. Replace them by Notation before translation. Precedence levels are now from 0 to 200. In V8, the precedence and associativity of an operator cannot be redefined. Typical level are (refer to the chapter on notations in the Reference Manual for the full list): <-> : 95 (no associativity) -> : 90 (right associativity) \/ : 85 (right associativity) /\ : 80 (right associativity) ~ : 75 (right associativity) =, <, >, <=, >=, <> : 70 (no associativity) +, - : 50 (left associativity) *, / : 40 (left associativity) ^ : 30 (right associativity) 1) Translating a V7 notation as it was By default, the translator keeps the associativity given in V7 while the levels are mapped according to the following table: the V7 levels [ 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10] are resp. mapped in V8 to [ 0; 20; 30; 40; 50; 70; 80; 85; 90; 95; 100] with predefined assoc [ No; L; R; L; L; No; R; R; R; No; L] If this is OK for you, just simply apply the translator. 2) Translating a V7 notation which conflicts with the new syntax a) Associativity conflict Since the associativity of the levels obtained by translating a V7 level (as shown on table above) cannot be changed, you have to choose another level with a compatible associativity. You can choose any level between 0 and 200, knowing that the standard operators are already set at the levels shown on the list above. Example 1: Assume you have a notation Infix NONA 2 "=_S" my_setoid_eq. By default, the translator moves it to level 30 which is right associative, hence a conflict with the expected no associativity. To solve the problem, just add the "V8only" modifier to reset the level and enforce the associativity as follows: Infix NONA 2 "=_S" my_setoid_eq V8only (at level 70, no associativity). The translator now knows that it has to translate "=_S" at level 70 with no associativity. Rem: 70 is the "natural" level for relations, hence the choice of 70 here, but any other level accepting a no-associativity would have been OK. Example 2: Assume you have a notation Infix RIGHTA 1 "o" my_comp. By default, the translator moves it to level 20 which is left associative, hence a conflict with the expected right associativity. To solve the problem, just add the "V8only" modifier to reset the level and enforce the associativity as follows: Infix RIGHTA 1 "o" my_comp V8only (at level 20, right associativity). The translator now knows that it has to translate "o" at level 20 which has the correct "right associativity". Rem: We assumed here that the user wants a strong precedence for composition, in such a way, say, that "f o g + h" is parsed as "(f o g) + h". To get "o" binding less than the arithmetical operators, an appropriated level would have been close of 70, and below, e.g. 65. b) Conflicts with other notations Since the new syntax comes with new keywords and new predefined symbols, new conflicts can occur. Again, you can use the option V8only to inform the translator of the new syntax to use. b1) A notation hides another notation Rem: use Print Grammar constr in V8 to diagnose the overlap and see the section on factorization in the chapter on notations of the Reference Manual for hints on how to factorize. Example: Notation "{ x }" := (my_embedding x) (at level 1). overlaps in V8 with notation "{ x : A & P }" at level 0 and with x at level 99. The conflicts can be solved by left-factorizing the notation as follows: Notation "{ x }" := (my_embedding x) (at level 1) V8only (at level 0, x at level 99). b2) A notation conflicts with the V8 grammar. Again, use the V8only modifier to tell the translator to automatically take in charge the new syntax. Example: Infix 3 "@" app. Since "@" is used in the new syntax for deactivating the implicit arguments, another symbol has to be used, e.g. "@@". This is done via the V8only option as follows: Infix 3 "@" app V8only "@@" (at level 40, left associativity). or, alternatively by Notation "x @ y" := (app x y) (at level 3, left associativity) V8only "x @@ y" (at level 40, left associativity). b3) My notation is already defined at another level (or with another associativity) In V8, the level and associativity of a given notation can no longer be changed. Then, either you adopt the standard reserved levels and associativity for this notation (as given on the list above) or you change your notation. - To change the notation, follow the directions in section b2. - To adopt the standard level, just use V8only without any argument. Example. Infix 6 "*" my_mult. is not accepted as such in V8. Write Infix 6 "*" my_mult V8only. to tell the translator to use "*" at the reserved level (i.e. 40 with left associativity). Even better, use interpretation scopes (look at the Reference Manual). c) How to use V8only with Distfix ? You can't, use Notation instead of Distfix. d) Can I overload a notation in V8, e.g. use "*" and "+" for my own algebraic operations ? Yes, using interpretation scopes (see the corresponding chapter in the Reference Manual). 3) Using the translator to have simplest notations Thanks to the new syntax, * has now the expected left associativity, and the symbols <, >, <= and >= are now available. Thanks to the interpretation scopes, you can overload the interpretation of these operators with the default interpretation provided in Coq. This may be a motivation to use the translator to automatically change the notations while switching to the new syntax. See sections b) and d) above for examples. 4) Setting the translator to automatically use new notations that wasn't used in old syntax Thanks to the "Notation" mechanism, defining symbolic notations is simpler than in the previous versions of Coq. Thanks to the new syntax and interpretation scopes, new symbols and overloading is available. This may be a motivation for using the translator to automatically change the notations while switching to the new syntax. Use for that the commands V8Notation and V8Infix. Examples: V8Infix "==>" my_relation (at level 65, right associativity). tells the translator to write an infix "==>" instead of my_relation in the translated files. V8Infix ">=" my_ge. tells the translator to write an infix ">=" instead of my_ge in the translated files and that the level and associativity are the standard one (as defined in the chart above). V8Infix ">=" my_ge : my_scope. tells the translator to write an infix ">=" instead of my_ge in the translated files, that the level and associativity are the standard one (as defined in the chart above), but only if scope my_scope is open or if a delimiting key is available for "my_scope" (see the Reference Manual). 5) Defining a construction and its notation simultaneously This is permitted by the new syntax. Look at the Reference Manual for explanation. The translator is not fully able to take this in charge... III) Various pitfalls ---------------- 1) New keywords The following identifiers are new keywords "forall"; "fun"; "match"; "fix"; "cofix"; "for"; "if"; "then"; "else"; "return"; "mod"; "at"; "let"; "_"; ".(" The translator automatically add a "_" to names clashing with a keyword, except for files. Hence users may need to rename the files whose name clashes with a keyword. Remark: "in"; "with"; "end"; "as"; "Prop"; "Set"; "Type" were already keywords 2) Old "Case" and "Match" "Case" and "Match" are normally automatically translated into "match" or "match" and "fix", but sometimes it fails to do so. It typically fails when the Case or Match is argument of a tactic whose typing context is unknown because of a preceding Intro/Intros, as e.g. in Intros; Exists [m:nat](Case m of t [p:nat](f m) end) The solution is then to replace the invocation of the sequence of tactics into several invocation of the elementary tactics as follows Intros. Exists [m:nat](Case m of t [p:nat](f m) end) ^^^ 3) Change of definition or theorem names Type "entier" from fast_integer.v is renamed into "N" by the translator. As a consequence, user-defined objects of same name "N" are systematically qualified even tough it may not be necessary. The same apply for names "GREATER", "EQUAL", "LESS", etc... [COMPLETE LIST TO GIVE]. 4) Change of tactics names Since tactics names are now lowercase, this can clash with user-defined tactic definitions. To pally this, clashing names are renamed by adding an extra "_" to their name. ====================================================================== Main examples for new syntax ---------------------------- 1) Constructions Applicative terms don't any longer require to be surrounded by parentheses as e.g in "x = f y -> S x = S (f y)" Product is written "forall x y : T, U" "forall x y, U" "forall (x y : T) z (v w : V), U" etc. Abstraction is written "fun x y : T, U" "fun x y, U" "fun (x y : T) z (v w : V), U" etc. Pattern-matching is written "match x with c1 x1 x2 => t | c2 y as z => u end" "match v1, v2 with c1 x1 x2, _ => t | c2 y, d z => u end" "match v1 as y in le _ n, v2 as z in I p q return P n y p q z with c1 x1 x2, _ => t | c2 y, d z => u end" The last example is the new form of what was written "<[n;y:(le ? n);p;q;z:(I p q)](P n y p q z)>Cases v1 v2 of (c1 x1 x2) _ => t | (c2 y) (d z) => u end" Pattern-matching of type with one constructors and no dependencies of the arguments in the resulting type can be written "let (x,y,z) as u return P u := t in v" Local fixpoints are written "fix f (n m:nat) z (x : X) {struct m} : nat := ... with ..." and "struct" tells which argument is structurally decreasing. Explicitation of implicit arguments is written "f @1:=u v @3:=w t" "@f u v w t" 2) Tactics The main change is that tactics names are now lowercase. Besides this, the following renaming are applied: "NewDestruct" -> "destruct" "NewInduction" -> "induction" "Induction" -> "simple induction" "Destruct" -> "simple destruct" For tactics with occurrences, the occurrences now comes after and repeated use is separated by comma as in "Pattern 1 3 c d 4 e" -> "pattern c at 3 1, d, e at 4" "Unfold 1 3 f 4 g" -> "unfold f at 1 3, g at 4" "Simpl 1 3 e" -> "simpl e at 1 3" 3) Tactic language Definitions are now introduced with keyword "Ltac" (instead of "Tactic"/"Meta" "Definition") and are implicitly recursive ("Recursive" is no longer used). The new rule for distinguishing terms from ltac expressions is: Write "ltac:" in front of any tactic in argument position and "constr:" in front of any construction in head position 4) Vernacular language a) Assumptions The syntax for commands is mainly unchanged. Declaration of assumptions is now done as follows Variable m : t. Variables m n p : t. Variables (m n : t) (u v : s) (w : r). b) Definitions Definitions are done as follows Definition f m n : t := ... . Definition f m n := ... . Definition f m n := ... : t. Definition f (m n : u) : t := ... . Definition f (m n : u) := ... : t. Definition f (m n : u) := ... . Definition f a b (p q : v) r s (m n : t) : t := ... . Definition f a b (p q : v) r s (m n : t) := ... . Definition f a b (p q : v) r s (m n : t) := ... : t. c) Fixpoints Fixpoints are done this way Fixpoint f x (y : t) z a (b c : u) {struct z} : v := ... with ... . Fixpoint f x : v := ... . Fixpoint f (x : t) : v := ... . It is possible to give a concrete notation to a fixpoint as follows Fixpoint plus (n m:nat) {struct n} : nat as "n + m" := match n with | O => m | S p => S (p + m) end. d) Inductive types The syntax for inductive types is as follows Inductive t (a b : u) (d : e) : v := c1 : w1 | c2 : w2 | ... . Inductive t (a b : u) (d : e) : v := c1 : w1 | c2 : w2 | ... . Inductive t (a b : u) (d : e) : v := c1 (x y : t) : w1 | c2 (z : r) : w2 | ... . As seen in the last example, arguments of the constructors can be given before the colon. If the type itself is omitted (allowed only in case the inductive type has no real arguments), this yields an ML-style notation as follows Inductive nat : Set := O | S (n:nat). Inductive bool : Set := true | false. It is even possible to define a syntax at the same time, as follows: Inductive or (A B:Prop) : Prop as "A \/ B":= | or_introl (a:A) : A \/ B | or_intror (b:B) : A \/ B. Inductive and (A B:Prop) : Prop as "A /\ B" := conj (a:A) (b:B). coq-8.6/dev/doc/old_svn_branches.txt0000644000175000017500000000250113022274260017052 0ustar mdenesmdenes## During the migration to git, some old branches and tags have not been ## converted to directly visible git branches or tags. They are still there ## in the archive, their names on the gforge repository are in the 3rd ## column below (e.g. remotes/V8-0-bugfix). After a git clone, they ## could always be accessed by their git hashref (2nd column below). # SVN # GIT # Symbolic name on gforge repository r5 d2f789d remotes/tags/start r1714 0605b7c remotes/V7 r2583 372f3f0 remotes/tags/modules-2-branching r2603 6e15d9a remotes/modules r2866 76a93fa remotes/tags/modules-2-before-grammar r2951 356f749 remotes/tags/before-modules r2952 8ee67df remotes/tags/modules-2-update r2956 fb11bd9 remotes/modules-2 r3193 4d23172 remotes/mowgli r3194 c91e99b remotes/tags/mowgli-before-merge r3500 5078d29 remotes/mowgli2 r3672 63b0886 remotes/V7-3-bugfix r5086 bdceb72 remotes/V7-4-bugfix r5731 a274456 remotes/recriture r9046 e19553c remotes/tags/trunk r9146 b38ce05 remotes/coq-diff-tool r9786 a05abf8 remotes/ProofIrrelevance r10294 fdf8871 remotes/InternalExtraction r10408 df97909 remotes/TypeClasses r10673 4e19bca remotes/bertot r11130 bfd1cb3 remotes/proofs r12282 a726b30 remotes/revised-theories r13855 bae3a8e remotes/native r14062 b77191b remotes/recdef r16421 9f4bfa8 remotes/V8-0-bugfix coq-8.6/dev/doc/versions-history.tex0000644000175000017500000003275713022274260017111 0ustar mdenesmdenes\documentclass[a4paper]{book} \usepackage{fullpage} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{amsfonts} \newcommand{\feature}[1]{{\em #1}} \begin{document} \begin{center} \begin{huge} A history of Coq versions \end{huge} \end{center} \bigskip \centerline{\large 1984-1989: The Calculus of Constructions} \bigskip \centerline{\large (see README.V1-V5 for details)} \mbox{}\\ \mbox{}\\ \begin{tabular}{l|l|l} version & date & comments \\ \hline CONSTR V1.10& mention of dates from 6 December & \feature{type-checker for Coquand's Calculus }\\ & 1984 to 13 February 1985 & \feature{of Constructions}, implementation \\ & frozen 22 December 1984 & language is a predecessor of CAML\\ CONSTR V1.11& mention of dates from 6 December\\ & 1984 to 19 February 1985 (freeze date) &\\ CoC V2.8& dated 16 December 1985 (freeze date)\\ CoC V2.9& & \feature{cumulative hierarchy of universes}\\ CoC V2.13& dated 25 June 1986 (freeze date)\\ CoC V3.1& started summer 1986 & \feature{AUTO tactic}\\ & dated 20 November 1986 & implementation language now named CAML\\ CoC V3.2& dated 27 November 1986\\ CoC V3.3& dated 1 January 1987 & creation of a directory for examples\\ CoC V3.4& dated 1 January 1987 & \feature{lambda and product distinguished in the syntax}\\ CoC V4.1& dated 24 July 1987 (freeze date)\\ CoC V4.2& dated 10 September 1987\\ CoC V4.3& dated 15 September 1987 & \feature{mathematical vernacular toplevel}\\ & frozen November 1987 & \feature{section mechanism}\\ & & \feature{logical vs computational content (sorte Spec)}\\ & & \feature{LCF engine}\\ CoC V4.4& dated 27 January 1988 & \feature{impredicatively encoded inductive types}\\ & frozen March 1988\\ CoC V4.5 and V4.5.5& dated 15 March 1988 & \feature{program extraction}\\ & demonstrated in June 1988\\ CoC V4.6& dated 1 September 1988 & start of LEGO fork\\ CoC V4.7& started 6 September 1988 \\ CoC V4.8& dated 1 December 1988 (release time) & \feature{floating universes}\\ CoC V4.8.5& dated 1 February 1989 & \\ CoC V4.9& dated 1 March 1989 (release date)\\ CoC V4.10 and 4.10.1& dated 1 May 1989 & released with documentation in English\\ \end{tabular} \bigskip \noindent Note: CoC above stands as an abbreviation for {\em Calculus of Constructions}, official name of the system. \bigskip \bigskip \newpage \centerline{\large 1989-now: The Calculus of Inductive Constructions} \mbox{}\\ \centerline{I- RCS archives in Caml and Caml-Light} \mbox{}\\ \mbox{}\\ \begin{tabular}{l|l|l} version & date & comments \\ \hline Coq V5.0 & headers dated 1 January 1990 & internal use \\ & & \feature{inductive types with primitive recursor}\\ Coq V5.1 & ended 12 July 1990 & internal use \\ Coq V5.2 & log dated 4 October 1990 & internal use \\ Coq V5.3 & log dated 12 October 1990 & internal use \\ Coq V5.4 & headers dated 24 October 1990 & internal use, new \feature{extraction} (version 1) [3-12-90]\\ Coq V5.5 & started 6 December 1990 & internal use \\ Coq V5.6 beta & 1991 & first announce of the new Coq based on CIC \\ & & (in May at TYPES?)\\ & & \feature{rewrite tactic}\\ & & use of RCS at least from February 1991\\ Coq V5.6& 7 August 1991 & \\ Coq V5.6 patch 1& 13 November 1991 & \\ Coq V5.6 (last) & mention of 27 November 1992\\ Coq V5.7.0& 1992 & translation to Caml-Light \footnotemark\\ Coq V5.8& 12 February 1993 & \feature{Program} (version 1), \feature{simpl}\\ & & has the xcoq graphical interface\\ & & first explicit notion of standard library\\ & & includes a MacOS 7-9 version\\ Coq V5.8.1& released 28 April 1993 & with xcoq graphical interface and MacOS 7-9 support\\ Coq V5.8.2& released 9 July 1993 & with xcoq graphical interface and MacOS 7-9 support\\ Coq V5.8.3& released 6 December 1993 % Announce on coq-club & with xcoq graphical interface and MacOS 7-9 support\\ & & 3 branches: Lyon (V5.8.x), Ulm (V5.10.x) and Rocq (V5.9)\\ Coq V5.9 alpha& 7 July 1993 & experimental version based on evars refinement \\ & & (merge from experimental ``V6.0'' and some pre-V5.8.3 \\ & & version), not released\\ & March 1994 & \feature{tauto} tactic in V5.9 branch\\ Coq V5.9 & 27 January 1993 & experimental version based on evars refinement\\ & & not released\\ \end{tabular} \bigskip \bigskip \footnotetext{archive lost?} \newpage \centerline{II- Starting with CVS archives in Caml-Light} \mbox{}\\ \mbox{}\\ \begin{tabular}{l|l|l} version & date & comments \\ \hline Coq V5.10 ``Murthy'' & 22 January 1994 & introduction of the ``DOPN'' structure\\ & & \feature{eapply/prolog} tactics\\ & & private use of cvs on madiran.inria.fr\\ Coq V5.10.1 ``Murthy''& 15 April 1994 \\ Coq V5.10.2 ``Murthy''& 19 April 1994 & \feature{mutual inductive types, fixpoint} (from Lyon's branch)\\ Coq V5.10.3& 28 April 1994 \\ Coq V5.10.5& dated 13 May 1994 & \feature{inversion}, \feature{discriminate}, \feature{injection} \\ & & \feature{type synthesis of hidden arguments}\\ & & \feature{separate compilation}, \feature{reset mechanism} \\ Coq V5.10.6& dated 30 May 1994\\ Coq Lyon's archive & in 1994 & cvs server set up on woodstock.ens-lyon.fr\\ Coq V5.10.9& announced on 17 August 1994 & % Announced by Catherine Parent on coqdev % Version avec une copie de THEORIES pour les inductifs mutuels \\ Coq V5.10.11& announced on 2 February 1995 & \feature{compute}\\ Coq Rocq's archive & on 16 February 1995 & set up of ``V5.10'' cvs archive on pauillac.inria.fr \\ & & with first dispatch of files over src/* directories\\ Coq V5.10.12& dated 30 January 1995 & on Lyon's cvs\\ Coq V5.10.13& dated 9 June 1995 & on Lyon's cvs\\ Coq V5.10.14.OO& dated 30 June 1995 & on Lyon's cvs\\ Coq V5.10.14.a& announced 5 September 1995 & bug-fix release \\ % Announce on coq-club by BW Coq V5.10.14.b& released 2 October 1995 & bug-fix release\\ & & MS-DOS version released on 30 October 1995\\ % still available at ftp://ftp.ens-lyon.fr/pub/LIP/COQ/V5.10.14.old/ in May 2009 % also known in /net/pauillac/constr archive as ``V5.11 old'' \\ % A copy of Coq V5.10.15 dated 1 January 1996 coming from Lyon's CVS is % known in /net/pauillac/constr archive as ``V5.11 new old'' \\ Coq V5.10.15 & released 20 February 1996 & \feature{Logic, Sorting, new Sets and Relations libraries} \\ % Announce on coq-club by BW % dated 15 February 1996 and bound to pauillac's cvs in /net/pauillac/constr archive & & MacOS 7-9 version released on 1 March 1996 \\ % Announce on coq-club by BW Coq V5.11 & dated 1 March 1996 & not released, not in pauillac's CVS, \feature{eauto} \\ \end{tabular} \bigskip \bigskip \newpage \centerline{III- A CVS archive in Caml Special Light} \mbox{}\\ \mbox{}\\ \begin{tabular}{l|l|l} version & date & comments \\ \hline Coq ``V6'' archive & 20 March 1996 & new cvs repository on pauillac.inria.fr with code ported \\ & & to Caml Special Light (to later become Objective Caml)\\ & & has implicit arguments and coercions\\ & & has coinductive types\\ Coq V6.1beta& released 18 November 1996 & \feature{coercions} [23-5-1996], \feature{user-level implicit arguments} [23-5-1996]\\ & & \feature{omega} [10-9-1996] \\ & & \feature{natural language proof printing} (stopped from Coq V7) [6-9-1996]\\ & & \feature{pattern-matching compilation} [7-10-1996]\\ & & \feature{ring} (version 1, ACSimpl) [11-12-1996]\\ Coq V6.1& released December 1996 & \\ Coq V6.2beta& released 30 January 1998 & % Announced on coq-club 2-2-1998 by CP \feature{SearchIsos} (stopped from Coq V7) [9-11-1997]\\ & & grammar extension mechanism moved to Camlp4 [12-6-1997]\\ & & \feature{refine tactic}\\ & & includes a Windows version\\ Coq V6.2& released 4 May 1998 & % Announced on coq-club 5-5-1998 by CP \feature{ring} (version 2) [7-4-1998] \\ Coq V6.2.1& released 23 July 1998\\ Coq V6.2.2 beta& released 30 January 1998\\ Coq V6.2.2& released 23 September 1998\\ Coq V6.2.3& released 22 December 1998 & \feature{Real numbers library} [from 13-11-1998] \\ Coq V6.2.4& released 8 February 1999\\ Coq V6.3& released 27 July 1999 & \feature{autorewrite} [25-3-1999]\\ & & \feature{Correctness} (deprecated in V8, led to Why) [28-10-1997]\\ Coq V6.3.1& released 7 December 1999\\ \end{tabular} \medskip \bigskip \newpage \centerline{IV- New CVS, back to a kernel-centric implementation} \mbox{}\\ \mbox{}\\ \begin{tabular}{l|l|l} version & date & comments \\ \hline Coq ``V7'' archive & August 1999 & new cvs archive based on J.-C. Filliâtre's \\ & & \feature{kernel-centric} architecture \\ & & more care for outside readers\\ & & (indentation, ocaml warning protection)\\ Coq V7.0beta& released 27 December 2000 & \feature{${\cal L}_{\mathit{tac}}$} \\ Coq V7.0beta2& released 2 February 2001\\ Coq V7.0& released 25 April 2001 & \feature{extraction} (version 2) [6-2-2001] \\ & & \feature{field} (version 1) [19-4-2001], \feature{fourier} [20-4-2001] \\ Coq V7.1& released 25 September 2001 & \feature{setoid rewriting} (version 1) [10-7-2001]\\ Coq V7.2& released 10 January 2002\\ Coq V7.3& released 16 May 2002\\ Coq V7.3.1& released 5 October 2002 & \feature{module system} [2-8-2002]\\ & & \feature{pattern-matching compilation} (version 2) [13-6-2002]\\ Coq V7.4& released 6 February 2003 & \feature{notation}, \feature{scopes} [13-10-2002]\\ \end{tabular} \medskip \bigskip \centerline{V- New concrete syntax} \mbox{}\\ \mbox{}\\ \begin{tabular}{l|l|l} version & date & comments \\ \hline Coq V8.0& released 21 April 2004 & \feature{new concrete syntax}, \feature{Set predicative}, \feature{CoqIDE} [from 4-2-2003]\\ Coq V8.0pl1& released 18 July 2004\\ Coq V8.0pl2& released 22 January 2005\\ Coq V8.0pl3& released 13 January 2006\\ Coq V8.0pl4& released 26 January 2007\\ Coq ``svn'' archive & 6 March 2006 & cvs archive moved to subversion control management\\ Coq V8.1beta& released 12 July 2006 & \feature{bytecode compiler} [20-10-2004] \\ & & \feature{setoid rewriting} (version 2) [3-9-2004]\\ & & \feature{functional induction} [1-2-2006]\\ & & \feature{Strings library} [8-2-2006], \feature{FSets/FMaps library} [15-3-2006] \\ & & \feature{Program} (version 2, Russell) [5-3-2006] \\ & & \feature{declarative language} [20-9-2006]\\ & & \feature{ring} (version 3) [18-11-2005]\\ Coq V8.1gamma& released 7 November 2006 & \feature{field} (version 2) [29-9-2006]\\ Coq V8.1& released 10 February 2007 & \\ Coq V8.1pl1& released 27 July 2007 & \\ Coq V8.1pl2& released 13 October 2007 & \\ Coq V8.1pl3& released 13 December 2007 & \\ Coq V8.1pl4& released 9 October 2008 & \\ Coq V8.2 beta1& released 13 June 2008 & \\ Coq V8.2 beta2& released 19 June 2008 & \\ Coq V8.2 beta3& released 27 June 2008 & \\ Coq V8.2 beta4& released 8 August 2008 & \\ Coq V8.2 & released 17 February 2009 & \feature{type classes} [10-12-2007], \feature{machine words} [11-5-2007]\\ & & \feature{big integers} [11-5-2007], \feature{abstract arithmetics} [9-2007]\\ & & \feature{setoid rewriting} (version 3) [18-12-2007] \\ & & \feature{micromega solving platform} [19-5-2008]\\ & & a first package released on February 11 was incomplete\\ Coq V8.2pl1& released 4 July 2009 & \\ Coq V8.2pl2& released 29 June 2010 & \\ \end{tabular} \medskip \bigskip \newpage \mbox{}\\ \mbox{}\\ \begin{tabular}{l|l|l} Coq V8.3 beta & released 16 February 2010 & \feature{MSets library} [13-10-2009] \\ Coq V8.3 & released 14 October 2010 & \feature{nsatz} [3-6-2010] \\ Coq V8.3pl1& released 23 December 2010 & \\ Coq V8.3pl2& released 19 April 2011 & \\ Coq V8.3pl3& released 19 December 2011 & \\ Coq V8.3pl3& released 26 March 2012 & \\ Coq V8.3pl5& released 28 September 2012 & \\ Coq V8.4 beta & released 27 December 2011 & \feature{modular arithmetic library} [2010-2012]\\ && \feature{vector library} [10-12-2010]\\ && \feature{structured scripts} [22-4-2010]\\ && \feature{eta-conversion} [20-9-2010]\\ && \feature{new proof engine available} [10-12-2010]\\ Coq V8.4 beta2 & released 21 May 2012 & \\ Coq V8.4 & released 12 August 2012 &\\ Coq V8.4pl1& released 22 December 2012 & \\ Coq V8.4pl2& released 4 April 2013 & \\ Coq V8.4pl3& released 21 December 2013 & \\ Coq V8.4pl4& released 24 April 2014 & \\ Coq V8.4pl5& released 22 October 2014 & \\ Coq V8.4pl6& released 9 April 2015 & \\ Coq V8.5 beta1 & released 21 January 2015 & \feature{computation via compilation to OCaml} [22-1-2013]\\ && \feature{asynchonous evaluation} [8-8-2013]\\ && \feature{new proof engine deployed} [2-11-2013]\\ && \feature{universe polymorphism} [6-5-2014]\\ && \feature{primitive projections} [6-5-2014]\\ Coq V8.5 beta2 & released 22 April 2015 & \feature{MMaps library} [4-3-2015]\\ \end{tabular} \medskip \bigskip \newpage \centerline{\large Other important dates} \mbox{}\\ \mbox{}\\ \begin{tabular}{l|l|l} version & date & comments \\ \hline Lechenadec's version in C& mention of \\ & 13 January 1985 on \\ & some vernacular files\\ Set up of the coq-club mailing list & 28 July 1993\\ Coq V6.0 ``evars'' & & experimentation based on evars refinement started \\ & & in 1991 by Gilles from V5.6 beta,\\ & & with work by Hugo in July 1992\\ Coq V6.0 ``evars'' ``light'' & July 1993 & Hugo's port of the first evars-based experimentation \\ & & to Coq V5.7, version from October/November 1992\\ CtCoq & released 25 October 1995 & first beta-version \\ % Announce on coq-club by Janet Proto with explicit substitutions & 1997 &\\ Coq web site & 15 April 1998 & new site designed by David Delahaye \\ Coq web site & January 2004 & web site new style \\ & & designed by Julien Narboux and Florent Kirchner \\ Coq web site & April 2009 & new Drupal-based site \\ & & designed by Jean-Marc Notin and Denis Cousineau \\ \end{tabular} \end{document} coq-8.6/dev/doc/naming-conventions.tex0000644000175000017500000005443013022274260017346 0ustar mdenesmdenes\documentclass[a4paper]{article} \usepackage{fullpage} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{amsfonts} \parindent=0pt \parskip=10pt %%%%%%%%%%%%% % Macros \newcommand\itemrule[3]{ \subsubsection{#1} \begin{quote} \begin{tt} #3 \end{tt} \end{quote} \begin{quote} Name: \texttt{#2} \end{quote}} \newcommand\formula[1]{\begin{tt}#1\end{tt}} \newcommand\tactic[1]{\begin{tt}#1\end{tt}} \newcommand\command[1]{\begin{tt}#1\end{tt}} \newcommand\term[1]{\begin{tt}#1\end{tt}} \newcommand\library[1]{\texttt{#1}} \newcommand\name[1]{\texttt{#1}} \newcommand\zero{\texttt{zero}} \newcommand\op{\texttt{op}} \newcommand\opPrime{\texttt{op'}} \newcommand\opSecond{\texttt{op''}} \newcommand\phimapping{\texttt{phi}} \newcommand\D{\texttt{D}} \newcommand\elt{\texttt{elt}} \newcommand\rel{\texttt{rel}} \newcommand\relp{\texttt{rel'}} %%%%%%%%%%%%% \begin{document} \begin{center} \begin{huge} Proposed naming conventions for the Coq standard library \end{huge} \end{center} \bigskip The following document describes a proposition of canonical naming schemes for the Coq standard library. Obviously and unfortunately, the current state of the library is not as homogeneous as it would be if it would systematically follow such a scheme. To tend in this direction, we however recommend to follow the following suggestions. \tableofcontents \section{General conventions} \subsection{Variable names} \begin{itemize} \item Variables are preferably quantified at the head of the statement, even if some premisses do not depend of one of them. For instance, one would state \begin{quote} \begin{tt} {forall x y z:D, x <= y -> x+z <= y+z} \end{tt} \end{quote} and not \begin{quote} \begin{tt} {forall x y:D, x <= y -> forall z:D, x+z <= y+z} \end{tt} \end{quote} \item Variables are preferably quantified (and named) in the order of ``importance'', then of appearance, from left to right, even if for the purpose of some tactics it would have been more convenient to have, say, the variables not occurring in the conclusion first. For instance, one would state \begin{quote} \begin{tt} {forall x y z:D, x+z <= y+z -> x <= y} \end{tt} \end{quote} and not \begin{quote} \begin{tt} {forall z x y:D, x+z <= y+z -> x <= y} \end{tt} \end{quote} nor \begin{quote} \begin{tt} {forall x y z:D, y+x <= z+x -> y <= z} \end{tt} \end{quote} \item Choice of effective names is domain-dependent. For instance, on natural numbers, the convention is to use the variables $n$, $m$, $p$, $q$, $r$, $s$ in this order. On generic domains, the convention is to use the letters $x$, $y$, $z$, $t$. When more than three variables are needed, indexing variables It is conventional to use specific names for variables having a special meaning. For instance, $eps$ or $\epsilon$ can be used to denote a number intended to be as small as possible. Also, $q$ and $r$ can be used to denote a quotient and a rest. This is good practice. \end{itemize} \subsection{Disjunctive statements} A disjunctive statement with a computational content will be suffixed by \name{\_inf}. For instance, if \begin{quote} \begin{tt} {forall x y, op x y = zero -> x = zero \/ y = zero} \end{tt} \end{quote} has name \texttt{D\_integral}, then \begin{quote} \begin{tt} {forall x y, op x y = zero -> \{x = zero\} + \{y = zero\}} \end{tt} \end{quote} will have name \texttt{D\_integral\_inf}. As an exception, decidability statements, such as \begin{quote} \begin{tt} {forall x y, \{x = y\} + \{x <> y\}} \end{tt} \end{quote} will have a named ended in \texttt{\_dec}. Idem for cotransitivity lemmas which are inherently computational that are ended in \texttt{\_cotrans}. \subsection{Inductive types constructor names} As a general rule, constructor names start with the name of the inductive type being defined as in \texttt{Inductive Z := Z0 : Z | Zpos : Z -> Z | Zneg : Z -> Z} to the exception of very standard types like \texttt{bool}, \texttt{nat}, \texttt{list}... For inductive predicates, constructor names also start with the name of the notion being defined with one or more suffixes separated with \texttt{\_} for discriminating the different cases as e.g. in \begin{verbatim} Inductive even : nat -> Prop := | even_O : even 0 | even_S n : odd n -> even (S n) with odd : nat -> Prop := | odd_S n : even n -> odd (S n). \end{verbatim} As a general rule, inductive predicate names should be lowercase (to the exception of notions referring to a proper name, e.g. \texttt{Bezout}) and multiple words must be separated by ``{\_}''. As an exception, when extending libraries whose general rule is that predicates names start with a capital letter, the convention of this library should be kept and the separation between multiple words is done by making the initial of each work a capital letter (if one of these words is a proper name, then a ``{\_}'' is added to emphasize that the capital letter is proper and not an application of the rule for marking the change of word). Inductive predicates that characterize the specification of a function should be named after the function it specifies followed by \texttt{\_spec} as in: \begin{verbatim} Inductive nth_spec : list A -> nat -> A -> Prop := | nth_spec_O a l : nth_spec (a :: l) 0 a | nth_spec_S n a b l : nth_spec l n a -> nth_spec (b :: l) (S n) a. \end{verbatim} \section{Equational properties of operations} \subsection{General conventions} If the conclusion is in the other way than listed below, add suffix \name{\_reverse} to the lemma name. \subsection{Specific conventions} \itemrule{Associativity of binary operator {\op} on domain {\D}}{Dop\_assoc} {forall x y z:D, op x (op y z) = op (op x y) z} Remark: Symmetric form: \name{Dop\_assoc\_reverse}: \formula{forall x y z:D, op (op x y) z = op x (op y z)} \itemrule{Commutativity of binary operator {\op} on domain {\D}}{Dop\_comm} {forall x y:D, op x y = op y x} Remark: Avoid \formula{forall x y:D, op y x = op x y}, or at worst, call it \name{Dop\_comm\_reverse} \itemrule{Left neutrality of element elt for binary operator {\op}}{Dop\_elt\_l} {forall x:D, op elt x = x} Remark: In English, ``{\elt} is an identity for {\op}'' seems to be a more common terminology. \itemrule{Right neutrality of element elt for binary operator {\op}}{Dop\_elt\_r} {forall x:D, op x elt = x} Remark: By convention, if the identities are reminiscent to zero or one, they are written 1 and 0 in the name of the property. \itemrule{Left absorption of element elt for binary operator {\op}}{Dop\_elt\_l} {forall x:D, op elt x = elt} Remarks: \begin{itemize} \item In French school, this property is named "elt est absorbant pour op" \item English, the property seems generally named "elt is a zero of op" \item In the context of lattices, this a boundedness property, it may be called "elt is a bound on D", or referring to a (possibly arbitrarily oriented) order "elt is a least element of D" or "elt is a greatest element of D" \end{itemize} \itemrule{Right absorption of element {\elt} for binary operator {\op}}{Dop\_elt\_l [BAD ??]} {forall x:D, op x elt = elt} \itemrule{Left distributivity of binary operator {\op} over {\opPrime} on domain {\D}}{Dop\_op'\_distr\_l} {forall x y z:D, op (op' x y) z = op' (op x z) (op y z)} Remark: Some authors say ``distribution''. \itemrule{Right distributivity of binary operator {\op} over {\opPrime} on domain {\D}}{Dop\_op'\_distr\_r} {forall x y z:D, op z (op' x y) = op' (op z x) (op z y)} Remark: Note the order of arguments. \itemrule{Distributivity of unary operator {\op} over binary op' on domain {\D}}{Dop\_op'\_distr} {forall x y:D, op (op' x y) = op' (op x) (op y)} \itemrule{Distributivity of unary operator {\op} over binary op' on domain {\D}}{Dop\_op'\_distr} {forall x y:D, op (op' x y) = op' (op x) (op y)} Remark: For a non commutative operation with inversion of arguments, as in \formula{forall x y z:D, op (op' x y) = op' (op y) (op y z)}, we may probably still call the property distributivity since there is no ambiguity. Example: \formula{forall n m : Z, -(n+m) = (-n)+(-m)}. Example: \formula{forall l l' : list A, rev (l++l') = (rev l)++(rev l')}. \itemrule{Left extrusion of unary operator {\op} over binary op' on domain {\D}}{Dop\_op'\_distr\_l} {forall x y:D, op (op' x y) = op' (op x) y} Question: Call it left commutativity ?? left swap ? \itemrule{Right extrusion of unary operator {\op} over binary op' on domain {\D}}{Dop\_op'\_distr\_r} {forall x y:D, op (op' x y) = op' x (op y)} \itemrule{Idempotency of binary operator {\op} on domain {\D}}{Dop\_idempotent} {forall x:D, op x n = x} \itemrule{Idempotency of unary operator {\op} on domain {\D}}{Dop\_idempotent} {forall x:D, op (op x) = op x} Remark: This is actually idempotency of {\op} wrt to composition and identity. \itemrule{Idempotency of element elt for binary operator {\op} on domain {\D}}{Dop\_elt\_idempotent} {op elt elt = elt} Remark: Generally useless in CIC for concrete, computable operators Remark: The general definition is ``exists n, iter n op x = x''. \itemrule{Nilpotency of element elt wrt a ring D with additive neutral element {\zero} and multiplicative binary operator {\op}}{Delt\_nilpotent} {op elt elt = zero} Remark: We leave the ring structure of D implicit; the general definition is ``exists n, iter n op elt = zero''. \itemrule{Zero-product property in a ring D with additive neutral element {\zero} and multiplicative binary operator {\op}}{D\_integral} {forall x y, op x y = zero -> x = zero \/ y = zero} Remark: We leave the ring structure of D implicit; the Coq library uses either \texttt{\_is\_O} (for \texttt{nat}), \texttt{\_integral} (for \texttt{Z}, \texttt{Q} and \texttt{R}), \texttt{eq\_mul\_0} (for \texttt{NZ}). Remark: The French school says ``integrité''. \itemrule{Nilpotency of binary operator {\op} wrt to its absorbing element zero in D}{Dop\_nilpotent} {forall x, op x x = zero} Remark: Did not find this definition on the web, but it used in the Coq library (to characterize \name{xor}). \itemrule{Involutivity of unary op on D}{Dop\_involutive} {forall x:D, op (op x) = x} \itemrule{Absorption law on the left for binary operator {\op} over binary operator {\op}' on the left}{Dop\_op'\_absorption\_l\_l} {forall x y:D, op x (op' x y) = x} \itemrule{Absorption law on the left for binary operator {\op} over binary operator {\op}' on the right}{Dop\_op'\_absorption\_l\_r} {forall x y:D, op x (op' y x) = x} Remark: Similarly for \name{Dop\_op'\_absorption\_r\_l} and \name{Dop\_op'\_absorption\_r\_r}. \itemrule{De Morgan law's for binary operators {\opPrime} and {\opSecond} wrt to unary op on domain {\D}}{Dop'\_op''\_de\_morgan, Dop''\_op'\_de\_morgan ?? \mbox{leaving the complementing operation implicit})} {forall x y:D, op (op' x y) = op'' (op x) (op y)\\ forall x y:D, op (op'' x y) = op' (op x) (op y)} \itemrule{Left complementation of binary operator {\op} by means of unary {\opPrime} wrt neutral element {\elt} of {\op} on domain {\D}}{Dop\_op'\_opp\_l} {forall x:D, op (op' x) x = elt} Remark: If the name of the opposite function is reminiscent of the notion of complement (e.g. if it is called \texttt{opp}), one can simply say {Dop\_opp\_l}. \itemrule{Right complementation of binary operator {\op} by means of unary {\op'} wrt neutral element {\elt} of {\op} on domain {\D}}{Dop\_opp\_r} {forall x:D, op x (op' x) = elt} Example: \formula{Radd\_opp\_l: forall r : R, - r + r = 0} \itemrule{Associativity of binary operators {\op} and {\op'}}{Dop\_op'\_assoc} {forall x y z, op x (op' y z) = op (op' x y) z} Example: \formula{forall x y z, x + (y - z) = (x + y) - z} \itemrule{Right extrusion of binary operator {\opPrime} over binary operator {\op}}{Dop\_op'\_extrusion\_r} {forall x y z, op x (op' y z) = op' (op x y) z} Remark: This requires {\op} and {\opPrime} to have their right and left argument respectively and their return types identical. Example: \formula{forall x y z, x + (y - z) = (x + y) - z} Remark: Other less natural combinations are possible, such as \formula{forall x y z, op x (op' y z) = op' y (op x z)}. \itemrule{Left extrusion of binary operator {\opPrime} over binary operator {\op}}{Dop\_op'\_extrusion\_l} {forall x y z, op (op' x y) z = op' x (op y z)} Remark: Operations are not necessarily internal composition laws. It is only required that {\op} and {\opPrime} have their right and left argument respectively and their return type identical. Remark: When the type are heterogeneous, only one extrusion law is possible and it can simply be named {Dop\_op'\_extrusion}. Example: \formula{app\_cons\_extrusion : forall a l l', (a :: l) ++ l' = a :: (l ++ l')}. %====================================================================== %\section{Properties of elements} %Remark: Not used in current library %====================================================================== \section{Preservation and compatibility properties of operations} \subsection{With respect to equality} \itemrule{Injectivity of unary operator {\op}}{Dop\_inj} {forall x y:D, op x = op y -> x = y} \itemrule{Left regularity of binary operator {\op}}{Dop\_reg\_l, Dop\_inj\_l, or Dop\_cancel\_l} {forall x y z:D, op z x = op z y -> x = y} Remark: Note the order of arguments. Remark: The Coq usage is to called it regularity but the English standard seems to be cancellation. The recommended form is not decided yet. Remark: Shall a property like $n^p \leq n^q \rightarrow p \leq q$ (for $n\geq 1$) be called cancellation or should it be reserved for operators that have an inverse? \itemrule{Right regularity of binary operator {\op}}{Dop\_reg\_r, Dop\_inj\_r, Dop\_cancel\_r} {forall x y z:D, op x z = op y z -> x = y} \subsection{With respect to a relation {\rel}} \itemrule{Compatibility of unary operator {\op}}{Dop\_rel\_compat} {forall x y:D, rel x y -> rel (op x) (op y)} \itemrule{Left compatibility of binary operator {\op}}{Dop\_rel\_compat\_l} {forall x y z:D, rel x y -> rel (op z x) (op z y)} \itemrule{Right compatibility of binary operator {\op}}{Dop\_rel\_compat\_r} {forall x y z:D, rel x y -> rel (op x z) (op y z)} Remark: For equality, use names of the form \name{Dop\_eq\_compat\_l} or \name{Dop\_eq\_compat\_r} (\formula{forall x y z:D, y = x -> op y z = op x z} and \formula{forall x y z:D, y = x -> op y z = op x z}) Remark: Should we admit (or even prefer) the name \name{Dop\_rel\_monotone}, \name{Dop\_rel\_monotone\_l}, \name{Dop\_rel\_monotone\_r} when {\rel} is an order ? \itemrule{Left regularity of binary operator {\op}}{Dop\_rel\_reg\_l} {forall x y z:D, rel (op z x) (op z y) -> rel x y} \itemrule{Right regularity of binary operator {\op}}{Dop\_rel\_reg\_r} {forall x y z:D, rel (op x z) (op y z) -> rel x y} Question: Would it be better to have \name{z} as first argument, since it is missing in the conclusion ?? (or admit we shall use the options ``\texttt{with p}''?) \itemrule{Left distributivity of binary operator {\op} over {\opPrime} along relation {\rel} on domain {\D}}{Dop\_op'\_rel\_distr\_l} {forall x y z:D, rel (op (op' x y) z) (op' (op x z) (op y z))} Example: standard property of (not necessarily distributive) lattices Remark: In a (non distributive) lattice, by swapping join and meet, one would like also, \formula{forall x y z:D, rel (op' (op x z) (op y z)) (op (op' x y) z)}. How to name it with a symmetric name (use \name{Dop\_op'\_rel\_distr\_mon\_l} and \name{Dop\_op'\_rel\_distr\_anti\_l})? \itemrule{Commutativity of binary operator {\op} along (equivalence) relation {\rel} on domain {\D}}{Dop\_op'\_rel\_comm} {forall x y z:D, rel (op x y) (op y x)} Example: \formula{forall l l':list A, Permutation (l++l') (l'++l)} \itemrule{Irreducibility of binary operator {\op} on domain {\D}}{Dop\_irreducible} {forall x y z:D, z = op x y -> z = x $\backslash/$ z = y} Question: What about the constructive version ? Call it \name{Dop\_irreducible\_inf} ? \formula{forall x y z:D, z = op x y -> \{z = x\} + \{z = y\}} \itemrule{Primality of binary operator {\op} along relation {\rel} on domain {\D}}{Dop\_rel\_prime} {forall x y z:D, rel z (op x y) -> rel z x $\backslash/$ rel z y} %====================================================================== \section{Morphisms} \itemrule{Morphism between structures {\D} and {\D'}}{\name{D'\_of\_D}}{D -> D'} Remark: If the domains are one-letter long, one can used \texttt{IDD'} as for \name{INR} or \name{INZ}. \itemrule{Morphism {\phimapping} mapping unary operators {\op} to {\op'}}{phi\_op\_op', phi\_op\_op'\_morphism} {forall x:D, phi (op x) = op' (phi x)} Remark: If the operators have the same name in both domains, one use \texttt{D'\_of\_D\_op} or \texttt{IDD'\_op}. Example: \formula{Z\_of\_nat\_mult: forall n m : nat, Z\_of\_nat (n * m) = (Z\_of\_nat n * Z\_of\_nat m)\%Z}. Remark: If the operators have different names on distinct domains, one can use \texttt{op\_op'}. \itemrule{Morphism {\phimapping} mapping binary operators {\op} to {\op'}}{phi\_op\_op', phi\_op\_op'\_morphism} {forall x y:D, phi (op x y) = op' (phi x) (phi y)} Remark: If the operators have the same name in both domains, one use \texttt{D'\_of\_D\_op} or \texttt{IDD'\_op}. Remark: If the operators have different names on distinct domains, one can use \texttt{op\_op'}. \itemrule{Morphism {\phimapping} mapping binary operator {\op} to binary relation {\rel}}{phi\_op\_rel, phi\_op\_rel\_morphism} {forall x y:D, phi (op x y) <-> rel (phi x) (phi y)} Remark: If the operator and the relation have similar name, one uses \texttt{phi\_op}. Question: How to name each direction? (add \_elim for -> and \_intro for <- ?? -- as done in Bool.v ??) Example: \formula{eq\_true\_neg: \~{} eq\_true b <-> eq\_true (negb b)}. %====================================================================== \section{Preservation and compatibility properties of operations wrt order} \itemrule{Compatibility of binary operator {\op} wrt (strict order) {\rel} and (large order) {\rel'}}{Dop\_rel\_rel'\_compat} {forall x y z t:D, rel x y -> rel' z t -> rel (op x z) (op y t)} \itemrule{Compatibility of binary operator {\op} wrt (large order) {\relp} and (strict order) {\rel}}{Dop\_rel'\_rel\_compat} {forall x y z t:D, rel' x y -> rel z t -> rel (op x z) (op y t)} %====================================================================== \section{Properties of relations} \itemrule{Reflexivity of relation {\rel} on domain {\D}}{Drel\_refl} {forall x:D, rel x x} \itemrule{Symmetry of relation {\rel} on domain {\D}}{Drel\_sym} {forall x y:D, rel x y -> rel y x} \itemrule{Transitivity of relation {\rel} on domain {\D}}{Drel\_trans} {forall x y z:D, rel x y -> rel y z -> rel x z} \itemrule{Antisymmetry of relation {\rel} on domain {\D}}{Drel\_antisym} {forall x y:D, rel x y -> rel y x -> x = y} \itemrule{Irreflexivity of relation {\rel} on domain {\D}}{Drel\_irrefl} {forall x:D, \~{} rel x x} \itemrule{Asymmetry of relation {\rel} on domain {\D}}{Drel\_asym} {forall x y:D, rel x y -> \~{} rel y x} \itemrule{Cotransitivity of relation {\rel} on domain {\D}}{Drel\_cotrans} {forall x y z:D, rel x y -> \{rel z y\} + \{rel x z\}} \itemrule{Linearity of relation {\rel} on domain {\D}}{Drel\_trichotomy} {forall x y:D, \{rel x y\} + \{x = y\} + \{rel y x\}} Questions: Or call it \name{Drel\_total}, or \name{Drel\_linear}, or \name{Drel\_connected}? Use $\backslash/$ ? or use a ternary sumbool, or a ternary disjunction, for nicer elimination. \itemrule{Informative decidability of relation {\rel} on domain {\D}}{Drel\_dec (or Drel\_dect, Drel\_dec\_inf ?)} {forall x y:D, \{rel x y\} + \{\~{} rel x y\}} Remark: If equality: \name{D\_eq\_dec} or \name{D\_dec} (not like \name{eq\_nat\_dec}) \itemrule{Non informative decidability of relation {\rel} on domain {\D}}{Drel\_dec\_prop (or Drel\_dec)} {forall x y:D, rel x y $\backslash/$ \~{} rel x y} \itemrule{Inclusion of relation {\rel} in relation {\rel}' on domain {\D}}{Drel\_rel'\_incl (or Drel\_incl\_rel')} {forall x y:D, rel x y -> rel' x y} Remark: Use \name{Drel\_rel'\_weak} for a strict inclusion ?? %====================================================================== \section{Relations between properties} \itemrule{Equivalence of properties \texttt{P} and \texttt{Q}}{P\_Q\_iff} {forall x1 .. xn, P <-> Q} Remark: Alternatively use \name{P\_iff\_Q} if it is too difficult to recover what pertains to \texttt{P} and what pertains to \texttt{Q} in their concatenation (as e.g. in \texttt{Godel\_Dummett\_iff\_right\_distr\_implication\_over\_disjunction}). %====================================================================== \section{Arithmetical conventions} \begin{minipage}{6in} \renewcommand{\thefootnote}{\thempfootnote} % For footnotes... \begin{tabular}{lll} Zero on domain {\D} & D0 & (notation \verb=0=)\\ One on domain {\D} & D1 (if explicitly defined) & (notation \verb=1=)\\ Successor on domain {\D} & Dsucc\\ Predessor on domain {\D} & Dpred\\ Addition on domain {\D} & Dadd/Dplus\footnote{Coq historically uses \texttt{plus} and \texttt{mult} for addition and multiplication which are inconsistent notations, the recommendation is to use \texttt{add} and \texttt{mul} except in existng libraries that already use \texttt{plus} and \texttt{mult}} & (infix notation \verb=+= [50,L])\\ Multiplication on domain {\D} & Dmul/Dmult\footnotemark[\value{footnote}] & (infix notation \verb=*= [40,L]))\\ Soustraction on domain {\D} & Dminus & (infix notation \verb=-= [50,L])\\ Opposite on domain {\D} & Dopp (if any) & (prefix notation \verb=-= [35,R]))\\ Inverse on domain {\D} & Dinv (if any) & (prefix notation \verb=/= [35,R]))\\ Power on domain {\D} & Dpower & (infix notation \verb=^= [30,R])\\ Minimal element on domain {\D} & Dmin\\ Maximal element on domain {\D} & Dmax\\ Large less than order on {\D} & Dle & (infix notations \verb!<=! and \verb!>=! [70,N]))\\ Strict less than order on {\D} & Dlt & (infix notations \verb=<= and \verb=>= [70,N]))\\ \end{tabular} \bigskip \end{minipage} \bigskip The status of \verb!>=! and \verb!>! is undecided yet. It will eithet be accepted only as parsing notations or may also accepted as a {\em definition} for the \verb!<=! and \verb! kernel/cClosure.ml{,i} lib/errors.ml{,i} -> lib/cErrors.ml{,i} toplevel/cerror.ml{,i} -> toplevel/explainErr.mli{,i} All IDE-specific files, including the XML protocol have been moved to ide/ ** Reduction functions ** In closure.ml, we introduced the more precise reduction flags fMATCH, fFIX, fCOFIX. We renamed the following functions: Closure.betadeltaiota -> Closure.all Closure.betadeltaiotanolet -> Closure.allnolet Reductionops.beta -> Closure.beta Reductionops.zeta -> Closure.zeta Reductionops.betaiota -> Closure.betaiota Reductionops.betaiotazeta -> Closure.betaiotazeta Reductionops.delta -> Closure.delta Reductionops.betalet -> Closure.betazeta Reductionops.betadelta -> Closure.betadeltazeta Reductionops.betadeltaiota -> Closure.all Reductionops.betadeltaiotanolet -> Closure.allnolet Closure.no_red -> Closure.nored Reductionops.nored -> Closure.nored Reductionops.nf_betadeltaiota -> Reductionops.nf_all Reductionops.whd_betadelta -> Reductionops.whd_betadeltazeta Reductionops.whd_betadeltaiota -> Reductionops.whd_all Reductionops.whd_betadeltaiota_nolet -> Reductionops.whd_allnolet Reductionops.whd_betadelta_stack -> Reductionops.whd_betadeltazeta_stack Reductionops.whd_betadeltaiota_stack -> Reductionops.whd_all_stack Reductionops.whd_betadeltaiota_nolet_stack -> Reductionops.whd_allnolet_stack Reductionops.whd_betadelta_state -> Reductionops.whd_betadeltazeta_state Reductionops.whd_betadeltaiota_state -> Reductionops.whd_all_state Reductionops.whd_betadeltaiota_nolet_state -> Reductionops.whd_allnolet_state Reductionops.whd_eta -> Reductionops.shrink_eta Tacmach.pf_whd_betadeltaiota -> Tacmach.pf_whd_all Tacmach.New.pf_whd_betadeltaiota -> Tacmach.New.pf_whd_all And removed the following ones: Reductionops.whd_betaetalet Reductionops.whd_betaetalet_stack Reductionops.whd_betaetalet_state Reductionops.whd_betadeltaeta_stack Reductionops.whd_betadeltaeta_state Reductionops.whd_betadeltaeta Reductionops.whd_betadeltaiotaeta_stack Reductionops.whd_betadeltaiotaeta_state Reductionops.whd_betadeltaiotaeta In intf/genredexpr.mli, fIota was replaced by FMatch, FFix and FCofix. Similarly, rIota was replaced by rMatch, rFix and rCofix. ** Notation_ops ** Use Glob_ops.glob_constr_eq instead of Notation_ops.eq_glob_constr. ** Logging and Pretty Printing: ** * Printing functions have been removed from `Pp.mli`, which is now a purely pretty-printing interface. Functions affected are: ```` ocaml val pp : std_ppcmds -> unit val ppnl : std_ppcmds -> unit val pperr : std_ppcmds -> unit val pperrnl : std_ppcmds -> unit val pperr_flush : unit -> unit val pp_flush : unit -> unit val flush_all : unit -> unit val msg : std_ppcmds -> unit val msgnl : std_ppcmds -> unit val msgerr : std_ppcmds -> unit val msgerrnl : std_ppcmds -> unit val message : string -> unit ```` which are no more available. Users of `Pp.pp msg` should now use the proper `Feedback.msg_*` function. Clients also have no control over flushing, the back end takes care of it. Also, the `msg_*` functions now take an optional `?loc` parameter for relaying location to the client. * Feedback related functions and definitions have been moved to the `Feedback` module. `message_level` has been renamed to level. Functions moved from Pp to Feedback are: ```` ocaml val set_logger : logger -> unit val std_logger : logger val emacs_logger : logger val feedback_logger : logger ```` * Changes in the Feedback format/Protocol. - The `Message` feedback type now carries an optional location, the main payload is encoded using the richpp document format. - The `ErrorMsg` feedback type is thus unified now with `Message` at level `Error`. * We now provide several loggers, `log_via_feedback` is removed in favor of `set_logger feedback_logger`. Output functions are: ```` ocaml val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b val msg_error : ?loc:Loc.t -> Pp.std_ppcmds -> unit val msg_warning : ?loc:Loc.t -> Pp.std_ppcmds -> unit val msg_notice : ?loc:Loc.t -> Pp.std_ppcmds -> unit val msg_info : ?loc:Loc.t -> Pp.std_ppcmds -> unit val msg_debug : ?loc:Loc.t -> Pp.std_ppcmds -> unit ```` with the `msg_*` functions being just an alias for `logger $Level`. * The main feedback functions are: ```` ocaml val set_feeder : (feedback -> unit) -> unit val feedback : ?id:edit_or_state_id -> ?route:route_id -> feedback_content -> unit val set_id_for_feedback : ?route:route_id -> edit_or_state_id -> unit ```` Note that `feedback` doesn't take two parameters anymore. After refactoring the following function has been removed: ```` ocaml val get_id_for_feedback : unit -> edit_or_state_id * route_id ```` ** Kernel API changes ** - The interface of the Context module was changed. Related types and functions were put in separate submodules. The mapping from old identifiers to new identifiers is the following: Context.named_declaration ---> Context.Named.Declaration.t Context.named_list_declaration ---> Context.NamedList.Declaration.t Context.rel_declaration ---> Context.Rel.Declaration.t Context.map_named_declaration ---> Context.Named.Declaration.map_constr Context.map_named_list_declaration ---> Context.NamedList.Declaration.map Context.map_rel_declaration ---> Context.Rel.Declaration.map_constr Context.fold_named_declaration ---> Context.Named.Declaration.fold Context.fold_rel_declaration ---> Context.Rel.Declaration.fold Context.exists_named_declaration ---> Context.Named.Declaration.exists Context.exists_rel_declaration ---> Context.Rel.Declaration.exists Context.for_all_named_declaration ---> Context.Named.Declaration.for_all Context.for_all_rel_declaration ---> Context.Rel.Declaration.for_all Context.eq_named_declaration ---> Context.Named.Declaration.equal Context.eq_rel_declaration ---> Context.Rel.Declaration.equal Context.named_context ---> Context.Named.t Context.named_list_context ---> Context.NamedList.t Context.rel_context ---> Context.Rel.t Context.empty_named_context ---> Context.Named.empty Context.add_named_decl ---> Context.Named.add Context.vars_of_named_context ---> Context.Named.to_vars Context.lookup_named ---> Context.Named.lookup Context.named_context_length ---> Context.Named.length Context.named_context_equal ---> Context.Named.equal Context.fold_named_context ---> Context.Named.fold_outside Context.fold_named_list_context ---> Context.NamedList.fold Context.fold_named_context_reverse ---> Context.Named.fold_inside Context.instance_from_named_context ---> Context.Named.to_instance Context.extended_rel_list ---> Context.Rel.to_extended_list Context.extended_rel_vect ---> Context.Rel.to_extended_vect Context.fold_rel_context ---> Context.Rel.fold_outside Context.fold_rel_context_reverse ---> Context.Rel.fold_inside Context.map_rel_context ---> Context.Rel.map_constr Context.map_named_context ---> Context.Named.map_constr Context.iter_rel_context ---> Context.Rel.iter Context.iter_named_context ---> Context.Named.iter Context.empty_rel_context ---> Context.Rel.empty Context.add_rel_decl ---> Context.Rel.add Context.lookup_rel ---> Context.Rel.lookup Context.rel_context_length ---> Context.Rel.length Context.rel_context_nhyps ---> Context.Rel.nhyps Context.rel_context_tags ---> Context.Rel.to_tags - Originally, rel-context was represented as: Context.rel_context = Names.Name.t * Constr.t option * Constr.t Now it is represented as: Context.Rel.Declaration.t = LocalAssum of Names.Name.t * Constr.t | LocalDef of Names.Name.t * Constr.t * Constr.t - Originally, named-context was represented as: Context.named_context = Names.Id.t * Constr.t option * Constr.t Now it is represented as: Context.Named.Declaration.t = LocalAssum of Names.Id.t * Constr.t | LocalDef of Names.Id.t * Constr.t * Constr.t - The various EXTEND macros do not handle specially the Coq-defined entries anymore. Instead, they just output a name that have to exist in the scope of the ML code. The parsing rules (VERNAC) ARGUMENT EXTEND will look for variables "$name" of type Gram.entry, while the parsing rules of (VERNAC COMMAND | TACTIC) EXTEND, as well as the various TYPED AS clauses will look for variables "wit_$name" of type Genarg.genarg_type. The small DSL for constructing compound entries still works over this scheme. Note that in the case of (VERNAC) ARGUMENT EXTEND, the name of the argument entry is bound in the parsing rules, so beware of recursive calls. For example, to get "wit_constr" you must "open Constrarg" at the top of the file. - Evarutil was split in two parts. The new Evardefine file exposes functions define_evar_* mostly used internally in the unification engine. - The Refine module was move out of Proofview. Proofview.Refine.* ---> Refine.* - A statically monotonous evarmap type was introduced in Sigma. Not all the API has been converted, so that the user may want to use compatibility functions Sigma.to_evar_map and Sigma.Unsafe.of_evar_map or Sigma.Unsafe.of_pair when needed. Code can be straightforwardly adapted in the following way: let (sigma, x1) = ... in ... let (sigma, xn) = ... in (sigma, ans) should be turned into: open Sigma.Notations let Sigma (x1, sigma, p1) = ... in ... let Sigma (xn, sigma, pn) = ... in Sigma (ans, sigma, p1 +> ... +> pn) Examples of `Sigma.Unsafe.of_evar_map` include: Evarutil.new_evar env (Tacmach.project goal) ty ----> Evarutil.new_evar env (Sigma.Unsafe.of_evar_map (Tacmach.project goal)) ty - The Proofview.Goal.*enter family of functions now takes a polymorphic continuation given as a record as an argument. Proofview.Goal.enter begin fun gl -> ... end should be turned into open Proofview.Notations Proofview.Goal.enter { enter = begin fun gl -> ... end } - `Tacexpr.TacDynamic(Loc.dummy_loc, Pretyping.constr_in c)` ---> `Tacinterp.Value.of_constr c` - `Vernacexpr.HintsResolveEntry(priority, poly, hnf, path, atom)` ---> `Vernacexpr.HintsResolveEntry(Vernacexpr.({hint_priority = priority; hint_pattern = None}), poly, hnf, path, atom)` - `Pretyping.Termops.mem_named_context` ---> `Engine.Termops.mem_named_context_val` (`Global.named_context` ---> `Global.named_context_val`) (`Context.Named.lookup` ---> `Environ.lookup_named_val`) ** Search API ** The main search functions now take a function iterating over the results. This allows for clients to use streaming or more economic printing. ========================================= = CHANGES BETWEEN COQ V8.4 AND COQ V8.5 = ========================================= ** Refactoring : more mli interfaces and simpler grammar.cma ** - A new directory intf/ now contains mli-only interfaces : Constrexpr : definition of constr_expr, was in Topconstr Decl_kinds : now contains binding_kind = Explicit | Implicit Evar_kinds : type Evar_kinds.t was previously Evd.hole_kind Extend : was parsing/extend.mli Genredexpr : regroup Glob_term.red_expr_gen and Tacexpr.glob_red_flag Glob_term : definition of glob_constr Locus : definition of occurrences and stuff about clauses Misctypes : intro_pattern_expr, glob_sort, cast_type, or_var, ... Notation_term : contains notation_constr, was Topconstr.aconstr Pattern : contains constr_pattern Tacexpr : was tactics/tacexpr.ml Vernacexpr : was toplevel/vernacexpr.ml - Many files have been divided : vernacexpr: vernacexpr.mli + Locality decl_kinds: decl_kinds.mli + Kindops evd: evar_kinds.mli + evd tacexpr: tacexpr.mli + tacops glob_term: glob_term.mli + glob_ops + genredexpr.mli + redops topconstr: constrexpr.mli + constrexpr_ops + notation_expr.mli + notation_ops + topconstr pattern: pattern.mli + patternops libnames: libnames (qualid, reference) + globnames (global_reference) egrammar: egramml + egramcoq - New utility files : miscops (cf. misctypes.mli) and redops (cf genredexpr.mli). - Some other directory changes : * grammar.cma and the source files specific to it are now in grammar/ * pretty-printing files are now in printing/ - Inner-file changes : * aconstr is now notation_constr, all constructors for this type now start with a N instead of a A (e.g. NApp instead of AApp), and functions about aconstr may have been renamed (e.g. match_aconstr is now match_notation_constr). * occurrences (now in Locus.mli) is now an algebraic type, with - AllOccurrences instead of all_occurrences_expr = (false,[]) - (AllOccurrencesBut l) instead of (all_occurrences_expr_but l) = (false,l) - NoOccurrences instead of no_occurrences_expr = (true,[]) - (OnlyOccurrences l) instead of (no_occurrences_expr_but l) = (true,l) * move_location (now in Misctypes) has two new constructors MoveFirst and MoveLast replacing (MoveToEnd false) and (MoveToEnd true) - API of pretyping.ml and constrintern.ml has been made more uniform * Parametrization of understand_* functions is now made using "inference flags" * Functions removed: - interp_constr_judgment (inline its former body if really needed) - interp_casted_constr, interp_type: use instead interp_constr with expected_type set to OfType or to IsType - interp_gen: use any of interp_constr, interp_casted_constr, interp_type - interp_open_constr_patvar - interp_context: use interp_context_evars (with a "evar_map ref") and call solve_remaining_evars afterwards with a failing flag (e.g. all_and_fail_flags) - understand_type, understand_gen: use understand with appropriate parameters * Change of semantics: - Functions interp_*_evars_impls have a different interface and do not any longer check resolution of evars by default; use check_evars_are_solved explicitly to check that evars are solved. See also the corresponding commit log. - Tactics API: new_induct -> induction; new_destruct -> destruct; letin_pat_tac do not accept a type anymore - New file find_subterm.ml for gathering former functions subst_closed_term_occ_modulo, subst_closed_term_occ_decl (which now take and outputs also an evar_map), and subst_closed_term_occ_modulo, subst_closed_term_occ_decl_modulo (now renamed into replace_term_occ_modulo and replace_term_occ_decl_modulo). - API of Inductiveops made more uniform (see commit log or file itself). - API of intros_pattern style tactic changed; "s" is dropped in "intros_pattern" and "intros_patterns" is not anymore behaving like tactic "intros" on the empty list. - API of cut tactics changed: for instance, cut_intro should be replaced by "assert_after Anonymous" - All functions taking an env and a sigma (or an evdref) now takes the env first. ========================================= = CHANGES BETWEEN COQ V8.3 AND COQ V8.4 = ========================================= ** Functions in unification.ml have now the evar_map coming just after the env ** Removal of Tacinterp.constr_of_id ** Use instead either global_reference or construct_reference in constrintern.ml. ** Optimizing calls to Evd functions ** Evars are split into defined evars and undefined evars; for efficiency, when an evar is known to be undefined, it is preferable to use specific functions about undefined evars since these ones are generally fewer than the defined ones. ** Type changes in TACTIC EXTEND rules ** Arguments bound with tactic(_) in TACTIC EXTEND rules are now of type glob_tactic_expr, instead of glob_tactic_expr * tactic. Only the first component is kept, the second one can be obtained via Tacinterp.eval_tactic. ** ARGUMENT EXTEND ** It is now forbidden to use TYPED simultaneously with {RAW,GLOB}_TYPED in ARGUMENT EXTEND statements. ** Renaming of rawconstr to glob_constr ** The "rawconstr" type has been renamed to "glob_constr" for consistency. The "raw" in everything related to former rawconstr has been changed to "glob". For more details about the rationale and scripts to migrate code using Coq's internals, see commits 13743, 13744, 13755, 13756, 13757, 13758, 13761 (by glondu, end of December 2010) in Subversion repository. Contribs have been fixed too, and commit messages there might also be helpful for migrating. ========================================= = CHANGES BETWEEN COQ V8.2 AND COQ V8.3 = ========================================= ** Light cleaning in evarutil.ml ** whd_castappevar is now whd_head_evar obsolete whd_ise disappears ** Restructuration of the syntax of binders ** binders_let -> binders binders_let_fixannot -> binders_fixannot binder_let -> closed_binder (and now covers only bracketed binders) binder was already obsolete and has been removed ** Semantical change of h_induction_destruct ** Warning, the order of the isrec and evar_flag was inconsistent and has been permuted. Tactic induction_destruct in tactics.ml is unchanged. ** Internal tactics renamed There is no more difference between bindings and ebindings. The following tactics are therefore renamed apply_with_ebindings_gen -> apply_with_bindings_gen left_with_ebindings -> left_with_bindings right_with_ebindings -> right_with_bindings split_with_ebindings -> split_with_bindings and the following tactics are removed apply_with_ebindings (use instead apply_with_bindings) eapply_with_ebindings (use instead eapply_with_bindings) ** Obsolete functions in typing.ml For mtype_of, msort_of, mcheck, now use type_of, sort_of, check ** Renaming functions renamed concrete_name -> compute_displayed_name_in concrete_let_name -> compute_displayed_let_name_in rename_rename_bound_var -> rename_bound_vars_as_displayed lookup_name_as_renamed -> lookup_name_as_displayed next_global_ident_away true -> next_ident_away_in_goal next_global_ident_away false -> next_global_ident_away ** Cleaning in commmand.ml Functions about starting/ending a lemma are in lemmas.ml Functions about inductive schemes are in indschemes.ml Functions renamed: declare_one_assumption -> declare_assumption declare_assumption -> declare_assumptions Command.syntax_definition -> Metasyntax.add_syntactic_definition declare_interning_data merged with add_notation_interpretation compute_interning_datas -> compute_full_internalization_env implicits_env -> internalization_env full_implicits_env -> full_internalization_env build_mutual -> do_mutual_inductive build_recursive -> do_fixpoint build_corecursive -> do_cofixpoint build_induction_scheme -> build_mutual_induction_scheme build_indrec -> build_induction_scheme instantiate_type_indrec_scheme -> weaken_sort_scheme instantiate_indrec_scheme -> modify_sort_scheme make_case_dep, make_case_nodep -> build_case_analysis_scheme make_case_gen -> build_case_analysis_scheme_default Types: decl_notation -> decl_notation option ** Cleaning in libnames/nametab interfaces Functions: dirpath_prefix -> pop_dirpath extract_dirpath_prefix pop_dirpath_n extend_dirpath -> add_dirpath_suffix qualid_of_sp -> qualid_of_path pr_sp -> pr_path make_short_qualid -> qualid_of_ident sp_of_syntactic_definition -> path_of_syntactic_definition sp_of_global -> path_of_global id_of_global -> basename_of_global absolute_reference -> global_of_path locate_syntactic_definition -> locate_syndef path_of_syntactic_definition -> path_of_syndef push_syntactic_definition -> push_syndef Types: section_path -> full_path ** Cleaning in parsing extensions (commit 12108) Many moves and renamings, one new file (Extrawit, that contains wit_tactic). ** Cleaning in tactical.mli tclLAST_HYP -> onLastHyp tclLAST_DECL -> onLastDecl tclLAST_NHYPS -> onNLastHypsId tclNTH_DECL -> onNthDecl tclNTH_HYP -> onNthHyp onLastHyp -> onLastHypId onNLastHyps -> onNLastDecls onClauses -> onClause allClauses -> allHypsAndConcl + removal of various unused combinators on type "clause" ========================================= = CHANGES BETWEEN COQ V8.1 AND COQ V8.2 = ========================================= A few differences in Coq ML interfaces between Coq V8.1 and V8.2 ================================================================ ** Datatypes List of occurrences moved from "int list" to "Termops.occurrences" (an alias to "bool * int list") ETIdent renamed to ETName ** Functions Eauto: e_resolve_constr, vernac_e_resolve_constr -> simplest_eapply Tactics: apply_with_bindings -> apply_with_bindings_wo_evars Eauto.simplest_apply -> Hiddentac.h_simplest_apply Evarutil.define_evar_as_arrow -> define_evar_as_product Old version of Tactics.assert_tac disappears Tactics.true_cut renamed into Tactics.assert_tac Constrintern.interp_constrpattern -> intern_constr_pattern Hipattern.match_with_conjunction is a bit more restrictive Hipattern.match_with_disjunction is a bit more restrictive ** Universe names (univ.mli) base_univ -> type0_univ (* alias of Set is the Type hierarchy *) prop_univ -> type1_univ (* the type of Set in the Type hierarchy *) neutral_univ -> lower_univ (* semantic alias of Prop in the Type hierarchy *) is_base_univ -> is_type1_univ is_empty_univ -> is_lower_univ ** Sort names (term.mli) mk_Set -> set_sort mk_Prop -> prop_sort type_0 -> type1_sort ========================================= = CHANGES BETWEEN COQ V8.0 AND COQ V8.1 = ========================================= A few differences in Coq ML interfaces between Coq V8.0 and V8.1 ================================================================ ** Functions Util: option_app -> option_map Term: substl_decl -> subst_named_decl Lib: library_part -> remove_section_part Printer: prterm -> pr_lconstr Printer: prterm_env -> pr_lconstr_env Ppconstr: pr_sort -> pr_rawsort Evd: in_dom, etc got standard ocaml names (i.e. mem, etc) Pretyping: - understand_gen_tcc and understand_gen_ltac merged into understand_ltac - type_constraints can now say typed by a sort (use OfType to get the previous behavior) Library: import_library -> import_module ** Constructors Declarations: mind_consnrealargs -> mind_consnrealdecls NoRedun -> NoDup Cast and RCast have an extra argument: you can recover the previous behavior by setting the extra argument to "CastConv DEFAULTcast" and "DEFAULTcast" respectively Names: "kernel_name" is now "constant" when argument of Term.Const Tacexpr: TacTrueCut and TacForward(false,_,_) merged into new TacAssert Tacexpr: TacForward(true,_,_) branched to TacLetTac ** Modules module Decl_kinds: new interface module Bigint: new interface module Tacred spawned module Redexpr module Symbols -> Notation module Coqast, Ast, Esyntax, Termast, and all other modules related to old syntax are removed module Instantiate: integrated to Evd module Pretyping now a functor: use Pretyping.Default instead ** Internal names OBJDEF and OBJDEF1 -> CANONICAL-STRUCTURE ** Tactic extensions - printers have an extra parameter which is a constr printer at high precedence - the tactic printers have an extra arg which is the expected precedence - level is now a precedence in declare_extra_tactic_pprule - "interp" functions now of types the actual arg type, not its encapsulation as a generic_argument ========================================= = CHANGES BETWEEN COQ V7.4 AND COQ V8.0 = ========================================= See files in dev/syntax-v8 ============================================== = MAIN CHANGES BETWEEN COQ V7.3 AND COQ V7.4 = ============================================== CHANGES DUE TO INTRODUCTION OF MODULES ====================================== 1.Kernel -------- The module level has no effect on constr except for the structure of section_path. The type of unique names for constructions (what section_path served) is now called a kernel name and is defined by type uniq_ident = int * string * dir_path (* int may be enough *) type module_path = | MPfile of dir_path (* reference to physical module, e.g. file *) | MPbound of uniq_ident (* reference to a module parameter in a functor *) | MPself of uniq_ident (* reference to one of the containing module *) | MPdot of module_path * label type label = identifier type kernel_name = module_path * dir_path * label ^^^^^^^^^^^ ^^^^^^^^ ^^^^^ | | \ | | the base name | \ / the (true) section path example: (non empty only inside open sections) L = (* i.e. some file of logical name L *) struct module A = struct Def a = ... end end M = (* i.e. some file of logical name M *) struct Def t = ... N = functor (X : sig module T = struct Def b = ... end end) -> struct module O = struct Def u = ... end Def x := ... .t ... .O.u ... X.T.b ... L.A.a and are self-references, X is a bound reference and L is a reference to a physical module. Notice that functor application is not part of a path: it must be named by a "module M = F(A)" declaration to be used in a kernel name. Notice that Jacek chose a practical approach, making directories not modules. Another approach could have been to replace the constructor MPfile by a constant constructor MProot representing the root of the world. Other relevant informations are in kernel/entries.ml (type module_expr) and kernel/declarations.ml (type module_body and module_type_body). 2. Library ---------- i) tables [Summaries] - the only change is the special treatment of the global environmet. ii) objects [Libobject] declares persistent objects, given with methods: * cache_function specifying how to add the object in the current scope; * load_function, specifying what to do when the module containing the object is loaded; * open_function, specifying what to do when the module containing the object is opened (imported); * classify_function, specyfying what to do with the object, when the current module (containing the object) is ended. * subst_function * export_function, to signal end_section survival (Almost) Each of these methods is called with a parameter of type object_name = section_path * kernel_name where section_path is the full user name of the object (such as Coq.Init.Datatypes.Fst) and kernel_name is its substitutive internal version such as (MPself,[],"Fst") (see above) What happens at the end of an interactive module ? ================================================== (or when a file is stored and reloaded from disk) All summaries (except Global environment) are reverted to the state from before the beginning of the module, and: a) the objects (again, since last Declaremods.start_module or Library.start_library) are classified using the classify_function. To simplify consider only those who returned Substitute _ or Keep _. b) If the module is not a functor, the subst_function for each object of the first group is called with the substitution [MPself "" |-> MPfile "Coq.Init.Datatypes"]. Then the load_function is called for substituted objects and the "keep" object. (If the module is a library the substitution is done at reloading). c) The objects which returned substitute are stored in the modtab together with the self ident of the module, and functor argument names if the module was a functor. They will be used (substituted and loaded) when a command like Module M := F(N) or Module Z := N is evaluated The difference between "substitute" and "keep" objects ======================================================== i) The "keep" objects can _only_ reference other objects by section_paths and qualids. They do not need the substitution function. They will work after end_module (or reloading a compiled library), because these operations do not change section_path's They will obviously not work after Module Z:=N. These would typically be grammar rules, pretty printing rules etc. ii) The "substitute" objects can _only_ reference objects by kernel_names. They must have a valid subst_function. They will work after end_module _and_ after Module Z:=N or Module Z:=F(M). Other kinds of objects: iii) "Dispose" - objects which do not survive end_module As a consequence, objects which reference other objects sometimes by kernel_names and sometimes by section_path must be of this kind... iv) "Anticipate" - objects which must be treated individually by end_module (typically "REQUIRE" objects) Writing subst_thing functions ============================= The subst_thing shoud not copy the thing if it hasn't actually changed. There are some cool emacs macros in dev/objects.el to help writing subst functions this way quickly and without errors. Also there are *_smartmap functions in Util. The subst_thing functions are already written for many types, including constr (Term.subst_mps), global_reference (Libnames.subst_global), rawconstr (Rawterm.subst_raw) etc They are all (apart from constr, for now) written in the non-copying way. Nametab ======= Nametab has been made more uniform. For every kind of thing there is only one "push" function and one "locate" function. Lib === library_segment is now a list of object_name * library_item, where object_name = section_path * kernel_name (see above) New items have been added for open modules and module types Declaremods ========== Functions to declare interactive and noninteractive modules and module types. Library ======= Uses Declaremods to actually communicate with Global and to register objects. OTHER CHANGES ============= Internal representation of tactics bindings has changed (see type Rawterm.substitution). New parsing model for tactics and vernacular commands - Introduction of a dedicated type for tactic expressions (Tacexpr.raw_tactic_expr) - Introduction of a dedicated type for vernac expressions (Vernacexpr.vernac_expr) - Declaration of new vernacular parsing rules by a new camlp4 macro GRAMMAR COMMAND EXTEND ... END to be used in ML files - Declaration of new tactics parsing/printing rules by a new camlp4 macro TACTIC EXTEND ... END to be used in ML files New organisation of THENS: tclTHENS tac tacs : tacs is now an array tclTHENSFIRSTn tac1 tacs tac2 : apply tac1 then, apply the array tacs on the first n subgoals and tac2 on the remaining subgoals (previously tclTHENST) tclTHENSLASTn tac1 tac2 tacs : apply tac1 then, apply tac2 on the first subgoals and apply the array tacs on the last n subgoals tclTHENFIRSTn tac1 tacs = tclTHENSFIRSTn tac1 tacs tclIDTAC (prev. tclTHENSI) tclTHENLASTn tac1 tacs = tclTHENSLASTn tac1 tclIDTAC tacs tclTHENFIRST tac1 tac2 = tclTHENFIRSTn tac1 [|tac2|] tclTHENLAST tac1 tac2 = tclTHENLASTn tac1 [|tac2|] (previously tclTHENL) tclTHENS tac1 tacs = tclTHENSFIRSTn tac1 tacs (fun _ -> error "wrong number") tclTHENSV same as tclTHENS but with an array tclTHENSi : no longer available Proof_type: subproof field in type proof_tree glued with the ref field Tacmach: no more echo from functions of module Refiner Files plugins/*/g_*.ml4 take the place of files plugins/*/*.v. Files parsing/{vernac,tac}extend.ml{4,i} implements TACTIC EXTEND andd VERNAC COMMAND EXTEND macros File syntax/PPTactic.v moved to parsing/pptactic.ml Tactics about False and not now in tactics/contradiction.ml Tactics depending on Init now tactics/*.ml4 (no longer in tactics/*.v) File tacinterp.ml moved from proofs to directory tactics ========================================== = MAIN CHANGES FROM COQ V7.1 TO COQ V7.2 = ========================================== The core of Coq (kernel) has meen minimized with the following effects: kernel/term.ml split into kernel/term.ml, pretyping/termops.ml kernel/reduction.ml split into kernel/reduction.ml, pretyping/reductionops.ml kernel/names.ml split into kernel/names.ml, library/nameops.ml kernel/inductive.ml split into kernel/inductive.ml, pretyping/inductiveops.ml the prefixes "Is" ans "IsMut" have been dropped from kind_of_term constructors, e.g. IsRel is now Rel, IsMutCase is now Case, etc. ======================================================= = PRINCIPAUX CHANGEMENTS ENTRE COQ V6.3.1 ET COQ V7.0 = ======================================================= Changements d'organisation / modules : -------------------------------------- Std, More_util -> lib/util.ml Names -> kernel/names.ml et kernel/sign.ml (les parties noms et signatures ont été séparées) Avm,Mavm,Fmavm,Mhm -> utiliser plutôt Map (et freeze alors gratuit) Mhb -> Bij Generic est intégré à Term (et un petit peu à Closure) Changements dans les types de données : --------------------------------------- dans Generic: free_rels : constr -> int Listset.t devient : constr -> Intset.t type_judgement -> typed_type environment -> context context -> typed_type signature ATTENTION: ---------- Il y a maintenant d'autres exceptions que UserError (TypeError, RefinerError, etc.) Il ne faut donc plus se contenter (pour rattraper) de faire try . .. with UserError _ -> ... mais écrire à la place try ... with e when Logic.catchable_exception e -> ... Changements dans les fonctions : -------------------------------- Vectops. it_vect -> Array.fold_left vect_it -> Array.fold_right exists_vect -> Util.array_exists for_all2eq_vect -> Util.array_for_all2 tabulate_vect -> Array.init hd_vect -> Util.array_hd tl_vect -> Util.array_tl last_vect -> Util.array_last it_vect_from -> array_fold_left_from vect_it_from -> array_fold_right_from app_tl_vect -> array_app_tl cons_vect -> array_cons map_i_vect -> Array.mapi map2_vect -> array_map2 list_of_tl_vect -> array_list_of_tl Names sign_it -> fold_var_context (se fait sur env maintenant) it_sign -> fold_var_context_reverse (sur env maintenant) Generic noccur_bet -> noccur_between substn_many -> substnl Std comp -> Util.compose rev_append -> List.rev_append Termenv mind_specif_of_mind -> Global.lookup_mind_specif ou Environ.lookup_mind_specif si on a un env sous la main mis_arity -> instantiate_arity mis_lc -> instantiate_lc Ex-Environ mind_of_path -> Global.lookup_mind Printer gentermpr -> gen_pr_term term0 -> prterm_env pr_sign -> pr_var_context pr_context_opt -> pr_context_of pr_ne_env -> pr_ne_context_of Typing, Machops type_of_type -> judge_of_type fcn_proposition -> judge_of_prop_contents safe_fmachine -> safe_infer Reduction, Clenv whd_betadeltat -> whd_betaevar whd_betadeltatiota -> whd_betaiotaevar find_mrectype -> Inductive.find_mrectype find_minductype -> Inductive.find_inductive find_mcoinductype -> Inductive.find_coinductive Astterm constr_of_com_casted -> interp_casted_constr constr_of_com_sort -> interp_type constr_of_com -> interp_constr rawconstr_of_com -> interp_rawconstr type_of_com -> type_judgement_of_rawconstr judgement_of_com -> judgement_of_rawconstr Termast bdize -> ast_of_constr Tacmach pf_constr_of_com_sort -> pf_interp_type pf_constr_of_com -> pf_interp_constr pf_get_hyp -> pf_get_hyp_typ pf_hyps, pf_untyped_hyps -> pf_env (tout se fait sur env maintenant) Pattern raw_sopattern_of_compattern -> Astterm.interp_constrpattern somatch -> is_matching dest_somatch -> matches Tacticals matches -> gl_is_matching dest_match -> gl_matches suff -> utiliser sort_of_goal lookup_eliminator -> utiliser sort_of_goal pour le dernier arg Divers initial_sign -> var_context Sign ids_of_sign -> ids_of_var_context (or Environ.ids_of_context) empty_sign -> empty_var_context Pfedit list_proofs -> get_all_proof_names get_proof -> get_current_proof_name abort_goal -> abort_proof abort_goals -> abort_all_proofs abort_cur_goal -> abort_current_proof get_evmap_sign -> get_goal_context/get_current_goal_context unset_undo -> reset_undo Proof_trees mkGOAL -> mk_goal Declare machine_constant -> declare_constant (+ modifs) ex-Trad, maintenant Pretyping inh_cast_rel -> Coercion.inh_conv_coerce_to inh_conv_coerce_to -> Coercion.inh_conv_coerce_to_fail ise_resolve1 -> understand, understand_type ise_resolve -> understand_judgment, understand_type_judgment ex-Tradevar, maintenant Evarutil mt_tycon -> empty_tycon Recordops struc_info -> find_structure Changements dans les inductifs ------------------------------ Nouveaux types "constructor" et "inductive" dans Term La plupart des fonctions de typage des inductives prennent maintenant un inductive au lieu d'un oonstr comme argument. Les seules fonctions à traduire un constr en inductive sont les find_rectype and co. Changements dans les grammaires ------------------------------- . le lexer (parsing/lexer.mll) est maintenant un lexer ocamllex . attention : LIDENT -> IDENT (les identificateurs n'ont pas de casse particulière dans Coq) . Le mot "command" est remplacé par "constr" dans les noms de fichiers, noms de modules et non-terminaux relatifs au parsing des termes; aussi les changements suivants "COMMAND"/"CONSTR" dans g_vernac.ml4, VARG_COMMAND/VARG_CONSTR dans vernac*.ml* . Les constructeurs d'arguments de tactiques IDENTIFIER, CONSTR, ...n passent en minuscule Identifier, Constr, ... . Plusieurs parsers ont changé de format (ex: sortarg) Changements dans le pretty-printing ----------------------------------- . Découplage de la traduction de constr -> rawconstr (dans detyping) et de rawconstr -> ast (dans termast) . Déplacement des options d'affichage de printer vers termast . Déplacement des réaiguillage d'univers du pp de printer vers esyntax Changements divers ------------------ . il n'y a plus de script coqtop => coqtop et coqtop.byte sont directement le résultat du link du code => debuggage et profiling directs . il n'y a plus d'installation locale dans bin/$ARCH . #use "include.ml" => #use "include" go() => loop() . il y a "make depend" et "make dependcamlp4" car ce dernier prend beaucoup de temps coq-8.6/dev/doc/setup.txt0000644000175000017500000002221713022274260014707 0ustar mdenesmdenesThis document provides detailed guidance on how to: - compile Coq - take advantage of Merlin in Emacs - enable auto-completion for Ocaml source-code - use ocamldebug in Emacs for debugging coqtop The instructions were tested with Debian 8.3 (Jessie). The procedure is somewhat tedious, but the final results are (still) worth the effort. How to compile Coq ------------------ Getting build dependencies: sudo apt-get install make opam git mercurial darcs opam init --comp 4.02.3 # Then follow the advice displayed at the end as how to update your ~/.bashrc and ~/.ocamlinit files. source ~/.bashrc # needed if you want to build "coqtop" target opam install camlp5 # needed if you want to build "coqide" target sudo apt-get install liblablgtksourceview2-ocaml-dev libgtk2.0-dev libgtksourceview2.0-dev opam install lablgtk # needed if you want to build "doc" target sudo apt-get install texlive-latex-recommended texlive-fonts-extra texlive-math-extra \ hevea texlive-latex-extra latex-xcolor Cloning Coq: # Go to the directory where you want to clone Coq's source-code. E.g.: cd ~/git git clone https://github.com/coq/coq.git Building coqtop: cd ~/git/coq git checkout trunk make distclean ./configure -annotate -with-doc no -local -debug -usecamlp5 make clean make -j4 coqide printers The "-annotate" option is essential when one wants to use Merlin. The "-local" option is useful if one wants to run the coqtop and coqide binaries without running make install The "-debug" option is essential if one wants to use ocamldebug with the coqtop binary. Then check if - bin/coqtop - bin/coqide behave as expected. A note about rlwrap ------------------- Running "coqtop" under "rlwrap" is possible, but there is a catch. If you try: cd ~/git/coq rlwrap bin/coqtop you will get an error: rlwrap: error: Couldn't read completions from /usr/share/rlwrap/completions/coqtop: No such file or directory This is a known issue: https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=779692 It was fixed upstream in version 0.42, and in a Debian package that, at the time of writing, is not part of Debian stable/testing/sid archives but only of Debian experimental. https://packages.debian.org/experimental/rlwrap The quick solution is to grab it from there, since it installs fine on Debian stable (jessie). cd /tmp wget http://ftp.us.debian.org/debian/pool/main/r/rlwrap/rlwrap_0.42-1_amd64.deb sudo dpkg -i rlwrap_0.42-1_amd64.deb After that, "rlwrap" works fine with "coqtop". How to install and configure Merlin (for Emacs) ----------------------------------------------- sudo apt-get install emacs opam install tuareg # Follow the advice displayed at the end as how to update your ~/.emacs file. opam install merlin # Follow the advice displayed at the end as how to update your ~/.emacs file. Then add this: (push "~/.opam/4.02.3/share/emacs/site-lisp" load-path) ; directory containing merlin.el (setq merlin-command "~/.opam/4.02.3/bin/ocamlmerlin") ; needed only if ocamlmerlin not already in your PATH (autoload 'merlin-mode "merlin" "Merlin mode" t) (add-hook 'tuareg-mode-hook 'merlin-mode) (add-hook 'caml-mode-hook 'merlin-mode) (load "~/.opam/4.02.3/share/emacs/site-lisp/tuareg-site-file") ;; Do not use TABs. These confuse Merlin. (setq-default indent-tabs-mode nil) to your ~/.emacs file. Further Emacs configuration when we start it for the first time. Try to open some *.ml file in Emacs, e.g.: cd ~/git/coq emacs toplevel/coqtop.ml & Emacs display the following strange message: The local variables list in ~/git/coq contains values that may be safe (*). Do you want to apply it? Just press "!", i.e. "apply the local variable list, and permanently mark these values (\*) as safe." Emacs then shows two windows: - one window that shows the contents of the "toplevel/coqtop.ml" file - and the other window that shows greetings for new Emacs users. If you do not want to see the second window next time you start Emacs, just check "Never show it again" and click on "Dismiss this startup screen." The default key-bindings are described here: https://github.com/the-lambda-church/merlin/wiki/emacs-from-scratch If you want, you can customize them by replacing the following lines: (define-key merlin-map (kbd "C-c C-x") 'merlin-error-next) (define-key merlin-map (kbd "C-c C-l") 'merlin-locate) (define-key merlin-map (kbd "C-c &") 'merlin-pop-stack) (define-key merlin-map (kbd "C-c C-t") 'merlin-type-enclosing) in the file "~/.opam/4.02.3/share/emacs/site-lisp/merlin.el" with what you want. In the text below we assume that you changed the origin key-bindings in the following way: (define-key merlin-map (kbd "C-n") 'merlin-error-next) (define-key merlin-map (kbd "C-l") 'merlin-locate) (define-key merlin-map (kbd "C-b") 'merlin-pop-stack) (define-key merlin-map (kbd "C-t") 'merlin-type-enclosing) Now, when you press , Merlin will show the definition of the symbol in a separate window. If you prefer to jump to the definition within the same window, do this: customize-group merlin Merlin Locate In New Window Value Menu Never Open In New Window State Set For Future Sessions Testing (Merlin): cd ~/git/coq emacs toplevel/coqtop.ml & Go to the end of the file where you will see the "start" function. Go to a line where "init_toplevel" function is called. If you want to jump to the position where that function or datatype under the cursor is defined, press . If you want to jump back, type: If you want to learn the type of the value at current cursor's position, type: Enabling auto-completion in emacs --------------------------------- In Emacs, type: list-packages In the list that is displayed, click on "company". A new window appears where just click on "Install" and then answer "Yes". These lines: (package-initialize) (require 'company) ; Make company aware of merlin (add-to-list 'company-backends 'merlin-company-backend) ; Enable company on merlin managed buffers (add-hook 'merlin-mode-hook 'company-mode) (global-set-key [C-tab] 'company-complete) then need to be added to your "~/.emacs" file. Next time when you start emacs and partially type some identifier, emacs will offer the corresponding completions. Auto-completion can also be manually invoked by typing . Description of various other shortcuts is here. http://company-mode.github.io/ Getting along with ocamldebug ----------------------------- The default ocamldebug key-bindings are described here. http://caml.inria.fr/pub/docs/manual-ocaml/debugger.html#sec369 If you want, you can customize them by putting the following commands: (global-set-key (kbd "") 'ocamldebug-break) (global-set-key (kbd "") 'ocamldebug-run) (global-set-key (kbd "") 'ocamldebug-next) (global-set-key (kbd "") 'ocamldebug-step) (global-set-key (kbd "") 'ocamldebug-finish) (global-set-key (kbd "") 'ocamldebug-print) (global-set-key (kbd "") 'camldebug) to your "~/.emacs" file. Let us try whether ocamldebug in Emacs works for us. (If necessary, re-)compile coqtop: cd ~/git/coq make -j4 coqide printers open Emacs: emacs toplevel/coqtop.ml & and type: ../bin/coqtop.byte ../dev/ocamldebug-coq As a result, a new window is open at the bottom where you should see: (ocd) i.e. an ocamldebug shell. 1. Switch to the window that contains the "coqtop.ml" file. 2. Go to the end of the file. 3. Find the definition of the "start" function. 4. Go to the "let" keyword that is at the beginning of the first line. 5. By pressing you set a breakpoint to the cursor's position. 6. By pressing you start the bin/coqtop process. 7. Then you can: - step over function calls: - step into function calls: - or finish execution of the current function until it returns: . Other ocamldebug commands, can be typed to the window that holds the ocamldebug shell. The points at which the execution of Ocaml program can stop are defined here: http://caml.inria.fr/pub/docs/manual-ocaml/debugger.html#sec350 Installing printers to ocamldebug --------------------------------- There is a pretty comprehensive set of printers defined for many common data types. You can load them by switching to the window holding the "ocamldebug" shell and typing: (ocd) source "../dev/db" Some of the functions were you might want to set a breakpoint and see what happens next --------------------------------------------------------------------------------------- - Coqtop.start : This function is called by the code produced by "coqmktop". - Coqtop.parse_args : This function is responsible for parsing command-line arguments. - Coqloop.loop : This function implements the read-eval-print loop. - Vernacentries.interp : This function is called to execute the Vernacular command user have typed.\ It dispatches the control to specific functions handling different Vernacular command. - Vernacentries.vernac_check_may_eval : This function handles the "Check ..." command. coq-8.6/dev/doc/profiling.txt0000644000175000017500000000353013022274260015535 0ustar mdenesmdenes# How to profile Coq? I (Pierre-Marie Pédrot) mainly use two OCaml branches to profile Coq, whether I want to profile time or memory consumption. AFAIK, this only works for Linux. ## Time In Coq source folder: opam switch 4.02.1+fp ./configure -local -debug make perf record -g bin/coqtop -compile file.v perf report -g fractal,callee --no-children To profile only part of a file, first load it using bin/coqtop -l file.v and plug into the process perf record -g -p PID ## Memory You first need a few commits atop trunk for this to work. git remote add ppedrot https://github.com/ppedrot/coq.git git fetch ppedrot git checkout ppedrot/allocation-profiling git rebase master Then: opam switch 4.00.1+alloc-profiling ./configure -local -debug make Note that linking the coqtop binary takes quite an amount of time with this branch, so do not worry too much. There are more recent branches of alloc-profiling on mshinwell's repo which can be found at: https://github.com/mshinwell/opam-repo-dev ### For memory dump: CAMLRUNPARAM=T,mj bin/coqtop -compile file.v In another terminal: pkill -SIGUSR1 $COQTOPPID ... pkill -SIGUSR1 $COQTOPPID dev/decode-major-heap.sh heap.$COQTOPPID.$N bin/coqtop where $COQTOPPID is coqtop pid and $N the index of the call to pkill. First column is the memory taken by the objects (in words), second one is the number of objects and third is the place where the objects where allocated. ### For complete memory graph: CAMLRUNPARAM=T,gr bin/coqtop -compile file.v In another terminal: pkill -SIGUSR1 $COQTOPPID ... pkill -SIGUSR1 $COQTOPPID ocaml dev/decodegraph.ml edge.$COQTOPPID.$N bin/coqtop > memory.dot dot -Tpdf -o memory.pdf memory.dot where $COQTOPPID is coqtop pid and $N the index of the call to pkill. The pdf produced by the last command gives a compact graphical representation of the various objects allocated. coq-8.6/dev/doc/univpoly.txt0000644000175000017500000003210613022274260015432 0ustar mdenesmdenesNotes on universe polymorphism and primitive projections, M. Sozeau =================================================================== The new implementation of universe polymorphism and primitive projections introduces a few changes to the API of Coq. First and foremost, the term language changes, as global references now carry a universe level substitution: type 'a puniverses = 'a * Univ.Instance.t type pconstant = constant puniverses type pinductive = inductive puniverses type pconstructor = constructor puniverses type constr = ... | Const of puniversess | Ind of pinductive | Constr of pconstructor | Proj of constant * constr Universes ========= Universe instances (an array of levels) gets substituted when unfolding definitions, are used to typecheck and are unified according to the rules in the ITP'14 paper on universe polymorphism in Coq. type Level.t = Set | Prop | Level of int * dirpath (* hashconsed *) type Instance.t = Level.t array type Universe.t = Level.t list (* hashconsed *) The universe module defines modules and abstract types for levels, universes etc.. Structures are hashconsed (with a hack to take care of the fact that deserialization breaks sharing). Definitions (constants, inductives) now carry around not only constraints but also the universes they introduced (a Univ.UContext.t). There is another kind of contexts [Univ.ContextSet.t], the latter has a set of universes, while the former has serialized the levels in an array, and is used for polymorphic objects. Both have "reified" constraints depending on global and local universes. A polymorphic definition is abstract w.r.t. the variables in this context, while a monomorphic one (or template polymorphic) just adds the universes and constraints to the global universe context when it is put in the environment. No other universes than the global ones and the declared local ones are needed to check a declaration, hence the kernel does not produce any constraints anymore, apart from module subtyping.... There are hence two conversion functions now: [check_conv] and [infer_conv]: the former just checks the definition in the current env (in which we usually push_universe_context of the associated context), and [infer_conv] which produces constraints that were not implied by the ambient constraints. Ideally, that one could be put out of the kernel, but currently module subtyping needs it. Inference of universes is now done during refinement, and the evar_map carries the incrementally built universe context, starting from the global universe constraints (see [Evd.from_env]). [Evd.conversion] is a wrapper around [infer_conv] that will do the bookkeeping for you, it uses [evar_conv_x]. There is a universe substitution being built incrementally according to the constraints, so one should normalize at the end of a proof (or during a proof) with that substitution just like we normalize evars. There are some nf_* functions in library/universes.ml to do that. Additionally, there is a minimization algorithm in there that can be applied at the end of a proof to simplify the universe constraints used in the term. It is heuristic but validity-preserving. No user-introduced universe (i.e. coming from a user-written anonymous Type) gets touched by this, only the fresh universes generated for each global application. Using val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic Is the way to make a constr out of a global reference in the new API. If they constr is polymorphic, it will add the necessary constraints to the evar_map. Even if a constr is not polymorphic, we have to take care of keeping track of its universes. Typically, using: mkApp (coq_id_function, [| A; a |]) and putting it in a proof term is not enough now. One has to somehow show that A's type is in cumululativity relation with id's type argument, incurring a universe constraint. To do this, one can simply call Typing.resolve_evars env evdref c which will do some infer_conv to produce the right constraints and put them in the evar_map. Of course in some cases you might know from an invariant that no new constraint would be produced and get rid of it. Anyway the kernel will tell you if you forgot some. As a temporary way out, [Universes.constr_of_global] allows you to make a constr from any non-polymorphic constant, but it will fail on polymorphic ones. Other than that, unification (w_unify and evarconv) now take account of universes and produce only well-typed evar_maps. Some syntactic comparisons like the one used in [change] have to be adapted to allow identification up-to-universes (when dealing with polymorphic references), [make_eq_univs_test] is there to help. In constr, there are actually many new comparison functions to deal with that: (** [equal a b] is true if [a] equals [b] modulo alpha, casts, and application grouping *) val equal : constr -> constr -> bool (** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts, application grouping and the universe equalities in [u]. *) val eq_constr_univs : constr Univ.check_function (** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo alpha, casts, application grouping and the universe inequalities in [u]. *) val leq_constr_univs : constr Univ.check_function (** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and the universe equalities in [c]. *) val eq_constr_universes : constr -> constr -> bool Univ.universe_constrained (** [leq_constr_universes a b] [true, c] if [a] is convertible to [b] modulo alpha, casts, application grouping and the universe inequalities in [c]. *) val leq_constr_universes : constr -> constr -> bool Univ.universe_constrained (** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and ignoring universe instances. *) val eq_constr_nounivs : constr -> constr -> bool The [_univs] versions are doing checking of universe constraints according to a graph, while the [_universes] are producing (non-atomic) universe constraints. The non-atomic universe constraints include the [ULub] constructor: when comparing [f (* u1 u2 *) c] and [f (* u1' u2' *) c] we add ULub constraints on [u1, u1'] and [u2, u2']. These are treated specially: as unfolding [f] might not result in these unifications, we need to keep track of the fact that failure to satisfy them does not mean that the term are actually equal. This is used in unification but probably not necessary to the average programmer. Another issue for ML programmers is that tables of constrs now usually need to take a [constr Univ.in_universe_context_set] instead, and properly refresh the universes context when using the constr, e.g. using Clenv.refresh_undefined_univs clenv or: (** Get fresh variables for the universe context. Useful to make tactics that manipulate constrs in universe contexts polymorphic. *) val fresh_universe_context_set_instance : universe_context_set -> universe_level_subst * universe_context_set The substitution should be applied to the constr(s) under consideration, and the context_set merged with the current evar_map with: val merge_context_set : rigid -> evar_map -> Univ.universe_context_set -> evar_map The [rigid] flag here should be [Evd.univ_flexible] most of the time. This means the universe levels of polymorphic objects in the constr might get instantiated instead of generating equality constraints (Evd.univ_rigid does that). On this issue, I recommend forcing commands to take [global_reference]s only, the user can declare his specialized terms used as hints as constants and this is cleaner. Alas, backward-compatibility-wise, this is the only solution I found. In the case of global_references only, it's just a matter of using [Evd.fresh_global] / [pf_constr_of_global] to let the system take care of universes. The universe graph ================== To accomodate universe polymorphic definitions, the graph structure in kernel/univ.ml was modified. The new API forces every universe to be declared before it is mentionned in any constraint. This forces to declare every universe to be >= Set or > Set. Every universe variable introduced during elaboration is >= Set. Every _global_ universe is now declared explicitly > Set, _after_ typechecking the definition. In polymorphic definitions Type@{i} ranges over Set and any other universe j. However, at instantiation time for polymorphic references, one can try to instantiate a universe parameter with Prop as well, if the instantiated constraints allow it. The graph invariants ensure that no universe i can be set lower than Set, so the chain of universes always bottoms down at Prop < Set. Modules ======= One has to think of universes in modules as being globally declared, so when including a module (type) which declares a type i (e.g. through a parameter), we get back a copy of i and not some fresh universe. Projections =========== | Proj of constant * constr Projections are always applied to a term, which must be of a record type (i.e. reducible to an inductive type [I params]). Type-checking, reduction and conversion are fast (not as fast as they could be yet) because we don't keep parameters around. As you can see, it's currently a [constant] that is used here to refer to the projection, that will change to an abstract [projection] type in the future. Basically a projection constant records which inductive it is a projection for, the number of params and the actual position in the constructor that must be projected. For compatibility reason, we also define an eta-expanded form (accessible from user syntax @f). The constant_entry of a projection has both informations. Declaring a record (under [Set Primitive Projections]) will generate such definitions. The API to declare them is not stable at the moment, but the inductive type declaration also knows about the projections, i.e. a record inductive type decl contains an array of terms representing the projections. This is used to implement eta-conversion for record types (with at least one field and having all projections definable). The canonical value being [Build_R (pn x) ... (pn x)]. Unification and conversion work up to this eta rule. The records can also be universe polymorphic of course, and we don't need to keep track of the universe instance for the projections either. Projections are reduced _eagerly_ everywhere, and introduce a new Zproj constructor in the abstract machines that obeys both the delta (for the constant opacity) and iota laws (for the actual reduction). Refolding works as well (afaict), but there is a slight hack there related to universes (not projections). For the ML programmer, the biggest change is that pattern-matchings on kind_of_term require an additional case, that is handled usually exactly like an [App (Const p) arg]. There are slight hacks related to hints is well, to use the primitive projection form of f when one does [Hint Resolve f]. Usually hint resolve will typecheck the term, resulting in a partially applied projection (disallowed), so we allow it to take [constr_or_global_reference] arguments instead and special-case on projections. Other tactic extensions might need similar treatment. WIP === - [vm_compute] does not deal with universes and projections correctly, except when it goes to a normal form with no projections or polymorphic constants left (the most common case). E.g. Ring with Set Universe Polymorphism and Set Primitive Projections work (at least it did at some point, I didn't recheck yet). - [native_compute] works with universes and projections. Incompatibilities ================= Old-style universe polymorphic definitions were implemented by taking advantage of the fact that elaboration (i.e., pretyping and unification) were _not_ universe aware, so some of the constraints generated during pretypechecking would be forgotten. In the current setting, this is not possible, as unification ensures that the substitution is built is entirely well-typed, even w.r.t universes. This means that some terms that type-checked before no longer do, especially projections of the pair: @fst ?x ?y : prod ?x ?y : Type (max(Datatypes.i, Datatypes.j)). The "template universe polymorphic" variables i and j appear during typing without being refreshed, meaning that they can be lowered (have upper constraints) with user-introduced universes. In most cases this won't work, so ?x and ?y have to be instantiated earlier, either from the type of the actual projected pair term (some t : prod A B) or the typing constraint. Adding the correct type annotations will always fix this. Unification semantics ===================== In Ltac, matching with: - a universe polymorphic constant [c] matches any instance of the constant. - a variable ?x already bound to a term [t] (non-linear pattern) uses strict equality of universes (e.g., Type@{i} and Type@{j} are not equal). In tactics: - [change foo with bar], [pattern foo] will unify all instances of [foo] (and convert them with [bar]). This might incur unifications of universes. [change] uses conversion while [pattern] only does syntactic matching up-to unification of universes. - [apply], [refine] use unification up to universes. coq-8.6/dev/doc/drop.txt0000644000175000017500000000254313022274260014513 0ustar mdenesmdenesWhen you start byte-compiled Coq toplevel: rlwrap bin/coqtop.byte then if you type: Drop. you will decend from Coq toplevel down to Ocaml toplevel. So if you want to learn: - the current values of some global variables you are interested in - or see what happens when you invoke certain functions this is the place where you can do that. When you try to print values belonging to abstract data types: # let sigma, env = Lemmas.get_current_context ();; val sigma : Evd.evar_map = val env : Environ.env = # Typeops.infer env (snd (Pretyping.understand_tcc env sigma (Constrintern.intern_constr env (Pcoq.parse_string Pcoq.Constr.lconstr "plus"))));; - : Environ.unsafe_judgment = {Environ.uj_val = ; uj_type = } the printed values are not very helpful. One way how to deal with that is to load the corresponding printers: # #use "dev/include";; Consequently, the result of: # Typeops.infer env (snd (Pretyping.understand_tcc env sigma (Constrintern.intern_constr env (Pcoq.parse_string Pcoq.Constr.lconstr "plus"))));; will be printed as: - : Environ.unsafe_judgment = Nat.add : nat -> nat -> nat which makes more sense. To be able to understand the meaning of the data types, sometimes the best option is to turn those data types from abstract to concrete and look at them without any kind of pretty printing. coq-8.6/dev/doc/transition-V5.10-V60000644000175000017500000000046613022274260016125 0ustar mdenesmdenesThe V5.10 archive has been created with cvs in February 1995 by Jean-Christophe Filliâtre. It was moved to archive V6 in March 1996. At this occasion, the contrib directory (user-contributions) were moved to a separate directory and some theories (like ALGEBRA) moved to the user-contributions directory too. coq-8.6/dev/doc/about-hints0000644000175000017500000002474113022274260015172 0ustar mdenesmdenesAn investigation of how ZArith lemmas could be classified in different automation classes - Reversible lemmas relating operators (to be declared as hints but needing precedences) - Equivalent notions (one has to be considered as primitive and the other rewritten into the canonical one) - Isomorphisms between structure (one structure has to be considered as more primitive than the other for a give operator) - Irreversible simplifications (to be declared with precedences) - Reversible bottom-up simplifications (to be used in hypotheses) - Irreversible bottom-up simplifications (to be used in hypotheses with precedences) - Rewriting rules (relevant for autorewrite, or for an improved auto) Note: this analysis, made in 2001, was previously stored in theories/ZArith/Zhints.v. It has been moved here to avoid obfuscating the standard library. (**********************************************************************) (** * Reversible lemmas relating operators *) (** Probably to be declared as hints but need to define precedences *) (** ** Conversion between comparisons/predicates and arithmetic operators *) (** Lemmas ending by eq *) (** << Zegal_left: (x,y:Z)`x = y`->`x+(-y) = 0` Zabs_eq: (x:Z)`0 <= x`->`|x| = x` Zeven_div2: (x:Z)(Zeven x)->`x = 2*(Zdiv2 x)` Zodd_div2: (x:Z)`x >= 0`->(Zodd x)->`x = 2*(Zdiv2 x)+1` >> *) (** Lemmas ending by Zgt *) (** << Zgt_left_rev: (x,y:Z)`x+(-y) > 0`->`x > y` Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0` >> *) (** Lemmas ending by Zlt *) (** << Zlt_left_rev: (x,y:Z)`0 < y+(-x)`->`x < y` Zlt_left_lt: (x,y:Z)`x < y`->`0 < y+(-x)` Zlt_O_minus_lt: (n,m:Z)`0 < n-m`->`m < n` >> *) (** Lemmas ending by Zle *) (** << Zle_left: (x,y:Z)`x <= y`->`0 <= y+(-x)` Zle_left_rev: (x,y:Z)`0 <= y+(-x)`->`x <= y` Zlt_left: (x,y:Z)`x < y`->`0 <= y+(-1)+(-x)` Zge_left: (x,y:Z)`x >= y`->`0 <= x+(-y)` Zgt_left: (x,y:Z)`x > y`->`0 <= x+(-1)+(-y)` >> *) (** ** Conversion between nat comparisons and Z comparisons *) (** Lemmas ending by eq *) (** << inj_eq: (x,y:nat)x=y->`(inject_nat x) = (inject_nat y)` >> *) (** Lemmas ending by Zge *) (** << inj_ge: (x,y:nat)(ge x y)->`(inject_nat x) >= (inject_nat y)` >> *) (** Lemmas ending by Zgt *) (** << inj_gt: (x,y:nat)(gt x y)->`(inject_nat x) > (inject_nat y)` >> *) (** Lemmas ending by Zlt *) (** << inj_lt: (x,y:nat)(lt x y)->`(inject_nat x) < (inject_nat y)` >> *) (** Lemmas ending by Zle *) (** << inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)` >> *) (** ** Conversion between comparisons *) (** Lemmas ending by Zge *) (** << not_Zlt: (x,y:Z)~`x < y`->`x >= y` Zle_ge: (m,n:Z)`m <= n`->`n >= m` >> *) (** Lemmas ending by Zgt *) (** << Zle_gt_S: (n,p:Z)`n <= p`->`(Zs p) > n` not_Zle: (x,y:Z)~`x <= y`->`x > y` Zlt_gt: (m,n:Z)`m < n`->`n > m` Zle_S_gt: (n,m:Z)`(Zs n) <= m`->`m > n` >> *) (** Lemmas ending by Zlt *) (** << not_Zge: (x,y:Z)~`x >= y`->`x < y` Zgt_lt: (m,n:Z)`m > n`->`n < m` Zle_lt_n_Sm: (n,m:Z)`n <= m`->`n < (Zs m)` >> *) (** Lemmas ending by Zle *) (** << Zlt_ZERO_pred_le_ZERO: (x:Z)`0 < x`->`0 <= (Zpred x)` not_Zgt: (x,y:Z)~`x > y`->`x <= y` Zgt_le_S: (n,p:Z)`p > n`->`(Zs n) <= p` Zgt_S_le: (n,p:Z)`(Zs p) > n`->`n <= p` Zge_le: (m,n:Z)`m >= n`->`n <= m` Zlt_le_S: (n,p:Z)`n < p`->`(Zs n) <= p` Zlt_n_Sm_le: (n,m:Z)`n < (Zs m)`->`n <= m` Zlt_le_weak: (n,m:Z)`n < m`->`n <= m` Zle_refl: (n,m:Z)`n = m`->`n <= m` >> *) (** ** Irreversible simplification involving several comparaisons *) (** useful with clear precedences *) (** Lemmas ending by Zlt *) (** << Zlt_le_reg :(a,b,c,d:Z)`a < b`->`c <= d`->`a+c < b+d` Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d` >> *) (** ** What is decreasing here ? *) (** Lemmas ending by eq *) (** << Zplus_minus: (n,m,p:Z)`n = m+p`->`p = n-m` >> *) (** Lemmas ending by Zgt *) (** << Zgt_pred: (n,p:Z)`p > (Zs n)`->`(Zpred p) > n` >> *) (** Lemmas ending by Zlt *) (** << Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)` >> *) (**********************************************************************) (** * Useful Bottom-up lemmas *) (** ** Bottom-up simplification: should be used *) (** Lemmas ending by eq *) (** << Zeq_add_S: (n,m:Z)`(Zs n) = (Zs m)`->`n = m` Zsimpl_plus_l: (n,m,p:Z)`n+m = n+p`->`m = p` Zplus_unit_left: (n,m:Z)`n+0 = m`->`n = m` Zplus_unit_right: (n,m:Z)`n = m+0`->`n = m` >> *) (** Lemmas ending by Zgt *) (** << Zsimpl_gt_plus_l: (n,m,p:Z)`p+n > p+m`->`n > m` Zsimpl_gt_plus_r: (n,m,p:Z)`n+p > m+p`->`n > m` Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n` >> *) (** Lemmas ending by Zlt *) (** << Zsimpl_lt_plus_l: (n,m,p:Z)`p+n < p+m`->`n < m` Zsimpl_lt_plus_r: (n,m,p:Z)`n+p < m+p`->`n < m` Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m` >> *) (** Lemmas ending by Zle *) (** << Zsimpl_le_plus_l: (p,n,m:Z)`p+n <= p+m`->`n <= m` Zsimpl_le_plus_r: (p,n,m:Z)`n+p <= m+p`->`n <= m` Zle_S_n: (n,m:Z)`(Zs m) <= (Zs n)`->`m <= n` >> *) (** ** Bottom-up irreversible (syntactic) simplification *) (** Lemmas ending by Zle *) (** << Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m` >> *) (** ** Other unclearly simplifying lemmas *) (** Lemmas ending by Zeq *) (** << Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0` >> *) (* Lemmas ending by Zgt *) (** << Zmult_gt: (x,y:Z)`x > 0`->`x*y > 0`->`y > 0` >> *) (* Lemmas ending by Zlt *) (** << pZmult_lt: (x,y:Z)`x > 0`->`0 < y*x`->`0 < y` >> *) (* Lemmas ending by Zle *) (** << Zmult_le: (x,y:Z)`x > 0`->`0 <= y*x`->`0 <= y` OMEGA1: (x,y:Z)`x = y`->`0 <= x`->`0 <= y` >> *) (**********************************************************************) (** * Irreversible lemmas with meta-variables *) (** To be used by EAuto *) (* Hints Immediate *) (** Lemmas ending by eq *) (** << Zle_antisym: (n,m:Z)`n <= m`->`m <= n`->`n = m` >> *) (** Lemmas ending by Zge *) (** << Zge_trans: (n,m,p:Z)`n >= m`->`m >= p`->`n >= p` >> *) (** Lemmas ending by Zgt *) (** << Zgt_trans: (n,m,p:Z)`n > m`->`m > p`->`n > p` Zgt_trans_S: (n,m,p:Z)`(Zs n) > m`->`m > p`->`n > p` Zle_gt_trans: (n,m,p:Z)`m <= n`->`m > p`->`n > p` Zgt_le_trans: (n,m,p:Z)`n > m`->`p <= m`->`n > p` >> *) (** Lemmas ending by Zlt *) (** << Zlt_trans: (n,m,p:Z)`n < m`->`m < p`->`n < p` Zlt_le_trans: (n,m,p:Z)`n < m`->`m <= p`->`n < p` Zle_lt_trans: (n,m,p:Z)`n <= m`->`m < p`->`n < p` >> *) (** Lemmas ending by Zle *) (** << Zle_trans: (n,m,p:Z)`n <= m`->`m <= p`->`n <= p` >> *) (**********************************************************************) (** * Unclear or too specific lemmas *) (** Not to be used ? *) (** ** Irreversible and too specific (not enough regular) *) (** Lemmas ending by Zle *) (** << Zle_mult: (x,y:Z)`x > 0`->`0 <= y`->`0 <= y*x` Zle_mult_approx: (x,y,z:Z)`x > 0`->`z > 0`->`0 <= y`->`0 <= y*x+z` OMEGA6: (x,y,z:Z)`0 <= x`->`y = 0`->`0 <= x+y*z` OMEGA7: (x,y,z,t:Z)`z > 0`->`t > 0`->`0 <= x`->`0 <= y`->`0 <= x*z+y*t` >> *) (** ** Expansion and too specific ? *) (** Lemmas ending by Zge *) (** << Zge_mult_simpl: (a,b,c:Z)`c > 0`->`a*c >= b*c`->`a >= b` >> *) (** Lemmas ending by Zgt *) (** << Zgt_mult_simpl: (a,b,c:Z)`c > 0`->`a*c > b*c`->`a > b` Zgt_square_simpl: (x,y:Z)`x >= 0`->`y >= 0`->`x*x > y*y`->`x > y` >> *) (** Lemmas ending by Zle *) (** << Zle_mult_simpl: (a,b,c:Z)`c > 0`->`a*c <= b*c`->`a <= b` Zmult_le_approx: (x,y,z:Z)`x > 0`->`x > z`->`0 <= y*x+z`->`0 <= y` >> *) (** ** Reversible but too specific ? *) (** Lemmas ending by Zlt *) (** << Zlt_minus: (n,m:Z)`0 < m`->`n-m < n` >> *) (**********************************************************************) (** * Lemmas to be used as rewrite rules *) (** but can also be used as hints *) (** Left-to-right simplification lemmas (a symbol disappears) *) (** << Zcompare_n_S: (n,m:Z)(Zcompare (Zs n) (Zs m))=(Zcompare n m) Zmin_n_n: (n:Z)`(Zmin n n) = n` Zmult_1_n: (n:Z)`1*n = n` Zmult_n_1: (n:Z)`n*1 = n` Zminus_plus: (n,m:Z)`n+m-n = m` Zle_plus_minus: (n,m:Z)`n+(m-n) = m` Zopp_Zopp: (x:Z)`(-(-x)) = x` Zero_left: (x:Z)`0+x = x` Zero_right: (x:Z)`x+0 = x` Zplus_inverse_r: (x:Z)`x+(-x) = 0` Zplus_inverse_l: (x:Z)`(-x)+x = 0` Zopp_intro: (x,y:Z)`(-x) = (-y)`->`x = y` Zmult_one: (x:Z)`1*x = x` Zero_mult_left: (x:Z)`0*x = 0` Zero_mult_right: (x:Z)`x*0 = 0` Zmult_Zopp_Zopp: (x,y:Z)`(-x)*(-y) = x*y` >> *) (** Right-to-left simplification lemmas (a symbol disappears) *) (** << Zpred_Sn: (m:Z)`m = (Zpred (Zs m))` Zs_pred: (n:Z)`n = (Zs (Zpred n))` Zplus_n_O: (n:Z)`n = n+0` Zmult_n_O: (n:Z)`0 = n*0` Zminus_n_O: (n:Z)`n = n-0` Zminus_n_n: (n:Z)`0 = n-n` Zred_factor6: (x:Z)`x = x+0` Zred_factor0: (x:Z)`x = x*1` >> *) (** Unclear orientation (no symbol disappears) *) (** << Zplus_n_Sm: (n,m:Z)`(Zs (n+m)) = n+(Zs m)` Zmult_n_Sm: (n,m:Z)`n*m+n = n*(Zs m)` Zmin_SS: (n,m:Z)`(Zs (Zmin n m)) = (Zmin (Zs n) (Zs m))` Zplus_assoc_l: (n,m,p:Z)`n+(m+p) = n+m+p` Zplus_assoc_r: (n,m,p:Z)`n+m+p = n+(m+p)` Zplus_permute: (n,m,p:Z)`n+(m+p) = m+(n+p)` Zplus_Snm_nSm: (n,m:Z)`(Zs n)+m = n+(Zs m)` Zminus_plus_simpl: (n,m,p:Z)`n-m = p+n-(p+m)` Zminus_Sn_m: (n,m:Z)`(Zs (n-m)) = (Zs n)-m` Zmult_plus_distr_l: (n,m,p:Z)`(n+m)*p = n*p+m*p` Zmult_minus_distr: (n,m,p:Z)`(n-m)*p = n*p-m*p` Zmult_assoc_r: (n,m,p:Z)`n*m*p = n*(m*p)` Zmult_assoc_l: (n,m,p:Z)`n*(m*p) = n*m*p` Zmult_permute: (n,m,p:Z)`n*(m*p) = m*(n*p)` Zmult_Sm_n: (n,m:Z)`n*m+m = (Zs n)*m` Zmult_Zplus_distr: (x,y,z:Z)`x*(y+z) = x*y+x*z` Zmult_plus_distr: (n,m,p:Z)`(n+m)*p = n*p+m*p` Zopp_Zplus: (x,y:Z)`(-(x+y)) = (-x)+(-y)` Zplus_sym: (x,y:Z)`x+y = y+x` Zplus_assoc: (x,y,z:Z)`x+(y+z) = x+y+z` Zmult_sym: (x,y:Z)`x*y = y*x` Zmult_assoc: (x,y,z:Z)`x*(y*z) = x*y*z` Zopp_Zmult: (x,y:Z)`(-x)*y = (-(x*y))` Zplus_S_n: (x,y:Z)`(Zs x)+y = (Zs (x+y))` Zopp_one: (x:Z)`(-x) = x*(-1)` Zopp_Zmult_r: (x,y:Z)`(-(x*y)) = x*(-y)` Zmult_Zopp_left: (x,y:Z)`(-x)*y = x*(-y)` Zopp_Zmult_l: (x,y:Z)`(-(x*y)) = (-x)*y` Zred_factor1: (x:Z)`x+x = x*2` Zred_factor2: (x,y:Z)`x+x*y = x*(1+y)` Zred_factor3: (x,y:Z)`x*y+x = x*(1+y)` Zred_factor4: (x,y,z:Z)`x*y+x*z = x*(y+z)` Zminus_Zplus_compatible: (x,y,n:Z)`x+n-(y+n) = x-y` Zmin_plus: (x,y,n:Z)`(Zmin (x+n) (y+n)) = (Zmin x y)+n` >> *) (** nat <-> Z *) (** << inj_S: (y:nat)`(inject_nat (S y)) = (Zs (inject_nat y))` inj_plus: (x,y:nat)`(inject_nat (plus x y)) = (inject_nat x)+(inject_nat y)` inj_mult: (x,y:nat)`(inject_nat (mult x y)) = (inject_nat x)*(inject_nat y)` inj_minus1: (x,y:nat)(le y x)->`(inject_nat (minus x y)) = (inject_nat x)-(inject_nat y)` inj_minus2: (x,y:nat)(gt y x)->`(inject_nat (minus x y)) = 0` >> *) (** Too specific ? *) (** << Zred_factor5: (x,y:Z)`x*0+y = y` >> *) coq-8.6/dev/doc/minicoq.tex0000644000175000017500000000560313022274260015167 0ustar mdenesmdenes\documentclass{article} \usepackage{fullpage} \input{./macros.tex} \newcommand{\minicoq}{\textsf{minicoq}} \newcommand{\nonterm}[1]{\textit{#1}} \newcommand{\terminal}[1]{\textsf{#1}} \newcommand{\listzero}{\textit{LIST$_0$}} \newcommand{\listun}{\textit{LIST$_1$}} \newcommand{\sep}{\textit{SEP}} \title{Minicoq: a type-checker for the pure \\ Calculus of Inductive Constructions} \begin{document} \maketitle \section{Introduction} \minicoq\ is a minimal toplevel for the \Coq\ kernel. \section{Grammar of terms} The grammar of \minicoq's terms is given in Figure~\ref{fig:terms}. \begin{figure}[htbp] \hrulefill \begin{center} \begin{tabular}{lrl} term & ::= & identifier \\ & $|$ & \terminal{Rel} integer \\ & $|$ & \terminal{Set} \\ & $|$ & \terminal{Prop} \\ & $|$ & \terminal{Type} \\ & $|$ & \terminal{Const} identifier \\ & $|$ & \terminal{Ind} identifier integer \\ & $|$ & \terminal{Construct} identifier integer integer \\ & $|$ & \terminal{[} name \terminal{:} term \terminal{]} term \\ & $|$ & \terminal{(} name \terminal{:} term \terminal{)} term \\ & $|$ & term \verb!->! term \\ & $|$ & \terminal{(} \listun\ term \terminal{)} \\ & $|$ & \terminal{(} term \terminal{::} term \terminal{)} \\ & $|$ & \verb!! \terminal{Case} term \terminal{of} \listzero\ term \terminal{end} \\[1em] name & ::= & \verb!_! \\ & $|$ & identifier \end{tabular} \end{center} \hrulefill \caption{Grammar of terms} \label{fig:terms} \end{figure} \section{Commands} The grammar of \minicoq's commands are given in Figure~\ref{fig:commands}. All commands end with a dot. \begin{figure}[htbp] \hrulefill \begin{center} \begin{tabular}{lrl} command & ::= & \terminal{Definition} identifier \terminal{:=} term. \\ & $|$ & \terminal{Definition} identifier \terminal{:} term \terminal{:=} term. \\ & $|$ & \terminal{Parameter} identifier \terminal{:} term. \\ & $|$ & \terminal{Variable} identifier \terminal{:} term. \\ & $|$ & \terminal{Inductive} \terminal{[} \listzero\ param \terminal{]} \listun\ inductive \sep\ \terminal{with}. \\ & $|$ & \terminal{Check} term. \\[1em] param & ::= & identifier \\[1em] inductive & ::= & identifier \terminal{:} term \terminal{:=} \listzero\ constructor \sep\ \terminal{$|$} \\[1em] constructor & ::= & identifier \terminal{:} term \end{tabular} \end{center} \hrulefill \caption{Commands} \label{fig:commands} \end{figure} \end{document} %%% Local Variables: %%% mode: latex %%% TeX-master: t %%% End: coq-8.6/dev/doc/unification.txt0000644000175000017500000001222513022274260016055 0ustar mdenesmdenesSome notes about the use of unification in Coq ---------------------------------------------- There are several applications of unification and pattern-matching ** Unification of types ** - For type inference, inference of implicit arguments * this basically amounts to solve problems of the form T <= U or T = U where T and U are types coming from a given typing problem * this kind of problem has to succeed and all the power of unification is a priori expected (full beta/delta/iota/zeta/nu/mu, pattern-unification, pruning, imitation/projection heuristics, ...) - For lemma application (apply, auto, ...) * these are also problems of the form T <= U on types but with T coming from a lemma and U from the goal * it is not obvious that we always want unification and not matching * it is not clear which amounts of delta one wants to use ** Looking for subterms ** - For tactics applying on subterms: induction, destruct, rewrite - As part of unification of types in the presence of higher-order evars (e.g. when applying a lemma of conclusion "?P t") ---------------------------------------------------------------------- Here are examples of features one may want or not when looking for subterms A- REWRITING 1- Full conversion on closed terms 1a- Full conversion on closed terms in the presence of at least one evars (meta) Section A1. Variable y: nat. Hypothesis H: forall x, x+2 = 0. Goal y+(1+1) = 0. rewrite H. (* 0 = 0 *) Abort. Goal 2+(1+1) = 0. rewrite H. (* 0 = 0 *) Abort. (* This exists since the very beginning of Chet's unification for tactics *) (* But this fails for setoid rewrite *) 1b- Full conversion on closed terms without any evars in the lemma 1b.1- Fails on rewrite (because Unification.w_unify_to_subterm_list replaces unification by check for a syntactic subterm if terms has no evar/meta) Goal 0+1 = 0 -> 0+(1+0) = 0. intros H; rewrite H. (* fails *) Abort. 1b.2- Works with setoid rewrite Require Import Setoid. Goal 0+1 = 0 -> 0+(1+0) = 0. intros H; rewrite H at 1. (* 0 = 0 *) Abort. 2- Using known instances in full conversion on closed terms Section A2. Hypothesis H: forall x, x+(2+x) = 0. Goal 1+(1+2) = 0. rewrite H. Abort. End A2. (* This exists since 8.2 (HH) *) 3- Pattern-unification on Rels Section A3a. Variable F: (nat->nat->nat)->nat. Goal exists f, F (fun x y => f x y) = 0 -> F (fun x y => plus y x) = 0. eexists. intro H; rewrite H. (* 0 = 0 *) Abort. End A3a. (* Works since pattern unification on Meta applied to Rel was introduced *) (* in unification.ml (8.1, Sep 2006, HH) *) Section A3b. Variables x y: nat. Variable H: forall f, f x y = 0. Goal plus y x = 0. rewrite H. (* 0 = 0 *) Abort. End A3b. (* Works since pattern unification on all Meta was supported *) (* in unification.ml (8.4, Jun 2011, HH) *) 4- Unification with open terms Section A4. Hypothesis H: forall x, S x = 0. Goal S 0 = 0. rewrite (H _). (* 0 = 0 *) Abort. End A4. (* Works since unification on Evar was introduced so as to support rewriting *) (* with open terms (8.2, MS, r11543, Unification.w_unify_to_subterm_list ) *) 5- Unification of pre-existing evars 5a- Basic unification of pre-existing evars Section A4. Variables x y: nat. Goal exists z, S z = 0 -> S (plus y x) = 0. eexists. intro H; rewrite H. (* 0 = 0 *) Abort. End A4. (* This worked in 8.2 and 8.3 as a side-effect of support for rewriting *) (* with open terms (8.2, MS, r11543) *) 5b- Pattern-unification of pre-existing evars in rewriting lemma Goal exists f, forall x y, f x y = 0 -> plus y x = 0. eexists. intros x y H; rewrite H. (* 0 = 0 *) Abort. (* Works since pattern-unification on Evar was introduced *) (* in unification.ml (8.3, HH, r12229) *) (* currently governed by a flag: use_evars_pattern_unification *) 5c- Pattern-unification of pre-existing evars in goal Goal exists f, forall x y, plus x y = 0 -> f y x = 0. eexists. intros x y H; rewrite H. (* 0 = 0 *) Abort. (* This worked in 8.2 and 8.3 but was removed for autorewrite in 8.4 *) 5d- Mixing pattern-unification of pre-existing evars in goal and evars in lemma Goal exists f, forall x, (forall y, plus x y = 0) -> forall y:nat, f y x = 0. eexists. intros x H y. rewrite H. (* 0 = 0 *) Abort. (* This worked in 8.2 and 8.3 but was removed for autorewrite in 8.4 *) 6- Multiple non-identical but convertible occurrences Tactic rewrite only considers the first one, from left-to-right, e.g.: Section A6. Variable y: nat. Hypothesis H: forall x, x+2 = 0. Goal (y+(2+0))+(y+(1+1)) = (y+(1+1))+(y+(2+0)). rewrite H. (* 0+(y+(1+1)) = y+(1+1)+0 *) Abort. End A6. Tactic setoid rewrite first looks for syntactically equal terms and if not uses the leftmost occurrence modulo delta. Require Import Setoid. Section A6. Variable y: nat. Hypothesis H: forall x, x+2 = 0. Goal (y+(2+0))+(y+2) = (y+2)+(y+(2+0)). rewrite H at 1 2 3 4. (* (y+(2+0))+0 = 0+(y+(2+0)) *) Abort. Goal (y+(2+0))+(y+(1+1)) = (y+(1+1))+(y+(2+0)). rewrite H at 1 2 3 4. (* 0+(y+(1+1)) = y+(1+1)+0 *) Abort. End A6. 7- Conversion Section A6. Variable y: nat. Hypothesis H: forall x, S x = 0. Goal id 1 = 0. rewrite H. B- ELIMINATION (INDUCTION / CASE ANALYSIS) This is simpler because open terms are not allowed and no unification is involved (8.3). coq-8.6/dev/doc/extensions.txt0000644000175000017500000000132313022274260015741 0ustar mdenesmdenesComment ajouter une nouvelle entrée primitive pour les TACTIC EXTEND ? ====================================================================== Exemple de l'ajout de l'entrée "clause": - ajouter un type ClauseArgType dans interp/genarg.ml{,i}, avec les wit_, rawwit_, et globwit_ correspondants - ajouter partout où Genarg.argument_type est filtré le cas traitant de ce nouveau ClauseArgType - utiliser le rawwit_clause pour définir une entrée clause du bon type et du bon nom dans le module Tactic de pcoq.ml4 - il faut aussi exporter la règle hors de g_tactic.ml4. Pour cela, il faut rejouter clause dans le GLOBAL du GEXTEND - seulement après, le nom clause sera accessible dans les TACTIC EXTEND ! coq-8.6/dev/doc/perf-analysis0000644000175000017500000001312313022274260015502 0ustar mdenesmdenesPerformance analysis (trunk repository) --------------------------------------- Jun 7, 2010: delayed re-typing of Ltac instances in matching (-1% on HighSchoolGeometry, -2% on JordanCurveTheorem) Jun 4, 2010: improvement in eauto and type classes inference by removing systematic preparation of debugging pretty-printing streams (std_ppcmds) (-7% in ATBR, visible only on V8.3 logs since ATBR is broken in trunk; -6% in HighSchoolGeometry) Apr 19, 2010: small improvement obtained by reducing evar instantiation from O(n^3) to O(n^2) in the size of the instance (-2% in Compcert, -2% AreaMethod, -15% in Ssreflect) Apr 17, 2010: small improvement obtained by not repeating unification twice in auto (-2% in Compcert, -2% in Algebra) Feb 15, 2010: Global decrease due to unicode inefficiency repaired Jan 8, 2010: Global increase due to an inefficiency in unicode treatment Dec 1, 2009 - Dec 19, 2009: Temporary addition of [forall x, P x] hints to exact (generally not significative but, e.g., +25% on Subst, +8% on ZFC, +5% on AreaMethod) Oct 19, 2009: Change in modules (CoLoR +35%) Aug 9, 2009: new files added in AreaMethod May 21, 2008: New version of CoRN (needs +84% more time to compile) Apr 25-29, 2008: Temporary attempt with delta in eauto (Matthieu) (+28% CoRN) Apr 17, 2008: improvement probably due to commit 10807 or 10813 (bug fixes, control of zeta in rewrite, auto (??)) (-18% Buchberger, -40% PAutomata, -28% IntMap, -43% CoRN, -13% LinAlg, but CatsInZFC -0.5% only, PiCalc stable, PersistentUnionFind -1%) Mar 11, 2008: (+19% PersistentUnionFind wrt Mar 3, +21% Angles, +270% Continuations between 7/3 and 18/4) Mar 7, 2008: (-10% PersistentUnionFind wrt Mar 3) Feb 20, 2008: temporary 1-day slow down (+64% LinAlg) Feb 14, 2008: (-10% PersistentUnionFind, -19% Groups) Feb 7, 8, 2008: temporary 2-days long slow down (+20 LinAlg, +50% BDDs) Feb 2, 2008: many updates of the module system (-13% LinAlg, -50% AMM11262, -5% Goedel, -1% PersistentUnionFind, -42% ExactRealArithmetic, -41% Icharate, -42% Kildall, -74% SquareMatrices) Jan 1, 2008: merge of TypeClasses branch (+8% PersistentUnionFind, +36% LinAlg, +76% Goedel) Nov 16, 17, 2007: (+18% Cantor, +4% LinAlg, +27% IEEE1394 on 2 days) Nov 8, 2007: (+18% Cantor, +16% LinAlg, +55% Continuations, +200% IEEE1394, +170% CTLTCTL, +220% SquareMatrices) Oct 29, V8.1 (+ 3% geometry but CoRN, Godel, Kildall, Stalmark stables) Between Oct 12 and Oct 27, 2007: inefficiency temporarily introduced in the tactic interpreter (from revision 10222 to 10267) (+22% CoRN, +10% geometry, ...) Sep 16, 2007: (+16% PersistentUnionFind on 3 days, LinAlg stable, Sep 4, 2007: (+26% PersistentUnionFind, LinAlg stable, Jun 6, 2007: optimization of the need for type unification in with-bindings (-3.5% Stalmark, -6% Kildall) May 20, 21, 22, 2007: improved inference of with-bindings (including activation of unification on types) (+4% PICALC, +5% Stalmark, +7% Kildall) May 11, 2007: added primitive integers (+6% CoLoR, +7% CoRN, +5% FSets, ...) Between Feb 22 and March 16, 2007: bench temporarily moved on JMN's computer (-25% CoRN, -25% Fairisle, ...) Oct 29 and Oct 30, 2006: abandoned attempt to add polymorphism on definitions (+4% in general during these two days) Oct 17, 2006: improvement in new field [r9248] (QArith -3%, geometry: -2%) Oct 5, 2006: fixing wrong unification of Meta below binders (e.g. CatsInZFC: +10%, CoRN: -2.5%, Godel: +4%, LinAlg: +7%, DISTRIBUTED_REFERENCE_COUNTING: +10%, CoLoR: +1%) Sep 26, 2006: new field [r9178-9181] (QArith: -16%, geometry: -5%, Float: +6%, BDDS:+5% but no ring in it) Sep 12, 2006: Rocq/AREA_METHOD extended (~ 530s) Aug 12, 2006: Rocq/AREA_METHOD added (~ 480s) May 30, 2006: Nancy/CoLoR added (~ 319s) May 23, 2006: new, lighter version of polymorphic inductive types (CoRN: -27%, back to Mar-24 time) May 17, 2006: changes in List.v (DISTRIBUTED_REFERENCE_COUNTING: -) May 5, 2006: improvement in closure (array instead of lists) (e.g. CatsInZFC: -10%, CoRN: -3%, May 23, 2006: polymorphic inductive types (precise, heavy algorithm) (CoRN: +37%) Dec 29, 2005: new test and use of -vm in Stalmarck Dec 27, 2005: contrib Karatsuba added (~ 30s) Dec 28, 2005: size decrease mainly due to Defined moved to Qed in FSets (reduction from 95M to 7Mo) Dec 1-14, 2005: benchmarking server down between the two dates: Godel: -10%, CoRN: -10% probably due to changes around vm (new informative Cast, change of equality in named_context_val) Oct 6, 2005: contribs IPC and Tait added (~ 22s and ~ 25s) Aug 19, 2005: time decrease after application of "Array.length x=0" Xavier's suggestions for optimisation (e.g. Nijmegen/QArith: -3%, Nijmegen/CoRN: -7%, Godel: -3%) Aug 1, 2005: contrib Kildall added (~ 65s) Jul 26-Aug 2, 2005: bench down Jul 14-15, 2005: 4 contribs failed including CoRN Jul 14, 2005: time increase after activation of "closure optimisation" (e.g. Nijmegen/QArith: +8%, Nijmegen/CoRN: +3%, Godel: +13%) Jul 7, 2005: adding contrib Fermat4 Jun 17, 2005: contrib Goodstein extended and moved to CantorOrdinals (~ 30s) May 19, 2005: contrib Goodstein and prfx (~ 9s) added Apr 21, 2005: strange time decrease (could it be due to the change of Back and Reset mechanism) (e.g. Nijmegen/CoRN: -2%, Nijmegen/QARITH: -4%, Godel: -11%) Mar 20, 2005: fixed Logic.with_check bug global time decrease (e.g. Nijmegen/CoRN: -3%, Nijmegen/QARITH: -1.5%) Jan 31-Feb 8, 2005: small instability (e.g. CoRN: ~2015s -> ~1999s -> ~2032s, Godel: ~340s -> ~370s) Jan 13, 2005: contrib SumOfTwoSquare added (~ 38s) coq-8.6/dev/doc/style.txt0000644000175000017500000000314613022274260014707 0ustar mdenesmdenes << L'uniformité du style est plus importante que le style lui-même. >> (Kernigan & Pike, The Practice of Programming) Mode Emacs ========== Tuareg, que l'on trouve ici : http://www.prism.uvsq.fr/~acohen/tuareg/ avec le réglage suivant : (setq tuareg-in-indent 2) Types récursifs et filtrages ============================ Une barre de séparation y compris sur le premier constructeur type t = | A | B of machin match expr with | A -> ... | B x -> ... Remarque : à partir de la 8.2 environ, la tendance est à utiliser le format suivant qui permet de limiter l'escalade d'indentation tout en produisant un aspect visuel intéressant de bloc : type t = | A | B of machin match expr with | A -> ... | B x -> ... let f expr = match expr with | A -> ... | B x -> ... let f expr = function | A -> ... | B x -> ... Le deuxième cas est obtenu sous tuareg avec les réglages (setq tuareg-with-indent 0) (setq tuareg-function-indent 0) (setq tuareg-let-always-indent nil) /// notons que cette dernière est bien /// pour les let mais pas pour les let-in Conditionnelles =============== if condition then premier-cas else deuxieme-cas Si effets de bord dans les branches, utilisez begin ... end et non des parenthèses i.e. if condition then begin instr1; instr2 end else begin instr3; instr4 end Si la première branche lève une exception, évitez le else i.e. if condition then if condition then error "machin"; error "machin" -----> suite else suite coq-8.6/dev/doc/notes-on-conversion0000644000175000017500000000501613022274260016654 0ustar mdenesmdenes(**********************************************************************) (* A few examples showing the current limits of the conversion algorithm *) (**********************************************************************) (*** We define (pseudo-)divergence from Ackermann function ***) Definition ack (n : nat) := (fix F (n0 : nat) : nat -> nat := match n0 with | O => S | S n1 => fun m : nat => (fix F0 (n2 : nat) : nat := match n2 with | O => F n1 1 | S n3 => F n1 (F0 n3) end) m end) n. Notation OMEGA := (ack 4 4). Definition f (x:nat) := x. (* Evaluation in tactics can somehow be controlled *) Lemma l1 : OMEGA = OMEGA. reflexivity. (* succeed: identity *) Qed. (* succeed: identity *) Lemma l2 : OMEGA = f OMEGA. reflexivity. (* fail: conversion wants to convert OMEGA with f OMEGA *) Abort. (* but it reduces the right side first! *) Lemma l3 : f OMEGA = OMEGA. reflexivity. (* succeed: reduce left side first *) Qed. (* succeed: expected concl (the one with f) is on the left *) Lemma l4 : OMEGA = OMEGA. assert (f OMEGA = OMEGA) by reflexivity. (* succeed *) unfold f in H. (* succeed: no type-checking *) exact H. (* succeed: identity *) Qed. (* fail: "f" is on the left *) (* This example would fail whatever the preferred side is *) Lemma l5 : OMEGA = f OMEGA. unfold f. assert (f OMEGA = OMEGA) by reflexivity. unfold f in H. exact H. Qed. (* needs to convert (f OMEGA = OMEGA) and (OMEGA = f OMEGA) *) (**********************************************************************) (* Analysis of the inefficiency in Nijmegen/LinAlg/LinAlg/subspace_dim.v *) (* (proof of span_ind_uninject_prop *) In the proof, a problem of the form (Equal S t1 t2) is "simpl"ified, then "red"uced to (Equal S' t1 t1) where the new t1's are surrounded by invisible coercions. A reflexivity steps conclude the proof. The trick is that Equal projects the equality in the setoid S, and that (Equal S) itself reduces to some (fun x y => Equal S' (f x) (g y)). At the Qed time, the problem to solve is (Equal S t1 t2) = (Equal S' t1 t1) and the algorithm is to first compare S and S', and t1 and t2. Unfortunately it does not work, and since t1 and t2 involve concrete instances of algebraic structures, it takes a lot of time to realize that it is not convertible. The only hope to improve this problem is to observe that S' hides (behind two indirections) a Setoid constructor. This could be the argument to solve the problem. coq-8.6/dev/doc/newsyntax.tex0000644000175000017500000006041213022274260015567 0ustar mdenesmdenes %% -*-french-tex-*- \documentclass{article} \usepackage{verbatim} \usepackage[T1]{fontenc} \usepackage[utf8]{inputenc} \usepackage[french]{babel} \usepackage{amsmath} \usepackage{amssymb} \usepackage{array} \author{B.~Barras} \title{Proposition de syntaxe pour Coq} %% Le _ est un caractère normal \catcode`\_=13 \let\subscr=_ \def_{\ifmmode\sb\else\subscr\fi} %% Macros pour les grammaires \def\NT#1{\langle\textit{#1}\rangle} \def\TERM#1{\textsf{#1}} \def\STAR#1{#1\!*} \def\PLUS#1{#1\!+} %% Tableaux de definition de non-terminaux \newenvironment{cadre} {\begin{array}{|c|}\hline\\} {\\\\\hline\end{array}} \newenvironment{rulebox} {$$\begin{cadre}\begin{array}{r@{~}c@{~}l@{}r}} {\end{array}\end{cadre}$$} \def\DEFNT#1{\NT{#1} & ::= &} \def\EXTNT#1{\NT{#1} & ::= & ... \\&|&} \def\RNAME#1{(\textsc{#1})} \def\SEPDEF{\\\\} \def\nlsep{\\&|&} \begin{document} \maketitle \section{Grammaire des tactiques} \label{tacticsyntax} La réflexion de la rénovation de la syntaxe des tactiques n'est pas encore aussi poussée que pour les termes (section~\ref{constrsyntax}), mais cette section vise à énoncer les quelques principes que l'on souhaite suivre. \begin{itemize} \item Réutiliser les mots-clés de la syntaxe des termes (i.e. en minuscules) pour les constructions similaires de tactiques (let_in, match, and, etc.). Le connecteur logique \texttt{and} n'étant que rarement utilisé autrement que sous la forme \texttt{$\wedge$} (sauf dans le code ML), on pourrait dégager ce mot-clé. \item Les arguments passés aux tactiques sont principalement des termes, on préconise l'utilisation d'un symbole spécial (par exemple l'apostrophe) pour passer une tactique ou une expression (AST). L'idée étant que l'on écrit plus souvent des tactiques prenant des termes en argument que des tacticals. \end{itemize} \begin{figure} \begin{rulebox} \DEFNT{tactic} \NT{tactic} ~\TERM{\&} ~\NT{tactic} & \RNAME{then} \nlsep \TERM{[} ~\NT{tactic}~\TERM{|}~... ~\TERM{|}~\NT{tactic}~\TERM{]} & \RNAME{par} \nlsep \NT{ident} ~\STAR{\NT{tactic-arg}} ~~~ & \RNAME{apply} \nlsep \TERM{fun} ~.... & \RNAME{function} \nlsep \NT{simple-tactic} \SEPDEF \DEFNT{tactic-arg} \NT{constr} \nlsep \TERM{'} ~\NT{tactic} \SEPDEF \DEFNT{simple-tactic} \TERM{Apply} ~\NT{binding-term} \nlsep \NT{elim-kw} ~\NT{binding-term} \nlsep \NT{elim-kw} ~\NT{binding-term} ~\TERM{using} ~\NT{binding-term} \nlsep \TERM{Intros} ~\NT{intro-pattern} \SEPDEF \DEFNT{elim-kw} \TERM{Elim} ~\mid~ \TERM{Case} ~\mid~ \TERM{Induction} ~\mid~ \TERM{Destruct} \end{rulebox} \caption{Grammaire des tactiques} \label{tactic} \end{figure} \subsection{Arguments de tactiques} La syntaxe actuelle des arguments de tactiques est que l'on parse par défaut une expression de tactique, ou bien l'on parse un terme si celui-ci est préfixé par \TERM{'} (sauf dans le cas des variables). Cela est gênant pour les utilisateurs qui doivent écrire des \TERM{'} pour leurs tactiques. À mon avis, il n'est pas souhaitable pour l'utilisateur de l'obliger à marquer une différence entre les tactiques ``primitives'' (en fait ``système'') et les tactiques définies par Ltac. En effet, on se dirige inévitablement vers une situation où il existera des librairies de tactiques et il va devenir difficile de savoir facilement s'il faut ou non mettre des \TERM{'}. \subsection{Bindings} Dans un premier temps, les ``bindings'' sont toujours considérés comme une construction du langage des tactiques, mais il est intéressant de prévoir l'extension de ce procédé aux termes, puisqu'il s'agit simplement de construire un n{\oe}ud d'application dans lequel on donne les arguments par nom ou par position, les autres restant à inférer. Le principal point est de trouver comment combiner de manière uniforme ce procédé avec les arguments implicites. Il est toutefois important de réfléchir dès maintenant à une syntaxe pour éviter de rechanger encore la syntaxe. Intégrer la notation \TERM{with} aux termes peut poser des problèmes puisque ce mot-clé est utilisé pour le filtrage: comment parser (en LL(1)) l'expression: \begin{verbatim} Cases x with y ... \end{verbatim} Soit on trouve un autre mot-clé, soit on joue avec les niveaus de priorité en obligeant a parenthéser le \TERM{with} des ``bindings'': \begin{verbatim} Cases (x with y) with (C z) => ... \end{verbatim} ce qui introduit un constructeur moralement équivalent à une application situé à une priorité totalement différente (les ``bindings'' seraient au plus haut niveau alors que l'application est à un niveau bas). \begin{figure} \begin{rulebox} \DEFNT{binding-term} \NT{constr} ~\TERM{with} ~\STAR{\NT{binding}} \SEPDEF \DEFNT{binding} \NT{constr} \end{rulebox} \caption{Grammaire des bindings} \label{bindings} \end{figure} \subsection{Enregistrements} Il faudrait aménager la syntaxe des enregistrements dans l'optique d'avoir des enregistrements anonymes (termes de première classe), même si pour l'instant, on ne dispose que d'enregistrements définis a toplevel. Exemple de syntaxe pour les types d'enregistrements: \begin{verbatim} { x1 : A1; x2 : A2(x1); _ : T; (* Pas de projection disponible *) y; (* Type infere *) ... (* ; optionnel pour le dernier champ *) } \end{verbatim} Exemple de syntaxe pour le constructeur: \begin{verbatim} { x1 = O; x2 : A2(x1) = v1; _ = v2; ... } \end{verbatim} Quant aux dépendences, une convention pourrait être de considérer les champs non annotés par le type comme non dépendants. Plusieurs interrogations: \begin{itemize} \item l'ordre des champs doit-il être respecté ? sinon, que faire pour les champs sans projection ? \item autorise-t-on \texttt{v1} a mentionner \texttt{x1} (comme dans la définition d'un module), ce qui se comporterait comme si on avait écrit \texttt{v1} à la place. Cela pourrait être une autre manière de déclarer les dépendences \end{itemize} La notation pointée pour les projections pose un problème de parsing, sauf si l'on a une convention lexicale qui discrimine les noms de modules des projections et identificateurs: \texttt{x.y.z} peut être compris comme \texttt{(x.y).z} ou texttt{x.(y.z)}. \section{Grammaire des termes} \label{constrsyntax} \subsection{Quelques principes} \begin{enumerate} \item Diminuer le nombre de niveaux de priorité en regroupant les règles qui se ressemblent: infixes, préfixes, lieurs (constructions ouvertes à droite), etc. \item Éviter de surcharger la signification d'un symbole (ex: \verb+( )+ comme parenthésage et produit dans la V7). \item Faire en sorte que les membres gauches (motifs de Cases, lieurs d'abstraction ou de produits) utilisent une syntaxe compatible avec celle des membres droits (branches de Cases et corps de fonction). \end{enumerate} \subsection{Présentation de la grammaire} \begin{figure} \begin{rulebox} \DEFNT{paren-constr} \NT{cast-constr}~\TERM{,}~\NT{paren-constr} &\RNAME{pair} \nlsep \NT{cast-constr} \SEPDEF \DEFNT{cast-constr} \NT{constr}~\TERM{\!\!:}~\NT{cast-constr} &\RNAME{cast} \nlsep \NT{constr} \SEPDEF \DEFNT{constr} \NT{appl-constr}~\NT{infix}~\NT{constr} &\RNAME{infix} \nlsep \NT{prefix}~\NT{constr} &\RNAME{prefix} \nlsep \NT{constr}~\NT{postfix} &\RNAME{postfix} \nlsep \NT{appl-constr} \SEPDEF \DEFNT{appl-constr} \NT{appl-constr}~\PLUS{\NT{appl-arg}} &\RNAME{apply} \nlsep \TERM{@}~\NT{global}~\PLUS{\NT{simple-constr}} &\RNAME{expl-apply} \nlsep \NT{simple-constr} \SEPDEF \DEFNT{appl-arg} \TERM{@}~\NT{int}~\TERM{\!:=}~\NT{simple-constr} &\RNAME{impl-arg} \nlsep \NT{simple-constr} \SEPDEF \DEFNT{simple-constr} \NT{atomic-constr} \nlsep \TERM{(}~\NT{paren-constr}~\TERM{)} \nlsep \NT{match-constr} \nlsep \NT{fix-constr} %% \nlsep \TERM{<\!\!:ast\!\!:<}~\NT{ast}~\TERM{>\!>} &\RNAME{quotation} \end{rulebox} \caption{Grammaire des termes} \label{constr} \end{figure} \begin{figure} \begin{rulebox} \DEFNT{prefix} \TERM{!}~\PLUS{\NT{binder}}~\TERM{.}~ &\RNAME{prod} \nlsep \TERM{fun} ~\PLUS{\NT{binder}} ~\TERM{$\Rightarrow$} &\RNAME{lambda} \nlsep \TERM{let}~\NT{ident}~\STAR{\NT{binder}} ~\TERM{=}~\NT{constr} ~\TERM{in} &\RNAME{let} %\nlsep \TERM{let (}~\NT{comma-ident-list}~\TERM{) =}~\NT{constr} % ~\TERM{in} &~~~\RNAME{let-case} \nlsep \TERM{if}~\NT{constr}~\TERM{then}~\NT{constr}~\TERM{else} &\RNAME{if-case} \nlsep \TERM{eval}~\NT{red-fun}~\TERM{in} &\RNAME{eval} \SEPDEF \DEFNT{infix} \TERM{$\rightarrow$} & \RNAME{impl} \SEPDEF \DEFNT{atomic-constr} \TERM{_} \nlsep \TERM{?}\NT{int} \nlsep \NT{sort} \nlsep \NT{global} \SEPDEF \DEFNT{binder} \NT{ident} &\RNAME{infer} \nlsep \TERM{(}~\NT{ident}~\NT{type}~\TERM{)} &\RNAME{binder} \SEPDEF \DEFNT{type} \TERM{\!:}~\NT{constr} \nlsep \epsilon \end{rulebox} \caption{Grammaires annexes aux termes} \label{gram-annexes} \end{figure} La grammaire des termes (correspondant à l'état \texttt{barestate}) est décrite figures~\ref{constr} et~\ref{gram-annexes}. On constate par rapport aux précédentes versions de Coq d'importants changements de priorité, le plus marquant étant celui de l'application qui se trouve désormais juste au dessus\footnote{La convention est de considérer les opérateurs moins lieurs comme ``au dessus'', c'est-à-dire ayant un niveau de priorité plus élévé (comme c'est le cas avec le niveau de la grammaire actuelle des termes).} des constructions fermées à gauche et à droite. La grammaire des noms globaux est la suivante: \begin{eqnarray*} \DEFNT{global} \NT{ident} %% \nlsep \TERM{\$}\NT{ident} \nlsep \NT{ident}\TERM{.}\NT{global} \end{eqnarray*} Le $\TERM{_}$ dénote les termes à synthétiser. Les métavariables sont reconnues au niveau du lexer pour ne pas entrer en conflit avec le $\TERM{?}$ de l'existentielle. Les opérateurs infixes ou préfixes sont tous au même niveau de priorité du point de vue de Camlp4. La solution envisagée est de les gérer à la manière de Yacc, avec une pile (voir discussions plus bas). Ainsi, l'implication est un infixe normal; la quantification universelle et le let sont vus comme des opérateurs préfixes avec un niveau de priorité plus haut (i.e. moins lieur). Il subsiste des problèmes si l'on ne veut pas écrire de parenthèses dans: \begin{verbatim} A -> (!x. B -> (let y = C in D)) \end{verbatim} La solution proposée est d'analyser le membre droit d'un infixe de manière à autoriser les préfixes et les infixes de niveau inférieur, et d'exiger le parenthésage que pour les infixes de niveau supérieurs. En revanche, à l'affichage, certains membres droits seront plus lisibles s'ils n'utilisent pas cette astuce: \begin{verbatim} (fun x => x) = fun x => x \end{verbatim} La proposition est d'autoriser ce type d'écritures au parsing, mais l'afficheur écrit de manière standardisée en mettant quelques parenthèses superflues: $\TERM{=}$ serait symétrique alors que $\rightarrow$ appellerait l'afficheur de priorité élevée pour son sous-terme droit. Les priorités des opérateurs primitifs sont les suivantes (le signe $*$ signifie que pour le membre droit les opérateurs préfixes seront affichés sans parenthèses quel que soit leur priorité): $$ \begin{array}{c|l} $symbole$ & $priorité$ \\ \hline \TERM{!} & 200\,R* \\ \TERM{fun} & 200\,R* \\ \TERM{let} & 200\,R* \\ \TERM{if} & 200\,R \\ \TERM{eval} & 200\,R \\ \rightarrow & 90\,R* \end{array} $$ Il y a deux points d'entrée pour les termes: $\NT{constr}$ et $\NT{simple-constr}$. Le premier peut être utilisé lorsqu'il est suivi d'un séparateur particulier. Dans le cas où l'on veut une liste de termes séparés par un espace, il faut lire des $\NT{simple-constr}$. Les constructions $\TERM{fix}$ et $\TERM{cofix}$ (voir aussi figure~\ref{gram-fix}) sont fermées par end pour simplifier l'analyse. Sinon, une expression de point fixe peut être suivie par un \TERM{in} ou un \TERM{and}, ce qui pose les mêmes problèmes que le ``dangling else'': dans \begin{verbatim} fix f1 x {x} = fix f2 y {y} = ... and ... in ... \end{verbatim} il faut définir une stratégie pour associer le \TERM{and} et le \TERM{in} au bon point fixe. Un autre avantage est de faire apparaitre que le \TERM{fix} est un constructeur de terme de première classe et pas un lieur: \begin{verbatim} fix f1 ... and f2 ... in f1 end x \end{verbatim} Les propositions précédentes laissaient \texttt{f1} et \texttt{x} accolés, ce qui est source de confusion lorsque l'on fait par exemple \texttt{Pattern (f1 x)}. Les corps de points fixes et co-points fixes sont identiques, bien que ces derniers n'aient pas d'information de décroissance. Cela fonctionne puisque l'annotation est optionnelle. Cela préfigure des cas où l'on arrive à inférer quel est l'argument qui décroit structurellement (en particulier dans le cas où il n'y a qu'un seul argument). \begin{figure} \begin{rulebox} \DEFNT{fix-expr} \TERM{fix}~\NT{fix-decls} ~\NT{fix-select} ~\TERM{end} &\RNAME{fix} \nlsep \TERM{cofix}~\NT{cofix-decls}~\NT{fix-select} ~\TERM{end} &\RNAME{cofix} \SEPDEF \DEFNT{fix-decls} \NT{fix-decl}~\TERM{and}~\NT{fix-decls} \nlsep \NT{fix-decl} \SEPDEF \DEFNT{fix-decl} \NT{ident}~\PLUS{\NT{binder}}~\NT{type}~\NT{annot} ~\TERM{=}~\NT{constr} \SEPDEF \DEFNT{annot} \TERM{\{}~\NT{ident}~\TERM{\}} \nlsep \epsilon \SEPDEF \DEFNT{fix-select} \TERM{in}~\NT{ident} \nlsep \epsilon \end{rulebox} \caption{Grammaires annexes des points fixes} \label{gram-fix} \end{figure} La construction $\TERM{Case}$ peut-être considérée comme obsolète. Quant au $\TERM{Match}$ de la V6, il disparaît purement et simplement. \begin{figure} \begin{rulebox} \DEFNT{match-expr} \TERM{match}~\NT{case-items}~\NT{case-type}~\TERM{with}~ \NT{branches}~\TERM{end} &\RNAME{match} \nlsep \TERM{match}~\NT{case-items}~\TERM{with}~ \NT{branches}~\TERM{end} &\RNAME{infer-match} %%\nlsep \TERM{case}~\NT{constr}~\NT{case-predicate}~\TERM{of}~ %% \STAR{\NT{constr}}~\TERM{end} &\RNAME{case} \SEPDEF \DEFNT{case-items} \NT{case-item} ~\TERM{\&} ~\NT{case-items} \nlsep \NT{case-item} \SEPDEF \DEFNT{case-item} \NT{constr}~\NT{pred-pattern} &\RNAME{dep-case} \nlsep \NT{constr} &\RNAME{nodep-case} \SEPDEF \DEFNT{case-type} \TERM{$\Rightarrow$}~\NT{constr} \nlsep \epsilon \SEPDEF \DEFNT{pred-pattern} \TERM{as}~\NT{ident} ~\TERM{\!:}~\NT{constr} \SEPDEF \DEFNT{branches} \TERM{|} ~\NT{patterns} ~\TERM{$\Rightarrow$} ~\NT{constr} ~\NT{branches} \nlsep \epsilon \SEPDEF \DEFNT{patterns} \NT{pattern} ~\TERM{\&} ~\NT{patterns} \nlsep \NT{pattern} \SEPDEF \DEFNT{pattern} ... \end{rulebox} \caption{Grammaires annexes du filtrage} \label{gram-match} \end{figure} De manière globale, l'introduction de définitions dans les termes se fait avec le symbole $=$, et le $\!:=$ est réservé aux définitions au niveau vernac. Il y avait un manque de cohérence dans la V6, puisque l'on utilisait $=$ pour le $\TERM{let}$ et $\!:=$ pour les points fixes et les commandes vernac. % OBSOLETE: lieurs multiples supprimes %On peut remarquer que $\NT{binder}$ est un sous-ensemble de %$\NT{simple-constr}$, à l'exception de $\texttt{(a,b\!\!:T)}$: en tant %que lieur, {\tt a} et {\tt b} sont tous deux contraints, alors qu'en %tant que terme, seul {\tt b} l'est. Cela qui signifie que l'objectif %de rendre compatibles les membres gauches et droits est {\it presque} %atteint. \subsection{Infixes} \subsubsection{Infixes extensibles} Le problème de savoir si la liste des symboles pouvant apparaître en infixe est fixée ou extensible par l'utilisateur reste à voir. Notons que la solution où les symboles infixes sont des identificateurs que l'on peut définir paraît difficilement praticable: par exemple $\texttt{Logic.eq}$ n'est pas un opérateur binaire, mais ternaire. Il semble plus simple de garder des déclarations infixes qui relient un symbole infixe à un terme avec deux ``trous''. Par exemple: $$\begin{array}{c|l} $infixe$ & $identificateur$ \\ \hline = & \texttt{Logic.eq _ ?1 ?2} \\ == & \texttt{JohnMajor.eq _ ?1 _ ?2} \end{array}$$ La syntaxe d'une déclaration d'infixe serait par exemple: \begin{verbatim} Infix "=" 50 := Logic.eq _ ?1 ?2; \end{verbatim} \subsubsection{Gestion des précédences} Les infixes peuvent être soit laissé à Camlp4, ou bien (comme ici) considérer que tous les opérateurs ont la même précédence et gérer soit même la recomposition des termes à l'aide d'une pile (comme Yacc). \subsection{Extensions de syntaxe} \subsubsection{Litéraux numériques} La proposition est de considerer les litéraux numériques comme de simples identificateurs. Comme il en existe une infinité, il faut un nouveau mécanisme pour leur associer une définition. Par exemple, en ce qui concerne \texttt{Arith}, la définition de $5$ serait $\texttt{S}~4$. Pour \texttt{ZArith}, $5$ serait $\texttt{xI}~2$. Comme les infixes, les constantes numériques peuvent être qualifiées pour indiquer dans quels module est le type que l'on veut référencer. Par exemple (si on renomme \texttt{Arith} en \texttt{N} et \texttt{ZArith} en \texttt{Z}): \verb+N.5+, \verb+Z.5+. \begin{eqnarray*} \EXTNT{global} \NT{int} \end{eqnarray*} \subsubsection{Nouveaux lieurs} $$ \begin{array}{rclr} \EXTNT{constr} \TERM{ex}~\PLUS{\NT{binder}}~\TERM{.}~\NT{constr} &\RNAME{ex} \nlsep \TERM{ex}~\PLUS{\NT{binder}}~\TERM{.}~\NT{constr}~\TERM{,}~\NT{constr} &\RNAME{ex2} \nlsep \TERM{ext}~\PLUS{\NT{binder}}~\TERM{.}~\NT{constr} &\RNAME{exT} \nlsep \TERM{ext}~\PLUS{\NT{binder}}~\TERM{.}~\NT{constr}~\TERM{,}~\NT{constr} &\RNAME{exT2} \end{array} $$ Pour l'instant l'existentielle n'admet qu'une seule variable, ce qui oblige à écrire des cascades de $\TERM{ex}$. Pour parser les existentielles avec deux prédicats, on peut considérer \TERM{\&} comme un infixe intermédiaire et l'opérateur existentiel en présence de cet infixe se transforme en \texttt{ex2}. \subsubsection{Nouveaux infixes} Précédences des opérateurs infixes (les plus grands associent moins fort): $$ \begin{array}{l|l|c|l} $identificateur$ & $module$ & $infixe/préfixe$ & $précédence$ \\ \hline \texttt{iff} & $Logic$ & \longleftrightarrow & 100 \\ \texttt{or} & $Logic$ & \vee & 80\, R \\ \texttt{sum} & $Datatypes$ & + & 80\, R \\ \texttt{and} & $Logic$ & \wedge & 70\, R \\ \texttt{prod} & $Datatypes$ & * & 70\, R \\ \texttt{not} & $Logic$ & \tilde{} & 60\, L \\ \texttt{eq _} & $Logic$ & = & 50 \\ \texttt{eqT _} & $Logic_Type$ & = & 50 \\ \texttt{identityT _} & $Data_Type$ & = & 50 \\ \texttt{le} & $Peano$ & $<=$ & 50 \\ \texttt{lt} & $Peano$ & $<$ & 50 \\ \texttt{ge} & $Peano$ & $>=$ & 50 \\ \texttt{gt} & $Peano$ & $>$ & 50 \\ \texttt{Zle} & $zarith_aux$ & $<=$ & 50 \\ \texttt{Zlt} & $zarith_aux$ & $<$ & 50 \\ \texttt{Zge} & $zarith_aux$ & $>=$ & 50 \\ \texttt{Zgt} & $zarith_aux$ & $>$ & 50 \\ \texttt{Rle} & $Rdefinitions$ & $<=$ & 50 \\ \texttt{Rlt} & $Rdefinitions$ & $<$ & 50 \\ \texttt{Rge} & $Rdefinitions$ & $>=$ & 50 \\ \texttt{Rgt} & $Rdefinitions$ & $>$ & 50 \\ \texttt{plus} & $Peano$ & + & 40\,L \\ \texttt{Zplus} & $fast_integer$ & + & 40\,L \\ \texttt{Rplus} & $Rdefinitions$ & + & 40\,L \\ \texttt{minus} & $Minus$ & - & 40\,L \\ \texttt{Zminus} & $zarith_aux$ & - & 40\,L \\ \texttt{Rminus} & $Rdefinitions$ & - & 40\,L \\ \texttt{Zopp} & $fast_integer$ & - & 40\,L \\ \texttt{Ropp} & $Rdefinitions$ & - & 40\,L \\ \texttt{mult} & $Peano$ & * & 30\,L \\ \texttt{Zmult} & $fast_integer$ & * & 30\,L \\ \texttt{Rmult} & $Rdefinitions$ & * & 30\,L \\ \texttt{Rdiv} & $Rdefinitions$ & / & 30\,L \\ \texttt{pow} & $Rfunctions$ & \hat & 20\,L \\ \texttt{fact} & $Rfunctions$ & ! & 20\,L \\ \end{array} $$ Notons qu'il faudrait découper {\tt Logic_Type} en deux car celui-ci définit deux égalités, ou alors les mettre dans des modules différents. \subsection{Exemples} \begin{verbatim} Definition not (A:Prop) := A->False; Inductive eq (A:Set) (x:A) : A->Prop := refl_equal : eq A x x; Inductive ex (A:Set) (P:A->Prop) : Prop := ex_intro : !x. P x -> ex A P; Lemma not_all_ex_not : !(P:U->Prop). ~(!n. P n) -> ?n. ~ P n; Fixpoint plus n m : nat {struct n} := match n with O => m | (S k) => S (plus k m) end; \end{verbatim} \subsection{Questions ouvertes} Voici les points sur lesquels la discussion est particulièrement ouverte: \begin{itemize} \item choix d'autres symboles pour les quantificateurs \TERM{!} et \TERM{?}. En l'état actuel des discussions, on garderait le \TERM{!} pour la qunatification universelle, mais on choisirait quelquechose comme \TERM{ex} pour l'existentielle, afin de ne pas suggérer trop de symétrie entre ces quantificateurs (l'un est primitif, l'autre pas). \item syntaxe particulière pour les \texttt{sig}, \texttt{sumor}, etc. \item la possibilité d'introduire plusieurs variables du même type est pour l'instant supprimée au vu des problèmes de compatibilité de syntaxe entre les membres gauches et membres droits. L'idée étant que l'inference de type permet d'éviter le besoin de déclarer tous les types. \end{itemize} \subsection{Autres extensions} \subsubsection{Lieur multiple} L'écriture de types en présence de polymorphisme est souvent assez pénible: \begin{verbatim} Check !(A:Set) (x:A) (B:Set) (y:B). P A x B y; \end{verbatim} On pourrait avoir des déclarations introduisant à la fois un type d'une certaine sorte et une variable de ce type: \begin{verbatim} Check !(x:A:Set) (y:B:Set). P A x B y; \end{verbatim} Noter que l'on aurait pu écrire: \begin{verbatim} Check !A x B y. P A (x:A:Set) B (y:B:Set); \end{verbatim} \section{Syntaxe des tactiques} \subsection{Questions diverses} Changer ``Pattern nl c ... nl c'' en ``Pattern [ nl ] c ... [ nl ] c'' pour permettre des chiffres seuls dans la catégorie syntaxique des termes. Par uniformité remplacer ``Unfold nl c'' par ``Unfold [ nl ] c'' ? Même problème pour l'entier de Specialize (ou virer Specialize ?) ? \subsection{Questions en suspens} \verb=EAuto= : deux syntaxes différentes pour la recherche en largeur et en profondeur ? Quelle recherche par défaut ? \section*{Remarques pêle-mêle (HH)} Autoriser la syntaxe \begin{verbatim} Variable R (a : A) (b : B) : Prop. Hypotheses H (a : A) (b : B) : Prop; Y (u : U) : V. Variables H (a : A) (b : B), J (k : K) : nat; Z (v : V) : Set. \end{verbatim} Renommer eqT, refl_eqT, eqT_ind, eqT_rect, eqT_rec en eq, refl_equal, etc. Remplacer == en =. Mettre des \verb=?x= plutot que des \verb=?1= dans les motifs de ltac ?? \section{Moulinette} \begin{itemize} \item Mettre \verb=/= et * au même niveau dans R. \item Changer la précédence du - unaire dans R. \item Ajouter Require Arith par necessite si Require ArithRing ou Require ZArithRing. \item Ajouter Require ZArith par necessite si Require ZArithRing ou Require Omega. \item Enlever le Export de Bool, Arith et ZARith de Ring quand inapproprié et l'ajouter à côté des Require Ring. \item Remplacer "Check n" par "n:Check ..." \item Renommer Variable/Hypothesis hors section en Parameter/Axiom. \item Renommer les \verb=command0=, \verb=command1=, ... \verb=lcommand= etc en \verb=constr0=, \verb=constr1=, ... \verb=lconstr=. \item Remplacer les noms Coq.omega.Omega par Coq.Omega ... \item Remplacer AddPath par Add LoadPath (ou + court) \item Unify + and \{\}+\{\} and +\{\} using Prop $\leq$ Set ?? \item Remplacer Implicit Arguments On/Off par Set/Unset Implicit Arguments. \item La syntaxe \verb=Intros (a,b)= est inutile, \verb=Intros [a b]= fait l'affaire. \item Virer \verb=Goal= sans argument (synonyme de \verb=Proof= et sans effets). \item Remplacer Save. par Qed. \item Remplacer \verb=Zmult_Zplus_distr= par \verb=Zmult_plus_distr_r= et \verb=Zmult_plus_distr= par \verb=Zmult_plus_distr_l=. \end{itemize} \end{document} coq-8.6/dev/doc/coq-src-description.txt0000644000175000017500000000452513022274260017441 0ustar mdenesmdenes Coq main source components (in link order) ------------------------------------------ clib : Basic files in lib/, such as util.ml lib : Other files in lib/ kernel library pretyping interp proofs printing parsing tactics toplevel highparsing : Files in parsing/ that cannot be linked too early. Contains the grammar rules g_*.ml4 Special components ------------------ intf : Contains mli-only interfaces, many of them providing a.s.t. used for dialog bewteen coq components. Ex: Constrexpr.constr_expr produced by parsing and transformed by interp. grammar : Camlp4 syntax extensions. The file grammar/grammar.cma is used to pre-process .ml4 files containing EXTEND constructions, either TACTIC EXTEND, ARGUMENTS EXTEND or VERNAC ... EXTEND. This grammar.cma incorporates many files from other directories (mainly parsing/), plus some specific files in grammar/. The other syntax extension grammar/q_constr.cmo is a addition to grammar.cma with a constr PATTERN quotation. Hierarchy of A.S.T. ------------------- *** Terms *** ... ... | /\ parsing | | printing | | V | Constrexpr.constr_expr | /\ constrintern | | constrextern (in interp) | | (in interp) globalization | | V | Glob_term.glob_constr | /\ pretyping | | detyping | | (in pretyping) V | Term.constr | /\ safe_typing | | (validation | | by kernel) |______| *** Patterns *** | | parsing V constr_pattern_expr = constr_expr | | Constrintern.interp_constr_pattern (in interp) | reverse way in Constrextern V Pattern.constr_pattern | ---> used for instance by Matching.matches (in pretyping) *** Notations *** Notation_term.notation_constr Conversion from/to glob_constr in Notation_ops TODO... *** Tactics *** | | parsing V Tacexpr.raw_tactic_expr | | Tacinterp.intern_pure_tactic (?) V Tacexpr.glob_tactic_expr | | Tacinterp.eval_tactic (?) V Proof_type.tactic TODO: check with Hugo *** Vernac expressions *** Vernacexpr.vernac_expr, produced by parsing, used in Vernacentries and Vernac coq-8.6/dev/base_include0000644000175000017500000001217113022274260014577 0ustar mdenesmdenes (* File to include to get some Coq facilities under the ocaml toplevel. This file is loaded by include *) #cd".";; #directory "parsing";; #directory "interp";; #directory "toplevel";; #directory "library";; #directory "kernel";; #directory "engine";; #directory "pretyping";; #directory "lib";; #directory "proofs";; #directory "tactics";; #directory "printing";; #directory "grammar";; #directory "intf";; #directory "stm";; #directory "ltac";; #directory "+camlp4";; (* lazy solution: add both of camlp4/5 so that *) #directory "+camlp5";; (* Gramext is found in top_printers.ml *) #use "top_printers.ml";; #use "vm_printers.ml";; #install_printer (* identifier *) ppid;; #install_printer (* identifier *) ppidset;; #install_printer (* Intset.t *) ppintset;; #install_printer (* label *) pplab;; #install_printer (* mod_bound_id *) ppmbid;; #install_printer (* dir_path *) ppdir;; #install_printer (* module_path *) ppmp;; #install_printer (* section_path *) ppsp;; #install_printer (* qualid *) ppqualid;; #install_printer (* kernel_name *) ppkn;; #install_printer (* constant *) ppcon;; #install_printer (* projection *) ppproj;; #install_printer (* cl_index *) ppclindex;; #install_printer (* recarg Rtree.t *) ppwf_paths;; #install_printer (* constr *) print_pure_constr;; #install_printer (* patch *) ppripos;; #install_printer (* values *) ppvalues;; #install_printer (* Idpred.t *) pp_idpred;; #install_printer (* Cpred.t *) pp_cpred;; #install_printer ppzipper;; #install_printer ppstack;; #install_printer (* Reductionops.Stack.t *) pp_stack_t;; #install_printer ppatom;; #install_printer ppwhd;; #install_printer ppvblock;; #install_printer (* bigint *) ppbigint;; #install_printer (* loc *) pploc;; #install_printer (* substitution *) prsubst;; (* Open main files *) open Names open Term open Vars open Context open Typeops open Term_typing open Univ open Inductive open Indtypes open Cooking open CClosure open Reduction open Safe_typing open Declare open Declaremods open Impargs open Libnames open Globnames open Nametab open Library open Cases open Pattern open Patternops open Cbv open Classops open Arguments_renaming open Pretyping open Cbv open Classops open Clenv open Clenvtac open Constr_matching open Glob_term open Glob_ops open Coercion open Recordops open Detyping open Reductionops open Evarconv open Retyping open Evarutil open Evarsolve open Tacred open Evd open Universes open Termops open Namegen open Indrec open Typing open Inductiveops open Locusops open Find_subterm open Unification open Miscops open Miscops open Nativenorm open Typeclasses open Typeclasses_errors open Vnorm open Constrextern open Constrintern open Coqlib open Genarg open Modintern open Notation open Ppextend open Reserve open Syntax_def open Constrexpr open Constrexpr_ops open Topconstr open Notation_term open Notation_ops open Prettyp open Search open Evar_refiner open Goal open Logic open Pfedit open Proof open Proof_using open Proof_global open Proof_type open Redexpr open Refiner open Tacmach open Tactic_debug open Decl_proof_instr open Decl_mode open Hints open Auto open Autorewrite open Contradiction open Eauto open Elim open Equality open Evar_tactics open Extraargs open Extratactics open Hipattern open Inv open Leminv open Tacsubst open Tacintern open Tacinterp open Tacticals open Tactics open Eqschemes open ExplainErr open Class open Command open Indschemes open Ind_tables open Auto_ind_decl open Coqinit open Coqtop open Discharge open Himsg open Metasyntax open Mltop open Record open Coqloop open Vernacentries open Vernacinterp open Vernac (* Various utilities *) let qid = Libnames.qualid_of_string;; (* parsing of terms *) let parse_constr = Pcoq.parse_string Pcoq.Constr.constr;; let parse_tac = Pcoq.parse_string Pcoq.Tactic.tactic;; let parse_vernac = Pcoq.parse_string Pcoq.Vernac_.vernac;; (* build a term of type glob_constr without type-checking or resolution of implicit syntax *) let e s = Constrintern.intern_constr (Global.env()) (parse_constr s);; (* build a term of type constr with type-checking and resolution of implicit syntax *) let constr_of_string s = Constrintern.interp_constr (Global.env()) Evd.empty (parse_constr s);; (* get the body of a constant *) open Declarations;; open Declareops;; let constbody_of_string s = let b = Global.lookup_constant (Nametab.locate_constant (qualid_of_string s)) in Option.get (Declareops.body_of_constant Opaqueproof.empty_opaquetab b);; (* Get the current goal *) (* let getgoal x = top_goal_of_pftreestate (Pfedit.get_pftreestate x);; let get_nth_goal n = nth_goal_of_pftreestate n (Pfedit.get_pftreestate ());; let current_goal () = get_nth_goal 1;; *) let pf_e gl s = Constrintern.interp_constr (pf_env gl) (project gl) (parse_constr s);; (* Set usual printing since the global env is available from the tracer *) let _ = Flags.in_debugger := false let _ = Flags.in_toplevel := true let _ = Constrextern.set_extern_reference (fun loc _ r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));; open Coqloop let go = loop let _ = print_string ("\n\tOcaml toplevel with Coq printers and utilities (use go();; to exit)\n\n"); flush_all() coq-8.6/dev/ocamldoc/0000755000175000017500000000000013022274260014016 5ustar mdenesmdenescoq-8.6/dev/ocamldoc/header.tex0000644000175000017500000000046013022274260015770 0ustar mdenesmdenes\documentclass[11pt]{article} \usepackage[utf8x]{inputenc} \usepackage[T1]{fontenc} \usepackage{textcomp} \usepackage{tipa} \usepackage{textgreek} \usepackage{fullpage} \usepackage{url} \usepackage{ocamldoc} \title{Coq mlis documentation} \begin{document} \maketitle \tableofcontents \vspace{0.2cm} coq-8.6/dev/ocamldoc/html/0000755000175000017500000000000013022274260014762 5ustar mdenesmdenescoq-8.6/dev/ocamldoc/html/style.css0000644000175000017500000000625013022274260016637 0ustar mdenesmdenesa:visited { color: #416DFF; text-decoration: none; } a:link { color: #416DFF; text-decoration: none; } a:hover { color: Red; text-decoration: none; background-color: #5FFF88 } a:active { color: Red; text-decoration: underline; } .keyword { font-weight: bold; color: Red } .keywordsign { color: #C04600 } .superscript { font-size: 8 } .subscript { font-size: 8 } .comment { color: Green } .constructor { color: Blue } .type { color: #5C6585 } .string { color: Maroon } .warning { color: Red; font-weight: bold } .info { margin-left: 3em; margin-right: 3em } .param_info { margin-top: 4px; margin-left: 3em; margin-right: 3em } .code { color: #465F91; } h1 { font-size: 20pt; text-align: center; } h5, h6, div.h7, div.h8, div.h9 { font-size: 20pt; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px; text-align: center; padding: 2px; } h5 { background-color: #90FDFF; } h6 { background-color: #016699; color: white; } div.h7 { background-color: #E0FFFF; } div.h8 { background-color: #F0FFFF; } div.h9 { background-color: #FFFFFF; } .typetable, .indextable, .paramstable { border-style: hidden; } .paramstable { padding: 5pt 5pt; } body { background-color: white; } tr { background-color: white; } td.typefieldcomment { background-color: #FFFFFF; font-size: smaller; } pre { margin-bottom: 4px; } div.sig_block { margin-left: 2em; } h2 { font-family: Arial, Helvetica, sans-serif; font-size: 16pt; font-weight: normal; border-bottom: 1px solid #dadada; border-top: 1px solid #dadada; color: #101010; background: #eeeeff; margin: 25px 0px 10px 0px; padding: 1px 1px 1px 1px; } h3 { font-family: Arial, Helvetica, sans-serif; font-size: 12pt; color: #016699; font-weight: bold; padding: 15px 0 0 0ex; margin: 5px 0 0 0; } h4 { font-family: Arial, Helvetica, sans-serif; font-size: 10pt; color: #016699; padding: 15px 0 0 0ex; margin: 5px 0 0 0; } /* Here starts the overwrite of default rules to give a better look */ body { font-family: Calibri, Georgia, Garamond, Baskerville, serif; font-size: 12pt; background-color: white; } a:link, a { color: #6895c3 !important; } a:hover { color: #2F4459 !important; background-color: white; } hr { height: 1px; color: #016699; background-color: #016699; border-width: 0; } h1, h1 a:link, h1 a:visited, h1 a { font-family: Cambria, Georgia, Garamond, Baskerville, serif; color: #016699; } .navbar { float: left; } .navbar a, .navbar a:link, .navbar a:visited { color: #016699; font-family: Arial, Helvetica, sans-serif; font-weight: bold; font-size: 80%; } .keyword { color: #c13939; } .constructor { color: #3c8f7e; } pre, code { font-family: "DejaVu Sans Mono", "Bitstream Vera Mono", "Courrier New", monospace; white-space: normal; font-size: 9pt; font-weight: bold; } .type br { display: none; } .info { margin-left: 1em; font-size: 12pt; } coq-8.6/dev/ocamldoc/fix-ocamldoc-utf80000755000175000017500000000062513022274260017200 0ustar mdenesmdenes#!/bin/sh # This reverts automatic translation of latin1 accentuated letters by ocamldoc # Usage: fix-ocamldoc-utf8 file sed -i -e 's/\\`a/\d224/g' -e "s/\\\^a/\d226/g" -e "s/\\\'e/\d233/g" -e 's/\\`e/\d232/g' -e "s/\\\^e/\d234/g" -e 's/\\\"e/\d235/g' -e "s/\\\^o/\d244/g" -e 's/\\\"o/\d246/g' -e "s/\\\^i/\d238/g" -e 's/\\\"i/\d239/g' -e 's/\\`u/\d249/g' -e "s/\\\^u/\d251/g" -e "s/\\\c{c}/\d231/g" $1 coq-8.6/dev/ocamldoc/docintro0000644000175000017500000000302013022274260015555 0ustar mdenesmdenes{!indexlist} This is Coq, a proof assistant for the Calculus of Inductive Constructions. This document describes the implementation of Coq. It has been automatically generated from the source of Coq using {{:http://caml.inria.fr/}ocamldoc}. The source files are organized in several directories ordered like that: {ol {- Utility libraries : lib describes the various utility libraries used in the code of Coq.} {- Kernel : kernel describes the Coq kernel, which is a type checker for the Calculus of Inductive Constructions.} {- Library : library describes the Coq library, which is made of two parts: - a general mechanism to keep a trace of all operations and of the state of the system, with backtrack capabilities; - a global environment for the CCI, with functions to export and import compiled modules. } {- Pretyping : pretyping } {- Front abstract syntax of terms : interp describes the translation from Coq context-dependent front abstract syntax of terms {v constr_expr v} to and from the context-free, untyped, globalized form of constructions {v glob_constr v}.} {- Parsers and printers : parsing describes the implementation of the Coq parsers and printers.} {- Proof engine : proofs describes the Coq proof engine, which is also called the ``refiner'', since it provides a way to build terms by successive refining steps. Those steps are either primitive rules or higher-level tactics.} {- Tacticts : tactics describes the Coq main tactics.} {- Toplevel : toplevel describes the highest modules of the Coq system.} } coq-8.6/dev/Makefile.oug0000644000175000017500000000500213022274260014463 0ustar mdenesmdenes####################################################################### # v # The Coq Proof Assistant / The Coq Development Team # # " --useless-elements $@ core_intf.oug: $(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(COREML) $(COREMLI) core_intf.useless: core_intf.oug $(OUG) --load-data $< --no-reduce --print-loc --roots "" --useless-elements $@ # Analysis of coqchk, considering only files in the checker/ subdir CHECKERML:=$(call local_ml_of_cma,checker/check.cma) CHECKERMLI:=$(call mli_of_ml,$(CHECKERML)) ## BUG: in oug, include dirs have reversed priority compared with ocaml, cannot use CHKLIBS MYCHKINCL:=$(MLINCLUDES) -I checker checker.oug: $(OUG) --dump-data $@ -rectypes $(MYCHKINCL) $(CHECKERML) #$(CHECKERMLI) checker.useless: checker.oug $(OUG) --load-data $< --no-reduce --print-loc --roots "" --useless-elements $@ # Analysis of extraction EXTRACTIONML:=$(call local_ml_of_cma,$(EXTRACTIONCMA)) EXTRACTIONMLI:=$(call mli_of_ml,$(EXTRACTIONMLI)) extraction.oug: $(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(EXTRACTIONML) #$(EXTRACTIONMLI) extraction.useless: extraction.oug $(OUG) --load-data $< --no-reduce --print-loc --useless-elements $@ # More to come ...coq-8.6/engine/0000755000175000017500000000000013022274260012724 5ustar mdenesmdenescoq-8.6/engine/uState.mli0000644000175000017500000000713713022274260014704 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t val is_empty : t -> bool val union : t -> t -> t val of_context_set : Univ.universe_context_set -> t val of_binders : Universes.universe_binders -> t (** {5 Projections} *) val context_set : t -> Univ.universe_context_set (** The local context of the state, i.e. a set of bound variables together with their associated constraints. *) val subst : t -> Universes.universe_opt_subst (** The local universes that are unification variables *) val ugraph : t -> UGraph.t (** The current graph extended with the local constraints *) val algebraics : t -> Univ.LSet.t (** The subset of unification variables that can be instantiated with algebraic universes as they appear in inferred types only. *) val constraints : t -> Univ.constraints (** Shorthand for {!context_set} composed with {!ContextSet.constraints}. *) val context : t -> Univ.universe_context (** Shorthand for {!context_set} with {!Context_set.to_context}. *) (** {5 Constraints handling} *) val add_constraints : t -> Univ.constraints -> t (** @raise UniversesDiffer when universes differ *) val add_universe_constraints : t -> Universes.universe_constraints -> t (** @raise UniversesDiffer when universes differ *) (** {5 Names} *) val add_universe_name : t -> string -> Univ.Level.t -> t (** Associate a human-readable name to a local variable. *) val universe_of_name : t -> string -> Univ.Level.t (** Retrieve the universe associated to the name. *) (** {5 Unification} *) val restrict : t -> Univ.universe_set -> t type rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) val univ_rigid : rigid val univ_flexible : rigid val univ_flexible_alg : rigid val merge : ?loc:Loc.t -> bool -> rigid -> t -> Univ.universe_context_set -> t val merge_subst : t -> Universes.universe_opt_subst -> t val emit_side_effects : Safe_typing.private_constants -> t -> t val new_univ_variable : ?loc:Loc.t -> rigid -> string option -> t -> t * Univ.Level.t val add_global_univ : t -> Univ.Level.t -> t val make_flexible_variable : t -> bool -> Univ.Level.t -> t val is_sort_variable : t -> Sorts.t -> Univ.Level.t option val normalize_variables : t -> Univ.universe_subst * t val constrain_variables : Univ.LSet.t -> t -> Univ.constraints val abstract_undefined_variables : t -> t val fix_undefined_variables : t -> t val refresh_undefined_univ_variables : t -> t * Univ.universe_level_subst val normalize : t -> t (** {5 TODO: Document me} *) val universe_context : ?names:(Id.t Loc.located) list -> t -> (Id.t * Univ.Level.t) list * Univ.universe_context val update_sigma_env : t -> Environ.env -> t (** {5 Pretty-printing} *) val pr_uctx_level : t -> Univ.Level.t -> Pp.std_ppcmds coq-8.6/engine/sigma.ml0000644000175000017500000000607213022274260014363 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ) = fun _ _ -> () type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma type 'a evar = Evar.t let lift_evar evk () = evk let to_evar_map evd = evd let to_evar evk = evk let here x s = Sigma (x, s, ()) (** API *) type 'r fresh = Fresh : 's evar * 's t * ('r, 's) le -> 'r fresh let new_evar sigma ?naming info = let (sigma, evk) = Evd.new_evar sigma ?naming info in Fresh (evk, sigma, ()) let define evk c sigma = Sigma ((), Evd.define evk c sigma, ()) let new_univ_level_variable ?loc ?name rigid sigma = let (sigma, u) = Evd.new_univ_level_variable ?loc ?name rigid sigma in Sigma (u, sigma, ()) let new_univ_variable ?loc ?name rigid sigma = let (sigma, u) = Evd.new_univ_variable ?loc ?name rigid sigma in Sigma (u, sigma, ()) let new_sort_variable ?loc ?name rigid sigma = let (sigma, u) = Evd.new_sort_variable ?loc ?name rigid sigma in Sigma (u, sigma, ()) let fresh_sort_in_family ?loc ?rigid env sigma s = let (sigma, s) = Evd.fresh_sort_in_family ?loc ?rigid env sigma s in Sigma (s, sigma, ()) let fresh_constant_instance ?loc env sigma cst = let (sigma, cst) = Evd.fresh_constant_instance ?loc env sigma cst in Sigma (cst, sigma, ()) let fresh_inductive_instance ?loc env sigma ind = let (sigma, ind) = Evd.fresh_inductive_instance ?loc env sigma ind in Sigma (ind, sigma, ()) let fresh_constructor_instance ?loc env sigma pc = let (sigma, c) = Evd.fresh_constructor_instance ?loc env sigma pc in Sigma (c, sigma, ()) let fresh_global ?loc ?rigid ?names env sigma r = let (sigma, c) = Evd.fresh_global ?loc ?rigid ?names env sigma r in Sigma (c, sigma, ()) (** Run *) type 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } let run sigma f : 'a * Evd.evar_map = let Sigma (x, sigma, ()) = f.run sigma in (x, sigma) (** Monotonic references *) type evdref = Evd.evar_map ref let apply evdref f = let Sigma (x, sigma, ()) = f.run !evdref in evdref := sigma; x let purify f = let f (sigma : Evd.evar_map) = let evdref = ref sigma in let ans = f evdref in Sigma (ans, !evdref, ()) in { run = f } (** Unsafe primitives *) module Unsafe = struct let le = () let of_evar_map sigma = sigma let of_evar evk = evk let of_ref ref = ref let of_pair (x, sigma) = Sigma (x, sigma, ()) end module Notations = struct type ('a, 'r) sigma_ = ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma_ let (+>) = fun _ _ -> () type 'a run_ = 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } end coq-8.6/engine/logic_monad.ml0000644000175000017500000002730413022274260015537 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* CErrors.errorlabstrm "Some timeout function" (Pp.str"Timeout!") | Exception e -> CErrors.print e | TacticFailure e -> CErrors.print e | _ -> Pervasives.raise CErrors.Unhandled end (** {6 Non-logical layer} *) (** The non-logical monad is a simple [unit -> 'a] (i/o) monad. The operations are simple wrappers around corresponding usual operations and require little documentation. *) module NonLogical = struct (* The functions in this module follow the pattern that they are defined with the form [(); fun ()->...]. This is an optimisation which signals to the compiler that the function is usually partially applied up to the [();]. Without this annotation, partial applications can be significantly slower. Documentation of this behaviour can be found at: https://ocaml.janestreet.com/?q=node/30 *) include Monad.Make(struct type 'a t = unit -> 'a let return a = (); fun () -> a let (>>=) a k = (); fun () -> k (a ()) () let (>>) a k = (); fun () -> a (); k () let map f a = (); fun () -> f (a ()) end) type 'a ref = 'a Pervasives.ref let ignore a = (); fun () -> ignore (a ()) let ref a = (); fun () -> Pervasives.ref a (** [Pervasives.(:=)] *) let (:=) r a = (); fun () -> r := a (** [Pervasives.(!)] *) let (!) = fun r -> (); fun () -> ! r (** [Pervasives.raise]. Except that exceptions are wrapped with {!Exception}. *) let raise ?info = fun e -> (); fun () -> Exninfo.raise ?info (Exception e) (** [try ... with ...] but restricted to {!Exception}. *) let catch = fun s h -> (); fun () -> try s () with Exception e as src -> let (src, info) = CErrors.push src in h (e, info) () let read_line = fun () -> try Pervasives.read_line () with e -> let (e, info) = CErrors.push e in raise ~info e () let print_char = fun c -> (); fun () -> print_char c let timeout = fun n t -> (); fun () -> Control.timeout n t (Exception Timeout) let make f = (); fun () -> try f () with e when CErrors.noncritical e -> let (e, info) = CErrors.push e in Util.iraise (Exception e, info) (** Use the current logger. The buffer is also flushed. *) let print_debug s = make (fun _ -> Feedback.msg_info s) let print_info s = make (fun _ -> Feedback.msg_info s) let print_warning s = make (fun _ -> Feedback.msg_warning s) let print_error s = make (fun _ -> Feedback.msg_error s) let print_notice s = make (fun _ -> Feedback.msg_notice s) let run = fun x -> try x () with Exception e as src -> let (src, info) = CErrors.push src in Util.iraise (e, info) end (** {6 Logical layer} *) (** The logical monad is a backtracking monad on top of which is layered a state monad (which is used to implement all of read/write, read only, and write only effects). The state monad being layered on top of the backtracking monad makes it so that the state is backtracked on failure. Backtracking differs from regular exception in that, writing (+) for exception catching and (>>=) for bind, we require the following extra distributivity laws: x+(y+z) = (x+y)+z zero+x = x x+zero = x (x+y)>>=k = (x>>=k)+(y>>=k) *) (** A view type for the logical monad, which is a form of list, hence we can decompose it with as a list. *) type ('a, 'b, 'e) list_view = | Nil of 'e | Cons of 'a * ('e -> 'b) module BackState = struct (** Double-continuation backtracking monads are reasonable folklore for "search" implementations (including the Tac interactive prover's tactics). Yet it's quite hard to wrap your head around these. I recommand reading a few times the "Backtracking, Interleaving, and Terminating Monad Transformers" paper by O. Kiselyov, C. Shan, D. Friedman, and A. Sabry. The peculiar shape of the monadic type is reminiscent of that of the continuation monad transformer. The paper also contains the rationale for the [split] abstraction. An explanation of how to derive such a monad from mathematical principles can be found in "Kan Extensions for Program Optimisation" by Ralf Hinze. A somewhat concrete view is that the type ['a iolist] is, in fact the impredicative encoding of the following stream type: [type 'a _iolist' = Nil of exn | Cons of 'a*'a iolist' and 'a iolist = 'a _iolist NonLogical.t] Using impredicative encoding avoids intermediate allocation and is, empirically, very efficient in Ocaml. It also has the practical benefit that the monadic operation are independent of the underlying monad, which simplifies the code and side-steps the limited inlining of Ocaml. In that vision, [bind] is simply [concat_map] (though the cps version is significantly simpler), [plus] is concatenation, and [split] is pattern-matching. *) type ('a, 'i, 'o, 'e) t = { iolist : 'r. 'i -> ('e -> 'r NonLogical.t) -> ('a -> 'o -> ('e -> 'r NonLogical.t) -> 'r NonLogical.t) -> 'r NonLogical.t } let return x = { iolist = fun s nil cons -> cons x s nil } let (>>=) m f = { iolist = fun s nil cons -> m.iolist s nil (fun x s next -> (f x).iolist s next cons) } let (>>) m f = { iolist = fun s nil cons -> m.iolist s nil (fun () s next -> f.iolist s next cons) } let map f m = { iolist = fun s nil cons -> m.iolist s nil (fun x s next -> cons (f x) s next) } let zero e = { iolist = fun _ nil cons -> nil e } let plus m1 m2 = { iolist = fun s nil cons -> m1.iolist s (fun e -> (m2 e).iolist s nil cons) cons } let ignore m = { iolist = fun s nil cons -> m.iolist s nil (fun _ s next -> cons () s next) } let lift m = { iolist = fun s nil cons -> NonLogical.(m >>= fun x -> cons x s nil) } (** State related *) let get = { iolist = fun s nil cons -> cons s s nil } let set s = { iolist = fun _ nil cons -> cons () s nil } let modify f = { iolist = fun s nil cons -> cons () (f s) nil } (** Exception manipulation *) let interleave src dst m = { iolist = fun s nil cons -> m.iolist s (fun e1 -> nil (src e1)) (fun x s next -> cons x s (fun e2 -> next (dst e2))) } (** List observation *) let once m = { iolist = fun s nil cons -> m.iolist s nil (fun x s _ -> cons x s nil) } let break f m = { iolist = fun s nil cons -> m.iolist s nil (fun x s next -> cons x s (fun e -> match f e with None -> next e | Some e -> nil e)) } (** For [reflect] and [split] see the "Backtracking, Interleaving, and Terminating Monad Transformers" paper. *) type ('a, 'e) reified = ('a, ('a, 'e) reified, 'e) list_view NonLogical.t let rec reflect (m : ('a * 'o, 'e) reified) = { iolist = fun s0 nil cons -> let next = function | Nil e -> nil e | Cons ((x, s), l) -> cons x s (fun e -> (reflect (l e)).iolist s0 nil cons) in NonLogical.(m >>= next) } let split m : ((_, _, _) list_view, _, _, _) t = let rnil e = NonLogical.return (Nil e) in let rcons p s l = NonLogical.return (Cons ((p, s), l)) in { iolist = fun s nil cons -> let open NonLogical in m.iolist s rnil rcons >>= begin function | Nil e -> cons (Nil e) s nil | Cons ((x, s), l) -> let l e = reflect (l e) in cons (Cons (x, l)) s nil end } let run m s = let rnil e = NonLogical.return (Nil e) in let rcons x s l = let p = (x, s) in NonLogical.return (Cons (p, l)) in m.iolist s rnil rcons let repr x = x end module type Param = sig (** Read only *) type e (** Write only *) type w (** [w] must be a monoid *) val wunit : w val wprod : w -> w -> w (** Read-write *) type s (** Update-only. Essentially a writer on [u->u]. *) type u (** [u] must be pointed. *) val uunit : u end module Logical (P:Param) = struct module Unsafe = struct (** All three of environment, writer and state are coded as a single state-passing-style monad.*) type state = { rstate : P.e; ustate : P.u; wstate : P.w; sstate : P.s; } let make m = m let repr m = m end open Unsafe type state = Unsafe.state type iexn = Exninfo.iexn type 'a reified = ('a, iexn) BackState.reified (** Inherited from Backstate *) open BackState include Monad.Make(struct type 'a t = ('a, state, state, iexn) BackState.t let return = BackState.return let (>>=) = BackState.(>>=) let (>>) = BackState.(>>) let map = BackState.map end) let zero = BackState.zero let plus = BackState.plus let ignore = BackState.ignore let lift = BackState.lift let once = BackState.once let break = BackState.break let split = BackState.split let repr = BackState.repr (** State related. We specialize them here to ensure soundness (for reader and writer) and efficiency. *) let get = { iolist = fun s nil cons -> cons s.sstate s nil } let set (sstate : P.s) = { iolist = fun s nil cons -> cons () { s with sstate } nil } let modify (f : P.s -> P.s) = { iolist = fun s nil cons -> cons () { s with sstate = f s.sstate } nil } let current = { iolist = fun s nil cons -> cons s.rstate s nil } let local e m = { iolist = fun s nil cons -> m.iolist { s with rstate = e } nil (fun x s' next -> cons x {s' with rstate = s.rstate} next) } let put w = { iolist = fun s nil cons -> cons () { s with wstate = P.wprod s.wstate w } nil } let update (f : P.u -> P.u) = { iolist = fun s nil cons -> cons () { s with ustate = f s.ustate } nil } (** Monadic run is specialized to handle reader / writer *) let run m r s = let s = { wstate = P.wunit; ustate = P.uunit; rstate = r; sstate = s } in let rnil e = NonLogical.return (Nil e) in let rcons x s l = let p = (x, s.sstate, s.wstate, s.ustate) in NonLogical.return (Cons (p, l)) in m.iolist s rnil rcons end coq-8.6/engine/evd.ml0000644000175000017500000013442213022274260014042 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> bool val identity : t val filter_list : t -> 'a list -> 'a list val filter_array : t -> 'a array -> 'a array val extend : int -> t -> t val compose : t -> t -> t val apply_subfilter : t -> bool list -> t val restrict_upon : t -> int -> (int -> bool) -> t option val map_along : (bool -> 'a -> bool) -> t -> 'a list -> t val make : bool list -> t val repr : t -> bool list option end = struct type t = bool list option (** We guarantee through the interface that if a filter is [Some _] then it contains at least one [false] somewhere. *) let identity = None let rec equal l1 l2 = match l1, l2 with | [], [] -> true | h1 :: l1, h2 :: l2 -> (if h1 then h2 else not h2) && equal l1 l2 | _ -> false let equal l1 l2 = match l1, l2 with | None, None -> true | Some _, None | None, Some _ -> false | Some l1, Some l2 -> equal l1 l2 let rec is_identity = function | [] -> true | true :: l -> is_identity l | false :: _ -> false let normalize f = if is_identity f then None else Some f let filter_list f l = match f with | None -> l | Some f -> CList.filter_with f l let filter_array f v = match f with | None -> v | Some f -> CArray.filter_with f v let rec extend n l = if n = 0 then l else extend (pred n) (true :: l) let extend n = function | None -> None | Some f -> Some (extend n f) let compose f1 f2 = match f1 with | None -> f2 | Some f1 -> match f2 with | None -> None | Some f2 -> normalize (CList.filter_with f1 f2) let apply_subfilter_array filter subfilter = (** In both cases we statically know that the argument will contain at least one [false] *) match filter with | None -> Some (Array.to_list subfilter) | Some f -> let len = Array.length subfilter in let fold b (i, ans) = if b then let () = assert (0 <= i) in (pred i, Array.unsafe_get subfilter i :: ans) else (i, false :: ans) in Some (snd (List.fold_right fold f (pred len, []))) let apply_subfilter filter subfilter = apply_subfilter_array filter (Array.of_list subfilter) let restrict_upon f len p = let newfilter = Array.init len p in if Array.for_all (fun id -> id) newfilter then None else Some (apply_subfilter_array f newfilter) let map_along f flt l = let ans = match flt with | None -> List.map (fun x -> f true x) l | Some flt -> List.map2 f flt l in normalize ans let make l = normalize l let repr f = f end (* The kinds of existential variables are now defined in [Evar_kinds] *) (* The type of mappings for existential variables *) module Dummy = struct end module Store = Store.Make(Dummy) type evar = Term.existential_key let string_of_existential evk = "?X" ^ string_of_int (Evar.repr evk) type evar_body = | Evar_empty | Evar_defined of constr type evar_info = { evar_concl : constr; evar_hyps : named_context_val; evar_body : evar_body; evar_filter : Filter.t; evar_source : Evar_kinds.t Loc.located; evar_candidates : constr list option; (* if not None, list of allowed instances *) evar_extra : Store.t } let make_evar hyps ccl = { evar_concl = ccl; evar_hyps = hyps; evar_body = Evar_empty; evar_filter = Filter.identity; evar_source = (Loc.ghost,Evar_kinds.InternalHole); evar_candidates = None; evar_extra = Store.empty } let instance_mismatch () = anomaly (Pp.str "Signature and its instance do not match") let evar_concl evi = evi.evar_concl let evar_filter evi = evi.evar_filter let evar_body evi = evi.evar_body let evar_context evi = named_context_of_val evi.evar_hyps let evar_filtered_context evi = Filter.filter_list (evar_filter evi) (evar_context evi) let evar_hyps evi = evi.evar_hyps let evar_filtered_hyps evi = match Filter.repr (evar_filter evi) with | None -> evar_hyps evi | Some filter -> let rec make_hyps filter ctxt = match filter, ctxt with | [], [] -> empty_named_context_val | false :: filter, _ :: ctxt -> make_hyps filter ctxt | true :: filter, decl :: ctxt -> let hyps = make_hyps filter ctxt in push_named_context_val decl hyps | _ -> instance_mismatch () in make_hyps filter (evar_context evi) let evar_env evi = Global.env_of_context evi.evar_hyps let evar_filtered_env evi = match Filter.repr (evar_filter evi) with | None -> evar_env evi | Some filter -> let rec make_env filter ctxt = match filter, ctxt with | [], [] -> reset_context (Global.env ()) | false :: filter, _ :: ctxt -> make_env filter ctxt | true :: filter, decl :: ctxt -> let env = make_env filter ctxt in push_named decl env | _ -> instance_mismatch () in make_env filter (evar_context evi) let map_evar_body f = function | Evar_empty -> Evar_empty | Evar_defined d -> Evar_defined (f d) let map_evar_info f evi = {evi with evar_body = map_evar_body f evi.evar_body; evar_hyps = map_named_val f evi.evar_hyps; evar_concl = f evi.evar_concl; evar_candidates = Option.map (List.map f) evi.evar_candidates } (* This exception is raised by *.existential_value *) exception NotInstantiatedEvar (* Note: let-in contributes to the instance *) let evar_instance_array test_id info args = let len = Array.length args in let rec instrec filter ctxt i = match filter, ctxt with | [], [] -> if Int.equal i len then [] else instance_mismatch () | false :: filter, _ :: ctxt -> instrec filter ctxt i | true :: filter, d :: ctxt -> if i < len then let c = Array.unsafe_get args i in if test_id d c then instrec filter ctxt (succ i) else (get_id d, c) :: instrec filter ctxt (succ i) else instance_mismatch () | _ -> instance_mismatch () in match Filter.repr (evar_filter info) with | None -> let map i d = if (i < len) then let c = Array.unsafe_get args i in if test_id d c then None else Some (get_id d, c) else instance_mismatch () in List.map_filter_i map (evar_context info) | Some filter -> instrec filter (evar_context info) 0 let make_evar_instance_array info args = evar_instance_array (isVarId % get_id) info args let instantiate_evar_array info c args = let inst = make_evar_instance_array info args in match inst with | [] -> c | _ -> replace_vars inst c type evar_universe_context = UState.t type 'a in_evar_universe_context = 'a * evar_universe_context let empty_evar_universe_context = UState.empty let is_empty_evar_universe_context = UState.is_empty let union_evar_universe_context = UState.union let evar_universe_context_set = UState.context_set let evar_universe_context_constraints = UState.constraints let evar_context_universe_context = UState.context let evar_universe_context_of = UState.of_context_set let evar_universe_context_subst = UState.subst let add_constraints_context = UState.add_constraints let add_universe_constraints_context = UState.add_universe_constraints let constrain_variables = UState.constrain_variables let evar_universe_context_of_binders = UState.of_binders (*******************************************************************) (* Metamaps *) (*******************************************************************) (* Constraints for existential variables *) (*******************************************************************) type 'a freelisted = { rebus : 'a; freemetas : Int.Set.t } (* Collects all metavars appearing in a constr *) let metavars_of c = let rec collrec acc c = match kind_of_term c with | Meta mv -> Int.Set.add mv acc | _ -> fold_constr collrec acc c in collrec Int.Set.empty c let mk_freelisted c = { rebus = c; freemetas = metavars_of c } let map_fl f cfl = { cfl with rebus=f cfl.rebus } (* Status of an instance found by unification wrt to the meta it solves: - a supertype of the meta (e.g. the solution to ?X <= T is a supertype of ?X) - a subtype of the meta (e.g. the solution to T <= ?X is a supertype of ?X) - a term that can be eta-expanded n times while still being a solution (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice) *) type instance_constraint = IsSuperType | IsSubType | Conv let eq_instance_constraint c1 c2 = c1 == c2 (* Status of the unification of the type of an instance against the type of the meta it instantiates: - CoerceToType means that the unification of types has not been done and that a coercion can still be inserted: the meta should not be substituted freely (this happens for instance given via the "with" binding clause). - TypeProcessed means that the information obtainable from the unification of types has been extracted. - TypeNotProcessed means that the unification of types has not been done but it is known that no coercion may be inserted: the meta can be substituted freely. *) type instance_typing_status = CoerceToType | TypeNotProcessed | TypeProcessed (* Status of an instance together with the status of its type unification *) type instance_status = instance_constraint * instance_typing_status (* Clausal environments *) type clbinding = | Cltyp of Name.t * constr freelisted | Clval of Name.t * (constr freelisted * instance_status) * constr freelisted let map_clb f = function | Cltyp (na,cfl) -> Cltyp (na,map_fl f cfl) | Clval (na,(cfl1,pb),cfl2) -> Clval (na,(map_fl f cfl1,pb),map_fl f cfl2) (* name of defined is erased (but it is pretty-printed) *) let clb_name = function Cltyp(na,_) -> (na,false) | Clval (na,_,_) -> (na,true) (***********************) module Metaset = Int.Set module Metamap = Int.Map let metamap_to_list m = Metamap.fold (fun n v l -> (n,v)::l) m [] (*************************) (* Unification state *) type conv_pb = Reduction.conv_pb type evar_constraint = conv_pb * Environ.env * constr * constr module EvMap = Evar.Map module EvNames : sig open Misctypes type t val empty : t val add_name_undefined : intro_pattern_naming_expr -> Evar.t -> evar_info -> t -> t val remove_name_defined : Evar.t -> t -> t val rename : Evar.t -> Id.t -> t -> t val reassign_name_defined : Evar.t -> Evar.t -> t -> t val ident : Evar.t -> t -> Id.t option val key : Id.t -> t -> Evar.t end = struct type t = Id.t EvMap.t * existential_key Idmap.t let empty = (EvMap.empty, Idmap.empty) let add_name_newly_undefined naming evk evi (evtoid, idtoev as names) = let id = match naming with | Misctypes.IntroAnonymous -> None | Misctypes.IntroIdentifier id -> if Idmap.mem id idtoev then user_err_loc (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id); Some id | Misctypes.IntroFresh id -> let id = Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in Some id in match id with | None -> names | Some id -> (EvMap.add evk id evtoid, Idmap.add id evk idtoev) let add_name_undefined naming evk evi (evtoid,idtoev as evar_names) = if EvMap.mem evk evtoid then evar_names else add_name_newly_undefined naming evk evi evar_names let remove_name_defined evk (evtoid, idtoev as names) = let id = try Some (EvMap.find evk evtoid) with Not_found -> None in match id with | None -> names | Some id -> (EvMap.remove evk evtoid, Idmap.remove id idtoev) let rename evk id (evtoid, idtoev) = let id' = try Some (EvMap.find evk evtoid) with Not_found -> None in match id' with | None -> (EvMap.add evk id evtoid, Idmap.add id evk idtoev) | Some id' -> if Idmap.mem id idtoev then anomaly (str "Evar name already in use"); (EvMap.update evk id evtoid (* overwrite old name *), Idmap.add id evk (Idmap.remove id' idtoev)) let reassign_name_defined evk evk' (evtoid, idtoev as names) = let id = try Some (EvMap.find evk evtoid) with Not_found -> None in match id with | None -> names (** evk' must not be defined *) | Some id -> (EvMap.add evk' id (EvMap.remove evk evtoid), Idmap.add id evk' (Idmap.remove id idtoev)) let ident evk (evtoid, _) = try Some (EvMap.find evk evtoid) with Not_found -> None let key id (_, idtoev) = Idmap.find id idtoev end type evar_map = { (** Existential variables *) defn_evars : evar_info EvMap.t; undf_evars : evar_info EvMap.t; evar_names : EvNames.t; (** Universes *) universes : evar_universe_context; (** Conversion problems *) conv_pbs : evar_constraint list; last_mods : Evar.Set.t; (** Metas *) metas : clbinding Metamap.t; (** Interactive proofs *) effects : Safe_typing.private_constants; future_goals : Evar.t list; (** list of newly created evars, to be eventually turned into goals if not solved.*) principal_future_goal : Evar.t option; (** if [Some e], [e] must be contained [future_goals]. The evar [e] will inherit properties (now: the name) of the evar which will be instantiated with a term containing [e]. *) extras : Store.t; } (*** Lifting primitive from Evar.Map. ***) let rename evk id evd = { evd with evar_names = EvNames.rename evk id evd.evar_names } let add_with_name ?(naming = Misctypes.IntroAnonymous) d e i = match i.evar_body with | Evar_empty -> let evar_names = EvNames.add_name_undefined naming e i d.evar_names in { d with undf_evars = EvMap.add e i d.undf_evars; evar_names } | Evar_defined _ -> let evar_names = EvNames.remove_name_defined e d.evar_names in { d with defn_evars = EvMap.add e i d.defn_evars; evar_names } let add d e i = add_with_name d e i (** New evars *) let evar_counter_summary_name = "evar counter" (* Generator of existential names *) let new_untyped_evar = let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr let new_evar evd ?naming evi = let evk = new_untyped_evar () in let evd = add_with_name evd ?naming evk evi in (evd, evk) let remove d e = let undf_evars = EvMap.remove e d.undf_evars in let defn_evars = EvMap.remove e d.defn_evars in let principal_future_goal = match d.principal_future_goal with | None -> None | Some e' -> if Evar.equal e e' then None else d.principal_future_goal in let future_goals = List.filter (fun e' -> not (Evar.equal e e')) d.future_goals in { d with undf_evars; defn_evars; principal_future_goal; future_goals } let find d e = try EvMap.find e d.undf_evars with Not_found -> EvMap.find e d.defn_evars let find_undefined d e = EvMap.find e d.undf_evars let mem d e = EvMap.mem e d.undf_evars || EvMap.mem e d.defn_evars (* spiwack: this function loses information from the original evar_map it might be an idea not to export it. *) let to_list d = (* Workaround for change in Map.fold behavior in ocaml 3.08.4 *) let l = ref [] in EvMap.iter (fun evk x -> l := (evk,x)::!l) d.defn_evars; EvMap.iter (fun evk x -> l := (evk,x)::!l) d.undf_evars; !l let undefined_map d = d.undf_evars let drop_all_defined d = { d with defn_evars = EvMap.empty } (* spiwack: not clear what folding over an evar_map, for now we shall simply fold over the inner evar_map. *) let fold f d a = EvMap.fold f d.defn_evars (EvMap.fold f d.undf_evars a) let fold_undefined f d a = EvMap.fold f d.undf_evars a let raw_map f d = let f evk info = let ans = f evk info in let () = match info.evar_body, ans.evar_body with | Evar_defined _, Evar_empty | Evar_empty, Evar_defined _ -> anomaly (str "Unrespectful mapping function.") | _ -> () in ans in let defn_evars = EvMap.smartmapi f d.defn_evars in let undf_evars = EvMap.smartmapi f d.undf_evars in { d with defn_evars; undf_evars; } let raw_map_undefined f d = let f evk info = let ans = f evk info in let () = match ans.evar_body with | Evar_defined _ -> anomaly (str "Unrespectful mapping function.") | _ -> () in ans in { d with undf_evars = EvMap.smartmapi f d.undf_evars; } let is_evar = mem let is_defined d e = EvMap.mem e d.defn_evars let is_undefined d e = EvMap.mem e d.undf_evars let existential_value d (n, args) = let info = find d n in match evar_body info with | Evar_defined c -> instantiate_evar_array info c args | Evar_empty -> raise NotInstantiatedEvar let existential_opt_value d ev = try Some (existential_value d ev) with NotInstantiatedEvar -> None let existential_type d (n, args) = let info = try find d n with Not_found -> anomaly (str "Evar " ++ str (string_of_existential n) ++ str " was not declared") in instantiate_evar_array info info.evar_concl args let add_constraints d c = { d with universes = add_constraints_context d.universes c } let add_universe_constraints d c = { d with universes = add_universe_constraints_context d.universes c } (*** /Lifting... ***) (* evar_map are considered empty disregarding histories *) let is_empty d = EvMap.is_empty d.defn_evars && EvMap.is_empty d.undf_evars && List.is_empty d.conv_pbs && Metamap.is_empty d.metas let cmap f evd = { evd with metas = Metamap.map (map_clb f) evd.metas; defn_evars = EvMap.map (map_evar_info f) evd.defn_evars; undf_evars = EvMap.map (map_evar_info f) evd.undf_evars } (* spiwack: deprecated *) let create_evar_defs sigma = { sigma with conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty } let empty = { defn_evars = EvMap.empty; undf_evars = EvMap.empty; universes = empty_evar_universe_context; conv_pbs = []; last_mods = Evar.Set.empty; metas = Metamap.empty; effects = Safe_typing.empty_private_constants; evar_names = EvNames.empty; (* id<->key for undefined evars *) future_goals = []; principal_future_goal = None; extras = Store.empty; } let from_env e = { empty with universes = UState.make (Environ.universes e) } let from_ctx ctx = { empty with universes = ctx } let has_undefined evd = not (EvMap.is_empty evd.undf_evars) let evars_reset_evd ?(with_conv_pbs=false) ?(with_univs=true) evd d = let conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs in let last_mods = if with_conv_pbs then evd.last_mods else d.last_mods in let universes = if not with_univs then evd.universes else union_evar_universe_context evd.universes d.universes in { evd with metas = d.metas; last_mods; conv_pbs; universes } let merge_universe_context evd uctx' = { evd with universes = union_evar_universe_context evd.universes uctx' } let set_universe_context evd uctx' = { evd with universes = uctx' } let add_conv_pb ?(tail=false) pb d = (** MS: we have duplicates here, why? *) if tail then {d with conv_pbs = d.conv_pbs @ [pb]} else {d with conv_pbs = pb::d.conv_pbs} let evar_source evk d = (find d evk).evar_source let evar_ident evk evd = EvNames.ident evk evd.evar_names let evar_key id evd = EvNames.key id evd.evar_names let define_aux def undef evk body = let oldinfo = try EvMap.find evk undef with Not_found -> if EvMap.mem evk def then anomaly ~label:"Evd.define" (Pp.str "cannot define an evar twice") else anomaly ~label:"Evd.define" (Pp.str "cannot define undeclared evar") in let () = assert (oldinfo.evar_body == Evar_empty) in let newinfo = { oldinfo with evar_body = Evar_defined body } in EvMap.add evk newinfo def, EvMap.remove evk undef (* define the existential of section path sp as the constr body *) let define evk body evd = let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in let last_mods = match evd.conv_pbs with | [] -> evd.last_mods | _ -> Evar.Set.add evk evd.last_mods in let evar_names = EvNames.remove_name_defined evk evd.evar_names in { evd with defn_evars; undf_evars; last_mods; evar_names } let restrict evk filter ?candidates evd = let evk' = new_untyped_evar () in let evar_info = EvMap.find evk evd.undf_evars in let evar_info' = { evar_info with evar_filter = filter; evar_candidates = candidates; evar_extra = Store.empty } in let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in let ctxt = Filter.filter_list filter (evar_context evar_info) in let id_inst = Array.map_of_list (mkVar % get_id) ctxt in let body = mkEvar(evk',id_inst) in let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in { evd with undf_evars = EvMap.add evk' evar_info' undf_evars; defn_evars; evar_names }, evk' let downcast evk ccl evd = let evar_info = EvMap.find evk evd.undf_evars in let evar_info' = { evar_info with evar_concl = ccl } in { evd with undf_evars = EvMap.add evk evar_info' evd.undf_evars } (* extracts conversion problems that satisfy predicate p *) (* Note: conv_pbs not satisying p are stored back in reverse order *) let extract_conv_pbs evd p = let (pbs,pbs1) = List.fold_left (fun (pbs,pbs1) pb -> if p pb then (pb::pbs,pbs1) else (pbs,pb::pbs1)) ([],[]) evd.conv_pbs in {evd with conv_pbs = pbs1; last_mods = Evar.Set.empty}, pbs let extract_changed_conv_pbs evd p = extract_conv_pbs evd (fun pb -> p evd.last_mods pb) let extract_all_conv_pbs evd = extract_conv_pbs evd (fun _ -> true) let loc_of_conv_pb evd (pbty,env,t1,t2) = match kind_of_term (fst (decompose_app t1)) with | Evar (evk1,_) -> fst (evar_source evk1 evd) | _ -> match kind_of_term (fst (decompose_app t2)) with | Evar (evk2,_) -> fst (evar_source evk2 evd) | _ -> Loc.ghost (** The following functions return the set of evars immediately contained in the object *) (* excluding defined evars *) let evar_list c = let rec evrec acc c = match kind_of_term c with | Evar (evk, _ as ev) -> ev :: acc | _ -> fold_constr evrec acc c in evrec [] c let evars_of_term c = let rec evrec acc c = match kind_of_term c with | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) | _ -> fold_constr evrec acc c in evrec Evar.Set.empty c let evars_of_named_context nc = List.fold_right (fun decl s -> Option.fold_left (fun s t -> Evar.Set.union s (evars_of_term t)) (Evar.Set.union s (evars_of_term (get_type decl))) (get_value decl)) nc Evar.Set.empty let evars_of_filtered_evar_info evi = Evar.Set.union (evars_of_term evi.evar_concl) (Evar.Set.union (match evi.evar_body with | Evar_empty -> Evar.Set.empty | Evar_defined b -> evars_of_term b) (evars_of_named_context (evar_filtered_context evi))) (**********************************************************) (* Sort variables *) type rigid = UState.rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) let univ_rigid = UnivRigid let univ_flexible = UnivFlexible false let univ_flexible_alg = UnivFlexible true let evar_universe_context d = d.universes let universe_context_set d = UState.context_set d.universes let pr_uctx_level = UState.pr_uctx_level let universe_context ?names evd = UState.universe_context ?names evd.universes let restrict_universe_context evd vars = { evd with universes = UState.restrict evd.universes vars } let universe_subst evd = UState.subst evd.universes let merge_context_set ?loc ?(sideff=false) rigid evd ctx' = {evd with universes = UState.merge ?loc sideff rigid evd.universes ctx'} let merge_universe_subst evd subst = {evd with universes = UState.merge_subst evd.universes subst } let with_context_set ?loc rigid d (a, ctx) = (merge_context_set ?loc rigid d ctx, a) let new_univ_level_variable ?loc ?name rigid evd = let uctx', u = UState.new_univ_variable ?loc rigid name evd.universes in ({evd with universes = uctx'}, u) let new_univ_variable ?loc ?name rigid evd = let uctx', u = UState.new_univ_variable ?loc rigid name evd.universes in ({evd with universes = uctx'}, Univ.Universe.make u) let new_sort_variable ?loc ?name rigid d = let (d', u) = new_univ_variable ?loc rigid ?name d in (d', Type u) let add_global_univ d u = { d with universes = UState.add_global_univ d.universes u } let make_flexible_variable evd b u = { evd with universes = UState.make_flexible_variable evd.universes b u } let make_evar_universe_context e l = let uctx = UState.make (Environ.universes e) in match l with | None -> uctx | Some us -> List.fold_left (fun uctx (loc,id) -> fst (UState.new_univ_variable ~loc univ_rigid (Some (Id.to_string id)) uctx)) uctx us (****************************************) (* Operations on constants *) (****************************************) let fresh_sort_in_family ?loc ?(rigid=univ_flexible) env evd s = with_context_set ?loc rigid evd (Universes.fresh_sort_in_family env s) let fresh_constant_instance ?loc env evd c = with_context_set ?loc univ_flexible evd (Universes.fresh_constant_instance env c) let fresh_inductive_instance ?loc env evd i = with_context_set ?loc univ_flexible evd (Universes.fresh_inductive_instance env i) let fresh_constructor_instance ?loc env evd c = with_context_set ?loc univ_flexible evd (Universes.fresh_constructor_instance env c) let fresh_global ?loc ?(rigid=univ_flexible) ?names env evd gr = with_context_set ?loc rigid evd (Universes.fresh_global_instance ?names env gr) let whd_sort_variable evd t = t let is_sort_variable evd s = UState.is_sort_variable evd.universes s let is_flexible_level evd l = let uctx = evd.universes in Univ.LMap.mem l (UState.subst uctx) let is_eq_sort s1 s2 = if Sorts.equal s1 s2 then None else let u1 = univ_of_sort s1 and u2 = univ_of_sort s2 in if Univ.Universe.equal u1 u2 then None else Some (u1, u2) (* Precondition: l is not defined in the substitution *) let universe_rigidity evd l = let uctx = evd.universes in if Univ.LSet.mem l (Univ.ContextSet.levels (UState.context_set uctx)) then UnivFlexible (Univ.LSet.mem l (UState.algebraics uctx)) else UnivRigid let normalize_universe evd = let vars = ref (UState.subst evd.universes) in let normalize = Universes.normalize_universe_opt_subst vars in normalize let normalize_universe_instance evd l = let vars = ref (UState.subst evd.universes) in let normalize = Univ.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in Univ.Instance.subst_fn normalize l let normalize_sort evars s = match s with | Prop _ -> s | Type u -> let u' = normalize_universe evars u in if u' == u then s else Type u' (* FIXME inefficient *) let set_eq_sort env d s1 s2 = let s1 = normalize_sort d s1 and s2 = normalize_sort d s2 in match is_eq_sort s1 s2 with | None -> d | Some (u1, u2) -> if not (type_in_type env) then add_universe_constraints d (Universes.Constraints.singleton (u1,Universes.UEq,u2)) else d let has_lub evd u1 u2 = if Univ.Universe.equal u1 u2 then evd else add_universe_constraints evd (Universes.Constraints.singleton (u1,Universes.ULub,u2)) let set_eq_level d u1 u2 = add_constraints d (Univ.enforce_eq_level u1 u2 Univ.Constraint.empty) let set_leq_level d u1 u2 = add_constraints d (Univ.enforce_leq_level u1 u2 Univ.Constraint.empty) let set_eq_instances ?(flex=false) d u1 u2 = add_universe_constraints d (Universes.enforce_eq_instances_univs flex u1 u2 Universes.Constraints.empty) let set_leq_sort env evd s1 s2 = let s1 = normalize_sort evd s1 and s2 = normalize_sort evd s2 in match is_eq_sort s1 s2 with | None -> evd | Some (u1, u2) -> if not (type_in_type env) then add_universe_constraints evd (Universes.Constraints.singleton (u1,Universes.ULe,u2)) else evd let check_eq evd s s' = UGraph.check_eq (UState.ugraph evd.universes) s s' let check_leq evd s s' = UGraph.check_leq (UState.ugraph evd.universes) s s' let normalize_evar_universe_context_variables = UState.normalize_variables let abstract_undefined_variables = UState.abstract_undefined_variables let fix_undefined_variables evd = { evd with universes = UState.fix_undefined_variables evd.universes } let refresh_undefined_universes evd = let uctx', subst = UState.refresh_undefined_univ_variables evd.universes in let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in evd', subst let normalize_evar_universe_context = UState.normalize let nf_univ_variables evd = let subst, uctx' = normalize_evar_universe_context_variables evd.universes in let evd' = {evd with universes = uctx'} in evd', subst let nf_constraints evd = let subst, uctx' = normalize_evar_universe_context_variables evd.universes in let uctx' = normalize_evar_universe_context uctx' in {evd with universes = uctx'} let universe_of_name evd s = UState.universe_of_name evd.universes s let add_universe_name evd s l = { evd with universes = UState.add_universe_name evd.universes s l } let universes evd = UState.ugraph evd.universes let update_sigma_env evd env = { evd with universes = UState.update_sigma_env evd.universes env } (* Conversion w.r.t. an evar map and its local universes. *) let test_conversion_gen env evd pb t u = match pb with | Reduction.CONV -> Reduction.conv env ~evars:((existential_opt_value evd), (UState.ugraph evd.universes)) t u | Reduction.CUMUL -> Reduction.conv_leq env ~evars:((existential_opt_value evd), (UState.ugraph evd.universes)) t u let test_conversion env d pb t u = try test_conversion_gen env d pb t u; true with _ -> false exception UniversesDiffer = UState.UniversesDiffer let eq_constr_univs evd t u = let fold cstr sigma = try Some (add_universe_constraints sigma cstr) with Univ.UniverseInconsistency _ | UniversesDiffer -> None in match Universes.eq_constr_univs_infer (UState.ugraph evd.universes) fold t u evd with | None -> evd, false | Some evd -> evd, true let e_eq_constr_univs evdref t u = let evd, b = eq_constr_univs !evdref t u in evdref := evd; b (**********************************************************) (* Side effects *) let emit_side_effects eff evd = { evd with effects = Safe_typing.concat_private eff evd.effects; universes = UState.emit_side_effects eff evd.universes } let drop_side_effects evd = { evd with effects = Safe_typing.empty_private_constants; } let eval_side_effects evd = evd.effects (* Future goals *) let declare_future_goal evk evd = { evd with future_goals = evk::evd.future_goals } let declare_principal_goal evk evd = match evd.principal_future_goal with | None -> { evd with future_goals = evk::evd.future_goals; principal_future_goal=Some evk; } | Some _ -> CErrors.error "Only one main subgoal per instantiation." let future_goals evd = evd.future_goals let principal_future_goal evd = evd.principal_future_goal let reset_future_goals evd = { evd with future_goals = [] ; principal_future_goal=None } let restore_future_goals evd gls pgl = { evd with future_goals = gls ; principal_future_goal = pgl } (**********************************************************) (* Accessing metas *) (** We use this function to overcome OCaml compiler limitations and to prevent the use of costly in-place modifications. *) let set_metas evd metas = { defn_evars = evd.defn_evars; undf_evars = evd.undf_evars; universes = evd.universes; conv_pbs = evd.conv_pbs; last_mods = evd.last_mods; metas; effects = evd.effects; evar_names = evd.evar_names; future_goals = evd.future_goals; principal_future_goal = evd.principal_future_goal; extras = evd.extras; } let meta_list evd = metamap_to_list evd.metas let undefined_metas evd = let filter = function | (n,Clval(_,_,typ)) -> None | (n,Cltyp (_,typ)) -> Some n in let m = List.map_filter filter (meta_list evd) in List.sort Int.compare m let map_metas_fvalue f evd = let map = function | Clval(id,(c,s),typ) -> Clval(id,(mk_freelisted (f c.rebus),s),typ) | x -> x in set_metas evd (Metamap.smartmap map evd.metas) let map_metas f evd = let map cl = map_clb f cl in set_metas evd (Metamap.smartmap map evd.metas) let meta_opt_fvalue evd mv = match Metamap.find mv evd.metas with | Clval(_,b,_) -> Some b | Cltyp _ -> None let meta_defined evd mv = match Metamap.find mv evd.metas with | Clval _ -> true | Cltyp _ -> false let try_meta_fvalue evd mv = match Metamap.find mv evd.metas with | Clval(_,b,_) -> b | Cltyp _ -> raise Not_found let meta_fvalue evd mv = try try_meta_fvalue evd mv with Not_found -> anomaly ~label:"meta_fvalue" (Pp.str "meta has no value") let meta_value evd mv = (fst (try_meta_fvalue evd mv)).rebus let meta_ftype evd mv = match Metamap.find mv evd.metas with | Cltyp (_,b) -> b | Clval(_,_,b) -> b let meta_type evd mv = (meta_ftype evd mv).rebus let meta_declare mv v ?(name=Anonymous) evd = let metas = Metamap.add mv (Cltyp(name,mk_freelisted v)) evd.metas in set_metas evd metas let meta_assign mv (v, pb) evd = let modify _ = function | Cltyp (na, ty) -> Clval (na, (mk_freelisted v, pb), ty) | _ -> anomaly ~label:"meta_assign" (Pp.str "already defined") in let metas = Metamap.modify mv modify evd.metas in set_metas evd metas let meta_reassign mv (v, pb) evd = let modify _ = function | Clval(na, _, ty) -> Clval (na, (mk_freelisted v, pb), ty) | _ -> anomaly ~label:"meta_reassign" (Pp.str "not yet defined") in let metas = Metamap.modify mv modify evd.metas in set_metas evd metas (* If the meta is defined then forget its name *) let meta_name evd mv = try fst (clb_name (Metamap.find mv evd.metas)) with Not_found -> Anonymous let clear_metas evd = {evd with metas = Metamap.empty} let meta_merge ?(with_univs = true) evd1 evd2 = let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in let universes = if with_univs then union_evar_universe_context evd2.universes evd1.universes else evd2.universes in {evd2 with universes; metas; } type metabinding = metavariable * constr * instance_status let retract_coercible_metas evd = let mc = ref [] in let map n v = match v with | Clval (na, (b, (Conv, CoerceToType as s)), typ) -> let () = mc := (n, b.rebus, s) :: !mc in Cltyp (na, typ) | v -> v in let metas = Metamap.smartmapi map evd.metas in !mc, set_metas evd metas let evar_source_of_meta mv evd = match meta_name evd mv with | Anonymous -> (Loc.ghost,Evar_kinds.GoalEvar) | Name id -> (Loc.ghost,Evar_kinds.VarInstance id) let dependent_evar_ident ev evd = let evi = find evd ev in match evi.evar_source with | (_,Evar_kinds.VarInstance id) -> id | _ -> anomaly (str "Not an evar resulting of a dependent binding") (**********************************************************) (* Extra data *) let get_extra_data evd = evd.extras let set_extra_data extras evd = { evd with extras } (*******************************************************************) type pending = (* before: *) evar_map * (* after: *) evar_map type pending_constr = pending * constr type open_constr = evar_map * constr (*******************************************************************) (* The type constructor ['a sigma] adds an evar map to an object of type ['a] *) type 'a sigma = { it : 'a ; sigma : evar_map } let sig_it x = x.it let sig_sig x = x.sigma let on_sig s f = let sigma', v = f s.sigma in { s with sigma = sigma' }, v (*******************************************************************) (* The state monad with state an evar map. *) module MonadR = Monad.Make (struct type +'a t = evar_map -> evar_map * 'a let return a = fun s -> (s,a) let (>>=) x f = fun s -> let (s',a) = x s in f a s' let (>>) x y = fun s -> let (s',()) = x s in y s' let map f x = fun s -> on_snd f (x s) end) module Monad = Monad.Make (struct type +'a t = evar_map -> 'a * evar_map let return a = fun s -> (a,s) let (>>=) x f = fun s -> let (a,s') = x s in f a s' let (>>) x y = fun s -> let ((),s') = x s in y s' let map f x = fun s -> on_fst f (x s) end) (**********************************************************) (* Failure explanation *) type unsolvability_explanation = SeveralInstancesFound of int (**********************************************************) (* Pretty-printing *) let pr_evar_suggested_name evk sigma = let base_id evk' evi = match evar_ident evk' sigma with | Some id -> id | None -> match evi.evar_source with | _,Evar_kinds.ImplicitArg (c,(n,Some id),b) -> id | _,Evar_kinds.VarInstance id -> id | _,Evar_kinds.GoalEvar -> Id.of_string "Goal" | _ -> let env = reset_with_named_context evi.evar_hyps (Global.env()) in Namegen.id_of_name_using_hdchar env evi.evar_concl Anonymous in let names = EvMap.mapi base_id sigma.undf_evars in let id = EvMap.find evk names in let fold evk' id' (seen, n) = if seen then (seen, n) else if Evar.equal evk evk' then (true, n) else if Id.equal id id' then (seen, succ n) else (seen, n) in let (_, n) = EvMap.fold fold names (false, 0) in if n = 0 then id else Nameops.add_suffix id (string_of_int (pred n)) let pr_existential_key sigma evk = match evar_ident evk sigma with | None -> str "?" ++ pr_id (pr_evar_suggested_name evk sigma) | Some id -> str "?" ++ pr_id id let pr_instance_status (sc,typ) = begin match sc with | IsSubType -> str " [or a subtype of it]" | IsSuperType -> str " [or a supertype of it]" | Conv -> mt () end ++ begin match typ with | CoerceToType -> str " [up to coercion]" | TypeNotProcessed -> mt () | TypeProcessed -> str " [type is checked]" end let protect f x = try f x with e -> str "EXCEPTION: " ++ str (Printexc.to_string e) let print_constr a = protect print_constr a let pr_meta_map mmap = let pr_name = function Name id -> str"[" ++ pr_id id ++ str"]" | _ -> mt() in let pr_meta_binding = function | (mv,Cltyp (na,b)) -> hov 0 (pr_meta mv ++ pr_name na ++ str " : " ++ print_constr b.rebus ++ fnl ()) | (mv,Clval(na,(b,s),t)) -> hov 0 (pr_meta mv ++ pr_name na ++ str " := " ++ print_constr b.rebus ++ str " : " ++ print_constr t.rebus ++ spc () ++ pr_instance_status s ++ fnl ()) in prlist pr_meta_binding (metamap_to_list mmap) let pr_decl (decl,ok) = let id = get_id decl in match get_value decl with | None -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}") | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++ print_constr c ++ str (if ok then ")" else "}") let pr_evar_source = function | Evar_kinds.QuestionMark _ -> str "underscore" | Evar_kinds.CasesType false -> str "pattern-matching return predicate" | Evar_kinds.CasesType true -> str "subterm of pattern-matching return predicate" | Evar_kinds.BinderType (Name id) -> str "type of " ++ Nameops.pr_id id | Evar_kinds.BinderType Anonymous -> str "type of anonymous binder" | Evar_kinds.ImplicitArg (c,(n,ido),b) -> let id = Option.get ido in str "parameter " ++ pr_id id ++ spc () ++ str "of" ++ spc () ++ print_constr (printable_constr_of_global c) | Evar_kinds.InternalHole -> str "internal placeholder" | Evar_kinds.TomatchTypeParameter (ind,n) -> pr_nth n ++ str " argument of type " ++ print_constr (mkInd ind) | Evar_kinds.GoalEvar -> str "goal evar" | Evar_kinds.ImpossibleCase -> str "type of impossible pattern-matching clause" | Evar_kinds.MatchingVar _ -> str "matching variable" | Evar_kinds.VarInstance id -> str "instance of " ++ pr_id id | Evar_kinds.SubEvar evk -> str "subterm of " ++ str (string_of_existential evk) let pr_evar_info evi = let phyps = try let decls = match Filter.repr (evar_filter evi) with | None -> List.map (fun c -> (c, true)) (evar_context evi) | Some filter -> List.combine (evar_context evi) filter in prlist_with_sep spc pr_decl (List.rev decls) with Invalid_argument _ -> str "Ill-formed filtered context" in let pty = print_constr evi.evar_concl in let pb = match evi.evar_body with | Evar_empty -> mt () | Evar_defined c -> spc() ++ str"=> " ++ print_constr c in let candidates = match evi.evar_body, evi.evar_candidates with | Evar_empty, Some l -> spc () ++ str "{" ++ prlist_with_sep (fun () -> str "|") print_constr l ++ str "}" | _ -> mt () in let src = str "(" ++ pr_evar_source (snd evi.evar_source) ++ str ")" in hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]" ++ candidates ++ spc() ++ src) let compute_evar_dependency_graph (sigma : evar_map) = (* Compute the map binding ev to the evars whose body depends on ev *) let fold evk evi acc = let fold_ev evk' acc = let tab = try EvMap.find evk' acc with Not_found -> Evar.Set.empty in EvMap.add evk' (Evar.Set.add evk tab) acc in match evar_body evi with | Evar_empty -> assert false | Evar_defined c -> Evar.Set.fold fold_ev (evars_of_term c) acc in EvMap.fold fold sigma.defn_evars EvMap.empty let evar_dependency_closure n sigma = (** Create the DAG of depth [n] representing the recursive dependencies of undefined evars. *) let graph = compute_evar_dependency_graph sigma in let rec aux n curr accu = if Int.equal n 0 then Evar.Set.union curr accu else let fold evk accu = try let deps = EvMap.find evk graph in Evar.Set.union deps accu with Not_found -> accu in (** Consider only the newly added evars *) let ncurr = Evar.Set.fold fold curr Evar.Set.empty in (** Merge the others *) let accu = Evar.Set.union curr accu in aux (n - 1) ncurr accu in let undef = EvMap.domain (undefined_map sigma) in aux n undef Evar.Set.empty let evar_dependency_closure n sigma = let deps = evar_dependency_closure n sigma in let map = EvMap.bind (fun ev -> find sigma ev) deps in EvMap.bindings map let has_no_evar sigma = EvMap.is_empty sigma.defn_evars && EvMap.is_empty sigma.undf_evars let pr_evd_level evd = pr_uctx_level evd.universes let pr_evar_universe_context ctx = let prl = pr_uctx_level ctx in if is_empty_evar_universe_context ctx then mt () else (str"UNIVERSES:"++brk(0,1)++ h 0 (Univ.pr_universe_context_set prl (evar_universe_context_set ctx)) ++ fnl () ++ str"ALGEBRAIC UNIVERSES:"++brk(0,1)++ h 0 (Univ.LSet.pr prl (UState.algebraics ctx)) ++ fnl() ++ str"UNDEFINED UNIVERSES:"++brk(0,1)++ h 0 (Universes.pr_universe_opt_subst (UState.subst ctx)) ++ fnl()) let print_env_short env = let pr_body n = function | None -> pr_name n | Some b -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" in let pr_named_decl decl = pr_body (Name (get_id decl)) (get_value decl) in let pr_rel_decl decl = let open Context.Rel.Declaration in pr_body (get_name decl) (get_value decl) in let nc = List.rev (named_context env) in let rc = List.rev (rel_context env) in str "[" ++ pr_sequence pr_named_decl nc ++ str "]" ++ spc () ++ str "[" ++ pr_sequence pr_rel_decl rc ++ str "]" let pr_evar_constraints pbs = let pr_evconstr (pbty, env, t1, t2) = let env = (** We currently allow evar instances to refer to anonymous de Bruijn indices, so we protect the error printing code in this case by giving names to every de Bruijn variable in the rel_context of the conversion problem. MS: we should rather stop depending on anonymous variables, they can be used to indicate independency. Also, this depends on a strategy for naming/renaming. *) Namegen.make_all_name_different env in print_env_short env ++ spc () ++ str "|-" ++ spc () ++ print_constr_env env t1 ++ spc () ++ str (match pbty with | Reduction.CONV -> "==" | Reduction.CUMUL -> "<=") ++ spc () ++ print_constr_env env t2 in prlist_with_sep fnl pr_evconstr pbs let pr_evar_map_gen with_univs pr_evars sigma = let { universes = uvs } = sigma in let evs = if has_no_evar sigma then mt () else pr_evars sigma ++ fnl () and svs = if with_univs then pr_evar_universe_context uvs else mt () and cstrs = if List.is_empty sigma.conv_pbs then mt () else str "CONSTRAINTS:" ++ brk (0, 1) ++ pr_evar_constraints sigma.conv_pbs ++ fnl () and metas = if Metamap.is_empty sigma.metas then mt () else str "METAS:" ++ brk (0, 1) ++ pr_meta_map sigma.metas in evs ++ svs ++ cstrs ++ metas let pr_evar_list sigma l = let pr (ev, evi) = h 0 (str (string_of_existential ev) ++ str "==" ++ pr_evar_info evi ++ (if evi.evar_body == Evar_empty then str " {" ++ pr_existential_key sigma ev ++ str "}" else mt ())) in h 0 (prlist_with_sep fnl pr l) let pr_evar_by_depth depth sigma = match depth with | None -> (* Print all evars *) str"EVARS:"++brk(0,1)++pr_evar_list sigma (to_list sigma)++fnl() | Some n -> (* Print all evars *) str"UNDEFINED EVARS:"++ (if Int.equal n 0 then mt() else str" (+level "++int n++str" closure):")++ brk(0,1)++ pr_evar_list sigma (evar_dependency_closure n sigma)++fnl() let pr_evar_by_filter filter sigma = let defined = Evar.Map.filter filter sigma.defn_evars in let undefined = Evar.Map.filter filter sigma.undf_evars in let prdef = if Evar.Map.is_empty defined then mt () else str "DEFINED EVARS:" ++ brk (0, 1) ++ pr_evar_list sigma (Evar.Map.bindings defined) in let prundef = if Evar.Map.is_empty undefined then mt () else str "UNDEFINED EVARS:" ++ brk (0, 1) ++ pr_evar_list sigma (Evar.Map.bindings undefined) in prdef ++ prundef let pr_evar_map ?(with_univs=true) depth sigma = pr_evar_map_gen with_univs (fun sigma -> pr_evar_by_depth depth sigma) sigma let pr_evar_map_filter ?(with_univs=true) filter sigma = pr_evar_map_gen with_univs (fun sigma -> pr_evar_by_filter filter sigma) sigma let pr_metaset metas = str "[" ++ pr_sequence pr_meta (Metaset.elements metas) ++ str "]" coq-8.6/engine/geninterp.ml0000644000175000017500000000502513022274260015253 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a tag | List : 'a tag -> 'a list tag | Opt : 'a tag -> 'a option tag | Pair : 'a tag * 'b tag -> ('a * 'b) tag type t = Dyn : 'a typ * 'a -> t let eq = ValT.eq let repr = ValT.repr let create = ValT.create let pr : type a. a typ -> Pp.std_ppcmds = fun t -> Pp.str (repr t) let typ_list = ValT.create "list" let typ_opt = ValT.create "option" let typ_pair = ValT.create "pair" let rec inject : type a. a tag -> a -> t = fun tag x -> match tag with | Base t -> Dyn (t, x) | List tag -> Dyn (typ_list, List.map (fun x -> inject tag x) x) | Opt tag -> Dyn (typ_opt, Option.map (fun x -> inject tag x) x) | Pair (tag1, tag2) -> Dyn (typ_pair, (inject tag1 (fst x), inject tag2 (snd x))) end module ValReprObj = struct type ('raw, 'glb, 'top) obj = 'top Val.tag let name = "valrepr" let default _ = None end module ValRepr = Register(ValReprObj) let rec val_tag : type a b c. (a, b, c) genarg_type -> c Val.tag = function | ListArg t -> Val.List (val_tag t) | OptArg t -> Val.Opt (val_tag t) | PairArg (t1, t2) -> Val.Pair (val_tag t1, val_tag t2) | ExtraArg s -> ValRepr.obj (ExtraArg s) let val_tag = function Topwit t -> val_tag t let register_val0 wit tag = let tag = match tag with | None -> let name = match wit with | ExtraArg s -> ArgT.repr s | _ -> assert false in Val.Base (Val.create name) | Some tag -> tag in ValRepr.register0 wit tag (** Interpretation functions *) type interp_sign = { lfun : Val.t Id.Map.t; extra : TacStore.t } type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t module InterpObj = struct type ('raw, 'glb, 'top) obj = ('glb, Val.t) interp_fun let name = "interp" let default _ = None end module Interp = Register(InterpObj) let interp = Interp.obj let register_interp0 = Interp.register0 coq-8.6/engine/ftactic.ml0000644000175000017500000001000313022274260014665 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* b t) : b t = m >>= function | Uniform x -> f x | Depends l -> let f arg = f arg >>= function | Uniform x -> (** We dispatch the uniform result on each goal under focus, as we know that the [m] argument was actually dependent. *) Proofview.Goal.goals >>= fun goals -> let ans = List.map (fun g -> (g,x)) goals in Proofview.tclUNIT ans | Depends l -> Proofview.Goal.goals >>= fun goals -> Proofview.tclUNIT (List.combine goals l) in (* After the tactic has run, some goals which were previously produced may have been solved by side effects. The values attached to such goals must be discarded, otherwise the list of result would not have the same length as the list of focused goals, which is an invariant of the [Ftactic] module. It is the reason why a goal is attached to each result above. *) let filter (g,x) = g >>= fun g -> Proofview.Goal.unsolved g >>= function | true -> Proofview.tclUNIT (Some x) | false -> Proofview.tclUNIT None in Proofview.tclDISPATCHL (List.map f l) >>= fun l -> Proofview.Monad.List.map_filter filter (List.concat l) >>= fun filtered -> Proofview.tclUNIT (Depends filtered) let goals = Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l) let set_sigma r = let Sigma.Sigma (ans, sigma, _) = r in Proofview.Unsafe.tclEVARS (Sigma.to_evar_map sigma) >>= fun () -> ans let nf_enter f = bind goals (fun gl -> gl >>= fun gl -> Proofview.Goal.normalize gl >>= fun nfgl -> Proofview.V82.wrap_exceptions (fun () -> f.enter nfgl)) let nf_s_enter f = bind goals (fun gl -> gl >>= fun gl -> Proofview.Goal.normalize gl >>= fun nfgl -> Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter nfgl))) let enter f = bind goals (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f.enter gl)) let s_enter f = bind goals (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter gl))) let with_env t = t >>= function | Uniform a -> Proofview.tclENV >>= fun env -> Proofview.tclUNIT (Uniform (env,a)) | Depends l -> Proofview.Goal.goals >>= fun gs -> Proofview.Monad.(List.map (map Proofview.Goal.env) gs) >>= fun envs -> Proofview.tclUNIT (Depends (List.combine envs l)) let lift (type a) (t:a Proofview.tactic) : a t = Proofview.tclBIND t (fun x -> Proofview.tclUNIT (Uniform x)) (** If the tactic returns unit, we can focus on the goals if necessary. *) let run m k = m >>= function | Uniform v -> k v | Depends l -> let tacs = List.map k l in Proofview.tclDISPATCH tacs let (>>=) = bind let (<*>) = fun m n -> bind m (fun () -> n) module Self = struct type 'a t = 'a focus Proofview.tactic let return = return let (>>=) = bind let (>>) = (<*>) let map f x = x >>= fun a -> return (f a) end module Ftac = Monad.Make(Self) module List = Ftac.List module Notations = struct let (>>=) = bind let (<*>) = fun m n -> bind m (fun () -> n) end coq-8.6/engine/proofview_monad.mli0000644000175000017500000001070313022274260016626 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a forest (** [open a] opens a tag with name [a]. *) val opn : 'a -> 'a incr -> 'a incr (** [close] closes the last open tag. It is the responsibility of the user to close all the tags. *) val close : 'a incr -> 'a incr (** [leaf] creates an empty tag with name [a]. *) val leaf : 'a -> 'a incr -> 'a incr end (** {6 State types} *) (** We typically label nodes of [Trace.tree] with messages to print. But we don't want to compute the result. *) type lazy_msg = unit -> Pp.std_ppcmds (** Info trace. *) module Info : sig (** The type of the tags for [info]. *) type tag = | Msg of lazy_msg (** A simple message *) | Tactic of lazy_msg (** A tactic call *) | Dispatch (** A call to [tclDISPATCH]/[tclEXTEND] *) | DBranch (** A special marker to delimit individual branch of a dispatch. *) type state = tag Trace.incr type tree = tag Trace.forest val print : tree -> Pp.std_ppcmds (** [collapse n t] flattens the first [n] levels of [Tactic] in an info trace, effectively forgetting about the [n] top level of names (if there are fewer, the last name is kept). *) val collapse : int -> tree -> tree end (** Type of proof views: current [evar_map] together with the list of focused goals. *) type proofview = { solution : Evd.evar_map; comb : Evar.t list; shelf : Evar.t list; } (** {6 Instantiation of the logic monad} *) module P : sig type s = proofview * Environ.env (** Status (safe/unsafe) * given up *) type w = bool * Evar.t list val wunit : w val wprod : w -> w -> w (** Recording info trace (true) or not. *) type e = bool type u = Info.state val uunit : u end module Logical : module type of Logic_monad.Logical(P) (** {6 Lenses to access to components of the states} *) module type State = sig type t val get : t Logical.t val set : t -> unit Logical.t val modify : (t->t) -> unit Logical.t end module type Writer = sig type t val put : t -> unit Logical.t end (** Lens to the [proofview]. *) module Pv : State with type t := proofview (** Lens to the [evar_map] of the proofview. *) module Solution : State with type t := Evd.evar_map (** Lens to the list of focused goals. *) module Comb : State with type t = Evar.t list (** Lens to the global environment. *) module Env : State with type t := Environ.env (** Lens to the tactic status ([true] if safe, [false] if unsafe) *) module Status : Writer with type t := bool (** Lens to the list of goals which have been shelved during the execution of the tactic. *) module Shelf : State with type t = Evar.t list (** Lens to the list of goals which were given up during the execution of the tactic. *) module Giveup : Writer with type t = Evar.t list (** Lens and utilies pertaining to the info trace *) module InfoL : sig (** [record_trace t] behaves like [t] and compute its [info] trace. *) val record_trace : 'a Logical.t -> 'a Logical.t val update : (Info.state -> Info.state) -> unit Logical.t val opn : Info.tag -> unit Logical.t val close : unit Logical.t val leaf : Info.tag -> unit Logical.t (** [tag a t] opens tag [a] runs [t] then closes the tag. *) val tag : Info.tag -> 'a Logical.t -> 'a Logical.t end coq-8.6/engine/evarutil.mli0000644000175000017500000002277413022274260015276 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* metavariable val mk_new_meta : unit -> constr (** {6 Creating a fresh evar given their type and context} *) val new_evar : env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> types -> (constr, 'r) Sigma.sigma val new_pure_evar : named_context_val -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> types -> (evar, 'r) Sigma.sigma val new_pure_evar_full : 'r Sigma.t -> evar_info -> (evar, 'r) Sigma.sigma (** the same with side-effects *) val e_new_evar : env -> evar_map ref -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> types -> constr (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> (constr * sorts, 'r) Sigma.sigma val e_new_type_evar : env -> evar_map ref -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts val new_Type : ?rigid:rigid -> env -> 'r Sigma.t -> (constr, 'r) Sigma.sigma val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr val restrict_evar : 'r Sigma.t -> existential_key -> Filter.t -> constr list option -> (existential_key, 'r) Sigma.sigma (** Polymorphic constants *) val new_global : 'r Sigma.t -> Globnames.global_reference -> (constr, 'r) Sigma.sigma val e_new_global : evar_map ref -> Globnames.global_reference -> constr (** Create a fresh evar in a context different from its definition context: [new_evar_instance sign evd ty inst] creates a new evar of context [sign] and type [ty], [inst] is a mapping of the evar context to the context where the evar should occur. This means that the terms of [inst] are typed in the occurrence context and their type (seen as a telescope) is [sign] *) val new_evar_instance : named_context_val -> 'r Sigma.t -> types -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> constr list -> (constr, 'r) Sigma.sigma val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list val safe_evar_value : evar_map -> existential -> constr option (** {6 Evars/Metas switching...} *) val non_instantiated : evar_map -> evar_info Evar.Map.t (** {6 Unification utils} *) (** [head_evar c] returns the head evar of [c] if any *) exception NoHeadEvar val head_evar : constr -> existential_key (** may raise NoHeadEvar *) (* Expand head evar if any *) val whd_head_evar : evar_map -> constr -> constr (* An over-approximation of [has_undefined (nf_evars evd c)] *) val has_undefined_evars : evar_map -> constr -> bool val is_ground_term : evar_map -> constr -> bool val is_ground_env : evar_map -> env -> bool (** [gather_dependent_evars evm seeds] classifies the evars in [evm] as dependent_evars and goals (these may overlap). A goal is an evar in [seeds] or an evar appearing in the (partial) definition of a goal. A dependent evar is an evar appearing in the type (hypotheses and conclusion) of a goal, or in the type or (partial) definition of a dependent evar. The value return is a map associating to each dependent evar [None] if it has no (partial) definition or [Some s] if [s] is the list of evars appearing in its (partial) definition. *) val gather_dependent_evars : evar_map -> evar list -> (Evar.Set.t option) Evar.Map.t (** [advance sigma g] returns [Some g'] if [g'] is undefined and is the current avatar of [g] (for instance [g] was changed by [clear] into [g']). It returns [None] if [g] has been (partially) solved. *) val advance : evar_map -> evar -> evar option (** The following functions return the set of undefined evars contained in the object, the defined evars being traversed. This is roughly a combination of the previous functions and [nf_evar]. *) val undefined_evars_of_term : evar_map -> constr -> Evar.Set.t val undefined_evars_of_named_context : evar_map -> Context.Named.t -> Evar.Set.t val undefined_evars_of_evar_info : evar_map -> evar_info -> Evar.Set.t (** [occur_evar_upto sigma k c] returns [true] if [k] appears in [c]. It looks up recursively in [sigma] for the value of existential variables. *) val occur_evar_upto : evar_map -> Evar.t -> Constr.t -> bool (** {6 Value/Type constraints} *) val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma (***********************************************************) (** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains uninstantiated; [nf_evar] leaves uninstantiated evars as is *) val whd_evar : evar_map -> constr -> constr val nf_evar : evar_map -> constr -> constr val j_nf_evar : evar_map -> unsafe_judgment -> unsafe_judgment val jl_nf_evar : evar_map -> unsafe_judgment list -> unsafe_judgment list val jv_nf_evar : evar_map -> unsafe_judgment array -> unsafe_judgment array val tj_nf_evar : evar_map -> unsafe_type_judgment -> unsafe_type_judgment val nf_named_context_evar : evar_map -> Context.Named.t -> Context.Named.t val nf_rel_context_evar : evar_map -> Context.Rel.t -> Context.Rel.t val nf_env_evar : evar_map -> env -> env val nf_evar_info : evar_map -> evar_info -> evar_info val nf_evar_map : evar_map -> evar_map val nf_evar_map_undefined : evar_map -> evar_map (** Presenting terms without solved evars *) val nf_evars_universes : evar_map -> constr -> constr val nf_evars_and_universes : evar_map -> evar_map * (constr -> constr) val e_nf_evars_and_universes : evar_map ref -> (constr -> constr) * Universes.universe_opt_subst (** Normalize the evar map w.r.t. universes, after simplification of constraints. Return the substitution function for constrs as well. *) val nf_evar_map_universes : evar_map -> evar_map * (constr -> constr) (** Replacing all evars, possibly raising [Uninstantiated_evar] *) exception Uninstantiated_evar of existential_key val flush_and_check_evars : evar_map -> constr -> constr (** {6 Term manipulation up to instantiation} *) (** Like {!Constr.kind} except that [kind_of_term sigma t] exposes [t] as an evar [e] only if [e] is uninstantiated in [sigma]. Otherwise the value of [e] in [sigma] is (recursively) used. *) val kind_of_term_upto : evar_map -> constr -> (constr,types) kind_of_term (** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and [u] up to existential variable instantiation and equalisable universes. The term [t] is interpreted in [sigma1] while [u] is interpreted in [sigma2]. The universe constraints in [sigma2] are assumed to be an extention of those in [sigma1]. *) val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool (** {6 Removing hyps in evars'context} raise OccurHypInSimpleClause if the removal breaks dependencies *) type clear_dependency_error = | OccurHypInSimpleClause of Id.t option | EvarTypingBreak of existential exception ClearDependencyError of Id.t * clear_dependency_error (* spiwack: marks an evar that has been "defined" by clear. used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*) val cleared : bool Store.field val clear_hyps_in_evi : env -> evar_map ref -> named_context_val -> types -> Id.Set.t -> named_context_val * types val clear_hyps2_in_evi : env -> evar_map ref -> named_context_val -> types -> types -> Id.Set.t -> named_context_val * types * types type csubst val empty_csubst : csubst val csubst_subst : csubst -> Constr.t -> Constr.t type ext_named_context = csubst * (Id.t * Constr.constr) list * Id.Set.t * Context.Named.t val push_rel_decl_to_named_context : Context.Rel.Declaration.t -> ext_named_context -> ext_named_context val push_rel_context_to_named_context : Environ.env -> types -> named_context_val * types * constr list * csubst * (identifier*constr) list val generalize_evar_over_rels : evar_map -> existential -> types * constr list (** Evar combinators *) val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a val subterm_source : existential_key -> Evar_kinds.t Loc.located -> Evar_kinds.t Loc.located val meta_counter_summary_name : string (** Deprecater *) type type_constraint = types option type val_constraint = constr option coq-8.6/engine/evd.mli0000644000175000017500000006016113022274260014211 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string (** {6 Evar filters} *) module Filter : sig type t (** Evar filters, seen as bitmasks. *) val equal : t -> t -> bool (** Equality over filters *) val identity : t (** The identity filter. *) val filter_list : t -> 'a list -> 'a list (** Filter a list. Sizes must coincide. *) val filter_array : t -> 'a array -> 'a array (** Filter an array. Sizes must coincide. *) val extend : int -> t -> t (** [extend n f] extends [f] on the left with [n]-th times [true]. *) val compose : t -> t -> t (** Horizontal composition : [compose f1 f2] only keeps parts of [f2] where [f1] is set. In particular, [f1] and [f2] must have the same length. *) val apply_subfilter : t -> bool list -> t (** [apply_subfilter f1 f2] applies filter [f2] where [f1] is [true]. In particular, the length of [f2] is the number of times [f1] is [true] *) val restrict_upon : t -> int -> (int -> bool) -> t option (** Ad-hoc primitive. *) val map_along : (bool -> 'a -> bool) -> t -> 'a list -> t (** Apply the function on the filter and the list. Sizes must coincide. *) val make : bool list -> t (** Create out of a list *) val repr : t -> bool list option (** Observe as a bool list. *) end (** {6 Evar infos} *) type evar_body = | Evar_empty | Evar_defined of constr module Store : Store.S (** Datatype used to store additional information in evar maps. *) type evar_info = { evar_concl : constr; (** Type of the evar. *) evar_hyps : named_context_val; (** Context of the evar. *) evar_body : evar_body; (** Optional content of the evar. *) evar_filter : Filter.t; (** Boolean mask over {!evar_hyps}. Should have the same length. When filtered out, the corresponding variable is not allowed to occur in the solution *) evar_source : Evar_kinds.t located; (** Information about the evar. *) evar_candidates : constr list option; (** List of possible solutions when known that it is a finite list *) evar_extra : Store.t (** Extra store, used for clever hacks. *) } val make_evar : named_context_val -> types -> evar_info val evar_concl : evar_info -> constr val evar_context : evar_info -> Context.Named.t val evar_filtered_context : evar_info -> Context.Named.t val evar_hyps : evar_info -> named_context_val val evar_filtered_hyps : evar_info -> named_context_val val evar_body : evar_info -> evar_body val evar_filter : evar_info -> Filter.t val evar_env : evar_info -> env val evar_filtered_env : evar_info -> env val map_evar_body : (constr -> constr) -> evar_body -> evar_body val map_evar_info : (constr -> constr) -> evar_info -> evar_info (** {6 Unification state} **) type evar_universe_context = UState.t (** The universe context associated to an evar map *) type evar_map (** Type of unification state. Essentially a bunch of state-passing data needed to handle incremental term construction. *) val empty : evar_map (** The empty evar map. *) val from_env : env -> evar_map (** The empty evar map with given universe context, taking its initial universes from env. *) val from_ctx : evar_universe_context -> evar_map (** The empty evar map with given universe context *) val is_empty : evar_map -> bool (** Whether an evarmap is empty. *) val has_undefined : evar_map -> bool (** [has_undefined sigma] is [true] if and only if there are uninstantiated evars in [sigma]. *) val new_evar : evar_map -> ?naming:Misctypes.intro_pattern_naming_expr -> evar_info -> evar_map * evar (** Creates a fresh evar mapping to the given information. *) val add : evar_map -> evar -> evar_info -> evar_map (** [add sigma ev info] adds [ev] with evar info [info] in sigma. Precondition: ev must not preexist in [sigma]. *) val find : evar_map -> evar -> evar_info (** Recover the data associated to an evar. *) val find_undefined : evar_map -> evar -> evar_info (** Same as {!find} but restricted to undefined evars. For efficiency reasons. *) val remove : evar_map -> evar -> evar_map (** Remove an evar from an evar map. Use with caution. *) val mem : evar_map -> evar -> bool (** Whether an evar is present in an evarmap. *) val fold : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a (** Apply a function to all evars and their associated info in an evarmap. *) val fold_undefined : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a (** Same as {!fold}, but restricted to undefined evars. For efficiency reasons. *) val raw_map : (evar -> evar_info -> evar_info) -> evar_map -> evar_map (** Apply the given function to all evars in the map. Beware: this function expects the argument function to preserve the kind of [evar_body], i.e. it must send [Evar_empty] to [Evar_empty] and [Evar_defined c] to some [Evar_defined c']. *) val raw_map_undefined : (evar -> evar_info -> evar_info) -> evar_map -> evar_map (** Same as {!raw_map}, but restricted to undefined evars. For efficiency reasons. *) val define : evar -> constr -> evar_map -> evar_map (** Set the body of an evar to the given constr. It is expected that: {ul {- The evar is already present in the evarmap.} {- The evar is not defined in the evarmap yet.} {- All the evars present in the constr should be present in the evar map.} } *) val cmap : (constr -> constr) -> evar_map -> evar_map (** Map the function on all terms in the evar map. *) val is_evar : evar_map -> evar -> bool (** Alias for {!mem}. *) val is_defined : evar_map -> evar -> bool (** Whether an evar is defined in an evarmap. *) val is_undefined : evar_map -> evar -> bool (** Whether an evar is not defined in an evarmap. *) val add_constraints : evar_map -> Univ.constraints -> evar_map (** Add universe constraints in an evar map. *) val undefined_map : evar_map -> evar_info Evar.Map.t (** Access the undefined evar mapping directly. *) val drop_all_defined : evar_map -> evar_map (** {6 Instantiating partial terms} *) exception NotInstantiatedEvar val existential_value : evar_map -> existential -> constr (** [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has no body and [Not_found] if it does not exist in [sigma] *) val existential_type : evar_map -> existential -> types val existential_opt_value : evar_map -> existential -> constr option (** Same as {!existential_value} but returns an option instead of raising an exception. *) val evar_instance_array : (Context.Named.Declaration.t -> 'a -> bool) -> evar_info -> 'a array -> (Id.t * 'a) list val instantiate_evar_array : evar_info -> constr -> constr array -> constr val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> evar_map -> evar_map -> evar_map (** spiwack: this function seems to somewhat break the abstraction. *) (** {6 Misc} *) val restrict : evar -> Filter.t -> ?candidates:constr list -> evar_map -> evar_map * evar (** Restrict an undefined evar into a new evar by filtering context and possibly limiting the instances to a set of candidates *) val downcast : evar -> types -> evar_map -> evar_map (** Change the type of an undefined evar to a new type assumed to be a subtype of its current type; subtyping must be ensured by caller *) val evar_source : existential_key -> evar_map -> Evar_kinds.t located (** Convenience function. Wrapper around {!find} to recover the source of an evar in a given evar map. *) val evar_ident : existential_key -> evar_map -> Id.t option val rename : existential_key -> Id.t -> evar_map -> evar_map val evar_key : Id.t -> evar_map -> existential_key val evar_source_of_meta : metavariable -> evar_map -> Evar_kinds.t located val dependent_evar_ident : existential_key -> evar_map -> Id.t (** {5 Side-effects} *) val emit_side_effects : Safe_typing.private_constants -> evar_map -> evar_map (** Push a side-effect into the evar map. *) val eval_side_effects : evar_map -> Safe_typing.private_constants (** Return the effects contained in the evar map. *) val drop_side_effects : evar_map -> evar_map (** This should not be used. For hacking purposes. *) (** {5 Future goals} *) val declare_future_goal : Evar.t -> evar_map -> evar_map (** Adds an existential variable to the list of future goals. For internal uses only. *) val declare_principal_goal : Evar.t -> evar_map -> evar_map (** Adds an existential variable to the list of future goals and make it principal. Only one existential variable can be made principal, an error is raised otherwise. For internal uses only. *) val future_goals : evar_map -> Evar.t list (** Retrieves the list of future goals. Used by the [refine] primitive of the tactic engine. *) val principal_future_goal : evar_map -> Evar.t option (** Retrieves the name of the principal existential variable if there is one. Used by the [refine] primitive of the tactic engine. *) val reset_future_goals : evar_map -> evar_map (** Clears the list of future goals (as well as the principal future goal). Used by the [refine] primitive of the tactic engine. *) val restore_future_goals : evar_map -> Evar.t list -> Evar.t option -> evar_map (** Sets the future goals (including the principal future goal) to a previous value. Intended to be used after a local list of future goals has been consumed. Used by the [refine] primitive of the tactic engine. *) (** {5 Sort variables} Evar maps also keep track of the universe constraints defined at a given point. This section defines the relevant manipulation functions. *) val whd_sort_variable : evar_map -> constr -> constr exception UniversesDiffer val add_universe_constraints : evar_map -> Universes.universe_constraints -> evar_map (** Add the given universe unification constraints to the evar map. @raises UniversesDiffer in case a first-order unification fails. @raises UniverseInconsistency *) (** {5 Extra data} Evar maps can contain arbitrary data, allowing to use an extensible state. As evar maps are theoretically used in a strict state-passing style, such additional data should be passed along transparently. Some old and bug-prone code tends to drop them nonetheless, so you should keep cautious. *) val get_extra_data : evar_map -> Store.t val set_extra_data : Store.t -> evar_map -> evar_map (** {5 Enriching with evar maps} *) type 'a sigma = { it : 'a ; (** The base object. *) sigma : evar_map (** The added unification state. *) } (** The type constructor ['a sigma] adds an evar map to an object of type ['a]. *) val sig_it : 'a sigma -> 'a val sig_sig : 'a sigma -> evar_map val on_sig : 'a sigma -> (evar_map -> evar_map * 'b) -> 'a sigma * 'b (** {5 The state monad with state an evar map} *) module MonadR : Monad.S with type +'a t = evar_map -> evar_map * 'a module Monad : Monad.S with type +'a t = evar_map -> 'a * evar_map (** {5 Meta machinery} These functions are almost deprecated. They were used before the introduction of the full-fledged evar calculus. In an ideal world, they should be removed. Alas, some parts of the code still use them. Do not use in newly-written code. *) module Metaset : Set.S with type elt = metavariable module Metamap : Map.ExtS with type key = metavariable and module Set := Metaset type 'a freelisted = { rebus : 'a; freemetas : Metaset.t } val metavars_of : constr -> Metaset.t val mk_freelisted : constr -> constr freelisted val map_fl : ('a -> 'b) -> 'a freelisted -> 'b freelisted (** Status of an instance found by unification wrt to the meta it solves: - a supertype of the meta (e.g. the solution to ?X <= T is a supertype of ?X) - a subtype of the meta (e.g. the solution to T <= ?X is a supertype of ?X) - a term that can be eta-expanded n times while still being a solution (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice) *) type instance_constraint = IsSuperType | IsSubType | Conv val eq_instance_constraint : instance_constraint -> instance_constraint -> bool (** Status of the unification of the type of an instance against the type of the meta it instantiates: - CoerceToType means that the unification of types has not been done and that a coercion can still be inserted: the meta should not be substituted freely (this happens for instance given via the "with" binding clause). - TypeProcessed means that the information obtainable from the unification of types has been extracted. - TypeNotProcessed means that the unification of types has not been done but it is known that no coercion may be inserted: the meta can be substituted freely. *) type instance_typing_status = CoerceToType | TypeNotProcessed | TypeProcessed (** Status of an instance together with the status of its type unification *) type instance_status = instance_constraint * instance_typing_status (** Clausal environments *) type clbinding = | Cltyp of Name.t * constr freelisted | Clval of Name.t * (constr freelisted * instance_status) * constr freelisted (** Unification constraints *) type conv_pb = Reduction.conv_pb type evar_constraint = conv_pb * env * constr * constr val add_conv_pb : ?tail:bool -> evar_constraint -> evar_map -> evar_map val extract_changed_conv_pbs : evar_map -> (Evar.Set.t -> evar_constraint -> bool) -> evar_map * evar_constraint list val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list val loc_of_conv_pb : evar_map -> evar_constraint -> Loc.t (** The following functions return the set of evars immediately contained in the object; need the term to be evar-normal otherwise defined evars are returned too. *) val evar_list : constr -> existential list (** excluding evars in instances of evars and collected with redundancies from right to left (used by tactic "instantiate") *) val evars_of_term : constr -> Evar.Set.t (** including evars in instances of evars *) val evars_of_named_context : Context.Named.t -> Evar.Set.t val evars_of_filtered_evar_info : evar_info -> Evar.Set.t (** Metas *) val meta_list : evar_map -> (metavariable * clbinding) list val meta_defined : evar_map -> metavariable -> bool val meta_value : evar_map -> metavariable -> constr (** [meta_fvalue] raises [Not_found] if meta not in map or [Anomaly] if meta has no value *) val meta_fvalue : evar_map -> metavariable -> constr freelisted * instance_status val meta_opt_fvalue : evar_map -> metavariable -> (constr freelisted * instance_status) option val meta_type : evar_map -> metavariable -> types val meta_ftype : evar_map -> metavariable -> types freelisted val meta_name : evar_map -> metavariable -> Name.t val meta_declare : metavariable -> types -> ?name:Name.t -> evar_map -> evar_map val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map val meta_reassign : metavariable -> constr * instance_status -> evar_map -> evar_map val clear_metas : evar_map -> evar_map (** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *) val meta_merge : ?with_univs:bool -> evar_map -> evar_map -> evar_map val undefined_metas : evar_map -> metavariable list val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map val map_metas : (constr -> constr) -> evar_map -> evar_map type metabinding = metavariable * constr * instance_status val retract_coercible_metas : evar_map -> metabinding list * evar_map (** {5 FIXME: Nothing to do here} *) (********************************************************* Sort/universe variables *) (** Rigid or flexible universe variables. [UnivRigid] variables are user-provided or come from an explicit [Type] in the source, we do not minimize them or unify them eagerly. [UnivFlexible alg] variables are fresh universe variables of polymorphic constants or generated during refinement, sometimes in algebraic position (i.e. not appearing in the term at the moment of creation). They are the candidates for minimization (if alg, to an algebraic universe) and unified eagerly in the first-order unification heurstic. *) type rigid = UState.rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) val univ_rigid : rigid val univ_flexible : rigid val univ_flexible_alg : rigid type 'a in_evar_universe_context = 'a * evar_universe_context val evar_universe_context_set : evar_universe_context -> Univ.universe_context_set val evar_universe_context_constraints : evar_universe_context -> Univ.constraints val evar_context_universe_context : evar_universe_context -> Univ.universe_context val evar_universe_context_of : Univ.universe_context_set -> evar_universe_context val empty_evar_universe_context : evar_universe_context val union_evar_universe_context : evar_universe_context -> evar_universe_context -> evar_universe_context val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst val constrain_variables : Univ.LSet.t -> evar_universe_context -> Univ.constraints val evar_universe_context_of_binders : Universes.universe_binders -> evar_universe_context val make_evar_universe_context : env -> (Id.t located) list option -> evar_universe_context val restrict_universe_context : evar_map -> Univ.universe_set -> evar_map (** Raises Not_found if not a name for a universe in this map. *) val universe_of_name : evar_map -> string -> Univ.universe_level val add_universe_name : evar_map -> string -> Univ.universe_level -> evar_map val add_constraints_context : evar_universe_context -> Univ.constraints -> evar_universe_context val normalize_evar_universe_context_variables : evar_universe_context -> Univ.universe_subst in_evar_universe_context val normalize_evar_universe_context : evar_universe_context -> evar_universe_context val new_univ_level_variable : ?loc:Loc.t -> ?name:string -> rigid -> evar_map -> evar_map * Univ.universe_level val new_univ_variable : ?loc:Loc.t -> ?name:string -> rigid -> evar_map -> evar_map * Univ.universe val new_sort_variable : ?loc:Loc.t -> ?name:string -> rigid -> evar_map -> evar_map * sorts val add_global_univ : evar_map -> Univ.Level.t -> evar_map val universe_rigidity : evar_map -> Univ.Level.t -> rigid val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map val is_sort_variable : evar_map -> sorts -> Univ.universe_level option (** [is_sort_variable evm s] returns [Some u] or [None] if [s] is not a local sort variable declared in [evm] *) val is_flexible_level : evar_map -> Univ.Level.t -> bool (* val normalize_universe_level : evar_map -> Univ.universe_level -> Univ.universe_level *) val normalize_universe : evar_map -> Univ.universe -> Univ.universe val normalize_universe_instance : evar_map -> Univ.universe_instance -> Univ.universe_instance val set_leq_sort : env -> evar_map -> sorts -> sorts -> evar_map val set_eq_sort : env -> evar_map -> sorts -> sorts -> evar_map val has_lub : evar_map -> Univ.universe -> Univ.universe -> evar_map val set_eq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map val set_leq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map val set_eq_instances : ?flex:bool -> evar_map -> Univ.universe_instance -> Univ.universe_instance -> evar_map val check_eq : evar_map -> Univ.universe -> Univ.universe -> bool val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool val evar_universe_context : evar_map -> evar_universe_context val universe_context_set : evar_map -> Univ.universe_context_set val universe_context : ?names:(Id.t located) list -> evar_map -> (Id.t * Univ.Level.t) list * Univ.universe_context val universe_subst : evar_map -> Universes.universe_opt_subst val universes : evar_map -> UGraph.t val merge_universe_context : evar_map -> evar_universe_context -> evar_map val set_universe_context : evar_map -> evar_universe_context -> evar_map val merge_context_set : ?loc:Loc.t -> ?sideff:bool -> rigid -> evar_map -> Univ.universe_context_set -> evar_map val merge_universe_subst : evar_map -> Universes.universe_opt_subst -> evar_map val with_context_set : ?loc:Loc.t -> rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst val abstract_undefined_variables : evar_universe_context -> evar_universe_context val fix_undefined_variables : evar_map -> evar_map val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_subst val nf_constraints : evar_map -> evar_map val update_sigma_env : evar_map -> env -> evar_map (** Polymorphic universes *) val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:rigid -> env -> evar_map -> sorts_family -> evar_map * sorts val fresh_constant_instance : ?loc:Loc.t -> env -> evar_map -> constant -> evar_map * pconstant val fresh_inductive_instance : ?loc:Loc.t -> env -> evar_map -> inductive -> evar_map * pinductive val fresh_constructor_instance : ?loc:Loc.t -> env -> evar_map -> constructor -> evar_map * pconstructor val fresh_global : ?loc:Loc.t -> ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map -> Globnames.global_reference -> evar_map * constr (******************************************************************** Conversion w.r.t. an evar map, not unifying universes. See [Reductionops.infer_conv] for conversion up-to universes. *) val test_conversion : env -> evar_map -> conv_pb -> constr -> constr -> bool (** WARNING: This does not allow unification of universes *) val eq_constr_univs : evar_map -> constr -> constr -> evar_map * bool (** Syntactic equality up to universes, recording the associated constraints *) val e_eq_constr_univs : evar_map ref -> constr -> constr -> bool (** Syntactic equality up to universes. *) (********************************************************************) (* constr with holes and pending resolution of classes, conversion *) (* problems, candidates, etc. *) type pending = (* before: *) evar_map * (* after: *) evar_map type pending_constr = pending * constr type open_constr = evar_map * constr (* Special case when before is empty *) (** Partially constructed constrs. *) type unsolvability_explanation = SeveralInstancesFound of int (** Failure explanation. *) val pr_existential_key : evar_map -> evar -> Pp.std_ppcmds val pr_evar_suggested_name : existential_key -> evar_map -> Id.t (** {5 Debug pretty-printers} *) val pr_evar_info : evar_info -> Pp.std_ppcmds val pr_evar_constraints : evar_constraint list -> Pp.std_ppcmds val pr_evar_map : ?with_univs:bool -> int option -> evar_map -> Pp.std_ppcmds val pr_evar_map_filter : ?with_univs:bool -> (Evar.t -> evar_info -> bool) -> evar_map -> Pp.std_ppcmds val pr_metaset : Metaset.t -> Pp.std_ppcmds val pr_evar_universe_context : evar_universe_context -> Pp.std_ppcmds val pr_evd_level : evar_map -> Univ.Level.t -> Pp.std_ppcmds (** {5 Deprecated functions} *) val create_evar_defs : evar_map -> evar_map (** Create an [evar_map] with empty meta map: *) (** {5 Summary names} *) val evar_counter_summary_name : string coq-8.6/engine/logic_monad.mli0000644000175000017500000001515413022274260015710 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a] (i/o) monad. The operations are simple wrappers around corresponding usual operations and require little documentation. *) module NonLogical : sig include Monad.S val ignore : 'a t -> unit t type 'a ref val ref : 'a -> 'a ref t (** [Pervasives.(:=)] *) val (:=) : 'a ref -> 'a -> unit t (** [Pervasives.(!)] *) val (!) : 'a ref -> 'a t val read_line : string t val print_char : char -> unit t (** Loggers. The buffer is also flushed. *) val print_debug : Pp.std_ppcmds -> unit t val print_warning : Pp.std_ppcmds -> unit t val print_notice : Pp.std_ppcmds -> unit t val print_info : Pp.std_ppcmds -> unit t val print_error : Pp.std_ppcmds -> unit t (** [Pervasives.raise]. Except that exceptions are wrapped with {!Exception}. *) val raise : ?info:Exninfo.info -> exn -> 'a t (** [try ... with ...] but restricted to {!Exception}. *) val catch : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t val timeout : int -> 'a t -> 'a t (** Construct a monadified side-effect. Exceptions raised by the argument are wrapped with {!Exception}. *) val make : (unit -> 'a) -> 'a t (** [run] performs effects. *) val run : 'a t -> 'a end (** {6 Logical layer} *) (** The logical monad is a backtracking monad on top of which is layered a state monad (which is used to implement all of read/write, read only, and write only effects). The state monad being layered on top of the backtracking monad makes it so that the state is backtracked on failure. Backtracking differs from regular exception in that, writing (+) for exception catching and (>>=) for bind, we require the following extra distributivity laws: x+(y+z) = (x+y)+z zero+x = x x+zero = x (x+y)>>=k = (x>>=k)+(y>>=k) *) (** A view type for the logical monad, which is a form of list, hence we can decompose it with as a list. *) type ('a, 'b, 'e) list_view = | Nil of 'e | Cons of 'a * ('e -> 'b) module BackState : sig type (+'a, -'i, +'o, 'e) t val return : 'a -> ('a, 's, 's, 'e) t val (>>=) : ('a, 'i, 'm, 'e) t -> ('a -> ('b, 'm, 'o, 'e) t) -> ('b, 'i, 'o, 'e) t val (>>) : (unit, 'i, 'm, 'e) t -> ('b, 'm, 'o, 'e) t -> ('b, 'i, 'o, 'e) t val map : ('a -> 'b) -> ('a, 'i, 'o, 'e) t -> ('b, 'i, 'o, 'e) t val ignore : ('a, 'i, 'o, 'e) t -> (unit, 'i, 'o, 'e) t val set : 'o -> (unit, 'i, 'o, 'e) t val get : ('s, 's, 's, 'e) t val modify : ('i -> 'o) -> (unit, 'i, 'o, 'e) t val interleave : ('e1 -> 'e2) -> ('e2 -> 'e1) -> ('a, 'i, 'o, 'e1) t -> ('a, 'i, 'o, 'e2) t (** [interleave src dst m] adapts the exceptional content of the monad according to the functions [src] and [dst]. To ensure a meaningful result, those functions must form a retraction, i.e. [dst (src e1) = e1] for all [e1]. This is typically the case when the type ['e1] is [unit]. *) val zero : 'e -> ('a, 'i, 'o, 'e) t val plus : ('a, 'i, 'o, 'e) t -> ('e -> ('a, 'i, 'o, 'e) t) -> ('a, 'i, 'o, 'e) t val split : ('a, 's, 's, 'e) t -> (('a, ('a, 'i, 's, 'e) t, 'e) list_view, 's, 's, 'e) t val once : ('a, 'i, 'o, 'e) t -> ('a, 'i, 'o, 'e) t val break : ('e -> 'e option) -> ('a, 'i, 'o, 'e) t -> ('a, 'i, 'o, 'e) t val lift : 'a NonLogical.t -> ('a, 's, 's, 'e) t type ('a, 'e) reified val repr : ('a, 'e) reified -> ('a, ('a, 'e) reified, 'e) list_view NonLogical.t val run : ('a, 'i, 'o, 'e) t -> 'i -> ('a * 'o, 'e) reified end (** The monad is parametrised in the types of state, environment and writer. *) module type Param = sig (** Read only *) type e (** Write only *) type w (** [w] must be a monoid *) val wunit : w val wprod : w -> w -> w (** Read-write *) type s (** Update-only. Essentially a writer on [u->u]. *) type u (** [u] must be pointed. *) val uunit : u end module Logical (P:Param) : sig include Monad.S val ignore : 'a t -> unit t val set : P.s -> unit t val get : P.s t val modify : (P.s -> P.s) -> unit t val put : P.w -> unit t val current : P.e t val local : P.e -> 'a t -> 'a t val update : (P.u -> P.u) -> unit t val zero : Exninfo.iexn -> 'a t val plus : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t val split : 'a t -> ('a, 'a t, Exninfo.iexn) list_view t val once : 'a t -> 'a t val break : (Exninfo.iexn -> Exninfo.iexn option) -> 'a t -> 'a t val lift : 'a NonLogical.t -> 'a t type 'a reified = ('a, Exninfo.iexn) BackState.reified val repr : 'a reified -> ('a, 'a reified, Exninfo.iexn) list_view NonLogical.t val run : 'a t -> P.e -> P.s -> ('a * P.s * P.w * P.u) reified module Unsafe : sig type state = { rstate : P.e; ustate : P.u; wstate : P.w; sstate : P.s; } val make : ('a, state, state, Exninfo.iexn) BackState.t -> 'a t val repr : 'a t -> ('a, state, state, Exninfo.iexn) BackState.t end end coq-8.6/engine/proofview.ml0000644000175000017500000012140313022274260015277 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* i+1) solution 0 in let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in let pruned_solution = Evd.drop_all_defined solution in let apply_subst_einfo _ ei = Evd.({ ei with evar_concl = nf ei.evar_concl; evar_hyps = Environ.map_named_val nf ei.evar_hyps; evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in Feedback.msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size)); new_el, { pv with solution = new_solution; } (** {6 Starting and querying a proof view} *) type telescope = | TNil of Evd.evar_map | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) let typeclass_resolvable = Evd.Store.field () let dependent_init = (* Goals are created with a store which marks them as unresolvable for type classes. *) let store = Evd.Store.set Evd.Store.empty typeclass_resolvable () in (* Goals don't have a source location. *) let src = (Loc.ghost,Evar_kinds.GoalEvar) in (* Main routine *) let rec aux = function | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] } | TCons (env, sigma, typ, t) -> let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in let sigma = Sigma.to_evar_map sigma in let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in let (gl, _) = Term.destEvar econstr in let entry = (econstr, typ) :: ret in entry, { solution = sol; comb = gl :: comb; shelf = [] } in fun t -> let entry, v = aux t in (* The created goal are not to be shelved. *) let solution = Evd.reset_future_goals v.solution in entry, { v with solution } let init = let rec aux sigma = function | [] -> TNil sigma | (env,g)::l -> TCons (env,sigma,g,(fun sigma _ -> aux sigma l)) in fun sigma l -> dependent_init (aux sigma l) let initial_goals initial = initial let finished = function | {comb = []} -> true | _ -> false let return { solution=defs } = defs let return_constr { solution = defs } c = Evarutil.nf_evar defs c let partial_proof entry pv = CList.map (return_constr pv) (CList.map fst entry) (** {6 Focusing commands} *) (** A [focus_context] represents the part of the proof view which has been removed by a focusing action, it can be used to unfocus later on. *) (* First component is a reverse list of the goals which come before and second component is the list of the goals which go after (in the expected order). *) type focus_context = Evar.t list * Evar.t list (** Returns a stylised view of a focus_context for use by, for instance, ide-s. *) (* spiwack: the type of [focus_context] will change as we push more refined functions to ide-s. This would be better than spawning a new nearly identical function everytime. Hence the generic name. *) (* In this version: the goals in the context, as a "zipper" (the first list is in reversed order). *) let focus_context f = f (** This (internal) function extracts a sublist between two indices, and returns this sublist together with its context: if it returns [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the original list. The focused list has lenght [j-i-1] and contains the goals from number [i] to number [j] (both included) the first goal of the list being numbered [1]. [focus_sublist i j l] raises [IndexOutOfRange] if [i > length l], or [j > length l] or [j < i]. *) let focus_sublist i j l = let (left,sub_right) = CList.goto (i-1) l in let (sub, right) = try CList.chop (j-i+1) sub_right with Failure _ -> raise CList.IndexOutOfRange in (sub, (left,right)) (** Inverse operation to the previous one. *) let unfocus_sublist (left,right) s = CList.rev_append left (s@right) (** [focus i j] focuses a proofview on the goals from index [i] to index [j] (inclusive, goals are indexed from [1]). I.e. goals number [i] to [j] become the only focused goals of the returned proofview. It returns the focused proofview, and a context for the focus stack. *) let focus i j sp = let (new_comb, context) = focus_sublist i j sp.comb in ( { sp with comb = new_comb } , context ) (** [undefined defs l] is the list of goals in [l] which are still unsolved (after advancing cleared goals). *) let undefined defs l = CList.map_filter (Evarutil.advance defs) l (** Unfocuses a proofview with respect to a context. *) let unfocus c sp = { sp with comb = undefined sp.solution (unfocus_sublist c sp.comb) } (** {6 The tactic monad} *) (** - Tactics are objects which apply a transformation to all the subgoals of the current view at the same time. By opposition to the old vision of applying it to a single goal. It allows tactics such as [shelve_unifiable], tactics to reorder the focused goals, or global automation tactic for dependent subgoals (instantiating an evar has influences on the other goals of the proof in progress, not being able to take that into account causes the current eauto tactic to fail on some instances where it could succeed). Another benefit is that it is possible to write tactics that can be executed even if there are no focused goals. - Tactics form a monad ['a tactic], in a sense a tactic can be seen as a function (without argument) which returns a value of type 'a and modifies the environment (in our case: the view). Tactics of course have arguments, but these are given at the meta-level as OCaml functions. Most tactics in the sense we are used to return [()], that is no really interesting values. But some might pass information around. The tactics seen in Coq's Ltac are (for now at least) only [unit tactic], the return values are kept for the OCaml toolkit. The operation or the monad are [Proofview.tclUNIT] (which is the "return" of the tactic monad) [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN] (which is a specialized bind on unit-returning tactics). - Tactics have support for full-backtracking. Tactics can be seen having multiple success: if after returning the first success a failure is encountered, the tactic can backtrack and use a second success if available. The state is backtracked to its previous value, except the non-logical state defined in the {!NonLogical} module below. *) (* spiwack: as far as I'm aware this doesn't really relate to F. Kirchner and C. Muñoz. *) module Proof = Logical (** type of tactics: tactics can - access the environment, - report unsafe status, shelved goals and given up goals - access and change the current [proofview] - backtrack on previous changes of the proofview *) type +'a tactic = 'a Proof.t (** Applies a tactic to the current proofview. *) let apply env t sp = let open Logic_monad in let ans = Proof.repr (Proof.run t false (sp,env)) in let ans = Logic_monad.NonLogical.run ans in match ans with | Nil (e, info) -> iraise (TacticFailure e, info) | Cons ((r, (state, _), status, info), _) -> let (status, gaveup) = status in let status = (status, state.shelf, gaveup) in let state = { state with shelf = [] } in r, state, status, Trace.to_tree info (** {7 Monadic primitives} *) (** Unit of the tactic monad. *) let tclUNIT = Proof.return (** Bind operation of the tactic monad. *) let tclBIND = Proof.(>>=) (** Interpretes the ";" (semicolon) of Ltac. As a monadic operation, it's a specialized "bind". *) let tclTHEN = Proof.(>>) (** [tclIGNORE t] has the same operational content as [t], but drops the returned value. *) let tclIGNORE = Proof.ignore module Monad = Proof (** {7 Failure and backtracking} *) (** [tclZERO e] fails with exception [e]. It has no success. *) let tclZERO ?info e = let info = match info with | None -> Exninfo.null | Some info -> info in Proof.zero (e, info) (** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever the successes of [t1] have been depleted and it failed with [e], then it behaves as [t2 e]. In other words, [tclOR] inserts a backtracking point. *) let tclOR = Proof.plus (** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one success or [t2 e] if [t1] fails with [e]. It is analogous to [try/with] handler of exception in that it is not a backtracking point. *) let tclORELSE t1 t2 = let open Logic_monad in let open Proof in split t1 >>= function | Nil e -> t2 e | Cons (a,t1') -> plus (return a) t1' (** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a] succeeds at least once then it behaves as [tclBIND a s] otherwise, if [a] fails with [e], then it behaves as [f e]. *) let tclIFCATCH a s f = let open Logic_monad in let open Proof in split a >>= function | Nil e -> f e | Cons (x,a') -> plus (s x) (fun e -> (a' e) >>= fun x' -> (s x')) (** [tclONCE t] behave like [t] except it has at most one success: [tclONCE t] stops after the first success of [t]. If [t] fails with [e], [tclONCE t] also fails with [e]. *) let tclONCE = Proof.once exception MoreThanOneSuccess let _ = CErrors.register_handler begin function | MoreThanOneSuccess -> CErrors.error "This tactic has more than one success." | _ -> raise CErrors.Unhandled end (** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one success. Otherwise it fails. The tactic [t] is run until its first success, then a failure with exception [e] is simulated. It [t] yields another success, then [tclEXACTLY_ONCE e t] fails with [MoreThanOneSuccess] (it is a user error). Otherwise, [tclEXACTLY_ONCE e t] succeeds with the first success of [t]. Notice that the choice of [e] is relevant, as the presence of further successes may depend on [e] (see {!tclOR}). *) let tclEXACTLY_ONCE e t = let open Logic_monad in let open Proof in split t >>= function | Nil (e, info) -> tclZERO ~info e | Cons (x,k) -> Proof.split (k (e, Exninfo.null)) >>= function | Nil _ -> tclUNIT x | _ -> tclZERO MoreThanOneSuccess (** [tclCASE t] wraps the {!Proofview_monad.Logical.split} primitive. *) type 'a case = | Fail of iexn | Next of 'a * (iexn -> 'a tactic) let tclCASE t = let open Logic_monad in let map = function | Nil e -> Fail e | Cons (x, t) -> Next (x, t) in Proof.map map (Proof.split t) let tclBREAK = Proof.break (** {7 Focusing tactics} *) exception NoSuchGoals of int (* This hook returns a string to be appended to the usual message. Primarily used to add a suggestion about the right bullet to use to focus the next goal, if applicable. *) let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ()) let set_nosuchgoals_hook f = nosuchgoals_hook := f (* This uses the hook above *) let _ = CErrors.register_handler begin function | NoSuchGoals n -> let suffix = !nosuchgoals_hook n in CErrors.errorlabstrm "" (str "No such " ++ str (String.plural n "goal") ++ str "." ++ pr_non_empty_arg (fun x -> x) suffix) | _ -> raise CErrors.Unhandled end (** [tclFOCUS_gen nosuchgoal i j t] applies [t] in a context where only the goals numbered [i] to [j] are focused (the rest of the goals is restored at the end of the tactic). If the range [i]-[j] is not valid, then it [tclFOCUS_gen nosuchgoal i j t] is [nosuchgoal]. *) let tclFOCUS_gen nosuchgoal i j t = let open Proof in Pv.get >>= fun initial -> try let (focused,context) = focus i j initial in Pv.set focused >> t >>= fun result -> Pv.modify (fun next -> unfocus context next) >> return result with CList.IndexOutOfRange -> nosuchgoal let tclFOCUS i j t = tclFOCUS_gen (tclZERO (NoSuchGoals (j+1-i))) i j t let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t let tclFOCUSLIST l t = let open Proof in Comb.get >>= fun comb -> let n = CList.length comb in (* First, remove empty intervals, and bound the intervals to the number of goals. *) let sanitize (i, j) = if i > j then None else if i > n then None else if j < 1 then None else Some ((max i 1), (min j n)) in let l = CList.map_filter sanitize l in match l with | [] -> tclZERO (NoSuchGoals 0) | (mi, _) :: _ -> (* Get the left-most goal to focus. This goal won't move, and we will then place all the other goals to focus to the right. *) let mi = CList.fold_left (fun m (i, _) -> min m i) mi l in (* [CList.goto] returns a zipper, so that [(rev left) @ sub_right = comb]. *) let left, sub_right = CList.goto (mi-1) comb in let p x _ = CList.exists (fun (i, j) -> i <= x + mi && x + mi <= j) l in let sub, right = CList.partitioni p sub_right in let mj = mi - 1 + CList.length sub in Comb.set (CList.rev_append left (sub @ right)) >> tclFOCUS mi mj t (** Like {!tclFOCUS} but selects a single goal by name. *) let tclFOCUSID id t = let open Proof in Pv.get >>= fun initial -> try let ev = Evd.evar_key id initial.solution in try let n = CList.index Evar.equal ev initial.comb in (* goal is already under focus *) let (focused,context) = focus n n initial in Pv.set focused >> t >>= fun result -> Pv.modify (fun next -> unfocus context next) >> return result with Not_found -> (* otherwise, save current focus and work purely on the shelve *) Comb.set [ev] >> t >>= fun result -> Comb.set initial.comb >> return result with Not_found -> tclZERO (NoSuchGoals 1) (** {7 Dispatching on goals} *) exception SizeMismatch of int*int let _ = CErrors.register_handler begin function | SizeMismatch (i,_) -> let open Pp in let errmsg = str"Incorrect number of goals" ++ spc() ++ str"(expected "++int i++str(String.plural i " tactic") ++ str")." in CErrors.errorlabstrm "" errmsg | _ -> raise CErrors.Unhandled end (** A variant of [Monad.List.iter] where we iter over the focused list of goals. The argument tactic is executed in a focus comprising only of the current goal, a goal which has been solved by side effect is skipped. The generated subgoals are concatenated in order. *) let iter_goal i = let open Proof in Comb.get >>= fun initial -> Proof.List.fold_left begin fun (subgoals as cur) goal -> Solution.get >>= fun step -> match Evarutil.advance step goal with | None -> return cur | Some goal -> Comb.set [goal] >> i goal >> Proof.map (fun comb -> comb :: subgoals) Comb.get end [] initial >>= fun subgoals -> Solution.get >>= fun evd -> Comb.set CList.(undefined evd (flatten (rev subgoals))) (** A variant of [Monad.List.fold_left2] where the first list is the list of focused goals. The argument tactic is executed in a focus comprising only of the current goal, a goal which has been solved by side effect is skipped. The generated subgoals are concatenated in order. *) let fold_left2_goal i s l = let open Proof in Pv.get >>= fun initial -> let err = return () >>= fun () -> (* Delay the computation of list lengths. *) tclZERO (SizeMismatch (CList.length initial.comb,CList.length l)) in Proof.List.fold_left2 err begin fun ((r,subgoals) as cur) goal a -> Solution.get >>= fun step -> match Evarutil.advance step goal with | None -> return cur | Some goal -> Comb.set [goal] >> i goal a r >>= fun r -> Proof.map (fun comb -> (r, comb :: subgoals)) Comb.get end (s,[]) initial.comb l >>= fun (r,subgoals) -> Solution.get >>= fun evd -> Comb.set CList.(undefined evd (flatten (rev subgoals))) >> return r (** Dispatch tacticals are used to apply a different tactic to each goal under focus. They come in two flavours: [tclDISPATCH] takes a list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL] takes a list of ['a tactic] and returns an ['a list tactic]. They both work by applying each of the tactic in a focus restricted to the corresponding goal (starting with the first goal). In the case of [tclDISPATCHL], the tactic returns a list of the same size as the argument list (of tactics), each element being the result of the tactic executed in the corresponding goal. When the length of the tactic list is not the number of goal, raises [SizeMismatch (g,t)] where [g] is the number of available goals, and [t] the number of tactics passed. [tclDISPATCHGEN join tacs] generalises both functions as the successive results of [tacs] are stored in reverse order in a list, and [join] is used to convert the result into the expected form. *) let tclDISPATCHGEN0 join tacs = match tacs with | [] -> begin let open Proof in Comb.get >>= function | [] -> tclUNIT (join []) | comb -> tclZERO (SizeMismatch (CList.length comb,0)) end | [tac] -> begin let open Proof in Pv.get >>= function | { comb=[goal] ; solution } -> begin match Evarutil.advance solution goal with | None -> tclUNIT (join []) | Some _ -> Proof.map (fun res -> join [res]) tac end | {comb} -> tclZERO (SizeMismatch(CList.length comb,1)) end | _ -> let iter _ t cur = Proof.map (fun y -> y :: cur) t in let ans = fold_left2_goal iter [] tacs in Proof.map join ans let tclDISPATCHGEN join tacs = let branch t = InfoL.tag (Info.DBranch) t in let tacs = CList.map branch tacs in InfoL.tag (Info.Dispatch) (tclDISPATCHGEN0 join tacs) let tclDISPATCH tacs = tclDISPATCHGEN Pervasives.ignore tacs let tclDISPATCHL tacs = tclDISPATCHGEN CList.rev tacs (** [extend_to_list startxs rx endxs l] builds a list [startxs@[rx,...,rx]@endxs] of the same length as [l]. Raises [SizeMismatch] if [startxs@endxs] is already longer than [l]. *) let extend_to_list startxs rx endxs l = (* spiwack: I use [l] essentially as a natural number *) let rec duplicate acc = function | [] -> acc | _::rest -> duplicate (rx::acc) rest in let rec tail to_match rest = match rest, to_match with | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *) | _::rest , _::to_match -> tail to_match rest | _ , [] -> duplicate endxs rest in let rec copy pref rest = match rest,pref with | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *) | _::rest, a::pref -> a::(copy pref rest) | _ , [] -> tail endxs rest in copy startxs l (** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r] tactic is "repeated" enough time such that every goal has a tactic assigned to it ([b] is the list of tactics applied to the first goals, [e] to the last goals, and [r] is applied to every goal in between). *) let tclEXTEND tacs1 rtac tacs2 = let open Proof in Comb.get >>= fun comb -> try let tacs = extend_to_list tacs1 rtac tacs2 comb in tclDISPATCH tacs with SizeMismatch _ -> tclZERO (SizeMismatch( CList.length comb, (CList.length tacs1)+(CList.length tacs2))) (* spiwack: failure occurs only when the number of goals is too small. Hence we can assume that [rtac] is replicated 0 times for any error message. *) (** [tclEXTEND [] tac []]. *) let tclINDEPENDENT tac = let open Proof in Pv.get >>= fun initial -> match initial.comb with | [] -> tclUNIT () | [_] -> tac | _ -> let tac = InfoL.tag (Info.DBranch) tac in InfoL.tag (Info.Dispatch) (iter_goal (fun _ -> tac)) (** {7 Goal manipulation} *) (** Shelves all the goals under focus. *) let shelve = let open Proof in Comb.get >>= fun initial -> Comb.set [] >> InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >> Shelf.modify (fun gls -> gls @ initial) let shelve_goals l = let open Proof in Comb.get >>= fun initial -> let comb = CList.filter (fun g -> not (CList.mem g l)) initial in Comb.set comb >> InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_goals")) >> Shelf.modify (fun gls -> gls @ l) (** [contained_in_info e evi] checks whether the evar [e] appears in the hypotheses, the conclusion or the body of the evar_info [evi]. Note: since we want to use it on goals, the body is actually supposed to be empty. *) let contained_in_info sigma e evi = Evar.Set.mem e (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi)) (** [depends_on sigma src tgt] checks whether the goal [src] appears as an existential variable in the definition of the goal [tgt] in [sigma]. *) let depends_on sigma src tgt = let evi = Evd.find sigma tgt in contained_in_info sigma src evi (** [unifiable sigma g l] checks whether [g] appears in another subgoal of [l]. The list [l] may contain [g], but it does not affect the result. *) let unifiable sigma g l = CList.exists (fun tgt -> not (Evar.equal g tgt) && depends_on sigma g tgt) l (** [partition_unifiable sigma l] partitions [l] into a pair [(u,n)] where [u] is composed of the unifiable goals, i.e. the goals on whose definition other goals of [l] depend, and [n] are the non-unifiable goals. *) let partition_unifiable sigma l = CList.partition (fun g -> unifiable sigma g l) l (** Shelves the unifiable goals under focus, i.e. the goals which appear in other goals under focus (the unfocused goals are not considered). *) let shelve_unifiable = let open Proof in Pv.get >>= fun initial -> let (u,n) = partition_unifiable initial.solution initial.comb in Comb.set n >> InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> Shelf.modify (fun gls -> gls @ u) (** [guard_no_unifiable] returns the list of unifiable goals if some goals are unifiable (see {!shelve_unifiable}) in the current focus. *) let guard_no_unifiable = let open Proof in Pv.get >>= fun initial -> let (u,n) = partition_unifiable initial.solution initial.comb in match u with | [] -> tclUNIT None | gls -> let l = CList.map (fun g -> Evd.dependent_evar_ident g initial.solution) gls in let l = CList.map (fun id -> Names.Name id) l in tclUNIT (Some l) (** [unshelve l p] adds all the goals in [l] at the end of the focused goals of p *) let unshelve l p = (* advance the goals in case of clear *) let l = undefined p.solution l in { p with comb = p.comb@l } let mark_in_evm ~goal evd content = let info = Evd.find evd content in let info = if goal then { info with Evd.evar_source = match info.Evd.evar_source with | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x | loc,_ -> loc,Evar_kinds.GoalEvar } else info in let info = match Evd.Store.get info.Evd.evar_extra typeclass_resolvable with | None -> { info with Evd.evar_extra = Evd.Store.set info.Evd.evar_extra typeclass_resolvable () } | Some () -> info in Evd.add evd content info let with_shelf tac = let open Proof in Pv.get >>= fun pv -> let { shelf; solution } = pv in Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >> tac >>= fun ans -> Pv.get >>= fun npv -> let { shelf = gls; solution = sigma } = npv in let gls' = Evd.future_goals sigma in let fgoals = Evd.future_goals solution in let pgoal = Evd.principal_future_goal solution in let sigma = Evd.restore_future_goals sigma fgoals pgoal in (* Ensure we mark and return only unsolved goals *) let gls' = undefined sigma (CList.rev_append gls' gls) in let sigma = CList.fold_left (mark_in_evm ~goal:false) sigma gls' in let npv = { npv with shelf; solution = sigma } in Pv.set npv >> tclUNIT (gls', ans) (** [goodmod p m] computes the representative of [p] modulo [m] in the interval [[0,m-1]].*) let goodmod p m = if m = 0 then 0 else let p' = p mod m in (* if [n] is negative [n mod l] is negative of absolute value less than [l], so [(n mod l)+l] is the representative of [n] in the interval [[0,l-1]].*) if p' < 0 then p'+m else p' let cycle n = let open Proof in InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle "++int n))) >> Comb.modify begin fun initial -> let l = CList.length initial in let n' = goodmod n l in let (front,rear) = CList.chop n' initial in rear@front end let swap i j = let open Proof in InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >> Comb.modify begin fun initial -> let l = CList.length initial in let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in let i = goodmod i l and j = goodmod j l in CList.map_i begin fun k x -> match k with | k when Int.equal k i -> CList.nth initial j | k when Int.equal k j -> CList.nth initial i | _ -> x end 0 initial end let revgoals = let open Proof in InfoL.leaf (Info.Tactic (fun () -> Pp.str"revgoals")) >> Comb.modify CList.rev let numgoals = let open Proof in Comb.get >>= fun comb -> return (CList.length comb) (** {7 Access primitives} *) let tclEVARMAP = Solution.get let tclENV = Env.get (** {7 Put-like primitives} *) let emit_side_effects eff x = { x with solution = Evd.emit_side_effects eff x.solution } let tclEFFECTS eff = let open Proof in return () >>= fun () -> (* The Global.env should be taken at exec time *) Env.set (Global.env ()) >> Pv.modify (fun initial -> emit_side_effects eff initial) let mark_as_unsafe = Status.put false (** Gives up on the goal under focus. Reports an unsafe status. Proofs with given up goals cannot be closed. *) let give_up = let open Proof in Comb.get >>= fun initial -> Comb.set [] >> mark_as_unsafe >> InfoL.leaf (Info.Tactic (fun () -> Pp.str"give_up")) >> Giveup.put initial (** {7 Control primitives} *) module Progress = struct let eq_constr = Evarutil.eq_constr_univs_test (** equality function on hypothesis contexts *) let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = let open Environ in let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in let eq_named_declaration d1 d2 = match d1, d2 with | LocalAssum (i1,t1), LocalAssum (i2,t2) -> Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2 | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) -> Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2 && eq_constr sigma1 sigma2 t1 t2 | _ -> false in List.equal eq_named_declaration c1 c2 let eq_evar_body sigma1 sigma2 b1 b2 = let open Evd in match b1, b2 with | Evar_empty, Evar_empty -> true | Evar_defined t1, Evar_defined t2 -> eq_constr sigma1 sigma2 t1 t2 | _ -> false let eq_evar_info sigma1 sigma2 ei1 ei2 = let open Evd in eq_constr sigma1 sigma2 ei1.evar_concl ei2.evar_concl && eq_named_context_val sigma1 sigma2 (ei1.evar_hyps) (ei2.evar_hyps) && eq_evar_body sigma1 sigma2 ei1.evar_body ei2.evar_body (** Equality function on goals *) let goal_equal evars1 gl1 evars2 gl2 = let evi1 = Evd.find evars1 gl1 in let evi2 = Evd.find evars2 gl2 in eq_evar_info evars1 evars2 evi1 evi2 end let tclPROGRESS t = let open Proof in Pv.get >>= fun initial -> t >>= fun res -> Pv.get >>= fun final -> (* [*_test] test absence of progress. [quick_test] is approximate whereas [exhaustive_test] is complete. *) let quick_test = initial.solution == final.solution && initial.comb == final.comb in let exhaustive_test = Util.List.for_all2eq begin fun i f -> Progress.goal_equal initial.solution i final.solution f end initial.comb final.comb in let test = quick_test || exhaustive_test in if not test then tclUNIT res else tclZERO (CErrors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) exception Timeout let _ = CErrors.register_handler begin function | Timeout -> CErrors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") | _ -> Pervasives.raise CErrors.Unhandled end let tclTIMEOUT n t = let open Proof in (* spiwack: as one of the monad is a continuation passing monad, it doesn't force the computation to be threaded inside the underlying (IO) monad. Hence I force it myself by asking for the evaluation of a dummy value first, lest [timeout] be called when everything has already been computed. *) let t = Proof.lift (Logic_monad.NonLogical.return ()) >> t in Proof.get >>= fun initial -> Proof.current >>= fun envvar -> Proof.lift begin Logic_monad.NonLogical.catch begin let open Logic_monad.NonLogical in timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r -> match r with | Logic_monad.Nil e -> return (Util.Inr e) | Logic_monad.Cons (r, _) -> return (Util.Inl r) end begin let open Logic_monad.NonLogical in function (e, info) -> match e with | Logic_monad.Timeout -> return (Util.Inr (Timeout, info)) | Logic_monad.TacticFailure e -> return (Util.Inr (e, info)) | e -> Logic_monad.NonLogical.raise ~info e end end >>= function | Util.Inl (res,s,m,i) -> Proof.set s >> Proof.put m >> Proof.update (fun _ -> i) >> return res | Util.Inr (e, info) -> tclZERO ~info e let tclTIME s t = let pr_time t1 t2 n msg = let msg = if n = 0 then str msg else str (msg ^ " after ") ++ int n ++ str (String.plural n " backtracking") in Feedback.msg_info(str "Tactic call" ++ pr_opt str s ++ str " ran for " ++ System.fmt_time_difference t1 t2 ++ str " " ++ surround msg) in let rec aux n t = let open Proof in tclUNIT () >>= fun () -> let tstart = System.get_time() in Proof.split t >>= let open Logic_monad in function | Nil (e, info) -> begin let tend = System.get_time() in pr_time tstart tend n "failure"; tclZERO ~info e end | Cons (x,k) -> let tend = System.get_time() in pr_time tstart tend n "success"; tclOR (tclUNIT x) (fun e -> aux (n+1) (k e)) in aux 0 t (** {7 Unsafe primitives} *) module Unsafe = struct let tclEVARS evd = Pv.modify (fun ps -> { ps with solution = evd }) let tclNEWGOALS gls = Pv.modify begin fun step -> let gls = undefined step.solution gls in { step with comb = step.comb @ gls } end let tclSETENV = Env.set let tclGETGOALS = Comb.get let tclSETGOALS = Comb.set let tclEVARSADVANCE evd = Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb }) let tclEVARUNIVCONTEXT ctx = Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx }) let reset_future_goals p = { p with solution = Evd.reset_future_goals p.solution } let mark_as_goal evd content = mark_in_evm ~goal:true evd content let advance = Evarutil.advance let mark_as_unresolvable p gl = { p with solution = mark_in_evm ~goal:false p.solution gl } let typeclass_resolvable = typeclass_resolvable end module UnsafeRepr = Proof.Unsafe let (>>=) = tclBIND (** {6 Goal-dependent tactics} *) let goal_env evars gl = let evi = Evd.find evars gl in Evd.evar_filtered_env evi let goal_nf_evar sigma gl = let evi = Evd.find sigma gl in let evi = Evarutil.nf_evar_info sigma evi in let sigma = Evd.add sigma gl evi in (gl, sigma) let goal_extra evars gl = let evi = Evd.find evars gl in evi.Evd.evar_extra let catchable_exception = function | Logic_monad.Exception _ -> false | e -> CErrors.noncritical e module Goal = struct type ('a, 'r) t = { env : Environ.env; sigma : Evd.evar_map; concl : Term.constr ; self : Evar.t ; (* for compatibility with old-style definitions *) } type ('a, 'b) enter = { enter : 'r. ('a, 'r) t -> 'b } let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t) let env { env=env } = env let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma let hyps { env=env } = Environ.named_context env let concl { concl=concl } = concl let extra { sigma=sigma; self=self } = goal_extra sigma self let raw_concl { concl=concl } = concl let gmake_with info env sigma goal = { env = Environ.reset_with_named_context (Evd.evar_filtered_hyps info) env ; sigma = sigma ; concl = Evd.evar_concl info ; self = goal } let nf_gmake env sigma goal = let info = Evarutil.nf_evar_info sigma (Evd.find sigma goal) in let sigma = Evd.add sigma goal info in gmake_with info env sigma goal , sigma let nf_enter f = InfoL.tag (Info.Dispatch) begin iter_goal begin fun goal -> Env.get >>= fun env -> tclEVARMAP >>= fun sigma -> try let (gl, sigma) = nf_gmake env sigma goal in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl)) with e when catchable_exception e -> let (e, info) = CErrors.push e in tclZERO ~info e end end let normalize { self } = Env.get >>= fun env -> tclEVARMAP >>= fun sigma -> let (gl,sigma) = nf_gmake env sigma self in tclTHEN (Unsafe.tclEVARS sigma) (tclUNIT gl) let gmake env sigma goal = let info = Evd.find sigma goal in gmake_with info env sigma goal let enter f = let f gl = InfoL.tag (Info.DBranch) (f.enter gl) in InfoL.tag (Info.Dispatch) begin iter_goal begin fun goal -> Env.get >>= fun env -> tclEVARMAP >>= fun sigma -> try f (gmake env sigma goal) with e when catchable_exception e -> let (e, info) = CErrors.push e in tclZERO ~info e end end exception NotExactlyOneSubgoal let _ = CErrors.register_handler begin function | NotExactlyOneSubgoal -> CErrors.errorlabstrm "" (Pp.str"Not exactly one subgoal.") | _ -> raise CErrors.Unhandled end let enter_one f = let open Proof in Comb.get >>= function | [goal] -> begin Env.get >>= fun env -> tclEVARMAP >>= fun sigma -> try f.enter (gmake env sigma goal) with e when catchable_exception e -> let (e, info) = CErrors.push e in tclZERO ~info e end | _ -> tclZERO NotExactlyOneSubgoal type ('a, 'b) s_enter = { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } let s_enter f = InfoL.tag (Info.Dispatch) begin iter_goal begin fun goal -> Env.get >>= fun env -> tclEVARMAP >>= fun sigma -> try let gl = gmake env sigma goal in let Sigma (tac, sigma, _) = f.s_enter gl in let sigma = Sigma.to_evar_map sigma in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) with e when catchable_exception e -> let (e, info) = CErrors.push e in tclZERO ~info e end end let nf_s_enter f = InfoL.tag (Info.Dispatch) begin iter_goal begin fun goal -> Env.get >>= fun env -> tclEVARMAP >>= fun sigma -> try let (gl, sigma) = nf_gmake env sigma goal in let Sigma (tac, sigma, _) = f.s_enter gl in let sigma = Sigma.to_evar_map sigma in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) with e when catchable_exception e -> let (e, info) = CErrors.push e in tclZERO ~info e end end let goals = Pv.get >>= fun step -> let sigma = step.solution in let map goal = match Evarutil.advance sigma goal with | None -> None (** ppedrot: Is this check really necessary? *) | Some goal -> let gl = Env.get >>= fun env -> tclEVARMAP >>= fun sigma -> tclUNIT (gmake env sigma goal) in Some gl in tclUNIT (CList.map_filter map step.comb) let unsolved { self=self } = tclEVARMAP >>= fun sigma -> tclUNIT (not (Option.is_empty (Evarutil.advance sigma self))) (* compatibility *) let goal { self=self } = self let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t) end (** {6 Trace} *) module Trace = struct let record_info_trace = InfoL.record_trace let log m = InfoL.leaf (Info.Msg m) let name_tactic m t = InfoL.tag (Info.Tactic m) t let pr_info ?(lvl=0) info = assert (lvl >= 0); Info.(print (collapse lvl info)) end (** {6 Non-logical state} *) module NonLogical = Logic_monad.NonLogical let tclLIFT = Proof.lift let tclCHECKINTERRUPT = tclLIFT (NonLogical.make Control.check_for_interrupt) (*** Compatibility layer with <= 8.2 tactics ***) module V82 = struct type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma let tactic tac = (* spiwack: we ignore the dependencies between goals here, expectingly preserving the semantics of <= 8.2 tactics *) (* spiwack: convenience notations, waiting for ocaml 3.12 *) let open Proof in Pv.get >>= fun ps -> try let tac gl evd = let glsigma = tac { Evd.it = gl ; sigma = evd; } in let sigma = glsigma.Evd.sigma in let g = glsigma.Evd.it in ( g, sigma ) in (* Old style tactics expect the goals normalized with respect to evars. *) let (initgoals,initevd) = Evd.Monad.List.map (fun g s -> goal_nf_evar s g) ps.comb ps.solution in let (goalss,evd) = Evd.Monad.List.map tac initgoals initevd in let sgs = CList.flatten goalss in let sgs = undefined evd sgs in InfoL.leaf (Info.Tactic (fun () -> Pp.str"")) >> Pv.set { ps with solution = evd; comb = sgs; } with e when catchable_exception e -> let (e, info) = CErrors.push e in tclZERO ~info e (* normalises the evars in the goals, and stores the result in solution. *) let nf_evar_goals = Pv.modify begin fun ps -> let map g s = goal_nf_evar s g in let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in { ps with solution = evd; comb = goals; } end let has_unresolved_evar pv = Evd.has_undefined pv.solution (* Main function in the implementation of Grab Existential Variables.*) let grab pv = let undef = Evd.undefined_map pv.solution in let goals = CList.rev_map fst (Evar.Map.bindings undef) in { pv with comb = goals } (* Returns the open goals of the proofview together with the evar_map to interpret them. *) let goals { comb = comb ; solution = solution; } = { Evd.it = comb ; sigma = solution } let top_goals initial { solution=solution; } = let goals = CList.map (fun (t,_) -> fst (Term.destEvar t)) initial in { Evd.it = goals ; sigma=solution; } let top_evars initial = let evars_of_initial (c,_) = Evar.Set.elements (Evd.evars_of_term c) in CList.flatten (CList.map evars_of_initial initial) let of_tactic t gls = try let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in let (_,final,_,_) = apply (goal_env gls.Evd.sigma gls.Evd.it) t init in { Evd.sigma = final.solution ; it = final.comb } with Logic_monad.TacticFailure e as src -> let (_, info) = CErrors.push src in iraise (e, info) let put_status = Status.put let catchable_exception = catchable_exception let wrap_exceptions f = try f () with e when catchable_exception e -> let (e, info) = CErrors.push e in tclZERO ~info e end (** {7 Notations} *) module Notations = struct let (>>=) = tclBIND let (<*>) = tclTHEN let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) type ('a, 'b) enter = ('a, 'b) Goal.enter = { enter : 'r. ('a, 'r) Goal.t -> 'b } type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } end coq-8.6/engine/geninterp.mli0000644000175000017500000000427413022274260015431 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a typ type _ tag = | Base : 'a typ -> 'a tag | List : 'a tag -> 'a list tag | Opt : 'a tag -> 'a option tag | Pair : 'a tag * 'b tag -> ('a * 'b) tag type t = Dyn : 'a typ * 'a -> t val eq : 'a typ -> 'b typ -> ('a, 'b) CSig.eq option val repr : 'a typ -> string val pr : 'a typ -> Pp.std_ppcmds val typ_list : t list typ val typ_opt : t option typ val typ_pair : (t * t) typ val inject : 'a tag -> 'a -> t end (** Dynamic types for toplevel values. While the generic types permit to relate objects at various levels of interpretation, toplevel values are wearing their own type regardless of where they came from. This allows to use the same runtime representation for several generic types. *) val val_tag : 'a typed_abstract_argument_type -> 'a Val.tag (** Retrieve the dynamic type associated to a toplevel genarg. *) val register_val0 : ('raw, 'glb, 'top) genarg_type -> 'top Val.tag option -> unit (** Register the representation of a generic argument. If no tag is given as argument, a new fresh tag with the same name as the argument is associated to the generic type. *) (** {6 Interpretation functions} *) module TacStore : Store.S type interp_sign = { lfun : Val.t Id.Map.t; extra : TacStore.t } type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t val interp : ('raw, 'glb, 'top) genarg_type -> ('glb, Val.t) interp_fun val register_interp0 : ('raw, 'glb, 'top) genarg_type -> ('glb, Val.t) interp_fun -> unit coq-8.6/engine/termops.mli0000644000175000017500000002561113022274260015125 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* std_ppcmds val pr_sort_family : sorts_family -> std_ppcmds val pr_fix : (constr -> std_ppcmds) -> fixpoint -> std_ppcmds (** debug printer: do not use to display terms to the casual user... *) val set_print_constr : (env -> constr -> std_ppcmds) -> unit val print_constr : constr -> std_ppcmds val print_constr_env : env -> constr -> std_ppcmds val print_named_context : env -> std_ppcmds val pr_rel_decl : env -> Context.Rel.Declaration.t -> std_ppcmds val print_rel_context : env -> std_ppcmds val print_env : env -> std_ppcmds (** about contexts *) val push_rel_assum : Name.t * types -> env -> env val push_rels_assum : (Name.t * types) list -> env -> env val push_named_rec_types : Name.t array * types array * 'a -> env -> env val lookup_rel_id : Id.t -> Context.Rel.t -> int * constr option * types (** Associates the contents of an identifier in a [rel_context]. Raise [Not_found] if there is no such identifier. *) (** Functions that build argument lists matching a block of binders or a context. [rel_vect n m] builds [|Rel (n+m);...;Rel(n+1)|] *) val rel_vect : int -> int -> constr array val rel_list : int -> int -> constr list (** iterators/destructors on terms *) val mkProd_or_LetIn : Context.Rel.Declaration.t -> types -> types val mkProd_wo_LetIn : Context.Rel.Declaration.t -> types -> types val it_mkProd : types -> (Name.t * types) list -> types val it_mkLambda : constr -> (Name.t * types) list -> constr val it_mkProd_or_LetIn : types -> Context.Rel.t -> types val it_mkProd_wo_LetIn : types -> Context.Rel.t -> types val it_mkLambda_or_LetIn : constr -> Context.Rel.t -> constr val it_mkNamedProd_or_LetIn : types -> Context.Named.t -> types val it_mkNamedProd_wo_LetIn : types -> Context.Named.t -> types val it_mkNamedLambda_or_LetIn : constr -> Context.Named.t -> constr (* Ad hoc version reinserting letin, assuming the body is defined in the context where the letins are expanded *) val it_mkLambda_or_LetIn_from_no_LetIn : constr -> Context.Rel.t -> constr (** {6 Generic iterators on constr} *) val map_constr_with_named_binders : (Name.t -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val map_constr_with_binders_left_to_right : (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val map_constr_with_full_binders : (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr (** [fold_constr_with_binders g f n acc c] folds [f n] on the immediate subterms of [c] starting from [acc] and proceeding from left to right according to the usual representation of the constructions as [fold_constr] but it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive *) val fold_constr_with_binders : ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b val fold_constr_with_full_binders : (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b val iter_constr_with_full_binders : (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit (**********************************************************************) val strip_head_cast : constr -> constr val drop_extra_implicit_args : constr -> constr (** occur checks *) exception Occur val occur_meta : types -> bool val occur_existential : types -> bool val occur_meta_or_existential : types -> bool val occur_evar : existential_key -> types -> bool val occur_var : env -> Id.t -> types -> bool val occur_var_in_decl : env -> Id.t -> Context.Named.Declaration.t -> bool (** As {!occur_var} but assume the identifier not to be a section variable *) val local_occur_var : Id.t -> types -> bool val free_rels : constr -> Int.Set.t (** [dependent m t] tests whether [m] is a subterm of [t] *) val dependent : constr -> constr -> bool val dependent_no_evar : constr -> constr -> bool val dependent_univs : constr -> constr -> bool val dependent_univs_no_evar : constr -> constr -> bool val dependent_in_decl : constr -> Context.Named.Declaration.t -> bool val count_occurrences : constr -> constr -> int val collect_metas : constr -> int list val collect_vars : constr -> Id.Set.t (** for visible vars only *) val vars_of_global_reference : env -> Globnames.global_reference -> Id.Set.t val occur_term : constr -> constr -> bool (** Synonymous of dependent Substitution of metavariables *) type meta_value_map = (metavariable * constr) list val subst_meta : meta_value_map -> constr -> constr (** Type assignment for metavariables *) type meta_type_map = (metavariable * types) list (** [pop c] lifts by -1 the positive indexes in [c] *) val pop : constr -> constr (** {6 ... } *) (** Substitution of an arbitrary large term. Uses equality modulo reduction of let *) (** [subst_term_gen eq d c] replaces [d] by [Rel 1] in [c] using [eq] as equality *) val subst_term_gen : (constr -> constr -> bool) -> constr -> constr -> constr (** [replace_term_gen eq d e c] replaces [d] by [e] in [c] using [eq] as equality *) val replace_term_gen : (constr -> constr -> bool) -> constr -> constr -> constr -> constr (** [subst_term d c] replaces [d] by [Rel 1] in [c] *) val subst_term : constr -> constr -> constr (** [replace_term d e c] replaces [d] by [e] in [c] *) val replace_term : constr -> constr -> constr -> constr (** Alternative term equalities *) val base_sort_cmp : Reduction.conv_pb -> sorts -> sorts -> bool val compare_constr_univ : (Reduction.conv_pb -> constr -> constr -> bool) -> Reduction.conv_pb -> constr -> constr -> bool val constr_cmp : Reduction.conv_pb -> constr -> constr -> bool val eq_constr : constr -> constr -> bool (* FIXME rename: erases universes*) val eta_reduce_head : constr -> constr exception CannotFilter (** Lightweight first-order filtering procedure. Unification variables ar represented by (untyped) Evars. [filtering c1 c2] returns the substitution n'th evar -> (context,term), or raises [CannotFilter]. Warning: Outer-kernel sort subtyping are taken into account: c1 has to be smaller than c2 wrt. sorts. *) type subst = (Context.Rel.t * constr) Evar.Map.t val filtering : Context.Rel.t -> Reduction.conv_pb -> constr -> constr -> subst val decompose_prod_letin : constr -> int * Context.Rel.t * constr val align_prod_letin : constr -> constr -> Context.Rel.t * constr (** [nb_lam] {% $ %}[x_1:T_1]...[x_n:T_n]c{% $ %} where {% $ %}c{% $ %} is not an abstraction gives {% $ %}n{% $ %} (casts are ignored) *) val nb_lam : constr -> int (** Similar to [nb_lam], but gives the number of products instead *) val nb_prod : constr -> int (** Similar to [nb_prod], but zeta-contracts let-in on the way *) val nb_prod_modulo_zeta : constr -> int (** Get the last arg of a constr intended to be an application *) val last_arg : constr -> constr (** Force the decomposition of a term as an applicative one *) val decompose_app_vect : constr -> constr * constr array val adjust_app_list_size : constr -> constr list -> constr -> constr list -> (constr * constr list * constr * constr list) val adjust_app_array_size : constr -> constr array -> constr -> constr array -> (constr * constr array * constr * constr array) (** name contexts *) type names_context = Name.t list val add_name : Name.t -> names_context -> names_context val lookup_name_of_rel : int -> names_context -> Name.t val lookup_rel_of_name : Id.t -> names_context -> int val empty_names_context : names_context val ids_of_rel_context : Context.Rel.t -> Id.t list val ids_of_named_context : Context.Named.t -> Id.t list val ids_of_context : env -> Id.t list val names_of_rel_context : env -> names_context (* [context_chop n Γ] returns (Γ₁,Γ₂) such that [Γ]=[Γ₂Γ₁], [Γ₁] has [n] hypotheses, excluding local definitions, and [Γ₁], if not empty, starts with an hypothesis (i.e. [Γ₁] has the form empty or [x:A;Γ₁'] *) val context_chop : int -> Context.Rel.t -> Context.Rel.t * Context.Rel.t (* [env_rel_context_chop n env] extracts out the [n] top declarations of the rel_context part of [env], counting both local definitions and hypotheses *) val env_rel_context_chop : int -> env -> env * Context.Rel.t (** Set of local names *) val vars_of_env: env -> Id.Set.t val add_vname : Id.Set.t -> Name.t -> Id.Set.t (** other signature iterators *) val process_rel_context : (Context.Rel.Declaration.t -> env -> env) -> env -> env val assums_of_rel_context : Context.Rel.t -> (Name.t * constr) list val lift_rel_context : int -> Context.Rel.t -> Context.Rel.t val substl_rel_context : constr list -> Context.Rel.t -> Context.Rel.t val smash_rel_context : Context.Rel.t -> Context.Rel.t (** expand lets in context *) val map_rel_context_in_env : (env -> constr -> constr) -> env -> Context.Rel.t -> Context.Rel.t val map_rel_context_with_binders : (int -> constr -> constr) -> Context.Rel.t -> Context.Rel.t val fold_named_context_both_sides : ('a -> Context.Named.Declaration.t -> Context.Named.Declaration.t list -> 'a) -> Context.Named.t -> init:'a -> 'a val mem_named_context_val : Id.t -> named_context_val -> bool val compact_named_context : Context.Named.t -> Context.NamedList.t val compact_named_context_reverse : Context.Named.t -> Context.NamedList.t val clear_named_body : Id.t -> env -> env val global_vars : env -> constr -> Id.t list val global_vars_set_of_decl : env -> Context.Named.Declaration.t -> Id.Set.t (** Gives an ordered list of hypotheses, closed by dependencies, containing a given set *) val dependency_closure : env -> Context.Named.t -> Id.Set.t -> Id.t list (** Test if an identifier is the basename of a global reference *) val is_section_variable : Id.t -> bool val isGlobalRef : constr -> bool val is_template_polymorphic : env -> constr -> bool (** Combinators on judgments *) val on_judgment : (types -> types) -> unsafe_judgment -> unsafe_judgment val on_judgment_value : (types -> types) -> unsafe_judgment -> unsafe_judgment val on_judgment_type : (types -> types) -> unsafe_judgment -> unsafe_judgment (** {6 Functions to deal with impossible cases } *) val set_impossible_default_clause : (unit -> (constr * types) Univ.in_universe_context_set) -> unit val coq_unit_judge : unit -> unsafe_judgment Univ.in_universe_context_set coq-8.6/engine/sigma.mli0000644000175000017500000000757213022274260014542 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ('b, 'c) le -> ('a, 'c) le (** Transitivity of anteriority *) val (+>) : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le (** Alias for {!cons} *) (** {5 Monotonous evarmaps} *) type 'r t (** Stage-indexed evarmaps. This is just a plain evarmap with a phantom type. *) type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma (** Return values at a later stage *) type 'r evar (** Stage-indexed evars *) (** {5 Constructors} *) val here : 'a -> 'r t -> ('a, 'r) sigma (** [here x s] is a shorthand for [Sigma (x, s, refl)] *) (** {5 Postponing} *) val lift_evar : 'r evar -> ('r, 's) le -> 's evar (** Any evar existing at stage ['r] is also valid at any later stage. *) (** {5 Downcasting} *) val to_evar_map : 'r t -> Evd.evar_map val to_evar : 'r evar -> Evar.t (** {5 Monotonous API} *) type 'r fresh = Fresh : 's evar * 's t * ('r, 's) le -> 'r fresh val new_evar : 'r t -> ?naming:Misctypes.intro_pattern_naming_expr -> Evd.evar_info -> 'r fresh val define : 'r evar -> Constr.t -> 'r t -> (unit, 'r) sigma (** Polymorphic universes *) val new_univ_level_variable : ?loc:Loc.t -> ?name:string -> Evd.rigid -> 'r t -> (Univ.universe_level, 'r) sigma val new_univ_variable : ?loc:Loc.t -> ?name:string -> Evd.rigid -> 'r t -> (Univ.universe, 'r) sigma val new_sort_variable : ?loc:Loc.t -> ?name:string -> Evd.rigid -> 'r t -> (Sorts.t, 'r) sigma val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:Evd.rigid -> Environ.env -> 'r t -> Term.sorts_family -> (Term.sorts, 'r) sigma val fresh_constant_instance : ?loc:Loc.t -> Environ.env -> 'r t -> constant -> (pconstant, 'r) sigma val fresh_inductive_instance : ?loc:Loc.t -> Environ.env -> 'r t -> inductive -> (pinductive, 'r) sigma val fresh_constructor_instance : ?loc:Loc.t -> Environ.env -> 'r t -> constructor -> (pconstructor, 'r) sigma val fresh_global : ?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> 'r t -> Globnames.global_reference -> (constr, 'r) sigma (** FILLME *) (** {5 Run} *) type 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } val run : Evd.evar_map -> 'a run -> 'a * Evd.evar_map (** {5 Imperative monotonic functions} *) type evdref (** Monotonic references over evarmaps *) val apply : evdref -> 'a run -> 'a (** Apply a monotonic function on a reference. *) val purify : (evdref -> 'a) -> 'a run (** Converse of {!apply}. *) (** {5 Unsafe primitives} *) module Unsafe : sig val le : ('a, 'b) le val of_evar_map : Evd.evar_map -> 'r t val of_evar : Evd.evar -> 'r evar val of_ref : Evd.evar_map ref -> evdref val of_pair : ('a * Evd.evar_map) -> ('a, 'r) sigma end (** {5 Notations} *) module Notations : sig type ('a, 'r) sigma_ = ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma_ type 'a run_ = 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } val (+>) : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le (** Alias for {!cons} *) end coq-8.6/engine/namegen.ml0000644000175000017500000003474113022274260014701 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let rec find_prefix = function |MPfile dp1 -> not (DirPath.equal dp1 dp) |MPdot(mp,_) -> find_prefix mp |MPbound(_) -> false in find_prefix (Lib.current_mp ()) | _ -> false let is_imported_ref = function | VarRef _ -> false | IndRef (kn,_) | ConstructRef ((kn,_),_) -> let (mp,_,_) = repr_mind kn in is_imported_modpath mp | ConstRef kn -> let (mp,_,_) = repr_con kn in is_imported_modpath mp let is_global id = try let ref = locate (qualid_of_ident id) in not (is_imported_ref ref) with Not_found -> false let is_constructor id = try match locate (qualid_of_ident id) with | ConstructRef _ -> true | _ -> false with Not_found -> false (**********************************************************************) (* Generating "intuitive" names from its type *) let head_name c = (* Find the head constant of a constr if any *) let rec hdrec c = match kind_of_term c with | Prod (_,_,c) | Lambda (_,_,c) | LetIn (_,_,_,c) | Cast (c,_,_) | App (c,_) -> hdrec c | Proj (kn,_) -> Some (Label.to_id (con_label (Projection.constant kn))) | Const _ | Ind _ | Construct _ | Var _ -> Some (basename_of_global (global_of_constr c)) | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) -> Some (match lna.(i) with Name id -> id | _ -> assert false) | Sort _ | Rel _ | Meta _|Evar _|Case (_, _, _, _) -> None in hdrec c let lowercase_first_char id = (* First character of a constr *) Unicode.lowercase_first_char (Id.to_string id) let sort_hdchar = function | Prop(_) -> "P" | Type(_) -> "T" let hdchar env c = let rec hdrec k c = match kind_of_term c with | Prod (_,_,c) | Lambda (_,_,c) | LetIn (_,_,_,c) -> hdrec (k+1) c | Cast (c,_,_) | App (c,_) -> hdrec k c | Proj (kn,_) -> lowercase_first_char (Label.to_id (con_label (Projection.constant kn))) | Const (kn,_) -> lowercase_first_char (Label.to_id (con_label kn)) | Ind (x,_) -> lowercase_first_char (basename_of_global (IndRef x)) | Construct (x,_) -> lowercase_first_char (basename_of_global (ConstructRef x)) | Var id -> lowercase_first_char id | Sort s -> sort_hdchar s | Rel n -> (if n<=k then "p" (* the initial term is flexible product/function *) else try match Environ.lookup_rel (n-k) env |> to_tuple with | (Name id,_,_) -> lowercase_first_char id | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t) with Not_found -> "y") | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) -> let id = match lna.(i) with Name id -> id | _ -> assert false in lowercase_first_char id | Evar _ (* We could do better... *) | Meta _ | Case (_, _, _, _) -> "y" in hdrec 0 c let id_of_name_using_hdchar env a = function | Anonymous -> Id.of_string (hdchar env a) | Name id -> id let named_hd env a = function | Anonymous -> Name (Id.of_string (hdchar env a)) | x -> x let mkProd_name env (n,a,b) = mkProd (named_hd env a n, a, b) let mkLambda_name env (n,a,b) = mkLambda (named_hd env a n, a, b) let lambda_name = mkLambda_name let prod_name = mkProd_name let prod_create env (a,b) = mkProd (named_hd env a Anonymous, a, b) let lambda_create env (a,b) = mkLambda (named_hd env a Anonymous, a, b) let name_assumption env = function | LocalAssum (na,t) -> LocalAssum (named_hd env t na, t) | LocalDef (na,c,t) -> LocalDef (named_hd env c na, c, t) let name_context env hyps = snd (List.fold_left (fun (env,hyps) d -> let d' = name_assumption env d in (push_rel d' env, d' :: hyps)) (env,[]) (List.rev hyps)) let mkProd_or_LetIn_name env b d = mkProd_or_LetIn (name_assumption env d) b let mkLambda_or_LetIn_name env b d = mkLambda_or_LetIn (name_assumption env d)b let it_mkProd_or_LetIn_name env b hyps = it_mkProd_or_LetIn b (name_context env hyps) let it_mkLambda_or_LetIn_name env b hyps = it_mkLambda_or_LetIn b (name_context env hyps) (**********************************************************************) (* Fresh names *) (* Looks for next "good" name by lifting subscript *) let next_ident_away_from id bad = let rec name_rec id = if bad id then name_rec (lift_subscript id) else id in name_rec id (* Restart subscript from x0 if name starts with xN, or x00 if name starts with x0N, etc *) let restart_subscript id = if not (has_subscript id) then id else (* It would probably be better with something in the spirit of *** make_ident id (Some 0) *** but compatibility would be lost... *) forget_subscript id let rec to_avoid id = function | [] -> false | id' :: avoid -> Id.equal id id' || to_avoid id avoid let visible_ids (nenv, c) = let accu = ref (Refset_env.empty, Int.Set.empty, Id.Set.empty) in let rec visible_ids n c = match kind_of_term c with | Const _ | Ind _ | Construct _ | Var _ -> let (gseen, vseen, ids) = !accu in let g = global_of_constr c in if not (Refset_env.mem g gseen) then begin try let gseen = Refset_env.add g gseen in let short = shortest_qualid_of_global Id.Set.empty g in let dir, id = repr_qualid short in let ids = if DirPath.is_empty dir then Id.Set.add id ids else ids in accu := (gseen, vseen, ids) with Not_found when !Flags.in_debugger || !Flags.in_toplevel -> () end | Rel p -> let (gseen, vseen, ids) = !accu in if p > n && not (Int.Set.mem p vseen) then let vseen = Int.Set.add p vseen in let name = try Some (lookup_name_of_rel (p - n) nenv) with Not_found -> (* Unbound index: may happen in debug and actually also while computing temporary implicit arguments of an inductive type *) None in let ids = match name with | Some (Name id) -> Id.Set.add id ids | _ -> ids in accu := (gseen, vseen, ids) | _ -> Constr.iter_with_binders succ visible_ids n c in let () = visible_ids 1 c in let (_, _, ids) = !accu in ids (* Now, there are different renaming strategies... *) (* 1- Looks for a fresh name for printing in cases pattern *) let next_name_away_in_cases_pattern env_t na avoid = let id = match na with Name id -> id | Anonymous -> default_dependent_ident in let visible = visible_ids env_t in let bad id = to_avoid id avoid || is_constructor id || Id.Set.mem id visible in next_ident_away_from id bad (* 2- Looks for a fresh name for introduction in goal *) (* The legacy strategy for renaming introduction variables is not very uniform: - if the name to use is fresh in the context but used as a global name, then a fresh name is taken by finding a free subscript starting from the current subscript; - but if the name to use is not fresh in the current context, the fresh name is taken by finding a free subscript starting from 0 *) let next_ident_away_in_goal id avoid = let id = if to_avoid id avoid then restart_subscript id else id in let bad id = to_avoid id avoid || (is_global id && not (is_section_variable id)) in next_ident_away_from id bad let next_name_away_in_goal na avoid = let id = match na with | Name id -> id | Anonymous -> default_non_dependent_ident in next_ident_away_in_goal id avoid (* 3- Looks for next fresh name outside a list that is moreover valid as a global identifier; the legacy algorithm is that if the name is already used in the list, one looks for a name of same base with lower available subscript; if the name is not in the list but is used globally, one looks for a name of same base with lower subscript beyond the current subscript *) let next_global_ident_away id avoid = let id = if to_avoid id avoid then restart_subscript id else id in let bad id = to_avoid id avoid || is_global id in next_ident_away_from id bad (* 4- Looks for next fresh name outside a list; if name already used, looks for same name with lower available subscript *) let next_ident_away id avoid = if to_avoid id avoid then next_ident_away_from (restart_subscript id) (fun id -> to_avoid id avoid) else id let next_name_away_with_default default na avoid = let id = match na with Name id -> id | Anonymous -> Id.of_string default in next_ident_away id avoid let reserved_type_name = ref (fun t -> Anonymous) let set_reserved_typed_name f = reserved_type_name := f let next_name_away_with_default_using_types default na avoid t = let id = match na with | Name id -> id | Anonymous -> match !reserved_type_name t with | Name id -> id | Anonymous -> Id.of_string default in next_ident_away id avoid let next_name_away = next_name_away_with_default default_non_dependent_string let make_all_name_different env = let avoid = ref (ids_of_named_context (named_context env)) in process_rel_context (fun decl newenv -> let (na,_,t) = to_tuple decl in let na = named_hd newenv t na in let id = next_name_away na !avoid in avoid := id::!avoid; push_rel (set_name (Name id) decl) newenv) env (* 5- Looks for next fresh name outside a list; avoids also to use names that would clash with short name of global references; if name is already used, looks for name of same base with lower available subscript beyond current subscript *) let next_ident_away_for_default_printing env_t id avoid = let visible = visible_ids env_t in let bad id = to_avoid id avoid || Id.Set.mem id visible in next_ident_away_from id bad let next_name_away_for_default_printing env_t na avoid = let id = match na with | Name id -> id | Anonymous -> (* In principle, an anonymous name is not dependent and will not be *) (* taken into account by the function compute_displayed_name_in; *) (* just in case, invent a valid name *) default_non_dependent_ident in next_ident_away_for_default_printing env_t id avoid (**********************************************************************) (* Displaying terms avoiding bound variables clashes *) (* Renaming strategy introduced in December 1998: - Rule number 1: all names, even if unbound and not displayed, contribute to the list of names to avoid - Rule number 2: only the dependency status is used for deciding if a name is displayed or not Example: bool_ind: "forall (P:bool->Prop)(f:(P true))(f:(P false))(b:bool), P b" is displayed "forall P:bool->Prop, P true -> P false -> forall b:bool, P b" but f and f0 contribute to the list of variables to avoid (knowing that f and f0 are how the f's would be named if introduced, assuming no other f and f0 are already used). *) type renaming_flags = | RenamingForCasesPattern of (Name.t list * constr) | RenamingForGoal | RenamingElsewhereFor of (Name.t list * constr) let next_name_for_display flags = match flags with | RenamingForCasesPattern env_t -> next_name_away_in_cases_pattern env_t | RenamingForGoal -> next_name_away_in_goal | RenamingElsewhereFor env_t -> next_name_away_for_default_printing env_t (* Remark: Anonymous var may be dependent in Evar's contexts *) let compute_displayed_name_in flags avoid na c = match na with | Anonymous when noccurn 1 c -> (Anonymous,avoid) | _ -> let fresh_id = next_name_for_display flags na avoid in let idopt = if noccurn 1 c then Anonymous else Name fresh_id in (idopt, fresh_id::avoid) let compute_and_force_displayed_name_in flags avoid na c = match na with | Anonymous when noccurn 1 c -> (Anonymous,avoid) | _ -> let fresh_id = next_name_for_display flags na avoid in (Name fresh_id, fresh_id::avoid) let compute_displayed_let_name_in flags avoid na c = let fresh_id = next_name_for_display flags na avoid in (Name fresh_id, fresh_id::avoid) let rename_bound_vars_as_displayed avoid env c = let rec rename avoid env c = match kind_of_term c with | Prod (na,c1,c2) -> let na',avoid' = compute_displayed_name_in (RenamingElsewhereFor (env,c2)) avoid na c2 in mkProd (na', c1, rename avoid' (add_name na' env) c2) | LetIn (na,c1,t,c2) -> let na',avoid' = compute_displayed_let_name_in (RenamingElsewhereFor (env,c2)) avoid na c2 in mkLetIn (na',c1,t, rename avoid' (add_name na' env) c2) | Cast (c,k,t) -> mkCast (rename avoid env c, k,t) | _ -> c in rename avoid env c (**********************************************************************) (* "H"-based naming strategy introduced June 2014 for hypotheses in Prop produced by case/elim/destruct/induction, in place of the strategy that was using the first letter of the type, leading to inelegant "n:~A", "e:t=u", etc. when eliminating sumbool or similar types *) let h_based_elimination_names = ref false let use_h_based_elimination_names () = !h_based_elimination_names && Flags.version_strictly_greater Flags.V8_4 open Goptions let _ = declare_bool_option { optsync = true; optdepr = false; optname = "use of \"H\"-based proposition names in elimination tactics"; optkey = ["Standard";"Proposition";"Elimination";"Names"]; optread = (fun () -> !h_based_elimination_names); optwrite = (:=) h_based_elimination_names } coq-8.6/engine/uState.ml0000644000175000017500000004507413022274260014535 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* match l, r with | Some _, _ -> l | _, _ -> r) s t end type uinfo = { uname : string option; uloc : Loc.t option; } (* 2nd part used to check consistency on the fly. *) type t = { uctx_names : Univ.Level.t UNameMap.t * uinfo Univ.LMap.t; uctx_local : Univ.universe_context_set; (** The local context of variables *) uctx_univ_variables : Universes.universe_opt_subst; (** The local universes that are unification variables *) uctx_univ_algebraic : Univ.universe_set; (** The subset of unification variables that can be instantiated with algebraic universes as they appear in inferred types only. *) uctx_universes : UGraph.t; (** The current graph extended with the local constraints *) uctx_initial_universes : UGraph.t; (** The graph at the creation of the evar_map *) } let empty = { uctx_names = UNameMap.empty, Univ.LMap.empty; uctx_local = Univ.ContextSet.empty; uctx_univ_variables = Univ.LMap.empty; uctx_univ_algebraic = Univ.LSet.empty; uctx_universes = UGraph.initial_universes; uctx_initial_universes = UGraph.initial_universes; } let make u = { empty with uctx_universes = u; uctx_initial_universes = u} let is_empty ctx = Univ.ContextSet.is_empty ctx.uctx_local && Univ.LMap.is_empty ctx.uctx_univ_variables let union ctx ctx' = if ctx == ctx' then ctx else if is_empty ctx' then ctx else let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local) (Univ.ContextSet.levels ctx.uctx_local) in let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in let declarenew g = Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) newus g in let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); uctx_local = local; uctx_univ_variables = Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; uctx_univ_algebraic = Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; uctx_initial_universes = declarenew ctx.uctx_initial_universes; uctx_universes = if local == ctx.uctx_local then ctx.uctx_universes else let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in UGraph.merge_constraints cstrsr (declarenew ctx.uctx_universes) } let context_set ctx = ctx.uctx_local let constraints ctx = snd ctx.uctx_local let context ctx = Univ.ContextSet.to_context ctx.uctx_local let of_context_set ctx = { empty with uctx_local = ctx } let subst ctx = ctx.uctx_univ_variables let ugraph ctx = ctx.uctx_universes let algebraics ctx = ctx.uctx_univ_algebraic let constrain_variables diff ctx = Univ.LSet.fold (fun l cstrs -> try match Univ.LMap.find l ctx.uctx_univ_variables with | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs | None -> cstrs with Not_found | Option.IsNone -> cstrs) diff Univ.Constraint.empty let add_uctx_names ?loc s l (names, names_rev) = (UNameMap.add s l names, Univ.LMap.add l { uname = Some s; uloc = loc } names_rev) let add_uctx_loc l loc (names, names_rev) = match loc with | None -> (names, names_rev) | Some _ -> (names, Univ.LMap.add l { uname = None; uloc = loc } names_rev) let of_binders b = let ctx = empty in let names = List.fold_left (fun acc (id, l) -> add_uctx_names (Id.to_string id) l acc) ctx.uctx_names b in { ctx with uctx_names = names } let instantiate_variable l b v = try v := Univ.LMap.update l (Some b) !v with Not_found -> assert false exception UniversesDiffer let process_universe_constraints ctx cstrs = let univs = ctx.uctx_universes in let vars = ref ctx.uctx_univ_variables in let normalize = Universes.normalize_universe_opt_subst vars in let rec unify_universes fo l d r local = let l = normalize l and r = normalize r in if Univ.Universe.equal l r then local else let varinfo x = match Univ.Universe.level x with | None -> Inl x | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l ctx.uctx_univ_algebraic) in if d == Universes.ULe then if UGraph.check_leq univs l r then (** Keep Prop/Set <= var around if var might be instantiated by prop or set later. *) if Univ.Universe.is_level l then match Univ.Universe.level r with | Some r -> Univ.Constraint.add (Option.get (Univ.Universe.level l),Univ.Le,r) local | _ -> local else local else match Univ.Universe.level r with | None -> error ("Algebraic universe on the right") | Some rl -> if Univ.Level.is_small rl then let levels = Univ.Universe.levels l in Univ.LSet.fold (fun l local -> if Univ.Level.is_small l || Univ.LMap.mem l !vars then unify_universes fo (Univ.Universe.make l) Universes.UEq r local else raise (Univ.UniverseInconsistency (Univ.Le, Univ.Universe.make l, r, None))) levels local else Univ.enforce_leq l r local else if d == Universes.ULub then match varinfo l, varinfo r with | (Inr (l, true, _), Inr (r, _, _)) | (Inr (r, _, _), Inr (l, true, _)) -> instantiate_variable l (Univ.Universe.make r) vars; Univ.enforce_eq_level l r local | Inr (_, _, _), Inr (_, _, _) -> unify_universes true l Universes.UEq r local | _, _ -> assert false else (* d = Universes.UEq *) match varinfo l, varinfo r with | Inr (l', lloc, _), Inr (r', rloc, _) -> let () = if lloc then instantiate_variable l' r vars else if rloc then instantiate_variable r' l vars else if not (UGraph.check_eq univs l r) then (* Two rigid/global levels, none of them being local, one of them being Prop/Set, disallow *) if Univ.Level.is_small l' || Univ.Level.is_small r' then raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) else if fo then raise UniversesDiffer in Univ.enforce_eq_level l' r' local | Inr (l, loc, alg), Inl r | Inl r, Inr (l, loc, alg) -> let inst = Univ.univ_level_rem l r r in if alg then (instantiate_variable l inst vars; local) else let lu = Univ.Universe.make l in if Univ.univ_level_mem l r then Univ.enforce_leq inst lu local else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None)) | _, _ (* One of the two is algebraic or global *) -> if UGraph.check_eq univs l r then local else raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) in let local = Universes.Constraints.fold (fun (l,d,r) local -> unify_universes false l d r local) cstrs Univ.Constraint.empty in !vars, local let add_constraints ctx cstrs = let univs, local = ctx.uctx_local in let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc -> let l = Univ.Universe.make l and r = Univ.Universe.make r in let cstr' = if d == Univ.Lt then (Univ.Universe.super l, Universes.ULe, r) else (l, (if d == Univ.Le then Universes.ULe else Universes.UEq), r) in Universes.Constraints.add cstr' acc) cstrs Universes.Constraints.empty in let vars, local' = process_universe_constraints ctx cstrs' in { ctx with uctx_local = (univs, Univ.Constraint.union local local'); uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } (* let addconstrkey = Profile.declare_profile "add_constraints_context";; *) (* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *) let add_universe_constraints ctx cstrs = let univs, local = ctx.uctx_local in let vars, local' = process_universe_constraints ctx cstrs in { ctx with uctx_local = (univs, Univ.Constraint.union local local'); uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } let pr_uctx_level uctx = let map, map_rev = uctx.uctx_names in fun l -> try str (Option.get (Univ.LMap.find l map_rev).uname) with Not_found | Option.IsNone -> Universes.pr_with_global_universes l let universe_context ?names ctx = match names with | None -> [], Univ.ContextSet.to_context ctx.uctx_local | Some pl -> let levels = Univ.ContextSet.levels ctx.uctx_local in let newinst, map, left = List.fold_right (fun (loc,id) (newinst, map, acc) -> let l = try UNameMap.find (Id.to_string id) (fst ctx.uctx_names) with Not_found -> user_err_loc (loc, "universe_context", str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc)) pl ([], [], levels) in if not (Univ.LSet.is_empty left) then let n = Univ.LSet.cardinal left in let loc = try let info = Univ.LMap.find (Univ.LSet.choose left) (snd ctx.uctx_names) in Option.default Loc.ghost info.uloc with Not_found -> Loc.ghost in user_err_loc (loc, "universe_context", (str(CString.plural n "Universe") ++ spc () ++ Univ.LSet.pr (pr_uctx_level ctx) left ++ spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.")) else let inst = Univ.Instance.of_array (Array.of_list newinst) in let ctx = Univ.UContext.make (inst, Univ.ContextSet.constraints ctx.uctx_local) in map, ctx let restrict ctx vars = let uctx' = Universes.restrict_universe_context ctx.uctx_local vars in { ctx with uctx_local = uctx' } type rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) let univ_rigid = UnivRigid let univ_flexible = UnivFlexible false let univ_flexible_alg = UnivFlexible true let merge ?loc sideff rigid uctx ctx' = let open Univ in let levels = ContextSet.levels ctx' in let uctx = if sideff then uctx else match rigid with | UnivRigid -> uctx | UnivFlexible b -> let fold u accu = if LMap.mem u accu then accu else LMap.add u None accu in let uvars' = LSet.fold fold levels uctx.uctx_univ_variables in if b then { uctx with uctx_univ_variables = uvars'; uctx_univ_algebraic = LSet.union uctx.uctx_univ_algebraic levels } else { uctx with uctx_univ_variables = uvars' } in let uctx_local = if sideff then uctx.uctx_local else ContextSet.append ctx' uctx.uctx_local in let declare g = LSet.fold (fun u g -> try UGraph.add_universe u false g with UGraph.AlreadyDeclared when sideff -> g) levels g in let uctx_names = let fold u accu = let modify _ info = match info.uloc with | None -> { info with uloc = loc } | Some _ -> info in try LMap.modify u modify accu with Not_found -> LMap.add u { uname = None; uloc = loc } accu in (fst uctx.uctx_names, LSet.fold fold levels (snd uctx.uctx_names)) in let initial = declare uctx.uctx_initial_universes in let univs = declare uctx.uctx_universes in let uctx_universes = UGraph.merge_constraints (ContextSet.constraints ctx') univs in { uctx with uctx_names; uctx_local; uctx_universes; uctx_initial_universes = initial } let merge_subst uctx s = { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s } let emit_side_effects eff u = let uctxs = Safe_typing.universes_of_private eff in List.fold_left (merge true univ_rigid) u uctxs let new_univ_variable ?loc rigid name ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = let u = Universes.new_univ_level (Global.current_dirpath ()) in let ctx' = Univ.ContextSet.add_universe u ctx in let uctx', pred = match rigid with | UnivRigid -> uctx, true | UnivFlexible b -> let uvars' = Univ.LMap.add u None uvars in if b then {uctx with uctx_univ_variables = uvars'; uctx_univ_algebraic = Univ.LSet.add u avars}, false else {uctx with uctx_univ_variables = uvars'}, false in let names = match name with | Some n -> add_uctx_names ?loc n u uctx.uctx_names | None -> add_uctx_loc u loc uctx.uctx_names in let initial = UGraph.add_universe u false uctx.uctx_initial_universes in let uctx' = {uctx' with uctx_names = names; uctx_local = ctx'; uctx_universes = UGraph.add_universe u false uctx.uctx_universes; uctx_initial_universes = initial} in uctx', u let add_global_univ uctx u = let initial = UGraph.add_universe u true uctx.uctx_initial_universes in let univs = UGraph.add_universe u true uctx.uctx_universes in { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local; uctx_initial_universes = initial; uctx_universes = univs } let make_flexible_variable ctx b u = let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} = ctx in let uvars' = Univ.LMap.add u None uvars in let avars' = if b then let uu = Univ.Universe.make u in let substu_not_alg u' v = Option.cata (fun vu -> Univ.Universe.equal uu vu && not (Univ.LSet.mem u' avars)) false v in if not (Univ.LMap.exists substu_not_alg uvars) then Univ.LSet.add u avars else avars else avars in {ctx with uctx_univ_variables = uvars'; uctx_univ_algebraic = avars'} let is_sort_variable uctx s = match s with | Sorts.Type u -> (match Univ.universe_level u with | Some l as x -> if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then x else None | None -> None) | _ -> None let subst_univs_context_with_def def usubst (ctx, cst) = (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst) let normalize_variables uctx = let normalized_variables, undef, def, subst = Universes.normalize_univ_variables uctx.uctx_univ_variables in let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in let ctx_local', univs = Universes.refresh_constraints uctx.uctx_initial_universes ctx_local in subst, { uctx with uctx_local = ctx_local'; uctx_univ_variables = normalized_variables; uctx_universes = univs } let abstract_undefined_variables uctx = let vars' = Univ.LMap.fold (fun u v acc -> if v == None then Univ.LSet.remove u acc else acc) uctx.uctx_univ_variables uctx.uctx_univ_algebraic in { uctx with uctx_local = Univ.ContextSet.empty; uctx_univ_algebraic = vars' } let fix_undefined_variables uctx = let algs', vars' = Univ.LMap.fold (fun u v (algs, vars as acc) -> if v == None then (Univ.LSet.remove u algs, Univ.LMap.remove u vars) else acc) uctx.uctx_univ_variables (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables) in { uctx with uctx_univ_variables = vars'; uctx_univ_algebraic = algs' } let refresh_undefined_univ_variables uctx = let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (Univ.subst_univs_level_level subst u) acc) uctx.uctx_univ_algebraic Univ.LSet.empty in let vars = Univ.LMap.fold (fun u v acc -> Univ.LMap.add (Univ.subst_univs_level_level subst u) (Option.map (Univ.subst_univs_level_universe subst) v) acc) uctx.uctx_univ_variables Univ.LMap.empty in let declare g = Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) (Univ.ContextSet.levels ctx') g in let initial = declare uctx.uctx_initial_universes in let univs = declare UGraph.initial_universes in let uctx' = {uctx_names = uctx.uctx_names; uctx_local = ctx'; uctx_univ_variables = vars; uctx_univ_algebraic = alg; uctx_universes = univs; uctx_initial_universes = initial } in uctx', subst let normalize uctx = let ((vars',algs'), us') = Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables uctx.uctx_univ_algebraic in if Univ.ContextSet.equal us' uctx.uctx_local then uctx else let us', universes = Universes.refresh_constraints uctx.uctx_initial_universes us' in { uctx_names = uctx.uctx_names; uctx_local = us'; uctx_univ_variables = vars'; uctx_univ_algebraic = algs'; uctx_universes = universes; uctx_initial_universes = uctx.uctx_initial_universes } let universe_of_name uctx s = UNameMap.find s (fst uctx.uctx_names) let add_universe_name uctx s l = let names' = add_uctx_names s l uctx.uctx_names in { uctx with uctx_names = names' } let update_sigma_env uctx env = let univs = Environ.universes env in let eunivs = { uctx with uctx_initial_universes = univs; uctx_universes = univs } in merge true univ_rigid eunivs eunivs.uctx_local coq-8.6/engine/proofview_monad.ml0000644000175000017500000002056013022274260016457 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* { head = a::head ; opened=[] } | a::Seq(b,f)::opened -> { head ; opened=Seq(b,a::f)::opened } | [] -> assert false let leaf a s = close (opn a s) (** Returning a forest. It is the responsibility of the library builder to close all the tags. *) (* spiwack: I may want to close the tags instead, to deal with interruptions. *) let rec mirror f = List.rev_map mirror_tree f and mirror_tree (Seq(a,f)) = Seq(a,mirror f) let to_tree = function | { head ; opened=[] } -> mirror head | { head ; opened=_::_} -> assert false end (** {6 State types} *) (** We typically label nodes of [Trace.tree] with messages to print. But we don't want to compute the result. *) type lazy_msg = unit -> Pp.std_ppcmds let pr_lazy_msg msg = msg () (** Info trace. *) module Info = struct (** The type of the tags for [info]. *) type tag = | Msg of lazy_msg (** A simple message *) | Tactic of lazy_msg (** A tactic call *) | Dispatch (** A call to [tclDISPATCH]/[tclEXTEND] *) | DBranch (** A special marker to delimit individual branch of a dispatch. *) type state = tag Trace.incr type tree = tag Trace.forest let pr_in_comments m = Pp.(str"(* "++pr_lazy_msg m++str" *)") let unbranch = function | Trace.Seq (DBranch,brs) -> brs | _ -> assert false let is_empty_branch = let open Trace in function | Seq(DBranch,[]) -> true | _ -> false (** Dispatch with empty branches are (supposed to be) equivalent to [idtac] which need not appear, so they are removed from the trace. *) let dispatch brs = let open Trace in if CList.for_all is_empty_branch brs then None else Some (Seq(Dispatch,brs)) let constr = let open Trace in function | Dispatch -> dispatch | t -> fun br -> Some (Seq(t,br)) let rec compress_tree = let open Trace in function | Seq(t,f) -> constr t (compress f) and compress f = CList.map_filter compress_tree f (** [with_sep] is [true] when [Tactic m] must be printed with a trailing semi-colon. *) let rec pr_tree with_sep = let open Trace in function | Seq (Msg m,[]) -> pr_in_comments m | Seq (Tactic m,_) -> let tail = if with_sep then Pp.str";" else Pp.mt () in Pp.(pr_lazy_msg m ++ tail) | Seq (Dispatch,brs) -> let tail = if with_sep then Pp.str";" else Pp.mt () in Pp.(pr_dispatch brs++tail) | Seq (Msg _,_::_) | Seq (DBranch,_) -> assert false and pr_dispatch brs = let open Pp in let brs = List.map unbranch brs in match brs with | [br] -> pr_forest br | _ -> let sep () = spc()++str"|"++spc() in let branches = prlist_with_sep sep pr_forest brs in str"[>"++spc()++branches++spc()++str"]" and pr_forest = function | [] -> Pp.mt () | [tr] -> pr_tree false tr | tr::l -> Pp.(pr_tree true tr ++ pr_forest l) let print f = pr_forest (compress f) let rec collapse_tree n t = let open Trace in match n , t with | 0 , t -> [t] | _ , (Seq(Tactic _,[]) as t) -> [t] | n , Seq(Tactic _,f) -> collapse (pred n) f | n , Seq(Dispatch,brs) -> [Seq(Dispatch, (collapse n brs))] | n , Seq(DBranch,br) -> [Seq(DBranch, (collapse n br))] | _ , (Seq(Msg _,_) as t) -> [t] and collapse n f = CList.map_append (collapse_tree n) f end (** Type of proof views: current [evar_map] together with the list of focused goals. *) type proofview = { solution : Evd.evar_map; comb : Evar.t list; shelf : Evar.t list; } (** {6 Instantiation of the logic monad} *) (** Parameters of the logic monads *) module P = struct type s = proofview * Environ.env (** Recording info trace (true) or not. *) type e = bool (** Status (safe/unsafe) * shelved goals * given up *) type w = bool * Evar.t list let wunit = true , [] let wprod (b1, g1) (b2, g2) = b1 && b2 , g1@g2 type u = Info.state let uunit = Trace.empty_incr end module Logical = Logic_monad.Logical(P) (** {6 Lenses to access to components of the states} *) module type State = sig type t val get : t Logical.t val set : t -> unit Logical.t val modify : (t->t) -> unit Logical.t end module type Writer = sig type t val put : t -> unit Logical.t end module Pv : State with type t := proofview = struct let get = Logical.(map fst get) let set p = Logical.modify (fun (_,e) -> (p,e)) let modify f= Logical.modify (fun (p,e) -> (f p,e)) end module Solution : State with type t := Evd.evar_map = struct let get = Logical.map (fun {solution} -> solution) Pv.get let set s = Pv.modify (fun pv -> { pv with solution = s }) let modify f = Pv.modify (fun pv -> { pv with solution = f pv.solution }) end module Comb : State with type t = Evar.t list = struct (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *) type t = Evar.t list let get = Logical.map (fun {comb} -> comb) Pv.get let set c = Pv.modify (fun pv -> { pv with comb = c }) let modify f = Pv.modify (fun pv -> { pv with comb = f pv.comb }) end module Env : State with type t := Environ.env = struct let get = Logical.(map snd get) let set e = Logical.modify (fun (p,_) -> (p,e)) let modify f = Logical.modify (fun (p,e) -> (p,f e)) end module Status : Writer with type t := bool = struct let put s = Logical.put (s, []) end module Shelf : State with type t = Evar.t list = struct (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *) type t = Evar.t list let get = Logical.map (fun {shelf} -> shelf) Pv.get let set c = Pv.modify (fun pv -> { pv with shelf = c }) let modify f = Pv.modify (fun pv -> { pv with shelf = f pv.shelf }) end module Giveup : Writer with type t = Evar.t list = struct (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *) type t = Evar.t list let put gs = Logical.put (true, gs) end (** Lens and utilies pertaining to the info trace *) module InfoL = struct let recording = Logical.current let if_recording t = let open Logical in recording >>= fun r -> if r then t else return () let record_trace t = Logical.local true t let raw_update = Logical.update let update f = if_recording (raw_update f) let opn a = update (Trace.opn a) let close = update Trace.close let leaf a = update (Trace.leaf a) let tag a t = let open Logical in recording >>= fun r -> if r then begin raw_update (Trace.opn a) >> t >>= fun a -> raw_update Trace.close >> return a end else t end coq-8.6/engine/engine.mllib0000644000175000017500000000014213022274260015207 0ustar mdenesmdenesLogic_monad Termops Namegen UState Evd Sigma Proofview_monad Evarutil Proofview Ftactic Geninterp coq-8.6/engine/evarutil.ml0000644000175000017500000007176013022274260015124 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* None let safe_evar_value sigma ev = try Some (Evd.existential_value sigma ev) with NotInstantiatedEvar | Not_found -> None (** Combinators *) let evd_comb0 f evdref = let (evd',x) = f !evdref in evdref := evd'; x let evd_comb1 f evdref x = let (evd',y) = f !evdref x in evdref := evd'; y let evd_comb2 f evdref x y = let (evd',z) = f !evdref x y in evdref := evd'; z let e_new_global evdref x = evd_comb1 (Evd.fresh_global (Global.env())) evdref x let new_global evd x = Sigma.fresh_global (Global.env()) evd x (****************************************************) (* Expanding/testing/exposing existential variables *) (****************************************************) (* flush_and_check_evars fails if an existential is undefined *) exception Uninstantiated_evar of existential_key let rec flush_and_check_evars sigma c = match kind_of_term c with | Evar (evk,_ as ev) -> (match existential_opt_value sigma ev with | None -> raise (Uninstantiated_evar evk) | Some c -> flush_and_check_evars sigma c) | _ -> map_constr (flush_and_check_evars sigma) c (* let nf_evar_key = Profile.declare_profile "nf_evar" *) (* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *) let rec whd_evar sigma c = match kind_of_term c with | Evar (evk, args) -> begin match safe_evar_info sigma evk with | Some ({ evar_body = Evar_defined c } as info) -> let args = Array.map (fun c -> whd_evar sigma c) args in let c = instantiate_evar_array info c args in whd_evar sigma c | _ -> c end | Sort (Type u) -> let u' = Evd.normalize_universe sigma u in if u' == u then c else mkSort (Sorts.sort_of_univ u') | Const (c', u) when not (Univ.Instance.is_empty u) -> let u' = Evd.normalize_universe_instance sigma u in if u' == u then c else mkConstU (c', u') | Ind (i, u) when not (Univ.Instance.is_empty u) -> let u' = Evd.normalize_universe_instance sigma u in if u' == u then c else mkIndU (i, u') | Construct (co, u) when not (Univ.Instance.is_empty u) -> let u' = Evd.normalize_universe_instance sigma u in if u' == u then c else mkConstructU (co, u') | _ -> c let rec nf_evar sigma t = Constr.map (fun t -> nf_evar sigma t) (whd_evar sigma t) let j_nf_evar sigma j = { uj_val = nf_evar sigma j.uj_val; uj_type = nf_evar sigma j.uj_type } let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl let jv_nf_evar sigma = Array.map (j_nf_evar sigma) let tj_nf_evar sigma {utj_val=v;utj_type=t} = {utj_val=nf_evar sigma v;utj_type=t} let nf_evars_universes evm = Universes.nf_evars_and_universes_opt_subst (safe_evar_value evm) (Evd.universe_subst evm) let nf_evars_and_universes evm = let evm = Evd.nf_constraints evm in evm, nf_evars_universes evm let e_nf_evars_and_universes evdref = evdref := Evd.nf_constraints !evdref; nf_evars_universes !evdref, Evd.universe_subst !evdref let nf_evar_map_universes evm = let evm = Evd.nf_constraints evm in let subst = Evd.universe_subst evm in if Univ.LMap.is_empty subst then evm, nf_evar evm else let f = nf_evars_universes evm in Evd.raw_map (fun _ -> map_evar_info f) evm, f let nf_named_context_evar sigma ctx = Context.Named.map (nf_evar sigma) ctx let nf_rel_context_evar sigma ctx = Context.Rel.map (nf_evar sigma) ctx let nf_env_evar sigma env = let nc' = nf_named_context_evar sigma (Environ.named_context env) in let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env) let nf_evar_info evc info = map_evar_info (nf_evar evc) info let nf_evar_map evm = Evd.raw_map (fun _ evi -> nf_evar_info evm evi) evm let nf_evar_map_undefined evm = Evd.raw_map_undefined (fun _ evi -> nf_evar_info evm evi) evm (*-------------------*) (* Auxiliary functions for the conversion algorithms modulo evars *) (* A probably faster though more approximative variant of [has_undefined (nf_evar c)]: instances are not substituted and maybe an evar occurs in an instance and it would disappear by instantiation *) let has_undefined_evars evd t = let rec has_ev t = match kind_of_term t with | Evar (ev,args) -> (match evar_body (Evd.find evd ev) with | Evar_defined c -> has_ev c; Array.iter has_ev args | Evar_empty -> raise NotInstantiatedEvar) | _ -> iter_constr has_ev t in try let _ = has_ev t in false with (Not_found | NotInstantiatedEvar) -> true let is_ground_term evd t = not (has_undefined_evars evd t) let is_ground_env evd env = let open Context.Rel.Declaration in let is_ground_rel_decl = function | LocalDef (_,b,_) -> is_ground_term evd b | _ -> true in let open Context.Named.Declaration in let is_ground_named_decl = function | LocalDef (_,b,_) -> is_ground_term evd b | _ -> true in List.for_all is_ground_rel_decl (rel_context env) && List.for_all is_ground_named_decl (named_context env) (* Memoization is safe since evar_map and environ are applicative structures *) let memo f = let m = ref None in fun x y -> match !m with | Some (x', y', r) when x == x' && y == y' -> r | _ -> let r = f x y in m := Some (x, y, r); r let is_ground_env = memo is_ground_env (* Return the head evar if any *) exception NoHeadEvar let head_evar = let rec hrec c = match kind_of_term c with | Evar (evk,_) -> evk | Case (_,_,c,_) -> hrec c | App (c,_) -> hrec c | Cast (c,_,_) -> hrec c | Proj (p, c) -> hrec c | _ -> raise NoHeadEvar in hrec (* Expand head evar if any (currently consider only applications but I guess it should consider Case too) *) let whd_head_evar_stack sigma c = let rec whrec (c, l as s) = match kind_of_term c with | Evar (evk,args as ev) -> let v = try Some (existential_value sigma ev) with NotInstantiatedEvar | Not_found -> None in begin match v with | None -> s | Some c -> whrec (c, l) end | Cast (c,_,_) -> whrec (c, l) | App (f,args) -> whrec (f, args :: l) | _ -> s in whrec (c, []) let whd_head_evar sigma c = let (f, args) = whd_head_evar_stack sigma c in (** optim: don't reallocate if empty/singleton *) match args with | [] -> f | [arg] -> mkApp (f, arg) | _ -> mkApp (f, Array.concat args) (**********************) (* Creating new metas *) (**********************) let meta_counter_summary_name = "meta counter" (* Generator of metavariables *) let new_meta = let meta_ctr = Summary.ref 0 ~name:meta_counter_summary_name in fun () -> incr meta_ctr; !meta_ctr let mk_new_meta () = mkMeta(new_meta()) (* The list of non-instantiated existential declarations (order is important) *) let non_instantiated sigma = let listev = Evd.undefined_map sigma in Evar.Map.smartmap (fun evi -> nf_evar_info sigma evi) listev (************************) (* Manipulating filters *) (************************) let make_pure_subst evi args = let open Context.Named.Declaration in snd (List.fold_right (fun decl (args,l) -> match args with | a::rest -> (rest, (get_id decl, a)::l) | _ -> anomaly (Pp.str "Instance does not match its signature")) (evar_filtered_context evi) (Array.rev_to_list args,[])) (*------------------------------------* * functional operations on evar sets * *------------------------------------*) (* [push_rel_context_to_named_context] builds the defining context and the * initial instance of an evar. If the evar is to be used in context * * Gamma = a1 ... an xp ... x1 * \- named part -/ \- de Bruijn part -/ * * then the x1...xp are turned into variables so that the evar is declared in * context * * a1 ... an xp ... x1 * \----------- named part ------------/ * * but used applied to the initial instance "a1 ... an Rel(p) ... Rel(1)" * so that ev[a1:=a1 ... an:=an xp:=Rel(p) ... x1:=Rel(1)] is correctly typed * in context Gamma. * * Remark 1: The instance is reverted in practice (i.e. Rel(1) comes first) * Remark 2: If some of the ai or xj are definitions, we keep them in the * instance. This is necessary so that no unfolding of local definitions * happens when inferring implicit arguments (consider e.g. the problem * "x:nat; x':=x; f:forall y, y=y -> Prop |- f _ (refl_equal x')" which * produces the equation "?y[x,x']=?y[x,x']" =? "x'=x'": we want * the hole to be instantiated by x', not by x (which would have been * the case in [invert_definition] if x' had disappeared from the instance). * Note that at any time, if, in some context env, the instance of * declaration x:A is t and the instance of definition x':=phi(x) is u, then * we have the property that u and phi(t) are convertible in env. *) let csubst_subst (k, s) c = let rec subst n c = match Constr.kind c with | Rel m -> if m <= n then c else if m - n <= k then Int.Map.find (k - m + n) s else mkRel (m - k) | _ -> Constr.map_with_binders succ subst n c in if k = 0 then c else subst 0 c let subst2 subst vsubst c = csubst_subst subst (replace_vars vsubst c) let next_ident_away id avoid = let avoid id = Id.Set.mem id avoid in next_ident_away_from id avoid let next_name_away na avoid = let avoid id = Id.Set.mem id avoid in let id = match na with Name id -> id | Anonymous -> default_non_dependent_ident in next_ident_away_from id avoid type csubst = int * Constr.t Int.Map.t let empty_csubst = (0, Int.Map.empty) type ext_named_context = csubst * (Id.t * Constr.constr) list * Id.Set.t * Context.Named.t let push_var id (n, s) = let s = Int.Map.add n (mkVar id) s in (succ n, s) let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) = let open Context.Named.Declaration in let replace_var_named_declaration id0 id decl = let id' = get_id decl in let id' = if Id.equal id0 id' then id else id' in let vsubst = [id0 , mkVar id] in decl |> set_id id' |> map_constr (replace_vars vsubst) in let extract_if_neq id = function | Anonymous -> None | Name id' when id_ord id id' = 0 -> None | Name id' -> Some id' in let open Context.Rel.Declaration in let (na, c, t) = to_tuple decl in let open Context.Named.Declaration in let id = (* ppedrot: we want to infer nicer names for the refine tactic, but keeping at the same time backward compatibility in other code using this function. For now, we only attempt to preserve the old behaviour of Program, but ultimately, one should do something about this whole name generation problem. *) if Flags.is_program_mode () then next_name_away na avoid else (** id_of_name_using_hdchar only depends on the rel context which is empty here *) next_ident_away (id_of_name_using_hdchar empty_env t na) avoid in match extract_if_neq id na with | Some id0 when not (is_section_variable id0) -> (* spiwack: if [id<>id0], rather than introducing a new binding named [id], we will keep [id0] (the name given by the user) and rename [id0] into [id] in the named context. Unless [id] is a section variable. *) let subst = (fst subst, Int.Map.map (replace_vars [id0,mkVar id]) (snd subst)) in let vsubst = (id0,mkVar id)::vsubst in let d = match c with | None -> LocalAssum (id0, subst2 subst vsubst t) | Some c -> LocalDef (id0, subst2 subst vsubst c, subst2 subst vsubst t) in let nc = List.map (replace_var_named_declaration id0 id) nc in (push_var id0 subst, vsubst, Id.Set.add id avoid, d :: nc) | _ -> (* spiwack: if [id0] is a section variable renaming it is incorrect. We revert to a less robust behaviour where the new binder has name [id]. Which amounts to the same behaviour than when [id=id0]. *) let d = match c with | None -> LocalAssum (id, subst2 subst vsubst t) | Some c -> LocalDef (id, subst2 subst vsubst c, subst2 subst vsubst t) in (push_var id subst, vsubst, Id.Set.add id avoid, d :: nc) let push_rel_context_to_named_context env typ = (* compute the instances relative to the named context and rel_context *) let open Context.Named.Declaration in let ids = List.map get_id (named_context env) in let inst_vars = List.map mkVar ids in if List.is_empty (Environ.rel_context env) then (named_context_val env, typ, inst_vars, empty_csubst, []) else let avoid = List.fold_right Id.Set.add ids Id.Set.empty in let inst_rels = List.rev (rel_list 0 (nb_rel env)) in (* move the rel context to a named context and extend the named instance *) (* with vars of the rel context *) (* We do keep the instances corresponding to local definition (see above) *) let (subst, vsubst, _, env) = Context.Rel.fold_outside push_rel_decl_to_named_context (rel_context env) ~init:(empty_csubst, [], avoid, named_context env) in (val_of_named_context env, subst2 subst vsubst typ, inst_rels@inst_vars, subst, vsubst) (*------------------------------------* * Entry points to define new evars * *------------------------------------*) let default_source = (Loc.ghost,Evar_kinds.InternalHole) let restrict_evar evd evk filter candidates = let evd = Sigma.to_evar_map evd in let evd, evk' = Evd.restrict evk filter ?candidates evd in Sigma.Unsafe.of_pair (evk', Evd.declare_future_goal evk' evd) let new_pure_evar_full evd evi = let evd = Sigma.to_evar_map evd in let (evd, evk) = Evd.new_evar evd evi in let evd = Evd.declare_future_goal evk evd in Sigma.Unsafe.of_pair (evk, evd) let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ = let evd = Sigma.to_evar_map evd in let default_naming = Misctypes.IntroAnonymous in let naming = Option.default default_naming naming in let evi = { evar_hyps = sign; evar_concl = typ; evar_body = Evar_empty; evar_filter = filter; evar_source = src; evar_candidates = candidates; evar_extra = store; } in let (evd, newevk) = Evd.new_evar evd ~naming evi in let evd = if principal then Evd.declare_principal_goal newevk evd else Evd.declare_future_goal newevk evd in Sigma.Unsafe.of_pair (newevk, evd) let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance = assert (not !Flags.debug || List.distinct (ids_of_named_context (named_context_of_val sign))); let Sigma (newevk, evd, p) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in Sigma (mkEvar (newevk,Array.of_list instance), evd, p) (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env typ in let candidates = Option.map (List.map (subst2 subst vsubst)) candidates in let instance = match filter with | None -> instance | Some filter -> Filter.filter_list filter instance in new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in (Sigma.to_evar_map evd, evk) let new_type_evar env evd ?src ?filter ?naming ?principal rigid = let Sigma (s, evd', p) = Sigma.new_sort_variable rigid evd in let Sigma (e, evd', q) = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in Sigma ((e, s), evd', p +> q) let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid = let sigma = Sigma.Unsafe.of_evar_map !evdref in let Sigma (c, sigma, _) = new_type_evar env sigma ?src ?filter ?naming ?principal rigid in let sigma = Sigma.to_evar_map sigma in evdref := sigma; c let new_Type ?(rigid=Evd.univ_flexible) env evd = let Sigma (s, sigma, p) = Sigma.new_sort_variable rigid evd in Sigma (mkSort s, sigma, p) let e_new_Type ?(rigid=Evd.univ_flexible) env evdref = let evd', s = new_sort_variable rigid !evdref in evdref := evd'; mkSort s (* The same using side-effect *) let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty = let (evd',ev) = new_evar_unsafe env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in evdref := evd'; ev (* This assumes an evar with identity instance and generalizes it over only the De Bruijn part of the context *) let generalize_evar_over_rels sigma (ev,args) = let evi = Evd.find sigma ev in let sign = named_context_of_val evi.evar_hyps in List.fold_left2 (fun (c,inst as x) a d -> if isRel a then (mkNamedProd_or_LetIn d c,a::inst) else x) (evi.evar_concl,[]) (Array.to_list args) sign (************************************) (* Removing a dependency in an evar *) (************************************) type clear_dependency_error = | OccurHypInSimpleClause of Id.t option | EvarTypingBreak of existential exception ClearDependencyError of Id.t * clear_dependency_error let cleared = Store.field () exception Depends of Id.t let rec check_and_clear_in_constr env evdref err ids global c = (* returns a new constr where all the evars have been 'cleaned' (ie the hypotheses ids have been removed from the contexts of evars). [global] should be true iff there is some variable of [ids] which is a section variable *) match kind_of_term c with | Var id' -> if Id.Set.mem id' ids then raise (ClearDependencyError (id', err)) else c | ( Const _ | Ind _ | Construct _ ) -> let () = if global then let check id' = if Id.Set.mem id' ids then raise (ClearDependencyError (id',err)) in Id.Set.iter check (Environ.vars_of_global env c) in c | Evar (evk,l as ev) -> if Evd.is_defined !evdref evk then (* If evk is already defined we replace it by its definition *) let nc = whd_evar !evdref c in (check_and_clear_in_constr env evdref err ids global nc) else (* We check for dependencies to elements of ids in the evar_info corresponding to e and in the instance of arguments. Concurrently, we build a new evar corresponding to e where hypotheses of ids have been removed *) let evi = Evd.find_undefined !evdref evk in let ctxt = Evd.evar_filtered_context evi in let (rids,filter) = List.fold_right2 (fun h a (ri,filter) -> try (* Check if some id to clear occurs in the instance a of rid in ev and remember the dependency *) let check id = if Id.Set.mem id ids then raise (Depends id) in let () = Id.Set.iter check (collect_vars a) in (* Check if some rid to clear in the context of ev has dependencies in another hyp of the context of ev and transitively remember the dependency *) let check id _ = if occur_var_in_decl (Global.env ()) id h then raise (Depends id) in let () = Id.Map.iter check ri in (* No dependency at all, we can keep this ev's context hyp *) (ri, true::filter) with Depends id -> let open Context.Named.Declaration in (Id.Map.add (get_id h) id ri, false::filter)) ctxt (Array.to_list l) (Id.Map.empty,[]) in (* Check if some rid to clear in the context of ev has dependencies in the type of ev and adjust the source of the dependency *) let _nconcl = try let nids = Id.Map.domain rids in let global = Id.Set.exists is_section_variable nids in check_and_clear_in_constr env evdref (EvarTypingBreak ev) nids global (evar_concl evi) with ClearDependencyError (rid,err) -> raise (ClearDependencyError (Id.Map.find rid rids,err)) in if Id.Map.is_empty rids then c else let origfilter = Evd.evar_filter evi in let filter = Evd.Filter.apply_subfilter origfilter filter in let evd = Sigma.Unsafe.of_evar_map !evdref in let Sigma (_, evd, _) = restrict_evar evd evk filter None in let evd = Sigma.to_evar_map evd in evdref := evd; (* spiwack: hacking session to mark the old [evk] as having been "cleared" *) let evi = Evd.find !evdref evk in let extra = evi.evar_extra in let extra' = Store.set extra cleared true in let evi' = { evi with evar_extra = extra' } in evdref := Evd.add !evdref evk evi' ; (* spiwack: /hacking session *) whd_evar !evdref c | _ -> map_constr (check_and_clear_in_constr env evdref err ids global) c let clear_hyps_in_evi_main env evdref hyps terms ids = (* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some hypothesis does not depend on a element of ids, and erases ids in the contexts of the evars occurring in evi *) let global = Id.Set.exists is_section_variable ids in let terms = List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids global) terms in let nhyps = let open Context.Named.Declaration in let check_context decl = let err = OccurHypInSimpleClause (Some (get_id decl)) in map_constr (check_and_clear_in_constr env evdref err ids global) decl in let check_value vk = match force_lazy_val vk with | None -> vk | Some (_, d) -> if (Id.Set.for_all (fun e -> not (Id.Set.mem e d)) ids) then (* v does depend on any of ids, it's ok *) vk else (* v depends on one of the cleared hyps: we forget the computed value *) dummy_lazy_val () in remove_hyps ids check_context check_value hyps in (nhyps,terms) let clear_hyps_in_evi env evdref hyps concl ids = match clear_hyps_in_evi_main env evdref hyps [concl] ids with | (nhyps,[nconcl]) -> (nhyps,nconcl) | _ -> assert false let clear_hyps2_in_evi env evdref hyps t concl ids = match clear_hyps_in_evi_main env evdref hyps [t;concl] ids with | (nhyps,[t;nconcl]) -> (nhyps,t,nconcl) | _ -> assert false (* spiwack: a few functions to gather evars on which goals depend. *) let queue_set q is_dependent set = Evar.Set.iter (fun a -> Queue.push (is_dependent,a) q) set let queue_term q is_dependent c = queue_set q is_dependent (evars_of_term c) let process_dependent_evar q acc evm is_dependent e = let evi = Evd.find evm e in (* Queues evars appearing in the types of the goal (conclusion, then hypotheses), they are all dependent. *) queue_term q true evi.evar_concl; List.iter begin fun decl -> let open Context.Named.Declaration in queue_term q true (get_type decl); match decl with | LocalAssum _ -> () | LocalDef (_,b,_) -> queue_term q true b end (Environ.named_context_of_val evi.evar_hyps); match evi.evar_body with | Evar_empty -> if is_dependent then Evar.Map.add e None acc else acc | Evar_defined b -> let subevars = evars_of_term b in (* evars appearing in the definition of an evar [e] are marked as dependent when [e] is dependent itself: if [e] is a non-dependent goal, then, unless they are reach from another path, these evars are just other non-dependent goals. *) queue_set q is_dependent subevars; if is_dependent then Evar.Map.add e (Some subevars) acc else acc let gather_dependent_evars q evm = let acc = ref Evar.Map.empty in while not (Queue.is_empty q) do let (is_dependent,e) = Queue.pop q in (* checks if [e] has already been added to [!acc] *) begin if not (Evar.Map.mem e !acc) then acc := process_dependent_evar q !acc evm is_dependent e end done; !acc let gather_dependent_evars evm l = let q = Queue.create () in List.iter (fun a -> Queue.add (false,a) q) l; gather_dependent_evars q evm (* /spiwack *) (** [advance sigma g] returns [Some g'] if [g'] is undefined and is the current avatar of [g] (for instance [g] was changed by [clear] into [g']). It returns [None] if [g] has been (partially) solved. *) (* spiwack: [advance] is probably performance critical, and the good behaviour of its definition may depend sensitively to the actual definition of [Evd.find]. Currently, [Evd.find] starts looking for a value in the heap of undefined variable, which is small. Hence in the most common case, where [advance] is applied to an unsolved goal ([advance] is used to figure if a side effect has modified the goal) it terminates quickly. *) let rec advance sigma evk = let evi = Evd.find sigma evk in match evi.evar_body with | Evar_empty -> Some evk | Evar_defined v -> if Option.default false (Store.get evi.evar_extra cleared) then let (evk,_) = Term.destEvar v in advance sigma evk else None (** The following functions return the set of undefined evars contained in the object, the defined evars being traversed. This is roughly a combination of the previous functions and [nf_evar]. *) let undefined_evars_of_term evd t = let rec evrec acc c = match kind_of_term c with | Evar (n, l) -> let acc = Array.fold_left evrec acc l in (try match (Evd.find evd n).evar_body with | Evar_empty -> Evar.Set.add n acc | Evar_defined c -> evrec acc c with Not_found -> anomaly ~label:"undefined_evars_of_term" (Pp.str "evar not found")) | _ -> fold_constr evrec acc c in evrec Evar.Set.empty t let undefined_evars_of_named_context evd nc = let open Context.Named.Declaration in Context.Named.fold_outside (fold (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c))) nc ~init:Evar.Set.empty let undefined_evars_of_evar_info evd evi = Evar.Set.union (undefined_evars_of_term evd evi.evar_concl) (Evar.Set.union (match evi.evar_body with | Evar_empty -> Evar.Set.empty | Evar_defined b -> undefined_evars_of_term evd b) (undefined_evars_of_named_context evd (named_context_of_val evi.evar_hyps))) (* spiwack: this is a more complete version of {!Termops.occur_evar}. The latter does not look recursively into an [evar_map]. If unification only need to check superficially, tactics do not have this luxury, and need the more complete version. *) let occur_evar_upto sigma n c = let rec occur_rec c = match kind_of_term c with | Evar (sp,_) when Evar.equal sp n -> raise Occur | Evar e -> Option.iter occur_rec (existential_opt_value sigma e) | _ -> iter_constr occur_rec c in try occur_rec c; false with Occur -> true (* We don't try to guess in which sort the type should be defined, since any type has type Type. May cause some trouble, but not so far... *) let judge_of_new_Type evd = let Sigma (s, evd', p) = Sigma.new_univ_variable univ_rigid evd in Sigma ({ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }, evd', p) let subterm_source evk (loc,k) = let evk = match k with | Evar_kinds.SubEvar (evk) -> evk | _ -> evk in (loc,Evar_kinds.SubEvar evk) (** Term exploration up to instantiation. *) let kind_of_term_upto sigma t = Constr.kind (whd_evar sigma t) (** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and [u] up to existential variable instantiation and equalisable universes. The term [t] is interpreted in [sigma1] while [u] is interpreted in [sigma2]. The universe constraints in [sigma2] are assumed to be an extention of those in [sigma1]. *) let eq_constr_univs_test sigma1 sigma2 t u = (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *) let open Evd in let fold cstr sigma = try Some (add_universe_constraints sigma cstr) with Univ.UniverseInconsistency _ | UniversesDiffer -> None in let ans = Universes.eq_constr_univs_infer_with (fun t -> kind_of_term_upto sigma1 t) (fun u -> kind_of_term_upto sigma2 u) (universes sigma2) fold t u sigma2 in match ans with None -> false | Some _ -> true type type_constraint = types option type val_constraint = constr option coq-8.6/engine/termops.ml0000644000175000017500000010760213022274260014755 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (str "Set") | Prop Null -> (str "Prop") | Type u -> (str "Type(" ++ Univ.Universe.pr u ++ str ")") let pr_sort_family = function | InSet -> (str "Set") | InProp -> (str "Prop") | InType -> (str "Type") let pr_name = function | Name id -> pr_id id | Anonymous -> str "_" let pr_con sp = str(string_of_con sp) let pr_fix pr_constr ((t,i),(lna,tl,bl)) = let fixl = Array.mapi (fun i na -> (na,t.(i),tl.(i),bl.(i))) lna in hov 1 (str"fix " ++ int i ++ spc() ++ str"{" ++ v 0 (prlist_with_sep spc (fun (na,i,ty,bd) -> pr_name na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++ cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ str"}") let pr_puniverses p u = if Univ.Instance.is_empty u then p else p ++ str"(*" ++ Univ.Instance.pr Universes.pr_with_global_universes u ++ str"*)" let rec pr_constr c = match kind_of_term c with | Rel n -> str "#"++int n | Meta n -> str "Meta(" ++ int n ++ str ")" | Var id -> pr_id id | Sort s -> print_sort s | Cast (c,_, t) -> hov 1 (str"(" ++ pr_constr c ++ cut() ++ str":" ++ pr_constr t ++ str")") | Prod (Name(id),t,c) -> hov 1 (str"forall " ++ pr_id id ++ str":" ++ pr_constr t ++ str"," ++ spc() ++ pr_constr c) | Prod (Anonymous,t,c) -> hov 0 (str"(" ++ pr_constr t ++ str " ->" ++ spc() ++ pr_constr c ++ str")") | Lambda (na,t,c) -> hov 1 (str"fun " ++ pr_name na ++ str":" ++ pr_constr t ++ str" =>" ++ spc() ++ pr_constr c) | LetIn (na,b,t,c) -> hov 0 (str"let " ++ pr_name na ++ str":=" ++ pr_constr b ++ str":" ++ brk(1,2) ++ pr_constr t ++ cut() ++ pr_constr c) | App (c,l) -> hov 1 (str"(" ++ pr_constr c ++ spc() ++ prlist_with_sep spc pr_constr (Array.to_list l) ++ str")") | Evar (e,l) -> hov 1 (str"Evar#" ++ int (Evar.repr e) ++ str"{" ++ prlist_with_sep spc pr_constr (Array.to_list l) ++str"}") | Const (c,u) -> str"Cst(" ++ pr_puniverses (pr_con c) u ++ str")" | Ind ((sp,i),u) -> str"Ind(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i) u ++ str")" | Construct (((sp,i),j),u) -> str"Constr(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")" | Proj (p,c) -> str"Proj(" ++ pr_con (Projection.constant p) ++ str"," ++ bool (Projection.unfolded p) ++ pr_constr c ++ str")" | Case (ci,p,c,bl) -> v 0 (hv 0 (str"<"++pr_constr p++str">"++ cut() ++ str"Case " ++ pr_constr c ++ str"of") ++ cut() ++ prlist_with_sep (fun _ -> brk(1,2)) pr_constr (Array.to_list bl) ++ cut() ++ str"end") | Fix f -> pr_fix pr_constr f | CoFix(i,(lna,tl,bl)) -> let fixl = Array.mapi (fun i na -> (na,tl.(i),bl.(i))) lna in hov 1 (str"cofix " ++ int i ++ spc() ++ str"{" ++ v 0 (prlist_with_sep spc (fun (na,ty,bd) -> pr_name na ++ str":" ++ pr_constr ty ++ cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ str"}") let term_printer = ref (fun _ -> pr_constr) let print_constr_env t = !term_printer t let print_constr t = !term_printer (Global.env()) t let set_print_constr f = term_printer := f let pr_var_decl env decl = let open NamedDecl in let pbody = match decl with | LocalAssum _ -> mt () | LocalDef (_,c,_) -> (* Force evaluation *) let pb = print_constr_env env c in (str" := " ++ pb ++ cut () ) in let pt = print_constr_env env (get_type decl) in let ptyp = (str" : " ++ pt) in (pr_id (get_id decl) ++ hov 0 (pbody ++ ptyp)) let pr_rel_decl env decl = let open RelDecl in let pbody = match decl with | LocalAssum _ -> mt () | LocalDef (_,c,_) -> (* Force evaluation *) let pb = print_constr_env env c in (str":=" ++ spc () ++ pb ++ spc ()) in let ptyp = print_constr_env env (get_type decl) in match get_name decl with | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) let print_named_context env = hv 0 (fold_named_context (fun env d pps -> pps ++ ws 2 ++ pr_var_decl env d) env ~init:(mt ())) let print_rel_context env = hv 0 (fold_rel_context (fun env d pps -> pps ++ ws 2 ++ pr_rel_decl env d) env ~init:(mt ())) let print_env env = let sign_env = fold_named_context (fun env d pps -> let pidt = pr_var_decl env d in (pps ++ fnl () ++ pidt)) env ~init:(mt ()) in let db_env = fold_rel_context (fun env d pps -> let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat)) env ~init:(mt ()) in (sign_env ++ db_env) (* [Rel (n+m);...;Rel(n+1)] *) let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) let rel_list n m = let rec reln l p = if p>m then l else reln (mkRel(n+p)::l) (p+1) in reln [] 1 let push_rel_assum (x,t) env = let open RelDecl in push_rel (LocalAssum (x,t)) env let push_rels_assum assums = let open RelDecl in push_rel_context (List.map (fun (x,t) -> LocalAssum (x,t)) assums) let push_named_rec_types (lna,typarray,_) env = let open NamedDecl in let ctxt = Array.map2_i (fun i na t -> match na with | Name id -> LocalAssum (id, lift i t) | Anonymous -> anomaly (Pp.str "Fix declarations must be named")) lna typarray in Array.fold_left (fun e assum -> push_named assum e) env ctxt let lookup_rel_id id sign = let open RelDecl in let rec lookrec n = function | [] -> raise Not_found | (LocalAssum (Anonymous, _) | LocalDef (Anonymous,_,_)) :: l -> lookrec (n + 1) l | LocalAssum (Name id', t) :: l -> if Names.Id.equal id' id then (n,None,t) else lookrec (n + 1) l | LocalDef (Name id', b, t) :: l -> if Names.Id.equal id' id then (n,Some b,t) else lookrec (n + 1) l in lookrec 1 sign (* Constructs either [forall x:t, c] or [let x:=b:t in c] *) let mkProd_or_LetIn decl c = let open RelDecl in match decl with | LocalAssum (na,t) -> mkProd (na, t, c) | LocalDef (na,b,t) -> mkLetIn (na, b, t, c) (* Constructs either [forall x:t, c] or [c] in which [x] is replaced by [b] *) let mkProd_wo_LetIn decl c = let open RelDecl in match decl with | LocalAssum (na,t) -> mkProd (na, t, c) | LocalDef (_,b,_) -> subst1 b c let it_mkProd init = List.fold_left (fun c (n,t) -> mkProd (n, t, c)) init let it_mkLambda init = List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) init let it_named_context_quantifier f ~init = List.fold_left (fun c d -> f d c) init let it_mkProd_or_LetIn init = it_named_context_quantifier mkProd_or_LetIn ~init let it_mkProd_wo_LetIn init = it_named_context_quantifier mkProd_wo_LetIn ~init let it_mkLambda_or_LetIn init = it_named_context_quantifier mkLambda_or_LetIn ~init let it_mkNamedProd_or_LetIn init = it_named_context_quantifier mkNamedProd_or_LetIn ~init let it_mkNamedProd_wo_LetIn init = it_named_context_quantifier mkNamedProd_wo_LetIn ~init let it_mkNamedLambda_or_LetIn init = it_named_context_quantifier mkNamedLambda_or_LetIn ~init let it_mkLambda_or_LetIn_from_no_LetIn c decls = let open RelDecl in let rec aux k decls c = match decls with | [] -> c | LocalDef (na,b,t) :: decls -> mkLetIn (na,b,t,aux (k-1) decls (liftn 1 k c)) | LocalAssum (na,t) :: decls -> mkLambda (na,t,aux (k-1) decls c) in aux (List.length decls) (List.rev decls) c (* *) (* strips head casts and flattens head applications *) let rec strip_head_cast c = match kind_of_term c with | App (f,cl) -> let rec collapse_rec f cl2 = match kind_of_term f with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) | Cast (c,_,_) -> collapse_rec c cl2 | _ -> if Int.equal (Array.length cl2) 0 then f else mkApp (f,cl2) in collapse_rec f cl | Cast (c,_,_) -> strip_head_cast c | _ -> c let rec drop_extra_implicit_args c = match kind_of_term c with (* Removed trailing extra implicit arguments, what improves compatibility for constants with recently added maximal implicit arguments *) | App (f,args) when isEvar (Array.last args) -> drop_extra_implicit_args (mkApp (f,fst (Array.chop (Array.length args - 1) args))) | _ -> c (* Get the last arg of an application *) let last_arg c = match kind_of_term c with | App (f,cl) -> Array.last cl | _ -> anomaly (Pp.str "last_arg") (* Get the last arg of an application *) let decompose_app_vect c = match kind_of_term c with | App (f,cl) -> (f, cl) | _ -> (c,[||]) let adjust_app_list_size f1 l1 f2 l2 = let len1 = List.length l1 and len2 = List.length l2 in if Int.equal len1 len2 then (f1,l1,f2,l2) else if len1 < len2 then let extras,restl2 = List.chop (len2-len1) l2 in (f1, l1, applist (f2,extras), restl2) else let extras,restl1 = List.chop (len1-len2) l1 in (applist (f1,extras), restl1, f2, l2) let adjust_app_array_size f1 l1 f2 l2 = let len1 = Array.length l1 and len2 = Array.length l2 in if Int.equal len1 len2 then (f1,l1,f2,l2) else if len1 < len2 then let extras,restl2 = Array.chop (len2-len1) l2 in (f1, l1, appvect (f2,extras), restl2) else let extras,restl1 = Array.chop (len1-len2) l1 in (appvect (f1,extras), restl1, f2, l2) (* [map_constr_with_named_binders g f l c] maps [f l] on the immediate subterms of [c]; it carries an extra data [l] (typically a name list) which is processed by [g na] (which typically cons [na] to [l]) at each binder traversal (with name [na]); it is not recursive and the order with which subterms are processed is not specified *) let map_constr_with_named_binders g f l c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c | Cast (c,k,t) -> mkCast (f l c, k, f l t) | Prod (na,t,c) -> mkProd (na, f l t, f (g na l) c) | Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c) | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c) | App (c,al) -> mkApp (f l c, Array.map (f l) al) | Proj (p,c) -> mkProj (p, f l c) | Evar (e,al) -> mkEvar (e, Array.map (f l) al) | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl) | Fix (ln,(lna,tl,bl)) -> let l' = Array.fold_left (fun l na -> g na l) l lna in mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) | CoFix(ln,(lna,tl,bl)) -> let l' = Array.fold_left (fun l na -> g na l) l lna in mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) (* [map_constr_with_binders_left_to_right g f n c] maps [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; the subterms are processed from left to right according to the usual representation of the constructions (this may matter if [f] does a side-effect); it is not recursive; in fact, the usual representation of the constructions is at the time being almost those of the ML representation (except for (co-)fixpoint) *) let fold_rec_types g (lna,typarray,_) e = let ctxt = Array.map2_i (fun i na t -> RelDecl.LocalAssum (na, lift i t)) lna typarray in Array.fold_left (fun e assum -> g assum e) e ctxt let map_left2 f a g b = let l = Array.length a in if Int.equal l 0 then [||], [||] else begin let r = Array.make l (f a.(0)) in let s = Array.make l (g b.(0)) in for i = 1 to l - 1 do r.(i) <- f a.(i); s.(i) <- g b.(i) done; r, s end let map_constr_with_binders_left_to_right g f l c = let open RelDecl in match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c | Cast (b,k,t) -> let b' = f l b in let t' = f l t in if b' == b && t' == t then c else mkCast (b',k,t') | Prod (na,t,b) -> let t' = f l t in let b' = f (g (LocalAssum (na,t)) l) b in if t' == t && b' == b then c else mkProd (na, t', b') | Lambda (na,t,b) -> let t' = f l t in let b' = f (g (LocalAssum (na,t)) l) b in if t' == t && b' == b then c else mkLambda (na, t', b') | LetIn (na,bo,t,b) -> let bo' = f l bo in let t' = f l t in let b' = f (g (LocalDef (na,bo,t)) l) b in if bo' == bo && t' == t && b' == b then c else mkLetIn (na, bo', t', b') | App (c,[||]) -> assert false | App (t,al) -> (*Special treatment to be able to recognize partially applied subterms*) let a = al.(Array.length al - 1) in let app = (mkApp (t, Array.sub al 0 (Array.length al - 1))) in let app' = f l app in let a' = f l a in if app' == app && a' == a then c else mkApp (app', [| a' |]) | Proj (p,b) -> let b' = f l b in if b' == b then c else mkProj (p, b') | Evar (e,al) -> let al' = Array.map_left (f l) al in if Array.for_all2 (==) al' al then c else mkEvar (e, al') | Case (ci,p,b,bl) -> (* In v8 concrete syntax, predicate is after the term to match! *) let b' = f l b in let p' = f l p in let bl' = Array.map_left (f l) bl in if b' == b && p' == p && bl' == bl then c else mkCase (ci, p', b', bl') | Fix (ln,(lna,tl,bl as fx)) -> let l' = fold_rec_types g fx l in let (tl', bl') = map_left2 (f l) tl (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then c else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl as fx)) -> let l' = fold_rec_types g fx l in let (tl', bl') = map_left2 (f l) tl (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then c else mkCoFix (ln,(lna,tl',bl')) (* strong *) let map_constr_with_full_binders g f l cstr = let open RelDecl in match kind_of_term cstr with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> cstr | Cast (c,k, t) -> let c' = f l c in let t' = f l t in if c==c' && t==t' then cstr else mkCast (c', k, t') | Prod (na,t,c) -> let t' = f l t in let c' = f (g (LocalAssum (na,t)) l) c in if t==t' && c==c' then cstr else mkProd (na, t', c') | Lambda (na,t,c) -> let t' = f l t in let c' = f (g (LocalAssum (na,t)) l) c in if t==t' && c==c' then cstr else mkLambda (na, t', c') | LetIn (na,b,t,c) -> let b' = f l b in let t' = f l t in let c' = f (g (LocalDef (na,b,t)) l) c in if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c') | App (c,al) -> let c' = f l c in let al' = Array.map (f l) al in if c==c' && Array.for_all2 (==) al al' then cstr else mkApp (c', al') | Proj (p,c) -> let c' = f l c in if c' == c then cstr else mkProj (p, c') | Evar (e,al) -> let al' = Array.map (f l) al in if Array.for_all2 (==) al al' then cstr else mkEvar (e, al') | Case (ci,p,c,bl) -> let p' = f l p in let c' = f l c in let bl' = Array.map (f l) bl in if p==p' && c==c' && Array.for_all2 (==) bl bl' then cstr else mkCase (ci, p', c', bl') | Fix (ln,(lna,tl,bl)) -> let tl' = Array.map (f l) tl in let l' = Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in let bl' = Array.map (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then cstr else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> let tl' = Array.map (f l) tl in let l' = Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in let bl' = Array.map (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then cstr else mkCoFix (ln,(lna,tl',bl')) (* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate subterms of [c] starting from [acc] and proceeding from left to right according to the usual representation of the constructions as [fold_constr] but it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive *) let fold_constr_with_full_binders g f n acc c = let open RelDecl in match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> acc | Cast (c,_, t) -> f n (f n acc c) t | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (p,c) -> f n acc c | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(lna,tl,bl)) -> let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n,t)) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd | CoFix (_,(lna,tl,bl)) -> let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n,t)) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd let fold_constr_with_binders g f n acc c = fold_constr_with_full_binders (fun _ x -> g x) f n acc c (* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate subterms of [c]; it carries an extra data [acc] which is processed by [g] at each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) let iter_constr_with_full_binders g f l c = let open RelDecl in match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () | Cast (c,_, t) -> f l c; f l t | Prod (na,t,c) -> f l t; f (g (LocalAssum (na,t)) l) c | Lambda (na,t,c) -> f l t; f (g (LocalAssum (na,t)) l) c | LetIn (na,b,t,c) -> f l b; f l t; f (g (LocalDef (na,b,t)) l) c | App (c,args) -> f l c; Array.iter (f l) args | Proj (p,c) -> f l c | Evar (_,args) -> Array.iter (f l) args | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl | Fix (_,(lna,tl,bl)) -> let l' = Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in Array.iter (f l) tl; Array.iter (f l') bl | CoFix (_,(lna,tl,bl)) -> let l' = Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in Array.iter (f l) tl; Array.iter (f l') bl (***************************) (* occurs check functions *) (***************************) exception Occur let occur_meta c = let rec occrec c = match kind_of_term c with | Meta _ -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur -> true let occur_existential c = let rec occrec c = match kind_of_term c with | Evar _ -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur -> true let occur_meta_or_existential c = let rec occrec c = match kind_of_term c with | Evar _ -> raise Occur | Meta _ -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur -> true let occur_evar n c = let rec occur_rec c = match kind_of_term c with | Evar (sp,_) when Evar.equal sp n -> raise Occur | _ -> iter_constr occur_rec c in try occur_rec c; false with Occur -> true let occur_in_global env id constr = let vars = vars_of_global env constr in if Id.Set.mem id vars then raise Occur let occur_var env id c = let rec occur_rec c = match kind_of_term c with | Var _ | Const _ | Ind _ | Construct _ -> occur_in_global env id c | _ -> iter_constr occur_rec c in try occur_rec c; false with Occur -> true let occur_var_in_decl env hyp decl = let open NamedDecl in match decl with | LocalAssum (_,typ) -> occur_var env hyp typ | LocalDef (_, body, typ) -> occur_var env hyp typ || occur_var env hyp body let local_occur_var id c = let rec occur c = match kind_of_term c with | Var id' -> if Id.equal id id' then raise Occur | _ -> Constr.iter occur c in try occur c; false with Occur -> true (* returns the list of free debruijn indices in a term *) let free_rels m = let rec frec depth acc c = match kind_of_term c with | Rel n -> if n >= depth then Int.Set.add (n-depth+1) acc else acc | _ -> fold_constr_with_binders succ frec depth acc c in frec 1 Int.Set.empty m (* collects all metavar occurrences, in left-to-right order, preserving * repetitions and all. *) let collect_metas c = let rec collrec acc c = match kind_of_term c with | Meta mv -> List.add_set Int.equal mv acc | _ -> fold_constr collrec acc c in List.rev (collrec [] c) (* collects all vars; warning: this is only visible vars, not dependencies in all section variables; for the latter, use global_vars_set *) let collect_vars c = let rec aux vars c = match kind_of_term c with | Var id -> Id.Set.add id vars | _ -> fold_constr aux vars c in aux Id.Set.empty c let vars_of_global_reference env gr = let c, _ = Universes.unsafe_constr_of_global gr in vars_of_global (Global.env ()) c (* Tests whether [m] is a subterm of [t]: [m] is appropriately lifted through abstractions of [t] *) let dependent_main noevar univs m t = let eqc x y = if univs then fst (Universes.eq_constr_universes x y) else eq_constr_nounivs x y in let rec deprec m t = if eqc m t then raise Occur else match kind_of_term m, kind_of_term t with | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt -> deprec m (mkApp (ft,Array.sub lt 0 (Array.length lm))); CArray.Fun1.iter deprec m (Array.sub lt (Array.length lm) ((Array.length lt) - (Array.length lm))) | _, Cast (c,_,_) when noevar && isMeta c -> () | _, Evar _ when noevar -> () | _ -> iter_constr_with_binders (fun c -> lift 1 c) deprec m t in try deprec m t; false with Occur -> true let dependent = dependent_main false false let dependent_no_evar = dependent_main true false let dependent_univs = dependent_main false true let dependent_univs_no_evar = dependent_main true true let dependent_in_decl a decl = let open NamedDecl in match decl with | LocalAssum (_,t) -> dependent a t | LocalDef (_, body, t) -> dependent a body || dependent a t let count_occurrences m t = let n = ref 0 in let rec countrec m t = if eq_constr m t then incr n else match kind_of_term m, kind_of_term t with | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt -> countrec m (mkApp (ft,Array.sub lt 0 (Array.length lm))); Array.iter (countrec m) (Array.sub lt (Array.length lm) ((Array.length lt) - (Array.length lm))) | _, Cast (c,_,_) when isMeta c -> () | _, Evar _ -> () | _ -> iter_constr_with_binders (lift 1) countrec m t in countrec m t; !n (* Synonymous *) let occur_term = dependent let pop t = lift (-1) t (***************************) (* bindings functions *) (***************************) type meta_type_map = (metavariable * types) list type meta_value_map = (metavariable * constr) list let rec subst_meta bl c = match kind_of_term c with | Meta i -> (try Int.List.assoc i bl with Not_found -> c) | _ -> map_constr (subst_meta bl) c (* First utilities for avoiding telescope computation for subst_term *) let prefix_application eq_fun (k,c) (t : constr) = let c' = collapse_appl c and t' = collapse_appl t in match kind_of_term c', kind_of_term t' with | App (f1,cl1), App (f2,cl2) -> let l1 = Array.length cl1 and l2 = Array.length cl2 in if l1 <= l2 && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1))) else None | _ -> None let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) = let c' = collapse_appl c and t' = collapse_appl t in match kind_of_term c', kind_of_term t' with | App (f1,cl1), App (f2,cl2) -> let l1 = Array.length cl1 and l2 = Array.length cl2 in if l1 <= l2 && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then Some (mkApp ((lift k by_c), Array.sub cl2 l1 (l2 - l1))) else None | _ -> None (* Recognizing occurrences of a given subterm in a term: [subst_term c t] substitutes [(Rel 1)] for all occurrences of term [c] in a term [t]; works if [c] has rels *) let subst_term_gen eq_fun c t = let rec substrec (k,c as kc) t = match prefix_application eq_fun kc t with | Some x -> x | None -> if eq_fun c t then mkRel k else map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c)) substrec kc t in substrec (1,c) t let subst_term = subst_term_gen eq_constr (* Recognizing occurrences of a given subterm in a term : [replace_term c1 c2 t] substitutes [c2] for all occurrences of term [c1] in a term [t]; works if [c1] and [c2] have rels *) let replace_term_gen eq_fun c by_c in_t = let rec substrec (k,c as kc) t = match my_prefix_application eq_fun kc by_c t with | Some x -> x | None -> (if eq_fun c t then (lift k by_c) else map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c)) substrec kc t) in substrec (0,c) in_t let replace_term = replace_term_gen eq_constr let vars_of_env env = let s = Context.Named.fold_outside (fun decl s -> Id.Set.add (NamedDecl.get_id decl) s) (named_context env) ~init:Id.Set.empty in Context.Rel.fold_outside (fun decl s -> match RelDecl.get_name decl with Name id -> Id.Set.add id s | _ -> s) (rel_context env) ~init:s let add_vname vars = function Name id -> Id.Set.add id vars | _ -> vars (*************************) (* Names environments *) (*************************) type names_context = Name.t list let add_name n nl = n::nl let lookup_name_of_rel p names = try List.nth names (p-1) with Invalid_argument _ | Failure _ -> raise Not_found let lookup_rel_of_name id names = let rec lookrec n = function | Anonymous :: l -> lookrec (n+1) l | (Name id') :: l -> if Id.equal id' id then n else lookrec (n+1) l | [] -> raise Not_found in lookrec 1 names let empty_names_context = [] let ids_of_rel_context sign = Context.Rel.fold_outside (fun decl l -> match RelDecl.get_name decl with Name id -> id::l | Anonymous -> l) sign ~init:[] let ids_of_named_context sign = Context.Named.fold_outside (fun decl idl -> NamedDecl.get_id decl :: idl) sign ~init:[] let ids_of_context env = (ids_of_rel_context (rel_context env)) @ (ids_of_named_context (named_context env)) let names_of_rel_context env = List.map RelDecl.get_name (rel_context env) let is_section_variable id = try let _ = Global.lookup_named id in true with Not_found -> false let isGlobalRef c = match kind_of_term c with | Const _ | Ind _ | Construct _ | Var _ -> true | _ -> false let is_template_polymorphic env f = match kind_of_term f with | Ind ind -> Environ.template_polymorphic_pind ind env | Const c -> Environ.template_polymorphic_pconstant c env | _ -> false let base_sort_cmp pb s0 s1 = match (s0,s1) with | (Prop c1, Prop c2) -> c1 == Null || c2 == Pos (* Prop <= Set *) | (Prop c1, Type u) -> pb == Reduction.CUMUL | (Type u1, Type u2) -> true | _ -> false (* eq_constr extended with universe erasure *) let compare_constr_univ f cv_pb t1 t2 = match kind_of_term t1, kind_of_term t2 with Sort s1, Sort s2 -> base_sort_cmp cv_pb s1 s2 | Prod (_,t1,c1), Prod (_,t2,c2) -> f Reduction.CONV t1 t2 && f cv_pb c1 c2 | _ -> compare_constr (fun t1 t2 -> f Reduction.CONV t1 t2) t1 t2 let rec constr_cmp cv_pb t1 t2 = compare_constr_univ constr_cmp cv_pb t1 t2 let eq_constr t1 t2 = constr_cmp Reduction.CONV t1 t2 (* App(c,[t1,...tn]) -> ([c,t1,...,tn-1],tn) App(c,[||]) -> ([],c) *) let split_app c = match kind_of_term c with App(c,l) -> let len = Array.length l in if Int.equal len 0 then ([],c) else let last = Array.get l (len-1) in let prev = Array.sub l 0 (len-1) in c::(Array.to_list prev), last | _ -> assert false type subst = (Context.Rel.t * constr) Evar.Map.t exception CannotFilter let filtering env cv_pb c1 c2 = let evm = ref Evar.Map.empty in let define cv_pb e1 ev c1 = try let (e2,c2) = Evar.Map.find ev !evm in let shift = List.length e1 - List.length e2 in if constr_cmp cv_pb c1 (lift shift c2) then () else raise CannotFilter with Not_found -> evm := Evar.Map.add ev (e1,c1) !evm in let rec aux env cv_pb c1 c2 = match kind_of_term c1, kind_of_term c2 with | App _, App _ -> let ((p1,l1),(p2,l2)) = (split_app c1),(split_app c2) in let () = aux env cv_pb l1 l2 in begin match p1, p2 with | [], [] -> () | (h1 :: p1), (h2 :: p2) -> aux env cv_pb (applistc h1 p1) (applistc h2 p2) | _ -> assert false end | Prod (n,t1,c1), Prod (_,t2,c2) -> aux env cv_pb t1 t2; aux (RelDecl.LocalAssum (n,t1) :: env) cv_pb c1 c2 | _, Evar (ev,_) -> define cv_pb env ev c1 | Evar (ev,_), _ -> define cv_pb env ev c2 | _ -> if compare_constr_univ (fun pb c1 c2 -> aux env pb c1 c2; true) cv_pb c1 c2 then () else raise CannotFilter (* TODO: le reste des binders *) in aux env cv_pb c1 c2; !evm let decompose_prod_letin : constr -> int * Context.Rel.t * constr = let rec prodec_rec i l c = match kind_of_term c with | Prod (n,t,c) -> prodec_rec (succ i) (RelDecl.LocalAssum (n,t)::l) c | LetIn (n,d,t,c) -> prodec_rec (succ i) (RelDecl.LocalDef (n,d,t)::l) c | Cast (c,_,_) -> prodec_rec i l c | _ -> i,l,c in prodec_rec 0 [] (* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction * gives n (casts are ignored) *) let nb_lam = let rec nbrec n c = match kind_of_term c with | Lambda (_,_,c) -> nbrec (n+1) c | Cast (c,_,_) -> nbrec n c | _ -> n in nbrec 0 (* similar to nb_lam, but gives the number of products instead *) let nb_prod = let rec nbrec n c = match kind_of_term c with | Prod (_,_,c) -> nbrec (n+1) c | Cast (c,_,_) -> nbrec n c | _ -> n in nbrec 0 let nb_prod_modulo_zeta x = let rec count n c = match kind_of_term c with Prod(_,_,t) -> count (n+1) t | LetIn(_,a,_,t) -> count n (subst1 a t) | Cast(c,_,_) -> count n c | _ -> n in count 0 x let align_prod_letin c a : Context.Rel.t * constr = let (lc,_,_) = decompose_prod_letin c in let (la,l,a) = decompose_prod_letin a in if not (la >= lc) then invalid_arg "align_prod_letin"; let (l1,l2) = Util.List.chop lc l in l2,it_mkProd_or_LetIn a l1 (* We reduce a series of head eta-redex or nothing at all *) (* [x1:c1;...;xn:cn]@(f;a1...an;x1;...;xn) --> @(f;a1...an) *) (* Remplace 2 earlier buggish versions *) let rec eta_reduce_head c = match kind_of_term c with | Lambda (_,c1,c') -> (match kind_of_term (eta_reduce_head c') with | App (f,cl) -> let lastn = (Array.length cl) - 1 in if lastn < 0 then anomaly (Pp.str "application without arguments") else (match kind_of_term cl.(lastn) with | Rel 1 -> let c' = if Int.equal lastn 0 then f else mkApp (f, Array.sub cl 0 lastn) in if noccurn 1 c' then lift (-1) c' else c | _ -> c) | _ -> c) | _ -> c (* iterator on rel context *) let process_rel_context f env = let sign = named_context_val env in let rels = rel_context env in let env0 = reset_with_named_context sign env in Context.Rel.fold_outside f rels ~init:env0 let assums_of_rel_context sign = Context.Rel.fold_outside (fun decl l -> match decl with | RelDecl.LocalDef _ -> l | RelDecl.LocalAssum (na,t) -> (na, t)::l) sign ~init:[] let map_rel_context_in_env f env sign = let rec aux env acc = function | d::sign -> aux (push_rel d env) (RelDecl.map_constr (f env) d :: acc) sign | [] -> acc in aux env [] (List.rev sign) let map_rel_context_with_binders f sign = let rec aux k = function | d::sign -> RelDecl.map_constr (f k) d :: aux (k-1) sign | [] -> [] in aux (Context.Rel.length sign) sign let substl_rel_context l = map_rel_context_with_binders (fun k -> substnl l (k-1)) let lift_rel_context n = map_rel_context_with_binders (liftn n) let smash_rel_context sign = let rec aux acc = function | [] -> acc | (RelDecl.LocalAssum _ as d) :: l -> aux (d::acc) l | RelDecl.LocalDef (_,b,_) :: l -> (* Quadratic in the number of let but there are probably a few of them *) aux (List.rev (substl_rel_context [b] (List.rev acc))) l in List.rev (aux [] sign) let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init let mem_named_context_val id ctxt = try ignore(Environ.lookup_named_val id ctxt); true with Not_found -> false let compact_named_context_reverse sign = let compact l decl = let (i1,c1,t1) = NamedDecl.to_tuple decl in match l with | [] -> [[i1],c1,t1] | (l2,c2,t2)::q -> if Option.equal Constr.equal c1 c2 && Constr.equal t1 t2 then (i1::l2,c2,t2)::q else ([i1],c1,t1)::l in Context.Named.fold_inside compact ~init:[] sign let compact_named_context sign = List.rev (compact_named_context_reverse sign) let clear_named_body id env = let open NamedDecl in let aux _ = function | LocalDef (id',c,t) when Id.equal id id' -> push_named (LocalAssum (id,t)) | d -> push_named d in fold_named_context aux env ~init:(reset_context env) let global_vars env ids = Id.Set.elements (global_vars_set env ids) let global_vars_set_of_decl env = function | NamedDecl.LocalAssum (_,t) -> global_vars_set env t | NamedDecl.LocalDef (_,c,t) -> Id.Set.union (global_vars_set env t) (global_vars_set env c) let dependency_closure env sign hyps = if Id.Set.is_empty hyps then [] else let (_,lh) = Context.Named.fold_inside (fun (hs,hl) d -> let x = NamedDecl.get_id d in if Id.Set.mem x hs then (Id.Set.union (global_vars_set_of_decl env d) (Id.Set.remove x hs), x::hl) else (hs,hl)) ~init:(hyps,[]) sign in List.rev lh (* Combinators on judgments *) let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type } let on_judgment_value f j = { j with uj_val = f j.uj_val } let on_judgment_type f j = { j with uj_type = f j.uj_type } (* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k non let-in variables skips let-in's; let-in's in the middle are put in ctx2 *) let context_chop k ctx = let rec chop_aux acc = function | (0, l2) -> (List.rev acc, l2) | (n, (RelDecl.LocalDef _ as h)::t) -> chop_aux (h::acc) (n, t) | (n, (h::t)) -> chop_aux (h::acc) (pred n, t) | (_, []) -> anomaly (Pp.str "context_chop") in chop_aux [] (k,ctx) (* Do not skip let-in's *) let env_rel_context_chop k env = let rels = rel_context env in let ctx1,ctx2 = List.chop k rels in push_rel_context ctx2 (reset_with_named_context (named_context_val env) env), ctx1 (*******************************************) (* Functions to deal with impossible cases *) (*******************************************) let impossible_default_case = ref None let set_impossible_default_clause c = impossible_default_case := Some c let coq_unit_judge = let na1 = Name (Id.of_string "A") in let na2 = Name (Id.of_string "H") in fun () -> match !impossible_default_case with | Some fn -> let (id,type_of_id), ctx = fn () in make_judge id type_of_id, ctx | None -> (* In case the constants id/ID are not defined *) make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1))) (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))), Univ.ContextSet.empty coq-8.6/engine/namegen.mli0000644000175000017500000001004513022274260015041 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string val sort_hdchar : sorts -> string val hdchar : env -> types -> string val id_of_name_using_hdchar : env -> types -> Name.t -> Id.t val named_hd : env -> types -> Name.t -> Name.t val head_name : types -> Id.t option val mkProd_name : env -> Name.t * types * types -> types val mkLambda_name : env -> Name.t * types * constr -> constr (** Deprecated synonyms of [mkProd_name] and [mkLambda_name] *) val prod_name : env -> Name.t * types * types -> types val lambda_name : env -> Name.t * types * constr -> constr val prod_create : env -> types * types -> constr val lambda_create : env -> types * constr -> constr val name_assumption : env -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t val name_context : env -> Context.Rel.t -> Context.Rel.t val mkProd_or_LetIn_name : env -> types -> Context.Rel.Declaration.t -> types val mkLambda_or_LetIn_name : env -> constr -> Context.Rel.Declaration.t -> constr val it_mkProd_or_LetIn_name : env -> types -> Context.Rel.t -> types val it_mkLambda_or_LetIn_name : env -> constr -> Context.Rel.t -> constr (********************************************************************* Fresh names *) (** Avoid clashing with a name satisfying some predicate *) val next_ident_away_from : Id.t -> (Id.t -> bool) -> Id.t (** Avoid clashing with a name of the given list *) val next_ident_away : Id.t -> Id.t list -> Id.t (** Avoid clashing with a name already used in current module *) val next_ident_away_in_goal : Id.t -> Id.t list -> Id.t (** Avoid clashing with a name already used in current module but tolerate overwriting section variables, as in goals *) val next_global_ident_away : Id.t -> Id.t list -> Id.t (** Default is [default_non_dependent_ident] *) val next_name_away : Name.t -> Id.t list -> Id.t val next_name_away_with_default : string -> Name.t -> Id.t list -> Id.t val next_name_away_with_default_using_types : string -> Name.t -> Id.t list -> types -> Id.t val set_reserved_typed_name : (types -> Name.t) -> unit (********************************************************************* Making name distinct for displaying *) type renaming_flags = | RenamingForCasesPattern of (Name.t list * constr) (** avoid only global constructors *) | RenamingForGoal (** avoid all globals (as in intro) *) | RenamingElsewhereFor of (Name.t list * constr) val make_all_name_different : env -> env val compute_displayed_name_in : renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list val compute_and_force_displayed_name_in : renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list val compute_displayed_let_name_in : renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list val rename_bound_vars_as_displayed : Id.t list -> Name.t list -> types -> types (**********************************************************************) (* Naming strategy for arguments in Prop when eliminating inductive types *) val use_h_based_elimination_names : unit -> bool coq-8.6/engine/ftactic.mli0000644000175000017500000000545013022274260015050 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a t (** The unit of the monad. *) val bind : 'a t -> ('a -> 'b t) -> 'b t (** The bind of the monad. *) (** {5 Operations} *) val lift : 'a Proofview.tactic -> 'a t (** Transform a tactic into a focussing tactic. The resulting tactic is not focussed. *) val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic (** Given a continuation producing a tactic, evaluates the focussing tactic. If the tactic has not focussed, then the continuation is evaluated once. Otherwise it is called in each of the currently focussed goals. *) (** {5 Focussing} *) val nf_enter : ([ `NF ], 'a t) enter -> 'a t (** Enter a goal. The resulting tactic is focussed. *) val enter : ([ `LZ ], 'a t) enter -> 'a t (** Enter a goal, without evar normalization. The resulting tactic is focussed. *) val s_enter : ([ `LZ ], 'a t) s_enter -> 'a t (** Enter a goal and put back an evarmap. The resulting tactic is focussed. *) val nf_s_enter : ([ `NF ], 'a t) s_enter -> 'a t (** Enter a goal, without evar normalization and put back an evarmap. The resulting tactic is focussed. *) val with_env : 'a t -> (Environ.env*'a) t (** [with_env t] returns, in addition to the return type of [t], an environment, which is the global environment if [t] does not focus on goals, or the local goal environment if [t] focuses on goals. *) (** {5 Notations} *) val (>>=) : 'a t -> ('a -> 'b t) -> 'b t (** Notation for {!bind}. *) val (<*>) : unit t -> 'a t -> 'a t (** Sequence. *) (** {5 List operations} *) module List : Monad.ListS with type 'a t := 'a t (** {5 Notations} *) module Notations : sig val (>>=) : 'a t -> ('a -> 'b t) -> 'b t val (<*>) : unit t -> 'a t -> 'a t end coq-8.6/engine/proofview.mli0000644000175000017500000006177213022274260015464 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Goal.goal list * Evd.evar_map (** {6 Starting and querying a proof view} *) (** Abstract representation of the initial goals of a proof. *) type entry (** Optimize memory consumption *) val compact : entry -> proofview -> entry * proofview (** Initialises a proofview, the main argument is a list of environments (including a [named_context] which are used as hypotheses) pair with conclusion types, creating accordingly many initial goals. Because a proof does not necessarily starts in an empty [evar_map] (indeed a proof can be triggered by an incomplete pretyping), [init] takes an additional argument to represent the initial [evar_map]. *) val init : Evd.evar_map -> (Environ.env * Term.types) list -> entry * proofview (** A [telescope] is a list of environment and conclusion like in {!init}, except that each element may depend on the previous goals. The telescope passes the goals in the form of a [Term.constr] which represents the goal as an [evar]. The [evar_map] is threaded in state passing style. *) type telescope = | TNil of Evd.evar_map | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) (** Like {!init}, but goals are allowed to be dependent on one another. Dependencies between goals is represented with the type [telescope] instead of [list]. Note that the first [evar_map] of the telescope plays the role of the [evar_map] argument in [init]. *) val dependent_init : telescope -> entry * proofview (** [finished pv] is [true] if and only if [pv] is complete. That is, if it has an empty list of focused goals. There could still be unsolved subgoals, but they would then be out of focus. *) val finished : proofview -> bool (** Returns the current [evar] state. *) val return : proofview -> Evd.evar_map val partial_proof : entry -> proofview -> constr list val initial_goals : entry -> (constr * types) list (** {6 Focusing commands} *) (** A [focus_context] represents the part of the proof view which has been removed by a focusing action, it can be used to unfocus later on. *) type focus_context (** Returns a stylised view of a focus_context for use by, for instance, ide-s. *) (* spiwack: the type of [focus_context] will change as we push more refined functions to ide-s. This would be better than spawning a new nearly identical function everytime. Hence the generic name. *) (* In this version: the goals in the context, as a "zipper" (the first list is in reversed order). *) val focus_context : focus_context -> Goal.goal list * Goal.goal list (** [focus i j] focuses a proofview on the goals from index [i] to index [j] (inclusive, goals are indexed from [1]). I.e. goals number [i] to [j] become the only focused goals of the returned proofview. It returns the focused proofview, and a context for the focus stack. *) val focus : int -> int -> proofview -> proofview * focus_context (** Unfocuses a proofview with respect to a context. *) val unfocus : focus_context -> proofview -> proofview (** {6 The tactic monad} *) (** - Tactics are objects which apply a transformation to all the subgoals of the current view at the same time. By opposition to the old vision of applying it to a single goal. It allows tactics such as [shelve_unifiable], tactics to reorder the focused goals, or global automation tactic for dependent subgoals (instantiating an evar has influences on the other goals of the proof in progress, not being able to take that into account causes the current eauto tactic to fail on some instances where it could succeed). Another benefit is that it is possible to write tactics that can be executed even if there are no focused goals. - Tactics form a monad ['a tactic], in a sense a tactic can be seen as a function (without argument) which returns a value of type 'a and modifies the environment (in our case: the view). Tactics of course have arguments, but these are given at the meta-level as OCaml functions. Most tactics in the sense we are used to return [()], that is no really interesting values. But some might pass information around. The tactics seen in Coq's Ltac are (for now at least) only [unit tactic], the return values are kept for the OCaml toolkit. The operation or the monad are [Proofview.tclUNIT] (which is the "return" of the tactic monad) [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN] (which is a specialized bind on unit-returning tactics). - Tactics have support for full-backtracking. Tactics can be seen having multiple success: if after returning the first success a failure is encountered, the tactic can backtrack and use a second success if available. The state is backtracked to its previous value, except the non-logical state defined in the {!NonLogical} module below. *) (** The abstract type of tactics *) type +'a tactic (** Applies a tactic to the current proofview. Returns a tuple [a,pv,(b,sh,gu)] where [a] is the return value of the tactic, [pv] is the updated proofview, [b] a boolean which is [true] if the tactic has not done any action considered unsafe (such as admitting a lemma), [sh] is the list of goals which have been shelved by the tactic, and [gu] the list of goals on which the tactic has given up. In case of multiple success the first one is selected. If there is no success, fails with {!Logic_monad.TacticFailure}*) val apply : Environ.env -> 'a tactic -> proofview -> 'a * proofview * (bool*Goal.goal list*Goal.goal list) * Proofview_monad.Info.tree (** {7 Monadic primitives} *) (** Unit of the tactic monad. *) val tclUNIT : 'a -> 'a tactic (** Bind operation of the tactic monad. *) val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic (** Interprets the ";" (semicolon) of Ltac. As a monadic operation, it's a specialized "bind". *) val tclTHEN : unit tactic -> 'a tactic -> 'a tactic (** [tclIGNORE t] has the same operational content as [t], but drops the returned value. *) val tclIGNORE : 'a tactic -> unit tactic (** Generic monadic combinators for tactics. *) module Monad : Monad.S with type +'a t = 'a tactic (** {7 Failure and backtracking} *) (** [tclZERO e] fails with exception [e]. It has no success. *) val tclZERO : ?info:Exninfo.info -> exn -> 'a tactic (** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever the successes of [t1] have been depleted and it failed with [e], then it behaves as [t2 e]. In other words, [tclOR] inserts a backtracking point. *) val tclOR : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic (** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one success or [t2 e] if [t1] fails with [e]. It is analogous to [try/with] handler of exception in that it is not a backtracking point. *) val tclORELSE : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic (** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a] succeeds at least once then it behaves as [tclBIND a s] otherwise, if [a] fails with [e], then it behaves as [f e]. *) val tclIFCATCH : 'a tactic -> ('a -> 'b tactic) -> (iexn -> 'b tactic) -> 'b tactic (** [tclONCE t] behave like [t] except it has at most one success: [tclONCE t] stops after the first success of [t]. If [t] fails with [e], [tclONCE t] also fails with [e]. *) val tclONCE : 'a tactic -> 'a tactic (** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one success. Otherwise it fails. The tactic [t] is run until its first success, then a failure with exception [e] is simulated. It [t] yields another success, then [tclEXACTLY_ONCE e t] fails with [MoreThanOneSuccess] (it is a user error). Otherwise, [tclEXACTLY_ONCE e t] succeeds with the first success of [t]. Notice that the choice of [e] is relevant, as the presence of further successes may depend on [e] (see {!tclOR}). *) exception MoreThanOneSuccess val tclEXACTLY_ONCE : exn -> 'a tactic -> 'a tactic (** [tclCASE t] splits [t] into its first success and a continuation. It is the most general primitive to control backtracking. *) type 'a case = | Fail of iexn | Next of 'a * (iexn -> 'a tactic) val tclCASE : 'a tactic -> 'a case tactic (** [tclBREAK p t] is a generalization of [tclONCE t]. Instead of stopping after the first success, it succeeds like [t] until a failure with an exception [e] such that [p e = Some e'] is raised. At which point it drops the remaining successes, failing with [e']. [tclONCE t] is equivalent to [tclBREAK (fun e -> Some e) t]. *) val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic (** {7 Focusing tactics} *) (** [tclFOCUS i j t] applies [t] after focusing on the goals number [i] to [j] (see {!focus}). The rest of the goals is restored after the tactic action. If the specified range doesn't correspond to existing goals, fails with [NoSuchGoals] (a user error). this exception is caught at toplevel with a default message + a hook message that can be customized by [set_nosuchgoals_hook] below. This hook is used to add a suggestion about bullets when applicable. *) exception NoSuchGoals of int val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit val tclFOCUS : int -> int -> 'a tactic -> 'a tactic (** [tclFOCUSLIST li t] applies [t] on the list of focused goals described by [li]. Each element of [li] is a pair [(i, j)] denoting the goals numbered from [i] to [j] (inclusive, starting from 1). It will try to apply [t] to all the valid goals in any of these intervals. If the set of such goals is not a single range, then it will move goals such that it is a single range. (So, for instance, [[1, 3-5]; idtac.] is not the identity.) If the set of such goals is empty, it will fail. *) val tclFOCUSLIST : (int * int) list -> 'a tactic -> 'a tactic (** [tclFOCUSID x t] applies [t] on a (single) focused goal like {!tclFOCUS}. The goal is found by its name rather than its number.*) val tclFOCUSID : Names.Id.t -> 'a tactic -> 'a tactic (** [tclTRYFOCUS i j t] behaves like {!tclFOCUS}, except that if the specified range doesn't correspond to existing goals, behaves like [tclUNIT ()] instead of failing. *) val tclTRYFOCUS : int -> int -> unit tactic -> unit tactic (** {7 Dispatching on goals} *) (** Dispatch tacticals are used to apply a different tactic to each goal under focus. They come in two flavours: [tclDISPATCH] takes a list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL] takes a list of ['a tactic] and returns an ['a list tactic]. They both work by applying each of the tactic in a focus restricted to the corresponding goal (starting with the first goal). In the case of [tclDISPATCHL], the tactic returns a list of the same size as the argument list (of tactics), each element being the result of the tactic executed in the corresponding goal. When the length of the tactic list is not the number of goal, raises [SizeMismatch (g,t)] where [g] is the number of available goals, and [t] the number of tactics passed. *) exception SizeMismatch of int*int val tclDISPATCH : unit tactic list -> unit tactic val tclDISPATCHL : 'a tactic list -> 'a list tactic (** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r] tactic is "repeated" enough time such that every goal has a tactic assigned to it ([b] is the list of tactics applied to the first goals, [e] to the last goals, and [r] is applied to every goal in between). *) val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tactic (** [tclINDEPENDENT tac] runs [tac] on each goal successively, from the first one to the last one. Backtracking in one goal is independent of backtracking in another. It is equivalent to [tclEXTEND [] tac []]. *) val tclINDEPENDENT : unit tactic -> unit tactic (** {7 Goal manipulation} *) (** Shelves all the goals under focus. The goals are placed on the shelf for later use (or being solved by side-effects). *) val shelve : unit tactic (** Shelves the given list of goals, which might include some that are under focus and some that aren't. All the goals are placed on the shelf for later use (or being solved by side-effects). *) val shelve_goals : Goal.goal list -> unit tactic (** [unifiable sigma g l] checks whether [g] appears in another subgoal of [l]. The list [l] may contain [g], but it does not affect the result. Used by [shelve_unifiable]. *) val unifiable : Evd.evar_map -> Goal.goal -> Goal.goal list -> bool (** Shelves the unifiable goals under focus, i.e. the goals which appear in other goals under focus (the unfocused goals are not considered). *) val shelve_unifiable : unit tactic (** [guard_no_unifiable] returns the list of unifiable goals if some goals are unifiable (see {!shelve_unifiable}) in the current focus. *) val guard_no_unifiable : Names.Name.t list option tactic (** [unshelve l p] adds all the goals in [l] at the end of the focused goals of p *) val unshelve : Goal.goal list -> proofview -> proofview (** [depends_on g1 g2 sigma] checks if g1 occurs in the type/ctx of g2 *) val depends_on : Evd.evar_map -> Goal.goal -> Goal.goal -> bool (** [with_shelf tac] executes [tac] and returns its result together with the set of goals shelved by [tac]. The current shelf is unchanged and the returned list contains only unsolved goals. *) val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic (** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] is negative, then it puts the [n] last goals first.*) val cycle : int -> unit tactic (** [swap i j] swaps the position of goals number [i] and [j] (negative numbers can be used to address goals from the end. Goals are indexed from [1]. For simplicity index [0] corresponds to goal [1] as well, rather than raising an error. *) val swap : int -> int -> unit tactic (** [revgoals] reverses the list of focused goals. *) val revgoals : unit tactic (** [numgoals] returns the number of goals under focus. *) val numgoals : int tactic (** {7 Access primitives} *) (** [tclEVARMAP] doesn't affect the proof, it returns the current [evar_map]. *) val tclEVARMAP : Evd.evar_map tactic (** [tclENV] doesn't affect the proof, it returns the current environment. It is not the environment of a particular goal, rather the "global" environment of the proof. The goal-wise environment is obtained via {!Proofview.Goal.env}. *) val tclENV : Environ.env tactic (** {7 Put-like primitives} *) (** [tclEFFECTS eff] add the effects [eff] to the current state. *) val tclEFFECTS : Safe_typing.private_constants -> unit tactic (** [mark_as_unsafe] declares the current tactic is unsafe. *) val mark_as_unsafe : unit tactic (** Gives up on the goal under focus. Reports an unsafe status. Proofs with given up goals cannot be closed. *) val give_up : unit tactic (** {7 Control primitives} *) (** [tclPROGRESS t] checks the state of the proof after [t]. It it is identical to the state before, then [tclePROGRESS t] fails, otherwise it succeeds like [t]. *) val tclPROGRESS : 'a tactic -> 'a tactic (** Checks for interrupts *) val tclCHECKINTERRUPT : unit tactic exception Timeout (** [tclTIMEOUT n t] can have only one success. In case of timeout if fails with [tclZERO Timeout]. *) val tclTIMEOUT : int -> 'a tactic -> 'a tactic (** [tclTIME s t] displays time for each atomic call to t, using s as an identifying annotation if present *) val tclTIME : string option -> 'a tactic -> 'a tactic (** {7 Unsafe primitives} *) (** The primitives in the [Unsafe] module should be avoided as much as possible, since they can make the proof state inconsistent. They are nevertheless helpful, in particular when interfacing the pretyping and the proof engine. *) module Unsafe : sig (** [tclEVARS sigma] replaces the current [evar_map] by [sigma]. If [sigma] has new unresolved [evar]-s they will not appear as goal. If goals have been solved in [sigma] they will still appear as unsolved goals. *) val tclEVARS : Evd.evar_map -> unit tactic (** Like {!tclEVARS} but also checks whether goals have been solved. *) val tclEVARSADVANCE : Evd.evar_map -> unit tactic (** Set the global environment of the tactic *) val tclSETENV : Environ.env -> unit tactic (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently being proved, appending them to the list of focused goals. If a goal is already solved, it is not added. *) val tclNEWGOALS : Goal.goal list -> unit tactic (** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a goal is already solved, it is not set. *) val tclSETGOALS : Goal.goal list -> unit tactic (** [tclGETGOALS] returns the list of goals under focus. *) val tclGETGOALS : Goal.goal list tactic (** Sets the evar universe context. *) val tclEVARUNIVCONTEXT : Evd.evar_universe_context -> unit tactic (** Clears the future goals store in the proof view. *) val reset_future_goals : proofview -> proofview (** Give an evar the status of a goal (changes its source location and makes it unresolvable for type classes. *) val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map (** Make an evar unresolvable for type classes. *) val mark_as_unresolvable : proofview -> Evar.t -> proofview (** [advance sigma g] returns [Some g'] if [g'] is undefined and is the current avatar of [g] (for instance [g] was changed by [clear] into [g']). It returns [None] if [g] has been (partially) solved. *) val advance : Evd.evar_map -> Evar.t -> Evar.t option val typeclass_resolvable : unit Evd.Store.field end (** This module gives access to the innards of the monad. Its use is restricted to very specific cases. *) module UnsafeRepr : sig type state = Proofview_monad.Logical.Unsafe.state val repr : 'a tactic -> ('a, state, state, iexn) Logic_monad.BackState.t val make : ('a, state, state, iexn) Logic_monad.BackState.t -> 'a tactic end (** {6 Goal-dependent tactics} *) module Goal : sig (** Type of goals. The first parameter type is a phantom argument indicating whether the data contained in the goal has been normalized w.r.t. the current sigma. If it is the case, it is flagged [ `NF ]. You may still access the un-normalized data using {!assume} if you known you do not rely on the assumption of being normalized, at your own risk. The second parameter is a stage indicating where the goal belongs. See module {!Sigma}. *) type ('a, 'r) t (** Assume that you do not need the goal to be normalized. *) val assume : ('a, 'r) t -> ([ `NF ], 'r) t (** Normalises the argument goal. *) val normalize : ('a, 'r) t -> ([ `NF ], 'r) t tactic (** [concl], [hyps], [env] and [sigma] given a goal [gl] return respectively the conclusion of [gl], the hypotheses of [gl], the environment of [gl] (i.e. the global environment and the hypotheses) and the current evar map. *) val concl : ([ `NF ], 'r) t -> Term.constr val hyps : ([ `NF ], 'r) t -> Context.Named.t val env : ('a, 'r) t -> Environ.env val sigma : ('a, 'r) t -> 'r Sigma.t val extra : ('a, 'r) t -> Evd.Store.t (** Returns the goal's conclusion even if the goal is not normalised. *) val raw_concl : ('a, 'r) t -> Term.constr type ('a, 'b) enter = { enter : 'r. ('a, 'r) t -> 'b } (** [nf_enter t] applies the goal-dependent tactic [t] in each goal independently, in the manner of {!tclINDEPENDENT} except that the current goal is also given as an argument to [t]. The goal is normalised with respect to evars. *) val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic (** Like {!nf_enter}, but does not normalize the goal beforehand. *) val enter : ([ `LZ ], unit tactic) enter -> unit tactic (** Like {!enter}, but assumes exactly one goal under focus, raising *) (** an error otherwise. *) val enter_one : ([ `LZ ], 'a tactic) enter -> 'a tactic type ('a, 'b) s_enter = { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } (** A variant of {!enter} allows to work with a monotonic state. The evarmap returned by the argument is put back into the current state before firing the returned tactic. *) val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic (** Like {!s_enter}, but normalizes the goal beforehand. *) val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic (** Recover the list of current goals under focus, without evar-normalization. FIXME: encapsulate the level in an existential type. *) val goals : ([ `LZ ], 'r) t tactic list tactic (** [unsolved g] is [true] if [g] is still unsolved in the current proof state. *) val unsolved : ('a, 'r) t -> bool tactic (** Compatibility: avoid if possible *) val goal : ([ `NF ], 'r) t -> Evar.t (** Every goal is valid at a later stage. FIXME: take a later evarmap *) val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t end (** {6 Trace} *) module Trace : sig (** [record_info_trace t] behaves like [t] except the [info] trace is stored. *) val record_info_trace : 'a tactic -> 'a tactic val log : Proofview_monad.lazy_msg -> unit tactic val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.std_ppcmds end (** {6 Non-logical state} *) (** The [NonLogical] module allows the execution of effects (including I/O) in tactics (non-logical side-effects are not discarded at failures). *) module NonLogical : module type of Logic_monad.NonLogical (** [tclLIFT c] is a tactic which behaves exactly as [c]. *) val tclLIFT : 'a NonLogical.t -> 'a tactic (**/**) (*** Compatibility layer with <= 8.2 tactics ***) module V82 : sig type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma val tactic : tac -> unit tactic (* normalises the evars in the goals, and stores the result in solution. *) val nf_evar_goals : unit tactic val has_unresolved_evar : proofview -> bool (* Main function in the implementation of Grab Existential Variables. Resets the proofview's goals so that it contains all unresolved evars (in chronological order of insertion). *) val grab : proofview -> proofview (* Returns the open goals of the proofview together with the evar_map to interpret them. *) val goals : proofview -> Evar.t list Evd.sigma val top_goals : entry -> proofview -> Evar.t list Evd.sigma (* returns the existential variable used to start the proof *) val top_evars : entry -> Evd.evar list (* Caution: this function loses quite a bit of information. It should be avoided as much as possible. It should work as expected for a tactic obtained from {!V82.tactic} though. *) val of_tactic : 'a tactic -> tac (* marks as unsafe if the argument is [false] *) val put_status : bool -> unit tactic (* exception for which it is deemed to be safe to transmute into tactic failure. *) val catchable_exception : exn -> bool (* transforms every Ocaml (catchable) exception into a failure in the monad. *) val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic end (** {7 Notations} *) module Notations : sig (** {!tclBIND} *) val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic (** {!tclTHEN} *) val (<*>) : unit tactic -> 'a tactic -> 'a tactic (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) val (<+>) : 'a tactic -> 'a tactic -> 'a tactic type ('a, 'b) enter = ('a, 'b) Goal.enter = { enter : 'r. ('a, 'r) Goal.t -> 'b } type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } end coq-8.6/install.sh0000755000175000017500000000035113022274260013463 0ustar mdenesmdenes#! /bin/sh dest="$1" shift for f; do bn=`basename $f` dn=`dirname $f` install -d "$dest/$dn" case $bn in *.cmxs) install -m 755 $f "$dest/$dn/$bn" ;; *) install -m 644 $f "$dest/$dn/$bn" ;; esac done coq-8.6/grammar/0000755000175000017500000000000013022274260013105 5ustar mdenesmdenescoq-8.6/grammar/compat5.ml0000644000175000017500000000125513022274260015012 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ] -> [< 't; '(UIDENT "Gram", Loc.ghost); my_token_filter s >] | [< 'tokloc; s >] -> [< 'tokloc; my_token_filter s >] | [< >] -> [< >] let _ = Token.Filter.define_filter (Gram.get_filter()) (fun prev strm -> prev (my_token_filter strm)) coq-8.6/grammar/tacextend.mlp0000644000175000017500000001440213022274260015577 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* > let plugin_name = <:expr< __coq_plugin_name >> let mlexpr_of_ident id = (** Workaround for badly-designed generic arguments lacking a closure *) let id = "$" ^ id in <:expr< Names.Id.of_string_soft $str:id$ >> let rec make_patt = function | [] -> <:patt< [] >> | ExtNonTerminal (_, p) :: l -> <:patt< [ $lid:p$ :: $make_patt l$ ] >> | _::l -> make_patt l let rec make_let raw e = function | [] -> <:expr< fun $lid:"ist"$ -> $e$ >> | ExtNonTerminal (g, p) :: l -> let t = type_of_user_symbol g in let loc = MLast.loc_of_expr e in let e = make_let raw e l in let v = if raw then <:expr< Genarg.out_gen $make_rawwit loc t$ $lid:p$ >> else <:expr< Tacinterp.Value.cast $make_topwit loc t$ $lid:p$ >> in <:expr< let $lid:p$ = $v$ in $e$ >> | _::l -> make_let raw e l let make_clause (pt,_,e) = (make_patt pt, vala None, make_let false e pt) let make_fun_clauses loc s l = let map c = GramCompat.make_fun loc [make_clause c] in mlexpr_of_list map l let get_argt e = <:expr< (fun e -> match e with [ Genarg.ExtraArg tag -> tag | _ -> assert False ]) $e$ >> let rec mlexpr_of_symbol = function | Ulist1 s -> <:expr< Extend.Ulist1 $mlexpr_of_symbol s$ >> | Ulist1sep (s,sep) -> <:expr< Extend.Ulist1sep $mlexpr_of_symbol s$ $str:sep$ >> | Ulist0 s -> <:expr< Extend.Ulist0 $mlexpr_of_symbol s$ >> | Ulist0sep (s,sep) -> <:expr< Extend.Ulist0sep $mlexpr_of_symbol s$ $str:sep$ >> | Uopt s -> <:expr< Extend.Uopt $mlexpr_of_symbol s$ >> | Uentry e -> let arg = get_argt <:expr< $lid:"wit_"^e$ >> in <:expr< Extend.Uentry (Genarg.ArgT.Any $arg$) >> | Uentryl (e, l) -> assert (e = "tactic"); let arg = get_argt <:expr< Constrarg.wit_tactic >> in <:expr< Extend.Uentryl (Genarg.ArgT.Any $arg$) $mlexpr_of_int l$>> let make_prod_item = function | ExtTerminal s -> <:expr< Tacentries.TacTerm $str:s$ >> | ExtNonTerminal (g, id) -> <:expr< Tacentries.TacNonTerm $default_loc$ $mlexpr_of_symbol g$ $mlexpr_of_ident id$ >> let mlexpr_of_clause cl = mlexpr_of_list (fun (a,_,_) -> mlexpr_of_list make_prod_item a) cl (** Special treatment of constr entries *) let is_constr_gram = function | ExtTerminal _ -> false | ExtNonTerminal (Uentry "constr", _) -> true | _ -> false let make_var = function | ExtNonTerminal (_, p) -> Some p | _ -> assert false let declare_tactic loc s c cl = match cl with | [(ExtTerminal name) :: rem, _, tac] when List.for_all is_constr_gram rem -> (** The extension is only made of a name followed by constr entries: we do not add any grammar nor printing rule and add it as a true Ltac definition. *) let patt = make_patt rem in let vars = List.map make_var rem in let vars = mlexpr_of_list (mlexpr_of_option mlexpr_of_ident) vars in let entry = mlexpr_of_string s in let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in let ml = <:expr< { Tacexpr.mltac_name = $se$; Tacexpr.mltac_index = 0 } >> in let name = mlexpr_of_string name in let tac = match rem with | [] -> (** Special handling of tactics without arguments: such tactics do not do a Proofview.Goal.nf_enter to compute their arguments. It matters for some whole-prof tactics like [shelve_unifiable]. *) <:expr< fun _ $lid:"ist"$ -> $tac$ >> | _ -> let f = GramCompat.make_fun loc [patt, vala None, <:expr< fun $lid:"ist"$ -> $tac$ >>] in <:expr< Tacinterp.lift_constr_tac_to_ml_tac $vars$ $f$ >> in (** Arguments are not passed directly to the ML tactic in the TacML node, the ML tactic retrieves its arguments in the [ist] environment instead. This is the rôle of the [lift_constr_tac_to_ml_tac] function. *) let body = <:expr< Tacexpr.TacFun ($vars$, Tacexpr.TacML ($dloc$, $ml$, [])) >> in let name = <:expr< Names.Id.of_string $name$ >> in declare_str_items loc [ <:str_item< do { let obj () = Tacenv.register_ltac True False $name$ $body$ in let () = Tacenv.register_ml_tactic $se$ [|$tac$|] in Mltop.declare_cache_obj obj $plugin_name$ } >> ] | _ -> (** Otherwise we add parsing and printing rules to generate a call to a TacML tactic. *) let entry = mlexpr_of_string s in let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in let gl = mlexpr_of_clause cl in let obj = <:expr< fun () -> Tacentries.add_ml_tactic_notation $se$ $gl$ >> in declare_str_items loc [ <:str_item< do { Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc s cl$); Mltop.declare_cache_obj $obj$ $plugin_name$; } >> ] open Pcaml open PcamlSig (* necessary for camlp4 *) EXTEND GLOBAL: str_item; str_item: [ [ "TACTIC"; "EXTEND"; s = tac_name; c = OPT [ "CLASSIFIED"; "BY"; c = LIDENT -> <:expr< $lid:c$ >> ]; OPT "|"; l = LIST1 tacrule SEP "|"; "END" -> declare_tactic loc s c l ] ] ; tacrule: [ [ "["; l = LIST1 tacargs; "]"; c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> c ]; "->"; "["; e = Pcaml.expr; "]" -> (match l with | ExtNonTerminal _ :: _ -> (* En attendant la syntaxe de tacticielles *) failwith "Tactic syntax must start with an identifier" | _ -> (l,c,e)) ] ] ; tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let e = parse_user_entry e "" in ExtNonTerminal (e, s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let e = parse_user_entry e sep in ExtNonTerminal (e, s) | s = STRING -> let () = if s = "" then failwith "Empty terminal." in ExtTerminal s ] ] ; tac_name: [ [ s = LIDENT -> s | s = UIDENT -> s ] ] ; END coq-8.6/grammar/q_util.mli0000644000175000017500000000304113022274260015103 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* MLast.expr) -> 'a list -> MLast.expr val mlexpr_of_pair : ('a -> MLast.expr) -> ('b -> MLast.expr) -> 'a * 'b -> MLast.expr val mlexpr_of_bool : bool -> MLast.expr val mlexpr_of_int : int -> MLast.expr val mlexpr_of_string : string -> MLast.expr val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> user_symbol -> MLast.expr val type_of_user_symbol : user_symbol -> argument_type val parse_user_entry : string -> string -> user_symbol coq-8.6/grammar/compat5.mlp0000644000175000017500000000170513022274260015172 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ] -> [< '(KEYWORD "EXTEND", loc); my_token_filter s >] | [< 'tokloc; s >] -> [< 'tokloc; my_token_filter s >] | [< >] -> [< >] let _ = Token.Filter.define_filter (Gram.get_filter()) (fun prev strm -> prev (my_token_filter strm)) coq-8.6/grammar/argextend.mlp0000644000175000017500000002202713022274260015603 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* > let mk_extraarg loc s = <:expr< $lid:"wit_"^s$ >> let rec make_wit loc = function | ListArgType t -> <:expr< Genarg.wit_list $make_wit loc t$ >> | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >> | PairArgType (t1,t2) -> <:expr< Genarg.wit_pair $make_wit loc t1$ $make_wit loc t2$ >> | ExtraArgType s -> mk_extraarg loc s let is_self s = function | ExtraArgType s' -> s = s' | _ -> false let make_rawwit loc arg = <:expr< Genarg.rawwit $make_wit loc arg$ >> let make_globwit loc arg = <:expr< Genarg.glbwit $make_wit loc arg$ >> let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >> let make_act loc act pil = let rec make = function | [] -> <:expr< (fun loc -> $act$) >> | ExtNonTerminal (_, p) :: tl -> <:expr< (fun $lid:p$ -> $make tl$) >> | ExtTerminal _ :: tl -> <:expr< (fun _ -> $make tl$) >> in make (List.rev pil) let make_prod_item = function | ExtTerminal s -> <:expr< Extend.Atoken (CLexer.terminal $mlexpr_of_string s$) >> | ExtNonTerminal (g, _) -> let base s = <:expr< $lid:s$ >> in mlexpr_of_prod_entry_key base g let rec make_prod = function | [] -> <:expr< Extend.Stop >> | item :: prods -> <:expr< Extend.Next $make_prod prods$ $make_prod_item item$ >> let make_rule loc (prods,act) = <:expr< Extend.Rule $make_prod (List.rev prods)$ $make_act loc act prods$ >> let is_ident x = function | <:expr< $lid:s$ >> -> (s : string) = x | _ -> false let make_extend loc s cl wit = match cl with | [[ExtNonTerminal (Uentry e, id)], act] when is_ident id act -> (** Special handling of identity arguments by not redeclaring an entry *) <:str_item< value $lid:s$ = let () = Pcoq.register_grammar $wit$ $lid:e$ in $lid:e$ >> | _ -> let se = mlexpr_of_string s in let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in <:str_item< value $lid:s$ = let $lid:s$ = Pcoq.create_generic_entry Pcoq.utactic $se$ (Genarg.rawwit $wit$) in let () = Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]) in $lid:s$ >> let warning_redundant prefix s = Printf.eprintf "Redundant [%sTYPED AS] clause in [ARGUMENT EXTEND %s].\n%!" prefix s let get_type prefix s = function | None -> None | Some typ -> if is_self s typ then let () = warning_redundant prefix s in None else Some typ let check_type prefix s = function | None -> () | Some _ -> warning_redundant prefix s let declare_tactic_argument loc s (typ, f, g, h) cl = let se = mlexpr_of_string s in let rawtyp, rawpr, globtyp, globpr, typ, pr = match typ with | `Uniform (typ, pr) -> let typ = get_type "" s typ in typ, pr, typ, pr, typ, pr | `Specialized (a, rpr, c, gpr, e, tpr) -> (** Check that we actually need the TYPED AS arguments *) let rawtyp = get_type "RAW_" s a in let glbtyp = get_type "GLOB_" s c in let toptyp = get_type "" s e in let () = match g with None -> () | Some _ -> check_type "RAW_" s rawtyp in let () = match f, h with Some _, Some _ -> check_type "GLOB_" s glbtyp | _ -> () in rawtyp, rpr, glbtyp, gpr, toptyp, tpr in let glob = match g with | None -> begin match rawtyp with | None -> <:expr< fun ist v -> (ist, v) >> | Some rawtyp -> <:expr< fun ist v -> let ans = out_gen $make_globwit loc rawtyp$ (Tacintern.intern_genarg ist (Genarg.in_gen $make_rawwit loc rawtyp$ v)) in (ist, ans) >> end | Some f -> <:expr< fun ist v -> (ist, $lid:f$ ist v) >> in let interp = match f with | None -> begin match globtyp with | None -> let typ = match globtyp with None -> ExtraArgType s | Some typ -> typ in <:expr< fun ist v -> Ftactic.return (Geninterp.Val.inject (Geninterp.val_tag $make_topwit loc typ$) v) >> | Some globtyp -> <:expr< fun ist x -> Tacinterp.interp_genarg ist (Genarg.in_gen $make_globwit loc globtyp$ x) >> end | Some f -> (** Compatibility layer, TODO: remove me *) let typ = match globtyp with None -> ExtraArgType s | Some typ -> typ in <:expr< let f = $lid:f$ in fun ist v -> Ftactic.nf_s_enter { Proofview.Goal.s_enter = fun gl -> let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in let v = Geninterp.Val.inject (Geninterp.val_tag $make_topwit loc typ$) v in Sigma.Unsafe.of_pair (Ftactic.return v, sigma) } >> in let subst = match h with | None -> begin match globtyp with | None -> <:expr< fun s v -> v >> | Some globtyp -> <:expr< fun s x -> out_gen $make_globwit loc globtyp$ (Tacsubst.subst_genarg s (Genarg.in_gen $make_globwit loc globtyp$ x)) >> end | Some f -> <:expr< $lid:f$>> in let dyn = match typ with | None -> <:expr< None >> | Some typ -> <:expr< Some (Geninterp.val_tag $make_topwit loc typ$) >> in let wit = <:expr< $lid:"wit_"^s$ >> in declare_str_items loc [ <:str_item< value ($lid:"wit_"^s$) = Genarg.make0 $se$ >>; <:str_item< Genintern.register_intern0 $wit$ $glob$ >>; <:str_item< Genintern.register_subst0 $wit$ $subst$ >>; <:str_item< Geninterp.register_interp0 $wit$ $interp$ >>; <:str_item< Geninterp.register_val0 $wit$ $dyn$ >>; make_extend loc s cl wit; <:str_item< do { Pptactic.declare_extra_genarg_pprule $wit$ $lid:rawpr$ $lid:globpr$ $lid:pr$; Tacentries.create_ltac_quotation $se$ (fun (loc, v) -> Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit $wit$) v)) ($lid:s$, None) } >> ] let declare_vernac_argument loc s pr cl = let se = mlexpr_of_string s in let wit = <:expr< $lid:"wit_"^s$ >> in let pr_rules = match pr with | None -> <:expr< fun _ _ _ _ -> str $str:"[No printer for "^s^"]"$ >> | Some pr -> <:expr< fun _ _ _ -> $lid:pr$ >> in declare_str_items loc [ <:str_item< value ($lid:"wit_"^s$ : Genarg.genarg_type 'a unit unit) = Genarg.create_arg $se$ >>; make_extend loc s cl wit; <:str_item< do { Pptactic.declare_extra_genarg_pprule $wit$ $pr_rules$ (fun _ _ _ _ -> CErrors.anomaly (Pp.str "vernac argument needs not globwit printer")) (fun _ _ _ _ -> CErrors.anomaly (Pp.str "vernac argument needs not wit printer")) } >> ] open Pcaml open PcamlSig (* necessary for camlp4 *) EXTEND GLOBAL: str_item; str_item: [ [ "ARGUMENT"; "EXTEND"; s = entry_name; header = argextend_header; OPT "|"; l = LIST1 argrule SEP "|"; "END" -> declare_tactic_argument loc s header l | "VERNAC"; "ARGUMENT"; "EXTEND"; s = entry_name; pr = OPT ["PRINTED"; "BY"; pr = LIDENT -> pr]; OPT "|"; l = LIST1 argrule SEP "|"; "END" -> declare_vernac_argument loc s pr l ] ] ; argextend_specialized: [ [ rawtyp = OPT [ "RAW_TYPED"; "AS"; rawtyp = argtype -> rawtyp ]; "RAW_PRINTED"; "BY"; rawpr = LIDENT; globtyp = OPT [ "GLOB_TYPED"; "AS"; globtyp = argtype -> globtyp ]; "GLOB_PRINTED"; "BY"; globpr = LIDENT -> (rawtyp, rawpr, globtyp, globpr) ] ] ; argextend_header: [ [ typ = OPT [ "TYPED"; "AS"; typ = argtype -> typ ]; "PRINTED"; "BY"; pr = LIDENT; f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ]; g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ]; h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ]; special = OPT argextend_specialized -> let repr = match special with | None -> `Uniform (typ, pr) | Some (rtyp, rpr, gtyp, gpr) -> `Specialized (rtyp, rpr, gtyp, gpr, typ, pr) in (repr, f, g, h) ] ] ; argtype: [ "2" [ e1 = argtype; "*"; e2 = argtype -> PairArgType (e1, e2) ] | "1" [ e = argtype; LIDENT "list" -> ListArgType e | e = argtype; LIDENT "option" -> OptArgType e ] | "0" [ e = LIDENT -> let e = parse_user_entry e "" in type_of_user_symbol e | "("; e = argtype; ")" -> e ] ] ; argrule: [ [ "["; l = LIST0 genarg; "]"; "->"; "["; e = Pcaml.expr; "]" -> (l,e) ] ] ; genarg: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let e = parse_user_entry e "" in ExtNonTerminal (e, s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let e = parse_user_entry e sep in ExtNonTerminal (e, s) | s = STRING -> ExtTerminal s ] ] ; entry_name: [ [ s = LIDENT -> s | UIDENT -> failwith "Argument entry names must be lowercase" ] ] ; END coq-8.6/grammar/q_util.mlp0000644000175000017500000001012113022274260015107 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let e1 = f e1 in let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in <:expr< [$e1$ :: $e2$] >>) l (let loc = CompatLoc.ghost in <:expr< [] >>) let mlexpr_of_pair m1 m2 (a1,a2) = let e1 = m1 a1 and e2 = m2 a2 in let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in <:expr< ($e1$, $e2$) >> (* We don't give location for tactic quotation! *) let loc = CompatLoc.ghost let mlexpr_of_bool = function | true -> <:expr< True >> | false -> <:expr< False >> let mlexpr_of_int n = <:expr< $int:string_of_int n$ >> let mlexpr_of_string s = <:expr< $str:s$ >> let mlexpr_of_option f = function | None -> <:expr< None >> | Some e -> <:expr< Some $f e$ >> let symbol_of_string s = <:expr< Extend.Atoken (CLexer.terminal $str:s$) >> let rec mlexpr_of_prod_entry_key f = function | Ulist1 s -> <:expr< Extend.Alist1 $mlexpr_of_prod_entry_key f s$ >> | Ulist1sep (s,sep) -> <:expr< Extend.Alist1sep $mlexpr_of_prod_entry_key f s$ $symbol_of_string sep$ >> | Ulist0 s -> <:expr< Extend.Alist0 $mlexpr_of_prod_entry_key f s$ >> | Ulist0sep (s,sep) -> <:expr< Extend.Alist0sep $mlexpr_of_prod_entry_key f s$ $symbol_of_string sep$ >> | Uopt s -> <:expr< Extend.Aopt $mlexpr_of_prod_entry_key f s$ >> | Uentry e -> <:expr< Extend.Aentry $f e$ >> | Uentryl (e, l) -> (** Keep in sync with Pcoq! *) assert (e = "tactic"); if l = 5 then <:expr< Extend.Aentry (Pcoq.Tactic.binder_tactic) >> else <:expr< Extend.Aentryl (Pcoq.Tactic.tactic_expr) $mlexpr_of_int l$ >> let rec type_of_user_symbol = function | Ulist1 s | Ulist1sep (s, _) | Ulist0 s | Ulist0sep (s, _) -> ListArgType (type_of_user_symbol s) | Uopt s -> OptArgType (type_of_user_symbol s) | Uentry e | Uentryl (e, _) -> ExtraArgType e let coincide s pat off = let len = String.length pat in let break = ref true in let i = ref 0 in while !break && !i < len do let c = Char.code s.[off + !i] in let d = Char.code pat.[!i] in break := c = d; incr i done; !break let rec parse_user_entry s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then let entry = parse_user_entry (String.sub s 3 (l-8)) "" in Ulist1 entry else if l > 12 && coincide s "ne_" 0 && coincide s "_list_sep" (l-9) then let entry = parse_user_entry (String.sub s 3 (l-12)) "" in Ulist1sep (entry, sep) else if l > 5 && coincide s "_list" (l-5) then let entry = parse_user_entry (String.sub s 0 (l-5)) "" in Ulist0 entry else if l > 9 && coincide s "_list_sep" (l-9) then let entry = parse_user_entry (String.sub s 0 (l-9)) "" in Ulist0sep (entry, sep) else if l > 4 && coincide s "_opt" (l-4) then let entry = parse_user_entry (String.sub s 0 (l-4)) "" in Uopt entry else if l = 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then let n = Char.code s.[6] - 48 in Uentryl ("tactic", n) else let s = match s with "hyp" -> "var" | _ -> s in Uentry s coq-8.6/grammar/vernacextend.mlp0000644000175000017500000001554013022274260016312 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* e | ExtNonTerminal (g, p) :: l -> let t = type_of_user_symbol g in let loc = MLast.loc_of_expr e in let e = make_let e l in <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> | _::l -> make_let e l let make_clause { r_patt = pt; r_branch = e; } = (make_patt pt, vala None, make_let e pt) (* To avoid warnings *) let mk_ignore c pt = let fold accu = function | ExtNonTerminal (_, p) -> p :: accu | _ -> accu in let names = List.fold_left fold [] pt in let fold accu id = <:expr< let _ = $lid:id$ in $accu$ >> in let names = List.fold_left fold <:expr< () >> names in <:expr< do { let _ = $names$ in $c$ } >> let make_clause_classifier cg s { r_patt = pt; r_class = c; } = match c ,cg with | Some c, _ -> (make_patt pt, vala None, make_let (mk_ignore c pt) pt) | None, Some cg -> (make_patt pt, vala None, <:expr< fun () -> $cg$ $str:s$ >>) | None, None -> prerr_endline (("Vernac entry \""^s^"\" misses a classifier. "^ "A classifier is a function that returns an expression "^ "of type vernac_classification (see Vernacexpr). You can: ") ^ "- " ^ ( ("Use '... EXTEND "^s^" CLASSIFIED AS QUERY ...' if the "^ "new vernacular command does not alter the system state;"))^ "\n" ^ "- " ^ ( ("Use '... EXTEND "^s^" CLASSIFIED AS SIDEFF ...' if the "^ "new vernacular command alters the system state but not the "^ "parser nor it starts a proof or ends one;"))^ "\n" ^ "- " ^ ( ("Use '... EXTEND "^s^" CLASSIFIED BY f ...' to specify "^ "a global function f. The function f will be called passing "^ "\""^s^"\" as the only argument;")) ^ "\n" ^ "- " ^ ( "Add a specific classifier in each clause using the syntax:" ^ "\n" ^("'[...] => [ f ] -> [...]'. "))^ "\n" ^ ("Specific classifiers have precedence over global "^ "classifiers. Only one classifier is called.") ^ "\n"); (make_patt pt, vala None, <:expr< fun () -> (Vernacexpr.VtUnknown, Vernacexpr.VtNow) >>) let make_fun_clauses loc s l = let map c = let depr = match c.r_depr with | None -> false | Some () -> true in let cl = GramCompat.make_fun loc [make_clause c] in <:expr< ($mlexpr_of_bool depr$, $cl$)>> in mlexpr_of_list map l let make_fun_classifiers loc s c l = let cl = List.map (fun x -> GramCompat.make_fun loc [make_clause_classifier c s x]) l in mlexpr_of_list (fun x -> x) cl let make_prod_item = function | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> | ExtNonTerminal (g, id) -> let nt = type_of_user_symbol g in let base s = <:expr< Pcoq.genarg_grammar ($mk_extraarg loc s$) >> in <:expr< Egramml.GramNonTerminal $default_loc$ $make_rawwit loc nt$ $mlexpr_of_prod_entry_key base g$ >> let mlexpr_of_clause cl = let mkexpr { r_head = a; r_patt = b; } = match a with | None -> mlexpr_of_list make_prod_item b | Some a -> mlexpr_of_list make_prod_item (ExtTerminal a :: b) in mlexpr_of_list mkexpr cl let declare_command loc s c nt cl = let se = mlexpr_of_string s in let gl = mlexpr_of_clause cl in let funcl = make_fun_clauses loc s cl in let classl = make_fun_classifiers loc s c cl in declare_str_items loc [ <:str_item< do { CList.iteri (fun i (depr, f) -> Vernacinterp.vinterp_add depr ($se$, i) f) $funcl$; CList.iteri (fun i f -> Vernac_classifier.declare_vernac_classifier ($se$, i) f) $classl$; CList.iteri (fun i r -> Egramml.extend_vernac_command_grammar ($se$, i) $nt$ r) $gl$; } >> ] open Pcaml open PcamlSig (* necessary for camlp4 *) EXTEND GLOBAL: str_item; str_item: [ [ "VERNAC"; "COMMAND"; "EXTEND"; s = UIDENT; c = OPT classification; OPT "|"; l = LIST1 rule SEP "|"; "END" -> declare_command loc s c <:expr> l | "VERNAC"; nt = LIDENT ; "EXTEND"; s = UIDENT; c = OPT classification; OPT "|"; l = LIST1 rule SEP "|"; "END" -> declare_command loc s c <:expr> l | "DECLARE"; "PLUGIN"; name = STRING -> declare_str_items loc [ <:str_item< value __coq_plugin_name = $str:name$ >>; <:str_item< value _ = Mltop.add_known_module $str:name$ >>; ] ] ] ; classification: [ [ "CLASSIFIED"; "BY"; c = LIDENT -> <:expr< $lid:c$ >> | "CLASSIFIED"; "AS"; "SIDEFF" -> <:expr< fun _ -> Vernac_classifier.classify_as_sideeff >> | "CLASSIFIED"; "AS"; "QUERY" -> <:expr< fun _ -> Vernac_classifier.classify_as_query >> ] ] ; deprecation: [ [ "DEPRECATED" -> () ] ] ; (* spiwack: comment-by-guessing: it seems that the isolated string (which otherwise could have been another argument) is not passed to the VernacExtend interpreter function to discriminate between the clauses. *) rule: [ [ "["; s = STRING; l = LIST0 args; "]"; d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> let () = if s = "" then failwith "Command name is empty." in let b = <:expr< fun () -> $e$ >> in { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } | "[" ; "-" ; l = LIST1 args ; "]" ; d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> let b = <:expr< fun () -> $e$ >> in { r_head = None; r_patt = l; r_class = c; r_branch = b; r_depr = d; } ] ] ; classifier: [ [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< fun () -> $c$>> ] ] ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let e = parse_user_entry e "" in ExtNonTerminal (e, s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let e = parse_user_entry e sep in ExtNonTerminal (e, s) | s = STRING -> ExtTerminal s ] ] ; END ;; coq-8.6/grammar/gramCompat.mlp0000644000175000017500000000410213022274260015706 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* > *) ELSE Ast.stSem_of_list l END (** Quotation difference for match clauses *) let default_patt loc = (<:patt< _ >>, vala None, <:expr< failwith "Extension: cannot occur" >>) IFDEF CAMLP5 THEN let make_fun loc cl = let l = cl @ [default_patt loc] in MLast.ExFun (loc, vala l) (* correspond to <:expr< fun [ $list:l$ ] >> *) ELSE let make_fun loc cl = let mk_when = function | Some w -> w | None -> Ast.ExNil loc in let mk_clause (patt,optwhen,expr) = (* correspond to <:match_case< ... when ... -> ... >> *) Ast.McArr (loc, patt, mk_when optwhen, expr) in let init = mk_clause (default_patt loc) in let add_clause x acc = Ast.McOr (loc, mk_clause x, acc) in let l = List.fold_right add_clause cl init in Ast.ExFun (loc,l) (* correspond to <:expr< fun [ $l$ ] >> *) END coq-8.6/checker/0000755000175000017500000000000013022274260013063 5ustar mdenesmdenescoq-8.6/checker/validate.ml0000644000175000017500000001200613022274260015205 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Obj.no_scan_tag then if t = Obj.string_tag then Format.print_string ("\""^String.escaped(Obj.magic o)^"\"") else Format.print_string "?" else (let n = Obj.size o in Format.print_string ("#"^string_of_int t^"("); Format.open_hvbox 0; for i = 0 to n-1 do pr_obj_rec (Obj.field o i); if i<>n-1 then (Format.print_string ","; Format.print_cut()) done; Format.close_box(); Format.print_string ")") else Format.print_string "?" let pr_obj o = pr_obj_rec o; Format.print_newline() (**************************************************************************) (* Obj low-level validators *) type error_frame = | CtxAnnot of string | CtxType of string | CtxField of int | CtxTag of int type error_context = error_frame list let mt_ec : error_context = [] let (/) (ctx:error_context) s : error_context = s::ctx exception ValidObjError of string * error_context * Obj.t let fail ctx o s = raise (ValidObjError(s,ctx,o)) type func = error_context -> Obj.t -> unit (* Check that object o is a block with tag t *) let val_tag t ctx o = if Obj.is_block o && Obj.tag o = t then () else fail ctx o ("expected tag "^string_of_int t) let val_block ctx o = if Obj.is_block o then (if Obj.tag o > Obj.no_scan_tag then fail ctx o "block: found no scan tag") else fail ctx o "expected block obj" let val_dyn ctx o = let fail () = fail ctx o "expected a Dyn.t" in if not (Obj.is_block o) then fail () else if not (Obj.size o = 2) then fail () else if not (Obj.tag (Obj.field o 0) = Obj.int_tag) then fail () else () open Values let rec val_gen v ctx o = match v with | Tuple (name,vs) -> val_tuple ~name vs ctx o | Sum (name,cc,vv) -> val_sum name cc vv ctx o | Array v -> val_array v ctx o | List v0 -> val_sum "list" 1 [|[|Annot ("elem",v0);v|]|] ctx o | Opt v -> val_sum "option" 1 [|[|v|]|] ctx o | Int -> if not (Obj.is_int o) then fail ctx o "expected an int" | String -> (try val_tag Obj.string_tag ctx o with Failure _ -> fail ctx o "expected a string") | Any -> () | Fail s -> fail ctx o ("unexpected object " ^ s) | Annot (s,v) -> val_gen v (ctx/CtxAnnot s) o | Dyn -> val_dyn ctx o (* Check that an object is a tuple (or a record). vs is an array of value representation for each field. Its size corresponds to the expected size of the object. *) and val_tuple ?name vs ctx o = let ctx = match name with | Some n -> ctx/CtxType n | _ -> ctx in let n = Array.length vs in let val_fld i v = val_gen v (ctx/(CtxField i)) (Obj.field o i) in val_block ctx o; if Obj.size o = n then Array.iteri val_fld vs else fail ctx o ("tuple size: found "^string_of_int (Obj.size o)^ ", expected "^string_of_int n) (* Check that the object is either a constant constructor of tag < cc, or a constructed variant. each element of vv is an array of value representations of the constructor arguments. The size of vv corresponds to the number of non-constant constructors, and the size of vv.(i) is the expected arity of the i-th non-constant constructor. *) and val_sum name cc vv ctx o = let ctx = ctx/CtxType name in if Obj.is_block o then (val_block ctx o; let n = Array.length vv in let i = Obj.tag o in let ctx' = if n=1 then ctx else ctx/CtxTag i in if i < n then val_tuple vv.(i) ctx' o else fail ctx' o ("sum: unexpected tag")) else if Obj.is_int o then let (n:int) = Obj.magic o in (if n<0 || n>=cc then fail ctx o ("bad constant constructor "^string_of_int n)) else fail ctx o "not a sum" (* Check the o is an array of values satisfying f. *) and val_array v ctx o = val_block (ctx/CtxType "array") o; for i = 0 to Obj.size o - 1 do val_gen v ctx (Obj.field o i) done let print_frame = function | CtxType t -> t | CtxAnnot t -> t | CtxField i -> Printf.sprintf "fld=%i" i | CtxTag i -> Printf.sprintf "tag=%i" i let validate debug v x = let o = Obj.repr x in try val_gen v mt_ec o with ValidObjError(msg,ctx,obj) -> if debug then begin let ctx = List.rev_map print_frame ctx in print_endline ("Validation failed: "^msg); print_endline ("Context: "^String.concat"/"ctx); pr_obj obj end; failwith "vo structure validation failed" coq-8.6/checker/check_stat.ml0000644000175000017500000000363613022274260015535 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* str "Theory: Set is impredicative" | PredicativeSet -> str "Theory: Set is predicative" end let cst_filter f csts = Cmap_env.fold (fun c ce acc -> if f c ce then c::acc else acc) csts [] let is_ax _ cb = not (constant_has_body cb) let pr_ax csts = let axs = cst_filter is_ax csts in if axs = [] then str "Axioms: " else hv 2 (str "Axioms:" ++ fnl() ++ prlist_with_sep fnl Indtypes.prcon axs) let print_context env = if !output_context then begin let {env_globals= {env_constants=csts; env_inductives=inds; env_modules=mods; env_modtypes=mtys}; env_stratification= {env_universes=univ; env_engagement=engt}} = env in Feedback.msg_notice (hov 0 (fnl() ++ str"CONTEXT SUMMARY" ++ fnl() ++ str"===============" ++ fnl() ++ fnl() ++ str "* " ++ hov 0 (pr_engagement engt ++ fnl()) ++ fnl() ++ str "* " ++ hov 0 (pr_ax csts))); end let stats () = print_context (Safe_typing.get_env()); print_memory_stat () coq-8.6/checker/.depend0000644000175000017500000000575313022274260014335 0ustar mdenesmdeneschecker.cmo: type_errors.cmi term.cmo safe_typing.cmi indtypes.cmi \ declarations.cmi check_stat.cmi check.cmo checker.cmx: type_errors.cmx term.cmx safe_typing.cmx indtypes.cmx \ declarations.cmx check_stat.cmx check.cmx check.cmo: safe_typing.cmi check.cmx: safe_typing.cmx check_stat.cmo: term.cmo safe_typing.cmi indtypes.cmi environ.cmo \ declarations.cmi check_stat.cmi check_stat.cmx: term.cmx safe_typing.cmx indtypes.cmx environ.cmx \ declarations.cmx check_stat.cmi closure.cmo: term.cmo environ.cmo closure.cmi closure.cmx: term.cmx environ.cmx closure.cmi closure.cmi: term.cmo environ.cmo declarations.cmo: term.cmo declarations.cmi declarations.cmx: term.cmx declarations.cmi declarations.cmi: term.cmo environ.cmo: term.cmo declarations.cmi environ.cmx: term.cmx declarations.cmx indtypes.cmo: typeops.cmi term.cmo reduction.cmi inductive.cmi environ.cmo \ declarations.cmi indtypes.cmi indtypes.cmx: typeops.cmx term.cmx reduction.cmx inductive.cmx environ.cmx \ declarations.cmx indtypes.cmi indtypes.cmi: typeops.cmi term.cmo environ.cmo declarations.cmi inductive.cmo: type_errors.cmi term.cmo reduction.cmi environ.cmo \ declarations.cmi inductive.cmi inductive.cmx: type_errors.cmx term.cmx reduction.cmx environ.cmx \ declarations.cmx inductive.cmi inductive.cmi: term.cmo environ.cmo declarations.cmi main.cmo: checker.cmo main.cmx: checker.cmx mod_checking.cmo: typeops.cmi term.cmo subtyping.cmi reduction.cmi modops.cmi \ inductive.cmi indtypes.cmi environ.cmo declarations.cmi mod_checking.cmx: typeops.cmx term.cmx subtyping.cmx reduction.cmx modops.cmx \ inductive.cmx indtypes.cmx environ.cmx declarations.cmx modops.cmo: term.cmo environ.cmo declarations.cmi modops.cmi modops.cmx: term.cmx environ.cmx declarations.cmx modops.cmi modops.cmi: term.cmo environ.cmo declarations.cmi reduction.cmo: term.cmo environ.cmo closure.cmi reduction.cmi reduction.cmx: term.cmx environ.cmx closure.cmx reduction.cmi reduction.cmi: term.cmo environ.cmo safe_typing.cmo: validate.cmo modops.cmi mod_checking.cmo environ.cmo \ declarations.cmi safe_typing.cmi safe_typing.cmx: validate.cmx modops.cmx mod_checking.cmx environ.cmx \ declarations.cmx safe_typing.cmi safe_typing.cmi: term.cmo environ.cmo declarations.cmi subtyping.cmo: typeops.cmi term.cmo reduction.cmi modops.cmi inductive.cmi \ environ.cmo declarations.cmi subtyping.cmi subtyping.cmx: typeops.cmx term.cmx reduction.cmx modops.cmx inductive.cmx \ environ.cmx declarations.cmx subtyping.cmi subtyping.cmi: term.cmo environ.cmo declarations.cmi type_errors.cmo: term.cmo environ.cmo type_errors.cmi type_errors.cmx: term.cmx environ.cmx type_errors.cmi type_errors.cmi: term.cmo environ.cmo typeops.cmo: type_errors.cmi term.cmo reduction.cmi inductive.cmi environ.cmo \ declarations.cmi typeops.cmi typeops.cmx: type_errors.cmx term.cmx reduction.cmx inductive.cmx environ.cmx \ declarations.cmx typeops.cmi typeops.cmi: term.cmo environ.cmo declarations.cmi coq-8.6/checker/values.ml0000644000175000017500000002524013022274260014717 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Any coq-8.6/checker/modops.ml0000644000175000017500000001134113022274260014716 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | NoFunctor _ -> false let destr_functor = function | MoreFunctor (arg_id,arg_t,body_t) -> (arg_id,arg_t,body_t) | NoFunctor _ -> error_not_a_functor () let module_body_of_type mp mtb = { mtb with mod_mp = mp; mod_expr = Abstract } let rec add_structure mp sign resolver env = let add_one env (l,elem) = let kn = KerName.make2 mp l in let con = Constant.make1 kn in let mind = mind_of_delta resolver (MutInd.make1 kn) in match elem with | SFBconst cb -> (* let con = constant_of_delta resolver con in*) Environ.add_constant con cb env | SFBmind mib -> (* let mind = mind_of_delta resolver mind in*) Environ.add_mind mind mib env | SFBmodule mb -> add_module mb env (* adds components as well *) | SFBmodtype mtb -> Environ.add_modtype mtb.mod_mp mtb env in List.fold_left add_one env sign and add_module mb env = let mp = mb.mod_mp in let env = Environ.shallow_add_module mp mb env in match mb.mod_type with | NoFunctor struc -> add_structure mp struc mb.mod_delta env | MoreFunctor _ -> env let add_module_type mp mtb env = add_module (module_body_of_type mp mtb) env let strengthen_const mp_from l cb resolver = match cb.const_body with | Def _ -> cb | _ -> let con = Constant.make2 mp_from l in let u = if cb.const_polymorphic then Univ.make_abstract_instance cb.const_universes else Univ.Instance.empty in { cb with const_body = Def (Declarations.from_val (Const (con,u))) } let rec strengthen_mod mp_from mp_to mb = if Declarations.mp_in_delta mb.mod_mp mb.mod_delta then mb else strengthen_body true mp_from mp_to mb and strengthen_body is_mod mp_from mp_to mb = match mb.mod_type with | MoreFunctor _ -> mb | NoFunctor sign -> let resolve_out,sign_out = strengthen_sig mp_from sign mp_to mb.mod_delta in { mb with mod_expr = (if is_mod then Algebraic (NoFunctor (MEident mp_to)) else Abstract); mod_type = NoFunctor sign_out; mod_delta = resolve_out } and strengthen_sig mp_from sign mp_to resolver = match sign with | [] -> empty_delta_resolver,[] | (l,SFBconst cb) :: rest -> let item' = l,SFBconst (strengthen_const mp_from l cb resolver) in let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in resolve_out,item'::rest' | (_,SFBmind _ as item):: rest -> let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in resolve_out,item::rest' | (l,SFBmodule mb) :: rest -> let mp_from' = MPdot (mp_from,l) in let mp_to' = MPdot(mp_to,l) in let mb_out = strengthen_mod mp_from' mp_to' mb in let item' = l,SFBmodule (mb_out) in let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in resolve_out (*add_delta_resolver resolve_out mb.mod_delta*), item':: rest' | (l,SFBmodtype mty as item) :: rest -> let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in resolve_out,item::rest' let strengthen mtb mp = strengthen_body false mtb.mod_mp mp mtb let subst_and_strengthen mb mp = strengthen_mod mb.mod_mp mp (subst_module (map_mp mb.mod_mp mp) mb) let module_type_of_module mp mb = let mtb = { mb with mod_expr = Abstract; mod_type_alg = None; mod_retroknowledge = [] } in match mp with | Some mp -> strengthen {mtb with mod_mp = mp} mp | None -> mtb coq-8.6/checker/typeops.ml0000644000175000017500000003066213022274260015127 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (try conv_leq env t1 t2 with NotConvertible -> raise (NotConvertibleVect i)); ()) () v1 v2 let check_constraints cst env = if Environ.check_constraints cst env then () else error_unsatisfied_constraints env cst (* This should be a type (a priori without intension to be an assumption) *) let type_judgment env (c,ty as j) = match whd_all env ty with | Sort s -> (c,s) | _ -> error_not_type env j (* This should be a type intended to be assumed. The error message is *) (* not as useful as for [type_judgment]. *) let assumption_of_judgment env j = try fst(type_judgment env j) with TypeError _ -> error_assumption env j (************************************************) (* Incremental typing rules: builds a typing judgement given the *) (* judgements for the subterms. *) (*s Type of sorts *) (* Prop and Set *) let judge_of_prop = Sort (Type Univ.type1_univ) (* Type of Type(i). *) let judge_of_type u = Sort (Type (Univ.super u)) (*s Type of a de Bruijn index. *) let judge_of_relative env n = try let LocalAssum (_,typ) | LocalDef (_,_,typ) = lookup_rel n env in lift n typ with Not_found -> error_unbound_rel env n (* Type of constants *) let type_of_constant_type_knowing_parameters env t paramtyps = match t with | RegularArity t -> t | TemplateArity (sign,ar) -> let ctx = List.rev sign in let ctx,s = instantiate_universes env ctx ar paramtyps in mkArity (List.rev ctx,s) let type_of_constant_knowing_parameters env cst paramtyps = let ty, cu = constant_type env cst in type_of_constant_type_knowing_parameters env ty paramtyps, cu let type_of_constant_type env t = type_of_constant_type_knowing_parameters env t [||] let type_of_constant env cst = type_of_constant_knowing_parameters env cst [||] let judge_of_constant_knowing_parameters env (kn,u as cst) paramstyp = let _cb = try lookup_constant kn env with Not_found -> failwith ("Cannot find constant: "^Constant.to_string kn) in let ty, cu = type_of_constant_knowing_parameters env cst paramstyp in let () = check_constraints cu env in ty let judge_of_constant env cst = judge_of_constant_knowing_parameters env cst [||] (* Type of an application. *) let judge_of_apply env (f,funj) argjv = let rec apply_rec n typ = function | [] -> typ | (h,hj)::restjl -> (match whd_all env typ with | Prod (_,c1,c2) -> (try conv_leq env hj c1 with NotConvertible -> error_cant_apply_bad_type env (n,c1, hj) (f,funj) argjv); apply_rec (n+1) (subst1 h c2) restjl | _ -> error_cant_apply_not_functional env (f,funj) argjv) in apply_rec 1 funj (Array.to_list argjv) (* Type of product *) let sort_of_product env domsort rangsort = match (domsort, rangsort) with (* Product rule (s,Prop,Prop) *) | (_, Prop Null) -> rangsort (* Product rule (Prop/Set,Set,Set) *) | (Prop _, Prop Pos) -> rangsort (* Product rule (Type,Set,?) *) | (Type u1, Prop Pos) -> if engagement env = ImpredicativeSet then (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) rangsort else (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) Type (Univ.sup u1 Univ.type0_univ) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Pos, Type u2) -> Type (Univ.sup Univ.type0_univ u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Null, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) | (Type u1, Type u2) -> Type (Univ.sup u1 u2) (* Type of a type cast *) (* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule env |- c:typ1 env |- typ2:s env |- typ1 <= typ2 --------------------------------------------------------------------- env |- c:typ2 *) let judge_of_cast env (c,cj) k tj = let conversion = match k with | VMcast | NATIVEcast -> vm_conv CUMUL | DEFAULTcast -> conv_leq in try conversion env cj tj with NotConvertible -> error_actual_type env (c,cj) tj (* Inductive types. *) (* The type is parametric over the uniform parameters whose conclusion is in Type; to enforce the internal constraints between the parameters and the instances of Type occurring in the type of the constructors, we use the level variables _statically_ assigned to the conclusions of the parameters as mediators: e.g. if a parameter has conclusion Type(alpha), static constraints of the form alpha<=v exist between alpha and the Type's occurring in the constructor types; when the parameters is finally instantiated by a term of conclusion Type(u), then the constraints u<=alpha is computed in the App case of execute; from this constraints, the expected dynamic constraints of the form u<=v are enforced *) let judge_of_inductive_knowing_parameters env (ind,u) (paramstyp:constr array) = let specif = try lookup_mind_specif env ind with Not_found -> failwith ("Cannot find inductive: "^MutInd.to_string (fst ind)) in type_of_inductive_knowing_parameters env (specif,u) paramstyp let judge_of_inductive env ind = judge_of_inductive_knowing_parameters env ind [||] (* Constructors. *) let judge_of_constructor env (c,u) = let ind = inductive_of_constructor c in let specif = try lookup_mind_specif env ind with Not_found -> failwith ("Cannot find inductive: "^MutInd.to_string (fst ind)) in type_of_constructor (c,u) specif (* Case. *) let check_branch_types env (c,cj) (lfj,explft) = try conv_leq_vecti env lfj explft with NotConvertibleVect i -> error_ill_formed_branch env c i lfj.(i) explft.(i) | Invalid_argument _ -> error_number_branches env (c,cj) (Array.length explft) let judge_of_case env ci pj (c,cj) lfj = let indspec = try find_rectype env cj with Not_found -> error_case_not_inductive env (c,cj) in let _ = check_case_info env (fst (fst indspec)) ci in let (bty,rslty) = type_case_branches env indspec pj c in check_branch_types env (c,cj) (lfj,bty); rslty (* Projection. *) let judge_of_projection env p c ct = let pb = lookup_projection p env in let (ind,u), args = try find_rectype env ct with Not_found -> error_case_not_inductive env (c, ct) in assert(MutInd.equal pb.proj_ind (fst ind)); let ty = subst_instance_constr u pb.proj_type in substl (c :: List.rev args) ty (* Fixpoints. *) (* Checks the type of a general (co)fixpoint, i.e. without checking *) (* the specific guard condition. *) let type_fixpoint env lna lar lbody vdefj = let lt = Array.length vdefj in assert (Array.length lar = lt && Array.length lbody = lt); try conv_leq_vecti env vdefj (Array.map (fun ty -> lift lt ty) lar) with NotConvertibleVect i -> let vdefj = Array.map2 (fun b ty -> b,ty) lbody vdefj in error_ill_typed_rec_body env i lna vdefj lar (************************************************************************) (************************************************************************) (* let refresh_arity env ar = *) (* let ctxt, hd = decompose_prod_assum ar in *) (* match hd with *) (* Sort (Type u) when not (is_univ_variable u) -> *) (* let u' = fresh_local_univ() in *) (* let env' = add_constraints (enforce_leq u u' empty_constraint) env in *) (* env', mkArity (ctxt,Type u') *) (* | _ -> env, ar *) (* The typing machine. *) let rec execute env cstr = match cstr with (* Atomic terms *) | Sort (Prop _) -> judge_of_prop | Sort (Type u) -> judge_of_type u | Rel n -> judge_of_relative env n | Var _ -> anomaly (Pp.str "Section variable in Coqchk !") | Const c -> judge_of_constant env c (* Lambda calculus operators *) | App (App (f,args),args') -> execute env (App(f,Array.append args args')) | App (f,args) -> let jl = execute_array env args in let j = match f with | Ind ind -> (* Sort-polymorphism of inductive types *) judge_of_inductive_knowing_parameters env ind jl | Const cst -> (* Sort-polymorphism of constant *) judge_of_constant_knowing_parameters env cst jl | _ -> (* No sort-polymorphism *) execute env f in let jl = Array.map2 (fun c ty -> c,ty) args jl in judge_of_apply env (f,j) jl | Proj (p, c) -> let ct = execute env c in judge_of_projection env p c ct | Lambda (name,c1,c2) -> let _ = execute_type env c1 in let env1 = push_rel (LocalAssum (name,c1)) env in let j' = execute env1 c2 in Prod(name,c1,j') | Prod (name,c1,c2) -> let varj = execute_type env c1 in let env1 = push_rel (LocalAssum (name,c1)) env in let varj' = execute_type env1 c2 in Sort (sort_of_product env varj varj') | LetIn (name,c1,c2,c3) -> let j1 = execute env c1 in (* /!\ c2 can be an inferred type => refresh (but the pushed type is still c2) *) let _ = let env',c2' = (* refresh_arity env *) env, c2 in let _ = execute_type env' c2' in judge_of_cast env' (c1,j1) DEFAULTcast c2' in let env1 = push_rel (LocalDef (name,c1,c2)) env in let j' = execute env1 c3 in subst1 c1 j' | Cast (c,k,t) -> let cj = execute env c in let _ = execute_type env t in judge_of_cast env (c,cj) k t; t (* Inductive types *) | Ind ind -> judge_of_inductive env ind | Construct c -> judge_of_constructor env c | Case (ci,p,c,lf) -> let cj = execute env c in let pj = execute env p in let lfj = execute_array env lf in judge_of_case env ci (p,pj) (c,cj) lfj | Fix ((_,i as vni),recdef) -> let fix_ty = execute_recdef env recdef i in let fix = (vni,recdef) in check_fix env fix; fix_ty | CoFix (i,recdef) -> let fix_ty = execute_recdef env recdef i in let cofix = (i,recdef) in check_cofix env cofix; fix_ty (* Partial proofs: unsupported by the kernel *) | Meta _ -> anomaly (Pp.str "the kernel does not support metavariables") | Evar _ -> anomaly (Pp.str "the kernel does not support existential variables") and execute_type env constr = let j = execute env constr in snd (type_judgment env (constr,j)) and execute_recdef env (names,lar,vdef) i = let larj = execute_array env lar in let larj = Array.map2 (fun c ty -> c,ty) lar larj in let lara = Array.map (assumption_of_judgment env) larj in let env1 = push_rec_types (names,lara,vdef) env in let vdefj = execute_array env1 vdef in type_fixpoint env1 names lara vdef vdefj; lara.(i) and execute_array env = Array.map (execute env) (* Derived functions *) let infer env constr = execute env constr let infer_type env constr = execute_type env constr (* Typing of several terms. *) let check_ctxt env rels = fold_rel_context (fun d env -> match d with | LocalAssum (_,ty) -> let _ = infer_type env ty in push_rel d env | LocalDef (_,bd,ty) -> let j1 = infer env bd in let _ = infer env ty in conv_leq env j1 ty; push_rel d env) rels ~init:env (* Polymorphic arities utils *) let check_kind env ar u = match (snd (dest_prod env ar)) with | Sort (Type u') when Univ.Universe.equal u' (Univ.Universe.make u) -> () | _ -> failwith "not the correct sort" let check_polymorphic_arity env params par = let pl = par.template_param_levels in let rec check_p env pl params = match pl, params with Some u::pl, LocalAssum (na,ty)::params -> check_kind env ty u; check_p (push_rel (LocalAssum (na,ty)) env) pl params | None::pl,d::params -> check_p (push_rel d env) pl params | [], _ -> () | _ -> failwith "check_poly: not the right number of params" in check_p env pl (List.rev params) coq-8.6/checker/safe_typing.ml0000644000175000017500000000642113022274260015730 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* CErrors.error "Needs option -impredicative-set." | _ -> () end; () (* Libraries = Compiled modules *) let report_clash f caller dir = let msg = str "compiled library " ++ pr_dirpath caller ++ spc() ++ str "makes inconsistent assumptions over library" ++ spc() ++ pr_dirpath dir ++ fnl() in f msg let check_imports f caller env needed = let check (dp,stamp) = try let actual_stamp = lookup_digest env dp in if stamp <> actual_stamp then report_clash f caller dp with Not_found -> error ("Reference to unknown module " ^ (DirPath.to_string dp)) in Array.iter check needed (* This function should append a certificate to the .vo file. The digest must be part of the certicate to rule out attackers that could change the .vo file between the time it was read and the time the stamp is written. For the moment, .vo are not signed. *) let stamp_library file digest = () (* When the module is checked, digests do not need to match, but a warning is issued in case of mismatch *) let import file clib univs digest = let env = !genv in check_imports Feedback.msg_warning clib.comp_name env clib.comp_deps; check_engagement env clib.comp_enga; let mb = clib.comp_mod in Mod_checking.check_module (push_context_set ~strict:true univs (push_context_set ~strict:true mb.mod_constraints env)) mb.mod_mp mb; stamp_library file digest; full_add_module clib.comp_name mb univs digest (* When the module is admitted, digests *must* match *) let unsafe_import file clib univs digest = let env = !genv in if !Flags.debug then check_imports Feedback.msg_warning clib.comp_name env clib.comp_deps else check_imports (errorlabstrm"unsafe_import") clib.comp_name env clib.comp_deps; check_engagement env clib.comp_enga; full_add_module clib.comp_name clib.comp_mod univs digest coq-8.6/checker/indtypes.ml0000644000175000017500000005052313022274260015261 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* DirPath.to_string sl | MPbound uid -> "bound("^MBId.to_string uid^")" | MPdot (mp,l) -> debug_string_of_mp mp ^ "." ^ Label.to_string l let rec string_of_mp = function | MPfile sl -> DirPath.to_string sl | MPbound uid -> MBId.to_string uid | MPdot (mp,l) -> string_of_mp mp ^ "." ^ Label.to_string l let string_of_mp mp = if !Flags.debug then debug_string_of_mp mp else string_of_mp mp let prkn kn = let (mp,_,l) = KerName.repr kn in str(string_of_mp mp ^ "." ^ Label.to_string l) let prcon c = let ck = Constant.canonical c in let uk = Constant.user c in if KerName.equal ck uk then prkn uk else (prkn uk ++str"(="++prkn ck++str")") (* Same as noccur_between but may perform reductions. Could be refined more... *) let weaker_noccur_between env x nvars t = if noccur_between x nvars t then Some t else let t' = whd_all env t in if noccur_between x nvars t' then Some t' else None let is_constructor_head t = match fst(decompose_app t) with | Rel _ -> true | _ -> false let conv_ctxt_prefix env (ctx1:rel_context) ctx2 = let rec chk env rctx1 rctx2 = match rctx1, rctx2 with (LocalAssum (_,ty1) as d1)::rctx1', LocalAssum (_,ty2)::rctx2' -> conv env ty1 ty2; chk (push_rel d1 env) rctx1' rctx2' | (LocalDef (_,bd1,ty1) as d1)::rctx1', LocalDef (_,bd2,ty2)::rctx2' -> conv env ty1 ty2; conv env bd1 bd2; chk (push_rel d1 env) rctx1' rctx2' | [],_ -> () | _ -> failwith "non convertible contexts" in chk env (List.rev ctx1) (List.rev ctx2) (************************************************************************) (* Various well-formedness check for inductive declarations *) (* Errors related to inductive constructions *) type inductive_error = | NonPos of env * constr * constr | NotEnoughArgs of env * constr * constr | NotConstructor of env * constr * constr | NonPar of env * constr * int * constr * constr | SameNamesTypes of Id.t | SameNamesConstructors of Id.t | SameNamesOverlap of Id.t list | NotAnArity of Id.t | BadEntry exception InductiveError of inductive_error (************************************************************************) (************************************************************************) (* Typing the arities and constructor types *) let rec sorts_of_constr_args env t = let t = whd_allnolet env t in match t with | Prod (name,c1,c2) -> let varj = infer_type env c1 in let env1 = push_rel (LocalAssum (name,c1)) env in varj :: sorts_of_constr_args env1 c2 | LetIn (name,def,ty,c) -> let env1 = push_rel (LocalDef (name,def,ty)) env in sorts_of_constr_args env1 c | _ when is_constructor_head t -> [] | _ -> anomaly ~label:"infos_and_sort" (Pp.str "not a positive constructor") (* Prop and Set are small *) let is_small_sort = function | Prop _ -> true | _ -> false let is_logic_sort = function | Prop Null -> true | _ -> false (* [infos] is a sequence of pair [islogic,issmall] for each type in the product of a constructor or arity *) let is_small_constr infos = List.for_all (fun s -> is_small_sort s) infos let is_logic_constr infos = List.for_all (fun s -> is_logic_sort s) infos (* An inductive definition is a "unit" if it has only one constructor and that all arguments expected by this constructor are logical, this is the case for equality, conjunction of logical properties *) let is_unit constrsinfos = match constrsinfos with (* One info = One constructor *) | [|constrinfos|] -> is_logic_constr constrinfos | [||] -> (* type without constructors *) true | _ -> false let small_unit constrsinfos = let issmall = Array.for_all is_small_constr constrsinfos and isunit = is_unit constrsinfos in issmall, isunit (* check information related to inductive arity *) let typecheck_arity env params inds = let nparamargs = rel_context_nhyps params in let nparamdecls = rel_context_length params in let check_arity arctxt = function | RegularArity mar -> let ar = mar.mind_user_arity in let _ = infer_type env ar in conv env (it_mkProd_or_LetIn (Sort mar.mind_sort) arctxt) ar; ar | TemplateArity par -> check_polymorphic_arity env params par; it_mkProd_or_LetIn (Sort(Type par.template_level)) arctxt in let env_arities = Array.fold_left (fun env_ar ind -> let ar_ctxt = ind.mind_arity_ctxt in let _ = check_ctxt env ar_ctxt in conv_ctxt_prefix env params ar_ctxt; (* Arities (with params) are typed-checked here *) let arity = check_arity ar_ctxt ind.mind_arity in (* mind_nrealargs *) let nrealargs = rel_context_nhyps ar_ctxt - nparamargs in if ind.mind_nrealargs <> nrealargs then failwith "bad number of real inductive arguments"; let nrealargs_ctxt = rel_context_length ar_ctxt - nparamdecls in if ind.mind_nrealdecls <> nrealargs_ctxt then failwith "bad length of real inductive arguments signature"; (* We do not need to generate the universe of full_arity; if later, after the validation of the inductive definition, full_arity is used as argument or subject to cast, an upper universe will be generated *) let id = ind.mind_typename in let env_ar' = push_rel (LocalAssum (Name id, arity)) env_ar in env_ar') env inds in env_arities (* Allowed eliminations *) let check_predicativity env s small level = match s, engagement env with Type u, _ -> (* let u' = fresh_local_univ () in *) (* let cst = *) (* merge_constraints (enforce_leq u u' empty_constraint) *) (* (universes env) in *) if not (Univ.check_leq (universes env) level u) then failwith "impredicative Type inductive type" | Prop Pos, ImpredicativeSet -> () | Prop Pos, _ -> if not small then failwith "impredicative Set inductive type" | Prop Null,_ -> () let sort_of_ind = function | RegularArity mar -> mar.mind_sort | TemplateArity par -> Type par.template_level let all_sorts = [InProp;InSet;InType] let small_sorts = [InProp;InSet] let logical_sorts = [InProp] let allowed_sorts issmall isunit s = match family_of_sort s with (* Type: all elimination allowed *) | InType -> all_sorts (* Small Set is predicative: all elimination allowed *) | InSet when issmall -> all_sorts (* Large Set is necessarily impredicative: forbids large elimination *) | InSet -> small_sorts (* Unitary/empty Prop: elimination to all sorts are realizable *) (* unless the type is large. If it is large, forbids large elimination *) (* which otherwise allows simulating the inconsistent system Type:Type *) | InProp when isunit -> if issmall then all_sorts else small_sorts (* Other propositions: elimination only to Prop *) | InProp -> logical_sorts let compute_elim_sorts env_ar params mib arity lc = let inst = extended_rel_list 0 params in let env_params = push_rel_context params env_ar in let lc = Array.map (fun c -> hnf_prod_applist env_params (lift (rel_context_length params) c) inst) lc in let s = sort_of_ind arity in let infos = Array.map (sorts_of_constr_args env_params) lc in let (small,unit) = small_unit infos in (* We accept recursive unit types... *) (* compute the max of the sorts of the products of the constructor type *) let level = max_inductive_sort (Array.concat (Array.to_list (Array.map Array.of_list infos))) in check_predicativity env_ar s small level; allowed_sorts small unit s let typecheck_one_inductive env params mib mip = (* mind_typename and mind_consnames not checked *) (* mind_reloc_tbl, mind_nb_constant, mind_nb_args not checked (VM) *) (* mind_arity_ctxt, mind_arity, mind_nrealargs DONE (typecheck_arity) *) (* mind_user_lc *) let _ = Array.map (infer_type env) mip.mind_user_lc in (* mind_nf_lc *) let _ = Array.map (infer_type env) mip.mind_nf_lc in Array.iter2 (conv env) mip.mind_nf_lc mip.mind_user_lc; (* mind_consnrealdecls *) let check_cons_args c n = let ctx,_ = decompose_prod_assum c in if n <> rel_context_length ctx - rel_context_length params then failwith "bad number of real constructor arguments" in Array.iter2 check_cons_args mip.mind_nf_lc mip.mind_consnrealdecls; (* mind_kelim: checked by positivity criterion ? *) let sorts = compute_elim_sorts env params mib mip.mind_arity mip.mind_nf_lc in let reject_sort s = not (List.mem_f family_equal s sorts) in if List.exists reject_sort mip.mind_kelim then failwith "elimination not allowed"; (* mind_recargs: checked by positivity criterion *) () (************************************************************************) (************************************************************************) (* Positivity *) type ill_formed_ind = | LocalNonPos of int | LocalNotEnoughArgs of int | LocalNotConstructor | LocalNonPar of int * int * int exception IllFormedInd of ill_formed_ind (* [mind_extract_params mie] extracts the params from an inductive types declaration, and checks that they are all present (and all the same) for all the given types. *) let mind_extract_params = decompose_prod_n_assum let explain_ind_err ntyp env0 nbpar c err = let (lpar,c') = mind_extract_params nbpar c in let env = push_rel_context lpar env0 in match err with | LocalNonPos kt -> raise (InductiveError (NonPos (env,c',Rel (kt+nbpar)))) | LocalNotEnoughArgs kt -> raise (InductiveError (NotEnoughArgs (env,c',Rel (kt+nbpar)))) | LocalNotConstructor -> raise (InductiveError (NotConstructor (env,c',Rel (ntyp+nbpar)))) | LocalNonPar (n,i,l) -> raise (InductiveError (NonPar (env,c',n,Rel i,Rel (l+nbpar)))) let failwith_non_pos n ntypes c = for k = n to n + ntypes - 1 do if not (noccurn k c) then raise (IllFormedInd (LocalNonPos (k-n+1))) done let failwith_non_pos_vect n ntypes v = Array.iter (failwith_non_pos n ntypes) v; anomaly ~label:"failwith_non_pos_vect" (Pp.str "some k in [n;n+ntypes-1] should occur") let failwith_non_pos_list n ntypes l = List.iter (failwith_non_pos n ntypes) l; anomaly ~label:"failwith_non_pos_list" (Pp.str "some k in [n;n+ntypes-1] should occur") (* Conclusion of constructors: check the inductive type is called with the expected parameters *) let check_correct_par (env,n,ntypes,_) hyps l largs = let nparams = rel_context_nhyps hyps in let largs = Array.of_list largs in if Array.length largs < nparams then raise (IllFormedInd (LocalNotEnoughArgs l)); let (lpar,largs') = Array.chop nparams largs in let nhyps = List.length hyps in let rec check k index = function | [] -> () | LocalDef _ :: hyps -> check k (index+1) hyps | _::hyps -> match whd_all env lpar.(k) with | Rel w when w = index -> check (k-1) (index+1) hyps | _ -> raise (IllFormedInd (LocalNonPar (k+1,index,l))) in check (nparams-1) (n-nhyps) hyps; if not (Array.for_all (noccur_between n ntypes) largs') then failwith_non_pos_vect n ntypes largs' (* Arguments of constructor: check the number of recursive parameters nrecp. the first parameters which are constant in recursive arguments n is the current depth, nmr is the maximum number of possible recursive parameters *) let check_rec_par (env,n,_,_) hyps nrecp largs = let (lpar,_) = List.chop nrecp largs in let rec find index = function | ([],_) -> () | (_,[]) -> failwith "number of recursive parameters cannot be greater than the number of parameters." | (lp,LocalDef _ :: hyps) -> find (index-1) (lp,hyps) | (p::lp,_::hyps) -> (match whd_all env p with | Rel w when w = index -> find (index-1) (lp,hyps) | _ -> failwith "bad number of recursive parameters") in find (n-1) (lpar,List.rev hyps) let lambda_implicit_lift n a = let lambda_implicit a = Lambda(Anonymous,Evar(0,[||]),a) in iterate lambda_implicit n (lift n a) (* This removes global parameters of the inductive types in lc (for nested inductive types only ) *) let abstract_mind_lc env ntyps npars lc = if npars = 0 then lc else let make_abs = List.init ntyps (function i -> lambda_implicit_lift npars (Rel (i+1))) in Array.map (substl make_abs) lc (* [env] is the typing environment [n] is the dB of the last inductive type [ntypes] is the number of inductive types in the definition (i.e. range of inductives is [n; n+ntypes-1]) [lra] is the list of recursive tree of each variable *) let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = (push_rel (LocalAssum (x,a)) env, n+1, ntypes, (Norec,ra)::lra) let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) = let auxntyp = 1 in let specif = lookup_mind_specif env mi in let env' = let decl = LocalAssum (Anonymous, hnf_prod_applist env (type_of_inductive env (specif,u)) lpar) in push_rel decl env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in (* New index of the inductive types *) let newidx = n + auxntyp in (env', newidx, ntypes, ra_env') let rec ienv_decompose_prod (env,_,_,_ as ienv) n c = if n=0 then (ienv,c) else let c' = whd_all env c in match c' with Prod(na,a,b) -> let ienv' = ienv_push_var ienv (na,a,mk_norec) in ienv_decompose_prod ienv' (n-1) b | _ -> assert false (* The recursive function that checks positivity and builds the list of recursive arguments *) let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc = let lparams = rel_context_length hyps in (* check the inductive types occur positively in [c] *) let rec check_pos (env, n, ntypes, ra_env as ienv) c = let x,largs = decompose_app (whd_all env c) in match x with | Prod (na,b,d) -> assert (List.is_empty largs); (match weaker_noccur_between env n ntypes b with None -> failwith_non_pos_list n ntypes [b] | Some b -> check_pos (ienv_push_var ienv (na, b, mk_norec)) d) | Rel k -> (try let (ra,rarg) = List.nth ra_env (k-1) in (match ra with Mrec _ -> check_rec_par ienv hyps nrecp largs | _ -> ()); if not (List.for_all (noccur_between n ntypes) largs) then failwith_non_pos_list n ntypes largs else rarg with Failure _ | Invalid_argument _ -> mk_norec) | Ind ind_kn -> (* If the inductive type being defined appears in a parameter, then we have an imbricated type *) if List.for_all (noccur_between n ntypes) largs then mk_norec else check_positive_imbr ienv (ind_kn, largs) | err -> if noccur_between n ntypes x && List.for_all (noccur_between n ntypes) largs then mk_norec else failwith_non_pos_list n ntypes (x::largs) (* accesses to the environment are not factorised, but is it worth it? *) and check_positive_imbr (env,n,ntypes,ra_env as ienv) ((mi,u), largs) = let (mib,mip) = lookup_mind_specif env mi in let auxnpar = mib.mind_nparams_rec in let nonrecpar = mib.mind_nparams - auxnpar in let (lpar,auxlargs) = try List.chop auxnpar largs with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in (* If the inductive appears in the args (non params) then the definition is not positive. *) if not (List.for_all (noccur_between n ntypes) auxlargs) then raise (IllFormedInd (LocalNonPos n)); (* We do not deal with imbricated mutual inductive types *) let auxntyp = mib.mind_ntypes in if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n)); (* The nested inductive type with parameters removed *) let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in (* Extends the environment with a variable corresponding to the inductive def *) let (env',_,_,_ as ienv') = ienv_push_inductive ienv ((mi,u),lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in let irecargs = (* fails if the inductive type occurs non positively *) (* with recursive parameters substituted *) Array.map (function c -> let c' = hnf_prod_applist env' c lpar' in (* skip non-recursive parameters *) let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in check_constructors ienv' false c') auxlcvect in (Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0) (* check the inductive types occur positively in the products of C, if check_head=true, also check the head corresponds to a constructor of the ith type *) and check_constructors ienv check_head c = let rec check_constr_rec (env,n,ntypes,ra_env as ienv) lrec c = let x,largs = decompose_app (whd_all env c) in match x with | Prod (na,b,d) -> assert (List.is_empty largs); let recarg = check_pos ienv b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in check_constr_rec ienv' (recarg::lrec) d | hd -> if check_head then match hd with | Rel j when j = (n + ntypes - i - 1) -> check_correct_par ienv hyps (ntypes-i) largs | _ -> raise (IllFormedInd LocalNotConstructor) else if not (List.for_all (noccur_between n ntypes) largs) then raise (IllFormedInd (LocalNonPos n)); List.rev lrec in check_constr_rec ienv [] c in let irecargs = Array.map (fun c -> let _,rawc = mind_extract_params lparams c in try check_constructors ienv true rawc with IllFormedInd err -> explain_ind_err (ntypes-i) env lparams c err) indlc in mk_paths (Mrec ind) irecargs let check_subtree t1 t2 = let cmp_labels l1 l2 = l1 == Norec || eq_recarg l1 l2 in if not (Rtree.equiv eq_recarg cmp_labels t1 t2) then failwith "bad recursive trees" (* if t1=t2 then () else msg_warning (str"TODO: check recursive positions")*) let check_positivity env_ar mind params nrecp inds = let ntypes = Array.length inds in let rc = Array.mapi (fun j t -> (Mrec(mind,j),t)) (Rtree.mk_rec_calls ntypes) in let lra_ind = List.rev (Array.to_list rc) in let lparams = rel_context_length params in let check_one i mip = let ra_env = List.init lparams (fun _ -> (Norec,mk_norec)) @ lra_ind in let ienv = (env_ar, 1+lparams, ntypes, ra_env) in check_positivity_one ienv params nrecp (mind,i) mip.mind_nf_lc in let irecargs = Array.mapi check_one inds in let wfp = Rtree.mk_rec irecargs in Array.iter2 (fun ind wfpi -> check_subtree ind.mind_recargs wfpi) inds wfp (************************************************************************) (************************************************************************) let check_inductive env kn mib = Flags.if_verbose Feedback.msg_notice (str " checking ind: " ++ MutInd.print kn); (* check mind_constraints: should be consistent with env *) let env = add_constraints (Univ.UContext.constraints mib.mind_universes) env in (* check mind_record : TODO ? check #constructor = 1 ? *) (* check mind_finite : always OK *) (* check mind_ntypes *) if Array.length mib.mind_packets <> mib.mind_ntypes then error "not the right number of packets"; (* check mind_params_ctxt *) let params = mib.mind_params_ctxt in let _ = check_ctxt env params in (* check mind_nparams *) if rel_context_nhyps params <> mib.mind_nparams then error "number the right number of parameters"; (* mind_packets *) (* - check arities *) let env_ar = typecheck_arity env params mib.mind_packets in (* - check constructor types *) Array.iter (typecheck_one_inductive env_ar params mib) mib.mind_packets; (* check mind_nparams_rec: positivity condition *) check_positivity env_ar kn params mib.mind_nparams_rec mib.mind_packets; (* check mind_equiv... *) (* Now we can add the inductive *) add_mind kn mib env coq-8.6/checker/indtypes.mli0000644000175000017500000000244213022274260015427 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Pp.std_ppcmds val prcon : constant -> Pp.std_ppcmds (*s The different kinds of errors that may result of a malformed inductive definition. *) (* Errors related to inductive constructions *) type inductive_error = | NonPos of env * constr * constr | NotEnoughArgs of env * constr * constr | NotConstructor of env * constr * constr | NonPar of env * constr * int * constr * constr | SameNamesTypes of Id.t | SameNamesConstructors of Id.t | SameNamesOverlap of Id.t list | NotAnArity of Id.t | BadEntry exception InductiveError of inductive_error (*s The following function does checks on inductive declarations. *) val check_inductive : env -> mutual_inductive -> mutual_inductive_body -> env coq-8.6/checker/inductive.mli0000644000175000017500000000554113022274260015565 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> pinductive * constr list type mind_specif = mutual_inductive_body * one_inductive_body (*s Fetching information in the environment about an inductive type. Raises [Not_found] if the inductive type is not found. *) val lookup_mind_specif : env -> inductive -> mind_specif val inductive_instance : mutual_inductive_body -> Univ.universe_instance val type_of_inductive : env -> mind_specif puniverses -> constr (* Return type as quoted by the user *) val type_of_constructor : pconstructor -> mind_specif -> constr val arities_of_specif : mutual_inductive puniverses -> mind_specif -> constr array (* [type_case_branches env (I,args) (p:A) c] computes useful types about the following Cases expression:

Cases (c :: (I args)) of b1..bn end It computes the type of every branch (pattern variables are introduced by products) and the type for the whole expression. *) val type_case_branches : env -> pinductive * constr list -> constr * constr -> constr -> constr array * constr (* Check a [case_info] actually correspond to a Case expression on the given inductive type. *) val check_case_info : env -> inductive -> case_info -> unit (*s Guard conditions for fix and cofix-points. *) val check_fix : env -> fixpoint -> unit val check_cofix : env -> cofixpoint -> unit (*s Support for sort-polymorphic inductive types *) val type_of_inductive_knowing_parameters : env -> mind_specif puniverses -> constr array -> constr val max_inductive_sort : sorts array -> Univ.universe val instantiate_universes : env -> rel_context -> template_arity -> constr array -> rel_context * sorts (***************************************************************) (* Debug *) type size = Large | Strict type subterm_spec = Subterm of (size * wf_paths) | Dead_code | Not_subterm type guard_env = { env : env; (* dB of last fixpoint *) rel_min : int; (* dB of variables denoting subterms *) genv : subterm_spec Lazy.t list; } type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec val branches_specif : guard_env -> subterm_spec Lazy.t -> case_info -> subterm_spec Lazy.t list array coq-8.6/checker/check_stat.mli0000644000175000017500000000114113022274260015673 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit coq-8.6/checker/typeops.mli0000644000175000017500000000156313022274260015276 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> constr val infer_type : env -> constr -> sorts val check_ctxt : env -> rel_context -> env val check_polymorphic_arity : env -> rel_context -> template_arity -> unit val type_of_constant_type : env -> constant_type -> constr coq-8.6/checker/main.ml0000644000175000017500000000003213022274260014334 0ustar mdenesmdenes let _ = Checker.start () coq-8.6/checker/modops.mli0000644000175000017500000000274113022274260015073 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* module_body -> module_type_body val is_functor : ('ty,'a) functorize -> bool val destr_functor : ('ty,'a) functorize -> MBId.t * 'ty * ('ty,'a) functorize (* adds a module and its components, but not the constraints *) val add_module : module_body -> env -> env val add_module_type : module_path -> module_type_body -> env -> env val strengthen : module_type_body -> module_path -> module_type_body val subst_and_strengthen : module_body -> module_path -> module_body val error_incompatible_modtypes : module_type_body -> module_type_body -> 'a val error_not_match : label -> structure_field_body -> 'a val error_with_module : unit -> 'a val error_no_such_label : label -> 'a val error_no_such_label_sub : label -> module_path -> 'a val error_not_a_constant : label -> 'a val error_not_a_module : label -> 'a coq-8.6/checker/analyze.mli0000644000175000017500000000142113022274260015227 0ustar mdenesmdenestype data = | Int of int | Ptr of int | Atm of int (* tag *) | Fun of int (* address *) type obj = | Struct of int * data array (* tag × data *) | String of string val parse_channel : in_channel -> (data * obj array) val parse_string : string -> (data * obj array) (** {6 Functorized version} *) module type Input = sig type t val input_byte : t -> int (** Input a single byte *) val input_binary_int : t -> int (** Input a big-endian 31-bits signed integer *) end (** Type of inputs *) module type S = sig type input val parse : input -> (data * obj array) (** Return the entry point and the reification of the memory out of a marshalled structure. *) end module Make (M : Input) : S with type input = M.t (** Functorized version of the previous code. *) coq-8.6/checker/cic.mli0000644000175000017500000003650113022274260014331 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* sorts_family val family_equal : sorts_family -> sorts_family -> bool val strip_outer_cast : constr -> constr val collapse_appl : constr -> constr val decompose_app : constr -> constr * constr list val applist : constr * constr list -> constr val iter_constr_with_binders : ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit exception LocalOccur val closedn : int -> constr -> bool val closed0 : constr -> bool val noccurn : int -> constr -> bool val noccur_between : int -> int -> constr -> bool val noccur_with_meta : int -> int -> constr -> bool val map_constr_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val exliftn : Esubst.lift -> constr -> constr val liftn : int -> int -> constr -> constr val lift : int -> constr -> constr type info = Closed | Open | Unknown type 'a substituend = { mutable sinfo : info; sit : 'a; } val lift_substituend : int -> constr substituend -> constr val make_substituend : 'a -> 'a substituend val substn_many : constr substituend array -> int -> constr -> constr val substnl : constr list -> int -> constr -> constr val substl : constr list -> constr -> constr val subst1 : constr -> constr -> constr val empty_rel_context : rel_context val rel_context_length : rel_context -> int val rel_context_nhyps : rel_context -> int val fold_rel_context : (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a val map_rel_decl : (constr -> constr) -> rel_declaration -> rel_declaration val map_rel_context : (constr -> constr) -> rel_context -> rel_context val extended_rel_list : int -> rel_context -> constr list val compose_lam : (name * constr) list -> constr -> constr val decompose_lam : constr -> (name * constr) list * constr val decompose_lam_n_assum : int -> constr -> rel_context * constr val mkProd_or_LetIn : rel_declaration -> constr -> constr val it_mkProd_or_LetIn : constr -> rel_context -> constr val decompose_prod_assum : constr -> rel_context * constr val decompose_prod_n_assum : int -> constr -> rel_context * constr type arity = rel_context * sorts val mkArity : arity -> constr val destArity : constr -> arity val isArity : constr -> bool val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool val eq_constr : constr -> constr -> bool (** Instance substitution for polymorphism. *) val subst_instance_constr : Univ.universe_instance -> constr -> constr val subst_instance_context : Univ.universe_instance -> rel_context -> rel_context coq-8.6/checker/closure.ml0000644000175000017500000007073613022274260015106 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* red_kind val fVAR : Id.t -> red_kind val no_red : reds val red_add : reds -> red_kind -> reds val mkflags : red_kind list -> reds val red_set : reds -> red_kind -> bool end module RedFlags = (struct (* [r_const=(true,cl)] means all constants but those in [cl] *) (* [r_const=(false,cl)] means only those in [cl] *) (* [r_delta=true] just mean [r_const=(true,[])] *) type reds = { r_beta : bool; r_delta : bool; r_const : transparent_state; r_zeta : bool; r_evar : bool; r_iota : bool } type red_kind = BETA | DELTA | IOTA | ZETA | CONST of constant | VAR of Id.t let fBETA = BETA let fDELTA = DELTA let fIOTA = IOTA let fZETA = ZETA let fCONST kn = CONST kn let fVAR id = VAR id let no_red = { r_beta = false; r_delta = false; r_const = all_opaque; r_zeta = false; r_evar = false; r_iota = false } let red_add red = function | BETA -> { red with r_beta = true } | DELTA -> { red with r_delta = true; r_const = all_transparent } | CONST kn -> let (l1,l2) = red.r_const in { red with r_const = l1, Cpred.add kn l2 } | IOTA -> { red with r_iota = true } | ZETA -> { red with r_zeta = true } | VAR id -> let (l1,l2) = red.r_const in { red with r_const = Id.Pred.add id l1, l2 } let mkflags = List.fold_left red_add no_red let red_set red = function | BETA -> incr_cnt red.r_beta beta | CONST kn -> let (_,l) = red.r_const in let c = Cpred.mem kn l in incr_cnt c delta | VAR id -> (* En attendant d'avoir des kn pour les Var *) let (l,_) = red.r_const in let c = Id.Pred.mem id l in incr_cnt c delta | ZETA -> incr_cnt red.r_zeta zeta | IOTA -> incr_cnt red.r_iota iota | DELTA -> (* Used for Rel/Var defined in context *) incr_cnt red.r_delta delta end : RedFlagsSig) open RedFlags let betadeltaiota = mkflags [fBETA;fDELTA;fZETA;fIOTA] let betadeltaiotanolet = mkflags [fBETA;fDELTA;fIOTA] let betaiotazeta = mkflags [fBETA;fIOTA;fZETA] (* specification of the reduction function *) (* Flags of reduction and cache of constants: 'a is a type that may be * mapped to constr. 'a infos implements a cache for constants and * abstractions, storing a representation (of type 'a) of the body of * this constant or abstraction. * * i_tab is the cache table of the results * * i_repr is the function to get the representation from the current * state of the cache and the body of the constant. The result * is stored in the table. * * i_rels = (4,[(1,c);(3,d)]) means there are 4 free rel variables * and only those with index 1 and 3 have bodies which are c and d resp. * * ref_value_cache searchs in the tab, otherwise uses i_repr to * compute the result and store it in the table. If the constant can't * be unfolded, returns None, but does not store this failure. * This * doesn't take the RESET into account. You mustn't keep such a table * after a Reset. * This type is not exported. Only its two * instantiations (cbv or lazy) are. *) type 'a tableKey = | ConstKey of 'a | VarKey of Id.t | RelKey of int type table_key = constant puniverses tableKey module KeyHash = struct type t = table_key let equal k1 k2 = match k1, k2 with | ConstKey (c1,u1), ConstKey (c2,u2) -> Constant.UserOrd.equal c1 c2 && Univ.Instance.equal u1 u2 | VarKey id1, VarKey id2 -> Id.equal id1 id2 | RelKey i1, RelKey i2 -> Int.equal i1 i2 | (ConstKey _ | VarKey _ | RelKey _), _ -> false open Hashset.Combine let hash = function | ConstKey (c,u) -> combinesmall 1 (Constant.UserOrd.hash c) | VarKey id -> combinesmall 2 (Id.hash id) | RelKey i -> combinesmall 3 (Int.hash i) end module KeyTable = Hashtbl.Make(KeyHash) type 'a infos = { i_flags : reds; i_repr : 'a infos -> constr -> 'a; i_env : env; i_rels : int * (int * constr) list; i_tab : 'a KeyTable.t } let ref_value_cache info ref = try Some (KeyTable.find info.i_tab ref) with Not_found -> try let body = match ref with | RelKey n -> let (s,l) = info.i_rels in lift n (Int.List.assoc (s-n) l) | VarKey id -> raise Not_found | ConstKey cst -> constant_value info.i_env cst in let v = info.i_repr info body in KeyTable.add info.i_tab ref v; Some v with | Not_found (* List.assoc *) | NotEvaluableConst _ (* Const *) -> None let defined_rels flags env = (* if red_local_const (snd flags) then*) fold_rel_context (fun decl (i,subs) -> match decl with | LocalAssum _ -> (i+1, subs) | LocalDef (_,body,_) -> (i+1, (i,body) :: subs)) (rel_context env) ~init:(0,[]) (* else (0,[])*) let mind_equiv_infos info = mind_equiv info.i_env let eq_table_key = KeyHash.equal let create mk_cl flgs env = { i_flags = flgs; i_repr = mk_cl; i_env = env; i_rels = defined_rels flgs env; i_tab = KeyTable.create 17 } (**********************************************************************) (* Lazy reduction: the one used in kernel operations *) (* type of shared terms. fconstr and frterm are mutually recursive. * Clone of the constr structure, but completely mutable, and * annotated with reduction state (reducible or not). * - FLIFT is a delayed shift; allows sharing between 2 lifted copies * of a given term. * - FCLOS is a delayed substitution applied to a constr * - FLOCKED is used to erase the content of a reference that must * be updated. This is to allow the garbage collector to work * before the term is computed. *) (* Norm means the term is fully normalized and cannot create a redex when substituted Cstr means the term is in head normal form and that it can create a redex when substituted (i.e. constructor, fix, lambda) Whnf means we reached the head normal form and that it cannot create a redex when substituted Red is used for terms that might be reduced *) type red_state = Norm | Cstr | Whnf | Red let neutr = function | (Whnf|Norm) -> Whnf | (Red|Cstr) -> Red type fconstr = { mutable norm: red_state; mutable term: fterm } and fterm = | FRel of int | FAtom of constr (* Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of pinductive | FConstruct of pconstructor | FApp of fconstr * fconstr array | FProj of projection * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCase of case_info * fconstr * fconstr * fconstr array | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (name * constr) list * constr * fconstr subs | FProd of name * fconstr * fconstr | FLetIn of name * fconstr * fconstr * constr * fconstr subs | FEvar of existential_key * fconstr array (* why diff from kernel/closure? *) | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED let fterm_of v = v.term let set_norm v = v.norm <- Norm (* Could issue a warning if no is still Red, pointing out that we loose sharing. *) let update v1 (no,t) = if !share then (v1.norm <- no; v1.term <- t; v1) else {norm=no;term=t} (**********************************************************************) (* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of int * int * projection | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr and stack = stack_member list let append_stack v s = if Array.length v = 0 then s else match s with | Zapp l :: s -> Zapp (Array.append v l) :: s | _ -> Zapp v :: s (* Collapse the shifts in the stack *) let zshift n s = match (n,s) with (0,_) -> s | (_,Zshift(k)::s) -> Zshift(n+k)::s | _ -> Zshift(n)::s (* Lifting. Preserves sharing (useful only for cell with norm=Red). lft_fconstr always create a new cell, while lift_fconstr avoids it when the lift is 0. *) let rec lft_fconstr n ft = match ft.term with | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)) -> ft | FRel i -> {norm=Norm;term=FRel(i+n)} | FLambda(k,tys,f,e) -> {norm=Cstr; term=FLambda(k,tys,f,subs_shft(n,e))} | FFix(fx,e) -> {norm=Cstr; term=FFix(fx,subs_shft(n,e))} | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))} | FLIFT(k,m) -> lft_fconstr (n+k) m | FLOCKED -> assert false | _ -> {norm=ft.norm; term=FLIFT(n,ft)} let lift_fconstr k f = if k=0 then f else lft_fconstr k f let lift_fconstr_vect k v = if k=0 then v else Array.map (fun f -> lft_fconstr k f) v let clos_rel e i = match expand_rel i e with | Inl(n,mt) -> lift_fconstr n mt | Inr(k,None) -> {norm=Norm; term= FRel k} | Inr(k,Some p) -> lift_fconstr (k-p) {norm=Red;term=FFlex(RelKey p)} (* since the head may be reducible, we might introduce lifts of 0 *) let compact_stack head stk = let rec strip_rec depth = function | Zshift(k)::s -> strip_rec (depth+k) s | Zupdate(m)::s -> (* Be sure to create a new cell otherwise sharing would be lost by the update operation *) let h' = lft_fconstr depth head in let _ = update m (h'.norm,h'.term) in strip_rec depth s | stk -> zshift depth stk in strip_rec 0 stk (* Put an update mark in the stack, only if needed *) let zupdate m s = if !share && m.norm = Red then let s' = compact_stack m s in let _ = m.term <- FLOCKED in Zupdate(m)::s' else s let mk_lambda env t = let (rvars,t') = decompose_lam t in FLambda(List.length rvars, List.rev rvars, t', env) let destFLambda clos_fun t = match t.term with FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b) | FLambda(n,(na,ty)::tys,b,e) -> (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)}) | _ -> assert false (* Optimization: do not enclose variables in a closure. Makes variable access much faster *) let mk_clos e t = match t with | Rel i -> clos_rel e i | Var x -> { norm = Red; term = FFlex (VarKey x) } | Const c -> { norm = Red; term = FFlex (ConstKey c) } | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } | Ind kn -> { norm = Norm; term = FInd kn } | Construct kn -> { norm = Cstr; term = FConstruct kn } | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _) -> {norm = Red; term = FCLOS(t,e)} let mk_clos_vect env v = Array.map (mk_clos env) v (* Translate the head constructor of t from constr to fconstr. This function is parameterized by the function to apply on the direct subterms. Could be used insted of mk_clos. *) let mk_clos_deep clos_fun env t = match t with | (Rel _|Ind _|Const _|Construct _|Var _|Meta _ | Sort _) -> mk_clos env t | Cast (a,k,b) -> { norm = Red; term = FCast (clos_fun env a, k, clos_fun env b)} | App (f,v) -> { norm = Red; term = FApp (clos_fun env f, Array.map (clos_fun env) v) } | Proj (p,c) -> { norm = Red; term = FProj (p, clos_fun env c) } | Case (ci,p,c,v) -> { norm = Red; term = FCaseT (ci, p, clos_fun env c, v, env) } | Fix fx -> { norm = Cstr; term = FFix (fx, env) } | CoFix cfx -> { norm = Cstr; term = FCoFix(cfx,env) } | Lambda _ -> { norm = Cstr; term = mk_lambda env t } | Prod (n,t,c) -> { norm = Whnf; term = FProd (n, clos_fun env t, clos_fun (subs_lift env) c) } | LetIn (n,b,t,c) -> { norm = Red; term = FLetIn (n, clos_fun env b, clos_fun env t, c, env) } | Evar(ev,args) -> { norm = Whnf; term = FEvar(ev,Array.map (clos_fun env) args) } (* A better mk_clos? *) let mk_clos2 = mk_clos_deep mk_clos (* The inverse of mk_clos_deep: move back to constr *) let rec to_constr constr_fun lfts v = match v.term with | FRel i -> Rel (reloc_rel i lfts) | FFlex (RelKey p) -> Rel (reloc_rel p lfts) | FFlex (VarKey x) -> Var x | FAtom c -> exliftn lfts c | FCast (a,k,b) -> Cast (constr_fun lfts a, k, constr_fun lfts b) | FFlex (ConstKey op) -> Const op | FInd op -> Ind op | FConstruct op -> Construct op | FCase (ci,p,c,ve) -> Case (ci, constr_fun lfts p, constr_fun lfts c, Array.map (constr_fun lfts) ve) | FCaseT (ci,p,c,ve,e) -> (* TODO: enable sharing, cf FCLOS below ? *) to_constr constr_fun lfts {norm=Red;term=FCase(ci,mk_clos2 e p,c,mk_clos_vect e ve)} | FFix ((op,(lna,tys,bds)),e) -> let n = Array.length bds in let ftys = Array.map (mk_clos e) tys in let fbds = Array.map (mk_clos (subs_liftn n e)) bds in let lfts' = el_liftn n lfts in Fix (op, (lna, Array.map (constr_fun lfts) ftys, Array.map (constr_fun lfts') fbds)) | FCoFix ((op,(lna,tys,bds)),e) -> let n = Array.length bds in let ftys = Array.map (mk_clos e) tys in let fbds = Array.map (mk_clos (subs_liftn n e)) bds in let lfts' = el_liftn (Array.length bds) lfts in CoFix (op, (lna, Array.map (constr_fun lfts) ftys, Array.map (constr_fun lfts') fbds)) | FApp (f,ve) -> App (constr_fun lfts f, Array.map (constr_fun lfts) ve) | FProj (p,c) -> Proj (p,constr_fun lfts c) | FLambda _ -> let (na,ty,bd) = destFLambda mk_clos2 v in Lambda (na, constr_fun lfts ty, constr_fun (el_lift lfts) bd) | FProd (n,t,c) -> Prod (n, constr_fun lfts t, constr_fun (el_lift lfts) c) | FLetIn (n,b,t,f,e) -> let fc = mk_clos2 (subs_lift e) f in LetIn (n, constr_fun lfts b, constr_fun lfts t, constr_fun (el_lift lfts) fc) | FEvar (ev,args) -> Evar(ev,Array.map (constr_fun lfts) args) | FLIFT (k,a) -> to_constr constr_fun (el_shft k lfts) a | FCLOS (t,env) -> let fr = mk_clos2 env t in let unfv = update v (fr.norm,fr.term) in to_constr constr_fun lfts unfv | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*) (* This function defines the correspondance between constr and fconstr. When we find a closure whose substitution is the identity, then we directly return the constr to avoid possibly huge reallocation. *) let term_of_fconstr = let rec term_of_fconstr_lift lfts v = match v.term with | FCLOS(t,env) when is_subs_id env && is_lift_id lfts -> t | FLambda(_,tys,f,e) when is_subs_id e && is_lift_id lfts -> compose_lam (List.rev tys) f | FCaseT(ci,p,c,b,env) when is_subs_id env && is_lift_id lfts -> Case(ci,p,term_of_fconstr_lift lfts c,b) | FFix(fx,e) when is_subs_id e && is_lift_id lfts -> Fix fx | FCoFix(cfx,e) when is_subs_id e && is_lift_id lfts -> CoFix cfx | _ -> to_constr term_of_fconstr_lift lfts v in term_of_fconstr_lift el_id (* fstrong applies unfreeze_fun recursively on the (freeze) term and * yields a term. Assumes that the unfreeze_fun never returns a * FCLOS term. let rec fstrong unfreeze_fun lfts v = to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v) *) let rec zip m stk = match stk with | [] -> m | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s | Zcase(ci,p,br)::s -> let t = FCase(ci, p, m, br) in zip {norm=neutr m.norm; term=t} s | ZcaseT(ci,p,br,e)::s -> let t = FCaseT(ci, p, m, br, e) in zip {norm=neutr m.norm; term=t} s | Zproj (i,j,cst) :: s -> zip {norm=neutr m.norm; term=FProj (cst,m)} s | Zfix(fx,par)::s -> zip fx (par @ append_stack [|m|] s) | Zshift(n)::s -> zip (lift_fconstr n m) s | Zupdate(rf)::s -> zip (update rf (m.norm,m.term)) s let fapp_stack (m,stk) = zip m stk (*********************************************************************) (* The assertions in the functions below are granted because they are called only when m is a constructor, a cofix (strip_update_shift_app), a fix (get_nth_arg) or an abstraction (strip_update_shift, through get_arg). *) (* optimised for the case where there are no shifts... *) let strip_update_shift_app head stk = assert (head.norm <> Red); let rec strip_rec rstk h depth = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s | (Zapp args :: s) -> strip_rec (Zapp args :: rstk) {norm=h.norm;term=FApp(h,args)} depth s | Zupdate(m)::s -> strip_rec rstk (update m (h.norm,h.term)) depth s | stk -> (depth,List.rev rstk, stk) in strip_rec [] head 0 stk let get_nth_arg head n stk = assert (head.norm <> Red); let rec strip_rec rstk h n = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) n s | Zapp args::s' -> let q = Array.length args in if n >= q then strip_rec (Zapp args::rstk) {norm=h.norm;term=FApp(h,args)} (n-q) s' else let bef = Array.sub args 0 n in let aft = Array.sub args (n+1) (q-n-1) in let stk' = List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in (Some (stk', args.(n)), append_stack aft s') | Zupdate(m)::s -> strip_rec rstk (update m (h.norm,h.term)) n s | s -> (None, List.rev rstk @ s) in strip_rec [] head n stk (* Beta reduction: look for an applied argument in the stack. Since the encountered update marks are removed, h must be a whnf *) let rec get_args n tys f e stk = match stk with Zupdate r :: s -> let _hd = update r (Cstr,FLambda(n,tys,f,e)) in get_args n tys f e s | Zshift k :: s -> get_args n tys f (subs_shft (k,e)) s | Zapp l :: s -> let na = Array.length l in if n == na then (Inl (subs_cons(l,e)),s) else if n < na then (* more arguments *) let args = Array.sub l 0 n in let eargs = Array.sub l n (na-n) in (Inl (subs_cons(args,e)), Zapp eargs :: s) else (* more lambdas *) let etys = List.skipn na tys in get_args (n-na) etys f (subs_cons(l,e)) s | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk) (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function | (Zapp _ | Zfix _ | Zcase _ | ZcaseT _ | Zproj _ | Zshift _ | Zupdate _ as e) :: s -> e :: eta_expand_stack s | [] -> [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]] (* Iota reduction: extract the arguments to be passed to the Case branches *) let rec reloc_rargs_rec depth stk = match stk with Zapp args :: s -> Zapp (lift_fconstr_vect depth args) :: reloc_rargs_rec depth s | Zshift(k)::s -> if k=depth then s else reloc_rargs_rec (depth-k) s | _ -> stk let reloc_rargs depth stk = if depth = 0 then stk else reloc_rargs_rec depth stk let rec try_drop_parameters depth n argstk = match argstk with Zapp args::s -> let q = Array.length args in if n > q then try_drop_parameters depth (n-q) s else if Int.equal n q then reloc_rargs depth s else let aft = Array.sub args n (q-n) in reloc_rargs depth (append_stack aft s) | Zshift(k)::s -> try_drop_parameters (depth-k) n s | [] -> if Int.equal n 0 then [] else raise Not_found | _ -> assert false (* strip_update_shift_app only produces Zapp and Zshift items *) let drop_parameters depth n argstk = try try_drop_parameters depth n argstk with Not_found -> assert false (* we know that n < stack_args_size(argstk) (if well-typed term) *) (** Projections and eta expansion *) let rec get_parameters depth n argstk = match argstk with Zapp args::s -> let q = Array.length args in if n > q then Array.append args (get_parameters depth (n-q) s) else if Int.equal n q then [||] else Array.sub args 0 n | Zshift(k)::s -> get_parameters (depth-k) n s | [] -> (* we know that n < stack_args_size(argstk) (if well-typed term) *) if Int.equal n 0 then [||] else raise Not_found (* Trying to eta-expand a partial application..., should do eta expansion first? *) | _ -> assert false (* strip_update_shift_app only produces Zapp and Zshift items *) let eta_expand_ind_stack env ind m s (f, s') = let mib = lookup_mind (fst ind) env in match mib.mind_record with | Some (Some (_,projs,pbs)) when mib.mind_finite <> CoFinite -> (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) let pars = mib.mind_nparams in let right = fapp_stack (f, s') in let (depth, args, s) = strip_update_shift_app m s in (** Try to drop the params, might fail on partially applied constructors. *) let argss = try_drop_parameters depth pars args in let hstack = Array.map (fun p -> { norm = Red; (* right can't be a constructor though *) term = FProj (Projection.make p false, right) }) projs in argss, [Zapp hstack] | _ -> raise Not_found (* disallow eta-exp for non-primitive records *) let rec project_nth_arg n argstk = match argstk with | Zapp args :: s -> let q = Array.length args in if n >= q then project_nth_arg (n - q) s else (* n < q *) args.(n) | _ -> assert false (* After drop_parameters we have a purely applicative stack *) (* Iota reduction: expansion of a fixpoint. * Given a fixpoint and a substitution, returns the corresponding * fixpoint body, and the substitution in which it should be * evaluated: its first variables are the fixpoint bodies * * FCLOS(fix Fi {F0 := T0 .. Fn-1 := Tn-1}, S) * -> (S. FCLOS(F0,S) . ... . FCLOS(Fn-1,S), Ti) *) (* does not deal with FLIFT *) let contract_fix_vect fix = let (thisbody, make_body, env, nfix) = match fix with | FFix (((reci,i),(_,_,bds as rdcl)),env) -> (bds.(i), (fun j -> { norm = Cstr; term = FFix (((reci,j),rdcl),env) }), env, Array.length bds) | FCoFix ((i,(_,_,bds as rdcl)),env) -> (bds.(i), (fun j -> { norm = Cstr; term = FCoFix ((j,rdcl),env) }), env, Array.length bds) | _ -> assert false in (subs_cons(Array.init nfix make_body, env), thisbody) (*********************************************************************) (* A machine that inspects the head of a term until it finds an atom or a subterm that may produce a redex (abstraction, constructor, cofix, letin, constant), or a neutral term (product, inductive) *) let rec knh info m stk = match m.term with | FLIFT(k,a) -> knh info a (zshift k stk) | FCLOS(t,e) -> knht info e t (zupdate m stk) | FLOCKED -> assert false | FApp(a,b) -> knh info a (append_stack b (zupdate m stk)) | FCase(ci,p,t,br) -> knh info t (Zcase(ci,p,br)::zupdate m stk) | FCaseT(ci,p,t,br,env) -> knh info t (ZcaseT(ci,p,br,env)::zupdate m stk) | FFix(((ri,n),(_,_,_)),_) -> (match get_nth_arg m ri.(n) stk with (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') | (None, stk') -> (m,stk')) | FCast(t,_,_) -> knh info t stk | FProj (p,c) -> if red_set info.i_flags (fCONST (Projection.constant p)) then (let pb = lookup_projection p (info.i_env) in knh info c (Zproj (pb.proj_npars, pb.proj_arg, p) :: zupdate m stk)) else (m,stk) (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) -> (m, stk) (* The same for pure terms *) and knht info e t stk = match t with | App(a,b) -> knht info e a (append_stack (mk_clos_vect e b) stk) | Case(ci,p,t,br) -> knht info e t (ZcaseT(ci, p, br, e)::stk) | Fix _ -> knh info (mk_clos2 e t) stk (* laziness *) | Cast(a,_,_) -> knht info e a stk | Rel n -> knh info (clos_rel e n) stk | Proj (p,c) -> knh info (mk_clos2 e t) stk (* laziness *) | (Lambda _|Prod _|Construct _|CoFix _|Ind _| LetIn _|Const _|Var _|Evar _|Meta _|Sort _) -> (mk_clos2 e t, stk) (************************************************************************) (* Computes a weak head normal form from the result of knh. *) let rec knr info m stk = match m.term with | FLambda(n,tys,f,e) when red_set info.i_flags fBETA -> (match get_args n tys f e stk with Inl e', s -> knit info e' f s | Inr lam, s -> (lam,s)) | FFlex(ConstKey kn) when red_set info.i_flags (fCONST (fst kn)) -> (match ref_value_cache info (ConstKey kn) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> (match ref_value_cache info (VarKey id) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FFlex(RelKey k) when red_set info.i_flags fDELTA -> (match ref_value_cache info (RelKey k) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FConstruct((ind,c),u) when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with (depth, args, Zcase(ci,_,br)::s) -> assert (ci.ci_npar>=0); let rargs = drop_parameters depth ci.ci_npar args in kni info br.(c-1) (rargs@s) | (depth, args, ZcaseT(ci,_,br,env)::s) -> assert (ci.ci_npar>=0); let rargs = drop_parameters depth ci.ci_npar args in knit info env br.(c-1) (rargs@s) | (_, cargs, Zfix(fx,par)::s) -> let rarg = fapp_stack(m,cargs) in let stk' = par @ append_stack [|rarg|] s in let (fxe,fxbd) = contract_fix_vect fx.term in knit info fxe fxbd stk' | (depth, args, Zproj (n, m, cst)::s) -> let rargs = drop_parameters depth n args in let rarg = project_nth_arg m rargs in kni info rarg s | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with (_, args, (((Zcase _|ZcaseT _)::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in knit info fxe fxbd (args@stk') | (_,args,s) -> (m,args@s)) | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> knit info (subs_cons([|v|],e)) bd stk | _ -> (m,stk) (* Computes the weak head normal form of a term *) and kni info m stk = let (hm,s) = knh info m stk in knr info hm s and knit info e t stk = let (ht,s) = knht info e t stk in knr info ht s let kh info v stk = fapp_stack(kni info v stk) (************************************************************************) (* Initialization and then normalization *) (* weak reduction *) let whd_val info v = with_stats (lazy (term_of_fconstr (kh info v []))) let inject = mk_clos (subs_id 0) let whd_stack infos m stk = let k = kni infos m stk in let _ = fapp_stack k in (* to unlock Zupdates! *) k (* cache of constants: the body is computed only when needed. *) type clos_infos = fconstr infos let infos_env x = x.i_env let infos_flags x = x.i_flags let create_clos_infos flgs env = create (fun _ -> inject) flgs env let unfold_reference = ref_value_cache coq-8.6/checker/reduction.ml0000644000175000017500000004571113022274260015421 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | Zupdate _::s -> is_empty_stack s | Zshift _::s -> is_empty_stack s | _ -> false (* Compute the lift to be performed on a term placed in a given stack *) let el_stack el stk = let n = List.fold_left (fun i z -> match z with Zshift n -> i+n | _ -> i) 0 stk in el_shft n el let compare_stack_shape stk1 stk2 = let rec compare_rec bal stk1 stk2 = match (stk1,stk2) with ([],[]) -> bal=0 | ((Zupdate _|Zshift _)::s1, _) -> compare_rec bal s1 stk2 | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 | ((Zcase(c1,_,_)|ZcaseT(c1,_,_,_))::s1, (Zcase(c2,_,_)|ZcaseT(c2,_,_,_))::s2) -> bal=0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> bal=0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 | (_,_) -> false in compare_rec 0 stk1 stk2 type lft_constr_stack_elt = Zlapp of (lift * fconstr) array | Zlproj of Names.projection * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list let rec zlapp v = function Zlapp v2 :: s -> zlapp (Array.append v v2) s | s -> Zlapp v :: s let pure_stack lfts stk = let rec pure_rec lfts stk = match stk with [] -> (lfts,[]) | zi::s -> (match (zi,pure_rec lfts s) with (Zupdate _,lpstk) -> lpstk | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) | (Zapp a, (l,pstk)) -> (l,zlapp (Array.map (fun t -> (l,t)) a) pstk) | (Zproj (n,m,c), (l,pstk)) -> (l, Zlproj (c,l)::pstk) | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) | (ZcaseT(ci,p,br,env),(l,pstk)) -> (l,Zlcase(ci,l,mk_clos env p,mk_clos_vect env br)::pstk) | (Zcase(ci,p,br),(l,pstk)) -> (l,Zlcase(ci,l,p,br)::pstk)) in snd (pure_rec lfts stk) (****************************************************************************) (* Reduction Functions *) (****************************************************************************) let whd_betaiotazeta x = match x with | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> x | _ -> whd_val (create_clos_infos betaiotazeta empty_env) (inject x) let whd_all env t = match t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> t | _ -> whd_val (create_clos_infos betadeltaiota env) (inject t) let whd_allnolet env t = match t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t | _ -> whd_val (create_clos_infos betadeltaiotanolet env) (inject t) (* Beta *) let beta_appvect c v = let rec stacklam env t stack = match t, stack with Lambda(_,_,c), arg::stacktl -> stacklam (arg::env) c stacktl | _ -> applist (substl env t, stack) in stacklam [] c (Array.to_list v) (********************************************************************) (* Conversion *) (********************************************************************) (* Conversion utility functions *) type 'a conversion_function = env -> 'a -> 'a -> unit exception NotConvertible exception NotConvertibleVect of int let convert_universes univ u u' = if Univ.Instance.check_eq univ u u' then () else raise NotConvertible let compare_stacks f fmind lft1 stk1 lft2 stk2 = let rec cmp_rec pstk1 pstk2 = match (pstk1,pstk2) with | (z1::s1, z2::s2) -> cmp_rec s1 s2; (match (z1,z2) with | (Zlapp a1,Zlapp a2) -> Array.iter2 f a1 a2 | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> f fx1 fx2; cmp_rec a1 a2 | (Zlproj (c1,l1),Zlproj (c2,l2)) -> if not (Names.eq_con_chk (Names.Projection.constant c1) (Names.Projection.constant c2)) then raise NotConvertible | (Zlcase(ci1,l1,p1,br1),Zlcase(ci2,l2,p2,br2)) -> if not (fmind ci1.ci_ind ci2.ci_ind) then raise NotConvertible; f (l1,p1) (l2,p2); Array.iter2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2 | _ -> assert false) | _ -> () in if compare_stack_shape stk1 stk2 then cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) else raise NotConvertible (* Convertibility of sorts *) type conv_pb = | CONV | CUMUL let sort_cmp env univ pb s0 s1 = match (s0,s1) with | (Prop c1, Prop c2) when pb = CUMUL -> if c1 = Pos && c2 = Null then raise NotConvertible | (Prop c1, Prop c2) -> if c1 <> c2 then raise NotConvertible | (Prop c1, Type u) -> (match pb with CUMUL -> () | _ -> raise NotConvertible) | (Type u1, Type u2) -> (** FIXME: handle type-in-type option here *) if (* snd (engagement env) == StratifiedType && *) not (match pb with | CONV -> Univ.check_eq univ u1 u2 | CUMUL -> Univ.check_leq univ u1 u2) then begin if !Flags.debug then begin let op = match pb with CONV -> "=" | CUMUL -> "<=" in Printf.eprintf "sort_cmp: %s\n%!" Pp.(string_of_ppcmds (str"Error: " ++ Univ.pr_uni u1 ++ str op ++ Univ.pr_uni u2 ++ str ":" ++ cut() ++ Univ.pr_universes univ)) end; raise NotConvertible end | (_, _) -> raise NotConvertible let rec no_arg_available = function | [] -> true | Zupdate _ :: stk -> no_arg_available stk | Zshift _ :: stk -> no_arg_available stk | Zapp v :: stk -> Array.length v = 0 && no_arg_available stk | Zproj _ :: _ -> true | Zcase _ :: _ -> true | ZcaseT _ :: _ -> true | Zfix _ :: _ -> true let rec no_nth_arg_available n = function | [] -> true | Zupdate _ :: stk -> no_nth_arg_available n stk | Zshift _ :: stk -> no_nth_arg_available n stk | Zapp v :: stk -> let k = Array.length v in if n >= k then no_nth_arg_available (n-k) stk else false | Zproj _ :: _ -> true | Zcase _ :: _ -> true | ZcaseT _ :: _ -> true | Zfix _ :: _ -> true let rec no_case_available = function | [] -> true | Zupdate _ :: stk -> no_case_available stk | Zshift _ :: stk -> no_case_available stk | Zapp _ :: stk -> no_case_available stk | Zproj (_,_,_) :: _ -> false | Zcase _ :: _ -> false | ZcaseT _ :: _ -> false | Zfix _ :: _ -> true let in_whnf (t,stk) = match fterm_of t with | (FLetIn _ | FCase _ | FCaseT _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false | FLambda _ -> no_arg_available stk | FConstruct _ -> no_case_available stk | FCoFix _ -> no_case_available stk | FFix(((ri,n),(_,_,_)),_) -> no_nth_arg_available ri.(n) stk | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _ | FProj _) -> true | FLOCKED -> assert false let oracle_order fl1 fl2 = match fl1,fl2 with ConstKey c1, ConstKey c2 -> (*height c1 > height c2*)false | _, ConstKey _ -> true | _ -> false let unfold_projection infos p c = let pb = lookup_projection p (infos_env infos) in let s = Zproj (pb.proj_npars, pb.proj_arg, p) in (c, s) (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 = eqappr univ cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = Control.check_for_interrupt (); (* First head reduce both terms *) let rec whd_both (t1,stk1) (t2,stk2) = let st1' = whd_stack infos t1 stk1 in let st2' = whd_stack infos t2 stk2 in (* Now, whd_stack on term2 might have modified st1 (due to sharing), and st1 might not be in whnf anymore. If so, we iterate ccnv. *) if in_whnf st1' then (st1',st2') else whd_both st1' st2' in let ((hd1,v1),(hd2,v2)) = whd_both st1 st2 in let appr1 = (lft1,(hd1,v1)) and appr2 = (lft2,(hd2,v2)) in (* compute the lifts that apply to the head of the term (hd1 and hd2) *) let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in match (fterm_of hd1, fterm_of hd2) with (* case of leaves *) | (FAtom a1, FAtom a2) -> (match a1, a2 with | (Sort s1, Sort s2) -> assert (is_empty_stack v1 && is_empty_stack v2); sort_cmp (infos_env infos) univ cv_pb s1 s2 | (Meta n, Meta m) -> if n=m then convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible | _ -> raise NotConvertible) | (FEvar (ev1,args1), FEvar (ev2,args2)) -> if ev1=ev2 then (convert_stacks univ infos lft1 lft2 v1 v2; convert_vect univ infos el1 el2 args1 args2) else raise NotConvertible (* 2 index known to be bound to no constant *) | (FRel n, FRel m) -> if reloc_rel n el1 = reloc_rel m el2 then convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try (* try first intensional equality *) if eq_table_key fl1 fl2 then convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible with NotConvertible -> (* else the oracle tells which constant is to be expanded *) let (app1,app2) = if oracle_order fl1 fl2 then match unfold_reference infos fl1 with | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2) | None -> (match unfold_reference infos fl2 with | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2)) | None -> raise NotConvertible) else match unfold_reference infos fl2 with | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2)) | None -> (match unfold_reference infos fl1 with | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2) | None -> raise NotConvertible) in eqappr univ cv_pb infos app1 app2) | (FProj (p1,c1), _) -> let (def1, s1) = unfold_projection infos p1 c1 in eqappr univ cv_pb infos (lft1, whd_stack infos def1 (s1 :: v1)) appr2 | (_, FProj (p2,c2)) -> let (def2, s2) = unfold_projection infos p2 c2 in eqappr univ cv_pb infos appr1 (lft2, whd_stack infos def2 (s2 :: v2)) (* other constructors *) | (FLambda _, FLambda _) -> (* Inconsistency: we tolerate that v1, v2 contain shift and update but we throw them away *) assert (is_empty_stack v1 && is_empty_stack v2); let (_,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in ccnv univ CONV infos el1 el2 ty1 ty2; ccnv univ CONV infos (el_lift el1) (el_lift el2) bd1 bd2 | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> assert (is_empty_stack v1 && is_empty_stack v2); (* Luo's system *) ccnv univ CONV infos el1 el2 c1 c'1; ccnv univ cv_pb infos (el_lift el1) (el_lift el2) c2 c'2 (* Eta-expansion on the fly *) | (FLambda _, _) -> if v1 <> [] then anomaly (Pp.str "conversion was given unreduced term (FLambda)"); let (_,_ty1,bd1) = destFLambda mk_clos hd1 in eqappr univ CONV infos (el_lift lft1,(bd1,[])) (el_lift lft2,(hd2,eta_expand_stack v2)) | (_, FLambda _) -> if v2 <> [] then anomaly (Pp.str "conversion was given unreduced term (FLambda)"); let (_,_ty2,bd2) = destFLambda mk_clos hd2 in eqappr univ CONV infos (el_lift lft1,(hd1,eta_expand_stack v1)) (el_lift lft2,(bd2,[])) (* only one constant, defined var or defined rel *) | (FFlex fl1, c2) -> (match unfold_reference infos fl1 with | Some def1 -> eqappr univ cv_pb infos (lft1, whd_stack infos def1 v1) appr2 | None -> match c2 with | FConstruct ((ind2,j2),u2) -> (try let v2, v1 = eta_expand_ind_stack (infos_env infos) ind2 hd2 v2 (snd appr1) in convert_stacks univ infos lft1 lft2 v1 v2 with Not_found -> raise NotConvertible) | _ -> raise NotConvertible) | (c1, FFlex fl2) -> (match unfold_reference infos fl2 with | Some def2 -> eqappr univ cv_pb infos appr1 (lft2, whd_stack infos def2 v2) | None -> match c1 with | FConstruct ((ind1,j1),u1) -> (try let v1, v2 = eta_expand_ind_stack (infos_env infos) ind1 hd1 v1 (snd appr2) in convert_stacks univ infos lft1 lft2 v1 v2 with Not_found -> raise NotConvertible) | _ -> raise NotConvertible) (* Inductive types: MutInd MutConstruct Fix Cofix *) | (FInd (ind1,u1), FInd (ind2,u2)) -> if mind_equiv_infos infos ind1 ind2 then (let () = convert_universes univ u1 u2 in convert_stacks univ infos lft1 lft2 v1 v2) else raise NotConvertible | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) -> if Int.equal j1 j2 && mind_equiv_infos infos ind1 ind2 then (let () = convert_universes univ u1 u2 in convert_stacks univ infos lft1 lft2 v1 v2) else raise NotConvertible (* Eta expansion of records *) | (FConstruct ((ind1,j1),u1), _) -> (try let v1, v2 = eta_expand_ind_stack (infos_env infos) ind1 hd1 v1 (snd appr2) in convert_stacks univ infos lft1 lft2 v1 v2 with Not_found -> raise NotConvertible) | (_, FConstruct ((ind2,j2),u2)) -> (try let v2, v1 = eta_expand_ind_stack (infos_env infos) ind2 hd2 v2 (snd appr1) in convert_stacks univ infos lft1 lft2 v1 v2 with Not_found -> raise NotConvertible) | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) -> if op1 = op2 then let n = Array.length cl1 in let fty1 = Array.map (mk_clos e1) tys1 in let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in convert_vect univ infos el1 el2 fty1 fty2; convert_vect univ infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2; convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> if op1 = op2 then let n = Array.length cl1 in let fty1 = Array.map (mk_clos e1) tys1 in let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in convert_vect univ infos el1 el2 fty1 fty2; convert_vect univ infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2; convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) | ( (FLetIn _, _) | (FCase _,_) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) | (_, FLetIn _) | (_,FCase _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false (* In all other cases, terms are not convertible *) | _ -> raise NotConvertible and convert_stacks univ infos lft1 lft2 stk1 stk2 = compare_stacks (fun (l1,t1) (l2,t2) -> ccnv univ CONV infos l1 l2 t1 t2) (mind_equiv_infos infos) lft1 stk1 lft2 stk2 and convert_vect univ infos lft1 lft2 v1 v2 = Array.iter2 (fun t1 t2 -> ccnv univ CONV infos lft1 lft2 t1 t2) v1 v2 let clos_fconv cv_pb eager_delta env t1 t2 = let infos = create_clos_infos (if eager_delta then betadeltaiota else betaiotazeta) env in let univ = universes env in ccnv univ cv_pb infos el_id el_id (inject t1) (inject t2) let fconv cv_pb eager_delta env t1 t2 = if eq_constr t1 t2 then () else clos_fconv cv_pb eager_delta env t1 t2 let conv = fconv CONV false let conv_leq = fconv CUMUL false (* option for conversion : no compilation for the checker *) let vm_conv cv_pb = fconv cv_pb true (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) (* pseudo-reduction rule: * [hnf_prod_app env s (Prod(_,B)) N --> B[N] * with an HNF on the first argument to produce a product. * if this does not work, then we use the string S as part of our * error message. *) let hnf_prod_app env t n = match whd_all env t with | Prod (_,_,b) -> subst1 n b | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product") let hnf_prod_applist env t nl = List.fold_left (hnf_prod_app env) t nl (* Dealing with arities *) let dest_prod env = let rec decrec env m c = let t = whd_all env c in match t with | Prod (n,a,c0) -> let d = LocalAssum (n,a) in decrec (push_rel d env) (d::m) c0 | _ -> m,t in decrec env empty_rel_context (* The same but preserving lets in the context, not internal ones. *) let dest_prod_assum env = let rec prodec_rec env l ty = let rty = whd_allnolet env ty in match rty with | Prod (x,t,c) -> let d = LocalAssum (x,t) in prodec_rec (push_rel d env) (d::l) c | LetIn (x,b,t,c) -> let d = LocalDef (x,b,t) in prodec_rec (push_rel d env) (d::l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> let rty' = whd_all env rty in if Term.eq_constr rty' rty then l, rty else prodec_rec env l rty' in prodec_rec env empty_rel_context let dest_lam_assum env = let rec lamec_rec env l ty = let rty = whd_allnolet env ty in match rty with | Lambda (x,t,c) -> let d = LocalAssum (x,t) in lamec_rec (push_rel d env) (d::l) c | LetIn (x,b,t,c) -> let d = LocalDef (x,b,t) in lamec_rec (push_rel d env) (d::l) c | Cast (c,_,_) -> lamec_rec env l c | _ -> l,rty in lamec_rec env empty_rel_context let dest_arity env c = let l, c = dest_prod_assum env c in match c with | Sort s -> l,s | _ -> error "not an arity" coq-8.6/checker/analyze.ml0000644000175000017500000002072713022274260015070 0ustar mdenesmdenes(** Headers *) let prefix_small_block = 0x80 let prefix_small_int = 0x40 let prefix_small_string = 0x20 let code_int8 = 0x00 let code_int16 = 0x01 let code_int32 = 0x02 let code_int64 = 0x03 let code_shared8 = 0x04 let code_shared16 = 0x05 let code_shared32 = 0x06 let code_double_array32_little = 0x07 let code_block32 = 0x08 let code_string8 = 0x09 let code_string32 = 0x0A let code_double_big = 0x0B let code_double_little = 0x0C let code_double_array8_big = 0x0D let code_double_array8_little = 0x0E let code_double_array32_big = 0x0F let code_codepointer = 0x10 let code_infixpointer = 0x11 let code_custom = 0x12 let code_block64 = 0x13 type code_descr = | CODE_INT8 | CODE_INT16 | CODE_INT32 | CODE_INT64 | CODE_SHARED8 | CODE_SHARED16 | CODE_SHARED32 | CODE_DOUBLE_ARRAY32_LITTLE | CODE_BLOCK32 | CODE_STRING8 | CODE_STRING32 | CODE_DOUBLE_BIG | CODE_DOUBLE_LITTLE | CODE_DOUBLE_ARRAY8_BIG | CODE_DOUBLE_ARRAY8_LITTLE | CODE_DOUBLE_ARRAY32_BIG | CODE_CODEPOINTER | CODE_INFIXPOINTER | CODE_CUSTOM | CODE_BLOCK64 let code_max = 0x13 let magic_number = "\132\149\166\190" (** Memory reification *) type repr = | RInt of int | RBlock of (int * int) (* tag × len *) | RString of string | RPointer of int | RCode of int type data = | Int of int (* value *) | Ptr of int (* pointer *) | Atm of int (* tag *) | Fun of int (* address *) type obj = | Struct of int * data array (* tag × data *) | String of string module type Input = sig type t val input_byte : t -> int val input_binary_int : t -> int end module type S = sig type input val parse : input -> (data * obj array) end module Make(M : Input) = struct open M type input = M.t let current_offset = ref 0 let input_byte chan = let () = incr current_offset in input_byte chan let input_binary_int chan = let () = current_offset := !current_offset + 4 in input_binary_int chan let input_char chan = Char.chr (input_byte chan) let parse_header chan = let () = current_offset := 0 in let magic = String.create 4 in let () = for i = 0 to 3 do magic.[i] <- input_char chan done in let length = input_binary_int chan in let objects = input_binary_int chan in let size32 = input_binary_int chan in let size64 = input_binary_int chan in (magic, length, size32, size64, objects) let input_int8s chan = let i = input_byte chan in if i land 0x80 = 0 then i else i lor ((-1) lsl 8) let input_int8u = input_byte let input_int16s chan = let i = input_byte chan in let j = input_byte chan in let ans = (i lsl 8) lor j in if i land 0x80 = 0 then ans else ans lor ((-1) lsl 16) let input_int16u chan = let i = input_byte chan in let j = input_byte chan in (i lsl 8) lor j let input_int32s chan = let i = input_byte chan in let j = input_byte chan in let k = input_byte chan in let l = input_byte chan in let ans = (i lsl 24) lor (j lsl 16) lor (k lsl 8) lor l in if i land 0x80 = 0 then ans else ans lor ((-1) lsl 31) let input_int32u chan = let i = input_byte chan in let j = input_byte chan in let k = input_byte chan in let l = input_byte chan in (i lsl 24) lor (j lsl 16) lor (k lsl 8) lor l let input_int64s chan = let i = input_byte chan in let j = input_byte chan in let k = input_byte chan in let l = input_byte chan in let m = input_byte chan in let n = input_byte chan in let o = input_byte chan in let p = input_byte chan in let ans = (i lsl 56) lor (j lsl 48) lor (k lsl 40) lor (l lsl 32) lor (m lsl 24) lor (n lsl 16) lor (o lsl 8) lor p in if i land 0x80 = 0 then ans else ans lor ((-1) lsl 63) let input_int64u chan = let i = input_byte chan in let j = input_byte chan in let k = input_byte chan in let l = input_byte chan in let m = input_byte chan in let n = input_byte chan in let o = input_byte chan in let p = input_byte chan in (i lsl 56) lor (j lsl 48) lor (k lsl 40) lor (l lsl 32) lor (m lsl 24) lor (n lsl 16) lor (o lsl 8) lor p let input_header32 chan = let i = input_byte chan in let j = input_byte chan in let k = input_byte chan in let l = input_byte chan in let tag = l in let len = (i lsl 14) lor (j lsl 6) lor (k lsr 2) in (tag, len) let input_header64 chan = let i = input_byte chan in let j = input_byte chan in let k = input_byte chan in let l = input_byte chan in let m = input_byte chan in let n = input_byte chan in let o = input_byte chan in let p = input_byte chan in let tag = p in let len = (i lsl 46) lor (j lsl 38) lor (k lsl 30) lor (l lsl 22) lor (m lsl 14) lor (n lsl 6) lor (o lsr 2) in (tag, len) let input_string len chan = let ans = String.create len in for i = 0 to pred len do ans.[i] <- input_char chan; done; ans let parse_object chan = let data = input_byte chan in if prefix_small_block <= data then let tag = data land 0x0F in let len = (data lsr 4) land 0x07 in RBlock (tag, len) else if prefix_small_int <= data then RInt (data land 0x3F) else if prefix_small_string <= data then let len = data land 0x1F in RString (input_string len chan) else if data > code_max then assert false else match (Obj.magic data) with | CODE_INT8 -> RInt (input_int8s chan) | CODE_INT16 -> RInt (input_int16s chan) | CODE_INT32 -> RInt (input_int32s chan) | CODE_INT64 -> RInt (input_int64s chan) | CODE_SHARED8 -> RPointer (input_int8u chan) | CODE_SHARED16 -> RPointer (input_int16u chan) | CODE_SHARED32 -> RPointer (input_int32u chan) | CODE_BLOCK32 -> RBlock (input_header32 chan) | CODE_BLOCK64 -> RBlock (input_header64 chan) | CODE_STRING8 -> let len = input_int8u chan in RString (input_string len chan) | CODE_STRING32 -> let len = input_int32u chan in RString (input_string len chan) | CODE_CODEPOINTER -> let addr = input_int32u chan in for i = 0 to 15 do ignore (input_byte chan); done; RCode addr | CODE_DOUBLE_ARRAY32_LITTLE | CODE_DOUBLE_BIG | CODE_DOUBLE_LITTLE | CODE_DOUBLE_ARRAY8_BIG | CODE_DOUBLE_ARRAY8_LITTLE | CODE_DOUBLE_ARRAY32_BIG | CODE_INFIXPOINTER | CODE_CUSTOM -> Printf.eprintf "Unhandled code %04x\n%!" data; assert false let parse chan = let (magic, len, _, _, size) = parse_header chan in let () = assert (magic = magic_number) in let memory = Array.make size (Struct ((-1), [||])) in let current_object = ref 0 in let fill_obj = function | RPointer n -> let data = Ptr (!current_object - n) in data, None | RInt n -> let data = Int n in data, None | RString s -> let data = Ptr !current_object in let () = memory.(!current_object) <- String s in let () = incr current_object in data, None | RBlock (tag, 0) -> (* Atoms are never shared *) let data = Atm tag in data, None | RBlock (tag, len) -> let data = Ptr !current_object in let nblock = Array.make len (Atm (-1)) in let () = memory.(!current_object) <- Struct (tag, nblock) in let () = incr current_object in data, Some nblock | RCode addr -> let data = Fun addr in data, None in let rec fill block off accu = if Array.length block = off then match accu with | [] -> () | (block, off) :: accu -> fill block off accu else let data, nobj = fill_obj (parse_object chan) in let () = block.(off) <- data in let block, off, accu = match nobj with | None -> block, succ off, accu | Some nblock -> nblock, 0, ((block, succ off) :: accu) in fill block off accu in let ans = [|Atm (-1)|] in let () = fill ans 0 [] in (ans.(0), memory) end module IChannel = struct type t = in_channel let input_byte = Pervasives.input_byte let input_binary_int = Pervasives.input_binary_int end module IString = struct type t = (string * int ref) let input_byte (s, off) = let ans = Char.code (s.[!off]) in let () = incr off in ans let input_binary_int chan = let i = input_byte chan in let j = input_byte chan in let k = input_byte chan in let l = input_byte chan in let ans = (i lsl 24) lor (j lsl 16) lor (k lsl 8) lor l in if i land 0x80 = 0 then ans else ans lor ((-1) lsl 31) end module PChannel = Make(IChannel) module PString = Make(IString) let parse_channel = PChannel.parse let parse_string s = PString.parse (s, ref 0) coq-8.6/checker/mod_checking.mli0000644000175000017500000000113513022274260016200 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Names.module_path -> Cic.module_body -> unit coq-8.6/checker/closure.mli0000644000175000017500000001350613022274260015247 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a (*s Delta implies all consts (both global (= by [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's. Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) type transparent_state = Id.Pred.t * Cpred.t val all_opaque : transparent_state val all_transparent : transparent_state val is_transparent_variable : transparent_state -> variable -> bool val is_transparent_constant : transparent_state -> constant -> bool (* Sets of reduction kinds. *) module type RedFlagsSig = sig type reds type red_kind (* The different kinds of reduction *) val fBETA : red_kind val fDELTA : red_kind val fIOTA : red_kind val fZETA : red_kind val fCONST : constant -> red_kind val fVAR : Id.t -> red_kind (* No reduction at all *) val no_red : reds (* Adds a reduction kind to a set *) val red_add : reds -> red_kind -> reds (* Build a reduction set from scratch = iter [red_add] on [no_red] *) val mkflags : red_kind list -> reds (* Tests if a reduction kind is set *) val red_set : reds -> red_kind -> bool end module RedFlags : RedFlagsSig open RedFlags val betadeltaiota : reds val betaiotazeta : reds val betadeltaiotanolet : reds (***********************************************************************) type 'a tableKey = | ConstKey of 'a | VarKey of Id.t | RelKey of int type table_key = constant puniverses tableKey type 'a infos val ref_value_cache: 'a infos -> table_key -> 'a option val create: ('a infos -> constr -> 'a) -> reds -> env -> 'a infos (************************************************************************) (*s Lazy reduction. *) (* [fconstr] is the type of frozen constr *) type fconstr (* [fconstr] can be accessed by using the function [fterm_of] and by matching on type [fterm] *) type fterm = | FRel of int | FAtom of constr (* Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of pinductive | FConstruct of pconstructor | FApp of fconstr * fconstr array | FProj of projection * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCase of case_info * fconstr * fconstr * fconstr array | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (name * constr) list * constr * fconstr subs | FProd of name * fconstr * fconstr | FLetIn of name * fconstr * fconstr * constr * fconstr subs | FEvar of existential_key * fconstr array | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED (************************************************************************) (*s A [stack] is a context of arguments, arguments are pushed by [append_stack] one array at a time but popped with [decomp_stack] one by one *) type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of int * int * projection | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr and stack = stack_member list val append_stack : fconstr array -> stack -> stack val eta_expand_stack : stack -> stack val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> (fconstr * stack) -> stack * stack (* To lazy reduce a constr, create a [clos_infos] with [create_clos_infos], inject the term to reduce with [inject]; then use a reduction function *) val inject : constr -> fconstr val fterm_of : fconstr -> fterm val term_of_fconstr : fconstr -> constr val destFLambda : (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr (* Global and local constant cache *) type clos_infos val create_clos_infos : reds -> env -> clos_infos val infos_env : clos_infos -> env val infos_flags : clos_infos -> reds (* Reduction function *) (* [whd_val] is for weak head normalization *) val whd_val : clos_infos -> fconstr -> constr (* [whd_stack] performs weak head normalization in a given stack. It stops whenever a reduction is blocked. *) val whd_stack : clos_infos -> fconstr -> stack -> fconstr * stack (* Conversion auxiliary functions to do step by step normalisation *) (* [unfold_reference] unfolds references in a [fconstr] *) val unfold_reference : clos_infos -> table_key -> fconstr option (* [mind_equiv] checks whether two inductive types are intentionally equal *) val mind_equiv_infos : clos_infos -> inductive -> inductive -> bool val eq_table_key : table_key -> table_key -> bool (************************************************************************) (*i This is for lazy debug *) val lift_fconstr : int -> fconstr -> fconstr val lift_fconstr_vect : int -> fconstr array -> fconstr array val mk_clos : fconstr subs -> constr -> fconstr val mk_clos_vect : fconstr subs -> constr array -> fconstr array val mk_clos_deep : (fconstr subs -> constr -> fconstr) -> fconstr subs -> constr -> fconstr val kni: clos_infos -> fconstr -> stack -> fconstr * stack val knr: clos_infos -> fconstr -> stack -> fconstr * stack val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr (* End of cbn debug section i*) coq-8.6/checker/univ.mli0000644000175000017500000001705313022274260014555 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int -> t (** Create a new universe level from a unique identifier and an associated module path. *) val equal : t -> t -> bool end type universe_level = Level.t (** Alias name. *) module Universe : sig type t (** Type of universes. A universe is defined as a set of level expressions. A level expression is built from levels and successors of level expressions, i.e.: le ::= l + n, n \in N. A universe is said atomic if it consists of a single level expression with no increment, and algebraic otherwise (think the least upper bound of a set of level expressions). *) val equal : t -> t -> bool (** Equality function on formal universes *) val make : Level.t -> t (** Create a universe representing the given level. *) end type universe = Universe.t (** Alias name. *) val pr_uni : universe -> Pp.std_ppcmds (** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *) val type0m_univ : universe val type0_univ : universe val type1_univ : universe val is_type0_univ : universe -> bool val is_type0m_univ : universe -> bool val is_univ_variable : universe -> bool val sup : universe -> universe -> universe val super : universe -> universe (** {6 Graphs of universes. } *) type universes type 'a check_function = universes -> 'a -> 'a -> bool val check_leq : universe check_function val check_eq : universe check_function (** The initial graph of universes: Prop < Set *) val initial_universes : universes (** Adds a universe to the graph, ensuring it is >= or > Set. @raises AlreadyDeclared if the level is already declared in the graph. *) exception AlreadyDeclared val add_universe : universe_level -> bool -> universes -> universes (** {6 Constraints. } *) type constraint_type = Lt | Le | Eq type univ_constraint = universe_level * constraint_type * universe_level module Constraint : Set.S with type elt = univ_constraint type constraints = Constraint.t val empty_constraint : constraints (** A value with universe constraints. *) type 'a constrained = 'a * constraints (** Enforcing constraints. *) type 'a constraint_function = 'a -> 'a -> constraints -> constraints val enforce_leq : universe constraint_function (** {6 ... } *) (** Merge of constraints in a universes graph. The function [merge_constraints] merges a set of constraints in a given universes graph. It raises the exception [UniverseInconsistency] if the constraints are not satisfiable. *) (** Type explanation is used to decorate error messages to provide useful explanation why a given constraint is rejected. It is composed of a path of universes and relation kinds [(r1,u1);..;(rn,un)] means .. <(r1) u1 <(r2) ... <(rn) un (where <(ri) is the relation symbol denoted by ri, currently only < and <=). The lowest end of the chain is supposed known (see UniverseInconsistency exn). The upper end may differ from the second univ of UniverseInconsistency because all universes in the path are canonical. Note that each step does not necessarily correspond to an actual constraint, but reflect how the system stores the graph and may result from combination of several constraints... *) type univ_inconsistency = constraint_type * universe * universe exception UniverseInconsistency of univ_inconsistency val merge_constraints : constraints -> universes -> universes val check_constraints : constraints -> universes -> bool (** {6 Support for universe polymorphism } *) (** Polymorphic maps from universe levels to 'a *) module LMap : CSig.MapS with type key = universe_level module LSet : CSig.SetS with type elt = universe_level type 'a universe_map = 'a LMap.t (** {6 Substitution} *) type universe_subst_fn = universe_level -> universe type universe_level_subst_fn = universe_level -> universe_level (** A full substitution, might involve algebraic universes *) type universe_subst = universe universe_map type universe_level_subst = universe_level universe_map val level_subst_of : universe_subst_fn -> universe_level_subst_fn (** {6 Universe instances} *) module Instance : sig type t (** A universe instance represents a vector of argument universes to a polymorphic definition (constant, inductive or constructor). *) val empty : t val is_empty : t -> bool val equal : t -> t -> bool (** Equality (note: instances are hash-consed, this is O(1)) *) val subst_fn : universe_level_subst_fn -> t -> t (** Substitution by a level-to-level function. *) val subst : universe_level_subst -> t -> t (** Substitution by a level-to-level function. *) val pr : t -> Pp.std_ppcmds (** Pretty-printing, no comments *) val check_eq : t check_function (** Check equality of instances w.r.t. a universe graph *) end type universe_instance = Instance.t type 'a puniverses = 'a * universe_instance (** A vector of universe levels with universe constraints, representiong local universe variables and associated constraints *) module UContext : sig type t val empty : t val make : universe_instance constrained -> t val instance : t -> Instance.t val constraints : t -> constraints end module ContextSet : sig type t val make : LSet.t -> constraints -> t val empty : t val constraints : t -> constraints end type universe_context = UContext.t type universe_context_set = ContextSet.t val merge_context : bool -> universe_context -> universes -> universes val merge_context_set : bool -> universe_context_set -> universes -> universes val empty_level_subst : universe_level_subst val is_empty_level_subst : universe_level_subst -> bool (** Substitution of universes. *) val subst_univs_level_level : universe_level_subst -> universe_level -> universe_level val subst_univs_level_universe : universe_level_subst -> universe -> universe (** Level to universe substitutions. *) val is_empty_subst : universe_subst -> bool val make_subst : universe_subst -> universe_subst_fn val subst_univs_universe : universe_subst_fn -> universe -> universe (** Substitution of instances *) val subst_instance_instance : universe_instance -> universe_instance -> universe_instance val subst_instance_universe : universe_instance -> universe -> universe val subst_instance_constraints : universe_instance -> constraints -> constraints (* val make_instance_subst : universe_instance -> universe_level_subst *) (* val make_inverse_instance_subst : universe_instance -> universe_level_subst *) (** Get the instantiated graph. *) val instantiate_univ_context : universe_context -> universe_context val instantiate_univ_constraints : universe_instance -> universe_context -> constraints (** Build the relative instance corresponding to the context *) val make_abstract_instance : universe_context -> universe_instance (** {6 Pretty-printing of universes. } *) val pr_universes : universes -> Pp.std_ppcmds coq-8.6/checker/check.mllib0000644000175000017500000000105313022274260015160 0ustar mdenesmdenesCoq_config Hook Terminal Canary Hashset Hashcons CSet CMap Int Dyn HMap Option Store Exninfo Backtrace Flags Control Pp_control Loc CList CString Serialize Stateid CObj CArray CStack Util Pp Ppstyle Xml_datatype Richpp Feedback Segmenttree Unicodetable Unicode CErrors CWarnings CEphemeron Future CUnix Minisys System Profile RemoteCounter Envars Predicate Rtree Names Univ Esubst Term Print Declarations Environ Closure Reduction Type_errors Modops Inductive Typeops Indtypes Subtyping Mod_checking Safe_typing Values Validate Check Check_stat Checker coq-8.6/checker/mod_checking.ml0000644000175000017500000001160213022274260016027 0ustar mdenesmdenes open Pp open Util open Names open Cic open Term open Reduction open Typeops open Indtypes open Modops open Subtyping open Declarations open Environ (** {6 Checking constants } *) let refresh_arity ar = let ctxt, hd = decompose_prod_assum ar in match hd with Sort (Type u) when not (Univ.is_univ_variable u) -> let ul = Univ.Level.make DirPath.empty 1 in let u' = Univ.Universe.make ul in let cst = Univ.enforce_leq u u' Univ.empty_constraint in let ctx = Univ.ContextSet.make (Univ.LSet.singleton ul) cst in mkArity (ctxt,Prop Null), ctx | _ -> ar, Univ.ContextSet.empty let check_constant_declaration env kn cb = Flags.if_verbose Feedback.msg_notice (str " checking cst: " ++ prcon kn); let env' = if cb.const_polymorphic then let inst = Univ.make_abstract_instance cb.const_universes in let ctx = Univ.UContext.make (inst, Univ.UContext.constraints cb.const_universes) in push_context ~strict:false ctx env else push_context ~strict:true cb.const_universes env in let envty, ty = match cb.const_type with RegularArity ty -> let ty', cu = refresh_arity ty in let envty = push_context_set cu env' in let _ = infer_type envty ty' in envty, ty | TemplateArity(ctxt,par) -> let _ = check_ctxt env' ctxt in check_polymorphic_arity env' ctxt par; env', it_mkProd_or_LetIn (Sort(Type par.template_level)) ctxt in let () = match body_of_constant cb with | Some bd -> (match cb.const_proj with | None -> let j = infer envty bd in conv_leq envty j ty | Some pb -> let env' = add_constant kn cb env' in let j = infer env' bd in conv_leq envty j ty) | None -> () in if cb.const_polymorphic then add_constant kn cb env else add_constant kn cb env' (** {6 Checking modules } *) (** We currently ignore the [mod_type_alg] and [typ_expr_alg] fields. The only delicate part is when [mod_expr] is an algebraic expression : we need to expand it before checking it is indeed a subtype of [mod_type]. Fortunately, [mod_expr] cannot contain any [MEwith]. *) let lookup_module mp env = try Environ.lookup_module mp env with Not_found -> failwith ("Unknown module: "^ModPath.to_string mp) let mk_mtb mp sign delta = { mod_mp = mp; mod_expr = Abstract; mod_type = sign; mod_type_alg = None; mod_constraints = Univ.ContextSet.empty; mod_delta = delta; mod_retroknowledge = []; } let rec check_module env mp mb = let (_:module_signature) = check_signature env mb.mod_type mb.mod_mp mb.mod_delta in let optsign = match mb.mod_expr with |Struct sign -> Some (check_signature env sign mb.mod_mp mb.mod_delta) |Algebraic me -> Some (check_mexpression env me mb.mod_mp mb.mod_delta) |Abstract|FullStruct -> None in match optsign with |None -> () |Some sign -> let mtb1 = mk_mtb mp sign mb.mod_delta and mtb2 = mk_mtb mp mb.mod_type mb.mod_delta in let env = add_module_type mp mtb1 env in Subtyping.check_subtypes env mtb1 mtb2 and check_module_type env mty = let (_:module_signature) = check_signature env mty.mod_type mty.mod_mp mty.mod_delta in () and check_structure_field env mp lab res = function | SFBconst cb -> let c = Constant.make2 mp lab in check_constant_declaration env c cb | SFBmind mib -> let kn = MutInd.make2 mp lab in let kn = mind_of_delta res kn in Indtypes.check_inductive env kn mib | SFBmodule msb -> let () = check_module env (MPdot(mp,lab)) msb in Modops.add_module msb env | SFBmodtype mty -> check_module_type env mty; add_modtype (MPdot(mp,lab)) mty env and check_mexpr env mse mp_mse res = match mse with | MEident mp -> let mb = lookup_module mp env in (subst_and_strengthen mb mp_mse).mod_type | MEapply (f,mp) -> let sign = check_mexpr env f mp_mse res in let farg_id, farg_b, fbody_b = destr_functor sign in let mtb = module_type_of_module (Some mp) (lookup_module mp env) in check_subtypes env mtb farg_b; subst_signature (map_mbid farg_id mp) fbody_b | MEwith _ -> error_with_module () and check_mexpression env sign mp_mse res = match sign with | MoreFunctor (arg_id, mtb, body) -> check_module_type env mtb; let env' = add_module_type (MPbound arg_id) mtb env in let body = check_mexpression env' body mp_mse res in MoreFunctor(arg_id,mtb,body) | NoFunctor me -> check_mexpr env me mp_mse res and check_signature env sign mp_mse res = match sign with | MoreFunctor (arg_id, mtb, body) -> check_module_type env mtb; let env' = add_module_type (MPbound arg_id) mtb env in let body = check_signature env' body mp_mse res in MoreFunctor(arg_id,mtb,body) | NoFunctor struc -> let (_:env) = List.fold_left (fun env (lab,mb) -> check_structure_field env mp_mse lab res mb) env struc in NoFunctor struc coq-8.6/checker/print.ml0000644000175000017500000001202613022274260014552 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* print_string "#"; print_int n | Meta n -> print_string "Meta("; print_int n; print_string ")" | Var id -> print_string (Id.to_string id) | Sort s -> sort_display s | Cast (c,_, t) -> open_hovbox 1; print_string "("; (term_display c); print_cut(); print_string "::"; (term_display t); print_string ")"; close_box() | Prod (Name(id),t,c) -> open_hovbox 1; print_string"("; print_string (Id.to_string id); print_string ":"; box_display t; print_string ")"; print_cut(); box_display c; close_box() | Prod (Anonymous,t,c) -> print_string"("; box_display t; print_cut(); print_string "->"; box_display c; print_string ")"; | Lambda (na,t,c) -> print_string "["; name_display na; print_string ":"; box_display t; print_string "]"; print_cut(); box_display c; | LetIn (na,b,t,c) -> print_string "["; name_display na; print_string "="; box_display b; print_cut(); print_string ":"; box_display t; print_string "]"; print_cut(); box_display c; | App (c,l) -> print_string "("; box_display c; Array.iter (fun x -> print_space (); box_display x) l; print_string ")" | Evar _ -> print_string "Evar#" | Const (c,u) -> print_string "Cons("; sp_con_display c; print_string ","; print_instance u; print_string ")" | Ind ((sp,i),u) -> print_string "Ind("; sp_display sp; print_string ","; print_int i; print_string ","; print_instance u; print_string ")" | Construct (((sp,i),j),u) -> print_string "Constr("; sp_display sp; print_string ","; print_int i; print_string ","; print_int j; print_string ","; print_instance u; print_string ")" | Case (ci,p,c,bl) -> open_vbox 0; print_string "<"; box_display p; print_string ">"; print_cut(); print_string "Case"; print_space(); box_display c; print_space (); print_string "of"; open_vbox 0; Array.iter (fun x -> print_cut(); box_display x) bl; close_box(); print_cut(); print_string "end"; close_box() | Fix ((t,i),(lna,tl,bl)) -> print_string "Fix("; print_int i; print_string ")"; print_cut(); open_vbox 0; let print_fix () = for k = 0 to (Array.length tl) - 1 do open_vbox 0; name_display lna.(k); print_string "/"; print_int t.(k); print_cut(); print_string ":"; box_display tl.(k) ; print_cut(); print_string ":="; box_display bl.(k); close_box (); print_cut() done in print_string"{"; print_fix(); print_string"}" | CoFix(i,(lna,tl,bl)) -> print_string "CoFix("; print_int i; print_string ")"; print_cut(); open_vbox 0; let print_fix () = for k = 0 to (Array.length tl) - 1 do open_vbox 1; name_display lna.(k); print_cut(); print_string ":"; box_display tl.(k) ; print_cut(); print_string ":="; box_display bl.(k); close_box (); print_cut(); done in print_string"{"; print_fix (); print_string"}" | Proj (p, c) -> print_string "Proj("; sp_con_display (Projection.constant p); print_string ","; box_display c; print_string ")" and box_display c = open_hovbox 1; term_display c; close_box() and sort_display = function | Prop(Pos) -> print_string "Set" | Prop(Null) -> print_string "Prop" | Type u -> print_string "Type("; chk_pp (Univ.pr_uni u); print_string ")" and name_display = function | Name id -> print_string (Id.to_string id) | Anonymous -> print_string "_" (* Remove the top names for library and Scratch to avoid long names *) and sp_display sp = (* let dir,l = decode_kn sp in let ls = match List.rev_map Id.to_string (DirPath.repr dir) with ("Top"::l)-> l | ("Coq"::_::l) -> l | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) print_string (MutInd.debug_to_string sp) and sp_con_display sp = (* let dir,l = decode_kn sp in let ls = match List.rev_map Id.to_string (DirPath.repr dir) with ("Top"::l)-> l | ("Coq"::_::l) -> l | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) print_string (Constant.debug_to_string sp) in try box_display csr; print_flush() with e -> print_string (Printexc.to_string e);print_flush (); raise e coq-8.6/checker/reduction.mli0000644000175000017500000000353213022274260015565 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr val whd_all : env -> constr -> constr val whd_allnolet : env -> constr -> constr (************************************************************************) (*s conversion functions *) exception NotConvertible exception NotConvertibleVect of int type 'a conversion_function = env -> 'a -> 'a -> unit type conv_pb = CONV | CUMUL val conv : constr conversion_function val conv_leq : constr conversion_function val vm_conv : conv_pb -> constr conversion_function (************************************************************************) (* Builds an application node, reducing beta redexes it may produce. *) val beta_appvect : constr -> constr array -> constr (* Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *) val hnf_prod_applist : env -> constr -> constr list -> constr (************************************************************************) (*s Recognizing products and arities modulo reduction *) val dest_prod : env -> constr -> rel_context * constr val dest_prod_assum : env -> constr -> rel_context * constr val dest_lam_assum : env -> constr -> rel_context * constr val dest_arity : env -> constr -> arity coq-8.6/checker/subtyping.mli0000644000175000017500000000132513022274260015613 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* module_type_body -> module_type_body -> unit coq-8.6/checker/Makefile0000644000175000017500000000401313022274260014521 0ustar mdenesmdenesOCAMLC=ocamlc OCAMLOPT=ocamlopt COQSRC=.. MLDIRS=-I $(COQSRC)/config -I $(COQSRC)/lib -I $(COQSRC)/kernel -I +camlp4 BYTEFLAGS=$(MLDIRS) OPTFLAGS=$(MLDIRS) CHECKERNAME=coqchk BINARIES=../bin/$(CHECKERNAME)$(EXE) ../bin/$(CHECKERNAME).opt$(EXE) MCHECKERLOCAL :=\ declarations.cmo environ.cmo \ closure.cmo reduction.cmo \ type_errors.cmo \ modops.cmo \ inductive.cmo typeops.cmo \ indtypes.cmo subtyping.cmo mod_checking.cmo \ validate.cmo \ safe_typing.cmo check.cmo \ check_stat.cmo checker.cmo MCHECKER:=\ $(COQSRC)/config/coq_config.cmo \ $(COQSRC)/lib/pp_control.cmo $(COQSRC)/lib/pp.cmo $(COQSRC)/lib/compat.cmo \ $(COQSRC)/lib/util.cmo $(COQSRC)/lib/option.cmo $(COQSRC)/lib/hashcons.cmo \ $(COQSRC)/lib/system.cmo $(COQSRC)/lib/flags.cmo \ $(COQSRC)/lib/predicate.cmo $(COQSRC)/lib/rtree.cmo \ $(COQSRC)/kernel/names.cmo $(COQSRC)/kernel/univ.cmo \ $(COQSRC)/kernel/esubst.cmo term.cmo \ $(MCHECKERLOCAL) all: $(BINARIES) byte : ../bin/$(CHECKERNAME)$(EXE) opt : ../bin/$(CHECKERNAME).opt$(EXE) check.cma: $(MCHECKERLOCAL) ocamlc $(BYTEFLAGS) -a -o $@ $(MCHECKER) check.cmxa: $(MCHECKERLOCAL:.cmo=.cmx) ocamlopt $(OPTFLAGS) -a -o $@ $(MCHECKER:.cmo=.cmx) ../bin/$(CHECKERNAME)$(EXE): check.cma ocamlc $(BYTEFLAGS) -o $@ unix.cma gramlib.cma check.cma main.ml ../bin/$(CHECKERNAME).opt$(EXE): check.cmxa ocamlopt $(OPTFLAGS) -o $@ unix.cmxa gramlib.cmxa check.cmxa main.ml stats: @echo STRUCTURE @wc names.ml term.ml declarations.ml environ.ml type_errors.ml @echo @echo REDUCTION @-wc esubst.ml closure.ml reduction.ml @echo @echo TYPAGE @wc univ.ml inductive.ml indtypes.ml typeops.ml safe_typing.ml @echo @echo MODULES @wc modops.ml subtyping.ml @echo @echo INTERFACE @wc check*.ml main.ml @echo @echo TOTAL @wc *.ml | tail -1 .SUFFIXES:.ml .mli .cmi .cmo .cmx .ml.cmo: $(OCAMLC) -c $(BYTEFLAGS) $< .ml.cmx: $(OCAMLOPT) -c $(OPTFLAGS) $< .mli.cmi: $(OCAMLC) -c $(BYTEFLAGS) $< depend:: ocamldep *.ml* > .depend clean:: rm -f *.cm* *.o *.a *~ $(BINARIES) -include .depend coq-8.6/checker/votour.ml0000644000175000017500000002532213022274260014757 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* quit () in if l = "u" then None else if l = "x" then quit () else try let v = int_of_string l in if v < 0 || v >= max then let () = Printf.printf "Out-of-range input! (only %d children)\n%!" max in read_num max else Some v with Failure "int_of_string" -> Printf.printf "Unrecognized input! enters the -th child, u goes up 1 level, x exits\n%!"; read_num max type 'a repr = | INT of int | STRING of string | BLOCK of int * 'a array | OTHER module type S = sig type obj val input : in_channel -> obj val repr : obj -> obj repr val size : obj -> int val oid : obj -> int option end module ReprObj : S = struct type obj = Obj.t * int list let input chan = let obj = input_value chan in let () = CObj.register_shared_size obj in (obj, []) let repr (obj, pos) = if Obj.is_block obj then let tag = Obj.tag obj in if tag = Obj.string_tag then STRING (Obj.magic obj) else if tag < Obj.no_scan_tag then let init i = (Obj.field obj i, i :: pos) in let data = Array.init (Obj.size obj) init in BLOCK (tag, Obj.magic data) else OTHER else INT (Obj.magic obj) let size (_, p) = CObj.shared_size_of_pos p let oid _ = None end module ReprMem : S = struct open Analyze type obj = data let memory = ref [||] let sizes = ref [||] (** size, in words *) let ws = Sys.word_size / 8 let rec init_size seen = function | Int _ | Atm _ | Fun _ -> 0 | Ptr p -> if seen.(p) then 0 else let () = seen.(p) <- true in match (!memory).(p) with | Struct (tag, os) -> let fold accu o = accu + 1 + init_size seen o in let size = Array.fold_left fold 1 os in let () = (!sizes).(p) <- size in size | String s -> let size = 2 + (String.length s / ws) in let () = (!sizes).(p) <- size in size let size = function | Int _ | Atm _ | Fun _ -> 0 | Ptr p -> (!sizes).(p) let repr = function | Int i -> INT i | Atm t -> BLOCK (t, [||]) | Fun _ -> OTHER | Ptr p -> match (!memory).(p) with | Struct (tag, os) -> BLOCK (tag, os) | String s -> STRING s let input ch = let obj, mem = parse_channel ch in let () = memory := mem in let () = sizes := Array.make (Array.length mem) (-1) in let seen = Array.make (Array.length mem) false in let _ = init_size seen obj in obj let oid = function | Int _ | Atm _ | Fun _ -> None | Ptr p -> Some p end module Visit (Repr : S) : sig val init : unit -> unit val visit : Values.value -> Repr.obj -> int list -> unit end = struct (** Name of a value *) let rec get_name ?(extra=false) = function |Any -> "?" |Fail s -> "Invalid node: "^s |Tuple (name,_) -> name |Sum (name,_,_) -> name |Array v -> "array"^(if extra then "/"^get_name ~extra v else "") |List v -> "list"^(if extra then "/"^get_name ~extra v else "") |Opt v -> "option"^(if extra then "/"^get_name ~extra v else "") |Int -> "int" |String -> "string" |Annot (s,v) -> s^"/"^get_name ~extra v |Dyn -> "" (** For tuples, its quite handy to display the inner 1st string (if any). Cf. [structure_body] for instance *) let get_string_in_tuple o = try for i = 0 to Array.length o - 1 do match Repr.repr o.(i) with | STRING s -> failwith (Printf.sprintf " [..%s..]" s) | _ -> () done; "" with Failure s -> s (** Some details : tags, integer value for non-block, etc etc *) let rec get_details v o = match v, Repr.repr o with | (String | Any), STRING s -> Printf.sprintf " [%s]" (String.escaped s) |Tuple (_,v), BLOCK (_, o) -> get_string_in_tuple o |(Sum _|Any), BLOCK (tag, _) -> Printf.sprintf " [tag=%i]" tag |(Sum _|Any), INT i -> Printf.sprintf " [imm=%i]" i |Int, INT i -> Printf.sprintf " [imm=%i]" i |Annot (s,v), _ -> get_details v o |_ -> "" let get_oid obj = match Repr.oid obj with | None -> "" | Some id -> Printf.sprintf " [0x%08x]" id let node_info (v,o,p) = get_name ~extra:true v ^ get_details v o ^ " (size "^ string_of_int (Repr.size o)^"w)" ^ get_oid o (** Children of a block : type, object, position. For lists, we collect all elements of the list at once *) let access_children vs os pos = if Array.length os = Array.length vs then Array.mapi (fun i v -> v, os.(i), i::pos) vs else raise Exit let access_list v o pos = let rec loop o pos = match Repr.repr o with | INT 0 -> [] | BLOCK (0, [|hd; tl|]) -> (v, hd, 0 :: pos) :: loop tl (1 :: pos) | _ -> raise Exit in Array.of_list (loop o pos) let access_block o = match Repr.repr o with | BLOCK (tag, os) -> (tag, os) | _ -> raise Exit let access_int o = match Repr.repr o with INT i -> i | _ -> raise Exit (** raises Exit if the object has not the expected structure *) let rec get_children v o pos = match v with |Tuple (_, v) -> let (_, os) = access_block o in access_children v os pos |Sum (_, _, vv) -> begin match Repr.repr o with | BLOCK (tag, os) -> access_children vv.(tag) os pos | INT _ -> [||] | _ -> raise Exit end |Array v -> let (_, os) = access_block o in access_children (Array.make (Array.length os) v) os pos |List v -> access_list v o pos |Opt v -> begin match Repr.repr o with | INT 0 -> [||] | BLOCK (0, [|x|]) -> [|(v, x, 0 :: pos)|] | _ -> raise Exit end |String | Int -> [||] |Annot (s,v) -> get_children v o pos |Any -> raise Exit |Dyn -> begin match Repr.repr o with | BLOCK (0, [|id; o|]) -> let n = access_int id in let tpe = find_dyn n in [|(Int, id, 0 :: pos); (tpe, o, 1 :: pos)|] | _ -> raise Exit end |Fail s -> failwith "forbidden" let get_children v o pos = try get_children v o pos with Exit -> match Repr.repr o with | BLOCK (_, os) -> Array.mapi (fun i o -> Any, o, i :: pos) os | _ -> [||] type info = { nam : string; typ : value; obj : Repr.obj; pos : int list } let stk = ref ([] : info list) let init () = stk := [] let push name v o p = stk := { nam = name; typ = v; obj = o; pos = p } :: !stk let pop () = match !stk with | i::s -> stk := s; i | _ -> failwith "empty stack" let rec visit v o pos = Printf.printf "\nDepth %d Pos %s Context %s\n" (List.length !stk) (String.concat "." (List.rev_map string_of_int pos)) (String.concat "/" (List.rev_map (fun i -> i.nam) !stk)); Printf.printf "-------------\n"; let children = get_children v o pos in let nchild = Array.length children in Printf.printf "Here: %s, %d child%s\n" (node_info (v,o,pos)) nchild (if nchild = 0 then "" else "ren:"); Array.iteri (fun i vop -> Printf.printf " %d: %s\n" i (node_info vop)) children; Printf.printf "-------------\n"; try match read_num (Array.length children) with | None -> let info = pop () in visit info.typ info.obj info.pos | Some child -> let v',o',pos' = children.(child) in push (get_name v) v o pos; visit v' o' pos' with | Failure "empty stack" -> () | Failure "forbidden" -> let info = pop () in visit info.typ info.obj info.pos | Failure _ | Invalid_argument _ -> visit v o pos end (** Loading the vo *) type header = { magic : string; (** Magic number of the marshaller *) length : int; (** Size on disk in bytes *) size32 : int; (** Size in words when loaded on 32-bit systems *) size64 : int; (** Size in words when loaded on 64-bit systems *) objects : int; (** Number of blocks defined in the marshalled structure *) } let dummy_header = { magic = "\000\000\000\000"; length = 0; size32 = 0; size64 = 0; objects = 0; } let parse_header chan = let magic = String.create 4 in let () = for i = 0 to 3 do magic.[i] <- input_char chan done in let length = input_binary_int chan in let objects = input_binary_int chan in let size32 = input_binary_int chan in let size64 = input_binary_int chan in { magic; length; size32; size64; objects } type segment = { name : string; mutable pos : int; typ : Values.value; mutable header : header; } let make_seg name typ = { name; typ; pos = 0; header = dummy_header } let visit_vo f = Printf.printf "\nWelcome to votour !\n"; Printf.printf "Enjoy your guided tour of a Coq .vo or .vi file\n"; Printf.printf "Object sizes are in words (%d bits)\n" Sys.word_size; Printf.printf "At prompt, enters the -th child, u goes up 1 level, x exits\n\n%!"; let segments = [| make_seg "summary" Values.v_libsum; make_seg "library" Values.v_lib; make_seg "univ constraints of opaque proofs" Values.v_univopaques; make_seg "discharging info" (Opt Any); make_seg "STM tasks" (Opt Values.v_stm_seg); make_seg "opaque proofs" Values.v_opaques; |] in let repr = if Sys.word_size = 64 then (module ReprMem : S) else (module ReprObj : S) (** On 32-bit machines, representation may exceed the max size of arrays *) in let module Repr = (val repr : S) in let module Visit = Visit(Repr) in while true do let ch = open_in_bin f in let magic = input_binary_int ch in Printf.printf "File format: %d\n%!" magic; for i=0 to Array.length segments - 1 do let pos = input_binary_int ch in segments.(i).pos <- pos_in ch; let header = parse_header ch in segments.(i).header <- header; seek_in ch pos; ignore(Digest.input ch); done; Printf.printf "The file has %d segments, choose the one to visit:\n" (Array.length segments); Array.iteri (fun i { name; pos; header } -> let size = if Sys.word_size = 64 then header.size64 else header.size32 in Printf.printf " %d: %s, starting at byte %d (size %iw)\n" i name pos size) segments; match read_num (Array.length segments) with | Some seg -> seek_in ch segments.(seg).pos; let o = Repr.input ch in let () = Visit.init () in Visit.visit segments.(seg).typ o [] | None -> () done let main = if not !Sys.interactive then Arg.parse [] visit_vo ("votour: guided tour of a Coq .vo or .vi file\n"^ "Usage: votour file.v[oi]") coq-8.6/checker/environ.mli0000644000175000017500000000462413022274260015254 0ustar mdenesmdenesopen Names open Cic (* Environments *) type globals = { env_constants : constant_body Cmap_env.t; env_inductives : mutual_inductive_body Mindmap_env.t; env_inductives_eq : kernel_name KNmap.t; env_modules : module_body MPmap.t; env_modtypes : module_type_body MPmap.t} type stratification = { env_universes : Univ.universes; env_engagement : engagement; } type env = { env_globals : globals; env_rel_context : rel_context; env_stratification : stratification; env_imports : Cic.vodigest MPmap.t; } val empty_env : env (* Engagement *) val engagement : env -> Cic.engagement val set_engagement : Cic.engagement -> env -> env (* Digests *) val add_digest : env -> DirPath.t -> Cic.vodigest -> env val lookup_digest : env -> DirPath.t -> Cic.vodigest (* de Bruijn variables *) val rel_context : env -> rel_context val lookup_rel : int -> env -> rel_declaration val push_rel : rel_declaration -> env -> env val push_rel_context : rel_context -> env -> env val push_rec_types : name array * constr array * 'a -> env -> env (* Universes *) val universes : env -> Univ.universes val add_constraints : Univ.constraints -> env -> env val push_context : ?strict:bool -> Univ.universe_context -> env -> env val push_context_set : ?strict:bool -> Univ.universe_context_set -> env -> env val check_constraints : Univ.constraints -> env -> bool (* Constants *) val lookup_constant : constant -> env -> Cic.constant_body val add_constant : constant -> Cic.constant_body -> env -> env val constant_type : env -> constant puniverses -> constant_type Univ.constrained type const_evaluation_result = NoBody | Opaque exception NotEvaluableConst of const_evaluation_result val constant_value : env -> constant puniverses -> constr val evaluable_constant : constant -> env -> bool val is_projection : constant -> env -> bool val lookup_projection : projection -> env -> projection_body (* Inductives *) val mind_equiv : env -> inductive -> inductive -> bool val lookup_mind : mutual_inductive -> env -> Cic.mutual_inductive_body val add_mind : mutual_inductive -> Cic.mutual_inductive_body -> env -> env (* Modules *) val add_modtype : module_path -> Cic.module_type_body -> env -> env val shallow_add_module : module_path -> Cic.module_body -> env -> env val shallow_remove_module : module_path -> env -> env val lookup_module : module_path -> env -> Cic.module_body val lookup_modtype : module_path -> env -> Cic.module_type_body coq-8.6/checker/type_errors.mli0000644000175000017500000000702413022274260016146 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int -> 'a val error_unbound_var : env -> variable -> 'a val error_not_type : env -> unsafe_judgment -> 'a val error_assumption : env -> unsafe_judgment -> 'a val error_reference_variables : env -> constr -> 'a val error_elim_arity : env -> pinductive -> sorts_family list -> constr -> unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a val error_number_branches : env -> unsafe_judgment -> int -> 'a val error_ill_formed_branch : env -> constr -> int -> constr -> constr -> 'a val error_actual_type : env -> unsafe_judgment -> constr -> 'a val error_cant_apply_not_functional : env -> unsafe_judgment -> unsafe_judgment array -> 'a val error_cant_apply_bad_type : env -> int * constr * constr -> unsafe_judgment -> unsafe_judgment array -> 'a val error_ill_formed_rec_body : env -> guard_error -> name array -> int -> 'a val error_ill_typed_rec_body : env -> int -> name array -> unsafe_judgment array -> constr array -> 'a val error_unsatisfied_constraints : env -> Univ.constraints -> 'a coq-8.6/checker/include0000644000175000017500000001154613022274260014440 0ustar mdenesmdenes(* -*-tuareg-*- *) (* Caml script to include for debugging the checker. Usage: from the checker/ directory launch ocaml toplevel and then type #use"include";; This command loads the relevent modules, defines some pretty printers, and provides functions to interactively check modules (mainly run_l and norec). *) #cd "..";; #directory "lib";; #directory "kernel";; #directory "checker";; #directory "+threads";; #directory "+camlp4";; #directory "+camlp5";; #load "unix.cma";; #load"threads.cma";; #load "str.cma";; #load "gramlib.cma";; (*#load "toplevellib.cma";; #directory "/usr/lib/ocaml/compiler-libs/utils";; let _ = Clflags.recursive_types:=true;; *) #load "check.cma";; open Typeops;; open Check;; open Pp;; open CErrors;; open Util;; open Names;; open Term;; open Environ;; open Declarations;; open Mod_checking;; open Cic;; let pr_id id = str(string_of_id id) let pr_na = function Name id -> pr_id id | _ -> str"_";; let prdp dp = pp(str(string_of_dirpath dp));; (* let prc c = pp(Himsg.pr_lconstr_env (Check.get_env()) c);; let prcs cs = prc (Declarations.force cs);; let pru u = pp(str(Univ.string_of_universe u));;*) let pru u = pp(Univ.pr_uni u);; let prlab l = pp(str(string_of_label l));; let prid id = pp(pr_id id);; let prcon c = pp(Indtypes.prcon c);; let prkn kn = pp(Indtypes.prkn kn);; let prus g = pp(Univ.pr_universes g);; let prcstrs c = let g = Univ.merge_constraints c Univ.initial_universes in pp(Univ.pr_universes g);; (*let prcstrs c = pp(Univ.pr_constraints c);; *) (* let prenvu e = let u = universes e in let pu = str "UNIVERSES:"++fnl()++str" "++hov 0 (Univ.pr_universes u) ++fnl() in pp pu;; let prenv e = let ctx1 = named_context e in let ctx2 = rel_context e in let pe = hov 1 (str"[" ++ prlist_with_sep spc (fun (na,_,_) -> pr_id na) (List.rev ctx1)++ str"]") ++ spc() ++ hov 1 (str"[" ++ prlist_with_sep spc (fun (na,_,_) -> pr_na na) (List.rev ctx2)++ str"]") in pp pe;; *) (* let prsub s = let string_of_mp mp = let s = string_of_mp mp in (match mp with MPbound _ -> "#bound."|_->"")^s in pp (hv 0 (fold_subst (fun msid mp strm -> str "S " ++ str (debug_string_of_msid msid) ++ str " |-> " ++ str (string_of_mp mp) ++ fnl() ++ strm) (fun mbid mp strm -> str"B " ++ str (debug_string_of_mbid mbid) ++ str " |-> " ++ str (string_of_mp mp) ++ fnl() ++ strm) (fun mp1 mp strm -> str"P " ++ str (string_of_mp mp1) ++ str " |-> " ++ str (string_of_mp mp) ++ fnl() ++ strm) s (mt()))) ;; *) #install_printer prid;; #install_printer prcon;; #install_printer prlab;; #install_printer prdp;; #install_printer prkn;; #install_printer pru;; (* #install_printer prc;; #install_printer prcs;; *) #install_printer prcstrs;; (*#install_printer prus;;*) (*#install_printer prenv;;*) (*#install_printer prenvu;; #install_printer prsub;;*) Checker.init_with_argv [|"";"-coqlib";"."|];; Flags.make_silent false;; Flags.debug := true;; Sys.catch_break true;; let module_of_file f = let (_,mb,_,_) = Obj.magic ((intern_from_file f).library_compiled) in (mb:Cic.module_body) ;; let deref_mod md s = let l = match md.mod_expr with Struct(NoFunctor l) -> l | FullStruct -> (match md.mod_type with NoFunctor l -> l) in List.assoc (label_of_id(id_of_string s)) l ;; (* let mod_access m fld = match m.mod_expr with Some(SEBstruct l) -> List.assoc fld l | _ -> failwith "bad structure type" ;; *) let parse_dp s = make_dirpath(List.rev_map id_of_string (Str.split(Str.regexp"\\.") s)) ;; let parse_sp s = let l = List.rev (Str.split(Str.regexp"\\.") s) in {dirpath=List.tl l; basename=List.hd l};; let parse_kn s = let l = List.rev (Str.split(Str.regexp"\\.") s) in let dp = make_dirpath(List.map id_of_string(List.tl l)) in make_kn(MPfile dp) empty_dirpath (label_of_id (id_of_string (List.hd l))) ;; let parse_con s = let l = List.rev (Str.split(Str.regexp"\\.") s) in let dp = make_dirpath(List.map id_of_string(List.tl l)) in make_con(MPfile dp) empty_dirpath (label_of_id (id_of_string (List.hd l))) ;; let get_mod dp = lookup_module dp (Safe_typing.get_env()) ;; let get_mod_type dp = lookup_modtype dp (Safe_typing.get_env()) ;; let get_cst kn = lookup_constant kn (Safe_typing.get_env()) ;; let read_mod s f = let lib = intern_from_file (parse_dp s,f) in ((Obj.magic lib.library_compiled): dir_path * module_body * (dir_path * Digest.t) list * engagement option);; let expln f x = try f x with UserError(_,strm) as e -> msgnl strm; raise e let admit_l l = let l = List.map parse_sp l in Check.recheck_library ~admit:l ~check:l;; let run_l l = Check.recheck_library ~admit:[] ~check:(List.map parse_sp l);; let norec q = Check.recheck_library ~norec:[parse_sp q] ~admit:[] ~check:[];; (* admit_l["Bool";"OrderedType";"DecidableType"];; run_l["FSetInterface"];; *) coq-8.6/checker/type_errors.ml0000644000175000017500000000740113022274260015774 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a -> 'a let empty_subst = Umap.empty let is_empty_subst = Umap.is_empty let add_mbid mbid mp = Umap.add_mbi mbid (mp,empty_delta_resolver) let add_mp mp1 mp2 = Umap.add_mp mp1 (mp2,empty_delta_resolver) let map_mbid mbid mp = add_mbid mbid mp empty_subst let map_mp mp1 mp2 = add_mp mp1 mp2 empty_subst let mp_in_delta mp = Deltamap.mem_mp mp let find_prefix resolve mp = let rec sub_mp = function | MPdot(mp,l) as mp_sup -> (try Deltamap.find_mp mp_sup resolve with Not_found -> MPdot(sub_mp mp,l)) | p -> Deltamap.find_mp p resolve in try sub_mp mp with Not_found -> mp (** Nota: the following function is slightly different in mod_subst PL: Is it on purpose ? *) let solve_delta_kn resolve kn = try match Deltamap.find_kn kn resolve with | Equiv kn1 -> kn1 | Inline _ -> raise Not_found with Not_found -> let mp,dir,l = KerName.repr kn in let new_mp = find_prefix resolve mp in if mp == new_mp then kn else KerName.make new_mp dir l let gen_of_delta resolve x kn fix_can = let new_kn = solve_delta_kn resolve kn in if kn == new_kn then x else fix_can new_kn let constant_of_delta resolve con = let kn = Constant.user con in gen_of_delta resolve con kn (Constant.make kn) let constant_of_delta2 resolve con = let kn, kn' = Constant.canonical con, Constant.user con in gen_of_delta resolve con kn (Constant.make kn') let mind_of_delta resolve mind = let kn = MutInd.user mind in gen_of_delta resolve mind kn (MutInd.make kn) let mind_of_delta2 resolve mind = let kn, kn' = MutInd.canonical mind, MutInd.user mind in gen_of_delta resolve mind kn (MutInd.make kn') let find_inline_of_delta kn resolve = match Deltamap.find_kn kn resolve with | Inline (_,o) -> o | _ -> raise Not_found let constant_of_delta_with_inline resolve con = let kn1,kn2 = Constant.canonical con, Constant.user con in try find_inline_of_delta kn2 resolve with Not_found -> try find_inline_of_delta kn1 resolve with Not_found -> None let subst_mp0 sub mp = (* 's like subst *) let rec aux mp = match mp with | MPfile sid -> Umap.find_mp mp sub | MPbound bid -> begin try Umap.find_mbi bid sub with Not_found -> Umap.find_mp mp sub end | MPdot (mp1,l) as mp2 -> begin try Umap.find_mp mp2 sub with Not_found -> let mp1',resolve = aux mp1 in MPdot (mp1',l),resolve end in try Some (aux mp) with Not_found -> None let subst_mp sub mp = match subst_mp0 sub mp with None -> mp | Some (mp',_) -> mp' let subst_kn_delta sub kn = let mp,dir,l = KerName.repr kn in match subst_mp0 sub mp with Some (mp',resolve) -> solve_delta_kn resolve (KerName.make mp' dir l) | None -> kn let subst_kn sub kn = let mp,dir,l = KerName.repr kn in match subst_mp0 sub mp with Some (mp',_) -> KerName.make mp' dir l | None -> kn exception No_subst type sideconstantsubst = | User | Canonical let gen_subst_mp f sub mp1 mp2 = match subst_mp0 sub mp1, subst_mp0 sub mp2 with | None, None -> raise No_subst | Some (mp',resolve), None -> User, (f mp' mp2), resolve | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2 let make_mind_equiv mpu mpc dir l = let knu = KerName.make mpu dir l in if mpu == mpc then MutInd.make1 knu else MutInd.make knu (KerName.make mpc dir l) let subst_ind sub mind = let kn1,kn2 = MutInd.user mind, MutInd.canonical mind in let mp1,dir,l = KerName.repr kn1 in let mp2,_,_ = KerName.repr kn2 in let rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 dir l in try let side,mind',resolve = gen_subst_mp rebuild_mind sub mp1 mp2 in match side with | User -> mind_of_delta resolve mind' | Canonical -> mind_of_delta2 resolve mind' with No_subst -> mind let make_con_equiv mpu mpc dir l = let knu = KerName.make mpu dir l in if mpu == mpc then Constant.make1 knu else Constant.make knu (KerName.make mpc dir l) let subst_con0 sub con u = let kn1,kn2 = Constant.user con, Constant.canonical con in let mp1,dir,l = KerName.repr kn1 in let mp2,_,_ = KerName.repr kn2 in let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in let dup con = con, Const (con, u) in let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in match constant_of_delta_with_inline resolve con' with | Some t -> con', t | None -> let con'' = match side with | User -> constant_of_delta resolve con' | Canonical -> constant_of_delta2 resolve con' in if con'' == con then raise No_subst else dup con'' let rec map_kn f f' c = let func = map_kn f f' in match c with | Const (kn, u) -> (try snd (f' kn u) with No_subst -> c) | Proj (p,t) -> let p' = Projection.map (fun kn -> try fst (f' kn Univ.Instance.empty) with No_subst -> kn) p in let t' = func t in if p' == p && t' == t then c else Proj (p', t') | Ind ((kn,i),u) -> let kn' = f kn in if kn'==kn then c else Ind ((kn',i),u) | Construct (((kn,i),j),u) -> let kn' = f kn in if kn'==kn then c else Construct (((kn',i),j),u) | Case (ci,p,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in let kn' = f kn in if kn'==kn then ci.ci_ind else kn',i in let p' = func p in let ct' = func ct in let l' = Array.smartmap func l in if (ci.ci_ind==ci_ind && p'==p && l'==l && ct'==ct)then c else Case ({ci with ci_ind = ci_ind}, p',ct', l') | Cast (ct,k,t) -> let ct' = func ct in let t'= func t in if (t'==t && ct'==ct) then c else Cast (ct', k, t') | Prod (na,t,ct) -> let ct' = func ct in let t'= func t in if (t'==t && ct'==ct) then c else Prod (na, t', ct') | Lambda (na,t,ct) -> let ct' = func ct in let t'= func t in if (t'==t && ct'==ct) then c else Lambda (na, t', ct') | LetIn (na,b,t,ct) -> let ct' = func ct in let t'= func t in let b'= func b in if (t'==t && ct'==ct && b==b') then c else LetIn (na, b', t', ct') | App (ct,l) -> let ct' = func ct in let l' = Array.smartmap func l in if (ct'== ct && l'==l) then c else App (ct',l') | Evar (e,l) -> let l' = Array.smartmap func l in if (l'==l) then c else Evar (e,l') | Fix (ln,(lna,tl,bl)) -> let tl' = Array.smartmap func tl in let bl' = Array.smartmap func bl in if (bl == bl'&& tl == tl') then c else Fix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> let tl' = Array.smartmap func tl in let bl' = Array.smartmap func bl in if (bl == bl'&& tl == tl') then c else CoFix (ln,(lna,tl',bl')) | _ -> c let subst_mps sub c = if is_empty_subst sub then c else map_kn (subst_ind sub) (subst_con0 sub) c let rec replace_mp_in_mp mpfrom mpto mp = match mp with | _ when ModPath.equal mp mpfrom -> mpto | MPdot (mp1,l) -> let mp1' = replace_mp_in_mp mpfrom mpto mp1 in if mp1==mp1' then mp else MPdot (mp1',l) | _ -> mp let rec mp_in_mp mp mp1 = match mp1 with | _ when ModPath.equal mp1 mp -> true | MPdot (mp2,l) -> mp_in_mp mp mp2 | _ -> false let subset_prefixed_by mp resolver = let mp_prefix mkey mequ rslv = if mp_in_mp mp mkey then Deltamap.add_mp mkey mequ rslv else rslv in let kn_prefix kn hint rslv = match hint with | Inline _ -> rslv | Equiv _ -> if mp_in_mp mp (KerName.modpath kn) then Deltamap.add_kn kn hint rslv else rslv in Deltamap.fold mp_prefix kn_prefix resolver empty_delta_resolver let subst_dom_delta_resolver subst resolver = let mp_apply_subst mkey mequ rslv = Deltamap.add_mp (subst_mp subst mkey) mequ rslv in let kn_apply_subst kkey hint rslv = Deltamap.add_kn (subst_kn subst kkey) hint rslv in Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver let subst_mp_delta sub mp mkey = match subst_mp0 sub mp with None -> empty_delta_resolver,mp | Some (mp',resolve) -> let mp1 = find_prefix resolve mp' in let resolve1 = subset_prefixed_by mp1 resolve in (subst_dom_delta_resolver (map_mp mp1 mkey) resolve1),mp1 let gen_subst_delta_resolver dom subst resolver = let mp_apply_subst mkey mequ rslv = let mkey' = if dom then subst_mp subst mkey else mkey in let rslv',mequ' = subst_mp_delta subst mequ mkey in Deltamap.join rslv' (Deltamap.add_mp mkey' mequ' rslv) in let kn_apply_subst kkey hint rslv = let kkey' = if dom then subst_kn subst kkey else kkey in let hint' = match hint with | Equiv kequ -> Equiv (subst_kn_delta subst kequ) | Inline (lev,Some t) -> Inline (lev,Some (subst_mps subst t)) | Inline (_,None) -> hint in Deltamap.add_kn kkey' hint' rslv in Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver let subst_codom_delta_resolver = gen_subst_delta_resolver false let subst_dom_codom_delta_resolver = gen_subst_delta_resolver true let update_delta_resolver resolver1 resolver2 = let mp_apply_rslv mkey mequ rslv = if Deltamap.mem_mp mkey resolver2 then rslv else Deltamap.add_mp mkey (find_prefix resolver2 mequ) rslv in let kn_apply_rslv kkey hint rslv = if Deltamap.mem_kn kkey resolver2 then rslv else let hint' = match hint with | Equiv kequ -> Equiv (solve_delta_kn resolver2 kequ) | _ -> hint in Deltamap.add_kn kkey hint' rslv in Deltamap.fold mp_apply_rslv kn_apply_rslv resolver1 empty_delta_resolver let add_delta_resolver resolver1 resolver2 = if resolver1 == resolver2 then resolver2 else if Deltamap.is_empty resolver2 then resolver1 else Deltamap.join (update_delta_resolver resolver1 resolver2) resolver2 let substition_prefixed_by k mp subst = let mp_prefixmp kmp (mp_to,reso) sub = if mp_in_mp mp kmp && not (ModPath.equal mp kmp) then let new_key = replace_mp_in_mp mp k kmp in Umap.add_mp new_key (mp_to,reso) sub else sub in let mbi_prefixmp mbi _ sub = sub in Umap.fold mp_prefixmp mbi_prefixmp subst empty_subst let join subst1 subst2 = let apply_subst mpk add (mp,resolve) res = let mp',resolve' = match subst_mp0 subst2 mp with | None -> mp, None | Some (mp',resolve') -> mp', Some resolve' in let resolve'' = match resolve' with | Some res -> add_delta_resolver (subst_dom_codom_delta_resolver subst2 resolve) res | None -> subst_codom_delta_resolver subst2 resolve in let prefixed_subst = substition_prefixed_by mpk mp' subst2 in Umap.join prefixed_subst (add (mp',resolve'') res) in let mp_apply_subst mp = apply_subst mp (Umap.add_mp mp) in let mbi_apply_subst mbi = apply_subst (MPbound mbi) (Umap.add_mbi mbi) in let subst = Umap.fold mp_apply_subst mbi_apply_subst subst1 empty_subst in Umap.join subst2 subst let from_val x = { subst_value = x; subst_subst = []; } let force fsubst r = match r.subst_subst with | [] -> r.subst_value | s -> let subst = List.fold_left join empty_subst (List.rev s) in let x = fsubst subst r.subst_value in let () = r.subst_subst <- [] in let () = r.subst_value <- x in x let subst_substituted s r = { r with subst_subst = s :: r.subst_subst; } let force_constr = force subst_mps let subst_constr_subst = subst_substituted let subst_lazy_constr sub = function | Indirect (l,dp,i) -> Indirect (sub::l,dp,i) let indirect_opaque_access = ref ((fun dp i -> assert false) : DirPath.t -> int -> constr) let indirect_opaque_univ_access = ref ((fun dp i -> assert false) : DirPath.t -> int -> Univ.ContextSet.t) let force_lazy_constr = function | Indirect (l,dp,i) -> let c = !indirect_opaque_access dp i in force_constr (List.fold_right subst_constr_subst l (from_val c)) let force_lazy_constr_univs = function | OpaqueDef (Indirect (l,dp,i)) -> !indirect_opaque_univ_access dp i | _ -> Univ.ContextSet.empty let subst_constant_def sub = function | Undef inl -> Undef inl | Def c -> Def (subst_constr_subst sub c) | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc) (** Local variables and graph *) let body_of_constant cb = match cb.const_body with | Undef _ -> None | Def c -> Some (force_constr c) | OpaqueDef c -> Some (force_lazy_constr c) let constant_has_body cb = match cb.const_body with | Undef _ -> false | Def _ | OpaqueDef _ -> true let is_opaque cb = match cb.const_body with | OpaqueDef _ -> true | Def _ | Undef _ -> false let opaque_univ_context cb = force_lazy_constr_univs cb.const_body let subst_rel_declaration sub (id,copt,t as x) = let copt' = Option.smartmap (subst_mps sub) copt in let t' = subst_mps sub t in if copt == copt' && t == t' then x else (id,copt',t') let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) let subst_recarg sub r = match r with | Norec -> r | (Mrec(kn,i)|Imbr (kn,i)) -> let kn' = subst_ind sub kn in if kn==kn' then r else Imbr (kn',i) let mk_norec = Rtree.mk_node Norec [||] let mk_paths r recargs = Rtree.mk_node r (Array.map (fun l -> Rtree.mk_node Norec (Array.of_list l)) recargs) let dest_recarg p = fst (Rtree.dest_node p) let dest_subterms p = let (_,cstrs) = Rtree.dest_node p in Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p let eq_recarg r1 r2 = match r1, r2 with | Norec, Norec -> true | Mrec i1, Mrec i2 -> Names.eq_ind i1 i2 | Imbr i1, Imbr i2 -> Names.eq_ind i1 i2 | _ -> false let eq_wf_paths = Rtree.equal eq_recarg (**********************************************************************) (* Representation of mutual inductive types in the kernel *) (* Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1 ... with In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn *) let subst_decl_arity f g sub ar = match ar with | RegularArity x -> let x' = f sub x in if x' == x then ar else RegularArity x' | TemplateArity x -> let x' = g sub x in if x' == x then ar else TemplateArity x' let map_decl_arity f g = function | RegularArity a -> RegularArity (f a) | TemplateArity a -> TemplateArity (g a) let subst_rel_declaration sub = Term.map_rel_decl (subst_mps sub) let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) let subst_template_cst_arity sub (ctx,s as arity) = let ctx' = subst_rel_context sub ctx in if ctx==ctx' then arity else (ctx',s) let subst_arity sub s = subst_decl_arity subst_mps subst_template_cst_arity sub s (* TODO: should be changed to non-coping after Term.subst_mps *) (* NB: we leave bytecode and native code fields untouched *) let subst_const_body sub cb = { cb with const_body = subst_constant_def sub cb.const_body; const_type = subst_arity sub cb.const_type } let subst_regular_ind_arity sub s = let uar' = subst_mps sub s.mind_user_arity in if uar' == s.mind_user_arity then s else { mind_user_arity = uar'; mind_sort = s.mind_sort } let subst_template_ind_arity sub s = s (* FIXME records *) let subst_ind_arity = subst_decl_arity subst_regular_ind_arity subst_template_ind_arity let subst_mind_packet sub mbp = { mind_consnames = mbp.mind_consnames; mind_consnrealdecls = mbp.mind_consnrealdecls; mind_consnrealargs = mbp.mind_consnrealargs; mind_typename = mbp.mind_typename; mind_nf_lc = Array.smartmap (subst_mps sub) mbp.mind_nf_lc; mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; mind_arity = subst_ind_arity sub mbp.mind_arity; mind_user_lc = Array.smartmap (subst_mps sub) mbp.mind_user_lc; mind_nrealargs = mbp.mind_nrealargs; mind_nrealdecls = mbp.mind_nrealdecls; mind_kelim = mbp.mind_kelim; mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); mind_nb_constant = mbp.mind_nb_constant; mind_nb_args = mbp.mind_nb_args; mind_reloc_tbl = mbp.mind_reloc_tbl } let subst_mind sub mib = { mib with mind_params_ctxt = map_rel_context (subst_mps sub) mib.mind_params_ctxt; mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets } (* Modules *) let rec functor_map fty f0 = function | NoFunctor a -> NoFunctor (f0 a) | MoreFunctor (mbid,ty,e) -> MoreFunctor(mbid,fty ty,functor_map fty f0 e) let implem_map fs fa = function | Struct s -> Struct (fs s) | Algebraic a -> Algebraic (fa a) | impl -> impl let subst_with_body sub = function | WithMod(id,mp) -> WithMod(id,subst_mp sub mp) | WithDef(id,(c,ctx)) -> WithDef(id,(subst_mps sub c,ctx)) let rec subst_expr sub = function | MEident mp -> MEident (subst_mp sub mp) | MEapply (me1,mp2)-> MEapply (subst_expr sub me1, subst_mp sub mp2) | MEwith (me,wd)-> MEwith (subst_expr sub me, subst_with_body sub wd) let rec subst_expression sub me = functor_map (subst_module sub) (subst_expr sub) me and subst_signature sub sign = functor_map (subst_module sub) (subst_structure sub) sign and subst_structure sub struc = let subst_body = function | SFBconst cb -> SFBconst (subst_const_body sub cb) | SFBmind mib -> SFBmind (subst_mind sub mib) | SFBmodule mb -> SFBmodule (subst_module sub mb) | SFBmodtype mtb -> SFBmodtype (subst_module sub mtb) in List.map (fun (l,b) -> (l,subst_body b)) struc and subst_module sub mb = { mb with mod_mp = subst_mp sub mb.mod_mp; mod_expr = implem_map (subst_signature sub) (subst_expression sub) mb.mod_expr; mod_type = subst_signature sub mb.mod_type; mod_type_alg = Option.smartmap (subst_expression sub) mb.mod_type_alg } coq-8.6/checker/declarations.mli0000644000175000017500000000317613022274260016245 0ustar mdenesmdenesopen Names open Cic val force_constr : constr_substituted -> constr val force_lazy_constr_univs : Cic.constant_def -> Univ.ContextSet.t val from_val : constr -> constr_substituted val indirect_opaque_access : (DirPath.t -> int -> constr) ref val indirect_opaque_univ_access : (DirPath.t -> int -> Univ.ContextSet.t) ref (** Constant_body *) val body_of_constant : constant_body -> constr option val constant_has_body : constant_body -> bool val is_opaque : constant_body -> bool val opaque_univ_context : constant_body -> Univ.ContextSet.t (* Mutual inductives *) val mk_norec : wf_paths val mk_paths : recarg -> wf_paths list array -> wf_paths val dest_recarg : wf_paths -> recarg val dest_subterms : wf_paths -> wf_paths list array val eq_recarg : recarg -> recarg -> bool val eq_wf_paths : wf_paths -> wf_paths -> bool (* Modules *) val empty_delta_resolver : delta_resolver (* Substitutions *) type 'a subst_fun = substitution -> 'a -> 'a val empty_subst : substitution val add_mbid : MBId.t -> module_path -> substitution -> substitution val add_mp : module_path -> module_path -> substitution -> substitution val map_mbid : MBId.t -> module_path -> substitution val map_mp : module_path -> module_path -> substitution val mp_in_delta : module_path -> delta_resolver -> bool val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive val subst_const_body : constant_body subst_fun val subst_mind : mutual_inductive_body subst_fun val subst_signature : substitution -> module_signature -> module_signature val subst_module : substitution -> module_body -> module_body val join : substitution -> substitution -> substitution coq-8.6/checker/environ.ml0000644000175000017500000001601113022274260015074 0ustar mdenesmdenesopen CErrors open Util open Names open Cic open Term open Declarations type globals = { env_constants : constant_body Cmap_env.t; env_inductives : mutual_inductive_body Mindmap_env.t; env_inductives_eq : kernel_name KNmap.t; env_modules : module_body MPmap.t; env_modtypes : module_type_body MPmap.t} type stratification = { env_universes : Univ.universes; env_engagement : engagement } type env = { env_globals : globals; env_rel_context : rel_context; env_stratification : stratification; env_imports : Cic.vodigest MPmap.t } let empty_env = { env_globals = { env_constants = Cmap_env.empty; env_inductives = Mindmap_env.empty; env_inductives_eq = KNmap.empty; env_modules = MPmap.empty; env_modtypes = MPmap.empty}; env_rel_context = []; env_stratification = { env_universes = Univ.initial_universes; env_engagement = PredicativeSet }; env_imports = MPmap.empty } let engagement env = env.env_stratification.env_engagement let universes env = env.env_stratification.env_universes let rel_context env = env.env_rel_context let set_engagement (impr_set as c) env = let expected_impr_set = env.env_stratification.env_engagement in begin match impr_set,expected_impr_set with | PredicativeSet, ImpredicativeSet -> error "Incompatible engagement" | _ -> () end; { env with env_stratification = { env.env_stratification with env_engagement = c } } (* Digests *) let add_digest env dp digest = { env with env_imports = MPmap.add (MPfile dp) digest env.env_imports } let lookup_digest env dp = MPmap.find (MPfile dp) env.env_imports (* Rel context *) let lookup_rel n env = let rec lookup_rel n sign = match n, sign with | 1, decl :: _ -> decl | n, _ :: sign -> lookup_rel (n-1) sign | _, [] -> raise Not_found in lookup_rel n env.env_rel_context let push_rel d env = { env with env_rel_context = d :: env.env_rel_context } let push_rel_context ctxt x = fold_rel_context push_rel ctxt ~init:x let push_rec_types (lna,typarray,_) env = let ctxt = Array.map2_i (fun i na t -> LocalAssum (na, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt (* Universe constraints *) let map_universes f env = let s = env.env_stratification in { env with env_stratification = { s with env_universes = f s.env_universes } } let add_constraints c env = if c == Univ.Constraint.empty then env else map_universes (Univ.merge_constraints c) env let push_context ?(strict=false) ctx env = map_universes (Univ.merge_context strict ctx) env let push_context_set ?(strict=false) ctx env = map_universes (Univ.merge_context_set strict ctx) env let check_constraints cst env = Univ.check_constraints cst env.env_stratification.env_universes (* Global constants *) let lookup_constant kn env = Cmap_env.find kn env.env_globals.env_constants let anomaly s = anomaly (Pp.str s) let add_constant kn cs env = if Cmap_env.mem kn env.env_globals.env_constants then Printf.ksprintf anomaly ("Constant %s is already defined") (Constant.to_string kn); let new_constants = Cmap_env.add kn cs env.env_globals.env_constants in let new_globals = { env.env_globals with env_constants = new_constants } in { env with env_globals = new_globals } type const_evaluation_result = NoBody | Opaque (* Constant types *) let constraints_of cb u = let univs = cb.const_universes in Univ.subst_instance_constraints u (Univ.UContext.constraints univs) let map_regular_arity f = function | RegularArity a as ar -> let a' = f a in if a' == a then ar else RegularArity a' | TemplateArity _ -> assert false (* constant_type gives the type of a constant *) let constant_type env (kn,u) = let cb = lookup_constant kn env in if cb.const_polymorphic then let csts = constraints_of cb u in (map_regular_arity (subst_instance_constr u) cb.const_type, csts) else cb.const_type, Univ.Constraint.empty exception NotEvaluableConst of const_evaluation_result let constant_value env (kn,u) = let cb = lookup_constant kn env in match cb.const_body with | Def l_body -> let b = force_constr l_body in if cb.const_polymorphic then subst_instance_constr u (force_constr l_body) else b | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) (* A global const is evaluable if it is defined and not opaque *) let evaluable_constant cst env = try let _ = constant_value env (cst, Univ.Instance.empty) in true with Not_found | NotEvaluableConst _ -> false let is_projection cst env = not (Option.is_empty (lookup_constant cst env).const_proj) let lookup_projection p env = match (lookup_constant (Projection.constant p) env).const_proj with | Some pb -> pb | None -> anomaly ("lookup_projection: constant is not a projection") (* Mutual Inductives *) let scrape_mind env kn= try KNmap.find kn env.env_globals.env_inductives_eq with Not_found -> kn let mind_equiv env (kn1,i1) (kn2,i2) = Int.equal i1 i2 && KerName.equal (scrape_mind env (MutInd.user kn1)) (scrape_mind env (MutInd.user kn2)) let lookup_mind kn env = Mindmap_env.find kn env.env_globals.env_inductives let add_mind kn mib env = if Mindmap_env.mem kn env.env_globals.env_inductives then Printf.ksprintf anomaly ("Inductive %s is already defined") (MutInd.to_string kn); let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in let kn1,kn2 = MutInd.user kn, MutInd.canonical kn in let new_inds_eq = if KerName.equal kn1 kn2 then env.env_globals.env_inductives_eq else KNmap.add kn1 kn2 env.env_globals.env_inductives_eq in let new_globals = { env.env_globals with env_inductives = new_inds; env_inductives_eq = new_inds_eq} in { env with env_globals = new_globals } (* Modules *) let add_modtype ln mtb env = if MPmap.mem ln env.env_globals.env_modtypes then Printf.ksprintf anomaly ("Module type %s is already defined") (ModPath.to_string ln); let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in let new_globals = { env.env_globals with env_modtypes = new_modtypes } in { env with env_globals = new_globals } let shallow_add_module mp mb env = if MPmap.mem mp env.env_globals.env_modules then Printf.ksprintf anomaly ("Module %s is already defined") (ModPath.to_string mp); let new_mods = MPmap.add mp mb env.env_globals.env_modules in let new_globals = { env.env_globals with env_modules = new_mods } in { env with env_globals = new_globals } let shallow_remove_module mp env = if not (MPmap.mem mp env.env_globals.env_modules) then Printf.ksprintf anomaly ("Module %s is unknown") (ModPath.to_string mp); let new_mods = MPmap.remove mp env.env_globals.env_modules in let new_globals = { env.env_globals with env_modules = new_mods } in { env with env_globals = new_globals } let lookup_module mp env = MPmap.find mp env.env_globals.env_modules let lookup_modtype ln env = MPmap.find ln env.env_globals.env_modtypes coq-8.6/checker/univ.ml0000644000175000017500000010602113022274260014376 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int val eq : t -> t -> bool val hcons : t -> t end module HashedList (M : Hashconsed) : sig type t = private Nil | Cons of M.t * int * t val nil : t val cons : M.t -> t -> t end = struct type t = Nil | Cons of M.t * int * t module Self = struct type _t = t type t = _t type u = (M.t -> M.t) let hash = function Nil -> 0 | Cons (_, h, _) -> h let eq l1 l2 = match l1, l2 with | Nil, Nil -> true | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2 | _ -> false let hashcons hc = function | Nil -> Nil | Cons (x, h, l) -> Cons (hc x, h, l) end module Hcons = Hashcons.Make(Self) let hcons = Hashcons.simple_hcons Hcons.generate Hcons.hcons M.hcons (** No recursive call: the interface guarantees that all HLists from this program are already hashconsed. If we get some external HList, we can still reconstruct it by traversing it entirely. *) let nil = Nil let cons x l = let h = M.hash x in let hl = match l with Nil -> 0 | Cons (_, h, _) -> h in let h = Hashset.Combine.combine h hl in hcons (Cons (x, h, l)) end module HList = struct module type S = sig type elt type t = private Nil | Cons of elt * int * t val hash : t -> int val nil : t val cons : elt -> t -> t val tip : elt -> t val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val map : (elt -> elt) -> t -> t val smartmap : (elt -> elt) -> t -> t val exists : (elt -> bool) -> t -> bool val for_all : (elt -> bool) -> t -> bool val for_all2 : (elt -> elt -> bool) -> t -> t -> bool val remove : elt -> t -> t val to_list : t -> elt list end module Make (H : Hashconsed) : S with type elt = H.t = struct type elt = H.t include HashedList(H) let hash = function Nil -> 0 | Cons (_, h, _) -> h let tip e = cons e nil let rec fold f l accu = match l with | Nil -> accu | Cons (x, _, l) -> fold f l (f x accu) let rec map f = function | Nil -> nil | Cons (x, _, l) -> cons (f x) (map f l) let smartmap = map (** Apriori hashconsing ensures that the map is equal to its argument *) let rec exists f = function | Nil -> false | Cons (x, _, l) -> f x || exists f l let rec for_all f = function | Nil -> true | Cons (x, _, l) -> f x && for_all f l let rec for_all2 f l1 l2 = match l1, l2 with | Nil, Nil -> true | Cons (x1, _, l1), Cons (x2, _, l2) -> f x1 x2 && for_all2 f l1 l2 | _ -> false let rec to_list = function | Nil -> [] | Cons (x, _, l) -> x :: to_list l let rec remove x = function | Nil -> nil | Cons (y, _, l) -> if H.eq x y then l else cons y (remove x l) end end module RawLevel = struct open Names type t = | Prop | Set | Level of int * DirPath.t | Var of int (* Hash-consing *) let equal x y = x == y || match x, y with | Prop, Prop -> true | Set, Set -> true | Level (n,d), Level (n',d') -> Int.equal n n' && DirPath.equal d d' | Var n, Var n' -> Int.equal n n' | _ -> false let compare u v = match u, v with | Prop,Prop -> 0 | Prop, _ -> -1 | _, Prop -> 1 | Set, Set -> 0 | Set, _ -> -1 | _, Set -> 1 | Level (i1, dp1), Level (i2, dp2) -> if i1 < i2 then -1 else if i1 > i2 then 1 else DirPath.compare dp1 dp2 | Level _, _ -> -1 | _, Level _ -> 1 | Var n, Var m -> Int.compare n m let hequal x y = x == y || match x, y with | Prop, Prop -> true | Set, Set -> true | Level (n,d), Level (n',d') -> n == n' && d == d' | Var n, Var n' -> n == n' | _ -> false let hcons = function | Prop as x -> x | Set as x -> x | Level (n,d) as x -> let d' = Names.DirPath.hcons d in if d' == d then x else Level (n,d') | Var n as x -> x open Hashset.Combine let hash = function | Prop -> combinesmall 1 0 | Set -> combinesmall 1 1 | Var n -> combinesmall 2 n | Level (n, d) -> combinesmall 3 (combine n (Names.DirPath.hash d)) end module Level = struct open Names type raw_level = RawLevel.t = | Prop | Set | Level of int * DirPath.t | Var of int (** Embed levels with their hash value *) type t = { hash : int; data : RawLevel.t } let equal x y = x == y || Int.equal x.hash y.hash && RawLevel.equal x.data y.data let hash x = x.hash let data x = x.data (** Hashcons on levels + their hash *) module Self = struct type _t = t type t = _t type u = unit let eq x y = x.hash == y.hash && RawLevel.hequal x.data y.data let hash x = x.hash let hashcons () x = let data' = RawLevel.hcons x.data in if x.data == data' then x else { x with data = data' } end let hcons = let module H = Hashcons.Make(Self) in Hashcons.simple_hcons H.generate H.hcons () let make l = hcons { hash = RawLevel.hash l; data = l } let set = make Set let prop = make Prop let var i = make (Var i) let is_small x = match data x with | Level _ -> false | _ -> true let is_prop x = match data x with | Prop -> true | _ -> false let is_set x = match data x with | Set -> true | _ -> false let compare u v = if u == v then 0 else let c = Int.compare (hash u) (hash v) in if c == 0 then RawLevel.compare (data u) (data v) else c let to_string x = match data x with | Prop -> "Prop" | Set -> "Set" | Level (n,d) -> Names.DirPath.to_string d^"."^string_of_int n | Var i -> "Var("^string_of_int i^")" let pr u = str (to_string u) let make m n = make (Level (n, Names.DirPath.hcons m)) end (** Level sets and maps *) module LMap = HMap.Make (Level) module LSet = LMap.Set type 'a universe_map = 'a LMap.t type universe_level = Level.t type universe_level_subst_fn = universe_level -> universe_level (* An algebraic universe [universe] is either a universe variable [Level.t] or a formal universe known to be greater than some universe variables and strictly greater than some (other) universe variables Universes variables denote universes initially present in the term to type-check and non variable algebraic universes denote the universes inferred while type-checking: it is either the successor of a universe present in the initial term to type-check or the maximum of two algebraic universes *) module Universe = struct (* Invariants: non empty, sorted and without duplicates *) module Expr = struct type t = Level.t * int type _t = t (* Hashing of expressions *) module ExprHash = struct type t = _t type u = Level.t -> Level.t let hashcons hdir (b,n as x) = let b' = hdir b in if b' == b then x else (b',n) let eq l1 l2 = l1 == l2 || match l1,l2 with | (b,n), (b',n') -> b == b' && n == n' let hash (x, n) = n + Level.hash x end module HExpr = struct module H = Hashcons.Make(ExprHash) type t = ExprHash.t let hcons = Hashcons.simple_hcons H.generate H.hcons Level.hcons let hash = ExprHash.hash let eq x y = x == y || (let (u,n) = x and (v,n') = y in Int.equal n n' && Level.equal u v) end let hcons = HExpr.hcons let make l = hcons (l, 0) let prop = make Level.prop let set = make Level.set let type1 = hcons (Level.set, 1) let is_prop = function | (l,0) -> Level.is_prop l | _ -> false let equal x y = x == y || (let (u,n) = x and (v,n') = y in Int.equal n n' && Level.equal u v) let leq (u,n) (v,n') = let cmp = Level.compare u v in if Int.equal cmp 0 then n <= n' else if n <= n' then (Level.is_prop u && Level.is_small v) else false let successor (u,n) = if Level.is_prop u then type1 else hcons (u, n + 1) let addn k (u,n as x) = if k = 0 then x else if Level.is_prop u then hcons (Level.set,n+k) else hcons (u,n+k) let super (u,n as x) (v,n' as y) = let cmp = Level.compare u v in if Int.equal cmp 0 then if n < n' then Inl true else Inl false else if is_prop x then Inl true else if is_prop y then Inl false else Inr cmp let to_string (v, n) = if Int.equal n 0 then Level.to_string v else Level.to_string v ^ "+" ^ string_of_int n let pr x = str(to_string x) let level = function | (v,0) -> Some v | _ -> None let map f (v, n as x) = let v' = f v in if v' == v then x else if Level.is_prop v' && n != 0 then hcons (Level.set, n) else hcons (v', n) end module Huniv = HList.Make(Expr.HExpr) type t = Huniv.t open Huniv let equal x y = x == y || (Huniv.hash x == Huniv.hash y && Huniv.for_all2 Expr.equal x y) let make l = Huniv.tip (Expr.make l) let tip x = Huniv.tip x let pr l = match l with | Cons (u, _, Nil) -> Expr.pr u | _ -> str "max(" ++ hov 0 (prlist_with_sep pr_comma Expr.pr (to_list l)) ++ str ")" let level l = match l with | Cons (l, _, Nil) -> Expr.level l | _ -> None (* The lower predicative level of the hierarchy that contains (impredicative) Prop and singleton inductive types *) let type0m = tip Expr.prop (* The level of sets *) let type0 = tip Expr.set (* When typing [Prop] and [Set], there is no constraint on the level, hence the definition of [type1_univ], the type of [Prop] *) let type1 = tip (Expr.successor Expr.set) let is_type0m x = equal type0m x let is_type0 x = equal type0 x (* Returns the formal universe that lies juste above the universe variable u. Used to type the sort u. *) let super l = Huniv.map (fun x -> Expr.successor x) l let addn n l = Huniv.map (fun x -> Expr.addn n x) l let rec merge_univs l1 l2 = match l1, l2 with | Nil, _ -> l2 | _, Nil -> l1 | Cons (h1, _, t1), Cons (h2, _, t2) -> (match Expr.super h1 h2 with | Inl true (* h1 < h2 *) -> merge_univs t1 l2 | Inl false -> merge_univs l1 t2 | Inr c -> if c <= 0 (* h1 < h2 is name order *) then cons h1 (merge_univs t1 l2) else cons h2 (merge_univs l1 t2)) let sort u = let rec aux a l = match l with | Cons (b, _, l') -> (match Expr.super a b with | Inl false -> aux a l' | Inl true -> l | Inr c -> if c <= 0 then cons a l else cons b (aux a l')) | Nil -> cons a l in fold (fun a acc -> aux a acc) u nil (* Returns the formal universe that is greater than the universes u and v. Used to type the products. *) let sup x y = merge_univs x y let empty = nil let exists = Huniv.exists let for_all = Huniv.for_all let smartmap = Huniv.smartmap end type universe = Universe.t (* The level of predicative Set *) let type0m_univ = Universe.type0m let type0_univ = Universe.type0 let type1_univ = Universe.type1 let is_type0m_univ = Universe.is_type0m let is_type0_univ = Universe.is_type0 let is_univ_variable l = Universe.level l != None let pr_uni = Universe.pr let sup = Universe.sup let super = Universe.super open Universe (* Comparison on this type is pointer equality *) type canonical_arc = { univ: Level.t; lt: Level.t list; le: Level.t list; rank : int; predicative : bool} let terminal u = {univ=u; lt=[]; le=[]; rank=0; predicative=false} module UMap : sig type key = Level.t type +'a t val empty : 'a t val add : key -> 'a -> 'a t -> 'a t val find : key -> 'a t -> 'a val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b end = HMap.Make(Level) (* A Level.t is either an alias for another one, or a canonical one, for which we know the universes that are above *) type univ_entry = Canonical of canonical_arc | Equiv of Level.t type universes = univ_entry UMap.t let enter_equiv_arc u v g = UMap.add u (Equiv v) g let enter_arc ca g = UMap.add ca.univ (Canonical ca) g (* Every Level.t has a unique canonical arc representative *) (* repr : universes -> Level.t -> canonical_arc *) (* canonical representative : we follow the Equiv links *) let repr g u = let rec repr_rec u = let a = try UMap.find u g with Not_found -> anomaly ~label:"Univ.repr" (str"Universe " ++ Level.pr u ++ str" undefined") in match a with | Equiv v -> repr_rec v | Canonical arc -> arc in repr_rec u let get_set_arc g = repr g Level.set exception AlreadyDeclared let add_universe vlev strict g = try let _arcv = UMap.find vlev g in raise AlreadyDeclared with Not_found -> let v = terminal vlev in let arc = let arc = get_set_arc g in if strict then { arc with lt=vlev::arc.lt} else { arc with le=vlev::arc.le} in let g = enter_arc arc g in enter_arc v g (* reprleq : canonical_arc -> canonical_arc list *) (* All canonical arcv such that arcu<=arcv with arcv#arcu *) let reprleq g arcu = let rec searchrec w = function | [] -> w | v :: vl -> let arcv = repr g v in if List.memq arcv w || arcu==arcv then searchrec w vl else searchrec (arcv :: w) vl in searchrec [] arcu.le (* between : Level.t -> canonical_arc -> canonical_arc list *) (* between u v = { w | u<=w<=v, w canonical } *) (* between is the most costly operation *) let between g arcu arcv = (* good are all w | u <= w <= v *) (* bad are all w | u <= w ~<= v *) (* find good and bad nodes in {w | u <= w} *) (* explore b u = (b or "u is good") *) let rec explore ((good, bad, b) as input) arcu = if List.memq arcu good then (good, bad, true) (* b or true *) else if List.memq arcu bad then input (* (good, bad, b or false) *) else let leq = reprleq g arcu in (* is some universe >= u good ? *) let good, bad, b_leq = List.fold_left explore (good, bad, false) leq in if b_leq then arcu::good, bad, true (* b or true *) else good, arcu::bad, b (* b or false *) in let good,_,_ = explore ([arcv],[],false) arcu in good (* We assume compare(u,v) = LE with v canonical (see compare below). In this case List.hd(between g u v) = repr u Otherwise, between g u v = [] *) type constraint_type = Lt | Le | Eq let constraint_type_ord c1 c2 = match c1, c2 with | Lt, Lt -> 0 | Lt, _ -> -1 | Le, Lt -> 1 | Le, Le -> 0 | Le, Eq -> -1 | Eq, Eq -> 0 | Eq, _ -> 1 (** [compare_neq] : is [arcv] in the transitive upward closure of [arcu] ? In [strict] mode, we fully distinguish between LE and LT, while in non-strict mode, we simply answer LE for both situations. If [arcv] is encountered in a LT part, we could directly answer without visiting unneeded parts of this transitive closure. In [strict] mode, if [arcv] is encountered in a LE part, we could only change the default answer (1st arg [c]) from NLE to LE, since a strict constraint may appear later. During the recursive traversal, [lt_done] and [le_done] are universes we have already visited, they do not contain [arcv]. The 4rd arg is [(lt_todo,le_todo)], two lists of universes not yet considered, known to be above [arcu], strictly or not. We use depth-first search, but the presence of [arcv] in [new_lt] is checked as soon as possible : this seems to be slightly faster on a test. *) type fast_order = FastEQ | FastLT | FastLE | FastNLE let fast_compare_neq strict g arcu arcv = (* [c] characterizes whether arcv has already been related to arcu among the lt_done,le_done universe *) let rec cmp c lt_done le_done lt_todo le_todo = match lt_todo, le_todo with | [],[] -> c | arc::lt_todo, le_todo -> if List.memq arc lt_done then cmp c lt_done le_done lt_todo le_todo else let rec find lt_todo lt le = match le with | [] -> begin match lt with | [] -> cmp c (arc :: lt_done) le_done lt_todo le_todo | u :: lt -> let arc = repr g u in if arc == arcv then if strict then FastLT else FastLE else find (arc :: lt_todo) lt le end | u :: le -> let arc = repr g u in if arc == arcv then if strict then FastLT else FastLE else find (arc :: lt_todo) lt le in find lt_todo arc.lt arc.le | [], arc::le_todo -> if arc == arcv then (* No need to continue inspecting universes above arc: if arcv is strictly above arc, then we would have a cycle. But we cannot answer LE yet, a stronger constraint may come later from [le_todo]. *) if strict then cmp FastLE lt_done le_done [] le_todo else FastLE else if (List.memq arc lt_done) || (List.memq arc le_done) then cmp c lt_done le_done [] le_todo else let rec find lt_todo lt = match lt with | [] -> let fold accu u = let node = repr g u in node :: accu in let le_new = List.fold_left fold le_todo arc.le in cmp c lt_done (arc :: le_done) lt_todo le_new | u :: lt -> let arc = repr g u in if arc == arcv then if strict then FastLT else FastLE else find (arc :: lt_todo) lt in find [] arc.lt in cmp FastNLE [] [] [] [arcu] let fast_compare g arcu arcv = if arcu == arcv then FastEQ else fast_compare_neq true g arcu arcv let is_leq g arcu arcv = arcu == arcv || (match fast_compare_neq false g arcu arcv with | FastNLE -> false | (FastEQ|FastLE|FastLT) -> true) let is_lt g arcu arcv = if arcu == arcv then false else match fast_compare_neq true g arcu arcv with | FastLT -> true | (FastEQ|FastLE|FastNLE) -> false (* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ compare(u,v) = LT or LE => compare(v,u) = NLE compare(u,v) = NLE => compare(v,u) = NLE or LE or LT Adding u>=v is consistent iff compare(v,u) # LT and then it is redundant iff compare(u,v) # NLE Adding u>v is consistent iff compare(v,u) = NLE and then it is redundant iff compare(u,v) = LT *) (** * Universe checks [check_eq] and [check_leq], used in coqchk *) (** First, checks on universe levels *) let check_equal g u v = let arcu = repr g u in let arcv = repr g v in arcu == arcv let check_eq_level g u v = u == v || check_equal g u v let is_set_arc u = Level.is_set u.univ let is_prop_arc u = Level.is_prop u.univ let check_smaller g strict u v = let arcu = repr g u in let arcv = repr g v in if strict then is_lt g arcu arcv else is_prop_arc arcu || (is_set_arc arcu && arcv.predicative) || is_leq g arcu arcv (** Then, checks on universes *) type 'a check_function = universes -> 'a -> 'a -> bool let check_equal_expr g x y = x == y || (let (u, n) = x and (v, m) = y in Int.equal n m && check_equal g u v) let check_eq_univs g l1 l2 = let f x1 x2 = check_equal_expr g x1 x2 in let exists x1 l = Huniv.exists (fun x2 -> f x1 x2) l in Huniv.for_all (fun x1 -> exists x1 l2) l1 && Huniv.for_all (fun x2 -> exists x2 l1) l2 let check_eq g u v = Universe.equal u v || check_eq_univs g u v let check_smaller_expr g (u,n) (v,m) = let diff = n - m in match diff with | 0 -> check_smaller g false u v | 1 -> check_smaller g true u v | x when x < 0 -> check_smaller g false u v | _ -> false let exists_bigger g ul l = Huniv.exists (fun ul' -> check_smaller_expr g ul ul') l let real_check_leq g u v = Huniv.for_all (fun ul -> exists_bigger g ul v) u let check_leq g u v = Universe.equal u v || Universe.is_type0m u || check_eq_univs g u v || real_check_leq g u v (** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *) (** To speed up tests of Set Level.t -> reason -> unit *) (* forces u > v *) (* this is normally an update of u in g rather than a creation. *) let setlt g arcu arcv = let arcu' = {arcu with lt=arcv.univ::arcu.lt} in let g = if is_set_arc arcu then set_predicative g arcv else g in enter_arc arcu' g, arcu' (* checks that non-redundant *) let setlt_if (g,arcu) v = let arcv = repr g v in if is_lt g arcu arcv then g, arcu else setlt g arcu arcv (* setleq : Level.t -> Level.t -> unit *) (* forces u >= v *) (* this is normally an update of u in g rather than a creation. *) let setleq g arcu arcv = let arcu' = {arcu with le=arcv.univ::arcu.le} in let g = if is_set_arc arcu' then set_predicative g arcv else g in enter_arc arcu' g, arcu' (* checks that non-redundant *) let setleq_if (g,arcu) v = let arcv = repr g v in if is_leq g arcu arcv then g, arcu else setleq g arcu arcv (* merge : Level.t -> Level.t -> unit *) (* we assume compare(u,v) = LE *) (* merge u v forces u ~ v with repr u as canonical repr *) let merge g arcu arcv = (* we find the arc with the biggest rank, and we redirect all others to it *) let arcu, g, v = let best_ranked (max_rank, old_max_rank, best_arc, rest) arc = if Level.is_small arc.univ || arc.rank >= max_rank then (arc.rank, max_rank, arc, best_arc::rest) else (max_rank, old_max_rank, best_arc, arc::rest) in match between g arcu arcv with | [] -> anomaly (str "Univ.between") | arc::rest -> let (max_rank, old_max_rank, best_arc, rest) = List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in if max_rank > old_max_rank then best_arc, g, rest else begin (* one redirected node also has max_rank *) let arcu = {best_arc with rank = max_rank + 1} in arcu, enter_arc arcu g, rest end in let redirect (g,w,w') arcv = let g' = enter_equiv_arc arcv.univ arcu.univ g in (g',List.unionq arcv.lt w,arcv.le@w') in let (g',w,w') = List.fold_left redirect (g,[],[]) v in let g_arcu = (g',arcu) in let g_arcu = List.fold_left setlt_if g_arcu w in let g_arcu = List.fold_left setleq_if g_arcu w' in fst g_arcu (* merge_disc : Level.t -> Level.t -> unit *) (* we assume compare(u,v) = compare(v,u) = NLE *) (* merge_disc u v forces u ~ v with repr u as canonical repr *) let merge_disc g arc1 arc2 = let arcu, arcv = if arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in let arcu, g = if not (Int.equal arc1.rank arc2.rank) then arcu, g else let arcu = {arcu with rank = succ arcu.rank} in arcu, enter_arc arcu g in let g' = enter_equiv_arc arcv.univ arcu.univ g in let g_arcu = (g',arcu) in let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in let g_arcu = List.fold_left setleq_if g_arcu arcv.le in fst g_arcu (* Universe inconsistency: error raised when trying to enforce a relation that would create a cycle in the graph of universes. *) type univ_inconsistency = constraint_type * universe * universe exception UniverseInconsistency of univ_inconsistency let error_inconsistency o u v = raise (UniverseInconsistency (o,make u,make v)) (* enforc_univ_eq : Level.t -> Level.t -> unit *) (* enforc_univ_eq u v will force u=v if possible, will fail otherwise *) let enforce_univ_eq u v g = let arcu = repr g u in let arcv = repr g v in match fast_compare g arcu arcv with | FastEQ -> g | FastLT -> error_inconsistency Eq v u | FastLE -> merge g arcu arcv | FastNLE -> (match fast_compare g arcv arcu with | FastLT -> error_inconsistency Eq u v | FastLE -> merge g arcv arcu | FastNLE -> merge_disc g arcu arcv | FastEQ -> anomaly (Pp.str "Univ.compare")) (* enforce_univ_leq : Level.t -> Level.t -> unit *) (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) let enforce_univ_leq u v g = let arcu = repr g u in let arcv = repr g v in if is_leq g arcu arcv then g else match fast_compare g arcv arcu with | FastLT -> error_inconsistency Le u v | FastLE -> merge g arcv arcu | FastNLE -> fst (setleq g arcu arcv) | FastEQ -> anomaly (Pp.str "Univ.compare") (* enforce_univ_lt u v will force u g | FastLE -> fst (setlt g arcu arcv) | FastEQ -> error_inconsistency Lt u v | FastNLE -> match fast_compare_neq false g arcv arcu with FastNLE -> fst (setlt g arcu arcv) | FastEQ -> anomaly (Pp.str "Univ.compare") | FastLE | FastLT -> error_inconsistency Lt u v (* Prop = Set is forbidden here. *) let initial_universes = let g = enter_arc (terminal Level.set) UMap.empty in let g = enter_arc (terminal Level.prop) g in enforce_univ_lt Level.prop Level.set g (* Constraints and sets of constraints. *) type univ_constraint = Level.t * constraint_type * Level.t let enforce_constraint cst g = match cst with | (u,Lt,v) -> enforce_univ_lt u v g | (u,Le,v) -> enforce_univ_leq u v g | (u,Eq,v) -> enforce_univ_eq u v g module UConstraintOrd = struct type t = univ_constraint let compare (u,c,v) (u',c',v') = let i = constraint_type_ord c c' in if not (Int.equal i 0) then i else let i' = Level.compare u u' in if not (Int.equal i' 0) then i' else Level.compare v v' end module Constraint = Set.Make(UConstraintOrd) let empty_constraint = Constraint.empty let merge_constraints c g = Constraint.fold enforce_constraint c g type constraints = Constraint.t (** A value with universe constraints. *) type 'a constrained = 'a * constraints (** Constraint functions. *) type 'a constraint_function = 'a -> 'a -> constraints -> constraints let constraint_add_leq v u c = (* We just discard trivial constraints like u<=u *) if Expr.equal v u then c else match v, u with | (x,n), (y,m) -> let j = m - n in if j = -1 (* n = m+1, v+1 <= u <-> v < u *) then Constraint.add (x,Lt,y) c else if j <= -1 (* n = m+k, v+k <= u <-> v+(k-1) < u *) then if Level.equal x y then (* u+(k+1) <= u *) raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u)) else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints") else if j = 0 then Constraint.add (x,Le,y) c else (* j >= 1 *) (* m = n + k, u <= v+k *) if Level.equal x y then c (* u <= u+k, trivial *) else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *) else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints") let check_univ_leq_one u v = Universe.exists (Expr.leq u) v let check_univ_leq u v = Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = match v with | Universe.Huniv.Cons (v, _, Universe.Huniv.Nil) -> Universe.Huniv.fold (fun u -> constraint_add_leq u v) u c | _ -> anomaly (Pp.str"A universe bound can only be a variable") let enforce_leq u v c = if check_univ_leq u v then c else enforce_leq u v c let check_constraint g (l,d,r) = match d with | Eq -> check_equal g l r | Le -> check_smaller g false l r | Lt -> check_smaller g true l r let check_constraints c g = Constraint.for_all (check_constraint g) c (**********************************************************************) (** Universe polymorphism *) (**********************************************************************) (** A universe level substitution, note that no algebraic universes are involved *) type universe_level_subst = universe_level universe_map (** A full substitution might involve algebraic universes *) type universe_subst = universe universe_map let level_subst_of f = fun l -> try let u = f l in match Universe.level u with | None -> l | Some l -> l with Not_found -> l module Instance : sig type t = Level.t array val empty : t val is_empty : t -> bool val equal : t -> t -> bool val subst_fn : universe_level_subst_fn -> t -> t val subst : universe_level_subst -> t -> t val pr : t -> Pp.std_ppcmds val check_eq : t check_function end = struct type t = Level.t array let empty : t = [||] module HInstancestruct = struct type _t = t type t = _t type u = Level.t -> Level.t let hashcons huniv a = let len = Array.length a in if Int.equal len 0 then empty else begin for i = 0 to len - 1 do let x = Array.unsafe_get a i in let x' = huniv x in if x == x' then () else Array.unsafe_set a i x' done; a end let eq t1 t2 = t1 == t2 || (Int.equal (Array.length t1) (Array.length t2) && let rec aux i = (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) in aux 0) let hash a = let accu = ref 0 in for i = 0 to Array.length a - 1 do let l = Array.unsafe_get a i in let h = Level.hash l in accu := Hashset.Combine.combine !accu h; done; (* [h] must be positive. *) let h = !accu land 0x3FFFFFFF in h end module HInstance = Hashcons.Make(HInstancestruct) let hcons = Hashcons.simple_hcons HInstance.generate HInstance.hcons Level.hcons let empty = hcons [||] let is_empty x = Int.equal (Array.length x) 0 let subst_fn fn t = let t' = CArray.smartmap fn t in if t' == t then t else hcons t' let subst s t = let t' = CArray.smartmap (fun x -> try LMap.find x s with Not_found -> x) t in if t' == t then t else hcons t' let pr = prvect_with_sep spc Level.pr let equal t u = t == u || (Array.is_empty t && Array.is_empty u) || (CArray.for_all2 Level.equal t u (* Necessary as universe instances might come from different modules and unmarshalling doesn't preserve sharing *)) let check_eq g t1 t2 = t1 == t2 || (Int.equal (Array.length t1) (Array.length t2) && let rec aux i = (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) in aux 0) end type universe_instance = Instance.t type 'a puniverses = 'a * Instance.t (** A context of universe levels with universe constraints, representiong local universe variables and constraints *) module UContext = struct type t = Instance.t constrained (** Universe contexts (variables as a list) *) let empty = (Instance.empty, Constraint.empty) let make x = x let instance (univs, cst) = univs let constraints (univs, cst) = cst end type universe_context = UContext.t module ContextSet = struct type t = LSet.t constrained let empty = LSet.empty, Constraint.empty let constraints (_, cst) = cst let levels (ctx, _) = ctx let make ctx cst = (ctx, cst) end type universe_context_set = ContextSet.t (** Substitutions. *) let is_empty_subst = LMap.is_empty let empty_level_subst = LMap.empty let is_empty_level_subst = LMap.is_empty (** Substitution functions *) (** With level to level substitutions. *) let subst_univs_level_level subst l = try LMap.find l subst with Not_found -> l let subst_univs_level_universe subst u = let f x = Universe.Expr.map (fun u -> subst_univs_level_level subst u) x in let u' = Universe.smartmap f u in if u == u' then u else Universe.sort u' (** Substitute instance inst for ctx in csts *) let subst_instance_level s l = match l.Level.data with | Level.Var n -> s.(n) | _ -> l let subst_instance_instance s i = Array.smartmap (fun l -> subst_instance_level s l) i let subst_instance_universe s u = let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in let u' = Universe.smartmap f u in if u == u' then u else Universe.sort u' let subst_instance_constraint s (u,d,v as c) = let u' = subst_instance_level s u in let v' = subst_instance_level s v in if u' == u && v' == v then c else (u',d,v') let subst_instance_constraints s csts = Constraint.fold (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) csts Constraint.empty let make_abstract_instance (ctx, _) = Array.mapi (fun i l -> Level.var i) ctx (** Substitute instance inst for ctx in csts *) let instantiate_univ_context (ctx, csts) = (ctx, subst_instance_constraints ctx csts) let instantiate_univ_constraints u (_, csts) = subst_instance_constraints u csts (** With level to universe substitutions. *) type universe_subst_fn = universe_level -> universe let make_subst subst = fun l -> LMap.find l subst let subst_univs_expr_opt fn (l,n) = Universe.addn n (fn l) let subst_univs_universe fn ul = let subst, nosubst = Universe.Huniv.fold (fun u (subst,nosubst) -> try let a' = subst_univs_expr_opt fn u in (a' :: subst, nosubst) with Not_found -> (subst, u :: nosubst)) ul ([], []) in if CList.is_empty subst then ul else let substs = List.fold_left Universe.merge_univs Universe.empty subst in List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u)) substs nosubst let merge_context strict ctx g = let g = Array.fold_left (* Be lenient, module typing reintroduces universes and constraints due to includes *) (fun g v -> try add_universe v strict g with AlreadyDeclared -> g) g (UContext.instance ctx) in merge_constraints (UContext.constraints ctx) g let merge_context_set strict ctx g = let g = LSet.fold (fun v g -> try add_universe v strict g with AlreadyDeclared -> g) (ContextSet.levels ctx) g in merge_constraints (ContextSet.constraints ctx) g (** Pretty-printing *) let pr_arc = function | _, Canonical {univ=u; lt=[]; le=[]} -> mt () | _, Canonical {univ=u; lt=lt; le=le} -> let opt_sep = match lt, le with | [], _ | _, [] -> mt () | _ -> spc () in Level.pr u ++ str " " ++ v 0 (pr_sequence (fun v -> str "< " ++ Level.pr v) lt ++ opt_sep ++ pr_sequence (fun v -> str "<= " ++ Level.pr v) le) ++ fnl () | u, Equiv v -> Level.pr u ++ str " = " ++ Level.pr v ++ fnl () let pr_universes g = let graph = UMap.fold (fun u a l -> (u,a)::l) g [] in prlist pr_arc graph coq-8.6/checker/checker.ml0000644000175000017500000003232513022274260015026 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* =len then dirs else let pos = try String.index_from s n '.' with Not_found -> len in let dir = String.sub s n (pos-n) in decoupe_dirs (dir::dirs) (pos+1) in decoupe_dirs [] 0 let dirpath_of_string s = match parse_dir s with [] -> Check.default_root_prefix | dir -> DirPath.make (List.map Id.of_string dir) let path_of_string s = match parse_dir s with [] -> invalid_arg "path_of_string" | l::dir -> {dirpath=dir; basename=l} let ( / ) = Filename.concat let get_version_date () = try let ch = open_in (Envars.coqlib () / "revision") in let ver = input_line ch in let rev = input_line ch in let () = close_in ch in (ver,rev) with _ -> (Coq_config.version,Coq_config.date) let print_header () = let (ver,rev) = (get_version_date ()) in Printf.printf "Welcome to Chicken %s (%s)\n" ver rev; flush stdout (* Adding files to Coq loadpath *) let add_path ~unix_path:dir ~coq_root:coq_dirpath = if exists_dir dir then begin Check.add_load_path (dir,coq_dirpath) end else Feedback.msg_warning (str "Cannot open " ++ str dir) let convert_string d = try Id.of_string d with CErrors.UserError _ -> if_verbose Feedback.msg_warning (str "Directory " ++ str d ++ str " cannot be used as a Coq identifier (skipped)"); raise Exit let add_rec_path ~unix_path ~coq_root = if exists_dir unix_path then let dirs = all_subdirs ~unix_path in let prefix = DirPath.repr coq_root in let convert_dirs (lp, cp) = try let path = List.rev_map convert_string cp @ prefix in Some (lp, Names.DirPath.make path) with Exit -> None in let dirs = List.map_filter convert_dirs dirs in List.iter Check.add_load_path dirs; Check.add_load_path (unix_path, coq_root) else Feedback.msg_warning (str "Cannot open " ++ str unix_path) (* By the option -include -I or -R of the command line *) let includes = ref [] let push_include (s, alias) = includes := (s,alias,false) :: !includes let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes let set_default_include d = push_include (d, Check.default_root_prefix) let set_include d p = let p = dirpath_of_string p in push_include (d,p) let set_rec_include d p = let p = dirpath_of_string p in push_rec_include(d,p) (* Initializes the LoadPath *) let init_load_path () = let coqlib = Envars.coqlib () in let user_contrib = coqlib/"user-contrib" in let xdg_dirs = Envars.xdg_dirs in let coqpath = Envars.coqpath in let plugins = coqlib/"plugins" in (* NOTE: These directories are searched from last to first *) (* first standard library *) add_rec_path ~unix_path:(coqlib/"theories") ~coq_root:(Names.DirPath.make[coq_root]); (* then plugins *) add_rec_path ~unix_path:plugins ~coq_root:(Names.DirPath.make [coq_root]); (* then user-contrib *) if Sys.file_exists user_contrib then add_rec_path ~unix_path:user_contrib ~coq_root:Check.default_root_prefix; (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME *) List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) (xdg_dirs ~warn:(fun x -> Feedback.msg_warning (str x))); (* then directories in COQPATH *) List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) coqpath; (* then current directory *) add_path ~unix_path:"." ~coq_root:Check.default_root_prefix; (* additional loadpath, given with -I -include -R options *) List.iter (fun (unix_path, coq_root, reci) -> if reci then add_rec_path ~unix_path ~coq_root else add_path ~unix_path ~coq_root) (List.rev !includes); includes := [] let set_debug () = Flags.debug := true let impredicative_set = ref Cic.PredicativeSet let set_impredicative_set () = impredicative_set := Cic.ImpredicativeSet let engage () = Safe_typing.set_engagement (!impredicative_set) let admit_list = ref ([] : section_path list) let add_admit s = admit_list := path_of_string s :: !admit_list let norec_list = ref ([] : section_path list) let add_norec s = norec_list := path_of_string s :: !norec_list let compile_list = ref ([] : section_path list) let add_compile s = compile_list := path_of_string s :: !compile_list (*s Parsing of the command line. We no longer use [Arg.parse], in order to use share [Usage.print_usage] between coqtop and coqc. *) let compile_files () = Check.recheck_library ~norec:(List.rev !norec_list) ~admit:(List.rev !admit_list) ~check:(List.rev !compile_list) let version () = Printf.printf "The Coq Proof Checker, version %s (%s)\n" Coq_config.version Coq_config.date; Printf.printf "compiled on %s\n" Coq_config.compile_date; exit 0 (* print the usage of coqtop (or coqc) on channel co *) let print_usage_channel co command = output_string co command; output_string co "coqchk options are:\n"; output_string co " -R dir coqdir map physical dir to logical coqdir\ \n\ \n -admit module load module and dependencies without checking\ \n -norec module check module but admit dependencies without checking\ \n\ \n -where print coqchk's standard library location and exit\ \n -v print coqchk version and exit\ \n -boot boot mode\ \n -o, --output-context print the list of assumptions\ \n -m, --memory print the maximum heap size\ \n -silent disable trace of constants being checked\ \n\ \n -impredicative-set set sort Set impredicative\ \n\ \n -h, --help print this list of options\ \n" (* print the usage on standard error *) let print_usage = print_usage_channel stderr let print_usage_coqtop () = print_usage "Usage: coqchk modules\n\n" let usage () = print_usage_coqtop (); flush stderr; exit 1 open Type_errors let anomaly_string () = str "Anomaly: " let report () = (str "." ++ spc () ++ str "Please report" ++ strbrk "at " ++ str Coq_config.wwwbugtracker ++ str ".") let guill s = str "\"" ++ str s ++ str "\"" let where s = if !Flags.debug then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) let rec explain_exn = function | Stream.Failure -> hov 0 (anomaly_string () ++ str "uncaught Stream.Failure.") | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt) | Sys_error msg -> hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ guill msg ++ report() ) | UserError(s,pps) -> hov 1 (str "User error: " ++ where s ++ pps) | Out_of_memory -> hov 0 (str "Out of memory") | Stack_overflow -> hov 0 (str "Stack overflow") | Match_failure(filename,pos1,pos2) -> hov 1 (anomaly_string () ++ str "Match failure in file " ++ guill filename ++ str " at line " ++ int pos1 ++ str " character " ++ int pos2 ++ report ()) | Not_found -> hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report ()) | Failure s -> hov 0 (str "Failure: " ++ str s ++ report ()) | Invalid_argument s -> hov 0 (anomaly_string () ++ str "uncaught exception Invalid_argument " ++ guill s ++ report ()) | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") | Univ.UniverseInconsistency (o,u,v) -> let msg = if !Flags.debug (*!Constrextern.print_universes*) then spc() ++ str "(cannot enforce" ++ spc() ++ Univ.pr_uni u ++ spc() ++ str (match o with Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=") ++ spc() ++ Univ.pr_uni v ++ str")" else mt() in hov 0 (str "Error: Universe inconsistency" ++ msg ++ str ".") | TypeError(ctx,te) -> hov 0 (str "Type error: " ++ (match te with | UnboundRel i -> str"UnboundRel " ++ int i | UnboundVar v -> str"UnboundVar" ++ str(Names.Id.to_string v) | NotAType _ -> str"NotAType" | BadAssumption _ -> str"BadAssumption" | ReferenceVariables _ -> str"ReferenceVariables" | ElimArity _ -> str"ElimArity" | CaseNotInductive _ -> str"CaseNotInductive" | WrongCaseInfo _ -> str"WrongCaseInfo" | NumberBranches _ -> str"NumberBranches" | IllFormedBranch _ -> str"IllFormedBranch" | Generalization _ -> str"Generalization" | ActualType _ -> str"ActualType" | CantApplyBadType ((n,a,b),(hd,hdty),args) -> Format.printf "====== ill-typed term ====@\n"; Format.printf "@[application head=@ "; Print.print_pure_constr hd; Format.printf "@]@\n@[head type=@ "; Print.print_pure_constr hdty; Format.printf "@]@\narguments:@\n@["; Array.iteri (fun i (t,ty) -> Format.printf "@[arg %d=@ " (i+1); Print.print_pure_constr t; Format.printf "@ type=@ "; Print.print_pure_constr ty) args; Format.printf "@]@\n====== type error ====@\n"; Print.print_pure_constr b; Format.printf "@\nis not convertible with@\n"; Print.print_pure_constr a; Format.printf "@\n====== universes ====@\n"; chk_pp (Univ.pr_universes (ctx.Environ.env_stratification.Environ.env_universes)); str "\nCantApplyBadType at argument " ++ int n | CantApplyNonFunctional _ -> str"CantApplyNonFunctional" | IllFormedRecBody _ -> str"IllFormedRecBody" | IllTypedRecBody _ -> str"IllTypedRecBody" | UnsatisfiedConstraints _ -> str"UnsatisfiedConstraints")) | Indtypes.InductiveError e -> hov 0 (str "Error related to inductive types") (* let ctx = Check.get_env() in hov 0 (str "Error:" ++ spc () ++ Himsg.explain_inductive_error ctx e)*) | Assert_failure (s,b,e) -> hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++ (if s = "" then mt () else (str "(file \"" ++ str s ++ str "\", line " ++ int b ++ str ", characters " ++ int e ++ str "-" ++ int (e+6) ++ str ")")) ++ report ()) | e -> CErrors.print e (* for anomalies and other uncaught exceptions *) let parse_args argv = let rec parse = function | [] -> () | "-impredicative-set" :: rem -> set_impredicative_set (); parse rem | "-coqlib" :: s :: rem -> if not (exists_dir s) then fatal_error (str "Directory '" ++ str s ++ str "' does not exist") false; Flags.coqlib := s; Flags.coqlib_spec := true; parse rem | ("-I"|"-include") :: d :: "-as" :: p :: rem -> set_include d p; parse rem | ("-I"|"-include") :: d :: "-as" :: [] -> usage () | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem | ("-I"|"-include") :: [] -> usage () | "-R" :: d :: p :: rem -> set_rec_include d p;parse rem | "-R" :: ([] | [_]) -> usage () | "-debug" :: rem -> set_debug (); parse rem | "-where" :: _ -> Envars.set_coqlib ~fail:CErrors.error; print_endline (Envars.coqlib ()); exit 0 | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () | ("-v"|"--version") :: _ -> version () | "-boot" :: rem -> boot := true; parse rem | ("-m" | "--memory") :: rem -> Check_stat.memory_stat := true; parse rem | ("-o" | "--output-context") :: rem -> Check_stat.output_context := true; parse rem | "-admit" :: s :: rem -> add_admit s; parse rem | "-admit" :: [] -> usage () | "-norec" :: s :: rem -> add_norec s; parse rem | "-norec" :: [] -> usage () | "-silent" :: rem -> Flags.make_silent true; parse rem | s :: _ when s<>"" && s.[0]='-' -> fatal_error (str "Unknown option " ++ str s) false | s :: rem -> add_compile s; parse rem in parse (List.tl (Array.to_list argv)) (* To prevent from doing the initialization twice *) let initialized = ref false let init_with_argv argv = if not !initialized then begin initialized := true; Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) try parse_args argv; if !Flags.debug then Printexc.record_backtrace true; Envars.set_coqlib ~fail:CErrors.error; if_verbose print_header (); init_load_path (); engage (); with e -> fatal_error (str "Error during initialization :" ++ (explain_exn e)) (is_anomaly e) end let init() = init_with_argv Sys.argv let run () = try compile_files (); flush_all() with e -> if !Flags.debug then Printexc.print_backtrace stderr; fatal_error (explain_exn e) (is_anomaly e) let start () = init(); run(); Check_stat.stats(); exit 0 coq-8.6/checker/subtyping.ml0000644000175000017500000003602013022274260015442 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Label.Map.add (Label.of_id id) (IndConstr((ip,i+1), mib)) map) oib.mind_consnames map in Label.Map.add (Label.of_id oib.mind_typename) (IndType (ip, mib)) map in Array.fold_right_i add_mip_nameobjects mib.mind_packets map (* creates (namedobject/namedmodule) map for the whole signature *) type labmap = { objs : namedobject Label.Map.t; mods : namedmodule Label.Map.t } let empty_labmap = { objs = Label.Map.empty; mods = Label.Map.empty } let get_obj mp map l = try Label.Map.find l map.objs with Not_found -> error_no_such_label_sub l mp let get_mod mp map l = try Label.Map.find l map.mods with Not_found -> error_no_such_label_sub l mp let make_labmap mp list = let add_one (l,e) map = match e with | SFBconst cb -> { map with objs = Label.Map.add l (Constant cb) map.objs } | SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs } | SFBmodule mb -> { map with mods = Label.Map.add l (Module mb) map.mods } | SFBmodtype mtb -> { map with mods = Label.Map.add l (Modtype mtb) map.mods } in List.fold_right add_one list empty_labmap let check_conv_error error f env a1 a2 = try f env a1 a2 with NotConvertible -> error () (* for now we do not allow reorderings *) let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= let kn = MutInd.make2 mp1 l in let error () = error_not_match l spec2 in let check_conv f = check_conv_error error f in let mib1 = match info1 with | IndType ((_,0), mib) -> mib | _ -> error () in let mib2 = subst_mind subst2 mib2 in let check eq f = if not (eq (f mib1) (f mib2)) then error () in let bool_equal (x : bool) (y : bool) = x = y in let u = check bool_equal (fun x -> x.mind_polymorphic); if mib1.mind_polymorphic then ( check Univ.Instance.equal (fun x -> Univ.UContext.instance x.mind_universes); Univ.UContext.instance mib1.mind_universes) else Univ.Instance.empty in let eq_projection_body p1 p2 = let check eq f = if not (eq (f p1) (f p2)) then error () in check MutInd.equal (fun x -> x.proj_ind); check (==) (fun x -> x.proj_npars); check (==) (fun x -> x.proj_arg); check (eq_constr) (fun x -> x.proj_type); check (eq_constr) (fun x -> fst x.proj_eta); check (eq_constr) (fun x -> snd x.proj_eta); check (eq_constr) (fun x -> x.proj_body); true in let check_inductive_type env t1 t2 = (* Due to sort-polymorphism in inductive types, the conclusions of t1 and t2, if in Type, are generated as the least upper bounds of the types of the constructors. By monotonicity of the infered l.u.b. wrt subtyping (i.e. if X:U |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each universe in the conclusion of t1 has an bounding universe in the conclusion of t2, so that we don't need to check the subtyping of the conclusions of t1 and t2. Even if we'd like to recheck it, the inference of constraints is not designed to deal with algebraic constraints of the form max-univ(u1..un) <= max-univ(u'1..u'n), so that it is not easy to recheck it (in short, we would need the actual graph of constraints as input while type checking is currently designed to output a set of constraints instead) *) (* So we cheat and replace the subtyping problem on algebraic constraints of the form max-univ(u1..un) <= max-univ(u'1..u'n) (that we know are necessary true) by trivial constraints that the constraint generator knows how to deal with *) let (ctx1,s1) = dest_arity env t1 in let (ctx2,s2) = dest_arity env t2 in let s1,s2 = match s1, s2 with | Type _, Type _ -> (* shortcut here *) Prop Null, Prop Null | (Prop _, Type _) | (Type _,Prop _) -> error () | _ -> (s1, s2) in check_conv conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) in let check_packet p1 p2 = let check eq f = if not (eq (f p1) (f p2)) then error () in check (fun a1 a2 -> Array.equal Id.equal a1 a2) (fun p -> p.mind_consnames); check Id.equal (fun p -> p.mind_typename); (* nf_lc later *) (* nf_arity later *) (* user_lc ignored *) (* user_arity ignored *) check Int.equal (fun p -> p.mind_nrealargs); (* kelim ignored *) (* listrec ignored *) (* finite done *) (* nparams done *) (* params_ctxt done because part of the inductive types *) (* Don't check the sort of the type if polymorphic *) check_inductive_type env (type_of_inductive env ((mib1,p1),u)) (type_of_inductive env ((mib2,p2),u)) in let check_cons_types i p1 p2 = Array.iter2 (check_conv conv env) (arities_of_specif (kn,u) (mib1,p1)) (arities_of_specif (kn,u) (mib2,p2)) in check (==) (fun mib -> mib.mind_finite); check Int.equal (fun mib -> mib.mind_ntypes); assert (Array.length mib1.mind_packets >= 1 && Array.length mib2.mind_packets >= 1); (* Check that the expected numbers of uniform parameters are the same *) (* No need to check the contexts of parameters: it is checked *) (* at the time of checking the inductive arities in check_packet. *) (* Notice that we don't expect the local definitions to match: only *) (* the inductive types and constructors types have to be convertible *) check Int.equal (fun mib -> mib.mind_nparams); (*begin match mib2.mind_equiv with | None -> () | Some kn2' -> let kn2 = scrape_mind env kn2' in let kn1 = match mib1.mind_equiv with None -> kn | Some kn1' -> scrape_mind env kn1' in if kn1 <> kn2 then error () end;*) (* we check that records and their field names are preserved. *) let record_equal x y = match x, y with | None, None -> true | Some None, Some None -> true | Some (Some (id1,p1,pb1)), Some (Some (id2,p2,pb2)) -> Id.equal id1 id2 && Array.for_all2 eq_con_chk p1 p2 && Array.for_all2 eq_projection_body pb1 pb2 | _, _ -> false in check record_equal (fun mib -> mib.mind_record); if mib1.mind_record != None then begin let rec names_prod_letin t = match t with | Prod(n,_,t) -> n::(names_prod_letin t) | LetIn(n,_,_,t) -> n::(names_prod_letin t) | Cast(t,_,_) -> names_prod_letin t | _ -> [] in assert (Array.length mib1.mind_packets = 1); assert (Array.length mib2.mind_packets = 1); assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); check (fun l1 l2 -> List.equal Name.equal l1 l2) (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0)); end; (* we first check simple things *) Array.iter2 check_packet mib1.mind_packets mib2.mind_packets; (* and constructor types in the end *) let _ = Array.map2_i check_cons_types mib1.mind_packets mib2.mind_packets in () let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = let error () = error_not_match l spec2 in let check_conv f = check_conv_error error f in let check_type env t1 t2 = (* If the type of a constant is generated, it may mention non-variable algebraic universes that the general conversion algorithm is not ready to handle. Anyway, generated types of constants are functions of the body of the constant. If the bodies are the same in environments that are subtypes one of the other, the types are subtypes too (i.e. if Gamma <= Gamma', Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T'). Hence they don't have to be checked again *) let t1,t2 = if isArity t2 then let (ctx2,s2) = destArity t2 in match s2 with | Type v when not (Univ.is_univ_variable v) -> (* The type in the interface is inferred and is made of algebraic universes *) begin try let (ctx1,s1) = dest_arity env t1 in match s1 with | Type u when not (Univ.is_univ_variable u) -> (* Both types are inferred, no need to recheck them. We cheat and collapse the types to Prop *) mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null) | Prop _ -> (* The type in the interface is inferred, it may be the case that the type in the implementation is smaller because the body is more reduced. We safely collapse the upper type to Prop *) mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null) | Type _ -> (* The type in the interface is inferred and the type in the implementation is not inferred or is inferred but from a more reduced body so that it is just a variable. Since constraints of the form "univ <= max(...)" are not expressible in the system of algebraic universes: we fail (the user has to use an explicit type in the interface *) error () with UserError _ (* "not an arity" *) -> error () end | _ -> t1,t2 else (t1,t2) in check_conv conv_leq env t1 t2 in match info1 with | Constant cb1 -> let cb1 = subst_const_body subst1 cb1 in let cb2 = subst_const_body subst2 cb2 in (*Start by checking types*) let typ1 = Typeops.type_of_constant_type env cb1.const_type in let typ2 = Typeops.type_of_constant_type env cb2.const_type in check_type env typ1 typ2; (* Now we check the bodies: - A transparent constant can only be implemented by a compatible transparent constant. - In the signature, an opaque is handled just as a parameter: anything of the right type can implement it, even if bodies differ. *) (match cb2.const_body with | Undef _ | OpaqueDef _ -> () | Def lc2 -> (match cb1.const_body with | Undef _ | OpaqueDef _ -> error () | Def lc1 -> (* NB: cb1 might have been strengthened and appear as transparent. Anyway [check_conv] will handle that afterwards. *) let c1 = force_constr lc1 in let c2 = force_constr lc2 in check_conv conv env c1 c2)) | IndType ((kn,i),mind1) -> ignore (CErrors.error ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by an inductive type. Hint: you can rename the " ^ "inductive type and give a definition to map the old name to the new " ^ "name.")); if constant_has_body cb2 then error () ; let u = inductive_instance mind1 in let arity1 = type_of_inductive env ((mind1,mind1.mind_packets.(i)),u) in let typ2 = Typeops.type_of_constant_type env cb2.const_type in check_conv conv_leq env arity1 typ2 | IndConstr (((kn,i),j) as cstr,mind1) -> ignore (CErrors.error ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by a constructor. Hint: you can rename the " ^ "constructor and give a definition to map the old name to the new " ^ "name.")); if constant_has_body cb2 then error () ; let u1 = inductive_instance mind1 in let ty1 = type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in let ty2 = Typeops.type_of_constant_type env cb2.const_type in check_conv conv env ty1 ty2 let rec check_modules env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module None msb1 in let mty2 = module_type_of_module None msb2 in check_modtypes env mty1 mty2 subst1 subst2 false; and check_signatures env mp1 sig1 sig2 subst1 subst2 = let map1 = make_labmap mp1 sig1 in let check_one_body (l,spec2) = match spec2 with | SFBconst cb2 -> check_constant env mp1 l (get_obj mp1 map1 l) cb2 spec2 subst1 subst2 | SFBmind mib2 -> check_inductive env mp1 l (get_obj mp1 map1 l) mib2 spec2 subst1 subst2 | SFBmodule msb2 -> begin match get_mod mp1 map1 l with | Module msb -> check_modules env msb msb2 subst1 subst2 | _ -> error_not_match l spec2 end | SFBmodtype mtb2 -> let mtb1 = match get_mod mp1 map1 l with | Modtype mtb -> mtb | _ -> error_not_match l spec2 in let env = add_module_type mtb2.mod_mp mtb2 (add_module_type mtb1.mod_mp mtb1 env) in check_modtypes env mtb1 mtb2 subst1 subst2 true in List.iter check_one_body sig2 and check_modtypes env mtb1 mtb2 subst1 subst2 equiv = if mtb1==mtb2 || mtb1.mod_type == mtb2.mod_type then () else let rec check_structure env str1 str2 equiv subst1 subst2 = match str1,str2 with | NoFunctor (list1), NoFunctor (list2) -> check_signatures env mtb1.mod_mp list1 list2 subst1 subst2; if equiv then check_signatures env mtb2.mod_mp list2 list1 subst1 subst2 else () | MoreFunctor (arg_id1,arg_t1,body_t1), MoreFunctor (arg_id2,arg_t2,body_t2) -> check_modtypes env arg_t2 arg_t1 (map_mp arg_t1.mod_mp arg_t2.mod_mp) subst2 equiv; (* contravariant *) let env = add_module_type (MPbound arg_id2) arg_t2 env in let env = if is_functor body_t1 then env else let env = shallow_remove_module mtb1.mod_mp env in add_module {mod_mp = mtb1.mod_mp; mod_expr = Abstract; mod_type = body_t1; mod_type_alg = None; mod_constraints = mtb1.mod_constraints; mod_retroknowledge = []; mod_delta = mtb1.mod_delta} env in check_structure env body_t1 body_t2 equiv (join (map_mbid arg_id1 (MPbound arg_id2)) subst1) subst2 | _ , _ -> error_incompatible_modtypes mtb1 mtb2 in check_structure env mtb1.mod_type mtb2.mod_type equiv subst1 subst2 let check_subtypes env sup super = check_modtypes env (strengthen sup sup.mod_mp) super empty_subst (map_mp super.mod_mp sup.mod_mp) false coq-8.6/checker/term.ml0000644000175000017500000003403413022274260014370 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* InProp | Prop Pos -> InSet | Type _ -> InType let family_equal = (==) let sort_of_univ u = if Univ.is_type0m_univ u then Prop Null else if Univ.is_type0_univ u then Prop Pos else Type u (********************************************************************) (* Constructions as implemented *) (********************************************************************) let rec strip_outer_cast c = match c with | Cast (c,_,_) -> strip_outer_cast c | _ -> c let collapse_appl c = match c with | App (f,cl) -> let rec collapse_rec f cl2 = match (strip_outer_cast f) with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) | _ -> App (f,cl2) in collapse_rec f cl | _ -> c let decompose_app c = match collapse_appl c with | App (f,cl) -> (f, Array.to_list cl) | _ -> (c,[]) let applist (f,l) = App (f, Array.of_list l) (****************************************************************************) (* Functions for dealing with constr terms *) (****************************************************************************) (*********************) (* Occurring *) (*********************) let iter_constr_with_binders g f n c = match c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () | Cast (c,_,t) -> f n c; f n t | Prod (_,t,c) -> f n t; f (g n) c | Lambda (_,t,c) -> f n t; f (g n) c | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c | App (c,l) -> f n c; Array.iter (f n) l | Evar (_,l) -> Array.iter (f n) l | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl | Fix (_,(_,tl,bl)) -> Array.iter (f n) tl; Array.iter (f (iterate g (Array.length tl) n)) bl | CoFix (_,(_,tl,bl)) -> Array.iter (f n) tl; Array.iter (f (iterate g (Array.length tl) n)) bl | Proj (p, c) -> f n c exception LocalOccur (* (closedn n M) raises FreeVar if a variable of height greater than n occurs in M, returns () otherwise *) let closedn n c = let rec closed_rec n c = match c with | Rel m -> if m>n then raise LocalOccur | _ -> iter_constr_with_binders succ closed_rec n c in try closed_rec n c; true with LocalOccur -> false (* [closed0 M] is true iff [M] is a (deBruijn) closed term *) let closed0 = closedn 0 (* (noccurn n M) returns true iff (Rel n) does NOT occur in term M *) let noccurn n term = let rec occur_rec n c = match c with | Rel m -> if Int.equal m n then raise LocalOccur | _ -> iter_constr_with_binders succ occur_rec n c in try occur_rec n term; true with LocalOccur -> false (* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M for n <= p < n+m *) let noccur_between n m term = let rec occur_rec n c = match c with | Rel(p) -> if n<=p && p iter_constr_with_binders succ occur_rec n c in try occur_rec n term; true with LocalOccur -> false (* Checking function for terms containing existential variables. The function [noccur_with_meta] considers the fact that each existential variable (as well as each isevar) in the term appears applied to its local context, which may contain the CoFix variables. These occurrences of CoFix variables are not considered *) let noccur_with_meta n m term = let rec occur_rec n c = match c with | Rel p -> if n<=p && p (match f with | (Cast (Meta _,_,_)| Meta _) -> () | _ -> iter_constr_with_binders succ occur_rec n c) | Evar (_, _) -> () | _ -> iter_constr_with_binders succ occur_rec n c in try (occur_rec n term; true) with LocalOccur -> false (*********************) (* Lifting *) (*********************) let map_constr_with_binders g f l c = match c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c | Cast (c,k,t) -> Cast (f l c, k, f l t) | Prod (na,t,c) -> Prod (na, f l t, f (g l) c) | Lambda (na,t,c) -> Lambda (na, f l t, f (g l) c) | LetIn (na,b,t,c) -> LetIn (na, f l b, f l t, f (g l) c) | App (c,al) -> App (f l c, Array.map (f l) al) | Evar (e,al) -> Evar (e, Array.map (f l) al) | Case (ci,p,c,bl) -> Case (ci, f l p, f l c, Array.map (f l) bl) | Fix (ln,(lna,tl,bl)) -> let l' = iterate g (Array.length tl) l in Fix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) | CoFix(ln,(lna,tl,bl)) -> let l' = iterate g (Array.length tl) l in CoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) | Proj (p, c) -> Proj (p, f l c) (* The generic lifting function *) let rec exliftn el c = match c with | Rel i -> Rel(reloc_rel i el) | _ -> map_constr_with_binders el_lift exliftn el c (* Lifting the binding depth across k bindings *) let liftn k n = match el_liftn (pred n) (el_shft k el_id) with | ELID -> (fun c -> c) | el -> exliftn el let lift k = liftn k 1 (*********************) (* Substituting *) (*********************) (* (subst1 M c) substitutes M for Rel(1) in c we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel M1,...,Mn for respectively Rel(1),...,Rel(n) in c *) (* 1st : general case *) type info = Closed | Open | Unknown type 'a substituend = { mutable sinfo: info; sit: 'a } let rec lift_substituend depth s = match s.sinfo with | Closed -> s.sit | Open -> lift depth s.sit | Unknown -> s.sinfo <- if closed0 s.sit then Closed else Open; lift_substituend depth s let make_substituend c = { sinfo=Unknown; sit=c } let substn_many lamv n c = let lv = Array.length lamv in if Int.equal lv 0 then c else let rec substrec depth c = match c with | Rel k -> if k<=depth then c else if k-depth <= lv then lift_substituend depth lamv.(k-depth-1) else Rel (k-lv) | _ -> map_constr_with_binders succ substrec depth c in substrec n c let substnl laml n = substn_many (Array.map make_substituend (Array.of_list laml)) n let substl laml = substnl laml 0 let subst1 lam = substl [lam] (***************************************************************************) (* Type of assumptions and contexts *) (***************************************************************************) let empty_rel_context = [] let rel_context_length = List.length let rel_context_nhyps hyps = let rec nhyps acc = function | [] -> acc | LocalAssum _ :: hyps -> nhyps (1+acc) hyps | LocalDef _ :: hyps -> nhyps acc hyps in nhyps 0 hyps let fold_rel_context f l ~init = List.fold_right f l init let map_rel_decl f = function | LocalAssum (n, typ) as decl -> let typ' = f typ in if typ' == typ then decl else LocalAssum (n, typ') | LocalDef (n, body, typ) as decl -> let body' = f body in let typ' = f typ in if body' == body && typ' == typ then decl else LocalDef (n, body', typ') let map_rel_context f = List.smartmap (map_rel_decl f) let extended_rel_list n hyps = let rec reln l p = function | LocalAssum _ :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps | LocalDef _ :: hyps -> reln l (p+1) hyps | [] -> l in reln [] 1 hyps (* Iterate lambda abstractions *) (* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) let compose_lam l b = let rec lamrec = function | ([], b) -> b | ((v,t)::l, b) -> lamrec (l, Lambda (v,t,b)) in lamrec (l,b) (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) let decompose_lam = let rec lamdec_rec l c = match c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c in lamdec_rec [] (* Decompose lambda abstractions and lets, until finding n abstractions *) let decompose_lam_n_assum n = if n < 0 then error "decompose_lam_n_assum: integer parameter must be positive"; let rec lamdec_rec l n c = if Int.equal n 0 then l,c else match c with | Lambda (x,t,c) -> lamdec_rec (LocalAssum (x,t) :: l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (LocalDef (x,b,t) :: l) n c | Cast (c,_,_) -> lamdec_rec l n c | c -> error "decompose_lam_n_assum: not enough abstractions" in lamdec_rec empty_rel_context n (* Iterate products, with or without lets *) (* Constructs either [(x:t)c] or [[x=b:t]c] *) let mkProd_or_LetIn decl c = match decl with | LocalAssum (na,t) -> Prod (na, t, c) | LocalDef (na,b,t) -> LetIn (na, b, t, c) let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) let decompose_prod_assum = let rec prodec_rec l c = match c with | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) c | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c in prodec_rec empty_rel_context let decompose_prod_n_assum n = if n < 0 then error "decompose_prod_n_assum: integer parameter must be positive"; let rec prodec_rec l n c = if Int.equal n 0 then l,c else match c with | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | c -> error "decompose_prod_n_assum: not enough assumptions" in prodec_rec empty_rel_context n (***************************) (* Other term constructors *) (***************************) type arity = rel_context * sorts let mkArity (sign,s) = it_mkProd_or_LetIn (Sort s) sign let destArity = let rec prodec_rec l c = match c with | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t)::l) c | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t)::l) c | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s | _ -> anomaly ~label:"destArity" (Pp.str "not an arity") in prodec_rec [] let rec isArity c = match c with | Prod (_,_,c) -> isArity c | LetIn (_,b,_,c) -> isArity (subst1 b c) | Cast (c,_,_) -> isArity c | Sort _ -> true | _ -> false (*******************************) (* alpha conversion functions *) (*******************************) (* alpha conversion : ignore print names and casts *) let compare_sorts s1 s2 = match s1, s2 with | Prop c1, Prop c2 -> begin match c1, c2 with | Pos, Pos | Null, Null -> true | Pos, Null -> false | Null, Pos -> false end | Type u1, Type u2 -> Univ.Universe.equal u1 u2 | Prop _, Type _ -> false | Type _, Prop _ -> false let eq_puniverses f (c1,u1) (c2,u2) = Univ.Instance.equal u1 u2 && f c1 c2 let compare_constr f t1 t2 = match t1, t2 with | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 | Var id1, Var id2 -> Id.equal id1 id2 | Sort s1, Sort s2 -> compare_sorts s1 s2 | Cast (c1,_,_), _ -> f c1 t2 | _, Cast (c2,_,_) -> f t1 c2 | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 && f c1 c2 | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 && f c1 c2 | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 && f t1 t2 && f c1 c2 | App (c1,l1), App (c2,l2) -> if Int.equal (Array.length l1) (Array.length l2) then f c1 c2 && Array.for_all2 f l1 l2 else let (h1,l1) = decompose_app t1 in let (h2,l2) = decompose_app t2 in if Int.equal (List.length l1) (List.length l2) then f h1 h2 && List.for_all2 f l1 l2 else false | Evar (e1,l1), Evar (e2,l2) -> Int.equal e1 e2 && Array.equal f l1 l2 | Const c1, Const c2 -> eq_puniverses eq_con_chk c1 c2 | Ind c1, Ind c2 -> eq_puniverses eq_ind_chk c1 c2 | Construct ((c1,i1),u1), Construct ((c2,i2),u2) -> Int.equal i1 i2 && eq_ind_chk c1 c2 && Univ.Instance.equal u1 u2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> f p1 p2 && f c1 c2 && Array.equal f bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 && Array.equal f tl1 tl2 && Array.equal f bl1 bl2 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> Int.equal ln1 ln2 && Array.equal f tl1 tl2 && Array.equal f bl1 bl2 | Proj (p1,c1), Proj(p2,c2) -> Projection.equal p1 p2 && f c1 c2 | _ -> false let rec eq_constr m n = (m == n) || compare_constr eq_constr m n let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *) (* Universe substitutions *) let map_constr f c = map_constr_with_binders (fun x -> x) (fun _ c -> f c) 0 c let subst_instance_constr subst c = if Univ.Instance.is_empty subst then c else let f u = Univ.subst_instance_instance subst u in let changed = ref false in let rec aux t = match t with | Const (c, u) -> if Univ.Instance.is_empty u then t else let u' = f u in if u' == u then t else (changed := true; Const (c, u')) | Ind (i, u) -> if Univ.Instance.is_empty u then t else let u' = f u in if u' == u then t else (changed := true; Ind (i, u')) | Construct (c, u) -> if Univ.Instance.is_empty u then t else let u' = f u in if u' == u then t else (changed := true; Construct (c, u')) | Sort (Type u) -> let u' = Univ.subst_instance_universe subst u in if u' == u then t else (changed := true; Sort (sort_of_univ u')) | _ -> map_constr aux t in let c' = aux c in if !changed then c' else c let subst_instance_context s ctx = if Univ.Instance.is_empty s then ctx else map_rel_context (fun x -> subst_instance_constr s x) ctx coq-8.6/checker/safe_typing.mli0000644000175000017500000000151413022274260016077 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* env val set_engagement : engagement -> unit val import : CUnix.physical_path -> compiled_library -> Univ.ContextSet.t -> Cic.vodigest -> unit val unsafe_import : CUnix.physical_path -> compiled_library -> Univ.ContextSet.t -> Cic.vodigest -> unit coq-8.6/checker/inductive.ml0000644000175000017500000012525313022274260015417 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* = Array.length mib.mind_packets then error "Inductive.lookup_mind_specif: invalid inductive index"; (mib, mib.mind_packets.(tyi)) let find_rectype env c = let (t, l) = decompose_app (whd_all env c) in match t with | Ind ind -> (ind, l) | _ -> raise Not_found let find_inductive env c = let (t, l) = decompose_app (whd_all env c) in match t with | Ind (ind,_) when (fst (lookup_mind_specif env ind)).mind_finite != CoFinite -> (ind, l) | _ -> raise Not_found let find_coinductive env c = let (t, l) = decompose_app (whd_all env c) in match t with | Ind (ind,_) when (fst (lookup_mind_specif env ind)).mind_finite == CoFinite -> (ind, l) | _ -> raise Not_found let inductive_params (mib,_) = mib.mind_nparams (** Polymorphic inductives *) let inductive_instance mib = if mib.mind_polymorphic then UContext.instance mib.mind_universes else Instance.empty (************************************************************************) (* Build the substitution that replaces Rels by the appropriate *) (* inductives *) let ind_subst mind mib u = let ntypes = mib.mind_ntypes in let make_Ik k = Ind ((mind,ntypes-k-1),u) in List.init ntypes make_Ik (* Instantiate inductives in constructor type *) let constructor_instantiate mind u mib c = let s = ind_subst mind mib u in substl s (subst_instance_constr u c) let instantiate_params full t u args sign = let fail () = anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in let (rem_args, subs, ty) = fold_rel_context (fun decl (largs,subs,ty) -> match (decl, largs, ty) with | (LocalAssum _, a::args, Prod(_,_,t)) -> (args, a::subs, t) | (LocalDef (_,b,_),_,LetIn(_,_,_,t)) -> (largs, (substl subs (subst_instance_constr u b))::subs, t) | (_,[],_) -> if full then fail() else ([], subs, ty) | _ -> fail ()) sign ~init:(args,[],t) in if rem_args <> [] then fail(); substl subs ty let full_inductive_instantiate mib u params sign = let dummy = Prop Null in let t = mkArity (subst_instance_context u sign,dummy) in fst (destArity (instantiate_params true t u params mib.mind_params_ctxt)) let full_constructor_instantiate ((mind,_),u,(mib,_),params) t = let inst_ind = constructor_instantiate mind u mib t in instantiate_params true inst_ind u params mib.mind_params_ctxt (************************************************************************) (************************************************************************) (* Functions to build standard types related to inductive *) (* Computing the actual sort of an applied or partially applied inductive type: I_i: forall uniformparams:utyps, forall otherparams:otyps, Type(a) uniformargs : utyps otherargs : otyps I_1:forall ...,s_1;...I_n:forall ...,s_n |- sort(C_kj(uniformargs)) = s_kj s'_k = max(..s_kj..) merge(..s'_k..) = ..s''_k.. -------------------------------------------------------------------- Gamma |- I_i uniformargs otherargs : phi(s''_i) where - if p=0, phi() = Prop - if p=1, phi(s) = s - if p<>1, phi(s) = sup(Set,s) Remark: Set (predicative) is encoded as Type(0) *) let sort_as_univ = function | Type u -> u | Prop Null -> Univ.type0m_univ | Prop Pos -> Univ.type0_univ (* cons_subst add the mapping [u |-> su] in subst if [u] is not *) (* in the domain or add [u |-> sup x su] if [u] is already mapped *) (* to [x]. *) let cons_subst u su subst = try Univ.LMap.add u (Univ.sup (Univ.LMap.find u subst) su) subst with Not_found -> Univ.LMap.add u su subst (* remember_subst updates the mapping [u |-> x] by [u |-> sup x u] *) (* if it is presents and returns the substitution unchanged if not.*) let remember_subst u subst = try let su = Universe.make u in Univ.LMap.add u (Univ.sup (Univ.LMap.find u subst) su) subst with Not_found -> subst (* Bind expected levels of parameters to actual levels *) (* Propagate the new levels in the signature *) let rec make_subst env = let rec make subst = function | LocalDef _ :: sign, exp, args -> make subst (sign, exp, args) | d::sign, None::exp, args -> let args = match args with _::args -> args | [] -> [] in make subst (sign, exp, args) | d::sign, Some u::exp, a::args -> (* We recover the level of the argument, but we don't change the *) (* level in the corresponding type in the arity; this level in the *) (* arity is a global level which, at typing time, will be enforce *) (* to be greater than the level of the argument; this is probably *) (* a useless extra constraint *) let s = sort_as_univ (snd (dest_arity env a)) in make (cons_subst u s subst) (sign, exp, args) | LocalAssum (na,t) :: sign, Some u::exp, [] -> (* No more argument here: we add the remaining universes to the *) (* substitution (when [u] is distinct from all other universes in the *) (* template, it is identity substitution otherwise (ie. when u is *) (* already in the domain of the substitution) [remember_subst] will *) (* update its image [x] by [sup x u] in order not to forget the *) (* dependency in [u] that remains to be fullfilled. *) make (remember_subst u subst) (sign, exp, []) | sign, [], _ -> (* Uniform parameters are exhausted *) subst | [], _, _ -> assert false in make Univ.LMap.empty let instantiate_universes env ctx ar argsorts = let args = Array.to_list argsorts in let subst = make_subst env (ctx,ar.template_param_levels,args) in let level = Univ.subst_univs_universe (Univ.make_subst subst) ar.template_level in let ty = (* Singleton type not containing types are interpretable in Prop *) if Univ.is_type0m_univ level then Prop Null (* Non singleton type not containing types are interpretable in Set *) else if Univ.is_type0_univ level then Prop Pos (* This is a Type with constraints *) else Type level in (ctx, ty) (* Type of an inductive type *) let type_of_inductive_gen env ((mib,mip),u) paramtyps = match mip.mind_arity with | RegularArity a -> if not mib.mind_polymorphic then a.mind_user_arity else subst_instance_constr u a.mind_user_arity | TemplateArity ar -> let ctx = List.rev mip.mind_arity_ctxt in let ctx,s = instantiate_universes env ctx ar paramtyps in mkArity (List.rev ctx,s) let type_of_inductive_knowing_parameters env mip args = type_of_inductive_gen env mip args (* Type of a (non applied) inductive type *) let type_of_inductive env mip = type_of_inductive_knowing_parameters env mip [||] (* The max of an array of universes *) let cumulate_constructor_univ u = function | Prop Null -> u | Prop Pos -> Univ.sup Univ.type0_univ u | Type u' -> Univ.sup u u' let max_inductive_sort = Array.fold_left cumulate_constructor_univ Univ.type0m_univ (************************************************************************) (* Type of a constructor *) let type_of_constructor_subst cstr u (mib,mip) = let ind = inductive_of_constructor cstr in let specif = mip.mind_user_lc in let i = index_of_constructor cstr in let nconstr = Array.length mip.mind_consnames in if i > nconstr then error "Not enough constructors in the type."; constructor_instantiate (fst ind) u mib specif.(i-1) let type_of_constructor_gen (cstr,u) (mib,mip as mspec) = type_of_constructor_subst cstr u mspec let type_of_constructor cstru mspec = type_of_constructor_gen cstru mspec let arities_of_specif (kn,u) (mib,mip) = let specif = mip.mind_nf_lc in Array.map (constructor_instantiate kn u mib) specif (************************************************************************) let error_elim_expln kp ki = match kp,ki with | (InType | InSet), InProp -> NonInformativeToInformative | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *) | _ -> WrongArity (* Type of case predicates *) (* Get type of inductive, with parameters instantiated *) let inductive_sort_family mip = match mip.mind_arity with | RegularArity s -> family_of_sort s.mind_sort | TemplateArity _ -> InType let mind_arity mip = mip.mind_arity_ctxt, inductive_sort_family mip let get_instantiated_arity (ind,u) (mib,mip) params = let sign, s = mind_arity mip in full_inductive_instantiate mib u params sign, s let elim_sorts (_,mip) = mip.mind_kelim let extended_rel_list n hyps = let rec reln l p = function | LocalAssum _ :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps | LocalDef _ :: hyps -> reln l (p+1) hyps | [] -> l in reln [] 1 hyps let build_dependent_inductive ind (_,mip) params = let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in applist (Ind ind, List.map (lift mip.mind_nrealdecls) params @ extended_rel_list 0 realargs) (* This exception is local *) exception LocalArity of (sorts_family * sorts_family * arity_error) option let check_allowed_sort ksort specif = if not (List.exists ((=) ksort) (elim_sorts specif)) then let s = inductive_sort_family (snd specif) in raise (LocalArity (Some(ksort,s,error_elim_expln ksort s))) let is_correct_arity env c (p,pj) ind specif params = let arsign,_ = get_instantiated_arity ind specif params in let rec srec env pt ar = let pt' = whd_all env pt in match pt', ar with | Prod (na1,a1,t), LocalAssum (_,a1')::ar' -> (try conv env a1 a1' with NotConvertible -> raise (LocalArity None)); srec (push_rel (LocalAssum (na1,a1)) env) t ar' | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) let env' = push_rel (LocalAssum (na1,a1)) env in let ksort = match (whd_all env' a2) with | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in let dep_ind = build_dependent_inductive ind specif params in (try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None)); check_allowed_sort ksort specif; true | Sort s', [] -> check_allowed_sort (family_of_sort s') specif; false | _, (LocalDef _ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' | _ -> raise (LocalArity None) in try srec env pj (List.rev arsign) with LocalArity kinds -> error_elim_arity env ind (elim_sorts specif) c (p,pj) kinds (************************************************************************) (* Type of case branches *) (* [p] is the predicate, [i] is the constructor number (starting from 0), and [cty] is the type of the constructor (params not instantiated) *) let build_branches_type (ind,u) (_,mip as specif) params dep p = let build_one_branch i cty = let typi = full_constructor_instantiate (ind,u,specif,params) cty in let (args,ccl) = decompose_prod_assum typi in let nargs = rel_context_length args in let (_,allargs) = decompose_app ccl in let (lparams,vargs) = List.chop (inductive_params specif) allargs in let cargs = if dep then let cstr = ith_constructor_of_inductive ind (i+1) in let dep_cstr = applist (Construct (cstr,u),lparams@extended_rel_list 0 args) in vargs @ [dep_cstr] else vargs in let base = beta_appvect (lift nargs p) (Array.of_list cargs) in it_mkProd_or_LetIn base args in Array.mapi build_one_branch mip.mind_nf_lc (* [p] is the predicate, [c] is the match object, [realargs] is the list of real args of the inductive type *) let build_case_type dep p c realargs = let args = if dep then realargs@[c] else realargs in beta_appvect p (Array.of_list args) let type_case_branches env (pind,largs) (p,pj) c = let specif = lookup_mind_specif env (fst pind) in let nparams = inductive_params specif in let (params,realargs) = List.chop nparams largs in let dep = is_correct_arity env c (p,pj) pind specif params in let lc = build_branches_type pind specif params dep p in let ty = build_case_type dep p c realargs in (lc, ty) (************************************************************************) (* Checking the case annotation is relevant *) let check_case_info env indsp ci = let (mib,mip) = lookup_mind_specif env indsp in if not (eq_ind indsp ci.ci_ind) || (mib.mind_nparams <> ci.ci_npar) || (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls) || (mip.mind_consnrealargs <> ci.ci_cstr_nargs) then raise (TypeError(env,WrongCaseInfo(indsp,ci))) (************************************************************************) (************************************************************************) (* Guard conditions for fix and cofix-points *) (* Check if t is a subterm of Rel n, and gives its specification, assuming lst already gives index of subterms with corresponding specifications of recursive arguments *) (* A powerful notion of subterm *) (* To each inductive definition corresponds an array describing the structure of recursive arguments for each constructor, we call it the recursive spec of the type (it has type recargs vect). For checking the guard, we start from the decreasing argument (Rel n) with its recursive spec. During checking the guardness condition, we collect patterns variables corresponding to subterms of n, each of them with its recursive spec. They are organised in a list lst of type (int * recargs) list which is sorted with respect to the first argument. *) (*************************************************************) (* Environment annotated with marks on recursive arguments *) (* tells whether it is a strict or loose subterm *) type size = Large | Strict (* merging information *) let size_glb s1 s2 = match s1,s2 with Strict, Strict -> Strict | _ -> Large (* possible specifications for a term: - Not_subterm: when the size of a term is not related to the recursive argument of the fixpoint - Subterm: when the term is a subterm of the recursive argument the wf_paths argument specifies which subterms are recursive - Dead_code: when the term has been built by elimination over an empty type *) type subterm_spec = Subterm of (size * wf_paths) | Dead_code | Not_subterm let eq_recarg r1 r2 = match r1, r2 with | Norec, Norec -> true | Mrec i1, Mrec i2 -> Names.eq_ind i1 i2 | Imbr i1, Imbr i2 -> Names.eq_ind i1 i2 | _ -> false let eq_wf_paths = Rtree.equal eq_recarg let pp_recarg = function | Norec -> Pp.str "Norec" | Mrec i -> Pp.str ("Mrec "^MutInd.to_string (fst i)) | Imbr i -> Pp.str ("Imbr "^MutInd.to_string (fst i)) let pp_wf_paths = Rtree.pp_tree pp_recarg let inter_recarg r1 r2 = match r1, r2 with | Norec, Norec -> Some r1 | Mrec i1, Mrec i2 | Imbr i1, Imbr i2 | Mrec i1, Imbr i2 -> if Names.eq_ind i1 i2 then Some r1 else None | Imbr i1, Mrec i2 -> if Names.eq_ind i1 i2 then Some r2 else None | _ -> None let inter_wf_paths = Rtree.inter eq_recarg inter_recarg Norec let incl_wf_paths = Rtree.incl eq_recarg inter_recarg Norec let spec_of_tree t = if eq_wf_paths t mk_norec then Not_subterm else Subterm (Strict, t) let inter_spec s1 s2 = match s1, s2 with | _, Dead_code -> s1 | Dead_code, _ -> s2 | Not_subterm, _ -> s1 | _, Not_subterm -> s2 | Subterm (a1,t1), Subterm (a2,t2) -> Subterm (size_glb a1 a2, inter_wf_paths t1 t2) let subterm_spec_glb = Array.fold_left inter_spec Dead_code type guard_env = { env : env; (* dB of last fixpoint *) rel_min : int; (* dB of variables denoting subterms *) genv : subterm_spec Lazy.t list; } let make_renv env recarg tree = { env = env; rel_min = recarg+2; (* recarg = 0 ==> Rel 1 -> recarg; Rel 2 -> fix *) genv = [Lazy.from_val(Subterm(Large,tree))] } let push_var renv (x,ty,spec) = { env = push_rel (LocalAssum (x,ty)) renv.env; rel_min = renv.rel_min+1; genv = spec:: renv.genv } let assign_var_spec renv (i,spec) = { renv with genv = List.assign renv.genv (i-1) spec } let push_var_renv renv (x,ty) = push_var renv (x,ty,Lazy.from_val Not_subterm) (* Fetch recursive information about a variable p *) let subterm_var p renv = try Lazy.force (List.nth renv.genv (p-1)) with Failure _ | Invalid_argument _ -> Not_subterm let push_ctxt_renv renv ctxt = let n = rel_context_length ctxt in { env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> Lazy.from_val Not_subterm::ge) n renv.genv } let push_fix_renv renv (_,v,_ as recdef) = let n = Array.length v in { env = push_rec_types recdef renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> Lazy.from_val Not_subterm::ge) n renv.genv } (* Definition and manipulation of the stack *) type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t let push_stack_closures renv l stack = List.fold_right (fun h b -> (SClosure (renv,h))::b) l stack let push_stack_args l stack = List.fold_right (fun h b -> (SArg h)::b) l stack (******************************) (* Computing the recursive subterms of a term (propagation of size information through Cases). *) (* c is a branch of an inductive definition corresponding to the spec lrec. mind_recvec is the recursive spec of the inductive definition of the decreasing argument n. case_branches_specif renv lrec lc will pass the lambdas of c corresponding to pattern variables and collect possibly new subterms variables and returns the bodies of the branches with the correct envs and decreasing args. *) let lookup_subterms env ind = let (_,mip) = lookup_mind_specif env ind in mip.mind_recargs let match_inductive ind ra = match ra with | (Mrec i | Imbr i) -> eq_ind ind i | Norec -> false (* In {match c as z in ci y_s return P with |C_i x_s => t end} [branches_specif renv c_spec ci] returns an array of x_s specs knowing c_spec. *) let branches_specif renv c_spec ci = let car = (* We fetch the regular tree associated to the inductive of the match. This is just to get the number of constructors (and constructor arities) that fit the match branches without forcing c_spec. Note that c_spec might be more precise than [v] below, because of nested inductive types. *) let (_,mip) = lookup_mind_specif renv.env ci.ci_ind in let v = dest_subterms mip.mind_recargs in Array.map List.length v in Array.mapi (fun i nca -> (* i+1-th cstructor has arity nca *) let lvra = lazy (match Lazy.force c_spec with Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) -> let vra = Array.of_list (dest_subterms t).(i) in assert (nca = Array.length vra); Array.map spec_of_tree vra | Dead_code -> Array.make nca Dead_code | _ -> Array.make nca Not_subterm) in List.init nca (fun j -> lazy (Lazy.force lvra).(j))) car let check_inductive_codomain env p = let absctx, ar = dest_lam_assum env p in let env = push_rel_context absctx env in let arctx, s = dest_prod_assum env ar in let env = push_rel_context arctx env in let i,l' = decompose_app (whd_all env s) in match i with Ind _ -> true | _ -> false (* The following functions are almost duplicated from indtypes.ml, except that they carry here a poorer environment (containing less information). *) let ienv_push_var (env, lra) (x,a,ra) = (push_rel (LocalAssum (x,a)) env, (Norec,ra)::lra) let ienv_push_inductive (env, ra_env) ((mind,u),lpar) = let mib = Environ.lookup_mind mind env in let ntypes = mib.mind_ntypes in let push_ind specif env = let decl = LocalAssum (Anonymous, hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in push_rel decl env in let env = Array.fold_right push_ind mib.mind_packets env in let rc = Array.mapi (fun j t -> (Imbr (mind,j),t)) (Rtree.mk_rec_calls ntypes) in let lra_ind = Array.rev_to_list rc in let ra_env = List.map (fun (r,t) -> (r,Rtree.lift ntypes t)) ra_env in (env, lra_ind @ ra_env) let rec ienv_decompose_prod (env,_ as ienv) n c = if Int.equal n 0 then (ienv,c) else let c' = whd_all env c in match c' with Prod(na,a,b) -> let ienv' = ienv_push_var ienv (na,a,mk_norec) in ienv_decompose_prod ienv' (n-1) b | _ -> assert false let lambda_implicit_lift n a = let level = Level.make (DirPath.make [Id.of_string "implicit"]) 0 in let implicit_sort = Sort (Type (Universe.make level)) in let lambda_implicit a = Lambda (Anonymous, implicit_sort, a) in iterate lambda_implicit n (lift n a) let abstract_mind_lc ntyps npars lc = if Int.equal npars 0 then lc else let make_abs = List.init ntyps (function i -> lambda_implicit_lift npars (Rel (i+1))) in Array.map (substl make_abs) lc (* [get_recargs_approx env tree ind args] builds an approximation of the recargs tree for ind, knowing args. The argument tree is used to know when candidate nested types should be traversed, pruning the tree otherwise. This code is very close to check_positive in indtypes.ml, but does no positivy check and does not compute the number of recursive arguments. *) let get_recargs_approx env tree ind args = let rec build_recargs (env, ra_env as ienv) tree c = let x,largs = decompose_app (whd_all env c) in match x with | Prod (na,b,d) -> assert (List.is_empty largs); build_recargs (ienv_push_var ienv (na, b, mk_norec)) tree d | Rel k -> (* Free variables are allowed and assigned Norec *) (try snd (List.nth ra_env (k-1)) with Failure _ | Invalid_argument _ -> mk_norec) | Ind ind_kn -> (* When the inferred tree allows it, we consider that we have a potential nested inductive type *) begin match dest_recarg tree with | Imbr kn' | Mrec kn' when eq_ind (fst ind_kn) kn' -> build_recargs_nested ienv tree (ind_kn, largs) | _ -> mk_norec end | err -> mk_norec and build_recargs_nested (env,ra_env as ienv) tree (((mind,i),u), largs) = (* If the infered tree already disallows recursion, no need to go further *) if eq_wf_paths tree mk_norec then tree else let mib = Environ.lookup_mind mind env in let auxnpar = mib.mind_nparams_rec in let nonrecpar = mib.mind_nparams - auxnpar in let (lpar,_) = List.chop auxnpar largs in let auxntyp = mib.mind_ntypes in (* Extends the environment with a variable corresponding to the inductive def *) let (env',_ as ienv') = ienv_push_inductive ienv ((mind,u),lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in (* In case of mutual inductive types, we use the recargs tree which was computed statically. This is fine because nested inductive types with mutually recursive containers are not supported. *) let trees = if Int.equal auxntyp 1 then [|dest_subterms tree|] else Array.map (fun mip -> dest_subterms mip.mind_recargs) mib.mind_packets in let mk_irecargs j specif = (* The nested inductive type with parameters removed *) let auxlcvect = abstract_mind_lc auxntyp auxnpar specif.mind_nf_lc in let paths = Array.mapi (fun k c -> let c' = hnf_prod_applist env' c lpar' in (* skip non-recursive parameters *) let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in build_recargs_constructors ienv' trees.(j).(k) c') auxlcvect in mk_paths (Imbr (mind,j)) paths in let irecargs = Array.mapi mk_irecargs mib.mind_packets in (Rtree.mk_rec irecargs).(i) and build_recargs_constructors ienv trees c = let rec recargs_constr_rec (env,ra_env as ienv) trees lrec c = let x,largs = decompose_app (whd_all env c) in match x with | Prod (na,b,d) -> let () = assert (List.is_empty largs) in let recarg = build_recargs ienv (List.hd trees) b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in recargs_constr_rec ienv' (List.tl trees) (recarg::lrec) d | hd -> List.rev lrec in recargs_constr_rec ienv trees [] c in (* starting with ra_env = [] seems safe because any unbounded Rel will be assigned Norec *) build_recargs_nested (env,[]) tree (ind, args) (* [restrict_spec env spec p] restricts the size information in spec to what is allowed to flow through a match with predicate p in environment env. *) let restrict_spec env spec p = if spec = Not_subterm then spec else let absctx, ar = dest_lam_assum env p in (* Optimization: if the predicate is not dependent, no restriction is needed and we avoid building the recargs tree. *) if noccur_with_meta 1 (rel_context_length absctx) ar then spec else let env = push_rel_context absctx env in let arctx, s = dest_prod_assum env ar in let env = push_rel_context arctx env in let i,args = decompose_app (whd_all env s) in match i with | Ind i -> begin match spec with | Dead_code -> spec | Subterm(st,tree) -> let recargs = get_recargs_approx env tree i args in let recargs = inter_wf_paths tree recargs in Subterm(st,recargs) | _ -> assert false end | _ -> Not_subterm (* [subterm_specif renv t] computes the recursive structure of [t] and compare its size with the size of the initial recursive argument of the fixpoint we are checking. [renv] collects such information about variables. *) let rec subterm_specif renv stack t = (* maybe reduction is not always necessary! *) let f,l = decompose_app (whd_all renv.env t) in match f with | Rel k -> subterm_var k renv | Case (ci,p,c,lbr) -> let stack' = push_stack_closures renv l stack in let cases_spec = branches_specif renv (lazy_subterm_specif renv [] c) ci in let stl = Array.mapi (fun i br' -> let stack_br = push_stack_args (cases_spec.(i)) stack' in subterm_specif renv stack_br br') lbr in let spec = subterm_spec_glb stl in restrict_spec renv.env spec p | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> (* when proving that the fixpoint f(x)=e is less than n, it is enough to prove that e is less than n assuming f is less than n furthermore when f is applied to a term which is strictly less than n, one may assume that x itself is strictly less than n *) if not (check_inductive_codomain renv.env typarray.(i)) then Not_subterm else let (ctxt,clfix) = dest_prod renv.env typarray.(i) in let oind = let env' = push_rel_context ctxt renv.env in try Some(fst(find_inductive env' clfix)) with Not_found -> None in (match oind with None -> Not_subterm (* happens if fix is polymorphic *) | Some ind -> let nbfix = Array.length typarray in let recargs = lookup_subterms renv.env ind in (* pushing the fixpoints *) let renv' = push_fix_renv renv recdef in let renv' = (* Why Strict here ? To be general, it could also be Large... *) assign_var_spec renv' (nbfix-i, lazy (Subterm(Strict,recargs))) in let decrArg = recindxs.(i) in let theBody = bodies.(i) in let nbOfAbst = decrArg+1 in let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in (* pushing the fix parameters *) let stack' = push_stack_closures renv l stack in let renv'' = push_ctxt_renv renv' sign in let renv'' = if List.length stack' < nbOfAbst then renv'' else let decrArg = List.nth stack' decrArg in let arg_spec = stack_element_specif decrArg in assign_var_spec renv'' (1, arg_spec) in subterm_specif renv'' [] strippedBody) | Lambda (x,a,b) -> assert (l=[]); let spec,stack' = extract_stack renv a stack in subterm_specif (push_var renv (x,a,spec)) stack' b (* Metas and evars are considered OK *) | (Meta _|Evar _) -> Dead_code (* Other terms are not subterms *) | _ -> Not_subterm and lazy_subterm_specif renv stack t = lazy (subterm_specif renv stack t) and stack_element_specif = function |SClosure (h_renv,h) -> lazy_subterm_specif h_renv [] h |SArg x -> x and extract_stack renv a = function | [] -> Lazy.from_val Not_subterm , [] | h::t -> stack_element_specif h, t (* Check size x is a correct size for recursive calls. *) let check_is_subterm x tree = match Lazy.force x with | Subterm (Strict,tree') -> incl_wf_paths tree tree' | Dead_code -> true | _ -> false (************************************************************************) exception FixGuardError of env * guard_error let error_illegal_rec_call renv fx (arg_renv,arg) = let (_,le_vars,lt_vars) = List.fold_left (fun (i,le,lt) sbt -> match Lazy.force sbt with (Subterm(Strict,_) | Dead_code) -> (i+1, le, i::lt) | (Subterm(Large,_)) -> (i+1, i::le, lt) | _ -> (i+1, le ,lt)) (1,[],[]) renv.genv in raise (FixGuardError (renv.env, RecursionOnIllegalTerm(fx,(arg_renv.env, arg), le_vars,lt_vars))) let error_partial_apply renv fx = raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx)) let filter_stack_domain env ci p stack = let absctx, ar = dest_lam_assum env p in (* Optimization: if the predicate is not dependent, no restriction is needed and we avoid building the recargs tree. *) if noccur_with_meta 1 (rel_context_length absctx) ar then stack else let env = push_rel_context absctx env in let rec filter_stack env ar stack = let t = whd_all env ar in match stack, t with | elt :: stack', Prod (n,a,c0) -> let d = LocalAssum (n,a) in let ty, args = decompose_app (whd_all env a) in let elt = match ty with | Ind ind -> let spec' = stack_element_specif elt in (match (Lazy.force spec') with | Not_subterm | Dead_code -> elt | Subterm(s,path) -> let recargs = get_recargs_approx env path ind args in let path = inter_wf_paths path recargs in SArg (lazy (Subterm(s,path)))) | _ -> (SArg (lazy Not_subterm)) in elt :: filter_stack (push_rel d env) c0 stack' | _,_ -> List.fold_right (fun _ l -> SArg (lazy Not_subterm) :: l) stack [] in filter_stack env ar stack (* Check if [def] is a guarded fixpoint body with decreasing arg. given [recpos], the decreasing arguments of each mutually defined fixpoint. *) let check_one_fix renv recpos trees def = let nfi = Array.length recpos in (* Checks if [t] only make valid recursive calls *) let rec check_rec_call renv stack t = (* if [t] does not make recursive calls, it is guarded: *) if noccur_with_meta renv.rel_min nfi t then () else let (f,l) = decompose_app (whd_betaiotazeta t) in match f with | Rel p -> (* Test if [p] is a fixpoint (recursive call) *) if renv.rel_min <= p && p < renv.rel_min+nfi then begin List.iter (check_rec_call renv []) l; (* the position of the invoked fixpoint: *) let glob = renv.rel_min+nfi-1-p in (* the decreasing arg of the rec call: *) let np = recpos.(glob) in let stack' = push_stack_closures renv l stack in if List.length stack' <= np then error_partial_apply renv glob else (* Retrieve the expected tree for the argument *) (* Check the decreasing arg is smaller *) let z = List.nth stack' np in if not (check_is_subterm (stack_element_specif z) trees.(glob)) then begin match z with |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z') |SArg _ -> error_partial_apply renv glob end end else begin match lookup_rel p renv.env with | LocalAssum _ -> List.iter (check_rec_call renv []) l | LocalDef (_,c,_) -> try List.iter (check_rec_call renv []) l with FixGuardError _ -> check_rec_call renv stack (applist(lift p c,l)) end | Case (ci,p,c_0,lrest) -> List.iter (check_rec_call renv []) (c_0::p::l); (* compute the recarg information for the arguments of each branch *) let case_spec = branches_specif renv (lazy_subterm_specif renv [] c_0) ci in let stack' = push_stack_closures renv l stack in let stack' = filter_stack_domain renv.env ci p stack' in Array.iteri (fun k br' -> let stack_br = push_stack_args case_spec.(k) stack' in check_rec_call renv stack_br br') lrest (* Enables to traverse Fixpoint definitions in a more intelligent way, ie, the rule : if - g = fix g (y1:T1)...(yp:Tp) {struct yp} := e & - f is guarded with respect to the set of pattern variables S in a1 ... am & - f is guarded with respect to the set of pattern variables S in T1 ... Tp & - ap is a sub-term of the formal argument of f & - f is guarded with respect to the set of pattern variables S+{yp} in e then f is guarded with respect to S in (g a1 ... am). Eduardo 7/9/98 *) | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> List.iter (check_rec_call renv []) l; Array.iter (check_rec_call renv []) typarray; let decrArg = recindxs.(i) in let renv' = push_fix_renv renv recdef in let stack' = push_stack_closures renv l stack in Array.iteri (fun j body -> if i=j && (List.length stack' > decrArg) then let recArg = List.nth stack' decrArg in let arg_sp = stack_element_specif recArg in check_nested_fix_body renv' (decrArg+1) arg_sp body else check_rec_call renv' [] body) bodies | Const (kn,u) -> if evaluable_constant kn renv.env then try List.iter (check_rec_call renv []) l with (FixGuardError _ ) -> let value = (applist(constant_value renv.env (kn,u), l)) in check_rec_call renv stack value else List.iter (check_rec_call renv []) l | Lambda (x,a,b) -> assert (l = []); check_rec_call renv [] a ; let spec, stack' = extract_stack renv a stack in check_rec_call (push_var renv (x,a,spec)) stack' b | Prod (x,a,b) -> assert (l = [] && stack = []); check_rec_call renv [] a; check_rec_call (push_var_renv renv (x,a)) [] b | CoFix (i,(_,typarray,bodies as recdef)) -> List.iter (check_rec_call renv []) l; Array.iter (check_rec_call renv []) typarray; let renv' = push_fix_renv renv recdef in Array.iter (check_rec_call renv' []) bodies | (Ind _ | Construct _) -> List.iter (check_rec_call renv []) l | Proj (p, c) -> List.iter (check_rec_call renv []) l; check_rec_call renv [] c | Var _ -> anomaly (Pp.str "Section variable in Coqchk !") | Sort _ -> assert (l = []) (* l is not checked because it is considered as the meta's context *) | (Evar _ | Meta _) -> () | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *) and check_nested_fix_body renv decr recArgsDecrArg body = if decr = 0 then check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body else match body with | Lambda (x,a,b) -> check_rec_call renv [] a; let renv' = push_var_renv renv (x,a) in check_nested_fix_body renv' (decr-1) recArgsDecrArg b | _ -> anomaly (Pp.str "Not enough abstractions in fix body") in check_rec_call renv [] def let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = let nbfix = Array.length bodies in if nbfix = 0 || Array.length nvect <> nbfix || Array.length types <> nbfix || Array.length names <> nbfix || bodynum < 0 || bodynum >= nbfix then anomaly (Pp.str "Ill-formed fix term"); let fixenv = push_rec_types recdef env in let raise_err env i err = error_ill_formed_rec_body env err names i in (* Check the i-th definition with recarg k *) let find_ind i k def = (* check fi does not appear in the k+1 first abstractions, gives the type of the k+1-eme abstraction (must be an inductive) *) let rec check_occur env n def = match (whd_all env def) with | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then let env' = push_rel (LocalAssum (x,a)) env in if n = k+1 then (* get the inductive type of the fixpoint *) let (mind, _) = try find_inductive env a with Not_found -> raise_err env i (RecursionNotOnInductiveType a) in (mind, (env', b)) else check_occur env' (n+1) b else anomaly ~label:"check_one_fix" (Pp.str "Bad occurrence of recursive call") | _ -> raise_err env i NotEnoughAbstractionInFixBody in check_occur fixenv 1 def in (* Do it on every fixpoint *) let rv = Array.map2_i find_ind nvect bodies in (Array.map fst rv, Array.map snd rv) let check_fix env ((nvect,_),(names,_,bodies as _recdef) as fix) = let (minds, rdef) = inductive_of_mutfix env fix in let get_tree (kn,i) = let mib = Environ.lookup_mind kn env in mib.mind_packets.(i).mind_recargs in let trees = Array.map get_tree minds in for i = 0 to Array.length bodies - 1 do let (fenv,body) = rdef.(i) in let renv = make_renv fenv nvect.(i) trees.(i) in try check_one_fix renv nvect trees body with FixGuardError (fixenv,err) -> error_ill_formed_rec_body fixenv err names i done (* let cfkey = Profile.declare_profile "check_fix";; let check_fix env fix = Profile.profile3 cfkey check_fix env fix;; *) (************************************************************************) (* Co-fixpoints. *) exception CoFixGuardError of env * guard_error let anomaly_ill_typed () = anomaly ~label:"check_one_cofix" (Pp.str "too many arguments applied to constructor") let rec codomain_is_coind env c = let b = whd_all env c in match b with | Prod (x,a,b) -> codomain_is_coind (push_rel (LocalAssum (x,a)) env) b | _ -> (try find_coinductive env b with Not_found -> raise (CoFixGuardError (env, CodomainNotInductiveType b))) let check_one_cofix env nbfix def deftype = let rec check_rec_call env alreadygrd n tree vlra t = if not (noccur_with_meta n nbfix t) then let c,args = decompose_app (whd_all env t) in match c with | Rel p when n <= p && p < n+nbfix -> (* recursive call: must be guarded and no nested recursive call allowed *) if not alreadygrd then raise (CoFixGuardError (env,UnguardedRecursiveCall t)) else if not(List.for_all (noccur_with_meta n nbfix) args) then raise (CoFixGuardError (env,NestedRecursiveOccurrences)) | Construct ((_,i as cstr_kn),u) -> let lra = vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in let (mib,mip) = lookup_mind_specif env mI in let realargs = List.skipn mib.mind_nparams args in let rec process_args_of_constr = function | (t::lr), (rar::lrar) -> if rar = mk_norec then if noccur_with_meta n nbfix t then process_args_of_constr (lr, lrar) else raise (CoFixGuardError (env,RecCallInNonRecArgOfConstructor t)) else begin check_rec_call env true n rar (dest_subterms rar) t; process_args_of_constr (lr, lrar) end | [],_ -> () | _ -> anomaly_ill_typed () in process_args_of_constr (realargs, lra) | Lambda (x,a,b) -> assert (args = []); if noccur_with_meta n nbfix a then let env' = push_rel (LocalAssum (x,a)) env in check_rec_call env' alreadygrd (n+1) tree vlra b else raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) | CoFix (j,(_,varit,vdefs as recdef)) -> if List.for_all (noccur_with_meta n nbfix) args then if Array.for_all (noccur_with_meta n nbfix) varit then let nbfix = Array.length vdefs in let env' = push_rec_types recdef env in (Array.iter (check_rec_call env' alreadygrd (n+nbfix) tree vlra) vdefs; List.iter (check_rec_call env alreadygrd n tree vlra) args) else raise (CoFixGuardError (env,RecCallInTypeOfDef c)) else raise (CoFixGuardError (env,UnguardedRecursiveCall c)) | Case (_,p,tm,vrest) -> begin let tree = match restrict_spec env (Subterm (Strict, tree)) p with | Dead_code -> assert false | Subterm (_, tree') -> tree' | _ -> raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c)) in if (noccur_with_meta n nbfix p) then if (noccur_with_meta n nbfix tm) then if (List.for_all (noccur_with_meta n nbfix) args) then let vlra = dest_subterms tree in Array.iter (check_rec_call env alreadygrd n tree vlra) vrest else raise (CoFixGuardError (env,RecCallInCaseFun c)) else raise (CoFixGuardError (env,RecCallInCaseArg c)) else raise (CoFixGuardError (env,RecCallInCasePred c)) end | Meta _ -> () | Evar _ -> List.iter (check_rec_call env alreadygrd n tree vlra) args | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in let (mind, _) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in check_rec_call env false 1 vlra (dest_subterms vlra) def (* The function which checks that the whole block of definitions satisfies the guarded condition *) let check_cofix env (bodynum,(names,types,bodies as recdef)) = let nbfix = Array.length bodies in for i = 0 to nbfix-1 do let fixenv = push_rec_types recdef env in try check_one_cofix fixenv nbfix bodies.(i) types.(i) with CoFixGuardError (errenv,err) -> error_ill_formed_rec_body errenv err names i done coq-8.6/checker/check.ml0000644000175000017500000003566313022274260014507 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* failwith "path_of_dirpath" | l::dir -> {dirpath=List.map Id.to_string dir;basename=Id.to_string l} let pr_dirlist dp = prlist_with_sep (fun _ -> str".") str (List.rev dp) let pr_path sp = match sp.dirpath with [] -> str sp.basename | sl -> pr_dirlist sl ++ str"." ++ str sp.basename (************************************************************************) (*s Modules loaded in memory contain the following informations. They are kept in the global table [libraries_table]. *) type library_t = { library_name : Cic.compilation_unit_name; library_filename : CUnix.physical_path; library_compiled : Cic.compiled_library; library_opaques : Cic.opaque_table; library_deps : Cic.library_deps; library_digest : Cic.vodigest; library_extra_univs : Univ.ContextSet.t } module LibraryOrdered = struct type t = DirPath.t let compare d1 d2 = Pervasives.compare (List.rev (DirPath.repr d1)) (List.rev (DirPath.repr d2)) end module LibrarySet = Set.Make(LibraryOrdered) module LibraryMap = Map.Make(LibraryOrdered) (* This is a map from names to loaded libraries *) let libraries_table = ref LibraryMap.empty (* various requests to the tables *) let find_library dir = LibraryMap.find dir !libraries_table let try_find_library dir = try find_library dir with Not_found -> error ("Unknown library " ^ (DirPath.to_string dir)) let library_full_filename dir = (find_library dir).library_filename (* If a library is loaded several time, then the first occurrence must be performed first, thus the libraries_loaded_list ... *) let register_loaded_library m = libraries_table := LibraryMap.add m.library_name m !libraries_table (* Map from library names to table of opaque terms *) let opaque_tables = ref LibraryMap.empty let opaque_univ_tables = ref LibraryMap.empty let access_opaque_table dp i = let t = try LibraryMap.find dp !opaque_tables with Not_found -> assert false in assert (i < Array.length t); Future.force t.(i) let access_opaque_univ_table dp i = try let t = LibraryMap.find dp !opaque_univ_tables in assert (i < Array.length t); Future.force t.(i) with Not_found -> Univ.ContextSet.empty let _ = Declarations.indirect_opaque_access := access_opaque_table let _ = Declarations.indirect_opaque_univ_access := access_opaque_univ_table let check_one_lib admit (dir,m) = let file = m.library_filename in let md = m.library_compiled in let dig = m.library_digest in (* Look up if the library is to be admitted correct. We could also check if it carries a validation certificate (yet to be implemented). *) if LibrarySet.mem dir admit then (Flags.if_verbose Feedback.msg_notice (str "Admitting library: " ++ pr_dirpath dir); Safe_typing.unsafe_import file md m.library_extra_univs dig) else (Flags.if_verbose Feedback.msg_notice (str "Checking library: " ++ pr_dirpath dir); Safe_typing.import file md m.library_extra_univs dig); register_loaded_library m (*************************************************************************) (*s Load path. Mapping from physical to logical paths etc.*) type logical_path = DirPath.t let load_paths = ref ([],[] : CUnix.physical_path list * logical_path list) let get_load_paths () = fst !load_paths (* Hints to partially detects if two paths refer to the same repertory *) let rec remove_path_dot p = let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *) let n = String.length curdir in if String.length p > n && String.sub p 0 n = curdir then remove_path_dot (String.sub p n (String.length p - n)) else p let strip_path p = let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *) let n = String.length cwd in if String.length p > n && String.sub p 0 n = cwd then remove_path_dot (String.sub p n (String.length p - n)) else remove_path_dot p let canonical_path_name p = let current = Sys.getcwd () in try Sys.chdir p; let p' = Sys.getcwd () in Sys.chdir current; p' with Sys_error _ -> (* We give up to find a canonical name and just simplify it... *) strip_path p let find_logical_path phys_dir = let phys_dir = canonical_path_name phys_dir in let physical, logical = !load_paths in match List.filter2 (fun p d -> p = phys_dir) physical logical with | _,[dir] -> dir | _,[] -> default_root_prefix | _,l -> anomaly (Pp.str ("Two logical paths are associated to "^phys_dir)) let remove_load_path dir = let physical, logical = !load_paths in load_paths := List.filter2 (fun p d -> p <> dir) physical logical let add_load_path (phys_path,coq_path) = if !Flags.debug then Feedback.msg_notice (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++ str phys_path); let phys_path = canonical_path_name phys_path in let physical, logical = !load_paths in match List.filter2 (fun p d -> p = phys_path) physical logical with | _,[dir] -> if coq_path <> dir (* If this is not the default -I . to coqtop *) && not (phys_path = canonical_path_name Filename.current_dir_name && coq_path = default_root_prefix) then begin (* Assume the user is concerned by library naming *) if dir <> default_root_prefix then Feedback.msg_warning (str phys_path ++ strbrk " was previously bound to " ++ pr_dirpath dir ++ strbrk "; it is remapped to " ++ pr_dirpath coq_path); remove_load_path phys_path; load_paths := (phys_path::fst !load_paths, coq_path::snd !load_paths) end | _,[] -> load_paths := (phys_path :: fst !load_paths, coq_path :: snd !load_paths) | _ -> anomaly (Pp.str ("Two logical paths are associated to "^phys_path)) let load_paths_of_dir_path dir = let physical, logical = !load_paths in fst (List.filter2 (fun p d -> d = dir) physical logical) (************************************************************************) (*s Locate absolute or partially qualified library names in the path *) exception LibUnmappedDir exception LibNotFound let locate_absolute_library dir = (* Search in loadpath *) let pref, base = split_dirpath dir in let loadpath = load_paths_of_dir_path pref in if loadpath = [] then raise LibUnmappedDir; try let name = Id.to_string base^".vo" in let _, file = System.where_in_path ~warn:false loadpath name in (dir, file) with Not_found -> (* Last chance, removed from the file system but still in memory *) try (dir, library_full_filename dir) with Not_found -> raise LibNotFound let locate_qualified_library qid = try let loadpath = (* Search library in loadpath *) if qid.dirpath=[] then get_load_paths () else (* we assume qid is an absolute dirpath *) load_paths_of_dir_path (dir_of_path qid) in if loadpath = [] then raise LibUnmappedDir; let name = qid.basename^".vo" in let path, file = System.where_in_path loadpath name in let dir = extend_dirpath (find_logical_path path) (Id.of_string qid.basename) in (* Look if loaded *) try (dir, library_full_filename dir) with Not_found -> (dir, file) with Not_found -> raise LibNotFound let error_unmapped_dir qid = let prefix = qid.dirpath in errorlabstrm "load_absolute_library_from" (str "Cannot load " ++ pr_path qid ++ str ":" ++ spc () ++ str "no physical path bound to" ++ spc () ++ pr_dirlist prefix ++ fnl ()) let error_lib_not_found qid = errorlabstrm "load_absolute_library_from" (str"Cannot find library " ++ pr_path qid ++ str" in loadpath") let try_locate_absolute_library dir = try locate_absolute_library dir with | LibUnmappedDir -> error_unmapped_dir (path_of_dirpath dir) | LibNotFound -> error_lib_not_found (path_of_dirpath dir) let try_locate_qualified_library qid = try locate_qualified_library qid with | LibUnmappedDir -> error_unmapped_dir qid | LibNotFound -> error_lib_not_found qid (************************************************************************) (*s Low-level interning of libraries from files *) let raw_intern_library f = System.raw_intern_state Coq_config.vo_magic_number f (************************************************************************) (* Internalise libraries *) open Cic let mk_library sd md f table digest cst = { library_name = sd.md_name; library_filename = f; library_compiled = md.md_compiled; library_opaques = table; library_deps = sd.md_deps; library_digest = digest; library_extra_univs = cst } let name_clash_message dir mdir f = str ("The file " ^ f ^ " contains library") ++ spc () ++ pr_dirpath mdir ++ spc () ++ str "and not library" ++ spc() ++ pr_dirpath dir (* Dependency graph *) let depgraph = ref LibraryMap.empty let intern_from_file (dir, f) = Flags.if_verbose chk_pp (str"[intern "++str f++str" ..."); let (sd,md,table,opaque_csts,digest) = try let ch = System.with_magic_number_check raw_intern_library f in let (sd:Cic.summary_disk), _, digest = System.marshal_in_segment f ch in let (md:Cic.library_disk), _, digest = System.marshal_in_segment f ch in let (opaque_csts:'a option), _, udg = System.marshal_in_segment f ch in let (discharging:'a option), _, _ = System.marshal_in_segment f ch in let (tasks:'a option), _, _ = System.marshal_in_segment f ch in let (table:Cic.opaque_table), pos, checksum = System.marshal_in_segment f ch in (* Verification of the final checksum *) let () = close_in ch in let ch = open_in_bin f in if not (String.equal (Digest.channel ch pos) checksum) then errorlabstrm "intern_from_file" (str "Checksum mismatch"); let () = close_in ch in if dir <> sd.md_name then errorlabstrm "intern_from_file" (name_clash_message dir sd.md_name f); if tasks <> None || discharging <> None then errorlabstrm "intern_from_file" (str "The file "++str f++str " contains unfinished tasks"); if opaque_csts <> None then begin chk_pp (str " (was a vio file) "); Option.iter (fun (_,_,b) -> if not b then errorlabstrm "intern_from_file" (str "The file "++str f++str " is still a .vio")) opaque_csts; Validate.validate !Flags.debug Values.v_univopaques opaque_csts; end; (* Verification of the unmarshalled values *) Validate.validate !Flags.debug Values.v_libsum sd; Validate.validate !Flags.debug Values.v_lib md; Validate.validate !Flags.debug Values.v_opaques table; Flags.if_verbose chk_pp (str" done]" ++ fnl ()); let digest = if opaque_csts <> None then Cic.Dviovo (digest,udg) else (Cic.Dvo digest) in sd,md,table,opaque_csts,digest with e -> Flags.if_verbose chk_pp (str" failed!]" ++ fnl ()); raise e in depgraph := LibraryMap.add sd.md_name sd.md_deps !depgraph; opaque_tables := LibraryMap.add sd.md_name table !opaque_tables; Option.iter (fun (opaque_csts,_,_) -> opaque_univ_tables := LibraryMap.add sd.md_name opaque_csts !opaque_univ_tables) opaque_csts; let extra_cst = Option.default Univ.ContextSet.empty (Option.map (fun (_,cs,_) -> cs) opaque_csts) in mk_library sd md f table digest extra_cst let get_deps (dir, f) = try LibraryMap.find dir !depgraph with Not_found -> let _ = intern_from_file (dir,f) in LibraryMap.find dir !depgraph (* Read a compiled library and all dependencies, in reverse order. Do not include files that are already in the context. *) let rec intern_library seen (dir, f) needed = if LibrarySet.mem dir seen then failwith "Recursive dependencies!"; (* Look if in the current logical environment *) try let _ = find_library dir in needed with Not_found -> (* Look if already listed and consequently its dependencies too *) if List.mem_assoc_f DirPath.equal dir needed then needed else (* [dir] is an absolute name which matches [f] which must be in loadpath *) let m = intern_from_file (dir,f) in let seen' = LibrarySet.add dir seen in let deps = Array.map (fun (d,_) -> try_locate_absolute_library d) m.library_deps in (dir,m) :: Array.fold_right (intern_library seen') deps needed (* Compute the reflexive transitive dependency closure *) let rec fold_deps seen ff (dir,f) (s,acc) = if LibrarySet.mem dir seen then failwith "Recursive dependencies!"; if LibrarySet.mem dir s then (s,acc) else let deps = get_deps (dir,f) in let deps = Array.map (fun (d,_) -> try_locate_absolute_library d) deps in let seen' = LibrarySet.add dir seen in let (s',acc') = Array.fold_right (fold_deps seen' ff) deps (s,acc) in (LibrarySet.add dir s', ff dir acc') and fold_deps_list seen ff modl needed = List.fold_right (fold_deps seen ff) modl needed let fold_deps_list ff modl acc = snd (fold_deps_list LibrarySet.empty ff modl (LibrarySet.empty,acc)) let recheck_library ~norec ~admit ~check = let ml = List.map try_locate_qualified_library check in let nrl = List.map try_locate_qualified_library norec in let al = List.map try_locate_qualified_library admit in let needed = List.rev (List.fold_right (intern_library LibrarySet.empty) (ml@nrl) []) in (* first compute the closure of norec, remove closure of check, add closure of admit, and finally remove norec and check *) let nochk = fold_deps_list LibrarySet.add nrl LibrarySet.empty in let nochk = fold_deps_list LibrarySet.remove ml nochk in let nochk = fold_deps_list LibrarySet.add al nochk in (* explicitly required modules cannot be skipped... *) let nochk = List.fold_right LibrarySet.remove (List.map fst (nrl@ml)) nochk in (* *) Flags.if_verbose Feedback.msg_notice (fnl()++hv 2 (str "Ordered list:" ++ fnl() ++ prlist (fun (dir,_) -> pr_dirpath dir ++ fnl()) needed)); List.iter (check_one_lib nochk) needed; Flags.if_verbose Feedback.msg_notice (str"Modules were successfully checked") open Printf let mem s = let m = try_find_library s in h 0 (str (sprintf "%dk" (CObj.size_kb m))) coq-8.6/kernel/0000755000175000017500000000000013022274260012737 5ustar mdenesmdenescoq-8.6/kernel/nativeconv.mli0000644000175000017500000000160513022274260015620 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* evars -> types kernel_conversion_function (** A conversion function parametrized by a universe comparator. Used outside of the kernel. *) val native_conv_gen : conv_pb -> evars -> (types, 'a) generic_conversion_function coq-8.6/kernel/term_typing.mli0000644000175000017500000000521013022274260016001 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* env -> Id.t -> side_effects definition_entry -> constant_def * types * constant_universes val translate_local_assum : env -> types -> types val mk_pure_proof : constr -> side_effects proof_output val inline_side_effects : env -> constr -> side_effects -> constr (** Returns the term where side effects have been turned into let-ins or beta redexes. *) val inline_entry_side_effects : env -> side_effects definition_entry -> side_effects definition_entry (** Same as {!inline_side_effects} but applied to entries. Only modifies the {!Entries.const_entry_body} field. It is meant to get a term out of a not yet type checked proof. *) val uniq_seff : side_effects -> side_effects val translate_constant : structure_body -> env -> constant -> side_effects constant_entry -> constant_body type side_effect_role = | Subproof | Schema of inductive * string type exported_side_effect = constant * constant_body * side_effects constant_entry * side_effect_role (* Given a constant entry containing side effects it exports them (either * by re-checking them or trusting them). Returns the constant bodies to * be pushed in the safe_env by safe typing. The main constant entry * needs to be translated as usual after this step. *) val export_side_effects : structure_body -> env -> side_effects constant_entry -> exported_side_effect list * side_effects constant_entry val constant_entry_of_side_effect : constant_body -> seff_env -> side_effects constant_entry val translate_mind : env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body val translate_recipe : env -> constant -> Cooking.recipe -> constant_body (** Internal functions, mentioned here for debug purpose only *) val infer_declaration : trust:structure_body -> env -> constant option -> side_effects constant_entry -> Cooking.result val build_constant_declaration : constant -> env -> Cooking.result -> constant_body val set_suggest_proof_using : (string -> env -> Id.Set.t -> Id.Set.t -> Id.t list -> string) -> unit coq-8.6/kernel/retroknowledge.mli0000644000175000017500000001532213022274260016500 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* entry -> Cbytecodes.comp_env -> constr array -> int -> Cbytecodes.bytecodes-> Cbytecodes.bytecodes (*Given an identifier id (usually Construct _) and its argument array, returns a function that tries an ad-hoc optimisated compilation (in the case of the 31-bit integers it means compiling them directly into an integer) raises Not_found if id should be compiled as usual, and expectingly CBytecodes.NotClosed if the term is not a closed constructor pattern (a constant for the compiler) *) val get_vm_constant_static_info : retroknowledge -> entry -> constr array -> Cbytecodes.structured_constant (*Given an identifier id (usually Construct _ ) its argument array and a continuation, returns the compiled version of id+args+cont when id has a specific treatment (in the case of 31-bit integers, that would be the dynamic compilation into integers) or raises Not_found if id should be compiled as usual *) val get_vm_constant_dynamic_info : retroknowledge -> entry -> Cbytecodes.comp_env -> Cbytecodes.block array -> int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes (** Given a type identifier, this function is used before compiling a match over this type. In the case of 31-bit integers for instance, it is used to add the instruction sequence which would perform a dynamic decompilation in case the argument of the match is not in coq representation *) val get_vm_before_match_info : retroknowledge -> entry -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes (** Given a type identifier, this function is used by pretyping/vnorm.ml to recover the elements of that type from their compiled form if it's non standard (it is used (and can be used) only when the compiled form is not a block *) val get_vm_decompile_constant_info : retroknowledge -> entry -> int -> Term.constr val get_native_compiling_info : retroknowledge -> entry -> Nativeinstr.prefix -> Nativeinstr.lambda array -> Nativeinstr.lambda val get_native_constant_static_info : retroknowledge -> entry -> constr array -> Nativeinstr.lambda val get_native_constant_dynamic_info : retroknowledge -> entry -> Nativeinstr.prefix -> constructor -> Nativeinstr.lambda array -> Nativeinstr.lambda val get_native_before_match_info : retroknowledge -> entry -> Nativeinstr.prefix -> constructor -> Nativeinstr.lambda -> Nativeinstr.lambda (** the following functions are solely used in Pre_env and Environ to implement the functions register and unregister (and mem) of Environ *) val add_field : retroknowledge -> field -> entry -> retroknowledge val mem : retroknowledge -> field -> bool (* val remove : retroknowledge -> field -> retroknowledge *) val find : retroknowledge -> field -> entry (** Dispatching type for the above [get_*] functions. *) type reactive_info = {(*information required by the compiler of the VM *) vm_compiling : (*fastcomputation flag -> continuation -> result *) (bool->Cbytecodes.comp_env->constr array -> int->Cbytecodes.bytecodes->Cbytecodes.bytecodes) option; vm_constant_static : (*fastcomputation flag -> constructor -> args -> result*) (bool->constr array->Cbytecodes.structured_constant) option; vm_constant_dynamic : (*fastcomputation flag -> constructor -> reloc -> args -> sz -> cont -> result *) (bool->Cbytecodes.comp_env->Cbytecodes.block array->int-> Cbytecodes.bytecodes->Cbytecodes.bytecodes) option; (* fastcomputation flag -> cont -> result *) vm_before_match : (bool -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) option; (* tag (= compiled int for instance) -> result *) vm_decompile_const : (int -> Term.constr) option; native_compiling : (bool -> Nativeinstr.prefix -> Nativeinstr.lambda array -> Nativeinstr.lambda) option; native_constant_static : (bool -> constr array -> Nativeinstr.lambda) option; native_constant_dynamic : (bool -> Nativeinstr.prefix -> constructor -> Nativeinstr.lambda array -> Nativeinstr.lambda) option; native_before_match : (bool -> Nativeinstr.prefix -> constructor -> Nativeinstr.lambda -> Nativeinstr.lambda) option } val empty_reactive_info : reactive_info (** Hook to be set after the compiler are installed to dispatch fields into the above [get_*] functions. *) val dispatch_hook : (retroknowledge -> entry -> field -> reactive_info) Hook.t coq-8.6/kernel/nativelambda.ml0000644000175000017500000006004113022274260015721 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr option; evars_typ : existential -> types; evars_metas : metavariable -> types } (*s Constructors *) let mkLapp f args = if Array.is_empty args then f else match f with | Lapp(f', args') -> Lapp (f', Array.append args' args) | _ -> Lapp(f, args) let mkLlam ids body = if Array.is_empty ids then body else match body with | Llam(ids', body) -> Llam(Array.append ids ids', body) | _ -> Llam(ids, body) let decompose_Llam lam = match lam with | Llam(ids,body) -> ids, body | _ -> [||], lam let rec decompose_Llam_Llet lam = match lam with | Llam(ids,body) -> let vars, body = decompose_Llam_Llet body in Array.fold_right (fun x l -> (x, None) :: l) ids vars, body | Llet(id,def,body) -> let vars, body = decompose_Llam_Llet body in (id,Some def) :: vars, body | _ -> [], lam let decompose_Llam_Llet lam = let vars, body = decompose_Llam_Llet lam in Array.of_list vars, body (*s Operators on substitution *) let subst_id = subs_id 0 let lift = subs_lift let liftn = subs_liftn let cons v subst = subs_cons([|v|], subst) let shift subst = subs_shft (1, subst) (* Linked code location utilities *) let get_mind_prefix env mind = let _,name = lookup_mind_key mind env in match !name with | NotLinked -> "" | Linked s -> s | LinkedInteractive s -> s let get_const_prefix env c = let _,(nameref,_) = lookup_constant_key c env in match !nameref with | NotLinked -> "" | Linked s -> s | LinkedInteractive s -> s (* A generic map function *) let map_lam_with_binders g f n lam = match lam with | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _ | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> lam | Lprod(dom,codom) -> let dom' = f n dom in let codom' = f n codom in if dom == dom' && codom == codom' then lam else Lprod(dom',codom') | Llam(ids,body) -> let body' = f (g (Array.length ids) n) body in if body == body' then lam else mkLlam ids body' | Llet(id,def,body) -> let def' = f n def in let body' = f (g 1 n) body in if body == body' && def == def' then lam else Llet(id,def',body') | Lapp(fct,args) -> let fct' = f n fct in let args' = Array.smartmap (f n) args in if fct == fct' && args == args' then lam else mkLapp fct' args' | Lprim(prefix,kn,op,args) -> let args' = Array.smartmap (f n) args in if args == args' then lam else Lprim(prefix,kn,op,args') | Lcase(annot,t,a,br) -> let t' = f n t in let a' = f n a in let on_b b = let (cn,ids,body) = b in let body' = if Array.is_empty ids then f n body else f (g (Array.length ids) n) body in if body == body' then b else (cn,ids,body') in let br' = Array.smartmap on_b br in if t == t' && a == a' && br == br' then lam else Lcase(annot,t',a',br') | Lif(t,bt,bf) -> let t' = f n t in let bt' = f n bt in let bf' = f n bf in if t == t' && bt == bt' && bf == bf' then lam else Lif(t',bt',bf') | Lfix(init,(ids,ltypes,lbodies)) -> let ltypes' = Array.smartmap (f n) ltypes in let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in if ltypes == ltypes' && lbodies == lbodies' then lam else Lfix(init,(ids,ltypes',lbodies')) | Lcofix(init,(ids,ltypes,lbodies)) -> let ltypes' = Array.smartmap (f n) ltypes in let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in if ltypes == ltypes' && lbodies == lbodies' then lam else Lcofix(init,(ids,ltypes',lbodies')) | Lmakeblock(prefix,cn,tag,args) -> let args' = Array.smartmap (f n) args in if args == args' then lam else Lmakeblock(prefix,cn,tag,args') (*s Lift and substitution *) let rec lam_exlift el lam = match lam with | Lrel(id,i) -> let i' = reloc_rel i el in if i == i' then lam else Lrel(id,i') | _ -> map_lam_with_binders el_liftn lam_exlift el lam let lam_lift k lam = if Int.equal k 0 then lam else lam_exlift (el_shft k el_id) lam let lam_subst_rel lam id n subst = match expand_rel n subst with | Inl(k,v) -> lam_lift k v | Inr(n',_) -> if n == n' then lam else Lrel(id, n') let rec lam_exsubst subst lam = match lam with | Lrel(id,i) -> lam_subst_rel lam id i subst | _ -> map_lam_with_binders liftn lam_exsubst subst lam let lam_subst subst lam = if is_subs_id subst then lam else lam_exsubst subst lam let lam_subst_args subst args = if is_subs_id subst then args else Array.smartmap (lam_exsubst subst) args (** Simplification of lambda expression *) (* [simplify subst lam] simplify the expression [lam_subst subst lam] *) (* that is : *) (* - Reduce [let] is the definition can be substituted i.e: *) (* - a variable (rel or identifier) *) (* - a constant *) (* - a structured constant *) (* - a function *) (* - Transform beta redex into [let] expression *) (* - Move arguments under [let] *) (* Invariant : Terms in [subst] are already simplified and can be *) (* substituted *) let can_subst lam = match lam with | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Llam _ | Lconstruct _ | Lmeta _ | Levar _ -> true | _ -> false let can_merge_if bt bf = match bt, bf with | Llam(idst,_), Llam(idsf,_) -> true | _ -> false let merge_if t bt bf = let (idst,bodyt) = decompose_Llam bt in let (idsf,bodyf) = decompose_Llam bf in let nt = Array.length idst in let nf = Array.length idsf in let common,idst,idsf = if Int.equal nt nf then idst, [||], [||] else if nt < nf then idst,[||], Array.sub idsf nt (nf - nt) else idsf, Array.sub idst nf (nt - nf), [||] in Llam(common, Lif(lam_lift (Array.length common) t, mkLlam idst bodyt, mkLlam idsf bodyf)) let rec simplify subst lam = match lam with | Lrel(id,i) -> lam_subst_rel lam id i subst | Llet(id,def,body) -> let def' = simplify subst def in if can_subst def' then simplify (cons def' subst) body else let body' = simplify (lift subst) body in if def == def' && body == body' then lam else Llet(id,def',body') | Lapp(f,args) -> begin match simplify_app subst f subst args with | Lapp(f',args') when f == f' && args == args' -> lam | lam' -> lam' end | Lif(t,bt,bf) -> let t' = simplify subst t in let bt' = simplify subst bt in let bf' = simplify subst bf in if can_merge_if bt' bf' then merge_if t' bt' bf' else if t == t' && bt == bt' && bf == bf' then lam else Lif(t',bt',bf') | _ -> map_lam_with_binders liftn simplify subst lam and simplify_app substf f substa args = match f with | Lrel(id, i) -> begin match lam_subst_rel f id i substf with | Llam(ids, body) -> reduce_lapp subst_id (Array.to_list ids) body substa (Array.to_list args) | f' -> mkLapp f' (simplify_args substa args) end | Llam(ids, body) -> reduce_lapp substf (Array.to_list ids) body substa (Array.to_list args) | Llet(id, def, body) -> let def' = simplify substf def in if can_subst def' then simplify_app (cons def' substf) body substa args else Llet(id, def', simplify_app (lift substf) body (shift substa) args) | Lapp(f, args') -> let args = Array.append (lam_subst_args substf args') (lam_subst_args substa args) in simplify_app substf f subst_id args (* TODO | Lproj -> simplify if the argument is known or a known global *) | _ -> mkLapp (simplify substf f) (simplify_args substa args) and simplify_args subst args = Array.smartmap (simplify subst) args and reduce_lapp substf lids body substa largs = match lids, largs with | id::lids, a::largs -> let a = simplify substa a in if can_subst a then reduce_lapp (cons a substf) lids body substa largs else let body = reduce_lapp (lift substf) lids body (shift substa) largs in Llet(id, a, body) | [], [] -> simplify substf body | _::_, _ -> Llam(Array.of_list lids, simplify (liftn (List.length lids) substf) body) | [], _::_ -> simplify_app substf body substa (Array.of_list largs) (* [occurrence kind k lam]: If [kind] is [true] return [true] if the variable [k] does not appear in [lam], return [false] if the variable appear one time and not under a lambda, a fixpoint, a cofixpoint; else raise Not_found. If [kind] is [false] return [false] if the variable does not appear in [lam] else raise [Not_found] *) let rec occurrence k kind lam = match lam with | Lrel (_,n) -> if Int.equal n k then if kind then false else raise Not_found else kind | Lvar _ | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _ | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> kind | Lprod(dom, codom) -> occurrence k (occurrence k kind dom) codom | Llam(ids,body) -> let _ = occurrence (k+Array.length ids) false body in kind | Llet(_,def,body) -> occurrence (k+1) (occurrence k kind def) body | Lapp(f, args) -> occurrence_args k (occurrence k kind f) args | Lprim(_,_,_,args) | Lmakeblock(_,_,_,args) -> occurrence_args k kind args | Lcase(_,t,a,br) -> let kind = occurrence k (occurrence k kind t) a in let r = ref kind in Array.iter (fun (_,ids,c) -> r := occurrence (k+Array.length ids) kind c && !r) br; !r | Lif (t, bt, bf) -> let kind = occurrence k kind t in kind && occurrence k kind bt && occurrence k kind bf | Lfix(_,(ids,ltypes,lbodies)) | Lcofix(_,(ids,ltypes,lbodies)) -> let kind = occurrence_args k kind ltypes in let _ = occurrence_args (k+Array.length ids) false lbodies in kind and occurrence_args k kind args = Array.fold_left (occurrence k) kind args let occur_once lam = try let _ = occurrence 1 true lam in true with Not_found -> false (* [remove_let lam] remove let expression in [lam] if the variable is *) (* used at most once time in the body, and does not appear under *) (* a lambda or a fix or a cofix *) let rec remove_let subst lam = match lam with | Lrel(id,i) -> lam_subst_rel lam id i subst | Llet(id,def,body) -> let def' = remove_let subst def in if occur_once body then remove_let (cons def' subst) body else let body' = remove_let (lift subst) body in if def == def' && body == body' then lam else Llet(id,def',body') | _ -> map_lam_with_binders liftn remove_let subst lam (*s Translation from [constr] to [lambda] *) (* Translation of constructor *) let is_value lc = match lc with | Lval _ -> true | Lmakeblock(_,_,_,args) when Array.is_empty args -> true | _ -> false let get_value lc = match lc with | Lval v -> v | Lmakeblock(_,_,tag,args) when Array.is_empty args -> Nativevalues.mk_int tag | _ -> raise Not_found let make_args start _end = Array.init (start - _end + 1) (fun i -> Lrel (Anonymous, start - i)) (* Translation of constructors *) let makeblock env cn u tag args = if Array.for_all is_value args && Array.length args > 0 then let args = Array.map get_value args in Lval (Nativevalues.mk_block tag args) else let prefix = get_mind_prefix env (fst (fst cn)) in Lmakeblock(prefix, (cn,u), tag, args) (* Translation of constants *) let rec get_alias env (kn, u as p) = let tps = (lookup_constant kn env).const_body_code in match tps with | None -> p | Some tps -> match Cemitcodes.force tps with | Cemitcodes.BCalias kn' -> get_alias env (kn', u) | _ -> p (*i Global environment *) let global_env = ref empty_env let set_global_env env = global_env := env let get_names decl = let decl = Array.of_list decl in Array.map fst decl (* Rel Environment *) module Vect = struct type 'a t = { mutable elems : 'a array; mutable size : int; } let make n a = { elems = Array.make n a; size = 0; } let length v = v.size let extend v = if Int.equal v.size (Array.length v.elems) then let new_size = min (2*v.size) Sys.max_array_length in if new_size <= v.size then invalid_arg "Vect.extend"; let new_elems = Array.make new_size v.elems.(0) in Array.blit v.elems 0 new_elems 0 (v.size); v.elems <- new_elems let push v a = extend v; v.elems.(v.size) <- a; v.size <- v.size + 1 let push_pos v a = let pos = v.size in push v a; pos let popn v n = v.size <- max 0 (v.size - n) let pop v = popn v 1 let get v n = if v.size <= n then invalid_arg "Vect.get:index out of bounds"; v.elems.(n) let get_last v n = if v.size <= n then invalid_arg "Vect.get:index out of bounds"; v.elems.(v.size - n - 1) let last v = if Int.equal v.size 0 then invalid_arg "Vect.last:index out of bounds"; v.elems.(v.size - 1) let clear v = v.size <- 0 let to_array v = Array.sub v.elems 0 v.size end let empty_args = [||] module Renv = struct module ConstrHash = struct type t = constructor let equal = eq_constructor let hash = constructor_hash end module ConstrTable = Hashtbl.Make(ConstrHash) type constructor_info = tag * int * int (* nparam nrealargs *) type t = { name_rel : name Vect.t; construct_tbl : constructor_info ConstrTable.t; } let make () = { name_rel = Vect.make 16 Anonymous; construct_tbl = ConstrTable.create 111 } let push_rel env id = Vect.push env.name_rel id let push_rels env ids = Array.iter (push_rel env) ids let pop env = Vect.pop env.name_rel let popn env n = for _i = 1 to n do pop env done let get env n = Lrel (Vect.get_last env.name_rel (n-1), n) let get_construct_info env c = try ConstrTable.find env.construct_tbl c with Not_found -> let ((mind,j), i) = c in let oib = lookup_mind mind !global_env in let oip = oib.mind_packets.(j) in let tag,arity = oip.mind_reloc_tbl.(i-1) in let nparams = oib.mind_nparams in let r = (tag, nparams, arity) in ConstrTable.add env.construct_tbl c r; r end (* What about pattern matching ?*) let is_lazy prefix t = match kind_of_term t with | App (f,args) -> begin match kind_of_term f with | Construct (c,_) -> let entry = mkInd (fst c) in (try let _ = Retroknowledge.get_native_before_match_info (!global_env).retroknowledge entry prefix c Llazy; in false with Not_found -> true) | _ -> true end | LetIn _ -> true | _ -> false let evar_value sigma ev = sigma.evars_val ev let evar_type sigma ev = sigma.evars_typ ev let meta_type sigma mv = sigma.evars_metas mv let empty_evars = { evars_val = (fun _ -> None); evars_typ = (fun _ -> assert false); evars_metas = (fun _ -> assert false) } let empty_ids = [||] let rec lambda_of_constr env sigma c = match kind_of_term c with | Meta mv -> let ty = meta_type sigma mv in Lmeta (mv, lambda_of_constr env sigma ty) | Evar ev -> (match evar_value sigma ev with | None -> let ty = evar_type sigma ev in Levar(ev, lambda_of_constr env sigma ty) | Some t -> lambda_of_constr env sigma t) | Cast (c, _, _) -> lambda_of_constr env sigma c | Rel i -> Renv.get env i | Var id -> Lvar id | Sort s -> Lsort s | Ind (ind,u as pind) -> let prefix = get_mind_prefix !global_env (fst ind) in Lind (prefix, pind) | Prod(id, dom, codom) -> let ld = lambda_of_constr env sigma dom in Renv.push_rel env id; let lc = lambda_of_constr env sigma codom in Renv.pop env; Lprod(ld, Llam([|id|], lc)) | Lambda _ -> let params, body = decompose_lam c in let ids = get_names (List.rev params) in Renv.push_rels env ids; let lb = lambda_of_constr env sigma body in Renv.popn env (Array.length ids); mkLlam ids lb | LetIn(id, def, _, body) -> let ld = lambda_of_constr env sigma def in Renv.push_rel env id; let lb = lambda_of_constr env sigma body in Renv.pop env; Llet(id, ld, lb) | App(f, args) -> lambda_of_app env sigma f args | Const _ -> lambda_of_app env sigma c empty_args | Construct _ -> lambda_of_app env sigma c empty_args | Proj (p, c) -> let kn = Projection.constant p in mkLapp (Lproj (get_const_prefix !global_env kn, kn)) [|lambda_of_constr env sigma c|] | Case(ci,t,a,branches) -> let (mind,i as ind) = ci.ci_ind in let mib = lookup_mind mind !global_env in let oib = mib.mind_packets.(i) in let tbl = oib.mind_reloc_tbl in (* Building info *) let prefix = get_mind_prefix !global_env mind in let annot_sw = { asw_ind = ind; asw_ci = ci; asw_reloc = tbl; asw_finite = mib.mind_finite <> Decl_kinds.CoFinite; asw_prefix = prefix} in (* translation of the argument *) let la = lambda_of_constr env sigma a in let entry = mkInd ind in let la = try Retroknowledge.get_native_before_match_info (!global_env).retroknowledge entry prefix (ind,1) la with Not_found -> la in (* translation of the type *) let lt = lambda_of_constr env sigma t in (* translation of branches *) let mk_branch i b = let cn = (ind,i+1) in let _, arity = tbl.(i) in let b = lambda_of_constr env sigma b in if Int.equal arity 0 then (cn, empty_ids, b) else match b with | Llam(ids, body) when Int.equal (Array.length ids) arity -> (cn, ids, body) | _ -> let ids = Array.make arity Anonymous in let args = make_args arity 1 in let ll = lam_lift arity b in (cn, ids, mkLapp ll args) in let bs = Array.mapi mk_branch branches in Lcase(annot_sw, lt, la, bs) | Fix(rec_init,(names,type_bodies,rec_bodies)) -> let ltypes = lambda_of_args env sigma 0 type_bodies in Renv.push_rels env names; let lbodies = lambda_of_args env sigma 0 rec_bodies in Renv.popn env (Array.length names); Lfix(rec_init, (names, ltypes, lbodies)) | CoFix(init,(names,type_bodies,rec_bodies)) -> let ltypes = lambda_of_args env sigma 0 type_bodies in Renv.push_rels env names; let lbodies = lambda_of_args env sigma 0 rec_bodies in Renv.popn env (Array.length names); Lcofix(init, (names, ltypes, lbodies)) and lambda_of_app env sigma f args = match kind_of_term f with | Const (kn,u as c) -> let kn,u = get_alias !global_env c in let cb = lookup_constant kn !global_env in (try let prefix = get_const_prefix !global_env kn in (* We delay the compilation of arguments to avoid an exponential behavior *) let f = Retroknowledge.get_native_compiling_info (!global_env).retroknowledge (mkConst kn) prefix in let args = lambda_of_args env sigma 0 args in f args with Not_found -> begin match cb.const_body with | Def csubst -> (* TODO optimize if f is a proj and argument is known *) if cb.const_inline_code then lambda_of_app env sigma (Mod_subst.force_constr csubst) args else let prefix = get_const_prefix !global_env kn in let t = if is_lazy prefix (Mod_subst.force_constr csubst) then mkLapp Lforce [|Lconst (prefix, (kn,u))|] else Lconst (prefix, (kn,u)) in mkLapp t (lambda_of_args env sigma 0 args) | OpaqueDef _ | Undef _ -> let prefix = get_const_prefix !global_env kn in mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args env sigma 0 args) end) | Construct (c,u) -> let tag, nparams, arity = Renv.get_construct_info env c in let expected = nparams + arity in let nargs = Array.length args in let prefix = get_mind_prefix !global_env (fst (fst c)) in if Int.equal nargs expected then try try Retroknowledge.get_native_constant_static_info (!global_env).retroknowledge f args with NotClosed -> assert (Int.equal nparams 0); (* should be fine for int31 *) let args = lambda_of_args env sigma nparams args in Retroknowledge.get_native_constant_dynamic_info (!global_env).retroknowledge f prefix c args with Not_found -> let args = lambda_of_args env sigma nparams args in makeblock !global_env c u tag args else let args = lambda_of_args env sigma 0 args in (try Retroknowledge.get_native_constant_dynamic_info (!global_env).retroknowledge f prefix c args with Not_found -> mkLapp (Lconstruct (prefix, (c,u))) args) | _ -> let f = lambda_of_constr env sigma f in let args = lambda_of_args env sigma 0 args in mkLapp f args and lambda_of_args env sigma start args = let nargs = Array.length args in if start < nargs then Array.init (nargs - start) (fun i -> lambda_of_constr env sigma args.(start + i)) else empty_args let optimize lam = let lam = simplify subst_id lam in (* if Flags.vm_draw_opt () then (msgerrnl (str "Simplify = \n" ++ pp_lam lam);flush_all()); let lam = remove_let subst_id lam in if Flags.vm_draw_opt () then (msgerrnl (str "Remove let = \n" ++ pp_lam lam);flush_all()); *) lam let lambda_of_constr env sigma c = set_global_env env; let env = Renv.make () in let open Context.Rel.Declaration in let ids = List.rev_map get_name !global_env.env_rel_context in Renv.push_rels env (Array.of_list ids); let lam = lambda_of_constr env sigma c in (* if Flags.vm_draw_opt () then begin (msgerrnl (str "Constr = \n" ++ pr_constr c);flush_all()); (msgerrnl (str "Lambda = \n" ++ pp_lam lam);flush_all()); end; *) optimize lam let mk_lazy c = mkLapp Llazy [|c|] (** Retroknowledge, to be removed once we move to primitive machine integers *) let compile_static_int31 fc args = if not fc then raise Not_found else Luint (UintVal (Uint31.of_int (Array.fold_left (fun temp_i -> fun t -> match kind_of_term t with | Construct ((_,d),_) -> 2*temp_i+d-1 | _ -> raise NotClosed) 0 args))) let compile_dynamic_int31 fc prefix c args = if not fc then raise Not_found else Luint (UintDigits (prefix,c,args)) (* We are relying here on the order of digits constructors *) let digits_from_uint digits_ind prefix i = let d0 = Lconstruct (prefix, ((digits_ind, 1), Univ.Instance.empty)) in let d1 = Lconstruct (prefix, ((digits_ind, 2), Univ.Instance.empty)) in let digits = Array.make 31 d0 in for k = 0 to 30 do if Int.equal ((Uint31.to_int i lsr k) land 1) 1 then digits.(30-k) <- d1 done; digits let before_match_int31 digits_ind fc prefix c t = if not fc then raise Not_found else match t with | Luint (UintVal i) -> let digits = digits_from_uint digits_ind prefix i in mkLapp (Lconstruct (prefix,(c, Univ.Instance.empty))) digits | Luint (UintDigits (prefix,c,args)) -> mkLapp (Lconstruct (prefix,(c, Univ.Instance.empty))) args | _ -> Luint (UintDecomp (prefix,c,t)) let compile_prim prim kn fc prefix args = if not fc then raise Not_found else Lprim(prefix, kn, prim, args) coq-8.6/kernel/cooking.mli0000644000175000017500000000207713022274260015101 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* recipe -> result val cook_constr : Opaqueproof.cooking_info -> Term.constr -> Term.constr (** {6 Utility functions used in module [Discharge]. } *) val expmod_constr : Opaqueproof.work_list -> constr -> constr coq-8.6/kernel/byterun/0000755000175000017500000000000013022274260014427 5ustar mdenesmdenescoq-8.6/kernel/byterun/coq_values.h0000644000175000017500000000233613022274260016745 0ustar mdenesmdenes/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ #ifndef _COQ_VALUES_ #define _COQ_VALUES_ #include #include #define Default_tag 0 #define Accu_tag 0 #define ATOM_ID_TAG 0 #define ATOM_INDUCTIVE_TAG 1 #define ATOM_TYPE_TAG 2 #define ATOM_PROJ_TAG 3 #define ATOM_FIX_TAG 4 #define ATOM_SWITCH_TAG 5 #define ATOM_COFIX_TAG 6 #define ATOM_COFIXEVALUATED_TAG 7 /* Les blocs accumulate */ #define Is_accu(v) (Is_block(v) && (Tag_val(v) == Accu_tag)) #define IS_EVALUATED_COFIX(v) (Is_accu(v) && Is_block(Field(v,1)) && (Tag_val(Field(v,1)) == ATOM_COFIXEVALUATED_TAG)) #endif /* _COQ_VALUES_ */ coq-8.6/kernel/byterun/coq_memory.h0000644000175000017500000000367613022274260016766 0ustar mdenesmdenes/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ #ifndef _COQ_MEMORY_ #define _COQ_MEMORY_ #include #include #include #include #include #define Coq_stack_size (4096 * sizeof(value)) #define Coq_stack_threshold (256 * sizeof(value)) #define Coq_global_data_Size (4096 * sizeof(value)) #define Coq_max_stack_size (256 * 1024) #define TRANSP 0 #define BOXED 1 /* stack */ extern value * coq_stack_low; extern value * coq_stack_high; extern value * coq_stack_threshold; /* global_data */ extern value coq_global_data; extern int coq_all_transp; extern value coq_atom_tbl; extern int drawinstr; /* interp state */ extern value * coq_sp; /* Some predefined pointer code */ extern code_t accumulate; /* functions over global environment */ value coq_static_alloc(value size); /* ML */ value init_coq_vm(value unit); /* ML */ value re_init_coq_vm(value unit); /* ML */ void realloc_coq_stack(asize_t required_space); value get_coq_global_data(value unit); /* ML */ value realloc_coq_global_data(value size); /* ML */ value get_coq_atom_tbl(value unit); /* ML */ value realloc_coq_atom_tbl(value size); /* ML */ value coq_set_transp_value(value transp); /* ML */ value get_coq_transp_value(value unit); /* ML */ #endif /* _COQ_MEMORY_ */ value coq_set_drawinstr(value unit); coq-8.6/kernel/byterun/libcoqrun.clib0000644000175000017500000000006613022274260017262 0ustar mdenesmdenescoq_fix_code.o coq_memory.o coq_values.o coq_interp.o coq-8.6/kernel/byterun/coq_values.c0000644000175000017500000000406213022274260016736 0ustar mdenesmdenes/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ #include #include "coq_fix_code.h" #include "coq_instruct.h" #include "coq_memory.h" #include "coq_values.h" #include /* KIND OF VALUES */ #define Setup_for_gc #define Restore_after_gc value coq_kind_of_closure(value v) { opcode_t * c; int is_app = 0; c = Code_val(v); if (Is_instruction(c, GRAB)) return Val_int(0); if (Is_instruction(c, RESTART)) {is_app = 1; c++;} if (Is_instruction(c, GRABREC)) return Val_int(1+is_app); if (Is_instruction(c, MAKEACCU)) return Val_int(3); return Val_int(0); } /* DESTRUCT ACCU */ value coq_closure_arity(value clos) { opcode_t * c = Code_val(clos); if (Is_instruction(c,RESTART)) { c++; if (Is_instruction(c,GRAB)) return Val_int(3 + c[1] - Wosize_val(clos)); else { if (Wosize_val(clos) != 2) failwith("Coq Values : coq_closure_arity"); return Val_int(1); } } if (Is_instruction(c,GRAB)) return Val_int(1 + c[1]); return Val_int(1); } /* Fonction sur les fix */ value coq_offset(value v) { if (Tag_val(v) == Closure_tag) return Val_int(0); else return Val_long(-Wsize_bsize(Infix_offset_val(v))); } value coq_offset_closure(value v, value offset){ return (value)&Field(v, Int_val(offset)); } value coq_offset_tcode(value code,value offset){ return((value)((code_t)code + Int_val(offset))); } value coq_int_tcode(value code, value offset) { return Val_int(*((code_t) code + Int_val(offset))); } coq-8.6/kernel/byterun/coq_fix_code.c0000644000175000017500000001407113022274260017220 0ustar mdenesmdenes/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ /* Arnaud Spiwack: expanded the virtual machine with operators used for fast computation of bounded (31bits) integers */ #include #include #include #include #include #include #include #include #include "coq_instruct.h" #include "coq_fix_code.h" #ifdef THREADED_CODE char ** coq_instr_table; char * coq_instr_base; int arity[STOP+1]; void init_arity () { /* instruction with zero operand */ arity[ACC0]=arity[ACC1]=arity[ACC2]=arity[ACC3]=arity[ACC4]=arity[ACC5]= arity[ACC6]=arity[ACC7]=arity[PUSH]=arity[PUSHACC0]=arity[PUSHACC1]= arity[PUSHACC2]=arity[PUSHACC3]=arity[PUSHACC4]=arity[PUSHACC5]= arity[PUSHACC6]=arity[PUSHACC7]=arity[ENVACC1]=arity[ENVACC2]= arity[ENVACC3]=arity[ENVACC4]=arity[PUSHENVACC1]=arity[PUSHENVACC2]= arity[PUSHENVACC3]=arity[PUSHENVACC4]=arity[APPLY1]=arity[APPLY2]= arity[APPLY3]=arity[RESTART]=arity[OFFSETCLOSUREM2]= arity[OFFSETCLOSURE0]=arity[OFFSETCLOSURE2]=arity[PUSHOFFSETCLOSUREM2]= arity[PUSHOFFSETCLOSURE0]=arity[PUSHOFFSETCLOSURE2]= arity[GETFIELD0]=arity[GETFIELD1]=arity[SETFIELD0]=arity[SETFIELD1]= arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= arity[ADDINT31]=arity[ADDCINT31]=arity[ADDCARRYCINT31]= arity[SUBINT31]=arity[SUBCINT31]=arity[SUBCARRYCINT31]= arity[MULCINT31]=arity[MULINT31]=arity[COMPAREINT31]= arity[DIV21INT31]=arity[DIVINT31]=arity[ADDMULDIVINT31]= arity[HEAD0INT31]=arity[TAIL0INT31]= arity[COMPINT31]=arity[DECOMPINT31]= arity[ORINT31]=arity[ANDINT31]=arity[XORINT31]=0; /* instruction with one operand */ arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]= arity[APPTERM3]=arity[RETURN]=arity[GRAB]=arity[OFFSETCLOSURE]= arity[PUSHOFFSETCLOSURE]=arity[GETGLOBAL]=arity[PUSHGETGLOBAL]= arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]= arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]= arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]= arity[BRANCH]=arity[ISCONST]=arity[ENSURESTACKCAPACITY]=1; /* instruction with two operands */ arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= arity[ARECONST]=arity[PROJ]=2; /* instruction with four operands */ arity[MAKESWITCHBLOCK]=4; /* instruction with arbitrary operands */ arity[CLOSUREREC]=arity[CLOSURECOFIX]=arity[SWITCH]=0; } #endif /* THREADED_CODE */ void * coq_stat_alloc (asize_t sz) { void * result = malloc (sz); if (result == NULL) raise_out_of_memory (); return result; } value coq_makeaccu (value i) { code_t q; code_t res = coq_stat_alloc(2 * sizeof(opcode_t)); q = res; *q++ = VALINSTR(MAKEACCU); *q = (opcode_t)Int_val(i); return (value)res; } value coq_pushpop (value i) { code_t res; int n; n = Int_val(i); if (n == 0) { res = coq_stat_alloc(sizeof(opcode_t)); *res = VALINSTR(STOP); return (value)res; } else { code_t q; res = coq_stat_alloc(3 * sizeof(opcode_t)); q = res; *q++ = VALINSTR(POP); *q++ = (opcode_t)n; *q = VALINSTR(STOP); return (value)res; } } value coq_is_accumulate_code(value code){ code_t q; int res; q = (code_t)code; res = Is_instruction(q,ACCUMULATE); return Val_bool(res); } #ifdef ARCH_BIG_ENDIAN #define Reverse_32(dst,src) { \ char * _p, * _q; \ char _a, _b; \ _p = (char *) (src); \ _q = (char *) (dst); \ _a = _p[0]; \ _b = _p[1]; \ _q[0] = _p[3]; \ _q[1] = _p[2]; \ _q[3] = _a; \ _q[2] = _b; \ } #define COPY32(dst,src) Reverse_32(dst,src) #else #define COPY32(dst,src) (*dst=*src) #endif /* ARCH_BIG_ENDIAN */ value coq_tcode_of_code (value code, value size) { code_t p, q, res; asize_t len = (asize_t) Long_val(size); res = coq_stat_alloc(len); q = res; len /= sizeof(opcode_t); for (p = (code_t)code; p < (code_t)code + len; /*nothing*/) { opcode_t instr; COPY32(&instr,p); p++; if (instr < 0 || instr > STOP){ instr = STOP; }; *q++ = VALINSTR(instr); if (instr == SWITCH) { uint32_t i, sizes, const_size, block_size; COPY32(q,p); p++; sizes=*q++; const_size = sizes & 0xFFFFFF; block_size = sizes >> 24; sizes = const_size + block_size; for(i=0; i #include #include typedef void (*scanning_action) (value, value *); CAMLextern char *young_ptr; CAMLextern char *young_limit; CAMLextern void (*scan_roots_hook) (scanning_action); CAMLextern void minor_collection (void); #define Caml_white (0 << 8) #define Caml_black (3 << 8) #ifdef HAS_OCP_MEMPROF /* This code is necessary to make the OCamlPro memory profiling branch of OCaml compile. */ #define Make_header(wosize, tag, color) \ caml_make_header(wosize, tag, color) #else #define Make_header(wosize, tag, color) \ (((header_t) (((header_t) (wosize) << 10) \ + (color) \ + (tag_t) (tag))) \ ) #endif #define Alloc_small(result, wosize, tag) do{ \ young_ptr -= Bhsize_wosize (wosize); \ if (young_ptr < young_limit){ \ young_ptr += Bhsize_wosize (wosize); \ Setup_for_gc; \ minor_collection (); \ Restore_after_gc; \ young_ptr -= Bhsize_wosize (wosize); \ } \ Hd_hp (young_ptr) = Make_header ((wosize), (tag), Caml_black); \ (result) = Val_hp (young_ptr); \ }while(0) #endif /*_COQ_CAML_GC_ */ coq-8.6/kernel/byterun/coq_instruct.h0000644000175000017500000000454413022274260017324 0ustar mdenesmdenes/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ #ifndef _COQ_INSTRUCT_ #define _COQ_INSTRUCT_ /* Nota: this list of instructions is parsed to produce derived files */ /* coq_jumptbl.h and copcodes.ml. Instructions should be uppercase */ /* and alone on lines starting by two spaces. */ /* If adding an instruction, DON'T FORGET TO UPDATE coq_fix_code.c */ /* with the arity of the instruction and maybe coq_tcode_of_code. */ enum instructions { ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC, PUSH, PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, PUSHACC4, PUSHACC5, PUSHACC6, PUSHACC7, PUSHACC, POP, ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC, PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC, PUSH_RETADDR, APPLY, APPLY1, APPLY2, APPLY3, APPTERM, APPTERM1, APPTERM2, APPTERM3, RETURN, RESTART, GRAB, GRABREC, CLOSURE, CLOSUREREC, CLOSURECOFIX, OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE, PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, PUSHOFFSETCLOSURE2, PUSHOFFSETCLOSURE, GETGLOBAL, PUSHGETGLOBAL, MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEBLOCK4, SWITCH, PUSHFIELDS, GETFIELD0, GETFIELD1, GETFIELD, SETFIELD0, SETFIELD1, SETFIELD, PROJ, ENSURESTACKCAPACITY, CONST0, CONST1, CONST2, CONST3, CONSTINT, PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, ACCUMULATE, MAKESWITCHBLOCK, MAKEACCU, MAKEPROD, /* spiwack: */ BRANCH, ADDINT31, ADDCINT31, ADDCARRYCINT31, SUBINT31, SUBCINT31, SUBCARRYCINT31, MULCINT31, MULINT31, DIV21INT31, DIVINT31, ADDMULDIVINT31, COMPAREINT31, HEAD0INT31, TAIL0INT31, ISCONST, ARECONST, COMPINT31, DECOMPINT31, ORINT31, ANDINT31, XORINT31, /* /spiwack */ STOP }; #endif /* _COQ_INSTRUCT_ */ coq-8.6/kernel/byterun/coq_memory.c0000644000175000017500000001323113022274260016745 0ustar mdenesmdenes/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ #include #include #include "coq_gc.h" #include "coq_instruct.h" #include "coq_fix_code.h" #include "coq_memory.h" #include "coq_interp.h" /* stack */ value * coq_stack_low; value * coq_stack_high; value * coq_stack_threshold; asize_t coq_max_stack_size = Coq_max_stack_size; /* global_data */ value coq_global_data; value coq_atom_tbl; int drawinstr; /* interp state */ long coq_saved_sp_offset; value * coq_sp; /* Some predefined pointer code */ code_t accumulate; /* functions over global environment */ void coq_stat_free (void * blk) { free (blk); } value coq_static_alloc(value size) /* ML */ { return (value) coq_stat_alloc((asize_t) Long_val(size)); } value accumulate_code(value unit) /* ML */ { return (value) accumulate; } static void (*coq_prev_scan_roots_hook) (scanning_action); static void coq_scan_roots(scanning_action action) { register value * i; /* Scan the global variables */ (*action)(coq_global_data, &coq_global_data); (*action)(coq_atom_tbl, &coq_atom_tbl); /* Scan the stack */ for (i = coq_sp; i < coq_stack_high; i++) { (*action) (*i, i); }; /* Hook */ if (coq_prev_scan_roots_hook != NULL) (*coq_prev_scan_roots_hook)(action); } void init_coq_stack() { coq_stack_low = (value *) coq_stat_alloc(Coq_stack_size); coq_stack_high = coq_stack_low + Coq_stack_size / sizeof (value); coq_stack_threshold = coq_stack_low + Coq_stack_threshold / sizeof(value); coq_max_stack_size = Coq_max_stack_size; } void init_coq_global_data(long requested_size) { int i; coq_global_data = alloc_shr(requested_size, 0); for (i = 0; i < requested_size; i++) Field (coq_global_data, i) = Val_unit; } void init_coq_atom_tbl(long requested_size){ int i; coq_atom_tbl = alloc_shr(requested_size, 0); for (i = 0; i < requested_size; i++) Field (coq_atom_tbl, i) = Val_unit; } void init_coq_interpreter() { coq_sp = coq_stack_high; coq_interprete(NULL, Val_unit, Val_unit, 0); } static int coq_vm_initialized = 0; value init_coq_vm(value unit) /* ML */ { if (coq_vm_initialized == 1) { fprintf(stderr,"already open \n");fflush(stderr);} else { drawinstr=0; #ifdef THREADED_CODE init_arity(); #endif /* THREADED_CODE */ /* Allocate the table of global and the stack */ init_coq_stack(); init_coq_global_data(Coq_global_data_Size); init_coq_atom_tbl(40); /* Initialing the interpreter */ init_coq_interpreter(); /* Some predefined pointer code */ accumulate = (code_t) coq_stat_alloc(sizeof(opcode_t)); *accumulate = VALINSTR(ACCUMULATE); /* Initialize GC */ if (coq_prev_scan_roots_hook == NULL) coq_prev_scan_roots_hook = scan_roots_hook; scan_roots_hook = coq_scan_roots; coq_vm_initialized = 1; } return Val_unit;; } /* [required_space] is a size in words */ void realloc_coq_stack(asize_t required_space) { asize_t size; value * new_low, * new_high, * new_sp; size = coq_stack_high - coq_stack_low; do { size *= 2; } while (size < coq_stack_high - coq_sp + required_space); new_low = (value *) coq_stat_alloc(size * sizeof(value)); new_high = new_low + size; #define shift(ptr) \ ((char *) new_high - ((char *) coq_stack_high - (char *) (ptr))) new_sp = (value *) shift(coq_sp); memmove((char *) new_sp, (char *) coq_sp, (coq_stack_high - coq_sp) * sizeof(value)); coq_stat_free(coq_stack_low); coq_stack_low = new_low; coq_stack_high = new_high; coq_stack_threshold = coq_stack_low + Coq_stack_threshold / sizeof(value); coq_sp = new_sp; #undef shift } value get_coq_global_data(value unit) /* ML */ { return coq_global_data; } value get_coq_atom_tbl(value unit) /* ML */ { return coq_atom_tbl; } value realloc_coq_global_data(value size) /* ML */ { mlsize_t requested_size, actual_size, i; value new_global_data; requested_size = Long_val(size); actual_size = Wosize_val(coq_global_data); if (requested_size >= actual_size) { requested_size = (requested_size + 0x100) & 0xFFFFFF00; new_global_data = alloc_shr(requested_size, 0); for (i = 0; i < actual_size; i++) initialize(&Field(new_global_data, i), Field(coq_global_data, i)); for (i = actual_size; i < requested_size; i++){ Field (new_global_data, i) = Val_long (0); } coq_global_data = new_global_data; } return Val_unit; } value realloc_coq_atom_tbl(value size) /* ML */ { mlsize_t requested_size, actual_size, i; value new_atom_tbl; requested_size = Long_val(size); actual_size = Wosize_val(coq_atom_tbl); if (requested_size >= actual_size) { requested_size = (requested_size + 0x100) & 0xFFFFFF00; new_atom_tbl = alloc_shr(requested_size, 0); for (i = 0; i < actual_size; i++) initialize(&Field(new_atom_tbl, i), Field(coq_atom_tbl, i)); for (i = actual_size; i < requested_size; i++) Field (new_atom_tbl, i) = Val_long (0); coq_atom_tbl = new_atom_tbl; } return Val_unit; } value coq_set_drawinstr(value unit) { drawinstr = 1; return Val_unit; } coq-8.6/kernel/byterun/coq_interp.h0000644000175000017500000000176713022274260016756 0ustar mdenesmdenes/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ value coq_push_ra(value tcode); value coq_push_val(value v); value coq_push_arguments(value args); value coq_push_vstack(value stk); value coq_interprete_ml(value tcode, value a, value e, value ea); value coq_interprete (code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args); value coq_eval_tcode (value tcode, value e); coq-8.6/kernel/byterun/coq_fix_code.h0000644000175000017500000000235513022274260017227 0ustar mdenesmdenes/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ #ifndef _COQ_FIX_CODE_ #define _COQ_FIX_CODE_ #include void * coq_stat_alloc (asize_t sz); #ifdef THREADED_CODE extern char ** coq_instr_table; extern char * coq_instr_base; void init_arity(); #define VALINSTR(instr) ((opcode_t)(coq_instr_table[instr] - coq_instr_base)) #else #define VALINSTR(instr) instr #endif /* THREADED_CODE */ #define Is_instruction(pc,instr) (*pc == VALINSTR(instr)) value coq_tcode_of_code(value code, value len); value coq_makeaccu (value i); value coq_pushpop (value i); value coq_is_accumulate_code(value code); #endif /* _COQ_FIX_CODE_ */ coq-8.6/kernel/byterun/coq_interp.c0000644000175000017500000011140413022274260016737 0ustar mdenesmdenes/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ /* The bytecode interpreter */ /* Spiwack: expanded the virtual machine with operators used for fast computation of bounded (31bits) integers */ #include #include #include #include "coq_gc.h" #include "coq_instruct.h" #include "coq_fix_code.h" #include "coq_memory.h" #include "coq_values.h" /* spiwack: I append here a few macros for value/number manipulation */ #define uint32_of_value(val) (((uint32_t)(val)) >> 1) #define value_of_uint32(i) ((value)((((uint32_t)(i)) << 1) | 1)) #define UI64_of_uint32(lo) ((uint64_t)((uint32_t)(lo))) #define UI64_of_value(val) (UI64_of_uint32(uint32_of_value(val))) /* /spiwack */ /* Registers for the abstract machine: pc the code pointer sp the stack pointer (grows downward) accu the accumulator env heap-allocated environment trapsp pointer to the current trap frame extra_args number of extra arguments provided by the caller sp is a local copy of the global variable extern_sp. */ /* Instruction decoding */ #ifdef THREADED_CODE # define Instruct(name) coq_lbl_##name: # if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) # define coq_Jumptbl_base ((char *) &&coq_lbl_ACC0) # else # define coq_Jumptbl_base ((char *) 0) # define coq_jumptbl_base ((char *) 0) # endif # ifdef DEBUG # define Next goto next_instr # else # define Next goto *(void *)(coq_jumptbl_base + *pc++) # endif #else # define Instruct(name) case name: # define Next break #endif /* #define _COQ_DEBUG_ */ #ifdef _COQ_DEBUG_ # define print_instr(s) /*if (drawinstr)*/ printf("%s\n",s) # define print_int(i) /*if (drawinstr)*/ printf("%d\n",i) # define print_lint(i) /*if (drawinstr)*/ printf("%ld\n",i) # else # define print_instr(s) # define print_int(i) # define print_lint(i) #endif #define CHECK_STACK(num_args) { \ if (sp - num_args < coq_stack_threshold) { \ coq_sp = sp; \ realloc_coq_stack(num_args + Coq_stack_threshold / sizeof(value)); \ sp = coq_sp; \ } \ } /* GC interface */ #define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; } #define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; } /* Register optimization. Some compilers underestimate the use of the local variables representing the abstract machine registers, and don't put them in hardware registers, which slows down the interpreter considerably. For GCC, Xavier Leroy have hand-assigned hardware registers for several architectures. */ #if defined(__GNUC__) && !defined(DEBUG) #ifdef __mips__ #define PC_REG asm("$16") #define SP_REG asm("$17") #define ACCU_REG asm("$18") #endif #ifdef __sparc__ #define PC_REG asm("%l0") #define SP_REG asm("%l1") #define ACCU_REG asm("%l2") #endif #ifdef __alpha__ #ifdef __CRAY__ #define PC_REG asm("r9") #define SP_REG asm("r10") #define ACCU_REG asm("r11") #define JUMPTBL_BASE_REG asm("r12") #else #define PC_REG asm("$9") #define SP_REG asm("$10") #define ACCU_REG asm("$11") #define JUMPTBL_BASE_REG asm("$12") #endif #endif #ifdef __i386__ #define PC_REG asm("%esi") #define SP_REG asm("%edi") #define ACCU_REG #endif #if defined(PPC) || defined(_POWER) || defined(_IBMR2) #define PC_REG asm("26") #define SP_REG asm("27") #define ACCU_REG asm("28") #endif #ifdef __hppa__ #define PC_REG asm("%r18") #define SP_REG asm("%r17") #define ACCU_REG asm("%r16") #endif #ifdef __mc68000__ #define PC_REG asm("a5") #define SP_REG asm("a4") #define ACCU_REG asm("d7") #endif #if defined(__arm__) && !defined(__thumb2__) #define PC_REG asm("r9") #define SP_REG asm("r8") #define ACCU_REG asm("r7") #endif #ifdef __ia64__ #define PC_REG asm("36") #define SP_REG asm("37") #define ACCU_REG asm("38") #define JUMPTBL_BASE_REG asm("39") #endif #endif /* For signal handling, we hijack some code from the caml runtime */ extern intnat caml_signals_are_pending; extern intnat caml_pending_signals[]; extern void caml_process_pending_signals(void); /* The interpreter itself */ value coq_interprete (code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args) { /*Declaration des variables */ #ifdef PC_REG register code_t pc PC_REG; register value * sp SP_REG; register value accu ACCU_REG; #else register code_t pc; register value * sp; register value accu; #endif #if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) #ifdef JUMPTBL_BASE_REG register char * coq_jumptbl_base JUMPTBL_BASE_REG; #else register char * coq_jumptbl_base; #endif #endif #ifdef THREADED_CODE static void * coq_jumptable[] = { # include "coq_jumptbl.h" }; #else opcode_t curr_instr; #endif print_instr("Enter Interpreter"); if (coq_pc == NULL) { /* Interpreter is initializing */ print_instr("Interpreter is initializing"); #ifdef THREADED_CODE coq_instr_table = (char **) coq_jumptable; coq_instr_base = coq_Jumptbl_base; #endif return Val_unit; } #if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) coq_jumptbl_base = coq_Jumptbl_base; #endif /* Initialisation */ sp = coq_sp; pc = coq_pc; accu = coq_accu; CHECK_STACK(0); #ifdef THREADED_CODE goto *(void *)(coq_jumptbl_base + *pc++); /* Jump to the first instruction */ #else while(1) { curr_instr = *pc++; switch(curr_instr) { #endif /* Basic stack operations */ Instruct(ACC0){ print_instr("ACC0"); accu = sp[0]; Next; } Instruct(ACC1){ print_instr("ACC1"); accu = sp[1]; Next; } Instruct(ACC2){ print_instr("ACC2"); accu = sp[2]; Next; } Instruct(ACC3){ print_instr("ACC3"); accu = sp[3]; Next; } Instruct(ACC4){ print_instr("ACC4"); accu = sp[4]; Next; } Instruct(ACC5){ print_instr("ACC5"); accu = sp[5]; Next; } Instruct(ACC6){ print_instr("ACC6"); accu = sp[6]; Next; } Instruct(ACC7){ print_instr("ACC7"); accu = sp[7]; Next; } Instruct(PUSH){ print_instr("PUSH"); *--sp = accu; Next; } Instruct(PUSHACC0) { print_instr("PUSHACC0"); *--sp = accu; Next; } Instruct(PUSHACC1){ print_instr("PUSHACC1"); *--sp = accu; accu = sp[1]; Next; } Instruct(PUSHACC2){ print_instr("PUSHACC2"); *--sp = accu; accu = sp[2]; Next; } Instruct(PUSHACC3){ print_instr("PUSHACC3"); *--sp = accu; accu = sp[3]; Next; } Instruct(PUSHACC4){ print_instr("PUSHACC4"); *--sp = accu; accu = sp[4]; Next; } Instruct(PUSHACC5){ print_instr("PUSHACC5"); *--sp = accu; accu = sp[5]; Next; } Instruct(PUSHACC6){ print_instr("PUSHACC5"); *--sp = accu; accu = sp[6]; Next; } Instruct(PUSHACC7){ print_instr("PUSHACC7"); *--sp = accu; accu = sp[7]; Next; } Instruct(PUSHACC){ print_instr("PUSHACC"); *--sp = accu; } /* Fallthrough */ Instruct(ACC){ print_instr("ACC"); accu = sp[*pc++]; Next; } Instruct(POP){ print_instr("POP"); sp += *pc++; Next; } /* Access in heap-allocated environment */ Instruct(ENVACC1){ print_instr("ENVACC1"); accu = Field(coq_env, 1); Next; } Instruct(ENVACC2){ print_instr("ENVACC2"); accu = Field(coq_env, 2); Next; } Instruct(ENVACC3){ print_instr("ENVACC3"); accu = Field(coq_env, 3); Next; } Instruct(ENVACC4){ print_instr("ENVACC4"); accu = Field(coq_env, 4); Next; } Instruct(PUSHENVACC1){ print_instr("PUSHENVACC1"); *--sp = accu; accu = Field(coq_env, 1); Next; } Instruct(PUSHENVACC2){ print_instr("PUSHENVACC2"); *--sp = accu; accu = Field(coq_env, 2); Next; } Instruct(PUSHENVACC3){ print_instr("PUSHENVACC3"); *--sp = accu; accu = Field(coq_env, 3); Next; } Instruct(PUSHENVACC4){ print_instr("PUSHENVACC4"); *--sp = accu; accu = Field(coq_env, 4); Next; } Instruct(PUSHENVACC){ print_instr("PUSHENVACC"); *--sp = accu; } /* Fallthrough */ Instruct(ENVACC){ print_instr("ENVACC"); print_int(*pc); accu = Field(coq_env, *pc++); Next; } /* Function application */ Instruct(PUSH_RETADDR) { print_instr("PUSH_RETADDR"); sp -= 3; sp[0] = (value) (pc + *pc); sp[1] = coq_env; sp[2] = Val_long(coq_extra_args); coq_extra_args = 0; pc++; Next; } Instruct(APPLY) { print_instr("APPLY"); coq_extra_args = *pc - 1; pc = Code_val(accu); coq_env = accu; goto check_stack; } Instruct(APPLY1) { value arg1 = sp[0]; print_instr("APPLY1"); sp -= 3; sp[0] = arg1; sp[1] = (value)pc; sp[2] = coq_env; sp[3] = Val_long(coq_extra_args); print_instr("call stack="); print_lint(sp[1]); print_lint(sp[2]); print_lint(sp[3]); pc = Code_val(accu); coq_env = accu; coq_extra_args = 0; goto check_stack; } Instruct(APPLY2) { value arg1 = sp[0]; value arg2 = sp[1]; print_instr("APPLY2"); sp -= 3; sp[0] = arg1; sp[1] = arg2; sp[2] = (value)pc; sp[3] = coq_env; sp[4] = Val_long(coq_extra_args); pc = Code_val(accu); coq_env = accu; coq_extra_args = 1; goto check_stack; } Instruct(APPLY3) { value arg1 = sp[0]; value arg2 = sp[1]; value arg3 = sp[2]; print_instr("APPLY3"); sp -= 3; sp[0] = arg1; sp[1] = arg2; sp[2] = arg3; sp[3] = (value)pc; sp[4] = coq_env; sp[5] = Val_long(coq_extra_args); pc = Code_val(accu); coq_env = accu; coq_extra_args = 2; goto check_stack; } /* Stack checks */ check_stack: print_instr("check_stack"); CHECK_STACK(0); /* We also check for signals */ if (caml_signals_are_pending) { /* If there's a Ctrl-C, we reset the vm */ if (caml_pending_signals[SIGINT]) { coq_sp = coq_stack_high; } caml_process_pending_signals(); } Next; Instruct(ENSURESTACKCAPACITY) { print_instr("ENSURESTACKCAPACITY"); int size = *pc++; /* CHECK_STACK may trigger here a useless allocation because of the threshold, but check_stack: often does it anyway, so we prefer to factorize the code. */ CHECK_STACK(size); Next; } Instruct(APPTERM) { int nargs = *pc++; int slotsize = *pc; value * newsp; int i; print_instr("APPTERM"); /* Slide the nargs bottom words of the current frame to the top of the frame, and discard the remainder of the frame */ newsp = sp + slotsize - nargs; for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i]; sp = newsp; pc = Code_val(accu); coq_env = accu; coq_extra_args += nargs - 1; goto check_stack; } Instruct(APPTERM1) { value arg1 = sp[0]; print_instr("APPTERM1"); sp = sp + *pc - 1; sp[0] = arg1; pc = Code_val(accu); coq_env = accu; goto check_stack; } Instruct(APPTERM2) { value arg1 = sp[0]; value arg2 = sp[1]; print_instr("APPTERM2"); sp = sp + *pc - 2; sp[0] = arg1; sp[1] = arg2; pc = Code_val(accu); print_lint(accu); coq_env = accu; coq_extra_args += 1; goto check_stack; } Instruct(APPTERM3) { value arg1 = sp[0]; value arg2 = sp[1]; value arg3 = sp[2]; print_instr("APPTERM3"); sp = sp + *pc - 3; sp[0] = arg1; sp[1] = arg2; sp[2] = arg3; pc = Code_val(accu); coq_env = accu; coq_extra_args += 2; goto check_stack; } Instruct(RETURN) { print_instr("RETURN"); print_int(*pc); sp += *pc++; print_instr("stack="); print_lint(sp[0]); print_lint(sp[1]); print_lint(sp[2]); if (coq_extra_args > 0) { print_instr("extra args > 0"); print_lint(coq_extra_args); coq_extra_args--; pc = Code_val(accu); coq_env = accu; } else { print_instr("extra args = 0"); pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; } Next; } Instruct(RESTART) { int num_args = Wosize_val(coq_env) - 2; int i; print_instr("RESTART"); CHECK_STACK(num_args); sp -= num_args; for (i = 0; i < num_args; i++) sp[i] = Field(coq_env, i + 2); coq_env = Field(coq_env, 1); coq_extra_args += num_args; Next; } Instruct(GRAB) { int required = *pc++; print_instr("GRAB"); /* printf("GRAB %d\n",required); */ if (coq_extra_args >= required) { coq_extra_args -= required; } else { mlsize_t num_args, i; num_args = 1 + coq_extra_args; /* arg1 + extra args */ Alloc_small(accu, num_args + 2, Closure_tag); Field(accu, 1) = coq_env; for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ sp += num_args; pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; } Next; } Instruct(GRABREC) { int rec_pos = *pc++; /* commence a zero */ print_instr("GRABREC"); if (rec_pos <= coq_extra_args && !Is_accu(sp[rec_pos])) { pc++;/* On saute le Restart */ } else { if (coq_extra_args < rec_pos) { /* Partial application */ mlsize_t num_args, i; num_args = 1 + coq_extra_args; /* arg1 + extra args */ Alloc_small(accu, num_args + 2, Closure_tag); Field(accu, 1) = coq_env; for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; Code_val(accu) = pc - 3; sp += num_args; pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; } else { /* The recursif argument is an accumulator */ mlsize_t num_args, i; /* Construction of fixpoint applied to its [rec_pos-1] first arguments */ Alloc_small(accu, rec_pos + 2, Closure_tag); Field(accu, 1) = coq_env; // We store the fixpoint in the first field for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i]; // Storing args Code_val(accu) = pc; sp += rec_pos; *--sp = accu; /* Construction of the atom */ Alloc_small(accu, 2, ATOM_FIX_TAG); Field(accu,1) = sp[0]; Field(accu,0) = sp[1]; sp++; sp[0] = accu; /* Construction of the accumulator */ num_args = coq_extra_args - rec_pos; Alloc_small(accu, 2+num_args, Accu_tag); Code_val(accu) = accumulate; Field(accu,1) = sp[0]; sp++; for (i = 0; i < num_args;i++)Field(accu, i + 2) = sp[i]; sp += num_args; pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; } } Next; } Instruct(CLOSURE) { int nvars = *pc++; int i; print_instr("CLOSURE"); print_int(nvars); if (nvars > 0) *--sp = accu; Alloc_small(accu, 1 + nvars, Closure_tag); Code_val(accu) = pc + *pc; pc++; for (i = 0; i < nvars; i++) { print_lint(sp[i]); Field(accu, i + 1) = sp[i]; } sp += nvars; Next; } Instruct(CLOSUREREC) { int nfuncs = *pc++; int nvars = *pc++; int start = *pc++; int i; value * p; print_instr("CLOSUREREC"); if (nvars > 0) *--sp = accu; /* construction du vecteur de type */ Alloc_small(accu, nfuncs, 0); for(i = 0; i < nfuncs; i++) { Field(accu,i) = (value)(pc+pc[i]); } pc += nfuncs; *--sp=accu; Alloc_small(accu, nfuncs * 2 + nvars, Closure_tag); Field(accu, nfuncs * 2 + nvars - 1) = *sp++; /* On remplie la partie pour les variables libres */ p = &Field(accu, nfuncs * 2 - 1); for (i = 0; i < nvars; i++) { *p++ = *sp++; } p = &Field(accu, 0); *p = (value) (pc + pc[0]); p++; for (i = 1; i < nfuncs; i++) { *p = Make_header(i * 2, Infix_tag, Caml_white); p++; /* color irrelevant. */ *p = (value) (pc + pc[i]); p++; } pc += nfuncs; accu = accu + 2 * start * sizeof(value); Next; } Instruct(CLOSURECOFIX){ int nfunc = *pc++; int nvars = *pc++; int start = *pc++; int i, j , size; value * p; print_instr("CLOSURECOFIX"); if (nvars > 0) *--sp = accu; /* construction du vecteur de type */ Alloc_small(accu, nfunc, 0); for(i = 0; i < nfunc; i++) { Field(accu,i) = (value)(pc+pc[i]); } pc += nfunc; *--sp=accu; /* Creation des blocks accumulate */ for(i=0; i < nfunc; i++) { Alloc_small(accu, 2, Accu_tag); Code_val(accu) = accumulate; Field(accu,1) = Val_int(1); *--sp=accu; } /* creation des fonction cofix */ p = sp; size = nfunc + nvars + 2; for (i=0; i < nfunc; i++) { Alloc_small(accu, size, Closure_tag); Code_val(accu) = pc+pc[i]; for (j = 0; j < nfunc; j++) Field(accu, j+1) = p[j]; Field(accu, size - 1) = p[nfunc]; for (j = nfunc+1; j <= nfunc+nvars; j++) Field(accu, j) = p[j]; *--sp = accu; /* creation du block contenant le cofix */ Alloc_small(accu,1, ATOM_COFIX_TAG); Field(accu, 0) = sp[0]; *sp = accu; /* mise a jour du block accumulate */ caml_modify(&Field(p[i], 1),*sp); sp++; } pc += nfunc; accu = p[start]; sp = p + nfunc + 1 + nvars; print_instr("ici4"); Next; } Instruct(PUSHOFFSETCLOSURE) { print_instr("PUSHOFFSETCLOSURE"); *--sp = accu; } /* fallthrough */ Instruct(OFFSETCLOSURE) { print_instr("OFFSETCLOSURE"); accu = coq_env + *pc++ * sizeof(value); Next; } Instruct(PUSHOFFSETCLOSUREM2) { print_instr("PUSHOFFSETCLOSUREM2"); *--sp = accu; } /* fallthrough */ Instruct(OFFSETCLOSUREM2) { print_instr("OFFSETCLOSUREM2"); accu = coq_env - 2 * sizeof(value); Next; } Instruct(PUSHOFFSETCLOSURE0) { print_instr("PUSHOFFSETCLOSURE0"); *--sp = accu; }/* fallthrough */ Instruct(OFFSETCLOSURE0) { print_instr("OFFSETCLOSURE0"); accu = coq_env; Next; } Instruct(PUSHOFFSETCLOSURE2){ print_instr("PUSHOFFSETCLOSURE2"); *--sp = accu; /* fallthrough */ } Instruct(OFFSETCLOSURE2) { print_instr("OFFSETCLOSURE2"); accu = coq_env + 2 * sizeof(value); Next; } /* Access to global variables */ Instruct(PUSHGETGLOBAL) { print_instr("PUSH"); *--sp = accu; } /* Fallthrough */ Instruct(GETGLOBAL){ print_instr("GETGLOBAL"); print_int(*pc); accu = Field(coq_global_data, *pc); pc++; Next; } /* Allocation of blocks */ Instruct(MAKEBLOCK) { mlsize_t wosize = *pc++; tag_t tag = *pc++; mlsize_t i; value block; print_instr("MAKEBLOCK, tag="); Alloc_small(block, wosize, tag); Field(block, 0) = accu; for (i = 1; i < wosize; i++) Field(block, i) = *sp++; accu = block; Next; } Instruct(MAKEBLOCK1) { tag_t tag = *pc++; value block; print_instr("MAKEBLOCK1, tag="); print_int(tag); Alloc_small(block, 1, tag); Field(block, 0) = accu; accu = block; Next; } Instruct(MAKEBLOCK2) { tag_t tag = *pc++; value block; print_instr("MAKEBLOCK2, tag="); print_int(tag); Alloc_small(block, 2, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; sp += 1; accu = block; Next; } Instruct(MAKEBLOCK3) { tag_t tag = *pc++; value block; print_instr("MAKEBLOCK3, tag="); print_int(tag); Alloc_small(block, 3, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; Field(block, 2) = sp[1]; sp += 2; accu = block; Next; } Instruct(MAKEBLOCK4) { tag_t tag = *pc++; value block; print_instr("MAKEBLOCK4, tag="); print_int(tag); Alloc_small(block, 4, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; Field(block, 2) = sp[1]; Field(block, 3) = sp[2]; sp += 3; accu = block; Next; } /* Access to components of blocks */ Instruct(SWITCH) { uint32_t sizes = *pc++; print_instr("SWITCH"); print_int(sizes & 0xFFFFFF); if (Is_block(accu)) { long index = Tag_val(accu); print_instr("block"); print_lint(index); pc += pc[(sizes & 0xFFFFFF) + index]; } else { long index = Long_val(accu); print_instr("constant"); print_lint(index); pc += pc[index]; } Next; } Instruct(PUSHFIELDS){ int i; int size = *pc++; print_instr("PUSHFIELDS"); sp -= size; for(i=0;i p = 2v*w */ p = UI64_of_value (accu) * UI64_of_uint32 ((*sp++)^1); if (p == 0) { accu = (value)1; } else { /* the output type is supposed to have a constant constructor and a non-constant constructor (in that order), the tag of the non-constant constructor is then 1 */ Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ /*unsigned shift*/ Field(accu, 0) = (value)((p >> 31)|1) ; /*higher part*/ Field(accu, 1) = (value)((uint32_t)p|1); /*lower part*/ } Next; } Instruct (DIV21INT31) { print_instr("DIV21INT31"); /* spiwack: takes three int31 (the two first ones represent an int62) and performs the euclidian division of the int62 by the int31 */ uint64_t bigint; bigint = UI64_of_value(accu); bigint = (bigint << 31) | UI64_of_value(*sp++); uint64_t divisor; divisor = UI64_of_value(*sp++); Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ if (divisor == 0) { Field(accu, 0) = 1; /* 2*0+1 */ Field(accu, 1) = 1; /* 2*0+1 */ } else { uint64_t quo, mod; quo = bigint / divisor; mod = bigint % divisor; Field(accu, 0) = value_of_uint32((uint32_t)(quo)); Field(accu, 1) = value_of_uint32((uint32_t)(mod)); } Next; } Instruct (DIVINT31) { print_instr("DIVINT31"); /* spiwack: a priori no need of the NON_STANDARD_DIV_MOD flag since it probably only concerns negative number. needs to be checked at this point */ uint32_t divisor; divisor = uint32_of_value(*sp++); if (divisor == 0) { Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ Field(accu, 0) = 1; /* 2*0+1 */ Field(accu, 1) = 1; /* 2*0+1 */ } else { uint32_t modulus; modulus = uint32_of_value(accu); Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ Field(accu, 0) = value_of_uint32(modulus/divisor); Field(accu, 1) = value_of_uint32(modulus%divisor); } Next; } Instruct (ADDMULDIVINT31) { print_instr("ADDMULDIVINT31"); /* higher level shift (does shifts and cycles and such) */ uint32_t shiftby; shiftby = uint32_of_value(accu); if (shiftby > 31) { if (shiftby < 62) { sp++; accu = (value)(((((uint32_t)*sp++)^1) << (shiftby - 31)) | 1); } else { sp+=2; accu = (value)(1); } } else{ /* *sp = 2*x+1 --> accu = 2^(shiftby+1)*x */ accu = (value)((((uint32_t)*sp++)^1) << shiftby); /* accu = 2^(shiftby+1)*x --> 2^(shifby+1)*x+2*y/2^(31-shiftby)+1 */ accu = (value)((accu | (((uint32_t)(*sp++)) >> (31-shiftby)))|1); } Next; } Instruct (COMPAREINT31) { /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ /* assumes Inductive _ : _ := Eq | Lt | Gt */ print_instr("COMPAREINT31"); if ((uint32_t)accu == (uint32_t)*sp) { accu = 1; /* 2*0+1 */ sp++; } else{if ((uint32_t)accu < (uint32_t)(*sp++)) { accu = 3; /* 2*1+1 */ } else{ accu = 5; /* 2*2+1 */ }} Next; } Instruct (HEAD0INT31) { int r = 0; uint32_t x; print_instr("HEAD0INT31"); x = (uint32_t) accu; if (!(x & 0xFFFF0000)) { x <<= 16; r += 16; } if (!(x & 0xFF000000)) { x <<= 8; r += 8; } if (!(x & 0xF0000000)) { x <<= 4; r += 4; } if (!(x & 0xC0000000)) { x <<= 2; r += 2; } if (!(x & 0x80000000)) { x <<=1; r += 1; } if (!(x & 0x80000000)) { r += 1; } accu = value_of_uint32(r); Next; } Instruct (TAIL0INT31) { int r = 0; uint32_t x; print_instr("TAIL0INT31"); x = (((uint32_t) accu >> 1) | 0x80000000); if (!(x & 0xFFFF)) { x >>= 16; r += 16; } if (!(x & 0x00FF)) { x >>= 8; r += 8; } if (!(x & 0x000F)) { x >>= 4; r += 4; } if (!(x & 0x0003)) { x >>= 2; r += 2; } if (!(x & 0x0001)) { x >>=1; r += 1; } if (!(x & 0x0001)) { r += 1; } accu = value_of_uint32(r); Next; } Instruct (ISCONST) { /* Branches if the accu does not contain a constant (i.e., a non-block value) */ print_instr("ISCONST"); if ((accu & 1) == 0) /* last bit is 0 -> it is a block */ pc += *pc; else pc++; Next; } Instruct (ARECONST) { /* Branches if the n first values on the stack are not all constansts */ print_instr("ARECONST"); int i, n, ok; ok = 1; n = *pc++; for(i=0; i < n; i++) { if ((sp[i] & 1) == 0) { ok = 0; break; } } if(ok) pc++; else pc += *pc; Next; } Instruct (COMPINT31) { /* makes an 31-bit integer out of the accumulator and the 30 first values of the stack and put it in the accumulator (the accumulator then the topmost get to be the heavier bits) */ print_instr("COMPINT31"); int i; /*accu=accu or accu = (value)((unsigned long)1-accu) if bool is used for the bits */ for(i=0; i < 30; i++) { accu = (value) ((((uint32_t)accu-1) << 1) | *sp++); /* -1 removes the tag bit, << 1 multiplies the value by 2, | *sp++ pops the last value and add it (no carry involved) not that it reintroduces a tag bit */ /* alternative, if bool is used for the bits : accu = (value) ((((unsigned long)accu) << 1) & !*sp++); */ } Next; } Instruct (DECOMPINT31) { /* builds a block out of a 31-bit integer (from the accumulator), used before cases */ int i; value block; print_instr("DECOMPINT31"); Alloc_small(block, 31, 1); // Alloc_small(*, size, tag) for(i = 30; i >= 0; i--) { Field(block, i) = (value)(accu & 3); /* two last bits of the accumulator */ //Field(block, i) = 3; accu = (value) ((uint32_t)accu >> 1) | 1; /* last bit must be a one */ }; accu = block; Next; } Instruct (ORINT31) { /* returns the bitwise or */ print_instr("ORINT31"); accu = value_of_uint32((uint32_of_value(accu)) | (uint32_of_value(*sp++))); Next; } Instruct (ANDINT31) { /* returns the bitwise and */ print_instr("ANDINT31"); accu = value_of_uint32((uint32_of_value(accu)) & (uint32_of_value(*sp++))); Next; } Instruct (XORINT31) { /* returns the bitwise xor */ print_instr("XORINT31"); accu = value_of_uint32((uint32_of_value(accu)) ^ (uint32_of_value(*sp++))); Next; } /* /spiwack */ /* Debugging and machine control */ Instruct(STOP){ print_instr("STOP"); coq_sp = sp; return accu; } #ifndef THREADED_CODE default: /*fprintf(stderr, "%d\n", *pc);*/ failwith("Coq VM: Fatal error: bad opcode"); } } #endif } value coq_push_ra(value tcode) { print_instr("push_ra"); coq_sp -= 3; coq_sp[0] = (value) tcode; coq_sp[1] = Val_unit; coq_sp[2] = Val_long(0); return Val_unit; } value coq_push_val(value v) { print_instr("push_val"); *--coq_sp = v; return Val_unit; } value coq_push_arguments(value args) { int nargs,i; value * sp = coq_sp; nargs = Wosize_val(args) - 2; CHECK_STACK(nargs); coq_sp -= nargs; print_instr("push_args");print_int(nargs); for(i = 0; i < nargs; i++) coq_sp[i] = Field(args, i+2); return Val_unit; } value coq_push_vstack(value stk, value max_stack_size) { int len,i; value * sp = coq_sp; len = Wosize_val(stk); CHECK_STACK(len); coq_sp -= len; print_instr("push_vstack");print_int(len); for(i = 0; i < len; i++) coq_sp[i] = Field(stk,i); sp = coq_sp; CHECK_STACK(uint32_of_value(max_stack_size)); return Val_unit; } value coq_interprete_ml(value tcode, value a, value e, value ea) { print_instr("coq_interprete"); return coq_interprete((code_t)tcode, a, e, Long_val(ea)); print_instr("end coq_interprete"); } value coq_eval_tcode (value tcode, value e) { return coq_interprete_ml(tcode, Val_unit, e, 0); } coq-8.6/kernel/modops.ml0000644000175000017500000005262713022274260014606 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* false |MoreFunctor _ -> true let destr_functor = function |NoFunctor _ -> error_not_a_functor () |MoreFunctor (mbid,ty,x) -> (mbid,ty,x) let destr_nofunctor = function |NoFunctor a -> a |MoreFunctor _ -> error_is_a_functor () let rec functor_smartmap fty f0 funct = match funct with |MoreFunctor (mbid,ty,e) -> let ty' = fty ty in let e' = functor_smartmap fty f0 e in if ty==ty' && e==e' then funct else MoreFunctor (mbid,ty',e') |NoFunctor a -> let a' = f0 a in if a==a' then funct else NoFunctor a' let rec functor_iter fty f0 = function |MoreFunctor (mbid,ty,e) -> fty ty; functor_iter fty f0 e |NoFunctor a -> f0 a (** {6 Misc operations } *) let module_type_of_module mb = { mb with mod_expr = Abstract; mod_type_alg = None } let module_body_of_type mp mtb = assert (mtb.mod_expr == Abstract); { mtb with mod_mp = mp } let check_modpath_equiv env mp1 mp2 = if ModPath.equal mp1 mp2 then () else let mp1' = mp_of_delta (lookup_module mp1 env).mod_delta mp1 in let mp2' = mp_of_delta (lookup_module mp2 env).mod_delta mp2 in if ModPath.equal mp1' mp2' then () else error_not_equal_modpaths mp1 mp2 let implem_smartmap fs fa impl = match impl with |Struct e -> let e' = fs e in if e==e' then impl else Struct e' |Algebraic a -> let a' = fa a in if a==a' then impl else Algebraic a' |Abstract|FullStruct -> impl let implem_iter fs fa impl = match impl with |Struct e -> fs e |Algebraic a -> fa a |Abstract|FullStruct -> () (** {6 Substitutions of modular structures } *) let id_delta x y = x let subst_with_body sub = function |WithMod(id,mp) as orig -> let mp' = subst_mp sub mp in if mp==mp' then orig else WithMod(id,mp') |WithDef(id,(c,ctx)) as orig -> let c' = subst_mps sub c in if c==c' then orig else WithDef(id,(c',ctx)) let rec subst_structure sub do_delta sign = let subst_body ((l,body) as orig) = match body with |SFBconst cb -> let cb' = subst_const_body sub cb in if cb==cb' then orig else (l,SFBconst cb') |SFBmind mib -> let mib' = subst_mind_body sub mib in if mib==mib' then orig else (l,SFBmind mib') |SFBmodule mb -> let mb' = subst_module sub do_delta mb in if mb==mb' then orig else (l,SFBmodule mb') |SFBmodtype mtb -> let mtb' = subst_modtype sub do_delta mtb in if mtb==mtb' then orig else (l,SFBmodtype mtb') in List.smartmap subst_body sign and subst_body is_mod sub do_delta mb = let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty } = mb in let mp' = subst_mp sub mp in let sub = if ModPath.equal mp mp' then sub else if is_mod && not (is_functor ty) then sub else add_mp mp mp' empty_delta_resolver sub in let ty' = subst_signature sub do_delta ty in let me' = implem_smartmap (subst_signature sub id_delta) (subst_expression sub id_delta) me in let aty' = Option.smartmap (subst_expression sub id_delta) aty in let delta' = do_delta mb.mod_delta sub in if mp==mp' && me==me' && ty==ty' && aty==aty' && delta'==mb.mod_delta then mb else { mb with mod_mp = mp'; mod_expr = me'; mod_type = ty'; mod_type_alg = aty'; mod_delta = delta' } and subst_module sub do_delta mb = subst_body true sub do_delta mb and subst_modtype sub do_delta mtb = subst_body false sub do_delta mtb and subst_expr sub do_delta seb = match seb with |MEident mp -> let mp' = subst_mp sub mp in if mp==mp' then seb else MEident mp' |MEapply (meb1,mp2) -> let meb1' = subst_expr sub do_delta meb1 in let mp2' = subst_mp sub mp2 in if meb1==meb1' && mp2==mp2' then seb else MEapply(meb1',mp2') |MEwith (meb,wdb) -> let meb' = subst_expr sub do_delta meb in let wdb' = subst_with_body sub wdb in if meb==meb' && wdb==wdb' then seb else MEwith(meb',wdb') and subst_expression sub do_delta = functor_smartmap (subst_modtype sub do_delta) (subst_expr sub do_delta) and subst_signature sub do_delta = functor_smartmap (subst_modtype sub do_delta) (subst_structure sub do_delta) let do_delta_dom reso sub = subst_dom_delta_resolver sub reso let do_delta_codom reso sub = subst_codom_delta_resolver sub reso let do_delta_dom_codom reso sub = subst_dom_codom_delta_resolver sub reso let subst_signature subst = subst_signature subst do_delta_codom let subst_structure subst = subst_structure subst do_delta_codom (** {6 Retroknowledge } *) (* spiwack: here comes the function which takes care of importing the retroknowledge declared in the library *) (* lclrk : retroknowledge_action list, rkaction : retroknowledge action *) let add_retroknowledge mp = let perform rkaction env = match rkaction with |Retroknowledge.RKRegister (f, e) when (isConst e || isInd e) -> Environ.register env f e |_ -> CErrors.anomaly ~label:"Modops.add_retroknowledge" (Pp.str "had to import an unsupported kind of term") in fun lclrk env -> (* The order of the declaration matters, for instance (and it's at the time this comment is being written, the only relevent instance) the int31 type registration absolutely needs int31 bits to be registered. Since the local_retroknowledge is stored in reverse order (each new registration is added at the top of the list) we need a fold_right for things to go right (the pun is not intented). So we lose tail recursivity, but the world will have exploded before any module imports 10 000 retroknowledge registration.*) List.fold_right perform lclrk env (** {6 Adding a module in the environment } *) let rec add_structure mp sign resolver linkinfo env = let add_one env (l,elem) = match elem with |SFBconst cb -> let c = constant_of_delta_kn resolver (KerName.make2 mp l) in Environ.add_constant_key c cb linkinfo env |SFBmind mib -> let mind = mind_of_delta_kn resolver (KerName.make2 mp l) in let mib = if mib.mind_private != None then { mib with mind_private = Some true } else mib in Environ.add_mind_key mind (mib,ref linkinfo) env |SFBmodule mb -> add_module mb linkinfo env (* adds components as well *) |SFBmodtype mtb -> Environ.add_modtype mtb env in List.fold_left add_one env sign and add_module mb linkinfo env = let mp = mb.mod_mp in let env = Environ.shallow_add_module mb env in match mb.mod_type with |NoFunctor struc -> add_retroknowledge mp mb.mod_retroknowledge (add_structure mp struc mb.mod_delta linkinfo env) |MoreFunctor _ -> env let add_linked_module mb linkinfo env = add_module mb linkinfo env let add_structure mp sign resolver env = add_structure mp sign resolver no_link_info env let add_module mb env = add_module mb no_link_info env let add_module_type mp mtb env = add_module (module_body_of_type mp mtb) env (** {6 Strengtening } *) let strengthen_const mp_from l cb resolver = match cb.const_body with |Def _ -> cb |_ -> let kn = KerName.make2 mp_from l in let con = constant_of_delta_kn resolver kn in let u = if cb.const_polymorphic then let u = Univ.UContext.instance cb.const_universes in let s = Univ.make_instance_subst u in Univ.subst_univs_level_instance s u else Univ.Instance.empty in { cb with const_body = Def (Mod_subst.from_val (mkConstU (con,u))); const_body_code = Some (Cemitcodes.from_val (Cbytegen.compile_alias con)) } let rec strengthen_mod mp_from mp_to mb = if mp_in_delta mb.mod_mp mb.mod_delta then mb else match mb.mod_type with |NoFunctor struc -> let reso,struc' = strengthen_sig mp_from struc mp_to mb.mod_delta in { mb with mod_expr = Algebraic (NoFunctor (MEident mp_to)); mod_type = NoFunctor struc'; mod_delta = add_mp_delta_resolver mp_from mp_to (add_delta_resolver mb.mod_delta reso) } |MoreFunctor _ -> mb and strengthen_sig mp_from struc mp_to reso = match struc with |[] -> empty_delta_resolver,[] |(l,SFBconst cb) :: rest -> let item' = l,SFBconst (strengthen_const mp_from l cb reso) in let reso',rest' = strengthen_sig mp_from rest mp_to reso in reso',item'::rest' |(_,SFBmind _ as item):: rest -> let reso',rest' = strengthen_sig mp_from rest mp_to reso in reso',item::rest' |(l,SFBmodule mb) :: rest -> let mp_from' = MPdot (mp_from,l) in let mp_to' = MPdot(mp_to,l) in let mb' = strengthen_mod mp_from' mp_to' mb in let item' = l,SFBmodule mb' in let reso',rest' = strengthen_sig mp_from rest mp_to reso in add_delta_resolver reso' mb.mod_delta, item':: rest' |(l,SFBmodtype mty as item) :: rest -> let reso',rest' = strengthen_sig mp_from rest mp_to reso in reso',item::rest' let strengthen mtb mp = (* Has mtb already been strengthened ? *) if mp_in_delta mtb.mod_mp mtb.mod_delta then mtb else match mtb.mod_type with |NoFunctor struc -> let reso',struc' = strengthen_sig mtb.mod_mp struc mp mtb.mod_delta in { mtb with mod_type = NoFunctor struc'; mod_delta = add_delta_resolver mtb.mod_delta (add_mp_delta_resolver mtb.mod_mp mp reso') } |MoreFunctor _ -> mtb let inline_delta_resolver env inl mp mbid mtb delta = let constants = inline_of_delta inl mtb.mod_delta in let rec make_inline delta = function | [] -> delta | (lev,kn)::r -> let kn = replace_mp_in_kn (MPbound mbid) mp kn in let con = constant_of_delta_kn delta kn in try let constant = lookup_constant con env in let l = make_inline delta r in match constant.const_body with | Undef _ | OpaqueDef _ -> l | Def body -> let constr = Mod_subst.force_constr body in add_inline_delta_resolver kn (lev, Some constr) l with Not_found -> error_no_such_label_sub (con_label con) (string_of_mp (con_modpath con)) in make_inline delta constants let rec strengthen_and_subst_mod mb subst mp_from mp_to = match mb.mod_type with |NoFunctor struc -> let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in if mb_is_an_alias then subst_module subst do_delta_dom mb else let reso',struc' = strengthen_and_subst_struct struc subst mp_from mp_to false false mb.mod_delta in { mb with mod_mp = mp_to; mod_expr = Algebraic (NoFunctor (MEident mp_from)); mod_type = NoFunctor struc'; mod_delta = add_mp_delta_resolver mp_to mp_from reso' } |MoreFunctor _ -> let subst = add_mp mb.mod_mp mp_to empty_delta_resolver subst in subst_module subst do_delta_dom mb and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso = match str with | [] -> empty_delta_resolver,[] | (l,SFBconst cb) as item :: rest -> let cb' = subst_const_body subst cb in let cb' = if alias then cb' else strengthen_const mp_from l cb' reso in let item' = if cb' == cb then item else (l, SFBconst cb') in let reso',rest' = strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in let str' = if rest' == rest && item' == item then str else item' :: rest' in if incl then (* If we are performing an inclusion we need to add the fact that the constant mp_to.l is \Delta-equivalent to reso(mp_from.l) *) let kn_from = KerName.make2 mp_from l in let kn_to = KerName.make2 mp_to l in let old_name = kn_of_delta reso kn_from in add_kn_delta_resolver kn_to old_name reso', str' else (* In this case the fact that the constant mp_to.l is \Delta-equivalent to resolver(mp_from.l) is already known because reso' contains mp_to maps to reso(mp_from) *) reso', str' | (l,SFBmind mib) as item :: rest -> let mib' = subst_mind_body subst mib in let item' = if mib' == mib then item else (l, SFBmind mib') in let reso',rest' = strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in let str' = if rest' == rest && item' == item then str else item' :: rest' in (* Same as constant *) if incl then let kn_from = KerName.make2 mp_from l in let kn_to = KerName.make2 mp_to l in let old_name = kn_of_delta reso kn_from in add_kn_delta_resolver kn_to old_name reso', str' else reso', str' | (l,SFBmodule mb) as item :: rest -> let mp_from' = MPdot (mp_from,l) in let mp_to' = MPdot (mp_to,l) in let mb' = if alias then subst_module subst do_delta_dom mb else strengthen_and_subst_mod mb subst mp_from' mp_to' in let item' = if mb' == mb then item else (l, SFBmodule mb') in let reso',rest' = strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in let str' = if rest' == rest && item' == item then str else item' :: rest' in (* if mb is a functor we should not derive new equivalences on names, hence we add the fact that the functor can only be equivalent to itself. If we adopt an applicative semantic for functor this should be changed.*) if is_functor mb'.mod_type then add_mp_delta_resolver mp_to' mp_to' reso', str' else add_delta_resolver reso' mb'.mod_delta, str' | (l,SFBmodtype mty) as item :: rest -> let mp_from' = MPdot (mp_from,l) in let mp_to' = MPdot(mp_to,l) in let subst' = add_mp mp_from' mp_to' empty_delta_resolver subst in let mty' = subst_modtype subst' (fun resolver _ -> subst_dom_codom_delta_resolver subst' resolver) mty in let item' = if mty' == mty then item else (l, SFBmodtype mty') in let reso',rest' = strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in let str' = if rest' == rest && item' == item then str else item' :: rest' in add_mp_delta_resolver mp_to' mp_to' reso', str' (** Let P be a module path when we write: "Module M:=P." or "Module M. Include P. End M." We need to perform two operations to compute the body of M. - The first one is applying the substitution {P <- M} on the type of P - The second one is strenghtening. *) let strengthen_and_subst_mb mb mp include_b = match mb.mod_type with |NoFunctor struc -> let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in (* if mb.mod_mp is an alias then the strengthening is useless (i.e. it is already done)*) let mp_alias = mp_of_delta mb.mod_delta mb.mod_mp in let subst_resolver = map_mp mb.mod_mp mp empty_delta_resolver in let new_resolver = add_mp_delta_resolver mp mp_alias (subst_dom_delta_resolver subst_resolver mb.mod_delta) in let subst = map_mp mb.mod_mp mp new_resolver in let reso',struc' = strengthen_and_subst_struct struc subst mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta in { mb with mod_mp = mp; mod_type = NoFunctor struc'; mod_expr = Algebraic (NoFunctor (MEident mb.mod_mp)); mod_delta = if include_b then reso' else add_delta_resolver new_resolver reso' } |MoreFunctor _ -> let subst = map_mp mb.mod_mp mp empty_delta_resolver in subst_module subst do_delta_dom_codom mb let subst_modtype_and_resolver mtb mp = let subst = map_mp mtb.mod_mp mp empty_delta_resolver in let new_delta = subst_dom_codom_delta_resolver subst mtb.mod_delta in let full_subst = map_mp mtb.mod_mp mp new_delta in subst_modtype full_subst do_delta_dom_codom mtb (** {6 Cleaning a module expression from bounded parts } For instance: functor(X:T)->struct module M:=X end) becomes: functor(X:T)->struct module M:= end) *) let rec is_bounded_expr l = function | MEident (MPbound mbid) -> MBIset.mem mbid l | MEapply (fexpr,mp) -> is_bounded_expr l (MEident mp) || is_bounded_expr l fexpr | _ -> false let rec clean_module l mb = let impl, typ = mb.mod_expr, mb.mod_type in let typ' = clean_signature l typ in let impl' = match impl with | Algebraic (NoFunctor m) when is_bounded_expr l m -> FullStruct | _ -> implem_smartmap (clean_signature l) (clean_expression l) impl in if typ==typ' && impl==impl' then mb else { mb with mod_type=typ'; mod_expr=impl' } and clean_field l field = match field with |(lab,SFBmodule mb) -> let mb' = clean_module l mb in if mb==mb' then field else (lab,SFBmodule mb') |_ -> field and clean_structure l = List.smartmap (clean_field l) and clean_signature l = functor_smartmap (clean_module l) (clean_structure l) and clean_expression l = functor_smartmap (clean_module l) (fun me -> me) let rec collect_mbid l sign = match sign with |MoreFunctor (mbid,ty,m) -> let m' = collect_mbid (MBIset.add mbid l) m in if m==m' then sign else MoreFunctor (mbid,ty,m') |NoFunctor struc -> let struc' = clean_structure l struc in if struc==struc' then sign else NoFunctor struc' let clean_bounded_mod_expr sign = if is_functor sign then collect_mbid MBIset.empty sign else sign (** {6 Stm machinery } *) let join_constant_body except otab cb = match cb.const_body with | OpaqueDef o -> (match Opaqueproof.uuid_opaque otab o with | Some uuid when not(Future.UUIDSet.mem uuid except) -> Opaqueproof.join_opaque otab o | _ -> ()) | _ -> () let join_structure except otab s = let rec join_module mb = implem_iter join_signature join_expression mb.mod_expr; Option.iter join_expression mb.mod_type_alg; join_signature mb.mod_type and join_field (l,body) = match body with |SFBconst sb -> join_constant_body except otab sb |SFBmind _ -> () |SFBmodule m |SFBmodtype m -> join_module m and join_structure struc = List.iter join_field struc and join_signature sign = functor_iter join_module join_structure sign and join_expression me = functor_iter join_module (fun _ -> ()) me in join_structure s coq-8.6/kernel/sorts.ml0000644000175000017500000000511513022274260014445 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* u | Prop Pos -> Universe.type0 | Prop Null -> Universe.type0m let sort_of_univ u = if is_type0m_univ u then prop else if is_type0_univ u then set else Type u let compare s1 s2 = if s1 == s2 then 0 else match s1, s2 with | Prop c1, Prop c2 -> begin match c1, c2 with | Pos, Pos | Null, Null -> 0 | Pos, Null -> -1 | Null, Pos -> 1 end | Type u1, Type u2 -> Universe.compare u1 u2 | Prop _, Type _ -> -1 | Type _, Prop _ -> 1 let equal s1 s2 = Int.equal (compare s1 s2) 0 let is_prop = function | Prop Null -> true | Type u when Universe.equal Universe.type0m u -> true | _ -> false let is_set = function | Prop Pos -> true | Type u when Universe.equal Universe.type0 u -> true | _ -> false let is_small = function | Prop _ -> true | Type u -> is_small_univ u let family = function | Prop Null -> InProp | Prop Pos -> InSet | Type u when is_type0m_univ u -> InProp | Type u when is_type0_univ u -> InSet | Type _ -> InType let family_equal = (==) open Hashset.Combine let hash = function | Prop p -> let h = match p with | Pos -> 0 | Null -> 1 in combinesmall 1 h | Type u -> let h = Univ.Universe.hash u in combinesmall 2 h module List = struct let mem = List.memq let intersect l l' = CList.intersect family_equal l l' end module Hsorts = Hashcons.Make( struct type _t = t type t = _t type u = universe -> universe let hashcons huniv = function | Type u as c -> let u' = huniv u in if u' == u then c else Type u' | s -> s let eq s1 s2 = match (s1,s2) with | (Prop c1, Prop c2) -> c1 == c2 | (Type u1, Type u2) -> u1 == u2 |_ -> false let hash = hash end) let hcons = Hashcons.simple_hcons Hsorts.generate Hsorts.hcons hcons_univ coq-8.6/kernel/esubst.ml0000644000175000017500000001322713022274260014603 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* n *) (* i.e under n binders *) let el_id = ELID (* compose a relocation of magnitude n *) let rec el_shft_rec n = function | ELSHFT(el,k) -> el_shft_rec (k+n) el | el -> ELSHFT(el,n) let el_shft n el = if Int.equal n 0 then el else el_shft_rec n el (* cross n binders *) let rec el_liftn_rec n = function | ELID -> ELID | ELLFT(k,el) -> el_liftn_rec (n+k) el | el -> ELLFT(n, el) let el_liftn n el = if Int.equal n 0 then el else el_liftn_rec n el let el_lift el = el_liftn_rec 1 el (* relocation of de Bruijn n in an explicit lift *) let rec reloc_rel n = function | ELID -> n | ELLFT(k,el) -> if n <= k then n else (reloc_rel (n-k) el) + k | ELSHFT(el,k) -> (reloc_rel (n+k) el) let rec is_lift_id = function | ELID -> true | ELSHFT(e,n) -> Int.equal n 0 && is_lift_id e | ELLFT (_,e) -> is_lift_id e (*********************) (* Substitutions *) (*********************) (* (bounded) explicit substitutions of type 'a *) type 'a subs = | ESID of int (* ESID(n) = %n END bounded identity *) | CONS of 'a array * 'a subs (* CONS([|t1..tn|],S) = (S.t1...tn) parallel substitution beware of the order *) | SHIFT of int * 'a subs (* SHIFT(n,S) = (^n o S) terms in S are relocated *) (* with n vars *) | LIFT of int * 'a subs (* LIFT(n,S) = (%n S) stands for ((^n o S).n...1) *) (* operations of subs: collapses constructors when possible. * Needn't be recursive if we always use these functions *) let subs_id i = ESID i let subs_cons(x,s) = if Int.equal (Array.length x) 0 then s else CONS(x,s) let subs_liftn n = function | ESID p -> ESID (p+n) (* bounded identity lifted extends by p *) | LIFT (p,lenv) -> LIFT (p+n, lenv) | lenv -> LIFT (n,lenv) let subs_lift a = subs_liftn 1 a let subs_liftn n a = if Int.equal n 0 then a else subs_liftn n a let subs_shft = function | (0, s) -> s | (n, SHIFT (k,s1)) -> SHIFT (k+n, s1) | (n, s) -> SHIFT (n,s) let subs_shft s = if Int.equal (fst s) 0 then snd s else subs_shft s let subs_shift_cons = function (0, s, t) -> CONS(t,s) | (k, SHIFT(n,s1), t) -> CONS(t,SHIFT(k+n, s1)) | (k, s, t) -> CONS(t,SHIFT(k, s));; (* Tests whether a substitution is equal to the identity *) let rec is_subs_id = function ESID _ -> true | LIFT(_,s) -> is_subs_id s | SHIFT(0,s) -> is_subs_id s | CONS(x,s) -> Int.equal (Array.length x) 0 && is_subs_id s | _ -> false (* Expands de Bruijn k in the explicit substitution subs * lams accumulates de shifts to perform when retrieving the i-th value * the rules used are the following: * * [id]k --> k * [S.t]1 --> t * [S.t]k --> [S](k-1) if k > 1 * [^n o S] k --> [^n]([S]k) * [(%n S)] k --> k if k <= n * [(%n S)] k --> [^n]([S](k-n)) * * the result is (Inr (k+lams,p)) when the variable is just relocated * where p is None if the variable points inside subs and Some(k) if the * variable points k bindings beyond subs. *) let rec exp_rel lams k subs = match subs with | CONS (def,_) when k <= Array.length def -> Inl(lams,def.(Array.length def - k)) | CONS (v,l) -> exp_rel lams (k - Array.length v) l | LIFT (n,_) when k<=n -> Inr(lams+k,None) | LIFT (n,l) -> exp_rel (n+lams) (k-n) l | SHIFT (n,s) -> exp_rel (n+lams) k s | ESID n when k<=n -> Inr(lams+k,None) | ESID n -> Inr(lams+k,Some (k-n)) let expand_rel k subs = exp_rel 0 k subs let rec comp mk_cl s1 s2 = match (s1, s2) with | _, ESID _ -> s1 | ESID _, _ -> s2 | SHIFT(k,s), _ -> subs_shft(k, comp mk_cl s s2) | _, CONS(x,s') -> CONS(CArray.Fun1.map (fun s t -> mk_cl(s,t)) s1 x, comp mk_cl s1 s') | CONS(x,s), SHIFT(k,s') -> let lg = Array.length x in if k == lg then comp mk_cl s s' else if k > lg then comp mk_cl s (SHIFT(k-lg, s')) else comp mk_cl (CONS(Array.sub x 0 (lg-k), s)) s' | CONS(x,s), LIFT(k,s') -> let lg = Array.length x in if k == lg then CONS(x, comp mk_cl s s') else if k > lg then CONS(x, comp mk_cl s (LIFT(k-lg, s'))) else CONS(Array.sub x (lg-k) k, comp mk_cl (CONS(Array.sub x 0 (lg-k),s)) s') | LIFT(k,s), SHIFT(k',s') -> if k if k= ci_cstr_nargs.(i) *) type case_info = { ci_ind : inductive; (* inductive type to which belongs the value that is being matched *) ci_npar : int; (* number of parameters of the above inductive type *) ci_cstr_ndecls : int array; (* For each constructor, the corresponding integer determines the number of values that can be bound in a match-construct. NOTE: parameters of the inductive type are therefore excluded from the count *) ci_cstr_nargs : int array; (* for each constructor, the corresponding integers determines the number of values that can be applied to the constructor, in addition to the parameters of the related inductive type NOTE: "lets" are therefore excluded from the count NOTE: parameters of the inductive type are also excluded from the count *) ci_pp_info : case_printing (* not interpreted by the kernel *) } (********************************************************************) (* Constructions as implemented *) (********************************************************************) (* [constr array] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) type 'constr pexistential = existential_key * 'constr array type ('constr, 'types) prec_declaration = Name.t array * 'types array * 'constr array type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration type ('constr, 'types) pcofixpoint = int * ('constr, 'types) prec_declaration type 'a puniverses = 'a Univ.puniverses type pconstant = constant puniverses type pinductive = inductive puniverses type pconstructor = constructor puniverses (* [Var] is used for named variables and [Rel] for variables as de Bruijn indices. *) type ('constr, 'types) kind_of_term = | Rel of int | Var of Id.t | Meta of metavariable | Evar of 'constr pexistential | Sort of Sorts.t | Cast of 'constr * cast_kind * 'types | Prod of Name.t * 'types * 'types | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array | Const of pconstant | Ind of pinductive | Construct of pconstructor | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of projection * 'constr (* constr is the fixpoint of the previous type. Requires option -rectypes of the Caml compiler to be set *) type t = (t,t) kind_of_term type constr = t type existential = existential_key * constr array type rec_declaration = Name.t array * constr array * constr array type fixpoint = (int array * int) * rec_declaration type cofixpoint = int * rec_declaration type types = constr (*********************) (* Term constructors *) (*********************) (* Constructs a DeBrujin index with number n *) let rels = [|Rel 1;Rel 2;Rel 3;Rel 4;Rel 5;Rel 6;Rel 7; Rel 8; Rel 9;Rel 10;Rel 11;Rel 12;Rel 13;Rel 14;Rel 15; Rel 16|] let mkRel n = if 0 mkProp (* Easy sharing *) | Sorts.Prop Sorts.Pos -> mkSet | s -> Sort s (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *) (* (that means t2 is declared as the type of t1) *) let mkCast (t1,k2,t2) = match t1 with | Cast (c,k1, _) when (k1 == VMcast || k1 == NATIVEcast) && k1 == k2 -> Cast (c,k1,t2) | _ -> Cast (t1,k2,t2) (* Constructs the product (x:t1)t2 *) let mkProd (x,t1,t2) = Prod (x,t1,t2) (* Constructs the abstraction [x:t1]t2 *) let mkLambda (x,t1,t2) = Lambda (x,t1,t2) (* Constructs [x=c_1:t]c_2 *) let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2) (* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *) (* We ensure applicative terms have at least one argument and the function is not itself an applicative term *) let mkApp (f, a) = if Int.equal (Array.length a) 0 then f else match f with | App (g, cl) -> App (g, Array.append cl a) | _ -> App (f, a) let map_puniverses f (x,u) = (f x, u) let in_punivs a = (a, Univ.Instance.empty) (* Constructs a constant *) let mkConst c = Const (in_punivs c) let mkConstU c = Const c (* Constructs an applied projection *) let mkProj (p,c) = Proj (p,c) (* Constructs an existential variable *) let mkEvar e = Evar e (* Constructs the ith (co)inductive type of the block named kn *) let mkInd m = Ind (in_punivs m) let mkIndU m = Ind m (* Constructs the jth constructor of the ith (co)inductive type of the block named kn. *) let mkConstruct c = Construct (in_punivs c) let mkConstructU c = Construct c let mkConstructUi ((ind,u),i) = Construct ((ind,i),u) (* Constructs the term

Case c of c1 | c2 .. | cn end *) let mkCase (ci, p, c, ac) = Case (ci, p, c, ac) (* If recindxs = [|i1,...in|] funnames = [|f1,...fn|] typarray = [|t1,...tn|] bodies = [|b1,...bn|] then mkFix ((recindxs,i),(funnames,typarray,bodies)) constructs the ith function of the block Fixpoint f1 [ctx1] : t1 := b1 with f2 [ctx2] : t2 := b2 ... with fn [ctxn] : tn := bn. where the length of the jth context is ij. *) let mkFix fix = Fix fix (* If funnames = [|f1,...fn|] typarray = [|t1,...tn|] bodies = [|b1,...bn|] then mkCoFix (i,(funnames,typsarray,bodies)) constructs the ith function of the block CoFixpoint f1 : t1 := b1 with f2 : t2 := b2 ... with fn : tn := bn. *) let mkCoFix cofix= CoFix cofix (* Constructs an existential variable named "?n" *) let mkMeta n = Meta n (* Constructs a Variable named id *) let mkVar id = Var id (************************************************************************) (* kind_of_term = constructions as seen by the user *) (************************************************************************) (* User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative term *) let kind c = c (****************************************************************************) (* Functions to recur through subterms *) (****************************************************************************) (* [fold f acc c] folds [f] on the immediate subterms of [c] starting from [acc] and proceeding from left to right according to the usual representation of the constructions; it is not recursive *) let fold f acc c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> acc | Cast (c,_,t) -> f (f acc c) t | Prod (_,t,c) -> f (f acc t) c | Lambda (_,t,c) -> f (f acc t) c | LetIn (_,b,t,c) -> f (f (f acc b) t) c | App (c,l) -> Array.fold_left f (f acc c) l | Proj (p,c) -> f acc c | Evar (_,l) -> Array.fold_left f acc l | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl | Fix (_,(lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl | CoFix (_,(lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl (* [iter f c] iters [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) let iter f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () | Cast (c,_,t) -> f c; f t | Prod (_,t,c) -> f t; f c | Lambda (_,t,c) -> f t; f c | LetIn (_,b,t,c) -> f b; f t; f c | App (c,l) -> f c; Array.iter f l | Proj (p,c) -> f c | Evar (_,l) -> Array.iter f l | Case (_,p,c,bl) -> f p; f c; Array.iter f bl | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl (* [iter_with_binders g f n c] iters [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) let iter_with_binders g f n c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () | Cast (c,_,t) -> f n c; f n t | Prod (_,t,c) -> f n t; f (g n) c | Lambda (_,t,c) -> f n t; f (g n) c | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c | App (c,l) -> f n c; CArray.Fun1.iter f n l | Evar (_,l) -> CArray.Fun1.iter f n l | Case (_,p,c,bl) -> f n p; f n c; CArray.Fun1.iter f n bl | Proj (p,c) -> f n c | Fix (_,(_,tl,bl)) -> CArray.Fun1.iter f n tl; CArray.Fun1.iter f (iterate g (Array.length tl) n) bl | CoFix (_,(_,tl,bl)) -> CArray.Fun1.iter f n tl; CArray.Fun1.iter f (iterate g (Array.length tl) n) bl (* [map f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) let map f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c | Cast (b,k,t) -> let b' = f b in let t' = f t in if b'==b && t' == t then c else mkCast (b', k, t') | Prod (na,t,b) -> let b' = f b in let t' = f t in if b'==b && t' == t then c else mkProd (na, t', b') | Lambda (na,t,b) -> let b' = f b in let t' = f t in if b'==b && t' == t then c else mkLambda (na, t', b') | LetIn (na,b,t,k) -> let b' = f b in let t' = f t in let k' = f k in if b'==b && t' == t && k'==k then c else mkLetIn (na, b', t', k') | App (b,l) -> let b' = f b in let l' = Array.smartmap f l in if b'==b && l'==l then c else mkApp (b', l') | Proj (p,t) -> let t' = f t in if t' == t then c else mkProj (p, t') | Evar (e,l) -> let l' = Array.smartmap f l in if l'==l then c else mkEvar (e, l') | Case (ci,p,b,bl) -> let b' = f b in let p' = f p in let bl' = Array.smartmap f bl in if b'==b && p'==p && bl'==bl then c else mkCase (ci, p', b', bl') | Fix (ln,(lna,tl,bl)) -> let tl' = Array.smartmap f tl in let bl' = Array.smartmap f bl in if tl'==tl && bl'==bl then c else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> let tl' = Array.smartmap f tl in let bl' = Array.smartmap f bl in if tl'==tl && bl'==bl then c else mkCoFix (ln,(lna,tl',bl')) (* Like {!map} but with an accumulator. *) let fold_map f accu c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> accu, c | Cast (b,k,t) -> let accu, b' = f accu b in let accu, t' = f accu t in if b'==b && t' == t then accu, c else accu, mkCast (b', k, t') | Prod (na,t,b) -> let accu, b' = f accu b in let accu, t' = f accu t in if b'==b && t' == t then accu, c else accu, mkProd (na, t', b') | Lambda (na,t,b) -> let accu, b' = f accu b in let accu, t' = f accu t in if b'==b && t' == t then accu, c else accu, mkLambda (na, t', b') | LetIn (na,b,t,k) -> let accu, b' = f accu b in let accu, t' = f accu t in let accu, k' = f accu k in if b'==b && t' == t && k'==k then accu, c else accu, mkLetIn (na, b', t', k') | App (b,l) -> let accu, b' = f accu b in let accu, l' = Array.smartfoldmap f accu l in if b'==b && l'==l then accu, c else accu, mkApp (b', l') | Proj (p,t) -> let accu, t' = f accu t in if t' == t then accu, c else accu, mkProj (p, t') | Evar (e,l) -> let accu, l' = Array.smartfoldmap f accu l in if l'==l then accu, c else accu, mkEvar (e, l') | Case (ci,p,b,bl) -> let accu, b' = f accu b in let accu, p' = f accu p in let accu, bl' = Array.smartfoldmap f accu bl in if b'==b && p'==p && bl'==bl then accu, c else accu, mkCase (ci, p', b', bl') | Fix (ln,(lna,tl,bl)) -> let accu, tl' = Array.smartfoldmap f accu tl in let accu, bl' = Array.smartfoldmap f accu bl in if tl'==tl && bl'==bl then accu, c else accu, mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> let accu, tl' = Array.smartfoldmap f accu tl in let accu, bl' = Array.smartfoldmap f accu bl in if tl'==tl && bl'==bl then accu, c else accu, mkCoFix (ln,(lna,tl',bl')) (* [map_with_binders g f n c] maps [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) let map_with_binders g f l c0 = match kind c0 with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c0 | Cast (c, k, t) -> let c' = f l c in let t' = f l t in if c' == c && t' == t then c0 else mkCast (c', k, t') | Prod (na, t, c) -> let t' = f l t in let c' = f (g l) c in if t' == t && c' == c then c0 else mkProd (na, t', c') | Lambda (na, t, c) -> let t' = f l t in let c' = f (g l) c in if t' == t && c' == c then c0 else mkLambda (na, t', c') | LetIn (na, b, t, c) -> let b' = f l b in let t' = f l t in let c' = f (g l) c in if b' == b && t' == t && c' == c then c0 else mkLetIn (na, b', t', c') | App (c, al) -> let c' = f l c in let al' = CArray.Fun1.smartmap f l al in if c' == c && al' == al then c0 else mkApp (c', al') | Proj (p, t) -> let t' = f l t in if t' == t then c0 else mkProj (p, t') | Evar (e, al) -> let al' = CArray.Fun1.smartmap f l al in if al' == al then c0 else mkEvar (e, al') | Case (ci, p, c, bl) -> let p' = f l p in let c' = f l c in let bl' = CArray.Fun1.smartmap f l bl in if p' == p && c' == c && bl' == bl then c0 else mkCase (ci, p', c', bl') | Fix (ln, (lna, tl, bl)) -> let tl' = CArray.Fun1.smartmap f l tl in let l' = iterate g (Array.length tl) l in let bl' = CArray.Fun1.smartmap f l' bl in if tl' == tl && bl' == bl then c0 else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> let tl' = CArray.Fun1.smartmap f l tl in let l' = iterate g (Array.length tl) l in let bl' = CArray.Fun1.smartmap f l' bl in mkCoFix (ln,(lna,tl',bl')) (* [compare_head_gen_evar k1 k2 u s e eq leq c1 c2] compare [c1] and [c2] (using [k1] to expose the structure of [c1] and [k2] to expose the structure [c2]) using [eq] to compare the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, [u] to compare universe instances, and [s] to compare sorts; Cast's, application associativity, binders name and Cases annotations are not taken into account. Note that as [kind1] and [kind2] are potentially different, we cannot use, in recursive case, the optimisation that physically equal arrays are equals (hence the calls to {!Array.equal_norefl}). *) let compare_head_gen_leq_with kind1 kind2 eq_universes leq_sorts eq leq t1 t2 = match kind1 t1, kind2 t2 with | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 | Var id1, Var id2 -> Id.equal id1 id2 | Sort s1, Sort s2 -> leq_sorts s1 s2 | Cast (c1,_,_), _ -> leq c1 t2 | _, Cast (c2,_,_) -> leq t1 c2 | Prod (_,t1,c1), Prod (_,t2,c2) -> eq t1 t2 && leq c1 c2 | Lambda (_,t1,c1), Lambda (_,t2,c2) -> eq t1 t2 && eq c1 c2 | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> eq b1 b2 && eq t1 t2 && leq c1 c2 | App (Cast(c1, _, _),l1), _ -> leq (mkApp (c1,l1)) t2 | _, App (Cast (c2, _, _),l2) -> leq t1 (mkApp (c2,l2)) | App (c1,l1), App (c2,l2) -> Int.equal (Array.length l1) (Array.length l2) && eq c1 c2 && Array.equal_norefl eq l1 l2 | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq c1 c2 | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal eq l1 l2 | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2 | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && eq_universes false u1 u2 | Construct (c1,u1), Construct (c2,u2) -> eq_constructor c1 c2 && eq_universes false u1 u2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> eq p1 p2 && eq c1 c2 && Array.equal eq bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 && Array.equal_norefl eq tl1 tl2 && Array.equal_norefl eq bl1 bl2 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> Int.equal ln1 ln2 && Array.equal_norefl eq tl1 tl2 && Array.equal_norefl eq bl1 bl2 | _ -> false (* [compare_head_gen_leq u s eq leq c1 c2] compare [c1] and [c2] using [eq] to compare the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, [u] to compare universe instances and [s] to compare sorts; Cast's, application associativity, binders name and Cases annotations are not taken into account *) let compare_head_gen_leq eq_universes leq_sorts eq leq t1 t2 = compare_head_gen_leq_with kind kind eq_universes leq_sorts eq leq t1 t2 (* [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare the immediate subterms of [c1] of [c2] if needed, [u] to compare universe instances and [s] to compare sorts; Cast's, application associativity, binders name and Cases annotations are not taken into account. [compare_head_gen_with] is a variant taking kind-of-term functions, to expose subterms of [c1] and [c2], as arguments. *) let compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq t1 t2 = compare_head_gen_leq_with kind1 kind2 eq_universes eq_sorts eq eq t1 t2 let compare_head_gen eq_universes eq_sorts eq t1 t2 = compare_head_gen_leq eq_universes eq_sorts eq eq t1 t2 let compare_head = compare_head_gen (fun _ -> Univ.Instance.equal) Sorts.equal (*******************************) (* alpha conversion functions *) (*******************************) (* alpha conversion : ignore print names and casts *) let rec eq_constr m n = (m == n) || compare_head_gen (fun _ -> Instance.equal) Sorts.equal eq_constr m n let equal m n = eq_constr m n (* to avoid tracing a recursive fun *) let eq_constr_univs univs m n = if m == n then true else let eq_universes _ = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = s1 == s2 || UGraph.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in let rec eq_constr' m n = m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n in compare_head_gen eq_universes eq_sorts eq_constr' m n let leq_constr_univs univs m n = if m == n then true else let eq_universes _ = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = s1 == s2 || UGraph.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in let leq_sorts s1 s2 = s1 == s2 || UGraph.check_leq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in let rec eq_constr' m n = m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n in let rec compare_leq m n = compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n and leq_constr' m n = m == n || compare_leq m n in compare_leq m n let eq_constr_univs_infer univs m n = if m == n then true, Constraint.empty else let cstrs = ref Constraint.empty in let eq_universes strict = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in if UGraph.check_eq univs u1 u2 then true else (cstrs := Univ.enforce_eq u1 u2 !cstrs; true) in let rec eq_constr' m n = m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n in let res = compare_head_gen eq_universes eq_sorts eq_constr' m n in res, !cstrs let leq_constr_univs_infer univs m n = if m == n then true, Constraint.empty else let cstrs = ref Constraint.empty in let eq_universes strict l l' = UGraph.check_eq_instances univs l l' in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in if UGraph.check_eq univs u1 u2 then true else (cstrs := Univ.enforce_eq u1 u2 !cstrs; true) in let leq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in if UGraph.check_leq univs u1 u2 then true else (cstrs := Univ.enforce_leq u1 u2 !cstrs; true) in let rec eq_constr' m n = m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n in let rec compare_leq m n = compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n and leq_constr' m n = m == n || compare_leq m n in let res = compare_leq m n in res, !cstrs let always_true _ _ = true let rec eq_constr_nounivs m n = (m == n) || compare_head_gen (fun _ -> always_true) always_true eq_constr_nounivs m n (** We only use this function over blocks! *) let tag t = Obj.tag (Obj.repr t) let constr_ord_int f t1 t2 = let (=?) f g i1 i2 j1 j2= let c = f i1 i2 in if Int.equal c 0 then g j1 j2 else c in let (==?) fg h i1 i2 j1 j2 k1 k2= let c=fg i1 i2 j1 j2 in if Int.equal c 0 then h k1 k2 else c in let fix_cmp (a1, i1) (a2, i2) = ((Array.compare Int.compare) =? Int.compare) a1 a2 i1 i2 in match kind t1, kind t2 with | Rel n1, Rel n2 -> Int.compare n1 n2 | Meta m1, Meta m2 -> Int.compare m1 m2 | Var id1, Var id2 -> Id.compare id1 id2 | Sort s1, Sort s2 -> Sorts.compare s1 s2 | Cast (c1,_,_), _ -> f c1 t2 | _, Cast (c2,_,_) -> f t1 c2 | Prod (_,t1,c1), Prod (_,t2,c2) | Lambda (_,t1,c1), Lambda (_,t2,c2) -> (f =? f) t1 t2 c1 c2 | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> ((f =? f) ==? f) b1 b2 t1 t2 c1 c2 | App (Cast(c1,_,_),l1), _ -> f (mkApp (c1,l1)) t2 | _, App (Cast(c2, _,_),l2) -> f t1 (mkApp (c2,l2)) | App (c1,l1), App (c2,l2) -> (f =? (Array.compare f)) c1 c2 l1 l2 | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2 | Evar (e1,l1), Evar (e2,l2) -> (Evar.compare =? (Array.compare f)) e1 e2 l1 l2 | Const (c1,u1), Const (c2,u2) -> con_ord c1 c2 | Ind (ind1, u1), Ind (ind2, u2) -> ind_ord ind1 ind2 | Construct (ct1,u1), Construct (ct2,u2) -> constructor_ord ct1 ct2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> ((f =? f) ==? (Array.compare f)) p1 p2 c1 c2 bl1 bl2 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> ((fix_cmp =? (Array.compare f)) ==? (Array.compare f)) ln1 ln2 tl1 tl2 bl1 bl2 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> ((Int.compare =? (Array.compare f)) ==? (Array.compare f)) ln1 ln2 tl1 tl2 bl1 bl2 | t1, t2 -> Int.compare (tag t1) (tag t2) let rec compare m n= constr_ord_int compare m n (*******************) (* hash-consing *) (*******************) (* Hash-consing of [constr] does not use the module [Hashcons] because [Hashcons] is not efficient on deep tree-like data structures. Indeed, [Hashcons] is based the (very efficient) generic hash function [Hashtbl.hash], which computes the hash key through a depth bounded traversal of the data structure to be hashed. As a consequence, for a deep [constr] like the natural number 1000 (S (S (... (S O)))), the same hash is assigned to all the sub [constr]s greater than the maximal depth handled by [Hashtbl.hash]. This entails a huge number of collisions in the hash table and leads to cubic hash-consing in this worst-case. In order to compute a hash key that is independent of the data structure depth while being constant-time, an incremental hashing function must be devised. A standard implementation creates a cache of the hashing function by decorating each node of the hash-consed data structure with its hash key. In that case, the hash function can deduce the hash key of a toplevel data structure by a local computation based on the cache held on its substructures. Unfortunately, this simple implementation introduces a space overhead that is damageable for the hash-consing of small [constr]s (the most common case). One can think of an heterogeneous distribution of caches on smartly chosen nodes, but this is forbidden by the use of generic equality in Coq source code. (Indeed, this forces each [constr] to have a unique canonical representation.) Given that hash-consing proceeds inductively, we can nonetheless computes the hash key incrementally during hash-consing by changing a little the signature of the hash-consing function: it now returns both the hash-consed term and its hash key. This simple solution is implemented in the following code: it does not introduce a space overhead in [constr], that's why the efficiency is unchanged for small [constr]s. Besides, it does handle deep [constr]s without introducing an unreasonable number of collisions in the hash table. Some benchmarks make us think that this implementation of hash-consing is linear in the size of the hash-consed data structure for our daily use of Coq. *) let array_eqeq t1 t2 = t1 == t2 || (Int.equal (Array.length t1) (Array.length t2) && let rec aux i = (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) in aux 0) let hasheq t1 t2 = match t1, t2 with | Rel n1, Rel n2 -> n1 == n2 | Meta m1, Meta m2 -> m1 == m2 | Var id1, Var id2 -> id1 == id2 | Sort s1, Sort s2 -> s1 == s2 | Cast (c1,k1,t1), Cast (c2,k2,t2) -> c1 == c2 && k1 == k2 && t1 == t2 | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 && t1 == t2 && c1 == c2 | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 && t1 == t2 && c1 == c2 | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) -> n1 == n2 && b1 == b2 && t1 == t2 && c1 == c2 | App (c1,l1), App (c2,l2) -> c1 == c2 && array_eqeq l1 l2 | Proj (p1,c1), Proj(p2,c2) -> p1 == p2 && c1 == c2 | Evar (e1,l1), Evar (e2,l2) -> e1 == e2 && array_eqeq l1 l2 | Const (c1,u1), Const (c2,u2) -> c1 == c2 && u1 == u2 | Ind (ind1,u1), Ind (ind2,u2) -> ind1 == ind2 && u1 == u2 | Construct (cstr1,u1), Construct (cstr2,u2) -> cstr1 == cstr2 && u1 == u2 | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) -> ci1 == ci2 && p1 == p2 && c1 == c2 && array_eqeq bl1 bl2 | Fix ((ln1, i1),(lna1,tl1,bl1)), Fix ((ln2, i2),(lna2,tl2,bl2)) -> Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 && array_eqeq lna1 lna2 && array_eqeq tl1 tl2 && array_eqeq bl1 bl2 | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) -> Int.equal ln1 ln2 && array_eqeq lna1 lna2 && array_eqeq tl1 tl2 && array_eqeq bl1 bl2 | _ -> false (** Note that the following Make has the side effect of creating once and for all the table we'll use for hash-consing all constr *) module HashsetTerm = Hashset.Make(struct type t = constr let eq = hasheq end) module HashsetTermArray = Hashset.Make(struct type t = constr array let eq = array_eqeq end) let term_table = HashsetTerm.create 19991 (* The associative table to hashcons terms. *) let term_array_table = HashsetTermArray.create 4999 (* The associative table to hashcons term arrays. *) open Hashset.Combine let hash_cast_kind = function | VMcast -> 0 | NATIVEcast -> 1 | DEFAULTcast -> 2 | REVERTcast -> 3 let sh_instance = Univ.Instance.share (* [hashcons hash_consing_functions constr] computes an hash-consed representation for [constr] using [hash_consing_functions] on leaves. *) let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let rec hash_term t = match t with | Var i -> (Var (sh_id i), combinesmall 1 (Id.hash i)) | Sort s -> (Sort (sh_sort s), combinesmall 2 (Sorts.hash s)) | Cast (c, k, t) -> let c, hc = sh_rec c in let t, ht = sh_rec t in (Cast (c, k, t), combinesmall 3 (combine3 hc (hash_cast_kind k) ht)) | Prod (na,t,c) -> let t, ht = sh_rec t and c, hc = sh_rec c in (Prod (sh_na na, t, c), combinesmall 4 (combine3 (Name.hash na) ht hc)) | Lambda (na,t,c) -> let t, ht = sh_rec t and c, hc = sh_rec c in (Lambda (sh_na na, t, c), combinesmall 5 (combine3 (Name.hash na) ht hc)) | LetIn (na,b,t,c) -> let b, hb = sh_rec b in let t, ht = sh_rec t in let c, hc = sh_rec c in (LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (Name.hash na) hb ht hc)) | App (c,l) -> let c, hc = sh_rec c in let l, hl = hash_term_array l in (App (c,l), combinesmall 7 (combine hl hc)) | Evar (e,l) -> let l, hl = hash_term_array l in (Evar (e,l), combinesmall 8 (combine (Evar.hash e) hl)) | Proj (p,c) -> let c, hc = sh_rec c in let p' = Projection.hcons p in (Proj (p', c), combinesmall 17 (combine (Projection.SyntacticOrd.hash p') hc)) | Const (c,u) -> let c' = sh_con c in let u', hu = sh_instance u in (Const (c', u'), combinesmall 9 (combine (Constant.SyntacticOrd.hash c) hu)) | Ind (ind,u) -> let u', hu = sh_instance u in (Ind (sh_ind ind, u'), combinesmall 10 (combine (ind_syntactic_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)) | Case (ci,p,c,bl) -> let p, hp = sh_rec p and c, hc = sh_rec c in let bl,hbl = hash_term_array bl in let hbl = combine (combine hc hp) hbl in (Case (sh_ci ci, p, c, bl), combinesmall 12 hbl) | Fix (ln,(lna,tl,bl)) -> let bl,hbl = hash_term_array bl in let tl,htl = hash_term_array tl in let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in let fold accu na = combine (Name.hash na) accu in let hna = Array.fold_left fold 0 lna in let h = combine3 hna hbl htl in (Fix (ln,(lna,tl,bl)), combinesmall 13 h) | CoFix(ln,(lna,tl,bl)) -> let bl,hbl = hash_term_array bl in let tl,htl = hash_term_array tl in let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in let fold accu na = combine (Name.hash na) accu in let hna = Array.fold_left fold 0 lna in let h = combine3 hna hbl htl in (CoFix (ln,(lna,tl,bl)), combinesmall 14 h) | Meta n -> (t, combinesmall 15 n) | Rel n -> (t, combinesmall 16 n) and sh_rec t = let (y, h) = hash_term t in (* [h] must be positive. *) let h = h land 0x3FFFFFFF in (HashsetTerm.repr h y term_table, h) (* Note : During hash-cons of arrays, we modify them *in place* *) and hash_term_array t = let accu = ref 0 in for i = 0 to Array.length t - 1 do let x, h = sh_rec (Array.unsafe_get t i) in accu := combine !accu h; Array.unsafe_set t i x done; (* [h] must be positive. *) let h = !accu land 0x3FFFFFFF in (HashsetTermArray.repr h t term_array_table, h) in (* Make sure our statically allocated Rels (1 to 16) are considered as canonical, and hence hash-consed to themselves *) ignore (hash_term_array rels); fun t -> fst (sh_rec t) (* Exported hashing fonction on constr, used mainly in plugins. Appears to have slight differences from [snd (hash_term t)] above ? *) let rec hash t = match kind t with | Var i -> combinesmall 1 (Id.hash i) | Sort s -> combinesmall 2 (Sorts.hash s) | Cast (c, k, t) -> let hc = hash c in let ht = hash t in combinesmall 3 (combine3 hc (hash_cast_kind k) ht) | Prod (_, t, c) -> combinesmall 4 (combine (hash t) (hash c)) | Lambda (_, t, c) -> combinesmall 5 (combine (hash t) (hash c)) | LetIn (_, b, t, c) -> combinesmall 6 (combine3 (hash b) (hash t) (hash c)) | App (Cast(c, _, _),l) -> hash (mkApp (c,l)) | App (c,l) -> combinesmall 7 (combine (hash_term_array l) (hash c)) | Proj (p,c) -> combinesmall 17 (combine (Projection.hash p) (hash c)) | Evar (e,l) -> combinesmall 8 (combine (Evar.hash e) (hash_term_array l)) | Const (c,u) -> combinesmall 9 (combine (Constant.hash c) (Instance.hash u)) | Ind (ind,u) -> combinesmall 10 (combine (ind_hash ind) (Instance.hash u)) | Construct (c,u) -> combinesmall 11 (combine (constructor_hash c) (Instance.hash u)) | Case (_ , p, c, bl) -> combinesmall 12 (combine3 (hash c) (hash p) (hash_term_array bl)) | Fix (ln ,(_, tl, bl)) -> combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl)) | CoFix(ln, (_, tl, bl)) -> combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl)) | Meta n -> combinesmall 15 n | Rel n -> combinesmall 16 n and hash_term_array t = Array.fold_left (fun acc t -> combine (hash t) acc) 0 t module CaseinfoHash = struct type t = case_info type u = inductive -> inductive let hashcons hind ci = { ci with ci_ind = hind ci.ci_ind } let pp_info_equal info1 info2 = List.equal (==) info1.ind_tags info2.ind_tags && Array.equal (List.equal (==)) info1.cstr_tags info2.cstr_tags && info1.style == info2.style let eq ci ci' = ci.ci_ind == ci'.ci_ind && Int.equal ci.ci_npar ci'.ci_npar && Array.equal Int.equal ci.ci_cstr_ndecls ci'.ci_cstr_ndecls && (* we use [Array.equal] on purpose *) Array.equal Int.equal ci.ci_cstr_nargs ci'.ci_cstr_nargs && (* we use [Array.equal] on purpose *) pp_info_equal ci.ci_pp_info ci'.ci_pp_info (* we use (=) on purpose *) open Hashset.Combine let hash_bool b = if b then 0 else 1 let hash_bool_list = List.fold_left (fun n b -> combine n (hash_bool b)) let hash_pp_info info = let h1 = match info.style with | LetStyle -> 0 | IfStyle -> 1 | LetPatternStyle -> 2 | MatchStyle -> 3 | RegularStyle -> 4 in let h2 = hash_bool_list 0 info.ind_tags in 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 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 let h5 = hash_pp_info ci.ci_pp_info in combine5 h1 h2 h3 h4 h5 end module Hcaseinfo = Hashcons.Make(CaseinfoHash) let case_info_hash = CaseinfoHash.hash module Hsorts = Hashcons.Make( struct open Sorts type t = Sorts.t type u = universe -> universe let hashcons huniv = function Prop c -> Prop c | Type u -> Type (huniv u) let eq s1 s2 = s1 == s2 || match (s1,s2) with (Prop c1, Prop c2) -> c1 == c2 | (Type u1, Type u2) -> u1 == u2 |_ -> false let hash = function | Prop Null -> 0 | Prop Pos -> 1 | Type u -> 2 + Universe.hash u end) (* let hcons_sorts = Hashcons.simple_hcons Hsorts.generate hcons_univ *) let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.generate Hcaseinfo.hcons hcons_ind let hcons = hashcons (Sorts.hcons, hcons_caseinfo, hcons_construct, hcons_ind, hcons_con, Name.hcons, Id.hcons) (* let hcons_types = hcons_constr *) (*******) (* Type of abstract machine values *) (** FIXME: nothing to do there *) type values coq-8.6/kernel/typeops.ml0000644000175000017500000004365513022274260015011 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* try conv_leq false env t1 t2 with NotConvertible -> raise (NotConvertibleVect i)) () v1 v2 let check_constraints cst env = if Environ.check_constraints cst env then () else error_unsatisfied_constraints env cst (* This should be a type (a priori without intension to be an assumption) *) let type_judgment env j = match kind_of_term(whd_all env j.uj_type) with | Sort s -> {utj_val = j.uj_val; utj_type = s } | _ -> error_not_type env j (* This should be a type intended to be assumed. The error message is *) (* not as useful as for [type_judgment]. *) let assumption_of_judgment env j = try (type_judgment env j).utj_val with TypeError _ -> error_assumption env j (************************************************) (* Incremental typing rules: builds a typing judgement given the *) (* judgements for the subterms. *) (*s Type of sorts *) (* Prop and Set *) let judge_of_prop = { uj_val = mkProp; uj_type = mkSort type1_sort } let judge_of_set = { uj_val = mkSet; uj_type = mkSort type1_sort } let judge_of_prop_contents = function | Null -> judge_of_prop | Pos -> judge_of_set (* Type of Type(i). *) let judge_of_type u = let uu = Universe.super u in { uj_val = mkType u; uj_type = mkType uu } (*s Type of a de Bruijn index. *) let judge_of_relative env n = try let typ = get_type (lookup_rel n env) in { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> error_unbound_rel env n (* Type of variables *) let judge_of_variable env id = try let ty = named_type id env in make_judge (mkVar id) ty with Not_found -> error_unbound_var env id (* Management of context of variables. *) (* Checks if a context of variables can be instantiated by the variables of the current env. Order does not have to be checked assuming that all names are distinct *) let check_hyps_inclusion env c sign = Context.Named.fold_outside (fun d1 () -> let open Context.Named.Declaration in let id = get_id d1 in try let d2 = lookup_named id env in conv env (get_type d2) (get_type d1); (match d2,d1 with | LocalAssum _, LocalAssum _ -> () | LocalAssum _, LocalDef _ -> (* This is wrong, because we don't know if the body is needed or not for typechecking: *) () | LocalDef _, LocalAssum _ -> raise NotConvertible | LocalDef (_,b2,_), LocalDef (_,b1,_) -> conv env b2 b1); with Not_found | NotConvertible | Option.Heterogeneous -> error_reference_variables env id c) sign ~init:() (* Instantiation of terms on real arguments. *) (* Make a type polymorphic if an arity *) let extract_level env p = let _,c = dest_prod_assum env p in match kind_of_term c with Sort (Type u) -> Univ.Universe.level u | _ -> None let extract_context_levels env l = let fold l = function | LocalAssum (_,p) -> extract_level env p :: l | LocalDef _ -> l in List.fold_left fold [] l let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} = let params, ccl = dest_prod_assum env t in match kind_of_term ccl with | Sort (Type u) -> let ind, l = decompose_app (whd_all env c) in if isInd ind && List.is_empty l then let mis = lookup_mind_specif env (fst (destInd ind)) in let nparams = Inductive.inductive_params mis in let paramsl = CList.lastn nparams params in let param_ccls = extract_context_levels env paramsl in let s = { template_param_levels = param_ccls; template_level = u} in TemplateArity (params,s) else RegularArity t | _ -> RegularArity t (* Type of constants *) let type_of_constant_type_knowing_parameters env t paramtyps = match t with | RegularArity t -> t | TemplateArity (sign,ar) -> let ctx = List.rev sign in let ctx,s = instantiate_universes env ctx ar paramtyps in mkArity (List.rev ctx,s) let type_of_constant_knowing_parameters env cst paramtyps = let cb = lookup_constant (fst cst) env in let () = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in let ty, cu = constant_type env cst in type_of_constant_type_knowing_parameters env ty paramtyps, cu let type_of_constant_knowing_parameters_in env cst paramtyps = let cb = lookup_constant (fst cst) env in let () = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in let ty = constant_type_in env cst in type_of_constant_type_knowing_parameters env ty paramtyps let type_of_constant_type env t = type_of_constant_type_knowing_parameters env t [||] let type_of_constant env cst = type_of_constant_knowing_parameters env cst [||] let type_of_constant_in env cst = let cb = lookup_constant (fst cst) env in let () = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in let ar = constant_type_in env cst in type_of_constant_type_knowing_parameters env ar [||] let judge_of_constant_knowing_parameters env (kn,u as cst) args = let c = mkConstU cst in let ty, cu = type_of_constant_knowing_parameters env cst args in let () = check_constraints cu env in make_judge c ty let judge_of_constant env cst = judge_of_constant_knowing_parameters env cst [||] let type_of_projection env (p,u) = let cst = Projection.constant p in let cb = lookup_constant cst env in match cb.const_proj with | Some pb -> if cb.const_polymorphic then Vars.subst_instance_constr u pb.proj_type else pb.proj_type | None -> raise (Invalid_argument "type_of_projection: not a projection") (* Type of a lambda-abstraction. *) (* [judge_of_abstraction env name var j] implements the rule env, name:typ |- j.uj_val:j.uj_type env, |- (name:typ)j.uj_type : s ----------------------------------------------------------------------- env |- [name:typ]j.uj_val : (name:typ)j.uj_type Since all products are defined in the Calculus of Inductive Constructions and no upper constraint exists on the sort $s$, we don't need to compute $s$ *) let judge_of_abstraction env name var j = { uj_val = mkLambda (name, var.utj_val, j.uj_val); uj_type = mkProd (name, var.utj_val, j.uj_type) } (* Type of let-in. *) let judge_of_letin env name defj typj j = { uj_val = mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val) ; uj_type = subst1 defj.uj_val j.uj_type } (* Type of an application. *) let judge_of_apply env funj argjv = let rec apply_rec n typ = function | [] -> { uj_val = mkApp (j_val funj, Array.map j_val argjv); uj_type = typ } | hj::restjl -> (match kind_of_term (whd_all env typ) with | Prod (_,c1,c2) -> (try let () = conv_leq false env hj.uj_type c1 in apply_rec (n+1) (subst1 hj.uj_val c2) restjl with NotConvertible -> error_cant_apply_bad_type env (n,c1, hj.uj_type) funj argjv) | _ -> error_cant_apply_not_functional env funj argjv) in apply_rec 1 funj.uj_type (Array.to_list argjv) (* Type of product *) let sort_of_product env domsort rangsort = match (domsort, rangsort) with (* Product rule (s,Prop,Prop) *) | (_, Prop Null) -> rangsort (* Product rule (Prop/Set,Set,Set) *) | (Prop _, Prop Pos) -> rangsort (* Product rule (Type,Set,?) *) | (Type u1, Prop Pos) -> if is_impredicative_set env then (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) rangsort else (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) Type (Universe.sup Universe.type0 u1) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Null, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) | (Type u1, Type u2) -> Type (Universe.sup u1 u2) (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule env |- typ1:s1 env, name:typ1 |- typ2 : s2 ------------------------------------------------------------------------- s' >= (s1,s2), env |- (name:typ)j.uj_val : s' where j.uj_type is convertible to a sort s2 *) let judge_of_product env name t1 t2 = let s = sort_of_product env t1.utj_type t2.utj_type in { uj_val = mkProd (name, t1.utj_val, t2.utj_val); uj_type = mkSort s } (* Type of a type cast *) (* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule env |- c:typ1 env |- typ2:s env |- typ1 <= typ2 --------------------------------------------------------------------- env |- c:typ2 *) let judge_of_cast env cj k tj = let expected_type = tj.utj_val in try let c, cst = match k with | VMcast -> mkCast (cj.uj_val, k, expected_type), Reduction.vm_conv CUMUL env cj.uj_type expected_type | DEFAULTcast -> mkCast (cj.uj_val, k, expected_type), default_conv ~l2r:false CUMUL env cj.uj_type expected_type | REVERTcast -> cj.uj_val, default_conv ~l2r:true CUMUL env cj.uj_type expected_type | NATIVEcast -> let sigma = Nativelambda.empty_evars in mkCast (cj.uj_val, k, expected_type), Nativeconv.native_conv CUMUL sigma env cj.uj_type expected_type in { uj_val = c; uj_type = expected_type } with NotConvertible -> error_actual_type env cj expected_type (* Inductive types. *) (* The type is parametric over the uniform parameters whose conclusion is in Type; to enforce the internal constraints between the parameters and the instances of Type occurring in the type of the constructors, we use the level variables _statically_ assigned to the conclusions of the parameters as mediators: e.g. if a parameter has conclusion Type(alpha), static constraints of the form alpha<=v exist between alpha and the Type's occurring in the constructor types; when the parameters is finally instantiated by a term of conclusion Type(u), then the constraints u<=alpha is computed in the App case of execute; from this constraints, the expected dynamic constraints of the form u<=v are enforced *) let judge_of_inductive_knowing_parameters env (ind,u as indu) args = let c = mkIndU indu in let (mib,mip) as spec = lookup_mind_specif env ind in check_hyps_inclusion env c mib.mind_hyps; let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters env (spec,u) args in check_constraints cst env; make_judge c t let judge_of_inductive env (ind,u as indu) = let c = mkIndU indu in let (mib,mip) as spec = lookup_mind_specif env ind in check_hyps_inclusion env c mib.mind_hyps; let t,cst = Inductive.constrained_type_of_inductive env (spec,u) in check_constraints cst env; (make_judge c t) (* Constructors. *) let judge_of_constructor env (c,u as cu) = let constr = mkConstructU cu in let _ = let ((kn,_),_) = c in let mib = lookup_mind kn env in check_hyps_inclusion env constr mib.mind_hyps in let specif = lookup_mind_specif env (inductive_of_constructor c) in let t,cst = constrained_type_of_constructor cu specif in let () = check_constraints cst env in (make_judge constr t) (* Case. *) let check_branch_types env (ind,u) cj (lfj,explft) = try conv_leq_vecti env (Array.map j_type lfj) explft with NotConvertibleVect i -> error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i) | Invalid_argument _ -> error_number_branches env cj (Array.length explft) let judge_of_case env ci pj cj lfj = let (pind, _ as indspec) = try find_rectype env cj.uj_type with Not_found -> error_case_not_inductive env cj in let () = check_case_info env pind ci in let (bty,rslty) = type_case_branches env indspec pj cj.uj_val in let () = check_branch_types env pind cj (lfj,bty) in ({ uj_val = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, Array.map j_val lfj); uj_type = rslty }) let judge_of_projection env p cj = let pb = lookup_projection p env in let (ind,u), args = try find_rectype env cj.uj_type with Not_found -> error_case_not_inductive env cj in assert(eq_mind pb.proj_ind (fst ind)); let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in let ty = substl (cj.uj_val :: List.rev args) ty in {uj_val = mkProj (p,cj.uj_val); uj_type = ty} (* Fixpoints. *) (* Checks the type of a general (co)fixpoint, i.e. without checking *) (* the specific guard condition. *) let type_fixpoint env lna lar vdefj = let lt = Array.length vdefj in assert (Int.equal (Array.length lar) lt); try conv_leq_vecti env (Array.map j_type vdefj) (Array.map (fun ty -> lift lt ty) lar) with NotConvertibleVect i -> error_ill_typed_rec_body env i lna vdefj lar (************************************************************************) (************************************************************************) (* The typing machine. *) (* ATTENTION : faudra faire le typage du contexte des Const, Ind et Constructsi un jour cela devient des constructions arbitraires et non plus des variables *) let rec execute env cstr = match kind_of_term cstr with (* Atomic terms *) | Sort (Prop c) -> judge_of_prop_contents c | Sort (Type u) -> judge_of_type u | Rel n -> judge_of_relative env n | Var id -> judge_of_variable env id | Const c -> judge_of_constant env c | Proj (p, c) -> let cj = execute env c in judge_of_projection env p cj (* Lambda calculus operators *) | App (f,args) -> let jl = execute_array env args in let j = match kind_of_term f with | Ind ind when Environ.template_polymorphic_pind ind env -> (* Sort-polymorphism of inductive types *) let args = Array.map (fun j -> lazy j.uj_type) jl in judge_of_inductive_knowing_parameters env ind args | Const cst when Environ.template_polymorphic_pconstant cst env -> (* Sort-polymorphism of constant *) let args = Array.map (fun j -> lazy j.uj_type) jl in judge_of_constant_knowing_parameters env cst args | _ -> (* No sort-polymorphism *) execute env f in judge_of_apply env j jl | Lambda (name,c1,c2) -> let varj = execute_type env c1 in let env1 = push_rel (LocalAssum (name,varj.utj_val)) env in let j' = execute env1 c2 in judge_of_abstraction env name varj j' | Prod (name,c1,c2) -> let varj = execute_type env c1 in let env1 = push_rel (LocalAssum (name,varj.utj_val)) env in let varj' = execute_type env1 c2 in judge_of_product env name varj varj' | LetIn (name,c1,c2,c3) -> let j1 = execute env c1 in let j2 = execute_type env c2 in let _ = judge_of_cast env j1 DEFAULTcast j2 in let env1 = push_rel (LocalDef (name,j1.uj_val,j2.utj_val)) env in let j' = execute env1 c3 in judge_of_letin env name j1 j2 j' | Cast (c,k,t) -> let cj = execute env c in let tj = execute_type env t in judge_of_cast env cj k tj (* Inductive types *) | Ind ind -> judge_of_inductive env ind | Construct c -> judge_of_constructor env c | Case (ci,p,c,lf) -> let cj = execute env c in let pj = execute env p in let lfj = execute_array env lf in judge_of_case env ci pj cj lfj | Fix ((vn,i as vni),recdef) -> let (fix_ty,recdef') = execute_recdef env recdef i in let fix = (vni,recdef') in check_fix env fix; make_judge (mkFix fix) fix_ty | CoFix (i,recdef) -> let (fix_ty,recdef') = execute_recdef env recdef i in let cofix = (i,recdef') in check_cofix env cofix; (make_judge (mkCoFix cofix) fix_ty) (* Partial proofs: unsupported by the kernel *) | Meta _ -> anomaly (Pp.str "the kernel does not support metavariables") | Evar _ -> anomaly (Pp.str "the kernel does not support existential variables") and execute_type env constr = let j = execute env constr in type_judgment env j and execute_recdef env (names,lar,vdef) i = let larj = execute_array env lar in let lara = Array.map (assumption_of_judgment env) larj in let env1 = push_rec_types (names,lara,vdef) env in let vdefj = execute_array env1 vdef in let vdefv = Array.map j_val vdefj in let () = type_fixpoint env1 names lara vdefj in (lara.(i),(names,lara,vdefv)) and execute_array env = Array.map (execute env) (* Derived functions *) let infer env constr = let j = execute env constr in assert (eq_constr j.uj_val constr); j (* let infer_key = Profile.declare_profile "infer" *) (* let infer = Profile.profile2 infer_key infer *) let infer_type env constr = let j = execute_type env constr in j let infer_v env cv = let jv = execute_array env cv in jv (* Typing of several terms. *) let infer_local_decl env id = function | LocalDefEntry c -> let j = infer env c in LocalDef (Name id, j.uj_val, j.uj_type) | LocalAssumEntry c -> let j = infer env c in LocalAssum (Name id, assumption_of_judgment env j) let infer_local_decls env decls = let rec inferec env = function | (id, d) :: l -> let (env, l) = inferec env l in let d = infer_local_decl env id d in (push_rel d env, Context.Rel.add d l) | [] -> (env, Context.Rel.empty) in inferec env decls coq-8.6/kernel/primitives.mli0000644000175000017500000000165213022274260015641 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int val to_string : t -> string coq-8.6/kernel/cClosure.ml0000644000175000017500000010764213022274260015062 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* red_kind val fVAR : Id.t -> red_kind val no_red : reds val red_add : reds -> red_kind -> reds val red_sub : reds -> red_kind -> reds val red_add_transparent : reds -> transparent_state -> reds val mkflags : red_kind list -> reds val red_set : reds -> red_kind -> bool val red_projection : reds -> projection -> bool end module RedFlags = (struct (* [r_const=(true,cl)] means all constants but those in [cl] *) (* [r_const=(false,cl)] means only those in [cl] *) (* [r_delta=true] just mean [r_const=(true,[])] *) type reds = { r_beta : bool; r_delta : bool; r_eta : bool; r_const : transparent_state; r_zeta : bool; r_match : bool; r_fix : bool; r_cofix : bool } type red_kind = BETA | DELTA | ETA | MATCH | FIX | COFIX | ZETA | CONST of constant | VAR of Id.t let fBETA = BETA let fDELTA = DELTA let fETA = ETA let fMATCH = MATCH let fFIX = FIX let fCOFIX = COFIX let fZETA = ZETA let fCONST kn = CONST kn let fVAR id = VAR id let no_red = { r_beta = false; r_delta = false; r_eta = false; r_const = all_opaque; r_zeta = false; r_match = false; r_fix = false; r_cofix = false } let red_add red = function | BETA -> { red with r_beta = true } | ETA -> { red with r_eta = true } | DELTA -> { red with r_delta = true; r_const = all_transparent } | CONST kn -> let (l1,l2) = red.r_const in { red with r_const = l1, Cpred.add kn l2 } | MATCH -> { red with r_match = true } | FIX -> { red with r_fix = true } | COFIX -> { red with r_cofix = true } | ZETA -> { red with r_zeta = true } | VAR id -> let (l1,l2) = red.r_const in { red with r_const = Id.Pred.add id l1, l2 } let red_sub red = function | BETA -> { red with r_beta = false } | ETA -> { red with r_eta = false } | DELTA -> { red with r_delta = false } | CONST kn -> let (l1,l2) = red.r_const in { red with r_const = l1, Cpred.remove kn l2 } | MATCH -> { red with r_match = false } | FIX -> { red with r_fix = false } | COFIX -> { red with r_cofix = false } | ZETA -> { red with r_zeta = false } | VAR id -> let (l1,l2) = red.r_const in { red with r_const = Id.Pred.remove id l1, l2 } let red_add_transparent red tr = { red with r_const = tr } let mkflags = List.fold_left red_add no_red let red_set red = function | BETA -> incr_cnt red.r_beta beta | ETA -> incr_cnt red.r_eta eta | CONST kn -> let (_,l) = red.r_const in let c = Cpred.mem kn l in incr_cnt c delta | VAR id -> (* En attendant d'avoir des kn pour les Var *) let (l,_) = red.r_const in let c = Id.Pred.mem id l in incr_cnt c delta | ZETA -> incr_cnt red.r_zeta zeta | MATCH -> incr_cnt red.r_match nb_match | FIX -> incr_cnt red.r_fix fix | COFIX -> incr_cnt red.r_cofix cofix | DELTA -> (* Used for Rel/Var defined in context *) incr_cnt red.r_delta delta let red_projection red p = if Projection.unfolded p then true else red_set red (fCONST (Projection.constant p)) end : RedFlagsSig) open RedFlags let all = mkflags [fBETA;fDELTA;fZETA;fMATCH;fFIX;fCOFIX] let allnolet = mkflags [fBETA;fDELTA;fMATCH;fFIX;fCOFIX] let beta = mkflags [fBETA] let betadeltazeta = mkflags [fBETA;fDELTA;fZETA] let betaiota = mkflags [fBETA;fMATCH;fFIX;fCOFIX] let betaiotazeta = mkflags [fBETA;fMATCH;fFIX;fCOFIX;fZETA] let betazeta = mkflags [fBETA;fZETA] let delta = mkflags [fDELTA] let zeta = mkflags [fZETA] let nored = no_red (* Removing fZETA for finer behaviour would break many developments *) let unfold_side_flags = [fBETA;fMATCH;fFIX;fCOFIX;fZETA] let unfold_side_red = mkflags [fBETA;fMATCH;fFIX;fCOFIX;fZETA] let unfold_red kn = let flag = match kn with | EvalVarRef id -> fVAR id | EvalConstRef kn -> fCONST kn in mkflags (flag::unfold_side_flags) (* Flags of reduction and cache of constants: 'a is a type that may be * mapped to constr. 'a infos implements a cache for constants and * abstractions, storing a representation (of type 'a) of the body of * this constant or abstraction. * * i_tab is the cache table of the results * * i_repr is the function to get the representation from the current * state of the cache and the body of the constant. The result * is stored in the table. * * i_rels is the array of free rel variables together with their optional * body * * ref_value_cache searchs in the tab, otherwise uses i_repr to * compute the result and store it in the table. If the constant can't * be unfolded, returns None, but does not store this failure. * This * doesn't take the RESET into account. You mustn't keep such a table * after a Reset. * This type is not exported. Only its two * instantiations (cbv or lazy) are. *) type table_key = constant puniverses tableKey let eq_pconstant_key (c,u) (c',u') = eq_constant_key c c' && Univ.Instance.equal u u' module IdKeyHash = struct open Hashset.Combine type t = table_key let equal = Names.eq_table_key eq_pconstant_key let hash = function | ConstKey (c, _) -> combinesmall 1 (Constant.UserOrd.hash c) | VarKey id -> combinesmall 2 (Id.hash id) | RelKey i -> combinesmall 3 (Int.hash i) end module KeyTable = Hashtbl.Make(IdKeyHash) let eq_table_key = IdKeyHash.equal type 'a infos_cache = { i_repr : 'a infos -> constr -> 'a; i_env : env; i_sigma : existential -> constr option; i_rels : constr option array; i_tab : 'a KeyTable.t } and 'a infos = { i_flags : reds; i_cache : 'a infos_cache } let info_flags info = info.i_flags let info_env info = info.i_cache.i_env open Context.Named.Declaration let assoc_defined id env = match Environ.lookup_named id env with | LocalDef (_, c, _) -> c | _ -> raise Not_found let ref_value_cache ({i_cache = cache} as infos) ref = try Some (KeyTable.find cache.i_tab ref) with Not_found -> try let body = match ref with | RelKey n -> let len = Array.length cache.i_rels in let i = n - 1 in let () = if i < 0 || len <= i then raise Not_found in begin match Array.unsafe_get cache.i_rels i with | None -> raise Not_found | Some t -> lift n t end | VarKey id -> assoc_defined id cache.i_env | ConstKey cst -> constant_value_in cache.i_env cst in let v = cache.i_repr infos body in KeyTable.add cache.i_tab ref v; Some v with | Not_found (* List.assoc *) | NotEvaluableConst _ (* Const *) -> None let evar_value cache ev = cache.i_sigma ev let defined_rels flags env = (* if red_local_const (snd flags) then*) let ctx = rel_context env in let len = List.length ctx in let ans = Array.make len None in let open Context.Rel.Declaration in let iter i = function | LocalAssum _ -> () | LocalDef (_,b,_) -> Array.unsafe_set ans i (Some b) in let () = List.iteri iter ctx in ans (* else (0,[])*) let create mk_cl flgs env evars = let cache = { i_repr = mk_cl; i_env = env; i_sigma = evars; i_rels = defined_rels flgs env; i_tab = KeyTable.create 17 } in { i_flags = flgs; i_cache = cache } (**********************************************************************) (* Lazy reduction: the one used in kernel operations *) (* type of shared terms. fconstr and frterm are mutually recursive. * Clone of the constr structure, but completely mutable, and * annotated with reduction state (reducible or not). * - FLIFT is a delayed shift; allows sharing between 2 lifted copies * of a given term. * - FCLOS is a delayed substitution applied to a constr * - FLOCKED is used to erase the content of a reference that must * be updated. This is to allow the garbage collector to work * before the term is computed. *) (* Norm means the term is fully normalized and cannot create a redex when substituted Cstr means the term is in head normal form and that it can create a redex when substituted (i.e. constructor, fix, lambda) Whnf means we reached the head normal form and that it cannot create a redex when substituted Red is used for terms that might be reduced *) type red_state = Norm | Cstr | Whnf | Red let neutr = function | (Whnf|Norm) -> Whnf | (Red|Cstr) -> Red type fconstr = { mutable norm: red_state; mutable term: fterm } and fterm = | FRel of int | FAtom of constr (* Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of pinductive | FConstruct of pconstructor | FApp of fconstr * fconstr array | FProj of projection * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs | FProd of Name.t * fconstr * fconstr | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED let fterm_of v = v.term let set_norm v = v.norm <- Norm let is_val v = match v.norm with Norm -> true | _ -> false let mk_atom c = {norm=Norm;term=FAtom c} let mk_red f = {norm=Red;term=f} (* Could issue a warning if no is still Red, pointing out that we loose sharing. *) let update v1 no t = if !share then (v1.norm <- no; v1.term <- t; v1) else {norm=no;term=t} (**********************************************************************) (* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of int * int * constant | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr and stack = stack_member list let empty_stack = [] let append_stack v s = if Int.equal (Array.length v) 0 then s else match s with | Zapp l :: s -> Zapp (Array.append v l) :: s | _ -> Zapp v :: s (* Collapse the shifts in the stack *) let zshift n s = match (n,s) with (0,_) -> s | (_,Zshift(k)::s) -> Zshift(n+k)::s | _ -> Zshift(n)::s let rec stack_args_size = function | Zapp v :: s -> Array.length v + stack_args_size s | Zshift(_)::s -> stack_args_size s | Zupdate(_)::s -> stack_args_size s | _ -> 0 (* When used as an argument stack (only Zapp can appear) *) let rec decomp_stack = function | Zapp v :: s -> (match Array.length v with 0 -> decomp_stack s | 1 -> Some (v.(0), s) | _ -> Some (v.(0), (Zapp (Array.sub v 1 (Array.length v - 1)) :: s))) | _ -> None let array_of_stack s = let rec stackrec = function | [] -> [] | Zapp args :: s -> args :: (stackrec s) | _ -> assert false in Array.concat (stackrec s) let rec stack_assign s p c = match s with | Zapp args :: s -> let q = Array.length args in if p >= q then Zapp args :: stack_assign s (p-q) c else (let nargs = Array.copy args in nargs.(p) <- c; Zapp nargs :: s) | _ -> s let rec stack_tail p s = if Int.equal p 0 then s else match s with | Zapp args :: s -> let q = Array.length args in if p >= q then stack_tail (p-q) s else Zapp (Array.sub args p (q-p)) :: s | _ -> failwith "stack_tail" let rec stack_nth s p = match s with | Zapp args :: s -> let q = Array.length args in if p >= q then stack_nth s (p-q) else args.(p) | _ -> raise Not_found (* Lifting. Preserves sharing (useful only for cell with norm=Red). lft_fconstr always create a new cell, while lift_fconstr avoids it when the lift is 0. *) let rec lft_fconstr n ft = match ft.term with | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)) -> ft | FRel i -> {norm=Norm;term=FRel(i+n)} | FLambda(k,tys,f,e) -> {norm=Cstr; term=FLambda(k,tys,f,subs_shft(n,e))} | FFix(fx,e) -> {norm=Cstr; term=FFix(fx,subs_shft(n,e))} | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))} | FLIFT(k,m) -> lft_fconstr (n+k) m | FLOCKED -> assert false | _ -> {norm=ft.norm; term=FLIFT(n,ft)} let lift_fconstr k f = if Int.equal k 0 then f else lft_fconstr k f let lift_fconstr_vect k v = if Int.equal k 0 then v else CArray.Fun1.map lft_fconstr k v let clos_rel e i = match expand_rel i e with | Inl(n,mt) -> lift_fconstr n mt | Inr(k,None) -> {norm=Norm; term= FRel k} | Inr(k,Some p) -> lift_fconstr (k-p) {norm=Red;term=FFlex(RelKey p)} (* since the head may be reducible, we might introduce lifts of 0 *) let compact_stack head stk = let rec strip_rec depth = function | Zshift(k)::s -> strip_rec (depth+k) s | Zupdate(m)::s -> (* Be sure to create a new cell otherwise sharing would be lost by the update operation *) let h' = lft_fconstr depth head in let _ = update m h'.norm h'.term in strip_rec depth s | stk -> zshift depth stk in strip_rec 0 stk (* Put an update mark in the stack, only if needed *) let zupdate m s = if !share && begin match m.norm with Red -> true | _ -> false end then let s' = compact_stack m s in let _ = m.term <- FLOCKED in Zupdate(m)::s' else s let mk_lambda env t = let (rvars,t') = decompose_lam t in FLambda(List.length rvars, List.rev rvars, t', env) let destFLambda clos_fun t = match t.term with FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b) | FLambda(n,(na,ty)::tys,b,e) -> (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)}) | _ -> assert false (* t must be a FLambda and binding list cannot be empty *) (* Optimization: do not enclose variables in a closure. Makes variable access much faster *) let mk_clos e t = match kind_of_term t with | Rel i -> clos_rel e i | Var x -> { norm = Red; term = FFlex (VarKey x) } | Const c -> { norm = Red; term = FFlex (ConstKey c) } | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } | Ind kn -> { norm = Norm; term = FInd kn } | Construct kn -> { norm = Cstr; term = FConstruct kn } | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _) -> {norm = Red; term = FCLOS(t,e)} let mk_clos_vect env v = CArray.Fun1.map mk_clos env v (* Translate the head constructor of t from constr to fconstr. This function is parameterized by the function to apply on the direct subterms. Could be used insted of mk_clos. *) let mk_clos_deep clos_fun env t = match kind_of_term t with | (Rel _|Ind _|Const _|Construct _|Var _|Meta _ | Sort _) -> mk_clos env t | Cast (a,k,b) -> { norm = Red; term = FCast (clos_fun env a, k, clos_fun env b)} | App (f,v) -> { norm = Red; term = FApp (clos_fun env f, CArray.Fun1.map clos_fun env v) } | Proj (p,c) -> { norm = Red; term = FProj (p, clos_fun env c) } | Case (ci,p,c,v) -> { norm = Red; term = FCaseT (ci, p, clos_fun env c, v, env) } | Fix fx -> { norm = Cstr; term = FFix (fx, env) } | CoFix cfx -> { norm = Cstr; term = FCoFix(cfx,env) } | Lambda _ -> { norm = Cstr; term = mk_lambda env t } | Prod (n,t,c) -> { norm = Whnf; term = FProd (n, clos_fun env t, clos_fun (subs_lift env) c) } | LetIn (n,b,t,c) -> { norm = Red; term = FLetIn (n, clos_fun env b, clos_fun env t, c, env) } | Evar ev -> { norm = Red; term = FEvar(ev,env) } (* A better mk_clos? *) let mk_clos2 = mk_clos_deep mk_clos (* The inverse of mk_clos_deep: move back to constr *) let rec to_constr constr_fun lfts v = match v.term with | FRel i -> mkRel (reloc_rel i lfts) | FFlex (RelKey p) -> mkRel (reloc_rel p lfts) | FFlex (VarKey x) -> mkVar x | FAtom c -> exliftn lfts c | FCast (a,k,b) -> mkCast (constr_fun lfts a, k, constr_fun lfts b) | FFlex (ConstKey op) -> mkConstU op | FInd op -> mkIndU op | FConstruct op -> mkConstructU op | FCaseT (ci,p,c,ve,env) -> mkCase (ci, constr_fun lfts (mk_clos env p), constr_fun lfts c, Array.map (fun b -> constr_fun lfts (mk_clos env b)) ve) | FFix ((op,(lna,tys,bds)),e) -> let n = Array.length bds in let ftys = CArray.Fun1.map mk_clos e tys in let fbds = CArray.Fun1.map mk_clos (subs_liftn n e) bds in let lfts' = el_liftn n lfts in mkFix (op, (lna, CArray.Fun1.map constr_fun lfts ftys, CArray.Fun1.map constr_fun lfts' fbds)) | FCoFix ((op,(lna,tys,bds)),e) -> let n = Array.length bds in let ftys = CArray.Fun1.map mk_clos e tys in let fbds = CArray.Fun1.map mk_clos (subs_liftn n e) bds in let lfts' = el_liftn (Array.length bds) lfts in mkCoFix (op, (lna, CArray.Fun1.map constr_fun lfts ftys, CArray.Fun1.map constr_fun lfts' fbds)) | FApp (f,ve) -> mkApp (constr_fun lfts f, CArray.Fun1.map constr_fun lfts ve) | FProj (p,c) -> mkProj (p,constr_fun lfts c) | FLambda _ -> let (na,ty,bd) = destFLambda mk_clos2 v in mkLambda (na, constr_fun lfts ty, constr_fun (el_lift lfts) bd) | FProd (n,t,c) -> mkProd (n, constr_fun lfts t, constr_fun (el_lift lfts) c) | FLetIn (n,b,t,f,e) -> let fc = mk_clos2 (subs_lift e) f in mkLetIn (n, constr_fun lfts b, constr_fun lfts t, constr_fun (el_lift lfts) fc) | FEvar ((ev,args),env) -> mkEvar(ev,Array.map (fun a -> constr_fun lfts (mk_clos2 env a)) args) | FLIFT (k,a) -> to_constr constr_fun (el_shft k lfts) a | FCLOS (t,env) -> let fr = mk_clos2 env t in let unfv = update v fr.norm fr.term in to_constr constr_fun lfts unfv | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*) (* This function defines the correspondance between constr and fconstr. When we find a closure whose substitution is the identity, then we directly return the constr to avoid possibly huge reallocation. *) let term_of_fconstr = let rec term_of_fconstr_lift lfts v = match v.term with | FCLOS(t,env) when is_subs_id env && is_lift_id lfts -> t | FLambda(_,tys,f,e) when is_subs_id e && is_lift_id lfts -> compose_lam (List.rev tys) f | FFix(fx,e) when is_subs_id e && is_lift_id lfts -> mkFix fx | FCoFix(cfx,e) when is_subs_id e && is_lift_id lfts -> mkCoFix cfx | _ -> to_constr term_of_fconstr_lift lfts v in term_of_fconstr_lift el_id (* fstrong applies unfreeze_fun recursively on the (freeze) term and * yields a term. Assumes that the unfreeze_fun never returns a * FCLOS term. let rec fstrong unfreeze_fun lfts v = to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v) *) let rec zip m stk = match stk with | [] -> m | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s | ZcaseT(ci,p,br,e)::s -> let t = FCaseT(ci, p, m, br, e) in zip {norm=neutr m.norm; term=t} s | Zproj (i,j,cst) :: s -> zip {norm=neutr m.norm; term=FProj(Projection.make cst true,m)} s | Zfix(fx,par)::s -> zip fx (par @ append_stack [|m|] s) | Zshift(n)::s -> zip (lift_fconstr n m) s | Zupdate(rf)::s -> zip (update rf m.norm m.term) s let fapp_stack (m,stk) = zip m stk (*********************************************************************) (* The assertions in the functions below are granted because they are called only when m is a constructor, a cofix (strip_update_shift_app), a fix (get_nth_arg) or an abstraction (strip_update_shift, through get_arg). *) (* optimised for the case where there are no shifts... *) let strip_update_shift_app_red head stk = let rec strip_rec rstk h depth = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s | (Zapp args :: s) -> strip_rec (Zapp args :: rstk) {norm=h.norm;term=FApp(h,args)} depth s | Zupdate(m)::s -> strip_rec rstk (update m h.norm h.term) depth s | stk -> (depth,List.rev rstk, stk) in strip_rec [] head 0 stk let strip_update_shift_app head stack = assert (match head.norm with Red -> false | _ -> true); strip_update_shift_app_red head stack let get_nth_arg head n stk = assert (match head.norm with Red -> false | _ -> true); let rec strip_rec rstk h n = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) n s | Zapp args::s' -> let q = Array.length args in if n >= q then strip_rec (Zapp args::rstk) {norm=h.norm;term=FApp(h,args)} (n-q) s' else let bef = Array.sub args 0 n in let aft = Array.sub args (n+1) (q-n-1) in let stk' = List.rev (if Int.equal n 0 then rstk else (Zapp bef :: rstk)) in (Some (stk', args.(n)), append_stack aft s') | Zupdate(m)::s -> strip_rec rstk (update m h.norm h.term) n s | s -> (None, List.rev rstk @ s) in strip_rec [] head n stk (* Beta reduction: look for an applied argument in the stack. Since the encountered update marks are removed, h must be a whnf *) let rec get_args n tys f e stk = match stk with Zupdate r :: s -> let _hd = update r Cstr (FLambda(n,tys,f,e)) in get_args n tys f e s | Zshift k :: s -> get_args n tys f (subs_shft (k,e)) s | Zapp l :: s -> let na = Array.length l in if n == na then (Inl (subs_cons(l,e)),s) else if n < na then (* more arguments *) let args = Array.sub l 0 n in let eargs = Array.sub l n (na-n) in (Inl (subs_cons(args,e)), Zapp eargs :: s) else (* more lambdas *) let etys = List.skipn na tys in get_args (n-na) etys f (subs_cons(l,e)) s | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk) (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function | (Zapp _ | Zfix _ | ZcaseT _ | Zproj _ | Zshift _ | Zupdate _ as e) :: s -> e :: eta_expand_stack s | [] -> [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]] (* Iota reduction: extract the arguments to be passed to the Case branches *) let rec reloc_rargs_rec depth stk = match stk with Zapp args :: s -> Zapp (lift_fconstr_vect depth args) :: reloc_rargs_rec depth s | Zshift(k)::s -> if Int.equal k depth then s else reloc_rargs_rec (depth-k) s | _ -> stk let reloc_rargs depth stk = if Int.equal depth 0 then stk else reloc_rargs_rec depth stk let rec try_drop_parameters depth n argstk = match argstk with Zapp args::s -> let q = Array.length args in if n > q then try_drop_parameters depth (n-q) s else if Int.equal n q then reloc_rargs depth s else let aft = Array.sub args n (q-n) in reloc_rargs depth (append_stack aft s) | Zshift(k)::s -> try_drop_parameters (depth-k) n s | [] -> if Int.equal n 0 then [] else raise Not_found | _ -> assert false (* strip_update_shift_app only produces Zapp and Zshift items *) let drop_parameters depth n argstk = try try_drop_parameters depth n argstk with Not_found -> (* we know that n < stack_args_size(argstk) (if well-typed term) *) anomaly (Pp.str "ill-typed term: found a match on a partially applied constructor") (** [eta_expand_ind_stack env ind c s t] computes stacks corresponding to the conversion of the eta expansion of t, considered as an inhabitant of ind, and the Constructor c of this inductive type applied to arguments s. @assumes [t] is an irreducible term, and not a constructor. [ind] is the inductive of the constructor term [c] @raises Not_found if the inductive is not a primitive record, or if the constructor is partially applied. *) let eta_expand_ind_stack env ind m s (f, s') = let mib = lookup_mind (fst ind) env in match mib.Declarations.mind_record with | Some (Some (_,projs,pbs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite -> (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) let pars = mib.Declarations.mind_nparams in let right = fapp_stack (f, s') in let (depth, args, s) = strip_update_shift_app m s in (** Try to drop the params, might fail on partially applied constructors. *) let argss = try_drop_parameters depth pars args in let hstack = Array.map (fun p -> { norm = Red; (* right can't be a constructor though *) term = FProj (Projection.make p true, right) }) projs in argss, [Zapp hstack] | _ -> raise Not_found (* disallow eta-exp for non-primitive records *) let rec project_nth_arg n argstk = match argstk with | Zapp args :: s -> let q = Array.length args in if n >= q then project_nth_arg (n - q) s else (* n < q *) args.(n) | _ -> assert false (* After drop_parameters we have a purely applicative stack *) (* Iota reduction: expansion of a fixpoint. * Given a fixpoint and a substitution, returns the corresponding * fixpoint body, and the substitution in which it should be * evaluated: its first variables are the fixpoint bodies * * FCLOS(fix Fi {F0 := T0 .. Fn-1 := Tn-1}, S) * -> (S. FCLOS(F0,S) . ... . FCLOS(Fn-1,S), Ti) *) (* does not deal with FLIFT *) let contract_fix_vect fix = let (thisbody, make_body, env, nfix) = match fix with | FFix (((reci,i),(_,_,bds as rdcl)),env) -> (bds.(i), (fun j -> { norm = Cstr; term = FFix (((reci,j),rdcl),env) }), env, Array.length bds) | FCoFix ((i,(_,_,bds as rdcl)),env) -> (bds.(i), (fun j -> { norm = Cstr; term = FCoFix ((j,rdcl),env) }), env, Array.length bds) | _ -> assert false in (subs_cons(Array.init nfix make_body, env), thisbody) (*********************************************************************) (* A machine that inspects the head of a term until it finds an atom or a subterm that may produce a redex (abstraction, constructor, cofix, letin, constant), or a neutral term (product, inductive) *) let rec knh info m stk = match m.term with | FLIFT(k,a) -> knh info a (zshift k stk) | FCLOS(t,e) -> knht info e t (zupdate m stk) | FLOCKED -> assert false | FApp(a,b) -> knh info a (append_stack b (zupdate m stk)) | FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate m stk) | FFix(((ri,n),(_,_,_)),_) -> (match get_nth_arg m ri.(n) stk with (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') | (None, stk') -> (m,stk')) | FCast(t,_,_) -> knh info t stk | FProj (p,c) -> let unf = Projection.unfolded p in if unf || red_set info.i_flags (fCONST (Projection.constant p)) then (match try Some (lookup_projection p (info_env info)) with Not_found -> None with | None -> (m, stk) | Some pb -> knh info c (Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, Projection.constant p) :: zupdate m stk)) else (m,stk) (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) -> (m, stk) (* The same for pure terms *) and knht info e t stk = match kind_of_term t with | App(a,b) -> knht info e a (append_stack (mk_clos_vect e b) stk) | Case(ci,p,t,br) -> knht info e t (ZcaseT(ci, p, br, e)::stk) | Fix _ -> knh info (mk_clos2 e t) stk | Cast(a,_,_) -> knht info e a stk | Rel n -> knh info (clos_rel e n) stk | Proj (p,c) -> knh info (mk_clos2 e t) stk | (Lambda _|Prod _|Construct _|CoFix _|Ind _| LetIn _|Const _|Var _|Evar _|Meta _|Sort _) -> (mk_clos2 e t, stk) (************************************************************************) (* Computes a weak head normal form from the result of knh. *) let rec knr info m stk = match m.term with | FLambda(n,tys,f,e) when red_set info.i_flags fBETA -> (match get_args n tys f e stk with Inl e', s -> knit info e' f s | Inr lam, s -> (lam,s)) | FFlex(ConstKey (kn,_ as c)) when red_set info.i_flags (fCONST kn) -> (match ref_value_cache info (ConstKey c) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> (match ref_value_cache info (VarKey id) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FFlex(RelKey k) when red_set info.i_flags fDELTA -> (match ref_value_cache info (RelKey k) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FConstruct((ind,c),u) -> let use_match = red_set info.i_flags fMATCH in let use_fix = red_set info.i_flags fFIX in if use_match || use_fix then (match strip_update_shift_app m stk with | (depth, args, ZcaseT(ci,_,br,e)::s) when use_match -> assert (ci.ci_npar>=0); let rargs = drop_parameters depth ci.ci_npar args in knit info e br.(c-1) (rargs@s) | (_, cargs, Zfix(fx,par)::s) when use_fix -> let rarg = fapp_stack(m,cargs) in let stk' = par @ append_stack [|rarg|] s in let (fxe,fxbd) = contract_fix_vect fx.term in knit info fxe fxbd stk' | (depth, args, Zproj (n, m, cst)::s) when use_match -> let rargs = drop_parameters depth n args in let rarg = project_nth_arg m rargs in kni info rarg s | (_,args,s) -> (m,args@s)) else (m,stk) | FCoFix _ when red_set info.i_flags fCOFIX -> (match strip_update_shift_app m stk with (_, args, (((ZcaseT _|Zproj _)::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in knit info fxe fxbd (args@stk') | (_,args,s) -> (m,args@s)) | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> knit info (subs_cons([|v|],e)) bd stk | FEvar(ev,env) -> (match evar_value info.i_cache ev with Some c -> knit info env c stk | None -> (m,stk)) | _ -> (m,stk) (* Computes the weak head normal form of a term *) and kni info m stk = let (hm,s) = knh info m stk in knr info hm s and knit info e t stk = let (ht,s) = knht info e t stk in knr info ht s let kh info v stk = fapp_stack(kni info v stk) (************************************************************************) let rec zip_term zfun m stk = match stk with | [] -> m | Zapp args :: s -> zip_term zfun (mkApp(m, Array.map zfun args)) s | ZcaseT(ci,p,br,e)::s -> let t = mkCase(ci, zfun (mk_clos e p), m, Array.map (fun b -> zfun (mk_clos e b)) br) in zip_term zfun t s | Zproj(_,_,p)::s -> let t = mkProj (Projection.make p true, m) in zip_term zfun t s | Zfix(fx,par)::s -> let h = mkApp(zip_term zfun (zfun fx) par,[|m|]) in zip_term zfun h s | Zshift(n)::s -> zip_term zfun (lift n m) s | Zupdate(rf)::s -> zip_term zfun m s (* Computes the strong normal form of a term. 1- Calls kni 2- tries to rebuild the term. If a closure still has to be computed, calls itself recursively. *) let rec kl info m = if is_val m then (incr prune; term_of_fconstr m) else let (nm,s) = kni info m [] in let _ = fapp_stack(nm,s) in (* to unlock Zupdates! *) zip_term (kl info) (norm_head info nm) s (* no redex: go up for atoms and already normalized terms, go down otherwise. *) and norm_head info m = if is_val m then (incr prune; term_of_fconstr m) else match m.term with | FLambda(n,tys,f,e) -> let (e',rvtys) = List.fold_left (fun (e,ctxt) (na,ty) -> (subs_lift e, (na,kl info (mk_clos e ty))::ctxt)) (e,[]) tys in let bd = kl info (mk_clos e' f) in List.fold_left (fun b (na,ty) -> mkLambda(na,ty,b)) bd rvtys | FLetIn(na,a,b,f,e) -> let c = mk_clos (subs_lift e) f in mkLetIn(na, kl info a, kl info b, kl info c) | FProd(na,dom,rng) -> mkProd(na, kl info dom, kl info rng) | FCoFix((n,(na,tys,bds)),e) -> let ftys = CArray.Fun1.map mk_clos e tys in let fbds = CArray.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in mkCoFix(n,(na, CArray.Fun1.map kl info ftys, CArray.Fun1.map kl info fbds)) | FFix((n,(na,tys,bds)),e) -> let ftys = CArray.Fun1.map mk_clos e tys in let fbds = CArray.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in mkFix(n,(na, CArray.Fun1.map kl info ftys, CArray.Fun1.map kl info fbds)) | FEvar((i,args),env) -> mkEvar(i, Array.map (fun a -> kl info (mk_clos env a)) args) | FProj (p,c) -> mkProj (p, kl info c) | t -> term_of_fconstr m (* Initialization and then normalization *) (* weak reduction *) let whd_val info v = with_stats (lazy (term_of_fconstr (kh info v []))) (* strong reduction *) let norm_val info v = with_stats (lazy (kl info v)) let inject c = mk_clos (subs_id 0) c let whd_stack infos m stk = let k = kni infos m stk in let _ = fapp_stack k in (* to unlock Zupdates! *) k (* cache of constants: the body is computed only when needed. *) type clos_infos = fconstr infos let create_clos_infos ?(evars=fun _ -> None) flgs env = create (fun _ -> inject) flgs env evars let oracle_of_infos infos = Environ.oracle infos.i_cache.i_env let env_of_infos infos = infos.i_cache.i_env let infos_with_reds infos reds = { infos with i_flags = reds } let unfold_reference info key = match key with | ConstKey (kn,_) -> if red_set info.i_flags (fCONST kn) then ref_value_cache info key else None | VarKey i -> if red_set info.i_flags (fVAR i) then ref_value_cache info key else None | _ -> ref_value_cache info key coq-8.6/kernel/term_typing.ml0000644000175000017500000004747013022274260015646 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* if not poly then (* Old-style polymorphism *) make_polymorphic_if_constant_for_ind env j else RegularArity (Vars.subst_univs_level_constr subst j.uj_type) | `Some t -> let tj = infer_type env t in let _ = judge_of_cast env j DEFAULTcast tj in assert (eq_constr t tj.utj_val); RegularArity (Vars.subst_univs_level_constr subst t) | `SomeWJ (t, tj) -> let tj = infer_type env t in let _ = judge_of_cast env j DEFAULTcast tj in assert (eq_constr t tj.utj_val); RegularArity (Vars.subst_univs_level_constr subst t) let map_option_typ = function None -> `None | Some x -> `Some x (* Insertion of constants and parameters in environment. *) let mk_pure_proof c = (c, Univ.ContextSet.empty), [] let equal_eff e1 e2 = let open Entries in match e1, e2 with | { eff = SEsubproof (c1,_,_) }, { eff = SEsubproof (c2,_,_) } -> Names.Constant.equal c1 c2 | { eff = SEscheme (cl1,_) }, { eff = SEscheme (cl2,_) } -> CList.for_all2eq (fun (_,c1,_,_) (_,c2,_,_) -> Names.Constant.equal c1 c2) cl1 cl2 | _ -> false let rec uniq_seff = function | [] -> [] | x :: xs -> x :: uniq_seff (List.filter (fun y -> not (equal_eff x y)) xs) (* The list of side effects is in reverse order (most recent first). * To keep the "topological" order between effects we have to uniq-ize from * the tail *) let uniq_seff l = List.rev (uniq_seff (List.rev l)) let inline_side_effects env body ctx side_eff = let handle_sideff (t,ctx,sl) { eff = se; from_env = mb } = let cbl = match se with | SEsubproof (c,cb,b) -> [c,cb,b] | SEscheme (cl,_) -> List.map (fun (_,c,cb,b) -> c,cb,b) cl in let not_exists (c,_,_) = try ignore(Environ.lookup_constant c env); false with Not_found -> true in let cbl = List.filter not_exists cbl in let cname c = let name = string_of_con c in for i = 0 to String.length name - 1 do if name.[i] == '.' || name.[i] == '#' then name.[i] <- '_' done; Name (id_of_string name) in let rec sub c i x = match kind_of_term x with | Const (c', _) when eq_constant c c' -> mkRel i | _ -> map_constr_with_binders ((+) 1) (fun i x -> sub c i x) i x in let rec sub_body c u b i x = match kind_of_term x with | Const (c',u') when eq_constant c c' -> Vars.subst_instance_constr u' b | _ -> map_constr_with_binders ((+) 1) (sub_body c u b) i x in let fix_body (c,cb,b) (t,ctx) = match cb.const_body, b with | Def b, _ -> let b = Mod_subst.force_constr b in let poly = cb.const_polymorphic in if not poly then let b_ty = Typeops.type_of_constant_type env cb.const_type in let t = sub c 1 (Vars.lift 1 t) in mkLetIn (cname c, b, b_ty, t), Univ.ContextSet.union ctx (Univ.ContextSet.of_context cb.const_universes) else let univs = cb.const_universes in sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t), ctx | OpaqueDef _, `Opaque (b,_) -> let poly = cb.const_polymorphic in if not poly then let b_ty = Typeops.type_of_constant_type env cb.const_type in let t = sub c 1 (Vars.lift 1 t) in mkApp (mkLambda (cname c, b_ty, t), [|b|]), Univ.ContextSet.union ctx (Univ.ContextSet.of_context cb.const_universes) else let univs = cb.const_universes in sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t), ctx | _ -> assert false in let t, ctx = List.fold_right fix_body cbl (t,ctx) in t, ctx, (mb,List.length cbl) :: sl in (* CAVEAT: we assure a proper order *) List.fold_left handle_sideff (body,ctx,[]) (uniq_seff side_eff) (* Given the list of signatures of side effects, checks if they match. * I.e. if they are ordered descendants of the current revstruct *) let check_signatures curmb sl = let is_direct_ancestor (sl, curmb) (mb, how_many) = match curmb with | None -> None, None | Some curmb -> try let mb = CEphemeron.get mb in match sl with | None -> sl, None | Some n -> if List.length mb >= how_many && CList.skipn how_many mb == curmb then Some (n + how_many), Some mb else None, None with CEphemeron.InvalidKey -> None, None in let sl, _ = List.fold_left is_direct_ancestor (Some 0,Some curmb) sl in sl let skip_trusted_seff sl b e = let rec aux sl b e acc = let open Context.Rel.Declaration in match sl, kind_of_term b with | (None|Some 0), _ -> b, e, acc | Some sl, LetIn (n,c,ty,bo) -> aux (Some (sl-1)) bo (Environ.push_rel (LocalDef (n,c,ty)) e) (`Let(n,c,ty)::acc) | Some sl, App(hd,arg) -> begin match kind_of_term hd with | Lambda (n,ty,bo) -> aux (Some (sl-1)) bo (Environ.push_rel (LocalAssum (n,ty)) e) (`Cut(n,ty,arg)::acc) | _ -> assert false end | _ -> assert false in aux sl b e [] let rec unzip ctx j = match ctx with | [] -> j | `Let (n,c,ty) :: ctx -> unzip ctx { j with uj_val = mkLetIn (n,c,ty,j.uj_val) } | `Cut (n,ty,arg) :: ctx -> unzip ctx { j with uj_val = mkApp (mkLambda (n,ty,j.uj_val),arg) } let hcons_j j = { uj_val = hcons_constr j.uj_val; uj_type = hcons_constr j.uj_type} let feedback_completion_typecheck = let open Feedback in Option.iter (fun state_id -> feedback ~id:(State state_id) Feedback.Complete) let infer_declaration ~trust env kn dcl = match dcl with | ParameterEntry (ctx,poly,(t,uctx),nl) -> let env = push_context ~strict:(not poly) uctx env in let j = infer env t in let abstract = poly && not (Option.is_empty kn) in let usubst, univs = Univ.abstract_universes abstract uctx in let c = Typeops.assumption_of_judgment env j in let t = hcons_constr (Vars.subst_univs_level_constr usubst c) in Undef nl, RegularArity t, None, poly, univs, false, ctx | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true; const_entry_polymorphic = false} as c) -> let env = push_context ~strict:true c.const_entry_universes env in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let tyj = infer_type env typ in let proofterm = Future.chain ~greedy:true ~pure:true body (fun ((body,uctx),side_eff) -> let body, uctx, signatures = inline_side_effects env body uctx side_eff in let valid_signatures = check_signatures trust signatures in let env' = push_context_set uctx env in let j = let body,env',ectx = skip_trusted_seff valid_signatures body env' in let j = infer env' body in unzip ectx j in let j = hcons_j j in let subst = Univ.LMap.empty in let _typ = constrain_type env' j c.const_entry_polymorphic subst (`SomeWJ (typ,tyj)) in feedback_completion_typecheck feedback_id; j.uj_val, uctx) in let def = OpaqueDef (Opaqueproof.create proofterm) in def, RegularArity typ, None, c.const_entry_polymorphic, c.const_entry_universes, c.const_entry_inline_code, c.const_entry_secctx | DefinitionEntry c -> let { const_entry_type = typ; const_entry_opaque = opaque } = c in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let (body, ctx), side_eff = Future.join body in let univsctx = Univ.ContextSet.of_context c.const_entry_universes in let body, ctx, _ = inline_side_effects env body (Univ.ContextSet.union univsctx ctx) side_eff in let env = push_context_set ~strict:(not c.const_entry_polymorphic) ctx env in let abstract = c.const_entry_polymorphic && not (Option.is_empty kn) in let usubst, univs = Univ.abstract_universes abstract (Univ.ContextSet.to_context ctx) in let j = infer env body in let typ = constrain_type env j c.const_entry_polymorphic usubst (map_option_typ typ) in let def = hcons_constr (Vars.subst_univs_level_constr usubst j.uj_val) in let def = if opaque then OpaqueDef (Opaqueproof.create (Future.from_val (def, Univ.ContextSet.empty))) else Def (Mod_subst.from_val def) in feedback_completion_typecheck feedback_id; def, typ, None, c.const_entry_polymorphic, univs, c.const_entry_inline_code, c.const_entry_secctx | ProjectionEntry {proj_entry_ind = ind; proj_entry_arg = i} -> let mib, _ = Inductive.lookup_mind_specif env (ind,0) in let kn, pb = match mib.mind_record with | Some (Some (id, kns, pbs)) -> if i < Array.length pbs then kns.(i), pbs.(i) else assert false | _ -> assert false in let term, typ = pb.proj_eta in Def (Mod_subst.from_val (hcons_constr term)), RegularArity typ, Some pb, mib.mind_polymorphic, mib.mind_universes, false, None let global_vars_set_constant_type env = function | RegularArity t -> global_vars_set env t | TemplateArity (ctx,_) -> Context.Rel.fold_outside (Context.Rel.Declaration.fold (fun t c -> Id.Set.union (global_vars_set env t) c)) ctx ~init:Id.Set.empty let record_aux env s_ty s_bo suggested_expr = let open Context.Named.Declaration in let in_ty = keep_hyps env s_ty in let v = String.concat " " (CList.map_filter (fun decl -> let id = get_id decl in if List.exists (Id.equal id % get_id) in_ty then None else Some (Id.to_string id)) (keep_hyps env s_bo)) in Aux_file.record_in_aux "context_used" (v ^ ";" ^ suggested_expr) let suggest_proof_using = ref (fun _ _ _ _ _ -> "") let set_suggest_proof_using f = suggest_proof_using := f let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) = let open Context.Named.Declaration in let check declared inferred = let mk_set l = List.fold_right Id.Set.add (List.map get_id l) Id.Set.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in if not (Id.Set.subset inferred_set declared_set) then let l = Id.Set.elements (Idset.diff inferred_set declared_set) in let n = List.length l in errorlabstrm "" (Pp.(str "The following section " ++ str (String.plural n "variable") ++ str " " ++ str (String.conjugate_verb_to_be n) ++ str " used but not declared:" ++ fnl () ++ pr_sequence Id.print (List.rev l) ++ str ".")) in let sort evn l = List.filter (fun decl -> let id = get_id decl in List.exists (Names.Id.equal id % get_id) l) (named_context env) in (* We try to postpone the computation of used section variables *) let hyps, def = let context_ids = List.map get_id (named_context env) in match ctx with | None when not (List.is_empty context_ids) -> (* No declared section vars, and non-empty section context: we must look at the body NOW, if any *) let ids_typ = global_vars_set_constant_type env typ in let ids_def = match def with | Undef _ -> Idset.empty | Def cs -> global_vars_set env (Mod_subst.force_constr cs) | OpaqueDef lc -> let vars = global_vars_set env (Opaqueproof.force_proof (opaque_tables env) lc) in (* we force so that cst are added to the env immediately after *) ignore(Opaqueproof.force_constraints (opaque_tables env) lc); let expr = !suggest_proof_using (Constant.to_string kn) env vars ids_typ context_ids in if !Flags.compilation_mode = Flags.BuildVo then record_aux env ids_typ vars expr; vars in keep_hyps env (Idset.union ids_typ ids_def), def | None -> if !Flags.compilation_mode = Flags.BuildVo then record_aux env Id.Set.empty Id.Set.empty ""; [], def (* Empty section context: no need to check *) | Some declared -> (* We use the declared set and chain a check of correctness *) sort env declared, match def with | Undef _ as x -> x (* nothing to check *) | Def cs as x -> let ids_typ = global_vars_set_constant_type env typ in let ids_def = global_vars_set env (Mod_subst.force_constr cs) in let inferred = keep_hyps env (Idset.union ids_typ ids_def) in check declared inferred; x | OpaqueDef lc -> (* In this case we can postpone the check *) OpaqueDef (Opaqueproof.iter_direct_opaque (fun c -> let ids_typ = global_vars_set_constant_type env typ in let ids_def = global_vars_set env c in let inferred = keep_hyps env (Idset.union ids_typ ids_def) in check declared inferred) lc) in let tps = let res = let comp_univs = if poly then Some univs else None in match proj with | None -> compile_constant_body env comp_univs def | Some pb -> (* The compilation of primitive projections is a bit tricky, because they refer to themselves (the body of p looks like fun c => Proj(p,c)). We break the cycle by building an ad-hoc compilation environment. A cleaner solution would be that kernel projections are simply Proj(i,c) with i an int and c a constr, but we would have to get rid of the compatibility layer. *) let cb = { const_hyps = hyps; const_body = def; const_type = typ; const_proj = proj; const_body_code = None; const_polymorphic = poly; const_universes = univs; const_inline_code = inline_code; const_typing_flags = Environ.typing_flags env; } in let env = add_constant kn cb env in compile_constant_body env comp_univs def in Option.map Cemitcodes.from_val res in { const_hyps = hyps; const_body = def; const_type = typ; const_proj = proj; const_body_code = tps; const_polymorphic = poly; const_universes = univs; const_inline_code = inline_code; const_typing_flags = Environ.typing_flags env } (*s Global and local constant declaration. *) let translate_constant mb env kn ce = build_constant_declaration kn env (infer_declaration ~trust:mb env (Some kn) ce) let constant_entry_of_side_effect cb u = let pt = match cb.const_body, u with | OpaqueDef _, `Opaque (b, c) -> b, c | Def b, `Nothing -> Mod_subst.force_constr b, Univ.ContextSet.empty | _ -> assert false in DefinitionEntry { const_entry_body = Future.from_val (pt, []); const_entry_secctx = None; const_entry_feedback = None; const_entry_type = (match cb.const_type with RegularArity t -> Some t | _ -> None); const_entry_polymorphic = cb.const_polymorphic; const_entry_universes = cb.const_universes; const_entry_opaque = Declareops.is_opaque cb; const_entry_inline_code = cb.const_inline_code } ;; let turn_direct (kn,cb,u,r as orig) = match cb.const_body, u with | OpaqueDef _, `Opaque (b,c) -> let pt = Future.from_val (b,c) in kn, { cb with const_body = OpaqueDef (Opaqueproof.create pt) }, u, r | _ -> orig ;; type side_effect_role = | Subproof | Schema of inductive * string type exported_side_effect = constant * constant_body * side_effects constant_entry * side_effect_role let export_side_effects mb env ce = match ce with | ParameterEntry _ | ProjectionEntry _ -> [], ce | DefinitionEntry c -> let { const_entry_body = body } = c in let _, eff = Future.force body in let ce = DefinitionEntry { c with const_entry_body = Future.chain ~greedy:true ~pure:true body (fun (b_ctx, _) -> b_ctx, []) } in let not_exists (c,_,_,_) = try ignore(Environ.lookup_constant c env); false with Not_found -> true in let aux (acc,sl) { eff = se; from_env = mb } = let cbl = match se with | SEsubproof (c,cb,b) -> [c,cb,b,Subproof] | SEscheme (cl,k) -> List.map (fun (i,c,cb,b) -> c,cb,b,Schema(i,k)) cl in let cbl = List.filter not_exists cbl in if cbl = [] then acc, sl else cbl :: acc, (mb,List.length cbl) :: sl in let seff, signatures = List.fold_left aux ([],[]) (uniq_seff eff) in let trusted = check_signatures mb signatures in let push_seff env = function | kn, cb, `Nothing, _ -> let env = Environ.add_constant kn cb env in if not cb.const_polymorphic then Environ.push_context ~strict:true cb.const_universes env else env | kn, cb, `Opaque(_, ctx), _ -> let env = Environ.add_constant kn cb env in if not cb.const_polymorphic then let env = Environ.push_context ~strict:true cb.const_universes env in Environ.push_context_set ~strict:true ctx env else env in let rec translate_seff sl seff acc env = match sl, seff with | _, [] -> List.rev acc, ce | (None | Some 0), cbs :: rest -> let env, cbs = List.fold_left (fun (env,cbs) (kn, ocb, u, r) -> let ce = constant_entry_of_side_effect ocb u in let cb = translate_constant mb env kn ce in (push_seff env (kn, cb,`Nothing, Subproof),(kn,cb,ce,r) :: cbs)) (env,[]) cbs in translate_seff sl rest (cbs @ acc) env | Some sl, cbs :: rest -> let cbs_len = List.length cbs in let cbs = List.map turn_direct cbs in let env = List.fold_left push_seff env cbs in let ecbs = List.map (fun (kn,cb,u,r) -> kn, cb, constant_entry_of_side_effect cb u, r) cbs in translate_seff (Some (sl-cbs_len)) rest (ecbs @ acc) env in translate_seff trusted seff [] env ;; let translate_local_assum env t = let j = infer env t in let t = Typeops.assumption_of_judgment env j in t let translate_recipe env kn r = build_constant_declaration kn env (Cooking.cook_constant env r) let translate_local_def mb env id centry = let def,typ,proj,poly,univs,inline_code,ctx = infer_declaration ~trust:mb env None (DefinitionEntry centry) in let typ = type_of_constant_type env typ in if ctx = None && !Flags.compilation_mode = Flags.BuildVo then begin match def with | Undef _ -> () | Def _ -> () | OpaqueDef lc -> let open Context.Named.Declaration in let context_ids = List.map get_id (named_context env) in let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Opaqueproof.force_proof (opaque_tables env) lc) in let expr = !suggest_proof_using (Id.to_string id) env ids_def ids_typ context_ids in record_aux env ids_typ ids_def expr end; def, typ, univs (* Insertion of inductive types. *) let translate_mind env kn mie = Indtypes.check_inductive env kn mie let inline_entry_side_effects env ce = { ce with const_entry_body = Future.chain ~greedy:true ~pure:true ce.const_entry_body (fun ((body, ctx), side_eff) -> let body, ctx',_ = inline_side_effects env body ctx side_eff in (body, ctx'), []); } let inline_side_effects env body side_eff = pi1 (inline_side_effects env body Univ.ContextSet.empty side_eff) coq-8.6/kernel/safe_typing.ml0000644000175000017500000010000613022274260015576 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* String.equal d1 d2 | Dvivo (d1,e1), Dvivo (d2,e2) -> String.equal d1 d2 && String.equal e1 e2 | Dvo_or_vi _, Dvivo _ -> false type library_info = DirPath.t * vodigest (** Functor and funsig parameters, most recent first *) type module_parameters = (MBId.t * module_type_body) list module DPMap = Map.Make(DirPath) type safe_environment = { env : Environ.env; modpath : module_path; modvariant : modvariant; modresolver : Mod_subst.delta_resolver; paramresolver : Mod_subst.delta_resolver; revstruct : structure_body; modlabels : Label.Set.t; objlabels : Label.Set.t; univ : Univ.ContextSet.t; future_cst : Univ.ContextSet.t Future.computation list; engagement : engagement option; required : vodigest DPMap.t; loads : (module_path * module_body) list; local_retroknowledge : Retroknowledge.action list; native_symbols : Nativecode.symbols DPMap.t } and modvariant = | NONE | LIBRARY | SIG of module_parameters * safe_environment (** saved env *) | STRUCT of module_parameters * safe_environment (** saved env *) let rec library_dp_of_senv senv = match senv.modvariant with | NONE | LIBRARY -> ModPath.dp senv.modpath | SIG(_,senv) -> library_dp_of_senv senv | STRUCT(_,senv) -> library_dp_of_senv senv let empty_environment = { env = Environ.empty_env; modpath = initial_path; modvariant = NONE; modresolver = Mod_subst.empty_delta_resolver; paramresolver = Mod_subst.empty_delta_resolver; revstruct = []; modlabels = Label.Set.empty; objlabels = Label.Set.empty; future_cst = []; univ = Univ.ContextSet.empty; engagement = None; required = DPMap.empty; loads = []; local_retroknowledge = []; native_symbols = DPMap.empty } let is_initial senv = match senv.revstruct, senv.modvariant with | [], NONE -> ModPath.equal senv.modpath initial_path | _ -> false let delta_of_senv senv = senv.modresolver,senv.paramresolver (** The safe_environment state monad *) type safe_transformer0 = safe_environment -> safe_environment type 'a safe_transformer = safe_environment -> 'a * safe_environment (** {6 Engagement } *) let set_engagement_opt env = function | Some c -> Environ.set_engagement c env | None -> env let set_engagement c senv = { senv with env = Environ.set_engagement c senv.env; engagement = Some c } let set_typing_flags c senv = { senv with env = Environ.set_typing_flags c senv.env } (** Check that the engagement [c] expected by a library matches the current (initial) one *) let check_engagement env expected_impredicative_set = let impredicative_set = Environ.engagement env in begin match impredicative_set, expected_impredicative_set with | PredicativeSet, ImpredicativeSet -> CErrors.error "Needs option -impredicative-set." | _ -> () end (** {6 Stm machinery } *) let get_opaque_body env cbo = match cbo.const_body with | Undef _ -> assert false | Def _ -> `Nothing | OpaqueDef opaque -> `Opaque (Opaqueproof.force_proof (Environ.opaque_tables env) opaque, Opaqueproof.force_constraints (Environ.opaque_tables env) opaque) type private_constant = Entries.side_effect type private_constants = private_constant list type private_constant_role = Term_typing.side_effect_role = | Subproof | Schema of inductive * string let empty_private_constants = [] let add_private x xs = x :: xs let concat_private xs ys = xs @ ys let mk_pure_proof = Term_typing.mk_pure_proof let inline_private_constants_in_constr = Term_typing.inline_side_effects let inline_private_constants_in_definition_entry = Term_typing.inline_entry_side_effects let side_effects_of_private_constants x = Term_typing.uniq_seff (List.rev x) let private_con_of_con env c = let cbo = Environ.lookup_constant c env.env in { Entries.from_env = CEphemeron.create env.revstruct; Entries.eff = Entries.SEsubproof (c,cbo,get_opaque_body env.env cbo) } let private_con_of_scheme ~kind env cl = { Entries.from_env = CEphemeron.create env.revstruct; Entries.eff = Entries.SEscheme( List.map (fun (i,c) -> let cbo = Environ.lookup_constant c env.env in i, c, cbo, get_opaque_body env.env cbo) cl, kind) } let universes_of_private eff = let open Declarations in List.fold_left (fun acc { Entries.eff } -> match eff with | Entries.SEscheme (l,s) -> List.fold_left (fun acc (_,_,cb,c) -> let acc = match c with | `Nothing -> acc | `Opaque (_, ctx) -> ctx :: acc in if cb.const_polymorphic then acc else (Univ.ContextSet.of_context cb.const_universes) :: acc) acc l | Entries.SEsubproof (c, cb, e) -> if cb.const_polymorphic then acc else Univ.ContextSet.of_context cb.const_universes :: acc) [] eff let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env type constraints_addition = | Now of bool * Univ.ContextSet.t | Later of Univ.ContextSet.t Future.computation let add_constraints cst senv = match cst with | Later fc -> {senv with future_cst = fc :: senv.future_cst} | Now (poly,cst) -> { senv with env = Environ.push_context_set ~strict:(not poly) cst senv.env; univ = Univ.ContextSet.union cst senv.univ } let add_constraints_list cst senv = List.fold_left (fun acc c -> add_constraints c acc) senv cst let push_context_set poly ctx = add_constraints (Now (poly,ctx)) let push_context poly ctx = add_constraints (Now (poly,Univ.ContextSet.of_context ctx)) let is_curmod_library senv = match senv.modvariant with LIBRARY -> true | _ -> false let join_safe_environment ?(except=Future.UUIDSet.empty) e = Modops.join_structure except (Environ.opaque_tables e.env) e.revstruct; List.fold_left (fun e fc -> if Future.UUIDSet.mem (Future.uuid fc) except then e else add_constraints (Now (false, Future.join fc)) e) {e with future_cst = []} e.future_cst let is_joined_environment e = List.is_empty e.future_cst (** {6 Various checks } *) let exists_modlabel l senv = Label.Set.mem l senv.modlabels let exists_objlabel l senv = Label.Set.mem l senv.objlabels let check_modlabel l senv = if exists_modlabel l senv then Modops.error_existing_label l let check_objlabel l senv = if exists_objlabel l senv then Modops.error_existing_label l let check_objlabels ls senv = Label.Set.iter (fun l -> check_objlabel l senv) ls (** Are we closing the right module / modtype ? No user error here, since the opening/ending coherence is now verified in [vernac_end_segment] *) let check_current_label lab = function | MPdot (_,l) -> assert (Label.equal lab l) | _ -> assert false let check_struct = function | STRUCT (params,oldsenv) -> params, oldsenv | NONE | LIBRARY | SIG _ -> assert false let check_sig = function | SIG (params,oldsenv) -> params, oldsenv | NONE | LIBRARY | STRUCT _ -> assert false let check_current_library dir senv = match senv.modvariant with | LIBRARY -> assert (ModPath.equal senv.modpath (MPfile dir)) | NONE | STRUCT _ | SIG _ -> assert false (* cf Lib.end_compilation *) (** When operating on modules, we're normally outside sections *) let check_empty_context senv = assert (Environ.empty_context senv.env) (** When adding a parameter to the current module/modtype, it must have been freshly started *) let check_empty_struct senv = assert (List.is_empty senv.revstruct && List.is_empty senv.loads) (** When starting a library, the current environment should be initial i.e. only composed of Require's *) let check_initial senv = assert (is_initial senv) (** When loading a library, its dependencies should be already there, with the correct digests. *) let check_required current_libs needed = let check (id,required) = try let actual = DPMap.find id current_libs in if not(digest_match ~actual ~required) then CErrors.error ("Inconsistent assumptions over module "^(DirPath.to_string id)^".") with Not_found -> CErrors.error ("Reference to unknown module "^(DirPath.to_string id)^".") in Array.iter check needed (** {6 Insertion of section variables} *) (** They are now typed before being added to the environment. Same as push_named, but check that the variable is not already there. Should *not* be done in Environ because tactics add temporary hypothesis many many times, and the check performed here would cost too much. *) let safe_push_named d env = let id = get_id d in let _ = try let _ = Environ.lookup_named id env in CErrors.error ("Identifier "^Id.to_string id^" already defined.") with Not_found -> () in Environ.push_named d env let push_named_def (id,de) senv = let c,typ,univs = Term_typing.translate_local_def senv.revstruct senv.env id de in let poly = de.Entries.const_entry_polymorphic in let univs = Univ.ContextSet.of_context univs in let c, univs = match c with | Def c -> Mod_subst.force_constr c, univs | OpaqueDef o -> Opaqueproof.force_proof (Environ.opaque_tables senv.env) o, Univ.ContextSet.union univs (Opaqueproof.force_constraints (Environ.opaque_tables senv.env) o) | _ -> assert false in let senv' = push_context_set poly univs senv in let env'' = safe_push_named (LocalDef (id,c,typ)) senv'.env in univs, {senv' with env=env''} let push_named_assum ((id,t,poly),ctx) senv = let senv' = push_context_set poly ctx senv in let t = Term_typing.translate_local_assum senv'.env t in let env'' = safe_push_named (LocalAssum (id,t)) senv'.env in {senv' with env=env''} (** {6 Insertion of new declarations to current environment } *) let labels_of_mib mib = let add,get = let labels = ref Label.Set.empty in (fun id -> labels := Label.Set.add (Label.of_id id) !labels), (fun () -> !labels) in let visit_mip mip = add mip.mind_typename; Array.iter add mip.mind_consnames in Array.iter visit_mip mib.mind_packets; get () let globalize_constant_universes env cb = if cb.const_polymorphic then [Now (true, Univ.ContextSet.empty)] else let cstrs = Univ.ContextSet.of_context cb.const_universes in Now (false, cstrs) :: (match cb.const_body with | (Undef _ | Def _) -> [] | OpaqueDef lc -> match Opaqueproof.get_constraints (Environ.opaque_tables env) lc with | None -> [] | Some fc -> match Future.peek_val fc with | None -> [Later fc] | Some c -> [Now (false, c)]) let globalize_mind_universes mb = if mb.mind_polymorphic then [Now (true, Univ.ContextSet.empty)] else [Now (false, Univ.ContextSet.of_context mb.mind_universes)] let constraints_of_sfb env sfb = match sfb with | SFBconst cb -> globalize_constant_universes env cb | SFBmind mib -> globalize_mind_universes mib | SFBmodtype mtb -> [Now (false, mtb.mod_constraints)] | SFBmodule mb -> [Now (false, mb.mod_constraints)] (** A generic function for adding a new field in a same environment. It also performs the corresponding [add_constraints]. *) type generic_name = | C of constant | I of mutual_inductive | M (** name already known, cf the mod_mp field *) | MT (** name already known, cf the mod_mp field *) let add_field ((l,sfb) as field) gn senv = let mlabs,olabs = match sfb with | SFBmind mib -> let l = labels_of_mib mib in check_objlabels l senv; (Label.Set.empty,l) | SFBconst _ -> check_objlabel l senv; (Label.Set.empty, Label.Set.singleton l) | SFBmodule _ | SFBmodtype _ -> check_modlabel l senv; (Label.Set.singleton l, Label.Set.empty) in let cst = constraints_of_sfb senv.env sfb in let senv = add_constraints_list cst senv in let env' = match sfb, gn with | SFBconst cb, C con -> Environ.add_constant con cb senv.env | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env | SFBmodtype mtb, MT -> Environ.add_modtype mtb senv.env | SFBmodule mb, M -> Modops.add_module mb senv.env | _ -> assert false in { senv with env = env'; revstruct = field :: senv.revstruct; modlabels = Label.Set.union mlabs senv.modlabels; objlabels = Label.Set.union olabs senv.objlabels } (** Applying a certain function to the resolver of a safe environment *) let update_resolver f senv = { senv with modresolver = f senv.modresolver } (** Insertion of constants and parameters in environment *) type global_declaration = | ConstantEntry of bool * private_constants Entries.constant_entry | GlobalRecipe of Cooking.recipe type exported_private_constant = constant * private_constants Entries.constant_entry * private_constant_role let add_constant_aux no_section senv (kn, cb) = let l = pi3 (Constant.repr3 kn) in let cb, otab = match cb.const_body with | OpaqueDef lc when no_section -> (* In coqc, opaque constants outside sections will be stored indirectly in a specific table *) let od, otab = Opaqueproof.turn_indirect (library_dp_of_senv senv) lc (Environ.opaque_tables senv.env) in { cb with const_body = OpaqueDef od }, otab | _ -> cb, (Environ.opaque_tables senv.env) in let senv = { senv with env = Environ.set_opaque_tables senv.env otab } in let senv' = add_field (l,SFBconst cb) (C kn) senv in let senv'' = match cb.const_body with | Undef (Some lev) -> update_resolver (Mod_subst.add_inline_delta_resolver (user_con kn) (lev,None)) senv' | _ -> senv' in senv'' let add_constant dir l decl senv = let kn = make_con senv.modpath dir l in let no_section = DirPath.is_empty dir in let seff_to_export, decl = match decl with | ConstantEntry (true, ce) -> let exports, ce = Term_typing.export_side_effects senv.revstruct senv.env ce in exports, ConstantEntry (false, ce) | _ -> [], decl in let senv = List.fold_left (add_constant_aux no_section) senv (List.map (fun (kn,cb,_,_) -> kn, cb) seff_to_export) in let senv = let cb = match decl with | ConstantEntry (export_seff,ce) -> Term_typing.translate_constant senv.revstruct senv.env kn ce | GlobalRecipe r -> let cb = Term_typing.translate_recipe senv.env kn r in if no_section then Declareops.hcons_const_body cb else cb in add_constant_aux no_section senv (kn, cb) in (kn, List.map (fun (kn,_,ce,r) -> kn, ce, r) seff_to_export), senv (** Insertion of inductive types *) let check_mind mie lab = let open Entries in match mie.mind_entry_inds with | [] -> assert false (* empty inductive entry *) | oie::_ -> (* The label and the first inductive type name should match *) assert (Id.equal (Label.to_id lab) oie.mind_entry_typename) let add_mind dir l mie senv = let () = check_mind mie l in let kn = make_mind senv.modpath dir l in let mib = Term_typing.translate_mind senv.env kn mie in let mib = match mib.mind_hyps with [] -> Declareops.hcons_mind mib | _ -> mib in kn, add_field (l,SFBmind mib) (I kn) senv (** Insertion of module types *) let add_modtype l params_mte inl senv = let mp = MPdot(senv.modpath, l) in let mtb = Mod_typing.translate_modtype senv.env mp inl params_mte in let mtb = Declareops.hcons_module_body mtb in let senv' = add_field (l,SFBmodtype mtb) MT senv in mp, senv' (** full_add_module adds module with universes and constraints *) let full_add_module mb senv = let senv = add_constraints (Now (false, mb.mod_constraints)) senv in let dp = ModPath.dp mb.mod_mp in let linkinfo = Nativecode.link_info_of_dirpath dp in { senv with env = Modops.add_linked_module mb linkinfo senv.env } let full_add_module_type mp mt senv = let senv = add_constraints (Now (false, mt.mod_constraints)) senv in { senv with env = Modops.add_module_type mp mt senv.env } (** Insertion of modules *) let add_module l me inl senv = let mp = MPdot(senv.modpath, l) in let mb = Mod_typing.translate_module senv.env mp inl me in let mb = Declareops.hcons_module_body mb in let senv' = add_field (l,SFBmodule mb) M senv in let senv'' = if Modops.is_functor mb.mod_type then senv' else update_resolver (Mod_subst.add_delta_resolver mb.mod_delta) senv' in (mp,mb.mod_delta),senv'' (** {6 Starting / ending interactive modules and module types } *) let start_module l senv = let () = check_modlabel l senv in let () = check_empty_context senv in let mp = MPdot(senv.modpath, l) in mp, { empty_environment with env = senv.env; modpath = mp; modvariant = STRUCT ([],senv); required = senv.required } let start_modtype l senv = let () = check_modlabel l senv in let () = check_empty_context senv in let mp = MPdot(senv.modpath, l) in mp, { empty_environment with env = senv.env; modpath = mp; modvariant = SIG ([], senv); required = senv.required } (** Adding parameters to the current module or module type. This module should have been freshly started. *) let add_module_parameter mbid mte inl senv = let () = check_empty_struct senv in let mp = MPbound mbid in let mtb = Mod_typing.translate_modtype senv.env mp inl ([],mte) in let senv = full_add_module_type mp mtb senv in let new_variant = match senv.modvariant with | STRUCT (params,oldenv) -> STRUCT ((mbid,mtb) :: params, oldenv) | SIG (params,oldenv) -> SIG ((mbid,mtb) :: params, oldenv) | _ -> assert false in let new_paramresolver = if Modops.is_functor mtb.mod_type then senv.paramresolver else Mod_subst.add_delta_resolver mtb.mod_delta senv.paramresolver in mtb.mod_delta, { senv with modvariant = new_variant; paramresolver = new_paramresolver } let functorize params init = List.fold_left (fun e (mbid,mt) -> MoreFunctor(mbid,mt,e)) init params let propagate_loads senv = List.fold_left (fun env (_,mb) -> full_add_module mb env) senv (List.rev senv.loads) (** Build the module body of the current module, taking in account a possible return type (_:T) *) let functorize_module params mb = let f x = functorize params x in { mb with mod_expr = Modops.implem_smartmap f f mb.mod_expr; mod_type = f mb.mod_type; mod_type_alg = Option.map f mb.mod_type_alg } let build_module_body params restype senv = let struc = NoFunctor (List.rev senv.revstruct) in let restype' = Option.map (fun (ty,inl) -> (([],ty),inl)) restype in let mb = Mod_typing.finalize_module senv.env senv.modpath (struc,None,senv.modresolver,senv.univ) restype' in let mb' = functorize_module params mb in { mb' with mod_retroknowledge = senv.local_retroknowledge } (** Returning back to the old pre-interactive-module environment, with one extra component and some updated fields (constraints, required, etc) *) let propagate_senv newdef newenv newresolver senv oldsenv = let now_cst, later_cst = List.partition Future.is_val senv.future_cst in (* This asserts that after Paral-ITP, standard vo compilation is behaving * exctly as before: the same universe constraints are added to modules *) if !Flags.compilation_mode = Flags.BuildVo && !Flags.async_proofs_mode = Flags.APoff then assert(later_cst = []); { oldsenv with env = newenv; modresolver = newresolver; revstruct = newdef::oldsenv.revstruct; modlabels = Label.Set.add (fst newdef) oldsenv.modlabels; univ = List.fold_left (fun acc cst -> Univ.ContextSet.union acc (Future.force cst)) (Univ.ContextSet.union senv.univ oldsenv.univ) now_cst; future_cst = later_cst @ oldsenv.future_cst; (* engagement is propagated to the upper level *) engagement = senv.engagement; required = senv.required; loads = senv.loads@oldsenv.loads; local_retroknowledge = senv.local_retroknowledge@oldsenv.local_retroknowledge; native_symbols = senv.native_symbols} let end_module l restype senv = let mp = senv.modpath in let params, oldsenv = check_struct senv.modvariant in let () = check_current_label l mp in let () = check_empty_context senv in let mbids = List.rev_map fst params in let mb = build_module_body params restype senv in let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in let newenv = set_engagement_opt newenv senv.engagement in let senv'= propagate_loads { senv with env = newenv; univ = Univ.ContextSet.union senv.univ mb.mod_constraints} in let newenv = Environ.push_context_set ~strict:true mb.mod_constraints senv'.env in let newenv = Modops.add_module mb newenv in let newresolver = if Modops.is_functor mb.mod_type then oldsenv.modresolver else Mod_subst.add_delta_resolver mb.mod_delta oldsenv.modresolver in (mp,mbids,mb.mod_delta), propagate_senv (l,SFBmodule mb) newenv newresolver senv' oldsenv let build_mtb mp sign cst delta = { mod_mp = mp; mod_expr = Abstract; mod_type = sign; mod_type_alg = None; mod_constraints = cst; mod_delta = delta; mod_retroknowledge = [] } let end_modtype l senv = let mp = senv.modpath in let params, oldsenv = check_sig senv.modvariant in let () = check_current_label l mp in let () = check_empty_context senv in let mbids = List.rev_map fst params in let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in let newenv = Environ.push_context_set ~strict:true senv.univ newenv in let newenv = set_engagement_opt newenv senv.engagement in let senv' = propagate_loads {senv with env=newenv} in let auto_tb = functorize params (NoFunctor (List.rev senv.revstruct)) in let mtb = build_mtb mp auto_tb senv'.univ senv.modresolver in let newenv = Environ.add_modtype mtb senv'.env in let newresolver = oldsenv.modresolver in (mp,mbids), propagate_senv (l,SFBmodtype mtb) newenv newresolver senv' oldsenv (** {6 Inclusion of module or module type } *) let add_include me is_module inl senv = let open Mod_typing in let mp_sup = senv.modpath in let sign,(),resolver,cst = translate_mse_incl is_module senv.env mp_sup inl me in let senv = add_constraints (Now (false, cst)) senv in (* Include Self support *) let rec compute_sign sign mb resolver senv = match sign with | MoreFunctor(mbid,mtb,str) -> let cst_sub = Subtyping.check_subtypes senv.env mb mtb in let senv = add_constraints (Now (false, Univ.ContextSet.add_constraints cst_sub Univ.ContextSet.empty)) senv in let mpsup_delta = Modops.inline_delta_resolver senv.env inl mp_sup mbid mtb mb.mod_delta in let subst = Mod_subst.map_mbid mbid mp_sup mpsup_delta in let resolver = Mod_subst.subst_codom_delta_resolver subst resolver in compute_sign (Modops.subst_signature subst str) mb resolver senv | NoFunctor str -> resolver,str,senv in let resolver,str,senv = let struc = NoFunctor (List.rev senv.revstruct) in let mtb = build_mtb mp_sup struc Univ.ContextSet.empty senv.modresolver in compute_sign sign mtb resolver senv in let senv = update_resolver (Mod_subst.add_delta_resolver resolver) senv in let add senv ((l,elem) as field) = let new_name = match elem with | SFBconst _ -> C (Mod_subst.constant_of_delta_kn resolver (KerName.make2 mp_sup l)) | SFBmind _ -> I (Mod_subst.mind_of_delta_kn resolver (KerName.make2 mp_sup l)) | SFBmodule _ -> M | SFBmodtype _ -> MT in add_field field new_name senv in resolver, List.fold_left add senv str (** {6 Libraries, i.e. compiled modules } *) type compiled_library = { comp_name : DirPath.t; comp_mod : module_body; comp_deps : library_info array; comp_enga : engagement; comp_natsymbs : Nativecode.symbols } type native_library = Nativecode.global list let get_library_native_symbols senv dir = DPMap.find dir senv.native_symbols (** FIXME: MS: remove?*) let current_modpath senv = senv.modpath let current_dirpath senv = Names.ModPath.dp (current_modpath senv) let start_library dir senv = check_initial senv; assert (not (DirPath.is_empty dir)); let mp = MPfile dir in mp, { empty_environment with env = senv.env; modpath = mp; modvariant = LIBRARY; required = senv.required } let export ?except senv dir = let senv = try join_safe_environment ?except senv with e -> let e = CErrors.push e in CErrors.errorlabstrm "export" (CErrors.iprint e) in assert(senv.future_cst = []); let () = check_current_library dir senv in let mp = senv.modpath in let str = NoFunctor (List.rev senv.revstruct) in let mb = { mod_mp = mp; mod_expr = FullStruct; mod_type = str; mod_type_alg = None; mod_constraints = senv.univ; mod_delta = senv.modresolver; mod_retroknowledge = senv.local_retroknowledge } in let ast, symbols = if !Flags.native_compiler then Nativelibrary.dump_library mp dir senv.env str else [], Nativecode.empty_symbols in let lib = { comp_name = dir; comp_mod = mb; comp_deps = Array.of_list (DPMap.bindings senv.required); comp_enga = Environ.engagement senv.env; comp_natsymbs = symbols } in mp, lib, ast (* cst are the constraints that were computed by the vi2vo step and hence are * not part of the mb.mod_constraints field (but morally should be) *) let import lib cst vodigest senv = check_required senv.required lib.comp_deps; check_engagement senv.env lib.comp_enga; if DirPath.equal (ModPath.dp senv.modpath) lib.comp_name then CErrors.errorlabstrm "Safe_typing.import" (Pp.strbrk "Cannot load a library with the same name as the current one."); let mp = MPfile lib.comp_name in let mb = lib.comp_mod in let env = Environ.push_context_set ~strict:true (Univ.ContextSet.union mb.mod_constraints cst) senv.env in mp, { senv with env = (let linkinfo = Nativecode.link_info_of_dirpath lib.comp_name in Modops.add_linked_module mb linkinfo env); modresolver = Mod_subst.add_delta_resolver mb.mod_delta senv.modresolver; required = DPMap.add lib.comp_name vodigest senv.required; loads = (mp,mb)::senv.loads; native_symbols = DPMap.add lib.comp_name lib.comp_natsymbs senv.native_symbols } (** {6 Safe typing } *) type judgment = Environ.unsafe_judgment let j_val j = j.Environ.uj_val let j_type j = j.Environ.uj_type let typing senv = Typeops.infer (env_of_senv senv) (** {6 Retroknowledge / native compiler } *) (** universal lifting, used for the "get" operations mostly *) let retroknowledge f senv = Environ.retroknowledge f (env_of_senv senv) let register field value by_clause senv = (* todo : value closed, by_clause safe, by_clause of the proper type*) (* spiwack : updates the safe_env with the information that the register action has to be performed (again) when the environment is imported *) { senv with env = Environ.register senv.env field value; local_retroknowledge = Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge } (* This function serves only for inlining constants in native compiler for now, but it is meant to become a replacement for environ.register *) let register_inline kn senv = let open Environ in let open Pre_env in if not (evaluable_constant kn senv.env) then CErrors.error "Register inline: an evaluable constant is expected"; let env = pre_env senv.env in let (cb,r) = Cmap_env.find kn env.env_globals.env_constants in let cb = {cb with const_inline_code = true} in let new_constants = Cmap_env.add kn (cb,r) env.env_globals.env_constants in let new_globals = { env.env_globals with env_constants = new_constants } in let env = { env with env_globals = new_globals } in { senv with env = env_of_pre_env env } let add_constraints c = add_constraints (Now (false, Univ.ContextSet.add_constraints c Univ.ContextSet.empty)) (* NB: The next old comment probably refers to [propagate_loads] above. When a Require is done inside a module, we'll redo this require at the upper level after the module is ended, and so on. This is probably not a big deal anyway, since these Require's inside modules should be pretty rare. Maybe someday we could brutally forbid this tricky "feature"... *) (* we have an inefficiency: Since loaded files are added to the environment every time a module is closed, their components are calculated many times. This could be avoided in several ways: 1 - for each file create a dummy environment containing only this file's components, merge this environment with the global environment, and store for the future (instead of just its type) 2 - create "persistent modules" environment table in Environ add put loaded by side-effect once and for all (like it is done in OCaml). Would this be correct with respect to undo's and stuff ? *) let set_strategy e k l = { e with env = (Environ.set_oracle e.env (Conv_oracle.set_strategy (Environ.oracle e.env) k l)) } coq-8.6/kernel/indtypes.ml0000644000175000017500000011237513022274260015141 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* idset | c::cl -> if Id.Set.mem c idset then raise (InductiveError (SameNamesConstructors c)) else check (Id.Set.add c idset) cl in check (* [mind_check_names mie] checks the names of an inductive types declaration, and raises the corresponding exceptions when two types or two constructors have the same name. *) let mind_check_names mie = let rec check indset cstset = function | [] -> () | ind::inds -> let id = ind.mind_entry_typename in let cl = ind.mind_entry_consnames in if Id.Set.mem id indset then raise (InductiveError (SameNamesTypes id)) else let cstset' = check_constructors_names cstset cl in check (Id.Set.add id indset) cstset' inds in check Id.Set.empty Id.Set.empty mie.mind_entry_inds (* The above verification is not necessary from the kernel point of vue since inductive and constructors are not referred to by their name, but only by the name of the inductive packet and an index. *) (************************************************************************) (************************************************************************) (* Typing the arities and constructor types *) (* An inductive definition is a "unit" if it has only one constructor and that all arguments expected by this constructor are logical, this is the case for equality, conjunction of logical properties *) let is_unit constrsinfos = match constrsinfos with (* One info = One constructor *) | [level] -> is_type0m_univ level | [] -> (* type without constructors *) true | _ -> false let infos_and_sort env t = let rec aux env t max = let t = whd_all env t in match kind_of_term t with | Prod (name,c1,c2) -> let varj = infer_type env c1 in let env1 = Environ.push_rel (LocalAssum (name,varj.utj_val)) env in let max = Universe.sup max (univ_of_sort varj.utj_type) in aux env1 c2 max | _ when is_constructor_head t -> max | _ -> (* don't fail if not positive, it is tested later *) max in aux env t Universe.type0m (* Computing the levels of polymorphic inductive types For each inductive type of a block that is of level u_i, we have the constraints that u_i >= v_i where v_i is the type level of the types of the constructors of this inductive type. Each v_i depends of some of the u_i and of an extra (maybe non variable) universe, say w_i that summarize all the other constraints. Typically, for three inductive types, we could have u1,u2,u3,w1 <= u1 u1 w2 <= u2 u2,u3,w3 <= u3 From this system of inequations, we shall deduce w1,w2,w3 <= u1 w1,w2 <= u2 w1,w2,w3 <= u3 *) (* This (re)computes informations relevant to extraction and the sort of an arity or type constructor; we do not to recompute universes constraints *) let infer_constructor_packet env_ar_par params lc = (* type-check the constructors *) let jlc = List.map (infer_type env_ar_par) lc in let jlc = Array.of_list jlc in (* generalize the constructor over the parameters *) let lc'' = Array.map (fun j -> it_mkProd_or_LetIn j.utj_val params) jlc in (* compute the max of the sorts of the products of the constructors types *) let levels = List.map (infos_and_sort env_ar_par) lc in let isunit = is_unit levels in let min = if Array.length jlc > 1 then Universe.type0 else Universe.type0m in let level = List.fold_left (fun max l -> Universe.sup max l) min levels in (lc'', (isunit, level)) (* If indices matter *) let cumulate_arity_large_levels env sign = fst (List.fold_right (fun d (lev,env) -> match d with | LocalAssum (_,t) -> let tj = infer_type env t in let u = univ_of_sort tj.utj_type in (Universe.sup u lev, push_rel d env) | LocalDef _ -> lev, push_rel d env) sign (Universe.type0m,env)) let is_impredicative env u = is_type0m_univ u || (is_type0_univ u && is_impredicative_set env) (* Returns the list [x_1, ..., x_n] of levels contributing to template polymorphism. The elements x_k is None if the k-th parameter (starting from the most recent and ignoring let-definitions) is not contributing or is Some u_k if its level is u_k and is contributing. *) let param_ccls paramsctxt = let fold acc = function | (LocalAssum (_, p)) -> (let c = strip_prod_assum p in match kind_of_term c with | Sort (Type u) -> Univ.Universe.level u | _ -> None) :: acc | LocalDef _ -> acc in List.fold_left fold [] paramsctxt (* Type-check an inductive definition. Does not check positivity conditions. *) (* TODO check that we don't overgeneralize construcors/inductive arities with universes that are absent from them. Is it possible? *) let typecheck_inductive env mie = let () = match mie.mind_entry_inds with | [] -> anomaly (Pp.str "empty inductive types declaration") | _ -> () in (* Check unicity of names *) mind_check_names mie; (* Params are typed-checked here *) let env' = push_context mie.mind_entry_universes env in let (env_params,paramsctxt) = infer_local_decls env' mie.mind_entry_params in (* We first type arity of each inductive definition *) (* This allows building the environment of arities and to share *) (* the set of constraints *) let env_arities, rev_arity_list = List.fold_left (fun (env_ar,l) ind -> (* Arities (without params) are typed-checked here *) let expltype = ind.mind_entry_template in let arity = if isArity ind.mind_entry_arity then let (ctx,s) = dest_arity env_params ind.mind_entry_arity in match s with | Type u when Univ.universe_level u = None -> (** We have an algebraic universe as the conclusion of the arity, typecheck the dummy Π ctx, Prop and do a special case for the conclusion. *) let proparity = infer_type env_params (mkArity (ctx, prop_sort)) in let (cctx, _) = destArity proparity.utj_val in (* Any universe is well-formed, we don't need to check [s] here *) mkArity (cctx, s) | _ -> let arity = infer_type env_params ind.mind_entry_arity in arity.utj_val else let arity = infer_type env_params ind.mind_entry_arity in arity.utj_val in let (sign, deflev) = dest_arity env_params arity in let inflev = (* The level of the inductive includes levels of indices if in indices_matter mode *) if !indices_matter then Some (cumulate_arity_large_levels env_params sign) else None in (* We do not need to generate the universe of full_arity; if later, after the validation of the inductive definition, full_arity is used as argument or subject to cast, an upper universe will be generated *) let full_arity = it_mkProd_or_LetIn arity paramsctxt in let id = ind.mind_entry_typename in let env_ar' = push_rel (LocalAssum (Name id, full_arity)) env_ar in (* (add_constraints cst2 env_ar) in *) (env_ar', (id,full_arity,sign @ paramsctxt,expltype,deflev,inflev)::l)) (env',[]) mie.mind_entry_inds in let arity_list = List.rev rev_arity_list in (* builds the typing context "Gamma, I1:A1, ... In:An, params" *) let env_ar_par = push_rel_context paramsctxt env_arities in (* Now, we type the constructors (without params) *) let inds = List.fold_right2 (fun ind arity_data inds -> let (lc',cstrs_univ) = infer_constructor_packet env_ar_par paramsctxt ind.mind_entry_lc in let consnames = ind.mind_entry_consnames in let ind' = (arity_data,consnames,lc',cstrs_univ) in ind'::inds) mie.mind_entry_inds arity_list ([]) in let inds = Array.of_list inds in (* Compute/check the sorts of the inductive types *) let inds = Array.map (fun ((id,full_arity,sign,expltype,def_level,inf_level),cn,lc,(is_unit,clev)) -> let infu = (** Inferred level, with parameters and constructors. *) match inf_level with | Some alev -> Universe.sup clev alev | None -> clev in let full_polymorphic () = let defu = Term.univ_of_sort def_level in let is_natural = type_in_type env || (UGraph.check_leq (universes env') infu defu) in let _ = (** Impredicative sort, always allow *) if is_impredicative env defu then () else (** Predicative case: the inferred level must be lower or equal to the declared level. *) if not is_natural then anomaly ~label:"check_inductive" (Pp.str"Incorrect universe " ++ Universe.pr defu ++ Pp.str " declared for inductive type, inferred level is " ++ Universe.pr infu) in RegularArity (not is_natural,full_arity,defu) in let template_polymorphic () = let sign, s = try dest_arity env full_arity with NotArity -> raise (InductiveError (NotAnArity (env, full_arity))) in match s with | Type u when expltype (* Explicitly polymorphic *) -> (* The polymorphic level is a function of the level of the *) (* conclusions of the parameters *) (* We enforce [u >= lev] in case [lev] has a strict upper *) (* constraints over [u] *) let b = type_in_type env || UGraph.check_leq (universes env') infu u in if not b then anomaly ~label:"check_inductive" (Pp.str"Incorrect universe " ++ Universe.pr u ++ Pp.str " declared for inductive type, inferred level is " ++ Universe.pr clev) else TemplateArity (param_ccls paramsctxt, infu) | _ (* Not an explicit occurrence of Type *) -> full_polymorphic () in let arity = if mie.mind_entry_polymorphic then full_polymorphic () else template_polymorphic () in (id,cn,lc,(sign,arity))) inds in (env_arities, env_ar_par, paramsctxt, inds) (************************************************************************) (************************************************************************) (* Positivity *) type ill_formed_ind = | LocalNonPos of int | LocalNotEnoughArgs of int | LocalNotConstructor of Context.Rel.t * int | LocalNonPar of int * int * int exception IllFormedInd of ill_formed_ind (* [mind_extract_params mie] extracts the params from an inductive types declaration, and checks that they are all present (and all the same) for all the given types. *) let mind_extract_params = decompose_prod_n_assum let explain_ind_err id ntyp env nparamsctxt c err = let (lparams,c') = mind_extract_params nparamsctxt c in match err with | LocalNonPos kt -> raise (InductiveError (NonPos (env,c',mkRel (kt+nparamsctxt)))) | LocalNotEnoughArgs kt -> raise (InductiveError (NotEnoughArgs (env,c',mkRel (kt+nparamsctxt)))) | LocalNotConstructor (paramsctxt,nargs)-> let nparams = Context.Rel.nhyps paramsctxt in raise (InductiveError (NotConstructor (env,id,c',mkRel (ntyp+nparamsctxt), nparams,nargs))) | LocalNonPar (n,i,l) -> raise (InductiveError (NonPar (env,c',n,mkRel i,mkRel (l+nparamsctxt)))) let failwith_non_pos n ntypes c = for k = n to n + ntypes - 1 do if not (noccurn k c) then raise (IllFormedInd (LocalNonPos (k-n+1))) done let failwith_non_pos_vect n ntypes v = Array.iter (failwith_non_pos n ntypes) v; anomaly ~label:"failwith_non_pos_vect" (Pp.str "some k in [n;n+ntypes-1] should occur") let failwith_non_pos_list n ntypes l = List.iter (failwith_non_pos n ntypes) l; anomaly ~label:"failwith_non_pos_list" (Pp.str "some k in [n;n+ntypes-1] should occur") (* Check the inductive type is called with the expected parameters *) (* [n] is the index of the last inductive type in [env] *) let check_correct_par (env,n,ntypes,_) paramdecls ind_index args = let nparams = Context.Rel.nhyps paramdecls in let args = Array.of_list args in if Array.length args < nparams then raise (IllFormedInd (LocalNotEnoughArgs ind_index)); let (params,realargs) = Array.chop nparams args in let nparamdecls = List.length paramdecls in let rec check param_index paramdecl_index = function | [] -> () | LocalDef _ :: paramdecls -> check param_index (paramdecl_index+1) paramdecls | _::paramdecls -> match kind_of_term (whd_all env params.(param_index)) with | Rel w when Int.equal w paramdecl_index -> check (param_index-1) (paramdecl_index+1) paramdecls | _ -> let paramdecl_index_in_env = paramdecl_index-n+nparamdecls+1 in let err = LocalNonPar (param_index+1, paramdecl_index_in_env, ind_index) in raise (IllFormedInd err) in check (nparams-1) (n-nparamdecls) paramdecls; if not (Array.for_all (noccur_between n ntypes) realargs) then failwith_non_pos_vect n ntypes realargs (* Computes the maximum number of recursive parameters: the first parameters which are constant in recursive arguments [n] is the current depth, [nmr] is the maximum number of possible recursive parameters *) let compute_rec_par (env,n,_,_) paramsctxt nmr largs = if Int.equal nmr 0 then 0 else (* start from 0, params will be in reverse order *) let (lpar,_) = List.chop nmr largs in let rec find k index = function ([],_) -> nmr | (_,[]) -> assert false (* |paramsctxt|>=nmr *) | (lp, LocalDef _ :: paramsctxt) -> find k (index-1) (lp,paramsctxt) | (p::lp,_::paramsctxt) -> ( match kind_of_term (whd_all env p) with | Rel w when Int.equal w index -> find (k+1) (index-1) (lp,paramsctxt) | _ -> k) in find 0 (n-1) (lpar,List.rev paramsctxt) (* [env] is the typing environment [n] is the dB of the last inductive type [ntypes] is the number of inductive types in the definition (i.e. range of inductives is [n; n+ntypes-1]) [lra] is the list of recursive tree of each variable *) let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = (push_rel (LocalAssum (x,a)) env, n+1, ntypes, (Norec,ra)::lra) let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lrecparams) = let auxntyp = 1 in let specif = (lookup_mind_specif env mi, u) in let ty = type_of_inductive env specif in let env' = let decl = LocalAssum (Anonymous, hnf_prod_applist env ty lrecparams) in push_rel decl env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in (* New index of the inductive types *) let newidx = n + auxntyp in (env', newidx, ntypes, ra_env') let rec ienv_decompose_prod (env,_,_,_ as ienv) n c = if Int.equal n 0 then (ienv,c) else let c' = whd_all env c in match kind_of_term c' with Prod(na,a,b) -> let ienv' = ienv_push_var ienv (na,a,mk_norec) in ienv_decompose_prod ienv' (n-1) b | _ -> assert false let array_min nmr a = if Int.equal nmr 0 then 0 else Array.fold_left (fun k (nmri,_) -> min k nmri) nmr a (** [check_positivity_one ienv paramsctxt (mind,i) nnonrecargs lcnames indlc] checks the positivity of the [i]-th member of the mutually inductive definition [mind]. It returns an [Rtree.t] which represents the position of the recursive calls of inductive in [i] for use by the guard condition (terms at these positions are considered sub-terms) as well as the number of of non-uniform arguments (used to generate induction schemes, so a priori less relevant to the kernel). If [chkpos] is [false] then positivity is assumed, and [check_positivity_one] computes the subterms occurrences in a best-effort fashion. *) let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt (_,i as ind) nnonrecargs lcnames indlc = let nparamsctxt = Context.Rel.length paramsctxt in let nmr = Context.Rel.nhyps paramsctxt in (** Positivity of one argument [c] of a constructor (i.e. the constructor [cn] has a type of the shape [… -> c … -> P], where, more generally, the arrows may be dependent). *) let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = let x,largs = decompose_app (whd_all env c) in match kind_of_term x with | Prod (na,b,d) -> let () = assert (List.is_empty largs) in (** If one of the inductives of the mutually inductive block occurs in the left-hand side of a product, then such an occurrence is a non-strictly-positive recursive call. Occurrences in the right-hand side of the product must be strictly positive.*) (match weaker_noccur_between env n ntypes b with | None when chkpos -> failwith_non_pos_list n ntypes [b] | None -> check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d | Some b -> check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d) | Rel k -> (try let (ra,rarg) = List.nth ra_env (k-1) in let largs = List.map (whd_all env) largs in let nmr1 = (match ra with Mrec _ -> compute_rec_par ienv paramsctxt nmr largs | _ -> nmr) in (** The case where one of the inductives of the mutually inductive block occurs as an argument of another is not known to be safe. So Coq rejects it. *) if chkpos && not (List.for_all (noccur_between n ntypes) largs) then failwith_non_pos_list n ntypes largs else (nmr1,rarg) with Failure _ | Invalid_argument _ -> (nmr,mk_norec)) | Ind ind_kn -> (** If one of the inductives of the mutually inductive block being defined appears in a parameter, then we have a nested inductive type. The positivity is then discharged to the [check_positive_nested] function. *) if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec) else check_positive_nested ienv nmr (ind_kn, largs) | err -> (** If an inductive of the mutually inductive block appears in any other way, then the positivy check gives up. *) if not chkpos || (noccur_between n ntypes x && List.for_all (noccur_between n ntypes) largs) then (nmr,mk_norec) else failwith_non_pos_list n ntypes (x::largs) (** [check_positive_nested] handles the case of nested inductive calls, that is, when an inductive types from the mutually inductive block is called as an argument of an inductive types (for the moment, this inductive type must be a previously defined types, not one of the types of the mutually inductive block being defined). *) (* accesses to the environment are not factorised, but is it worth? *) and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr ((mi,u), largs) = let (mib,mip) = lookup_mind_specif env mi in let auxnrecpar = mib.mind_nparams_rec in let auxnnonrecpar = mib.mind_nparams - auxnrecpar in let (auxrecparams,auxnonrecargs) = try List.chop auxnrecpar largs with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in (** Inductives of the inductive block being defined are only allowed to appear nested in the parameters of another inductive type. Not in the proper indices. *) if chkpos && not (List.for_all (noccur_between n ntypes) auxnonrecargs) then failwith_non_pos_list n ntypes auxnonrecargs; (* Nested mutual inductive types are not supported *) let auxntyp = mib.mind_ntypes in if not (Int.equal auxntyp 1) then raise (IllFormedInd (LocalNonPos n)); (* The nested inductive type with parameters removed *) let auxlcvect = abstract_mind_lc auxntyp auxnrecpar mip.mind_nf_lc in (* Extends the environment with a variable corresponding to the inductive def *) let (env',_,_,_ as ienv') = ienv_push_inductive ienv ((mi,u),auxrecparams) in (* Parameters expressed in env' *) let auxrecparams' = List.map (lift auxntyp) auxrecparams in let irecargs_nmr = (** Checks that the "nesting" inductive type is covariant in the relevant parameters. In other words, that the (nested) parameters which are instantiated with inductives of the mutually inductive block occur positively in the types of the nested constructors. *) Array.map (function c -> let c' = hnf_prod_applist env' c auxrecparams' in (* skip non-recursive parameters *) let (ienv',c') = ienv_decompose_prod ienv' auxnnonrecpar c' in check_constructors ienv' false nmr c') auxlcvect in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr in (nmr',(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0)) (** [check_constructors ienv check_head nmr c] checks the positivity condition in the type [c] of a constructor (i.e. that recursive calls to the inductives of the mutually inductive definition appear strictly positively in each of the arguments of the constructor, see also [check_pos]). If [check_head] is [true], then the type of the fully applied constructor (the "head" of the type [c]) is checked to be the right (properly applied) inductive type. *) and check_constructors ienv check_head nmr c = let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c = let x,largs = decompose_app (whd_all env c) in match kind_of_term x with | Prod (na,b,d) -> let () = assert (List.is_empty largs) in if not recursive && not (noccur_between n ntypes b) then raise (InductiveError BadEntry); let nmr',recarg = check_pos ienv nmr b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in check_constr_rec ienv' nmr' (recarg::lrec) d | hd -> let () = if check_head then begin match hd with | Rel j when Int.equal j (n + ntypes - i - 1) -> check_correct_par ienv paramsctxt (ntypes - i) largs | _ -> raise (IllFormedInd (LocalNotConstructor(paramsctxt,nnonrecargs))) end else if chkpos && not (List.for_all (noccur_between n ntypes) largs) then failwith_non_pos_list n ntypes largs in (nmr, List.rev lrec) in check_constr_rec ienv nmr [] c in let irecargs_nmr = Array.map2 (fun id c -> let _,rawc = mind_extract_params nparamsctxt c in try check_constructors ienv true nmr rawc with IllFormedInd err -> explain_ind_err id (ntypes-i) env nparamsctxt c err) (Array.of_list lcnames) indlc in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr in (nmr', mk_paths (Mrec ind) irecargs) (** [check_positivity ~chkpos kn env_ar paramsctxt inds] checks that the mutually inductive block [inds] is strictly positive. If [chkpos] is [false] then positivity is assumed, and [check_positivity_one] computes the subterms occurrences in a best-effort fashion. *) let check_positivity ~chkpos kn env_ar_par paramsctxt finite inds = let ntypes = Array.length inds in let recursive = finite != Decl_kinds.BiFinite in let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in let ra_env_ar = Array.rev_to_list rc in let nparamsctxt = Context.Rel.length paramsctxt in let nmr = Context.Rel.nhyps paramsctxt in let check_one i (_,lcnames,lc,(sign,_)) = let ra_env_ar_par = List.init nparamsctxt (fun _ -> (Norec,mk_norec)) @ ra_env_ar in let ienv = (env_ar_par, 1+nparamsctxt, ntypes, ra_env_ar_par) in let nnonrecargs = Context.Rel.nhyps sign - nmr in check_positivity_one ~chkpos recursive ienv paramsctxt (kn,i) nnonrecargs lcnames lc in let irecargs_nmr = Array.mapi check_one inds in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr in (nmr',Rtree.mk_rec irecargs) (************************************************************************) (************************************************************************) (* Build the inductive packet *) (* Allowed eliminations *) let all_sorts = [InProp;InSet;InType] let small_sorts = [InProp;InSet] let logical_sorts = [InProp] let allowed_sorts is_smashed s = if not is_smashed then (** Naturally in the defined sort. If [s] is Prop, it must be small and unitary. Unsmashed, predicative Type and Set: all elimination allowed as well. *) all_sorts else match family_of_sort s with (* Type: all elimination allowed: above and below *) | InType -> all_sorts (* Smashed Set is necessarily impredicative: forbids large elimination *) | InSet -> small_sorts (* Smashed to Prop, no informative eliminations allowed *) | InProp -> logical_sorts (* Previous comment: *) (* Unitary/empty Prop: elimination to all sorts are realizable *) (* unless the type is large. If it is large, forbids large elimination *) (* which otherwise allows simulating the inconsistent system Type:Type. *) (* -> this is now handled by is_smashed: *) (* - all_sorts in case of small, unitary Prop (not smashed) *) (* - logical_sorts in case of large, unitary Prop (smashed) *) let arity_conclusion = function | RegularArity (_, c, _) -> c | TemplateArity (_, s) -> mkType s let fold_inductive_blocks f = Array.fold_left (fun acc (_,_,lc,(arsign,ar)) -> f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (arity_conclusion ar) arsign)) let used_section_variables env inds = let ids = fold_inductive_blocks (fun l c -> Id.Set.union (Environ.global_vars_set env c) l) Id.Set.empty inds in keep_hyps env ids let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) let rel_list n m = Array.to_list (rel_vect n m) exception UndefinableExpansion (** From a rel context describing the constructor arguments, build an expansion function. The term built is expecting to be substituted first by a substitution of the form [params, x : ind params] *) let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params mind_consnrealdecls mind_consnrealargs paramslet ctx = let mp, dp, l = repr_mind kn in (** We build a substitution smashing the lets in the record parameters so that typechecking projections requires just a substitution and not matching with a parameter context. *) let indty, paramsletsubst = (* [ty] = [Ind inst] is typed in context [params] *) let inst = Context.Rel.to_extended_vect 0 paramslet in let ty = mkApp (mkIndU indu, inst) in (* [Ind inst] is typed in context [params-wo-let] *) let inst' = rel_list 0 nparamargs in (* {params-wo-let |- subst:params] *) let subst = subst_of_rel_context_instance paramslet inst' in (* {params-wo-let, x:Ind inst' |- subst':(params,x:Ind inst)] *) let subst = (* For the record parameter: *) mkRel 1 :: List.map (lift 1) subst in ty, subst in let ci = let print_info = { ind_tags = []; cstr_tags = [|Context.Rel.to_tags ctx|]; style = LetStyle } in { ci_ind = ind; ci_npar = nparamargs; ci_cstr_ndecls = mind_consnrealdecls; ci_cstr_nargs = mind_consnrealargs; ci_pp_info = print_info } in let len = List.length ctx in let x = Name x in let compat_body ccl i = (* [ccl] is defined in context [params;x:indty] *) (* [ccl'] is defined in context [params;x:indty;x:indty] *) let ccl' = liftn 1 2 ccl in let p = mkLambda (x, lift 1 indty, ccl') in let branch = it_mkLambda_or_LetIn (mkRel (len - i)) ctx in let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in it_mkLambda_or_LetIn (mkLambda (x,indty,body)) params in let projections decl (i, j, kns, pbs, subst, letsubst) = match decl with | LocalDef (na,c,t) -> (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] to [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] *) let c = liftn 1 j c in (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] to [params, x:I |- c(params,proj1 x,..,projj x)] *) let c1 = substl subst c in (* From [params, x:I |- subst:field1,..,fieldj] to [params, x:I |- subst:field1,..,fieldj+1] where [subst] is represented with instance of field1 last *) let subst = c1 :: subst in (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] to [params-wo-let, x:I |- c(params,proj1 x,..,projj x)] *) let c2 = substl letsubst c in (* From [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj)] to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *) let letsubst = c2 :: letsubst in (i, j+1, kns, pbs, subst, letsubst) | LocalAssum (na,t) -> match na with | Name id -> let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)] to [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj] *) let t = liftn 1 j t in (* from [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj)] to [params-wo-let, x:I |- t(params,proj1 x,..,projj x)] *) let projty = substl letsubst t in (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)] to [params, x:I |- t(proj1 x,..,projj x)] *) let ty = substl subst t in let term = mkProj (Projection.make kn true, mkRel 1) in let fterm = mkProj (Projection.make kn false, mkRel 1) in let compat = compat_body ty (j - 1) in let etab = it_mkLambda_or_LetIn (mkLambda (x, indty, term)) params in let etat = it_mkProd_or_LetIn (mkProd (x, indty, ty)) params in let body = { proj_ind = fst ind; proj_npars = nparamargs; proj_arg = i; proj_type = projty; proj_eta = etab, etat; proj_body = compat } in (i + 1, j + 1, kn :: kns, body :: pbs, fterm :: subst, fterm :: letsubst) | Anonymous -> raise UndefinableExpansion in let (_, _, kns, pbs, subst, letsubst) = List.fold_right projections ctx (0, 1, [], [], [], paramsletsubst) in Array.of_list (List.rev kns), Array.of_list (List.rev pbs) let build_inductive env p prv ctx env_ar paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env inds in let nparamargs = Context.Rel.nhyps paramsctxt in let nparamsctxt = Context.Rel.length paramsctxt in let subst, ctx = Univ.abstract_universes p ctx in let paramsctxt = Vars.subst_univs_level_context subst paramsctxt in let env_ar = let ctx = Environ.rel_context env_ar in let ctx' = Vars.subst_univs_level_context subst ctx in Environ.push_rel_context ctx' env in (* Check one inductive *) let build_one_packet (id,cnames,lc,(ar_sign,ar_kind)) recarg = (* Type of constructors in normal form *) let lc = Array.map (Vars.subst_univs_level_constr subst) lc in let splayed_lc = Array.map (dest_prod_assum env_ar) lc in let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in let consnrealdecls = Array.map (fun (d,_) -> Context.Rel.length d - nparamsctxt) splayed_lc in let consnrealargs = Array.map (fun (d,_) -> Context.Rel.nhyps d - nparamargs) splayed_lc in (* Elimination sorts *) let arkind,kelim = match ar_kind with | TemplateArity (paramlevs, lev) -> let ar = {template_param_levels = paramlevs; template_level = lev} in TemplateArity ar, all_sorts | RegularArity (info,ar,defs) -> let s = sort_of_univ defs in let kelim = allowed_sorts info s in let ar = RegularArity { mind_user_arity = Vars.subst_univs_level_constr subst ar; mind_sort = sort_of_univ (Univ.subst_univs_level_universe subst defs); } in ar, kelim in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in let transf num = let arity = List.length (dest_subterms recarg).(num) in if Int.equal arity 0 then let p = (!nconst, 0) in incr nconst; p else let p = (!nblock + 1, arity) in incr nblock; p (* les tag des constructeur constant commence a 0, les tag des constructeur non constant a 1 (0 => accumulator) *) in let rtbl = Array.init (List.length cnames) transf in (* Build the inductive packet *) { mind_typename = id; mind_arity = arkind; mind_arity_ctxt = Vars.subst_univs_level_context subst ar_sign; mind_nrealargs = Context.Rel.nhyps ar_sign - nparamargs; mind_nrealdecls = Context.Rel.length ar_sign - nparamsctxt; mind_kelim = kelim; mind_consnames = Array.of_list cnames; mind_consnrealdecls = consnrealdecls; mind_consnrealargs = consnrealargs; mind_user_lc = lc; mind_nf_lc = nf_lc; mind_recargs = recarg; mind_nb_constant = !nconst; mind_nb_args = !nblock; mind_reloc_tbl = rtbl; } in let packets = Array.map2 build_one_packet inds recargs in let pkt = packets.(0) in let isrecord = match isrecord with | Some (Some rid) when pkt.mind_kelim == all_sorts && Array.length pkt.mind_consnames == 1 && pkt.mind_consnrealargs.(0) > 0 -> (** The elimination criterion ensures that all projections can be defined. *) let u = if p then subst_univs_level_instance subst (Univ.UContext.instance ctx) else Univ.Instance.empty in let indsp = ((kn, 0), u) in let rctx, indty = decompose_prod_assum (subst1 (mkIndU indsp) pkt.mind_nf_lc.(0)) in (try let fields, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in let kns, projs = compute_projections indsp pkt.mind_typename rid nparamargs paramsctxt pkt.mind_consnrealdecls pkt.mind_consnrealargs paramslet fields in Some (Some (rid, kns, projs)) with UndefinableExpansion -> Some None) | Some _ -> Some None | None -> None in (* Build the mutual inductive *) { mind_record = isrecord; mind_ntypes = ntypes; mind_finite = isfinite; mind_hyps = hyps; mind_nparams = nparamargs; mind_nparams_rec = nmr; mind_params_ctxt = paramsctxt; mind_packets = packets; mind_polymorphic = p; mind_universes = ctx; mind_private = prv; mind_typing_flags = Environ.typing_flags env; } (************************************************************************) (************************************************************************) let check_inductive env kn mie = (* First type-check the inductive definition *) let (env_ar, env_ar_par, paramsctxt, inds) = typecheck_inductive env mie in (* Then check positivity conditions *) let chkpos = (Environ.typing_flags env).check_guarded in let (nmr,recargs) = check_positivity ~chkpos kn env_ar_par paramsctxt mie.mind_entry_finite inds in (* Build the inductive packets *) build_inductive env mie.mind_entry_polymorphic mie.mind_entry_private mie.mind_entry_universes env_ar paramsctxt kn mie.mind_entry_record mie.mind_entry_finite inds nmr recargs coq-8.6/kernel/doc.tex0000644000175000017500000000042513022274260014227 0ustar mdenesmdenes \newpage \section*{The Coq kernel} \ocwsection \label{kernel} This chapter describes the \Coq\ kernel, which is a type checker for the \CCI. The modules of the kernel are organized as follows. \bigskip \begin{center}\epsfig{file=kernel.dep.ps,width=\linewidth}\end{center} coq-8.6/kernel/esubst.mli0000644000175000017500000000546113022274260014755 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a subs val subs_cons: 'a array * 'a subs -> 'a subs val subs_shft: int * 'a subs -> 'a subs val subs_lift: 'a subs -> 'a subs val subs_liftn: int -> 'a subs -> 'a subs (** [subs_shift_cons(k,s,[|t1..tn|])] builds (^k s).t1..tn *) val subs_shift_cons: int * 'a subs * 'a array -> 'a subs (** [expand_rel k subs] expands de Bruijn [k] in the explicit substitution [subs]. The result is either (Inl(lams,v)) when the variable is substituted by value [v] under lams binders (i.e. v *has* to be shifted by lams), or (Inr (k',p)) when the variable k is just relocated as k'; p is None if the variable points inside subs and Some(k) if the variable points k bindings beyond subs (cf argument of ESID). *) val expand_rel: int -> 'a subs -> (int * 'a, int * int option) Util.union (** Tests whether a substitution behaves like the identity *) val is_subs_id: 'a subs -> bool (** Composition of substitutions: [comp mk_clos s1 s2] computes a substitution equivalent to applying s2 then s1. Argument mk_clos is used when a closure has to be created, i.e. when s1 is applied on an element of s2. *) val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs (** {6 Compact representation } *) (** Compact representation of explicit relocations - [ELSHFT(l,n)] == lift of [n], then apply [lift l]. - [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. *) type lift = private | ELID | ELSHFT of lift * int | ELLFT of int * lift val el_id : lift val el_shft : int -> lift -> lift val el_liftn : int -> lift -> lift val el_lift : lift -> lift val reloc_rel : int -> lift -> int val is_lift_id : lift -> bool coq-8.6/kernel/csymtable.ml0000644000175000017500000001631313022274260015260 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int -> tcode = "coq_tcode_of_code" external eval_tcode : tcode -> values array -> values = "coq_eval_tcode" (*******************) (* Linkage du code *) (*******************) (* Table des globaux *) (* [global_data] contient les valeurs des constantes globales (axiomes,definitions), les annotations des switch et les structured constant *) external global_data : unit -> values array = "get_coq_global_data" (* [realloc_global_data n] augmente de n la taille de [global_data] *) external realloc_global_data : int -> unit = "realloc_coq_global_data" let check_global_data n = if n >= Array.length (global_data()) then realloc_global_data n let num_global = ref 0 let set_global v = let n = !num_global in check_global_data n; (global_data()).(n) <- v; incr num_global; n (* table pour les structured_constant et les annotations des switchs *) let rec eq_structured_constant c1 c2 = match c1, c2 with | Const_sorts s1, Const_sorts s2 -> Sorts.equal s1 s2 | Const_sorts _, _ -> false | Const_ind i1, Const_ind i2 -> eq_ind i1 i2 | Const_ind _, _ -> false | Const_proj p1, Const_proj p2 -> Constant.equal p1 p2 | Const_proj _, _ -> false | Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2 | Const_b0 _, _ -> false | Const_bn (t1, a1), Const_bn (t2, a2) -> Int.equal t1 t2 && Array.equal eq_structured_constant a1 a2 | Const_bn _, _ -> false | Const_univ_level l1 , Const_univ_level l2 -> Univ.eq_levels l1 l2 | Const_univ_level _ , _ -> false | Const_type u1 , Const_type u2 -> Univ.Universe.equal u1 u2 | Const_type _ , _ -> false let rec hash_structured_constant c = let open Hashset.Combine in match c with | Const_sorts s -> combinesmall 1 (Sorts.hash s) | Const_ind i -> combinesmall 2 (ind_hash i) | Const_proj p -> combinesmall 3 (Constant.hash p) | Const_b0 t -> combinesmall 4 (Int.hash t) | Const_bn (t, a) -> let fold h c = combine h (hash_structured_constant c) in let h = Array.fold_left fold 0 a in combinesmall 5 (combine (Int.hash t) h) | Const_univ_level l -> combinesmall 6 (Univ.Level.hash l) | Const_type u -> combinesmall 7 (Univ.Universe.hash u) module SConstTable = Hashtbl.Make (struct type t = structured_constant let equal = eq_structured_constant let hash = hash_structured_constant end) let eq_annot_switch asw1 asw2 = let eq_ci ci1 ci2 = eq_ind ci1.ci_ind ci2.ci_ind && Int.equal ci1.ci_npar ci2.ci_npar && Array.equal Int.equal ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls in let eq_rlc (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 in eq_ci asw1.ci asw2.ci && Array.equal eq_rlc asw1.rtbl asw2.rtbl && (asw1.tailcall : bool) == asw2.tailcall let hash_annot_switch asw = let open Hashset.Combine in let h1 = Constr.case_info_hash asw.ci in let h2 = Array.fold_left (fun h (t, i) -> combine3 h t i) 0 asw.rtbl in let h3 = if asw.tailcall then 1 else 0 in combine3 h1 h2 h3 module AnnotTable = Hashtbl.Make (struct type t = annot_switch let equal = eq_annot_switch let hash = hash_annot_switch end) let str_cst_tbl : int SConstTable.t = SConstTable.create 31 let annot_tbl : int AnnotTable.t = AnnotTable.create 31 (* (annot_switch * int) Hashtbl.t *) (*************************************************************) (*** Mise a jour des valeurs des variables et des constantes *) (*************************************************************) exception NotEvaluated let key rk = match !rk with | None -> raise NotEvaluated | Some k -> try CEphemeron.get k with CEphemeron.InvalidKey -> raise NotEvaluated (************************) (* traduction des patch *) (* slot_for_*, calcul la valeur de l'objet, la place dans la table global, rend sa position dans la table *) let slot_for_str_cst key = try SConstTable.find str_cst_tbl key with Not_found -> let n = set_global (val_of_str_const key) in SConstTable.add str_cst_tbl key n; n let slot_for_annot key = try AnnotTable.find annot_tbl key with Not_found -> let n = set_global (val_of_annot_switch key) in AnnotTable.add annot_tbl key n; n let rec slot_for_getglobal env kn = let (cb,(_,rk)) = lookup_constant_key kn env in try key rk with NotEvaluated -> (* Pp.msgnl(str"not yet evaluated");*) let pos = match cb.const_body_code with | None -> set_global (val_of_constant kn) | Some code -> match Cemitcodes.force code with | BCdefined(code,pl,fv) -> let v = eval_to_patch env (code,pl,fv) in set_global v | BCalias kn' -> slot_for_getglobal env kn' | BCconstant -> set_global (val_of_constant kn) in (*Pp.msgnl(str"value stored at: "++int pos);*) rk := Some (CEphemeron.create pos); pos and slot_for_fv env fv = let fill_fv_cache cache id v_of_id env_of_id b = let v,d = match b with | None -> v_of_id id, Id.Set.empty | Some c -> val_of_constr (env_of_id id env) c, Environ.global_vars_set (Environ.env_of_pre_env env) c in build_lazy_val cache (v, d); v in let val_of_rel i = val_of_rel (nb_rel env - i) in let idfun _ x = x in match fv with | FVnamed id -> let nv = Pre_env.lookup_named_val id env in begin match force_lazy_val nv with | None -> let open Context.Named in let open Declaration in env |> Pre_env.lookup_named id |> get_value |> fill_fv_cache nv id val_of_named idfun | Some (v, _) -> v end | FVrel i -> let rv = Pre_env.lookup_rel_val i env in begin match force_lazy_val rv with | None -> let open Context.Rel in let open Declaration in env.env_rel_context |> lookup i |> get_value |> fill_fv_cache rv i val_of_rel env_of_rel | Some (v, _) -> v end | FVuniv_var idu -> assert false and eval_to_patch env (buff,pl,fv) = let patch = function | Reloc_annot a, pos -> (pos, slot_for_annot a) | Reloc_const sc, pos -> (pos, slot_for_str_cst sc) | Reloc_getglobal kn, pos -> (pos, slot_for_getglobal env kn) in let patches = List.map_left patch pl in let buff = patch_int buff patches in let vm_env = Array.map (slot_for_fv env) fv in let tc = tcode_of_code buff (length buff) in eval_tcode tc vm_env and val_of_constr env c = match compile true env c with | Some v -> eval_to_patch env (to_memory v) | None -> assert false let set_transparent_const kn = () (* !?! *) let set_opaque_const kn = () (* !?! *) coq-8.6/kernel/cbytegen.ml0000644000175000017500000012270513022274260015100 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* *) (* type = [Ct1 | .... | Ctn] *) (* Ci is the code pointer of the i-th body *) (* At runtime, a fixpoint environment (which is the same as the fixpoint *) (* itself) is a pointer to the field holding its code pointer. *) (* In each fixpoint body, de Bruijn [nbr] represents the first fixpoint *) (* and de Bruijn [1] the last one. *) (* Access to these variables is performed by the [Koffsetclosure n] *) (* instruction that shifts the environment pointer of [n] fields. *) (* This allows representing mutual fixpoints in just one block. *) (* [Ct1 | ... | Ctn] is an array holding code pointers of the fixpoint *) (* types. They are used in conversion tests (which requires that *) (* fixpoint types must be convertible). Their environment is the one of *) (* the last fixpoint : *) (* [t1|C1| ... |tc|Cc| ... |t(nbr)|C(nbr)| fv1 | fv2 | .... | fvn | type] *) (* ^ *) (* Representation of mutual cofix : *) (* a1 = [A_t | accumulate | [Cfx_t | fcofix1 ] ] *) (* ... *) (* anbr = [A_t | accumulate | [Cfx_t | fcofixnbr ] ] *) (* *) (* fcofix1 = [clos_t | code1 | a1 |...| anbr | fv1 |...| fvn | type] *) (* ^ *) (* ... *) (* fcofixnbr = [clos_t | codenbr | a1 |...| anbr | fv1 |...| fvn | type] *) (* ^ *) (* The [ai] blocks are functions that accumulate their arguments: *) (* ai arg1 argp ---> *) (* ai' = [A_t | accumulate | [Cfx_t | fcofixi] | arg1 | ... | argp ] *) (* If such a block is matched against, we have to force evaluation, *) (* function [fcofixi] is then applied to [ai'] [arg1] ... [argp] *) (* Once evaluation is completed [ai'] is updated with the result: *) (* ai' <-- *) (* [A_t | accumulate | [Cfxe_t |fcofixi|result] | arg1 | ... | argp ] *) (* This representation is nice because the application of the cofix is *) (* evaluated only once (it simulates a lazy evaluation) *) (* Moreover, when cofix don't have arguments, it is possible to create *) (* a cycle, e.g.: *) (* cofix one := cons 1 one *) (* a1 = [A_t | accumulate | [Cfx_t|fcofix1] ] *) (* fcofix1 = [clos_t | code | a1] *) (* The result of evaluating [a1] is [cons_t | 1 | a1]. *) (* When [a1] is updated : *) (* a1 = [A_t | accumulate | [Cfxe_t | fcofix1 | [cons_t | 1 | a1]] ] *) (* The cycle is created ... *) (* *) (* In Cfxe_t accumulators, we need to store [fcofixi] for testing *) (* conversion of cofixpoints (which is intentional). *) module Config = struct let stack_threshold = 256 (* see byterun/coq_memory.h *) let stack_safety_margin = 15 end type argument = ArgConstr of Constr.t | ArgUniv of Univ.Level.t let empty_fv = { size= 0; fv_rev = []; fv_fwd = FvMap.empty } let push_fv d e = { size = e.size + 1; fv_rev = d :: e.fv_rev; fv_fwd = FvMap.add d e.size e.fv_fwd; } let fv r = !(r.in_env) let empty_comp_env ?(univs=0) ()= { nb_uni_stack = univs; nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; offset = 0; in_env = ref empty_fv } (* Maximal stack size reached during the current function body. Used to reallocate the stack if we lack space. *) let max_stack_size = ref 0 let set_max_stack_size stack_size = if stack_size > !max_stack_size then max_stack_size := stack_size let ensure_stack_capacity f x = let old = !max_stack_size in max_stack_size := 0; let code = f x in let used_safe = !max_stack_size + Config.stack_safety_margin in max_stack_size := old; if used_safe > Config.stack_threshold then Kensurestackcapacity used_safe :: code else code (*i Creation functions for comp_env *) let rec add_param n sz l = if Int.equal n 0 then l else add_param (n - 1) sz (n+sz::l) let comp_env_fun ?(univs=0) arity = { nb_uni_stack = univs ; nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = 0; pos_rec = []; offset = 1; in_env = ref empty_fv } let comp_env_fix_type rfv = { nb_uni_stack = 0; nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; offset = 1; in_env = rfv } let comp_env_fix ndef curr_pos arity rfv = let prec = ref [] in for i = ndef downto 1 do prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec done; { nb_uni_stack = 0; nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = ndef; pos_rec = !prec; offset = 2 * (ndef - curr_pos - 1)+1; in_env = rfv } let comp_env_cofix_type ndef rfv = { nb_uni_stack = 0; nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; offset = 1+ndef; in_env = rfv } let comp_env_cofix ndef arity rfv = let prec = ref [] in for i = 1 to ndef do prec := Kenvacc i :: !prec done; { nb_uni_stack = 0; nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = ndef; pos_rec = !prec; offset = ndef+1; in_env = rfv } (* [push_param ] add function parameters on the stack *) let push_param n sz r = { r with nb_stack = r.nb_stack + n; in_stack = add_param n sz r.in_stack } (* [push_local sz r] add a new variable on the stack at position [sz] *) let push_local sz r = { r with nb_stack = r.nb_stack + 1; in_stack = (sz + 1) :: r.in_stack } (*i Compilation of variables *) let find_at fv env = FvMap.find fv env.fv_fwd let pos_named id r = let env = !(r.in_env) in let cid = FVnamed id in try Kenvacc(r.offset + find_at cid env) with Not_found -> let pos = env.size in r.in_env := push_fv cid env; Kenvacc (r.offset + pos) let pos_rel i r sz = if i <= r.nb_stack then Kacc(sz - (List.nth r.in_stack (i-1))) else let i = i - r.nb_stack in if i <= r.nb_rec then try List.nth r.pos_rec (i-1) with (Failure _|Invalid_argument _) -> assert false else let i = i - r.nb_rec in let db = FVrel(i) in let env = !(r.in_env) in try Kenvacc(r.offset + find_at db env) with Not_found -> let pos = env.size in r.in_env := push_fv db env; Kenvacc(r.offset + pos) let pos_universe_var i r sz = if i < r.nb_uni_stack then Kacc (sz - r.nb_stack - (r.nb_uni_stack - i)) else let env = !(r.in_env) in let db = FVuniv_var i in try Kenvacc (r.offset + find_at db env) with Not_found -> let pos = env.size in r.in_env := push_fv db env; Kenvacc(r.offset + pos) (*i Examination of the continuation *) (* Discard all instructions up to the next label. *) (* This function is to be applied to the continuation before adding a *) (* non-terminating instruction (branch, raise, return, appterm) *) (* in front of it. *) let discard_dead_code cont = cont (*function [] -> [] | (Klabel _ | Krestart ) :: _ as cont -> cont | _ :: cont -> discard_dead_code cont *) (* Return a label to the beginning of the given continuation. *) (* If the sequence starts with a branch, use the target of that branch *) (* as the label, thus avoiding a jump to a jump. *) let label_code = function | Klabel lbl :: _ as cont -> (lbl, cont) | Kbranch lbl :: _ as cont -> (lbl, cont) | cont -> let lbl = Label.create() in (lbl, Klabel lbl :: cont) (* Return a branch to the continuation. That is, an instruction that, when executed, branches to the continuation or performs what the continuation performs. We avoid generating branches to returns. *) (* spiwack: make_branch was only used once. Changed it back to the ZAM one to match the appropriate semantics (old one avoided the introduction of an unconditional branch operation, which seemed appropriate for the 31-bit integers' code). As a memory, I leave the former version in this comment. let make_branch cont = match cont with | (Kreturn _ as return) :: cont' -> return, cont' | Klabel lbl as b :: _ -> b, cont | _ -> let b = Klabel(Label.create()) in b,b::cont *) let rec make_branch_2 lbl n cont = function Kreturn m :: _ -> (Kreturn (n + m), cont) | Klabel _ :: c -> make_branch_2 lbl n cont c | Kpop m :: c -> make_branch_2 lbl (n + m) cont c | _ -> match lbl with Some lbl -> (Kbranch lbl, cont) | None -> let lbl = Label.create() in (Kbranch lbl, Klabel lbl :: cont) let make_branch cont = match cont with (Kbranch _ as branch) :: _ -> (branch, cont) | (Kreturn _ as return) :: _ -> (return, cont) | Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont | _ -> make_branch_2 (None) 0 cont cont (* Check if we're in tailcall position *) let rec is_tailcall = function | Kreturn k :: _ -> Some k | Klabel _ :: c -> is_tailcall c | _ -> None (* Extention of the continuation *) (* Add a Kpop n instruction in front of a continuation *) let rec add_pop n = function | Kpop m :: cont -> add_pop (n+m) cont | Kreturn m:: cont -> Kreturn (n+m) ::cont | cont -> if Int.equal n 0 then cont else Kpop n :: cont let add_grab arity lbl cont = if Int.equal arity 1 then Klabel lbl :: cont else Krestart :: Klabel lbl :: Kgrab (arity - 1) :: cont let add_grabrec rec_arg arity lbl cont = if Int.equal arity 1 && rec_arg < arity then Klabel lbl :: Kgrabrec 0 :: Krestart :: cont else Krestart :: Klabel lbl :: Kgrabrec rec_arg :: Krestart :: Kgrab (arity - 1) :: cont (* continuation of a cofix *) let cont_cofix arity = (* accu = res *) (* stk = ai::args::ra::... *) (* ai = [At|accumulate|[Cfx_t|fcofix]|args] *) [ Kpush; Kpush; (* stk = res::res::ai::args::ra::... *) Kacc 2; Kfield 1; Kfield 0; Kmakeblock(2, cofix_evaluated_tag); Kpush; (* stk = [Cfxe_t|fcofix|res]::res::ai::args::ra::...*) Kacc 2; Ksetfield 1; (* ai = [At|accumulate|[Cfxe_t|fcofix|res]|args] *) (* stk = res::ai::args::ra::... *) Kacc 0; (* accu = res *) Kreturn (arity+2) ] (*i Global environment *) let global_env = ref empty_env let set_global_env env = global_env := env (* Code of closures *) let fun_code = ref [] let init_fun_code () = fun_code := [] (* Compilation of constructors and inductive types *) (* Limitation due to OCaml's representation of non-constant constructors: limited to 245 + 1 (0 tag) cases. *) exception TooLargeInductive of Id.t let max_nb_const = 0x1000000 let max_nb_block = 0x1000000 + last_variant_tag - 1 let str_max_constructors = Format.sprintf " which has more than %i constant constructors or more than %i non-constant constructors" max_nb_const max_nb_block let check_compilable ib = if not (ib.mind_nb_args <= max_nb_block && ib.mind_nb_constant <= max_nb_const) then raise (TooLargeInductive ib.mind_typename) (* Inv: arity > 0 *) let const_bn tag args = if tag < last_variant_tag then Const_bn(tag, args) else Const_bn(last_variant_tag, Array.append [|Const_b0 (tag - last_variant_tag) |] args) (* If [tag] hits the OCaml limitation for non constant constructors, we switch to another representation for the remaining constructors: [last_variant_tag|tag - last_variant_tag|args] We subtract last_variant_tag for efficiency of match interpretation. *) let nest_block tag arity cont = Kconst (Const_b0 (tag - last_variant_tag)) :: Kmakeblock(arity+1, last_variant_tag) :: cont let code_makeblock ~stack_size ~arity ~tag cont = if tag < last_variant_tag then Kmakeblock(arity, tag) :: cont else begin set_max_stack_size (stack_size + 1); Kpush :: nest_block tag arity cont end (* [code_construct] compiles an abstracted constructor dropping parameters and updates [fun_code] *) (* Inv : nparam + arity > 0 *) let code_construct tag nparams arity cont = let f_cont = add_pop nparams (if Int.equal arity 0 then [Kconst (Const_b0 tag); Kreturn 0] else if tag < last_variant_tag then [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0] else nest_block tag arity [Kreturn 0]) in let lbl = Label.create() in (* No need to grow the stack here, as the function does not push stuff. *) fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)]; Kclosure(lbl,0) :: cont let get_strcst = function | Bstrconst sc -> sc | _ -> raise Not_found let rec str_const c = match kind_of_term c with | Sort s -> Bstrconst (Const_sorts s) | Cast(c,_,_) -> str_const c | App(f,args) -> begin match kind_of_term f with | Construct(((kn,j),i),u) -> begin let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in let () = check_compilable oip in let tag,arity = oip.mind_reloc_tbl.(i-1) in let nparams = oib.mind_nparams in if Int.equal (nparams + arity) (Array.length args) then (* spiwack: *) (* 1/ tries to compile the constructor in an optimal way, it is supposed to work only if the arguments are all fully constructed, fails with Cbytecodes.NotClosed. it can also raise Not_found when there is no special treatment for this constructor for instance: tries to to compile an integer of the form I31 D1 D2 ... D31 to [D1D2...D31] as a processor number (a caml number actually) *) try try Bstrconst (Retroknowledge.get_vm_constant_static_info (!global_env).retroknowledge f args) with NotClosed -> (* 2/ if the arguments are not all closed (this is expectingly (and it is currently the case) the only reason why this exception is raised) tries to give a clever, run-time behavior to the constructor. Raises Not_found if there is no special treatment for this integer. this is done in a lazy fashion, using the constructor Bspecial because it needs to know the continuation and such, which can't be done at this time. for instance, for int31: if one of the digit is not closed, it's not impossible that the number gets fully instanciated at run-time, thus to ensure uniqueness of the representation in the vm it is necessary to try and build a caml integer during the execution *) let rargs = Array.sub args nparams arity in let b_args = Array.map str_const rargs in Bspecial ((Retroknowledge.get_vm_constant_dynamic_info (!global_env).retroknowledge f), b_args) with Not_found -> (* 3/ if no special behavior is available, then the compiler falls back to the normal behavior *) if Int.equal arity 0 then Bstrconst(Const_b0 tag) else let rargs = Array.sub args nparams arity in let b_args = Array.map str_const rargs in try let sc_args = Array.map get_strcst b_args in Bstrconst(const_bn tag sc_args) with Not_found -> Bmakeblock(tag,b_args) else let b_args = Array.map str_const args in (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) try Bspecial ((Retroknowledge.get_vm_constant_dynamic_info (!global_env).retroknowledge f), b_args) with Not_found -> Bconstruct_app(tag, nparams, arity, b_args) end | _ -> Bconstr c end | Ind (ind,u) when Univ.Instance.is_empty u -> Bstrconst (Const_ind ind) | Construct (((kn,j),i),_) -> begin (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) try Bspecial ((Retroknowledge.get_vm_constant_dynamic_info (!global_env).retroknowledge c), [| |]) with Not_found -> let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in let () = check_compilable oip in let num,arity = oip.mind_reloc_tbl.(i-1) in let nparams = oib.mind_nparams in if Int.equal (nparams + arity) 0 then Bstrconst(Const_b0 num) else Bconstruct_app(num,nparams,arity,[||]) end | _ -> Bconstr c (* compiling application *) let comp_args comp_expr reloc args sz cont = let nargs_m_1 = Array.length args - 1 in let c = ref (comp_expr reloc args.(0) (sz + nargs_m_1) cont) in for i = 1 to nargs_m_1 do c := comp_expr reloc args.(i) (sz + nargs_m_1 - i) (Kpush :: !c) done; !c (* Precondition: args not empty *) let comp_app comp_fun comp_arg reloc f args sz cont = let nargs = Array.length args in match is_tailcall cont with | Some k -> comp_args comp_arg reloc args sz (Kpush :: comp_fun reloc f (sz + nargs) (Kappterm(nargs, k + nargs) :: (discard_dead_code cont))) | None -> if nargs < 4 then comp_args comp_arg reloc args sz (Kpush :: (comp_fun reloc f (sz+nargs) (Kapply nargs :: cont))) else let lbl,cont1 = label_code cont in Kpush_retaddr lbl :: (comp_args comp_arg reloc args (sz + 3) (Kpush :: (comp_fun reloc f (sz+3+nargs) (Kapply nargs :: cont1)))) (* Compiling free variables *) let compile_fv_elem reloc fv sz cont = match fv with | FVrel i -> pos_rel i reloc sz :: cont | FVnamed id -> pos_named id reloc :: cont | FVuniv_var i -> pos_universe_var i reloc sz :: cont let rec compile_fv reloc l sz cont = match l with | [] -> cont | [fvn] -> set_max_stack_size (sz + 1); compile_fv_elem reloc fvn sz cont | fvn :: tl -> compile_fv_elem reloc fvn sz (Kpush :: compile_fv reloc tl (sz + 1) cont) (* Compiling constants *) let rec get_alias env kn = let cb = lookup_constant kn env in let tps = cb.const_body_code in match tps with | None -> kn | Some tps -> (match Cemitcodes.force tps with | BCalias kn' -> get_alias env kn' | _ -> kn) (* sz is the size of the local stack *) let rec compile_constr reloc c sz cont = set_max_stack_size sz; match kind_of_term c with | Meta _ -> invalid_arg "Cbytegen.compile_constr : Meta" | Evar _ -> invalid_arg "Cbytegen.compile_constr : Evar" | Proj (p,c) -> let kn = Projection.constant p in let cb = lookup_constant kn !global_env in let pb = Option.get cb.const_proj in let n = pb.proj_arg in compile_constr reloc c sz (Kproj (n,kn) :: cont) | Cast(c,_,_) -> compile_constr reloc c sz cont | Rel i -> pos_rel i reloc sz :: cont | Var id -> pos_named id reloc :: cont | Const (kn,u) -> compile_const reloc kn u [||] sz cont | Ind (ind,u) -> let bcst = Bstrconst (Const_ind ind) in if Univ.Instance.is_empty u then compile_str_cst reloc bcst sz cont else comp_app compile_str_cst compile_universe reloc bcst (Univ.Instance.to_array u) sz cont | Sort (Prop _) | Construct _ -> compile_str_cst reloc (str_const c) sz cont | Sort (Type u) -> (* We separate global and local universes in [u]. The former will be part of the structured constant, while the later (if any) will be applied as arguments. *) let open Univ in begin let levels = Universe.levels u in let global_levels = LSet.filter (fun x -> Level.var_index x = None) levels in let local_levels = List.map_filter (fun x -> Level.var_index x) (LSet.elements levels) in (* We assume that [Universe.type0m] is a neutral element for [Universe.sup] *) let uglob = LSet.fold (fun lvl u -> Universe.sup u (Universe.make lvl)) global_levels Universe.type0m in if local_levels = [] then compile_str_cst reloc (Bstrconst (Const_sorts (Type uglob))) sz cont else let compile_get_univ reloc idx sz cont = set_max_stack_size sz; compile_fv_elem reloc (FVuniv_var idx) sz cont in comp_app compile_str_cst compile_get_univ reloc (Bstrconst (Const_type u)) (Array.of_list local_levels) sz cont end | LetIn(_,xb,_,body) -> compile_constr reloc xb sz (Kpush :: (compile_constr (push_local sz reloc) body (sz+1) (add_pop 1 cont))) | Prod(id,dom,codom) -> let cont1 = Kpush :: compile_constr reloc dom (sz+1) (Kmakeprod :: cont) in compile_constr reloc (mkLambda(id,dom,codom)) sz cont1 | Lambda _ -> let params, body = decompose_lam c in let arity = List.length params in let r_fun = comp_env_fun arity in let lbl_fun = Label.create() in let cont_fun = ensure_stack_capacity (compile_constr r_fun body arity) [Kreturn arity] in fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)]; let fv = fv r_fun in compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont) | App(f,args) -> begin match kind_of_term f with | Construct _ -> compile_str_cst reloc (str_const c) sz cont | Const (kn,u) -> compile_const reloc kn u args sz cont | _ -> comp_app compile_constr compile_constr reloc f args sz cont end | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) -> let ndef = Array.length type_bodies in let rfv = ref empty_fv in let lbl_types = Array.make ndef Label.no in let lbl_bodies = Array.make ndef Label.no in (* Compilation des types *) let env_type = comp_env_fix_type rfv in for i = 0 to ndef - 1 do let fcode = ensure_stack_capacity (compile_constr env_type type_bodies.(i) 0) [Kstop] in let lbl,fcode = label_code fcode in lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; (* Compiling bodies *) for i = 0 to ndef - 1 do let params,body = decompose_lam rec_bodies.(i) in let arity = List.length params in let env_body = comp_env_fix ndef i arity rfv in let cont1 = ensure_stack_capacity (compile_constr env_body body arity) [Kreturn arity] in let lbl = Label.create () in lbl_bodies.(i) <- lbl; let fcode = add_grabrec rec_args.(i) arity lbl cont1 in fun_code := [Ksequence(fcode,!fun_code)] done; let fv = !rfv in compile_fv reloc fv.fv_rev sz (Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont) | CoFix(init,(_,type_bodies,rec_bodies)) -> let ndef = Array.length type_bodies in let lbl_types = Array.make ndef Label.no in let lbl_bodies = Array.make ndef Label.no in (* Compiling types *) let rfv = ref empty_fv in let env_type = comp_env_cofix_type ndef rfv in for i = 0 to ndef - 1 do let fcode = ensure_stack_capacity (compile_constr env_type type_bodies.(i) 0) [Kstop] in let lbl,fcode = label_code fcode in lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; (* Compiling bodies *) for i = 0 to ndef - 1 do let params,body = decompose_lam rec_bodies.(i) in let arity = List.length params in let env_body = comp_env_cofix ndef arity rfv in let lbl = Label.create () in let comp arity = (* 4 stack slots are needed to update the cofix when forced *) set_max_stack_size (arity + 4); compile_constr env_body body (arity+1) (cont_cofix arity) in let cont = ensure_stack_capacity comp arity in lbl_bodies.(i) <- lbl; fun_code := [Ksequence(add_grab (arity+1) lbl cont,!fun_code)]; done; let fv = !rfv in set_max_stack_size (sz + fv.size + ndef + 2); compile_fv reloc fv.fv_rev sz (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) | Case(ci,t,a,branchs) -> let ind = ci.ci_ind in let mib = lookup_mind (fst ind) !global_env in let oib = mib.mind_packets.(snd ind) in let () = check_compilable oib in let tbl = oib.mind_reloc_tbl in let lbl_consts = Array.make oib.mind_nb_constant Label.no in let nallblock = oib.mind_nb_args + 1 in (* +1 : accumulate *) let nblock = min nallblock (last_variant_tag + 1) in let lbl_blocks = Array.make nblock Label.no in let neblock = max 0 (nallblock - last_variant_tag) in let lbl_eblocks = Array.make neblock Label.no in let branch1,cont = make_branch cont in (* Compiling return type *) let fcode = ensure_stack_capacity (compile_constr reloc t sz) [Kpop sz; Kstop] in let lbl_typ,fcode = label_code fcode in fun_code := [Ksequence(fcode,!fun_code)]; (* Compiling branches *) let lbl_sw = Label.create () in let sz_b,branch,is_tailcall = match branch1 with | Kreturn k -> assert (Int.equal k sz) ; sz, branch1, true | _ -> sz+3, Kjump, false in let c = ref cont in (* Perform the extra match if needed (too many block constructors) *) if neblock <> 0 then begin let lbl_b, code_b = label_code ( Kpush :: Kfield 0 :: Kswitch(lbl_eblocks, [||]) :: !c) in lbl_blocks.(last_variant_tag) <- lbl_b; c := code_b end; (* Compiling regular constructor branches *) for i = 0 to Array.length tbl - 1 do let tag, arity = tbl.(i) in if Int.equal arity 0 then let lbl_b,code_b = label_code(compile_constr reloc branchs.(i) sz_b (branch :: !c)) in lbl_consts.(tag) <- lbl_b; c := code_b else let args, body = decompose_lam branchs.(i) in let nargs = List.length args in let code_b = if Int.equal nargs arity then compile_constr (push_param arity sz_b reloc) body (sz_b+arity) (add_pop arity (branch :: !c)) else let sz_appterm = if is_tailcall then sz_b + arity else arity in compile_constr reloc branchs.(i) (sz_b+arity) (Kappterm(arity,sz_appterm) :: !c) in let code_b = if tag < last_variant_tag then begin set_max_stack_size (sz_b + arity); Kpushfields arity :: code_b end else begin set_max_stack_size (sz_b + arity + 1); Kacc 0::Kpop 1::Kpushfields(arity+1)::Kpop 1::code_b end in let lbl_b,code_b = label_code code_b in if tag < last_variant_tag then lbl_blocks.(tag) <- lbl_b else lbl_eblocks.(tag - last_variant_tag) <- lbl_b; c := code_b done; let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall; max_stack_size = !max_stack_size - sz} in (* Compiling branch for accumulators *) let lbl_accu, code_accu = set_max_stack_size (sz+3); label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch :: !c) in lbl_blocks.(0) <- lbl_accu; c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: code_accu; let code_sw = match branch1 with (* spiwack : branch1 can't be a lbl anymore it's a Branch instead | Klabel lbl -> Kpush_retaddr lbl :: !c *) | Kbranch lbl -> Kpush_retaddr lbl :: !c | _ -> !c in compile_constr reloc a sz (try let entry = mkInd ind in Retroknowledge.get_vm_before_match_info (!global_env).retroknowledge entry code_sw with Not_found -> code_sw) and compile_str_cst reloc sc sz cont = set_max_stack_size sz; match sc with | Bconstr c -> compile_constr reloc c sz cont | Bstrconst sc -> Kconst sc :: cont | Bmakeblock(tag,args) -> let arity = Array.length args in let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in comp_args compile_str_cst reloc args sz cont | Bconstruct_app(tag,nparams,arity,args) -> if Int.equal (Array.length args) 0 then code_construct tag nparams arity cont else comp_app (fun _ _ _ cont -> code_construct tag nparams arity cont) compile_str_cst reloc () args sz cont | Bspecial (comp_fx, args) -> comp_fx reloc args sz cont (* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) and compile_get_global reloc (kn,u) sz cont = set_max_stack_size sz; let kn = get_alias !global_env kn in if Univ.Instance.is_empty u then Kgetglobal kn :: cont else comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) compile_universe reloc () (Univ.Instance.to_array u) sz cont and compile_universe reloc uni sz cont = set_max_stack_size sz; match Univ.Level.var_index uni with | None -> Kconst (Const_univ_level uni) :: cont | Some idx -> pos_universe_var idx reloc sz :: cont and compile_const reloc kn u args sz cont = set_max_stack_size sz; let nargs = Array.length args in (* spiwack: checks if there is a specific way to compile the constant if there is not, Not_found is raised, and the function falls back on its normal behavior *) try Retroknowledge.get_vm_compiling_info (!global_env).retroknowledge (mkConstU (kn,u)) reloc args sz cont with Not_found -> if Int.equal nargs 0 then compile_get_global reloc (kn,u) sz cont else if Univ.Instance.is_empty u then (* normal compilation *) comp_app (fun _ _ sz cont -> compile_get_global reloc (kn,u) sz cont) compile_constr reloc () args sz cont else let compile_arg reloc constr_or_uni sz cont = match constr_or_uni with | ArgConstr cst -> compile_constr reloc cst sz cont | ArgUniv uni -> compile_universe reloc uni sz cont in let u = Univ.Instance.to_array u in let lu = Array.length u in let all = Array.init (lu + Array.length args) (fun i -> if i < lu then ArgUniv u.(i) else ArgConstr args.(i-lu)) in comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) compile_arg reloc () all sz cont let is_univ_copy max u = let u = Univ.Instance.to_array u in if Array.length u = max then Array.fold_left_i (fun i acc u -> if acc then match Univ.Level.var_index u with | None -> false | Some l -> l = i else false) true u else false let dump_bytecodes init code fvs = let open Pp in (str "code =" ++ fnl () ++ pp_bytecodes init ++ fnl () ++ pp_bytecodes code ++ fnl () ++ str "fv = " ++ prlist_with_sep (fun () -> str "; ") pp_fv_elem fvs ++ fnl ()) let compile fail_on_error ?universes:(universes=0) env c = set_global_env env; init_fun_code (); Label.reset_label_counter (); let cont = [Kstop] in try let reloc, init_code = if Int.equal universes 0 then let reloc = empty_comp_env () in reloc, ensure_stack_capacity (compile_constr reloc c 0) cont else (* We are going to generate a lambda, but merge the universe closure * with the function closure if it exists. *) let reloc = empty_comp_env () in let arity , body = match kind_of_term c with | Lambda _ -> let params, body = decompose_lam c in List.length params , body | _ -> 0 , c in let full_arity = arity + universes in let r_fun = comp_env_fun ~univs:universes arity in let lbl_fun = Label.create () in let cont_fun = ensure_stack_capacity (compile_constr r_fun body full_arity) [Kreturn full_arity] in fun_code := [Ksequence(add_grab full_arity lbl_fun cont_fun,!fun_code)]; let fv = fv r_fun in let init_code = ensure_stack_capacity (compile_fv reloc fv.fv_rev 0) (Kclosure(lbl_fun,fv.size) :: cont) in reloc, init_code in let fv = List.rev (!(reloc.in_env).fv_rev) in (if !Flags.dump_bytecode then Feedback.msg_debug (dump_bytecodes init_code !fun_code fv)) ; Some (init_code,!fun_code, Array.of_list fv) with TooLargeInductive tname -> let fn = if fail_on_error then CErrors.errorlabstrm "compile" else (fun x -> Feedback.msg_warning x) in (Pp.(fn (str "Cannot compile code for virtual machine as it uses inductive " ++ Id.print tname ++ str str_max_constructors)); None) let compile_constant_body fail_on_error env univs = function | Undef _ | OpaqueDef _ -> Some BCconstant | Def sb -> let body = Mod_subst.force_constr sb in let instance_size = match univs with | None -> 0 | Some univ -> Univ.UContext.size univ in match kind_of_term body with | Const (kn',u) when is_univ_copy instance_size u -> (* we use the canonical name of the constant*) let con= constant_of_kn (canonical_con kn') in Some (BCalias (get_alias env con)) | _ -> let res = compile fail_on_error ~universes:instance_size env body in Option.map (fun x -> BCdefined (to_memory x)) res (* Shortcut of the previous function used during module strengthening *) let compile_alias kn = BCalias (constant_of_kn (canonical_con kn)) (* spiwack: additional function which allow different part of compilation of the 31-bit integers *) let make_areconst n else_lbl cont = if n <= 0 then cont else Kareconst (n, else_lbl)::cont (* try to compile int31 as a const_b0. Succeed if all the arguments are closed fails otherwise by raising NotClosed*) let compile_structured_int31 fc args = if not fc then raise Not_found else Const_b0 (Array.fold_left (fun temp_i -> fun t -> match kind_of_term t with | Construct ((_,d),_) -> 2*temp_i+d-1 | _ -> raise NotClosed) 0 args ) (* this function is used for the compilation of the constructor of the int31, it is used when it appears not fully applied, or applied to at least one non-closed digit *) let dynamic_int31_compilation fc reloc args sz cont = if not fc then raise Not_found else let nargs = Array.length args in if Int.equal nargs 31 then let (escape,labeled_cont) = make_branch cont in let else_lbl = Label.create() in comp_args compile_str_cst reloc args sz ( Kisconst else_lbl::Kareconst(30,else_lbl)::Kcompint31::escape::Klabel else_lbl::Kmakeblock(31, 1)::labeled_cont) else let code_construct cont = (* spiwack: variant of the global code_construct which handles dynamic compilation of integers *) let f_cont = let else_lbl = Label.create () in [Kacc 0; Kpop 1; Kisconst else_lbl; Kareconst(30,else_lbl); Kcompint31; Kreturn 0; Klabel else_lbl; Kmakeblock(31, 1); Kreturn 0] in let lbl = Label.create() in fun_code := [Ksequence (add_grab 31 lbl f_cont,!fun_code)]; Kclosure(lbl,0) :: cont in if Int.equal nargs 0 then code_construct cont else comp_app (fun _ _ _ cont -> code_construct cont) compile_str_cst reloc () args sz cont (*(* template compilation for 2ary operation, it probably possible to make a generic such function with arity abstracted *) let op2_compilation op = let code_construct normal cont = (*kn cont =*) let f_cont = let else_lbl = Label.create () in Kareconst(2, else_lbl):: Kacc 0:: Kpop 1:: op:: Kreturn 0:: Klabel else_lbl:: (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*) (*Kgetglobal (get_alias !global_env kn):: *) normal:: Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *) in let lbl = Label.create () in fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; Kclosure(lbl, 0)::cont in fun normal fc _ reloc args sz cont -> if not fc then raise Not_found else let nargs = Array.length args in if nargs=2 then (*if it is a fully applied addition*) let (escape, labeled_cont) = make_branch cont in let else_lbl = Label.create () in comp_args compile_constr reloc args sz (Kisconst else_lbl::(make_areconst 1 else_lbl (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: (* works as comp_app with nargs = 2 and non-tailcall cont*) (*Kgetglobal (get_alias !global_env kn):: *) normal:: Kapply 2::labeled_cont))) else if nargs=0 then code_construct normal cont else comp_app (fun _ _ _ cont -> code_construct normal cont) compile_constr reloc () args sz cont *) (*template for n-ary operation, invariant: n>=1, the operations does the following : 1/ checks if all the arguments are constants (i.e. non-block values) 2/ if they are, uses the "op" instruction to execute 3/ if at least one is not, branches to the normal behavior: Kgetglobal (get_alias !global_env kn) *) let op_compilation n op = let code_construct reloc kn sz cont = let f_cont = let else_lbl = Label.create () in Kareconst(n, else_lbl):: Kacc 0:: Kpop 1:: op:: Kreturn 0:: Klabel else_lbl:: (* works as comp_app with nargs = n and tailcall cont [Kreturn 0]*) compile_get_global reloc kn sz ( Kappterm(n, n):: []) (* = discard_dead_code [Kreturn 0] *) in let lbl = Label.create () in fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)]; Kclosure(lbl, 0)::cont in fun kn fc reloc args sz cont -> if not fc then raise Not_found else let nargs = Array.length args in if Int.equal nargs n then (*if it is a fully applied addition*) let (escape, labeled_cont) = make_branch cont in let else_lbl = Label.create () in comp_args compile_constr reloc args sz (Kisconst else_lbl::(make_areconst (n-1) else_lbl (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: (* works as comp_app with nargs = n and non-tailcall cont*) compile_get_global reloc kn sz (Kapply n::labeled_cont)))) else if Int.equal nargs 0 then code_construct reloc kn sz cont else comp_app (fun reloc _ sz cont -> code_construct reloc kn sz cont) compile_constr reloc () args sz cont let int31_escape_before_match fc cont = if not fc then raise Not_found else let escape_lbl, labeled_cont = label_code cont in (Kisconst escape_lbl)::Kdecompint31::labeled_cont coq-8.6/kernel/indtypes.mli0000644000175000017500000000327613022274260015311 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body (** The following enforces a system compatible with the univalent model *) val enforce_indices_matter : unit -> unit val is_indices_matter : unit -> bool val compute_projections : pinductive -> Id.t -> Id.t -> int -> Context.Rel.t -> int array -> int array -> Context.Rel.t -> Context.Rel.t -> (constant array * projection_body array) coq-8.6/kernel/fast_typeops.mli0000644000175000017500000000205413022274260016163 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> unsafe_judgment val infer_v : env -> constr array -> unsafe_judgment array val infer_type : env -> types -> unsafe_type_judgment coq-8.6/kernel/inductive.mli0000644000175000017500000001225213022274260015436 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* types -> pinductive * constr list val find_inductive : env -> types -> pinductive * constr list val find_coinductive : env -> types -> pinductive * constr list type mind_specif = mutual_inductive_body * one_inductive_body (** {6 ... } *) (** Fetching information in the environment about an inductive type. Raises [Not_found] if the inductive type is not found. *) val lookup_mind_specif : env -> inductive -> mind_specif (** {6 Functions to build standard types related to inductive } *) val ind_subst : mutual_inductive -> mutual_inductive_body -> universe_instance -> constr list val inductive_paramdecls : mutual_inductive_body puniverses -> Context.Rel.t val instantiate_inductive_constraints : mutual_inductive_body -> universe_instance -> constraints val constrained_type_of_inductive : env -> mind_specif puniverses -> types constrained val constrained_type_of_inductive_knowing_parameters : env -> mind_specif puniverses -> types Lazy.t array -> types constrained val type_of_inductive : env -> mind_specif puniverses -> types val type_of_inductive_knowing_parameters : env -> ?polyprop:bool -> mind_specif puniverses -> types Lazy.t array -> types val elim_sorts : mind_specif -> sorts_family list val is_private : mind_specif -> bool val is_primitive_record : mind_specif -> bool (** Return type as quoted by the user *) val constrained_type_of_constructor : pconstructor -> mind_specif -> types constrained val type_of_constructor : pconstructor -> mind_specif -> types (** Return constructor types in normal form *) val arities_of_constructors : pinductive -> mind_specif -> types array (** Return constructor types in user form *) val type_of_constructors : pinductive -> mind_specif -> types array (** Transforms inductive specification into types (in nf) *) val arities_of_specif : mutual_inductive puniverses -> mind_specif -> types array val inductive_params : mind_specif -> int (** [type_case_branches env (I,args) (p:A) c] computes useful types about the following Cases expression:

Cases (c :: (I args)) of b1..bn end It computes the type of every branch (pattern variables are introduced by products), the type for the whole expression, and the universe constraints generated. *) val type_case_branches : env -> pinductive * constr list -> unsafe_judgment -> constr -> types array * types val build_branches_type : pinductive -> mutual_inductive_body * one_inductive_body -> constr list -> constr -> types array (** Return the arity of an inductive type *) val mind_arity : one_inductive_body -> Context.Rel.t * sorts_family val inductive_sort_family : one_inductive_body -> sorts_family (** Check a [case_info] actually correspond to a Case expression on the given inductive type. *) val check_case_info : env -> pinductive -> case_info -> unit (** {6 Guard conditions for fix and cofix-points. } *) (** When [chk] is false, the guard condition is not actually checked. *) val check_fix : env -> fixpoint -> unit val check_cofix : env -> cofixpoint -> unit (** {6 Support for sort-polymorphic inductive types } *) (** The "polyprop" optional argument below controls the "Prop-polymorphism". By default, it is allowed. But when "polyprop=false", the following exception is raised when a polymorphic singleton inductive type becomes Prop due to parameter instantiation. This is used by the Ocaml extraction, which cannot handle (yet?) Prop-polymorphism. *) exception SingletonInductiveBecomesProp of Id.t val max_inductive_sort : sorts array -> universe val instantiate_universes : env -> Context.Rel.t -> template_arity -> constr Lazy.t array -> Context.Rel.t * sorts (** {6 Debug} *) type size = Large | Strict type subterm_spec = Subterm of (size * wf_paths) | Dead_code | Not_subterm type guard_env = { env : env; (** dB of last fixpoint *) rel_min : int; (** dB of variables denoting subterms *) genv : subterm_spec Lazy.t list; } type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec val lambda_implicit_lift : int -> Constr.constr -> Term.constr val abstract_mind_lc : int -> Int.t -> Constr.constr array -> Constr.constr array coq-8.6/kernel/vars.mli0000644000175000017500000001473613022274260014430 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> bool (** [closed0 M] is true iff [M] is a (deBruijn) closed term *) val closed0 : constr -> bool (** [noccurn n M] returns true iff [Rel n] does NOT occur in term [M] *) val noccurn : int -> constr -> bool (** [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M] for n <= p < n+m *) val noccur_between : int -> int -> constr -> bool (** Checking function for terms containing existential- or meta-variables. The function [noccur_with_meta] does not consider meta-variables applied to some terms (intended to be its local context) (for existential variables, it is necessarily the case) *) val noccur_with_meta : int -> int -> constr -> bool (** {6 Relocation and substitution } *) (** [exliftn el c] lifts [c] with lifting [el] *) val exliftn : Esubst.lift -> constr -> constr (** [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *) val liftn : int -> int -> constr -> constr (** [lift n c] lifts by [n] the positive indexes in [c] *) val lift : int -> constr -> constr (** The type [substl] is the type of substitutions [u₁..un] of type some context Δ and defined in some environment Γ. Typing of substitutions is defined by: - Γ ⊢ ∅ : ∅, - Γ ⊢ u₁..u{_n-1} : Δ and Γ ⊢ u{_n} : An\[u₁..u{_n-1}\] implies Γ ⊢ u₁..u{_n} : Δ,x{_n}:A{_n} - Γ ⊢ u₁..u{_n-1} : Δ and Γ ⊢ un : A{_n}\[u₁..u{_n-1}\] implies Γ ⊢ u₁..u{_n} : Δ,x{_n}:=c{_n}:A{_n} when Γ ⊢ u{_n} ≡ c{_n}\[u₁..u{_n-1}\] Note that [u₁..un] is represented as a list with [un] at the head of the list, i.e. as [[un;...;u₁]]. *) type substl = constr list (** Let [Γ] be a context interleaving declarations [x₁:T₁..xn:Tn] and definitions [y₁:=c₁..yp:=cp] in some context [Γ₀]. Let [u₁..un] be an {e instance} of [Γ], i.e. an instance in [Γ₀] of the [xi]. Then, [subst_of_rel_context_instance Γ u₁..un] returns the corresponding {e substitution} of [Γ], i.e. the appropriate interleaving [σ] of the [u₁..un] with the [c₁..cp], all of them in [Γ₀], so that a derivation [Γ₀, Γ, Γ₁|- t:T] can be instantiated into a derivation [Γ₀, Γ₁ |- t[σ]:T[σ]] using [substnl σ |Γ₁| t]. Note that the instance [u₁..un] is represented starting with [u₁], as if usable in [applist] while the substitution is represented the other way round, i.e. ending with either [u₁] or [c₁], as if usable for [substl]. *) val subst_of_rel_context_instance : Context.Rel.t -> constr list -> substl (** For compatibility: returns the substitution reversed *) val adjust_subst_to_rel_context : Context.Rel.t -> constr list -> constr list (** [substnl [a₁;...;an] k c] substitutes in parallel [a₁],...,[an] for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates accordingly indexes in [an],...,[a1] and [c]. In terms of typing, if Γ ⊢ a{_n}..a₁ : Δ and Γ, Δ, Γ' ⊢ c : T with |Γ'|=k, then Γ, Γ' ⊢ [substnl [a₁;...;an] k c] : [substnl [a₁;...;an] k T]. *) val substnl : substl -> int -> constr -> constr (** [substl σ c] is a short-hand for [substnl σ 0 c] *) val substl : substl -> constr -> constr (** [substl a c] is a short-hand for [substnl [a] 0 c] *) val subst1 : constr -> constr -> constr (** [substnl_decl [a₁;...;an] k Ω] substitutes in parallel [a₁], ..., [an] for respectively [Rel(k+1)], ..., [Rel(k+n)] in [Ω]; it relocates accordingly indexes in [a₁],...,[an] and [c]. In terms of typing, if Γ ⊢ a{_n}..a₁ : Δ and Γ, Δ, Γ', Ω ⊢ with |Γ'|=[k], then Γ, Γ', [substnl_decl [a₁;...;an]] k Ω ⊢. *) val substnl_decl : substl -> int -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t (** [substl_decl σ Ω] is a short-hand for [substnl_decl σ 0 Ω] *) val substl_decl : substl -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t (** [subst1_decl a Ω] is a short-hand for [substnl_decl [a] 0 Ω] *) val subst1_decl : constr -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t (** [replace_vars k [(id₁,c₁);...;(idn,cn)] t] substitutes [Var idj] by [cj] in [t]. *) val replace_vars : (Id.t * constr) list -> constr -> constr (** [substn_vars k [id₁;...;idn] t] substitutes [Var idj] by [Rel j+k-1] in [t]. If two names are identical, the one of least index is kept. In terms of typing, if Γ,x{_n}:U{_n},...,x₁:U₁,Γ' ⊢ t:T, together with id{_j}:T{_j} and Γ,x{_n}:U{_n},...,x₁:U₁,Γ' ⊢ T{_j}\[id{_j+1}..id{_n}:=x{_j+1}..x{_n}\] ≡ Uj, then Γ\\{id₁,...,id{_n}\},x{_n}:U{_n},...,x₁:U₁,Γ' ⊢ [substn_vars (|Γ'|+1) [id₁;...;idn] t] : [substn_vars (|Γ'|+1) [id₁;...;idn] T]. *) val substn_vars : int -> Id.t list -> constr -> constr (** [subst_vars [id1;...;idn] t] is a short-hand for [substn_vars [id1;...;idn] 1 t]: it substitutes [Var idj] by [Rel j] in [t]. If two names are identical, the one of least index is kept. *) val subst_vars : Id.t list -> constr -> constr (** [subst_var id t] is a short-hand for [substn_vars [id] 1 t]: it substitutes [Var id] by [Rel 1] in [t]. *) val subst_var : Id.t -> constr -> constr (** {3 Substitution of universes} *) open Univ val subst_univs_fn_constr : universe_subst_fn -> constr -> constr val subst_univs_fn_puniverses : universe_level_subst_fn -> 'a puniverses -> 'a puniverses val subst_univs_constr : universe_subst -> constr -> constr (** Level substitutions for polymorphism. *) val subst_univs_level_constr : universe_level_subst -> constr -> constr val subst_univs_level_context : Univ.universe_level_subst -> Context.Rel.t -> Context.Rel.t (** Instance substitution for polymorphism. *) val subst_instance_constr : universe_instance -> constr -> constr val subst_instance_context : universe_instance -> Context.Rel.t -> Context.Rel.t type id_key = constant tableKey val eq_id_key : id_key -> id_key -> bool coq-8.6/kernel/cClosure.mli0000644000175000017500000001737113022274260015232 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a (** {6 ... } *) (** Delta implies all consts (both global (= by [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's. Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) val all_opaque : transparent_state val all_transparent : transparent_state val is_transparent_variable : transparent_state -> variable -> bool val is_transparent_constant : transparent_state -> constant -> bool (** Sets of reduction kinds. *) module type RedFlagsSig = sig type reds type red_kind (** {7 The different kinds of reduction } *) val fBETA : red_kind val fDELTA : red_kind val fETA : red_kind (** The fETA flag is never used by the kernel reduction but pretyping does *) val fMATCH : red_kind val fFIX : red_kind val fCOFIX : red_kind val fZETA : red_kind val fCONST : constant -> red_kind val fVAR : Id.t -> red_kind (** No reduction at all *) val no_red : reds (** Adds a reduction kind to a set *) val red_add : reds -> red_kind -> reds (** Removes a reduction kind to a set *) val red_sub : reds -> red_kind -> reds (** Adds a reduction kind to a set *) val red_add_transparent : reds -> transparent_state -> reds (** Build a reduction set from scratch = iter [red_add] on [no_red] *) val mkflags : red_kind list -> reds (** Tests if a reduction kind is set *) val red_set : reds -> red_kind -> bool (** This tests if the projection is in unfolded state already or is unfodable due to delta. *) val red_projection : reds -> projection -> bool end module RedFlags : RedFlagsSig open RedFlags (* These flags do not contain eta *) val all : reds val allnolet : reds val beta : reds val betadeltazeta : reds val betaiota : reds val betaiotazeta : reds val betazeta : reds val delta : reds val zeta : reds val nored : reds val unfold_side_red : reds val unfold_red : evaluable_global_reference -> reds (***********************************************************************) type table_key = constant puniverses tableKey type 'a infos_cache type 'a infos = { i_flags : reds; i_cache : 'a infos_cache } val ref_value_cache: 'a infos -> table_key -> 'a option val create: ('a infos -> constr -> 'a) -> reds -> env -> (existential -> constr option) -> 'a infos val evar_value : 'a infos_cache -> existential -> constr option val info_env : 'a infos -> env val info_flags: 'a infos -> reds (*********************************************************************** s Lazy reduction. *) (** [fconstr] is the type of frozen constr *) type fconstr (** [fconstr] can be accessed by using the function [fterm_of] and by matching on type [fterm] *) type fterm = | FRel of int | FAtom of constr (** Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of inductive puniverses | FConstruct of constructor puniverses | FApp of fconstr * fconstr array | FProj of projection * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs | FProd of Name.t * fconstr * fconstr | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED (*********************************************************************** s A [stack] is a context of arguments, arguments are pushed by [append_stack] one array at a time but popped with [decomp_stack] one by one *) type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of int * int * constant | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr and stack = stack_member list val empty_stack : stack val append_stack : fconstr array -> stack -> stack val decomp_stack : stack -> (fconstr * stack) option val array_of_stack : stack -> fconstr array val stack_assign : stack -> int -> fconstr -> stack val stack_args_size : stack -> int val stack_tail : int -> stack -> stack val stack_nth : stack -> int -> fconstr val zip_term : (fconstr -> constr) -> constr -> stack -> constr val eta_expand_stack : stack -> stack (** To lazy reduce a constr, create a [clos_infos] with [create_clos_infos], inject the term to reduce with [inject]; then use a reduction function *) val inject : constr -> fconstr (** mk_atom: prevents a term from being evaluated *) val mk_atom : constr -> fconstr (** mk_red: makes a reducible term (used in newring) *) val mk_red : fterm -> fconstr val fterm_of : fconstr -> fterm val term_of_fconstr : fconstr -> constr val destFLambda : (fconstr subs -> constr -> fconstr) -> fconstr -> Name.t * fconstr * fconstr (** Global and local constant cache *) type clos_infos = fconstr infos val create_clos_infos : ?evars:(existential->constr option) -> reds -> env -> clos_infos val oracle_of_infos : clos_infos -> Conv_oracle.oracle val env_of_infos : clos_infos -> env val infos_with_reds : clos_infos -> reds -> clos_infos (** Reduction function *) (** [norm_val] is for strong normalization *) val norm_val : clos_infos -> fconstr -> constr (** [whd_val] is for weak head normalization *) val whd_val : clos_infos -> fconstr -> constr (** [whd_stack] performs weak head normalization in a given stack. It stops whenever a reduction is blocked. *) val whd_stack : clos_infos -> fconstr -> stack -> fconstr * stack (** [eta_expand_ind_stack env ind c s t] computes stacks correspoding to the conversion of the eta expansion of t, considered as an inhabitant of ind, and the Constructor c of this inductive type applied to arguments s. @assumes [t] is a rigid term, and not a constructor. [ind] is the inductive of the constructor term [c] @raises Not_found if the inductive is not a primitive record, or if the constructor is partially applied. *) val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> (fconstr * stack) -> stack * stack (** Conversion auxiliary functions to do step by step normalisation *) (** [unfold_reference] unfolds references in a [fconstr] *) val unfold_reference : clos_infos -> table_key -> fconstr option val eq_table_key : table_key -> table_key -> bool (*********************************************************************** i This is for lazy debug *) val lift_fconstr : int -> fconstr -> fconstr val lift_fconstr_vect : int -> fconstr array -> fconstr array val mk_clos : fconstr subs -> constr -> fconstr val mk_clos_vect : fconstr subs -> constr array -> fconstr array val mk_clos_deep : (fconstr subs -> constr -> fconstr) -> fconstr subs -> constr -> fconstr val kni: clos_infos -> fconstr -> stack -> fconstr * stack val knr: clos_infos -> fconstr -> stack -> fconstr * stack val kl : clos_infos -> fconstr -> constr val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr (** End of cbn debug section i*) coq-8.6/kernel/conv_oracle.ml0000644000175000017500000000623613022274260015572 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | _ -> false let transparent = default let is_transparent = function | Level 0 -> true | _ -> false type oracle = { var_opacity : level Id.Map.t; cst_opacity : level Cmap.t; var_trstate : Id.Pred.t; cst_trstate : Cpred.t; } let empty = { var_opacity = Id.Map.empty; cst_opacity = Cmap.empty; var_trstate = Id.Pred.full; cst_trstate = Cpred.full; } let get_strategy { var_opacity; cst_opacity } f = function | VarKey id -> (try Id.Map.find id var_opacity with Not_found -> default) | ConstKey c -> (try Cmap.find (f c) cst_opacity with Not_found -> default) | RelKey _ -> Expand let set_strategy ({ var_opacity; cst_opacity } as oracle) k l = match k with | VarKey id -> let var_opacity = if is_default l then Id.Map.remove id var_opacity else Id.Map.add id l var_opacity in let var_trstate = match l with | Opaque -> Id.Pred.remove id oracle.var_trstate | _ -> Id.Pred.add id oracle.var_trstate in { oracle with var_opacity; var_trstate; } | ConstKey c -> let cst_opacity = if is_default l then Cmap.remove c cst_opacity else Cmap.add c l cst_opacity in let cst_trstate = match l with | Opaque -> Cpred.remove c oracle.cst_trstate | _ -> Cpred.add c oracle.cst_trstate in { oracle with cst_opacity; cst_trstate; } | RelKey _ -> CErrors.error "set_strategy: RelKey" let fold_strategy f { var_opacity; cst_opacity; } accu = let fvar id lvl accu = f (VarKey id) lvl accu in let fcst cst lvl accu = f (ConstKey cst) lvl accu in let accu = Id.Map.fold fvar var_opacity accu in Cmap.fold fcst cst_opacity accu let get_transp_state { var_trstate; cst_trstate } = (var_trstate, cst_trstate) (* Unfold the first constant only if it is "more transparent" than the second one. In case of tie, use the recommended default. *) let oracle_order f o l2r k1 k2 = match get_strategy o f k1, get_strategy o f k2 with | Expand, Expand -> l2r | Expand, (Opaque | Level _) -> true | (Opaque | Level _), Expand -> false | Opaque, Opaque -> l2r | Level _, Opaque -> true | Opaque, Level _ -> false | Level n1, Level n2 -> if Int.equal n1 n2 then l2r else n1 < n2 let get_strategy o = get_strategy o (fun x -> x) coq-8.6/kernel/typeops.mli0000644000175000017500000001055513022274260015153 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> unsafe_judgment val infer_v : env -> constr array -> unsafe_judgment array val infer_type : env -> types -> unsafe_type_judgment val infer_local_decls : env -> (Id.t * local_entry) list -> (env * Context.Rel.t) (** {6 Basic operations of the typing machine. } *) (** If [j] is the judgement {% $ %}c:t{% $ %}, then [assumption_of_judgement env j] returns the type {% $ %}c{% $ %}, checking that {% $ %}t{% $ %} is a sort. *) val assumption_of_judgment : env -> unsafe_judgment -> types val type_judgment : env -> unsafe_judgment -> unsafe_type_judgment (** {6 Type of sorts. } *) val judge_of_prop : unsafe_judgment val judge_of_set : unsafe_judgment val judge_of_prop_contents : contents -> unsafe_judgment val judge_of_type : universe -> unsafe_judgment (** {6 Type of a bound variable. } *) val judge_of_relative : env -> int -> unsafe_judgment (** {6 Type of variables } *) val judge_of_variable : env -> variable -> unsafe_judgment (** {6 type of a constant } *) val judge_of_constant : env -> pconstant -> unsafe_judgment val judge_of_constant_knowing_parameters : env -> pconstant -> types Lazy.t array -> unsafe_judgment (** {6 type of an applied projection } *) val judge_of_projection : env -> Names.projection -> unsafe_judgment -> unsafe_judgment (** {6 Type of application. } *) val judge_of_apply : env -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment (** {6 Type of an abstraction. } *) val judge_of_abstraction : env -> Name.t -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment val sort_of_product : env -> sorts -> sorts -> sorts (** {6 Type of a product. } *) val judge_of_product : env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment (** s Type of a let in. *) val judge_of_letin : env -> Name.t -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment (** {6 Type of a cast. } *) val judge_of_cast : env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment -> unsafe_judgment (** {6 Inductive types. } *) val judge_of_inductive : env -> inductive puniverses -> unsafe_judgment (* val judge_of_inductive_knowing_parameters : *) (* env -> inductive -> unsafe_judgment array -> unsafe_judgment *) val judge_of_constructor : env -> constructor puniverses -> unsafe_judgment (** {6 Type of Cases. } *) val judge_of_case : env -> case_info -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment (** Typecheck general fixpoint (not checking guard conditions) *) val type_fixpoint : env -> Name.t array -> types array -> unsafe_judgment array -> unit val type_of_constant : env -> pconstant -> types constrained val type_of_constant_type : env -> constant_type -> types val type_of_projection : env -> Names.projection puniverses -> types val type_of_constant_in : env -> pconstant -> types val type_of_constant_type_knowing_parameters : env -> constant_type -> types Lazy.t array -> types val type_of_constant_knowing_parameters : env -> pconstant -> types Lazy.t array -> types constrained val type_of_constant_knowing_parameters_in : env -> pconstant -> types Lazy.t array -> types (** Make a type polymorphic if an arity *) val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment -> constant_type (** Check that hyps are included in env and fails with error otherwise *) val check_hyps_inclusion : env -> constr -> Context.section_context -> unit coq-8.6/kernel/modops.mli0000644000175000017500000001162013022274260014743 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool val destr_functor : ('ty,'a) functorize -> MBId.t * 'ty * ('ty,'a) functorize val destr_nofunctor : ('ty,'a) functorize -> 'a (** Conversions between [module_body] and [module_type_body] *) val module_type_of_module : module_body -> module_type_body val module_body_of_type : module_path -> module_type_body -> module_body val check_modpath_equiv : env -> module_path -> module_path -> unit val implem_smartmap : (module_signature -> module_signature) -> (module_expression -> module_expression) -> (module_implementation -> module_implementation) (** {6 Substitutions } *) val subst_signature : substitution -> module_signature -> module_signature val subst_structure : substitution -> structure_body -> structure_body (** {6 Adding to an environment } *) val add_structure : module_path -> structure_body -> delta_resolver -> env -> env (** adds a module and its components, but not the constraints *) val add_module : module_body -> env -> env (** same as add_module, but for a module whose native code has been linked by the native compiler. The linking information is updated. *) val add_linked_module : module_body -> Pre_env.link_info -> env -> env (** same, for a module type *) val add_module_type : module_path -> module_type_body -> env -> env (** {6 Strengthening } *) val strengthen : module_type_body -> module_path -> module_type_body val inline_delta_resolver : env -> inline -> module_path -> MBId.t -> module_type_body -> delta_resolver -> delta_resolver val strengthen_and_subst_mb : module_body -> module_path -> bool -> module_body val subst_modtype_and_resolver : module_type_body -> module_path -> module_type_body (** {6 Cleaning a module expression from bounded parts } For instance: functor(X:T)->struct module M:=X end) becomes: functor(X:T)->struct module M:= end) *) val clean_bounded_mod_expr : module_signature -> module_signature (** {6 Stm machinery } *) val join_structure : Future.UUIDSet.t -> Opaqueproof.opaquetab -> structure_body -> unit (** {6 Errors } *) type signature_mismatch_error = | InductiveFieldExpected of mutual_inductive_body | DefinitionFieldExpected | ModuleFieldExpected | ModuleTypeFieldExpected | NotConvertibleInductiveField of Id.t | NotConvertibleConstructorField of Id.t | NotConvertibleBodyField | NotConvertibleTypeField of env * types * types | PolymorphicStatusExpected of bool | NotSameConstructorNamesField | NotSameInductiveNameInBlockField | FiniteInductiveFieldExpected of bool | InductiveNumbersFieldExpected of int | InductiveParamsNumberField of int | RecordFieldExpected of bool | RecordProjectionsExpected of Name.t list | NotEqualInductiveAliases | NoTypeConstraintExpected | IncompatibleInstances | IncompatibleUniverses of Univ.univ_inconsistency | IncompatiblePolymorphism of env * types * types | IncompatibleConstraints of Univ.constraints type module_typing_error = | SignatureMismatch of Label.t * structure_field_body * signature_mismatch_error | LabelAlreadyDeclared of Label.t | ApplicationToNotPath of module_struct_entry | NotAFunctor | IsAFunctor | IncompatibleModuleTypes of module_type_body * module_type_body | NotEqualModulePaths of module_path * module_path | NoSuchLabel of Label.t | IncompatibleLabels of Label.t * Label.t | NotAModule of string | NotAModuleType of string | NotAConstant of Label.t | IncorrectWithConstraint of Label.t | GenerativeModuleExpected of Label.t | LabelMissing of Label.t * string | IncludeRestrictedFunctor of module_path exception ModuleTypingError of module_typing_error val error_existing_label : Label.t -> 'a val error_incompatible_modtypes : module_type_body -> module_type_body -> 'a val error_signature_mismatch : Label.t -> structure_field_body -> signature_mismatch_error -> 'a val error_incompatible_labels : Label.t -> Label.t -> 'a val error_no_such_label : Label.t -> 'a val error_not_a_module : string -> 'a val error_not_a_constant : Label.t -> 'a val error_incorrect_with_constraint : Label.t -> 'a val error_generative_module_expected : Label.t -> 'a val error_no_such_label_sub : Label.t->string->'a val error_include_restricted_functor : module_path -> 'a coq-8.6/kernel/evar.mli0000644000175000017500000000245213022274260014402 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int (** Recover the underlying integer. *) val unsafe_of_int : int -> t (** This is not for dummies. Do not use this function if you don't know what you are doing. *) val equal : t -> t -> bool (** Equality over existential variables. *) val compare : t -> t -> int (** Comparison over existential variables. *) val hash : t -> int (** Hash over existential variables. *) module Set : Set.S with type elt = t module Map : CMap.ExtS with type key = t and module Set := Set coq-8.6/kernel/mod_typing.mli0000644000175000017500000000427313022274260015621 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* module_path -> inline -> module_entry -> module_body (** [translate_modtype] produces a [module_type_body] whose [mod_type_alg] cannot be [None] (and of course [mod_expr] is [Abstract]). *) val translate_modtype : env -> module_path -> inline -> module_type_entry -> module_type_body (** Low-level function for translating a module struct entry : - We translate to a module when a [module_path] is given, otherwise to a module type. - The first output is the expanded signature - The second output is the algebraic expression, kept mostly for the extraction. *) type 'alg translation = module_signature * 'alg * delta_resolver * Univ.ContextSet.t val translate_mse : env -> module_path option -> inline -> module_struct_entry -> module_alg_expr translation (** From an already-translated (or interactive) implementation and an (optional) signature entry, produces a final [module_body] *) val finalize_module : env -> module_path -> (module_expression option) translation -> (module_type_entry * inline) option -> module_body (** [translate_mse_incl] translate the mse of a module or module type given to an Include *) val translate_mse_incl : bool -> env -> module_path -> inline -> module_struct_entry -> unit translation coq-8.6/kernel/cooking.ml0000644000175000017500000002063313022274260014726 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* anomaly ~label:"dirpath_prefix" (Pp.str "empty dirpath") | _::l -> DirPath.make l let pop_mind kn = let (mp,dir,l) = Names.repr_mind kn in Names.make_mind mp (pop_dirpath dir) l let pop_con con = let (mp,dir,l) = Names.repr_con con in Names.make_con mp (pop_dirpath dir) l type my_global_reference = | ConstRef of constant | IndRef of inductive | ConstructRef of constructor module RefHash = 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 | _ -> 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) end module RefTable = Hashtbl.Make(RefHash) let instantiate_my_gr gr u = match gr with | ConstRef c -> mkConstU (c, u) | IndRef i -> mkIndU (i, u) | ConstructRef c -> mkConstructU (c, u) let share cache r (cstl,knl) = try RefTable.find cache r with Not_found -> let f,(u,l) = match r with | IndRef (kn,i) -> IndRef (pop_mind kn,i), Mindmap.find kn knl | ConstructRef ((kn,i),j) -> ConstructRef ((pop_mind kn,i),j), Mindmap.find kn knl | ConstRef cst -> ConstRef (pop_con cst), Cmap.find cst cstl in let c = (f, (u, Array.map mkVar l)) in RefTable.add cache r c; c let share_univs cache r u l = let r', (u', args) = share cache r l in mkApp (instantiate_my_gr r' (Instance.append u' u), args) let update_case_info cache ci modlist = try let ind, n = match share cache (IndRef ci.ci_ind) modlist with | (IndRef f,(u,l)) -> (f, Array.length l) | _ -> assert false in { ci with ci_ind = ind; ci_npar = ci.ci_npar + n } with Not_found -> ci let is_empty_modlist (cm, mm) = Cmap.is_empty cm && Mindmap.is_empty mm let expmod_constr cache modlist c = let share_univs = share_univs cache in let update_case_info = update_case_info cache in let rec substrec c = match kind_of_term c with | Case (ci,p,t,br) -> map_constr substrec (mkCase (update_case_info ci modlist,p,t,br)) | Ind (ind,u) -> (try share_univs (IndRef ind) u modlist with | Not_found -> map_constr substrec c) | Construct (cstr,u) -> (try share_univs (ConstructRef cstr) u modlist with | Not_found -> map_constr substrec c) | Const (cst,u) -> (try share_univs (ConstRef cst) u modlist with | Not_found -> map_constr substrec c) | Proj (p, c') -> (try let p' = share_univs (ConstRef (Projection.constant p)) Univ.Instance.empty modlist in let make c = Projection.make c (Projection.unfolded p) in match kind_of_term p' with | Const (p',_) -> mkProj (make p', substrec c') | App (f, args) -> (match kind_of_term f with | Const (p', _) -> mkProj (make p', substrec c') | _ -> assert false) | _ -> assert false with Not_found -> map_constr substrec c) | _ -> map_constr substrec c in if is_empty_modlist modlist then c else substrec c let abstract_constant_type = List.fold_left (fun c d -> mkNamedProd_wo_LetIn d c) let abstract_constant_body = List.fold_left (fun c d -> mkNamedLambda_or_LetIn d c) type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = constant_def * constant_type * projection_body option * bool * constant_universes * inline * Context.section_context option let on_body ml hy f = function | Undef _ as x -> x | Def cs -> Def (Mod_subst.from_val (f (Mod_subst.force_constr cs))) | OpaqueDef o -> OpaqueDef (Opaqueproof.discharge_direct_opaque ~cook_constr:f { Opaqueproof.modlist = ml; abstract = hy } o) let constr_of_def otab = function | Undef _ -> assert false | Def cs -> Mod_subst.force_constr cs | OpaqueDef lc -> Opaqueproof.force_proof otab lc let expmod_constr_subst cache modlist subst c = let c = expmod_constr cache modlist c in Vars.subst_univs_level_constr subst c let cook_constr { Opaqueproof.modlist ; abstract } c = let cache = RefTable.create 13 in let expmod = expmod_constr_subst cache modlist (pi2 abstract) in let hyps = Context.Named.map expmod (pi1 abstract) in abstract_constant_body (expmod c) hyps let lift_univs cb subst = if cb.const_polymorphic && not (Univ.LMap.is_empty subst) then let inst = Univ.UContext.instance cb.const_universes in let cstrs = Univ.UContext.constraints cb.const_universes in let len = Univ.LMap.cardinal subst in let subst = Array.fold_left_i (fun i acc v -> Univ.LMap.add (Level.var i) (Level.var (i + len)) acc) subst (Univ.Instance.to_array inst) in let cstrs' = Univ.subst_univs_level_constraints subst cstrs in subst, Univ.UContext.make (inst,cstrs') else subst, cb.const_universes let cook_constant env { from = cb; info } = let { Opaqueproof.modlist; abstract } = info in let cache = RefTable.create 13 in let abstract, usubst, abs_ctx = abstract in let usubst, univs = lift_univs cb usubst in let expmod = expmod_constr_subst cache modlist usubst in let hyps = Context.Named.map expmod abstract in let body = on_body modlist (hyps, usubst, abs_ctx) (fun c -> abstract_constant_body (expmod c) hyps) cb.const_body in let const_hyps = Context.Named.fold_outside (fun decl hyps -> let open Context.Named.Declaration in List.filter (fun decl' -> not (Id.equal (get_id decl) (get_id decl'))) hyps) hyps ~init:cb.const_hyps in let typ = match cb.const_type with | RegularArity t -> let typ = abstract_constant_type (expmod t) hyps in RegularArity typ | TemplateArity (ctx,s) -> let t = mkArity (ctx,Type s.template_level) in let typ = abstract_constant_type (expmod t) hyps in let j = make_judge (constr_of_def (opaque_tables env) body) typ in Typeops.make_polymorphic_if_constant_for_ind env j in let projection pb = let c' = abstract_constant_body (expmod pb.proj_body) hyps in let etab = abstract_constant_body (expmod (fst pb.proj_eta)) hyps in let etat = abstract_constant_body (expmod (snd pb.proj_eta)) hyps in let ((mind, _), _), n' = try let c' = share_univs cache (IndRef (pb.proj_ind,0)) Univ.Instance.empty modlist in match kind_of_term c' with | App (f,l) -> (destInd f, Array.length l) | Ind ind -> ind, 0 | _ -> assert false with Not_found -> (((pb.proj_ind,0),Univ.Instance.empty), 0) in let typ = (* By invariant, a regular arity *) match typ with RegularArity t -> t | TemplateArity _ -> assert false in let ctx, ty' = decompose_prod_n (n' + pb.proj_npars + 1) typ in { proj_ind = mind; proj_npars = pb.proj_npars + n'; proj_arg = pb.proj_arg; proj_eta = etab, etat; proj_type = ty'; proj_body = c' } in let univs = let abs' = if cb.const_polymorphic then abs_ctx else instantiate_univ_context abs_ctx in UContext.union abs' univs in (body, typ, Option.map projection cb.const_proj, cb.const_polymorphic, univs, cb.const_inline_code, Some const_hyps) (* let cook_constant_key = Profile.declare_profile "cook_constant" *) (* let cook_constant = Profile.profile2 cook_constant_key cook_constant *) let expmod_constr modlist c = expmod_constr (RefTable.create 13) modlist c coq-8.6/kernel/cbytegen.mli0000644000175000017500000000360213022274260015243 0ustar mdenesmdenesopen Cbytecodes open Cemitcodes open Term open Declarations open Pre_env (** Should only be used for monomorphic terms *) val compile : bool -> (* Fail on error with a nice user message, otherwise simply a warning *) ?universes:int -> env -> constr -> (bytecodes * bytecodes * fv) option (** init, fun, fv *) val compile_constant_body : bool -> env -> constant_universes option -> constant_def -> body_code option (** Shortcut of the previous function used during module strengthening *) val compile_alias : Names.constant -> body_code (** spiwack: this function contains the information needed to perform the static compilation of int31 (trying and obtaining a 31-bit integer in processor representation at compile time) *) val compile_structured_int31 : bool -> constr array -> structured_constant (** this function contains the information needed to perform the dynamic compilation of int31 (trying and obtaining a 31-bit integer in processor representation at runtime when it failed at compile time *) val dynamic_int31_compilation : bool -> comp_env -> block array -> int -> bytecodes -> bytecodes (*spiwack: template for the compilation n-ary operation, invariant: n>=1. works as follow: checks if all the arguments are non-pointers if they are applies the operation (second argument) if not all of them are, returns to a coq definition (third argument) *) val op_compilation : int -> instruction -> pconstant -> bool -> comp_env -> constr array -> int -> bytecodes-> bytecodes (*spiwack: compiling function to insert dynamic decompilation before matching integers (in case they are in processor representation) *) val int31_escape_before_match : bool -> bytecodes -> bytecodes coq-8.6/kernel/names.mli0000644000175000017500000005472513022274260014562 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> bool (** Equality over identifiers. *) val compare : t -> t -> int (** Comparison over identifiers. *) val hash : t -> int (** Hash over identifiers. *) val is_valid : string -> bool (** Check that a string may be converted to an identifier. @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) val of_string : string -> t (** Converts a string into an identifier. @raise UserError if the string is not valid, or echo a warning if it contains invalid identifier characters. @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) val of_string_soft : string -> t (** Same as {!of_string} except that no warning is ever issued. @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) val to_string : t -> string (** Converts a identifier into an string. *) val print : t -> Pp.std_ppcmds (** Pretty-printer. *) module Set : Set.S with type elt = t (** Finite sets of identifiers. *) module Map : Map.ExtS with type key = t and module Set := Set (** Finite maps of identifiers. *) module Pred : Predicate.S with type elt = t (** Predicates over identifiers. *) module List : List.MonoS with type elt = t (** Operations over lists of identifiers. *) val hcons : t -> t (** Hashconsing of identifiers. *) end (** Representation and operations on identifiers that are allowed to be anonymous (i.e. "_" in concrete syntax). *) module Name : sig type t = Anonymous (** anonymous identifier *) | Name of Id.t (** non-anonymous identifier *) val is_anonymous : t -> bool (** Return [true] iff a given name is [Anonymous]. *) val is_name : t -> bool (** Return [true] iff a given name is [Name _]. *) val compare : t -> t -> int (** Comparison over names. *) val equal : t -> t -> bool (** Equality over names. *) val hash : t -> int (** Hash over names. *) val hcons : t -> t (** Hashconsing over names. *) end (** {6 Type aliases} *) type name = Name.t = Anonymous | Name of Id.t type variable = Id.t type module_ident = Id.t module ModIdset : Set.S with type elt = module_ident module ModIdmap : Map.ExtS with type key = module_ident and module Set := ModIdset (** {6 Directory paths = section names paths } *) module DirPath : sig type t (** Type of directory paths. Essentially a list of module identifiers. The order is reversed to improve sharing. E.g. A.B.C is ["C";"B";"A"] *) val equal : t -> t -> bool (** Equality over directory paths. *) val compare : t -> t -> int (** Comparison over directory paths. *) val hash : t -> int (** Hash over directory paths. *) val make : module_ident list -> t (** Create a directory path. (The list must be reversed). *) val repr : t -> module_ident list (** Represent a directory path. (The result list is reversed). *) val empty : t (** The empty directory path. *) val is_empty : t -> bool (** Test whether a directory path is empty. *) val to_string : t -> string (** Print directory paths as ["coq_root.module.submodule"] *) val initial : t (** Initial "seed" of the unique identifier generator *) val hcons : t -> t (** Hashconsing of directory paths. *) end (** {6 Names of structure elements } *) module Label : sig type t (** Type of labels *) val equal : t -> t -> bool (** Equality over labels *) val compare : t -> t -> int (** Comparison over labels. *) val hash : t -> int (** Hash over labels. *) val make : string -> t (** Create a label out of a string. *) val to_string : t -> string (** Conversion to string. *) val of_id : Id.t -> t (** Conversion from an identifier. *) val to_id : t -> Id.t (** Conversion to an identifier. *) val print : t -> Pp.std_ppcmds (** Pretty-printer. *) module Set : Set.S with type elt = t module Map : Map.ExtS with type key = t and module Set := Set val hcons : t -> t end (** {6 Unique names for bound modules} *) module MBId : sig type t (** Unique names for bound modules. Each call to [make] constructs a fresh unique identifier. *) val equal : t -> t -> bool (** Equality over unique bound names. *) val compare : t -> t -> int (** Comparison over unique bound names. *) val hash : t -> int (** Hash over unique bound names. *) val make : DirPath.t -> Id.t -> t (** The first argument is a file name, to prevent conflict between different files. *) val repr : t -> int * Id.t * DirPath.t (** Reverse of [make]. *) val to_id : t -> Id.t (** Return the identifier contained in the argument. *) val to_string : t -> string (** Conversion to a string. *) val debug_to_string : t -> string (** Same as [to_string], but outputs information related to debug. *) end module MBIset : Set.S with type elt = MBId.t module MBImap : Map.ExtS with type key = MBId.t and module Set := MBIset (** {6 The module part of the kernel name } *) module ModPath : sig type t = | MPfile of DirPath.t | MPbound of MBId.t | MPdot of t * Label.t val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val is_bound : t -> bool val to_string : t -> string val debug_to_string : t -> string (** Same as [to_string], but outputs information related to debug. *) val initial : t (** Name of the toplevel structure ([= MPfile initial_dir]) *) val dp : t -> DirPath.t end module MPset : Set.S with type elt = ModPath.t module MPmap : Map.ExtS with type key = ModPath.t and module Set := MPset (** {6 The absolute names of objects seen by kernel } *) module KerName : sig type t (** Constructor and destructor *) val make : ModPath.t -> DirPath.t -> Label.t -> t val make2 : ModPath.t -> Label.t -> t val repr : t -> ModPath.t * DirPath.t * Label.t (** Projections *) val modpath : t -> ModPath.t val label : t -> Label.t (** Display *) val to_string : t -> string val debug_to_string : t -> string (** Same as [to_string], but outputs information related to debug. *) val print : t -> Pp.std_ppcmds (** Comparisons *) val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int end 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 Constant Names } *) module Constant: sig type t (** Constructors *) val make : KerName.t -> KerName.t -> t (** Builds a constant name from a user and a canonical kernel name. *) val make1 : KerName.t -> t (** Special case of [make] where the user name is canonical. *) val make2 : ModPath.t -> Label.t -> t (** Shortcut for [(make1 (KerName.make2 ...))] *) val make3 : ModPath.t -> DirPath.t -> Label.t -> t (** Shortcut for [(make1 (KerName.make ...))] *) (** Projections *) val user : t -> KerName.t val canonical : t -> KerName.t val repr3 : t -> ModPath.t * DirPath.t * Label.t (** Shortcut for [KerName.repr (user ...)] *) val modpath : t -> ModPath.t (** Shortcut for [KerName.modpath (user ...)] *) val label : t -> Label.t (** Shortcut for [KerName.label (user ...)] *) (** 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 val equal : t -> t -> bool (** Default comparison, alias for [CanOrd.equal] *) val hash : t -> int (** Hashing function *) val change_label : t -> Label.t -> t (** Builds a new constant name with a different label *) (** Displaying *) val to_string : t -> string val print : t -> Pp.std_ppcmds val debug_to_string : t -> string val debug_print : t -> Pp.std_ppcmds end (** The [*_env] modules consider an order on user part of names the others consider an order on canonical part of names*) module Cpred : Predicate.S with type elt = Constant.t module Cset : CSig.SetS with type elt = Constant.t module Cset_env : CSig.SetS with type elt = Constant.t module Cmap : Map.ExtS with type key = Constant.t and module Set := Cset module Cmap_env : Map.ExtS with type key = Constant.t and module Set := Cset_env (** {6 Inductive names} *) module MutInd : sig type t (** Constructors *) val make : KerName.t -> KerName.t -> t (** Builds a mutual inductive name from a user and a canonical kernel name. *) val make1 : KerName.t -> t (** Special case of [make] where the user name is canonical. *) val make2 : ModPath.t -> Label.t -> t (** Shortcut for [(make1 (KerName.make2 ...))] *) val make3 : ModPath.t -> DirPath.t -> Label.t -> t (** Shortcut for [(make1 (KerName.make ...))] *) (** Projections *) val user : t -> KerName.t val canonical : t -> KerName.t val repr3 : t -> ModPath.t * DirPath.t * Label.t (** Shortcut for [KerName.repr (user ...)] *) val modpath : t -> ModPath.t (** Shortcut for [KerName.modpath (user ...)] *) val label : t -> Label.t (** Shortcut for [KerName.label (user ...)] *) (** 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 val equal : t -> t -> bool (** Default comparison, alias for [CanOrd.equal] *) val hash : t -> int (** Displaying *) val to_string : t -> string val print : t -> Pp.std_ppcmds val debug_to_string : t -> string val debug_print : t -> Pp.std_ppcmds end 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 : CSig.MapS 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. *) (** 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 Indmap : CSig.MapS with type key = inductive module Constrmap : CSig.MapS with type key = constructor module Indmap_env : CSig.MapS with type key = inductive module Constrmap_env : CSig.MapS with type key = constructor val ind_modpath : inductive -> ModPath.t val constr_modpath : constructor -> ModPath.t 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 val eq_user_ind : inductive -> inductive -> bool val eq_syntactic_ind : inductive -> inductive -> bool val ind_ord : inductive -> inductive -> int val ind_hash : inductive -> int val ind_user_ord : inductive -> inductive -> int val ind_user_hash : inductive -> int val ind_syntactic_ord : inductive -> inductive -> int val ind_syntactic_hash : inductive -> int val eq_constructor : constructor -> constructor -> bool val eq_user_constructor : constructor -> constructor -> bool val eq_syntactic_constructor : constructor -> constructor -> bool val constructor_ord : constructor -> constructor -> int val constructor_hash : constructor -> int val constructor_user_ord : constructor -> constructor -> int val constructor_user_hash : constructor -> int val constructor_syntactic_ord : constructor -> constructor -> int val constructor_syntactic_hash : constructor -> int (** Better to have it here that in Closure, since required in grammar.cma *) type evaluable_global_reference = | EvalVarRef of Id.t | EvalConstRef of Constant.t val eq_egr : evaluable_global_reference -> evaluable_global_reference -> bool (** {6 Hash-consing } *) val hcons_con : Constant.t -> Constant.t val hcons_mind : MutInd.t -> MutInd.t val hcons_ind : inductive -> inductive val hcons_construct : constructor -> constructor (******) type 'a tableKey = | ConstKey of 'a | VarKey of Id.t | RelKey of Int.t (** Sets of names *) type transparent_state = Id.Pred.t * Cpred.t val empty_transparent_state : transparent_state val full_transparent_state : transparent_state val var_full_transparent_state : transparent_state val cst_full_transparent_state : transparent_state type inv_rel_key = int (** index in the [rel_context] part of environment starting by the end, {e inverse} of de Bruijn indice *) val eq_table_key : ('a -> 'a -> bool) -> 'a tableKey -> 'a tableKey -> bool val eq_constant_key : Constant.t -> Constant.t -> bool (** equalities on constant and inductive names (for the checker) *) val eq_con_chk : Constant.t -> Constant.t -> bool val eq_ind_chk : inductive -> inductive -> bool (** {6 Deprecated functions. For backward compatibility.} *) (** {5 Identifiers} *) type identifier = Id.t (** @deprecated Alias for [Id.t] *) val string_of_id : identifier -> string (** @deprecated Same as [Id.to_string]. *) val id_of_string : string -> identifier (** @deprecated Same as [Id.of_string]. *) val id_ord : identifier -> identifier -> int (** @deprecated Same as [Id.compare]. *) val id_eq : identifier -> identifier -> bool (** @deprecated Same as [Id.equal]. *) module Idset : Set.S with type elt = identifier and type t = Id.Set.t (** @deprecated Same as [Id.Set]. *) module Idpred : Predicate.S with type elt = identifier and type t = Id.Pred.t (** @deprecated Same as [Id.Pred]. *) module Idmap : module type of Id.Map (** @deprecated Same as [Id.Map]. *) (** {5 Directory paths} *) type dir_path = DirPath.t (** @deprecated Alias for [DirPath.t]. *) val dir_path_ord : dir_path -> dir_path -> int (** @deprecated Same as [DirPath.compare]. *) val dir_path_eq : dir_path -> dir_path -> bool (** @deprecated Same as [DirPath.equal]. *) val make_dirpath : module_ident list -> dir_path (** @deprecated Same as [DirPath.make]. *) val repr_dirpath : dir_path -> module_ident list (** @deprecated Same as [DirPath.repr]. *) val empty_dirpath : dir_path (** @deprecated Same as [DirPath.empty]. *) val is_empty_dirpath : dir_path -> bool (** @deprecated Same as [DirPath.is_empty]. *) val string_of_dirpath : dir_path -> string (** @deprecated Same as [DirPath.to_string]. *) val initial_dir : DirPath.t (** @deprecated Same as [DirPath.initial]. *) (** {5 Labels} *) type label = Label.t (** Alias type *) val mk_label : string -> label (** @deprecated Same as [Label.make]. *) val string_of_label : label -> string (** @deprecated Same as [Label.to_string]. *) val pr_label : label -> Pp.std_ppcmds (** @deprecated Same as [Label.print]. *) val label_of_id : Id.t -> label (** @deprecated Same as [Label.of_id]. *) val id_of_label : label -> Id.t (** @deprecated Same as [Label.to_id]. *) val eq_label : label -> label -> bool (** @deprecated Same as [Label.equal]. *) (** {5 Unique bound module names} *) type mod_bound_id = MBId.t (** Alias type. *) val mod_bound_id_ord : mod_bound_id -> mod_bound_id -> int (** @deprecated Same as [MBId.compare]. *) val mod_bound_id_eq : mod_bound_id -> mod_bound_id -> bool (** @deprecated Same as [MBId.equal]. *) val make_mbid : DirPath.t -> Id.t -> mod_bound_id (** @deprecated Same as [MBId.make]. *) val repr_mbid : mod_bound_id -> int * Id.t * DirPath.t (** @deprecated Same as [MBId.repr]. *) val id_of_mbid : mod_bound_id -> Id.t (** @deprecated Same as [MBId.to_id]. *) val string_of_mbid : mod_bound_id -> string (** @deprecated Same as [MBId.to_string]. *) val debug_string_of_mbid : mod_bound_id -> string (** @deprecated Same as [MBId.debug_to_string]. *) (** {5 Names} *) val name_eq : name -> name -> bool (** @deprecated Same as [Name.equal]. *) (** {5 Module paths} *) type module_path = ModPath.t = | MPfile of DirPath.t | MPbound of MBId.t | MPdot of module_path * Label.t (** @deprecated Alias type *) val mp_ord : module_path -> module_path -> int (** @deprecated Same as [ModPath.compare]. *) val mp_eq : module_path -> module_path -> bool (** @deprecated Same as [ModPath.equal]. *) val check_bound_mp : module_path -> bool (** @deprecated Same as [ModPath.is_bound]. *) val string_of_mp : module_path -> string (** @deprecated Same as [ModPath.to_string]. *) val initial_path : module_path (** @deprecated Same as [ModPath.initial]. *) (** {5 Kernel names} *) type kernel_name = KerName.t (** @deprecated Alias type *) val make_kn : ModPath.t -> DirPath.t -> Label.t -> kernel_name (** @deprecated Same as [KerName.make]. *) val repr_kn : kernel_name -> module_path * DirPath.t * Label.t (** @deprecated Same as [KerName.repr]. *) val modpath : kernel_name -> module_path (** @deprecated Same as [KerName.modpath]. *) val label : kernel_name -> Label.t (** @deprecated Same as [KerName.label]. *) val string_of_kn : kernel_name -> string (** @deprecated Same as [KerName.to_string]. *) val pr_kn : kernel_name -> Pp.std_ppcmds (** @deprecated Same as [KerName.print]. *) val kn_ord : kernel_name -> kernel_name -> int (** @deprecated Same as [KerName.compare]. *) (** {5 Constant names} *) type constant = Constant.t (** @deprecated Alias type *) module Projection : sig type t val make : constant -> bool -> t module SyntacticOrd : sig val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int end val constant : t -> constant val unfolded : t -> bool val unfold : t -> t val equal : t -> t -> bool val hash : t -> int val hcons : t -> t (** Hashconsing of projections. *) val compare : t -> t -> int val map : (constant -> constant) -> t -> t val to_string : t -> string val print : t -> Pp.std_ppcmds end type projection = Projection.t val constant_of_kn_equiv : KerName.t -> KerName.t -> constant (** @deprecated Same as [Constant.make] *) val constant_of_kn : KerName.t -> constant (** @deprecated Same as [Constant.make1] *) val make_con : ModPath.t -> DirPath.t -> Label.t -> constant (** @deprecated Same as [Constant.make3] *) val repr_con : constant -> ModPath.t * DirPath.t * Label.t (** @deprecated Same as [Constant.repr3] *) val user_con : constant -> KerName.t (** @deprecated Same as [Constant.user] *) val canonical_con : constant -> KerName.t (** @deprecated Same as [Constant.canonical] *) val con_modpath : constant -> ModPath.t (** @deprecated Same as [Constant.modpath] *) val con_label : constant -> Label.t (** @deprecated Same as [Constant.label] *) val eq_constant : constant -> constant -> bool (** @deprecated Same as [Constant.equal] *) val con_ord : constant -> constant -> int (** @deprecated Same as [Constant.CanOrd.compare] *) val con_user_ord : constant -> constant -> int (** @deprecated Same as [Constant.UserOrd.compare] *) val con_with_label : constant -> Label.t -> constant (** @deprecated Same as [Constant.change_label] *) val string_of_con : constant -> string (** @deprecated Same as [Constant.to_string] *) val pr_con : constant -> Pp.std_ppcmds (** @deprecated Same as [Constant.print] *) val debug_pr_con : constant -> Pp.std_ppcmds (** @deprecated Same as [Constant.debug_print] *) val debug_string_of_con : constant -> string (** @deprecated Same as [Constant.debug_to_string] *) (** {5 Mutual Inductive names} *) type mutual_inductive = MutInd.t (** @deprecated Alias type *) val mind_of_kn : KerName.t -> mutual_inductive (** @deprecated Same as [MutInd.make1] *) val mind_of_kn_equiv : KerName.t -> KerName.t -> mutual_inductive (** @deprecated Same as [MutInd.make] *) val make_mind : ModPath.t -> DirPath.t -> Label.t -> mutual_inductive (** @deprecated Same as [MutInd.make3] *) val user_mind : mutual_inductive -> KerName.t (** @deprecated Same as [MutInd.user] *) val canonical_mind : mutual_inductive -> KerName.t (** @deprecated Same as [MutInd.canonical] *) val repr_mind : mutual_inductive -> ModPath.t * DirPath.t * Label.t (** @deprecated Same as [MutInd.repr3] *) val eq_mind : mutual_inductive -> mutual_inductive -> bool (** @deprecated Same as [MutInd.equal] *) val mind_ord : mutual_inductive -> mutual_inductive -> int (** @deprecated Same as [MutInd.CanOrd.compare] *) val mind_user_ord : mutual_inductive -> mutual_inductive -> int (** @deprecated Same as [MutInd.UserOrd.compare] *) val mind_label : mutual_inductive -> Label.t (** @deprecated Same as [MutInd.label] *) val mind_modpath : mutual_inductive -> ModPath.t (** @deprecated Same as [MutInd.modpath] *) val string_of_mind : mutual_inductive -> string (** @deprecated Same as [MutInd.to_string] *) val pr_mind : mutual_inductive -> Pp.std_ppcmds (** @deprecated Same as [MutInd.print] *) val debug_pr_mind : mutual_inductive -> Pp.std_ppcmds (** @deprecated Same as [MutInd.debug_print] *) val debug_string_of_mind : mutual_inductive -> string (** @deprecated Same as [MutInd.debug_to_string] *) coq-8.6/kernel/conv_oracle.mli0000644000175000017500000000324113022274260015734 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constant) -> oracle -> bool -> 'a tableKey -> 'a tableKey -> bool (** Priority for the expansion of constant in the conversion test. * Higher levels means that the expansion is less prioritary. * (And Expand stands for -oo, and Opaque +oo.) * The default value (transparent constants) is [Level 0]. *) type level = Expand | Level of int | Opaque val transparent : level (** Check whether a level is transparent *) val is_transparent : level -> bool val get_strategy : oracle -> constant tableKey -> level (** Sets the level of a constant. * Level of RelKey constant cannot be set. *) val set_strategy : oracle -> constant tableKey -> level -> oracle (** Fold over the non-transparent levels of the oracle. Order unspecified. *) val fold_strategy : (constant tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a val get_transp_state : oracle -> transparent_state coq-8.6/kernel/term.mli0000644000175000017500000004211013022274260014407 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool val isRelN : int -> constr -> bool val isVar : constr -> bool val isVarId : Id.t -> constr -> bool val isInd : constr -> bool val isEvar : constr -> bool val isMeta : constr -> bool val isMetaOf : metavariable -> constr -> bool val isEvar_or_Meta : constr -> bool val isSort : constr -> bool val isCast : constr -> bool val isApp : constr -> bool val isLambda : constr -> bool val isLetIn : constr -> bool val isProd : constr -> bool val isConst : constr -> bool val isConstruct : constr -> bool val isFix : constr -> bool val isCoFix : constr -> bool val isCase : constr -> bool val isProj : constr -> bool val is_Prop : constr -> bool val is_Set : constr -> bool val isprop : constr -> bool val is_Type : constr -> bool val iskind : constr -> bool val is_small : sorts -> bool (** {5 Term destructors } *) (** Destructor operations are partial functions and @raise DestKO if the term has not the expected form. *) exception DestKO (** Destructs a DeBrujin index *) val destRel : constr -> int (** Destructs an existential variable *) val destMeta : constr -> metavariable (** Destructs a variable *) val destVar : constr -> Id.t (** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) val destSort : constr -> sorts (** Destructs a casted term *) val destCast : constr -> constr * cast_kind * constr (** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) val destProd : types -> Name.t * types * types (** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) val destLambda : constr -> Name.t * types * constr (** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) val destLetIn : constr -> Name.t * constr * types * constr (** Destructs an application *) val destApp : constr -> constr * constr array (** Obsolete synonym of destApp *) val destApplication : constr -> constr * constr array (** Decompose any term as an applicative term; the list of args can be empty *) val decompose_app : constr -> constr * constr list (** Same as [decompose_app], but returns an array. *) val decompose_appvect : constr -> constr * constr array (** Destructs a constant *) val destConst : constr -> constant puniverses (** Destructs an existential variable *) val destEvar : constr -> existential (** Destructs a (co)inductive type *) val destInd : constr -> inductive puniverses (** Destructs a constructor *) val destConstruct : constr -> constructor puniverses (** Destructs a [match c as x in I args return P with ... | Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args return P in t1], or [if c then t1 else t2]) @return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] where [info] is pretty-printing information *) val destCase : constr -> case_info * constr * constr * constr array (** Destructs a projection *) val destProj : constr -> projection * constr (** Destructs the {% $ %}i{% $ %}th function of the block [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1} with f{_ 2} ctx{_ 2} = b{_ 2} ... with f{_ n} ctx{_ n} = b{_ n}], where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. *) val destFix : constr -> fixpoint val destCoFix : constr -> cofixpoint (** {5 Derived constructors} *) (** non-dependent product [t1 -> t2], an alias for [forall (_:t1), t2]. Beware [t_2] is NOT lifted. Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 1) (mkRel 2))] *) val mkArrow : types -> types -> constr (** Named version of the functions from [Term]. *) val mkNamedLambda : Id.t -> types -> constr -> constr val mkNamedLetIn : Id.t -> constr -> types -> constr -> constr val mkNamedProd : Id.t -> types -> types -> types (** Constructs either [(x:t)c] or [[x=b:t]c] *) val mkProd_or_LetIn : Context.Rel.Declaration.t -> types -> types val mkProd_wo_LetIn : Context.Rel.Declaration.t -> types -> types val mkNamedProd_or_LetIn : Context.Named.Declaration.t -> types -> types val mkNamedProd_wo_LetIn : Context.Named.Declaration.t -> types -> types (** Constructs either [[x:t]c] or [[x=b:t]c] *) val mkLambda_or_LetIn : Context.Rel.Declaration.t -> constr -> constr val mkNamedLambda_or_LetIn : Context.Named.Declaration.t -> constr -> constr (** {5 Other term constructors. } *) (** [applist (f,args)] and its variants work as [mkApp] *) val applist : constr * constr list -> constr val applistc : constr -> constr list -> constr val appvect : constr * constr array -> constr val appvectc : constr -> constr array -> constr (** [prodn n l b] = [forall (x_1:T_1)...(x_n:T_n), b] where [l] is [(x_n,T_n)...(x_1,T_1)...]. *) val prodn : int -> (Name.t * constr) list -> constr -> constr (** [compose_prod l b] @return [forall (x_1:T_1)...(x_n:T_n), b] where [l] is [(x_n,T_n)...(x_1,T_1)]. Inverse of [decompose_prod]. *) val compose_prod : (Name.t * constr) list -> constr -> constr (** [lamn n l b] @return [fun (x_1:T_1)...(x_n:T_n) => b] where [l] is [(x_n,T_n)...(x_1,T_1)...]. *) val lamn : int -> (Name.t * constr) list -> constr -> constr (** [compose_lam l b] @return [fun (x_1:T_1)...(x_n:T_n) => b] where [l] is [(x_n,T_n)...(x_1,T_1)]. Inverse of [it_destLam] *) val compose_lam : (Name.t * constr) list -> constr -> constr (** [to_lambda n l] @return [fun (x_1:T_1)...(x_n:T_n) => T] where [l] is [forall (x_1:T_1)...(x_n:T_n), T] *) val to_lambda : int -> constr -> constr (** [to_prod n l] @return [forall (x_1:T_1)...(x_n:T_n), T] where [l] is [fun (x_1:T_1)...(x_n:T_n) => T] *) val to_prod : int -> constr -> constr val it_mkLambda_or_LetIn : constr -> Context.Rel.t -> constr val it_mkProd_or_LetIn : types -> Context.Rel.t -> types (** In [lambda_applist c args], [c] is supposed to have the form [λΓ.c] with [Γ] without let-in; it returns [c] with the variables of [Γ] instantiated by [args]. *) val lambda_applist : constr -> constr list -> constr val lambda_appvect : constr -> constr array -> constr (** In [lambda_applist_assum n c args], [c] is supposed to have the form [λΓ.c] with [Γ] of length [m] and possibly with let-ins; it returns [c] with the assumptions of [Γ] instantiated by [args] and the local definitions of [Γ] expanded. *) val lambda_applist_assum : int -> constr -> constr list -> constr val lambda_appvect_assum : int -> constr -> constr array -> constr (** pseudo-reduction rule *) (** [prod_appvect] [forall (x1:B1;...;xn:Bn), B] [a1...an] @return [B[a1...an]] *) val prod_appvect : constr -> constr array -> constr val prod_applist : constr -> constr list -> constr (** In [prod_appvect_assum n c args], [c] is supposed to have the form [∀Γ.c] with [Γ] of length [m] and possibly with let-ins; it returns [c] with the assumptions of [Γ] instantiated by [args] and the local definitions of [Γ] expanded. *) val prod_appvect_assum : int -> constr -> constr array -> constr val prod_applist_assum : int -> constr -> constr list -> constr (** {5 Other term destructors. } *) (** Transforms a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product. *) val decompose_prod : constr -> (Name.t*constr) list * constr (** Transforms a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a lambda. *) val decompose_lam : constr -> (Name.t*constr) list * constr (** Given a positive integer n, decompose a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair {% $ %}([(xn,Tn);...;(x1,T1)],T){% $ %}. Raise a user error if not enough products. *) val decompose_prod_n : int -> constr -> (Name.t * constr) list * constr (** Given a positive integer {% $ %}n{% $ %}, decompose a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}. Raise a user error if not enough lambdas. *) val decompose_lam_n : int -> constr -> (Name.t * constr) list * constr (** Extract the premisses and the conclusion of a term of the form "(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *) val decompose_prod_assum : types -> Context.Rel.t * types (** Idem with lambda's and let's *) val decompose_lam_assum : constr -> Context.Rel.t * constr (** Idem but extract the first [n] premisses, counting let-ins. *) val decompose_prod_n_assum : int -> types -> Context.Rel.t * types (** Idem for lambdas, _not_ counting let-ins *) val decompose_lam_n_assum : int -> constr -> Context.Rel.t * constr (** Idem, counting let-ins *) val decompose_lam_n_decls : int -> constr -> Context.Rel.t * constr (** Return the premisses/parameters of a type/term (let-in included) *) val prod_assum : types -> Context.Rel.t val lam_assum : constr -> Context.Rel.t (** Return the first n-th premisses/parameters of a type (let included and counted) *) val prod_n_assum : int -> types -> Context.Rel.t (** Return the first n-th premisses/parameters of a term (let included but not counted) *) val lam_n_assum : int -> constr -> Context.Rel.t (** Remove the premisses/parameters of a type/term *) val strip_prod : types -> types val strip_lam : constr -> constr (** Remove the first n-th premisses/parameters of a type/term *) val strip_prod_n : int -> types -> types val strip_lam_n : int -> constr -> constr (** Remove the premisses/parameters of a type/term (including let-in) *) val strip_prod_assum : types -> types val strip_lam_assum : constr -> constr (** Flattens application lists *) val collapse_appl : constr -> constr (** Remove recursively the casts around a term i.e. [strip_outer_cast (Cast (Cast ... (Cast c, t) ... ))] is [c]. *) val strip_outer_cast : constr -> constr (** Apply a function letting Casted types in place *) val under_casts : (constr -> constr) -> constr -> constr (** Apply a function under components of Cast if any *) val under_outer_cast : (constr -> constr) -> constr -> constr (** {5 ... } *) (** An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort. Such a term can canonically be seen as the pair of a context of types and of a sort *) type arity = Context.Rel.t * sorts (** Build an "arity" from its canonical form *) val mkArity : arity -> types (** Destruct an "arity" into its canonical form *) val destArity : types -> arity (** Tell if a term has the form of an arity *) val isArity : types -> bool (** {5 Kind of type} *) type ('constr, 'types) kind_of_type = | SortType of sorts | CastType of 'types * 'types | ProdType of Name.t * 'types * 'types | LetInType of Name.t * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array val kind_of_type : types -> (constr, types) kind_of_type (** {5 Redeclaration of stuff from module [Sorts]} *) val set_sort : sorts (** Alias for Sorts.set *) val prop_sort : sorts (** Alias for Sorts.prop *) val type1_sort : sorts (** Alias for Sorts.type1 *) val sorts_ord : sorts -> sorts -> int (** Alias for Sorts.compare *) val is_prop_sort : sorts -> bool (** Alias for Sorts.is_prop *) val family_of_sort : sorts -> sorts_family (** Alias for Sorts.family *) (** {5 Redeclaration of stuff from module [Constr]} See module [Constr] for further info. *) (** {6 Term constructors. } *) val mkRel : int -> constr val mkVar : Id.t -> constr val mkMeta : metavariable -> constr val mkEvar : existential -> constr val mkSort : sorts -> types val mkProp : types val mkSet : types val mkType : Univ.universe -> types val mkCast : constr * cast_kind * constr -> constr val mkProd : Name.t * types * types -> types val mkLambda : Name.t * types * constr -> constr val mkLetIn : Name.t * constr * types * constr -> constr val mkApp : constr * constr array -> constr val mkConst : constant -> constr val mkProj : projection * constr -> constr val mkInd : inductive -> constr val mkConstruct : constructor -> constr val mkConstU : constant puniverses -> constr val mkIndU : inductive puniverses -> constr val mkConstructU : constructor puniverses -> constr val mkConstructUi : (pinductive * int) -> constr val mkCase : case_info * constr * constr * constr array -> constr val mkFix : fixpoint -> constr val mkCoFix : cofixpoint -> constr (** {6 Aliases} *) val eq_constr : constr -> constr -> bool (** Alias for [Constr.equal] *) (** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts, application grouping and the universe constraints in [u]. *) val eq_constr_univs : constr UGraph.check_function (** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo alpha, casts, application grouping and the universe constraints in [u]. *) val leq_constr_univs : constr UGraph.check_function (** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and ignoring universe instances. *) val eq_constr_nounivs : constr -> constr -> bool val kind_of_term : constr -> (constr, types) kind_of_term (** Alias for [Constr.kind] *) val constr_ord : constr -> constr -> int (** Alias for [Constr.compare] *) val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a (** Alias for [Constr.fold] *) val map_constr : (constr -> constr) -> constr -> constr (** Alias for [Constr.map] *) val map_constr_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr (** Alias for [Constr.map_with_binders] *) val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses val univ_of_sort : sorts -> Univ.universe val sort_of_univ : Univ.universe -> sorts val iter_constr : (constr -> unit) -> constr -> unit (** Alias for [Constr.iter] *) val iter_constr_with_binders : ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit (** Alias for [Constr.iter_with_binders] *) val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool (** Alias for [Constr.compare_head] *) val hash_constr : constr -> int (** Alias for [Constr.hash] *) (*********************************************************************) val hcons_sorts : sorts -> sorts (** Alias for [Constr.hashcons_sorts] *) val hcons_constr : constr -> constr (** Alias for [Constr.hashcons] *) val hcons_types : types -> types (** Alias for [Constr.hashcons] *) coq-8.6/kernel/csymtable.mli0000644000175000017500000000130413022274260015423 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> values val set_opaque_const : constant -> unit val set_transparent_const : constant -> unit coq-8.6/kernel/uGraph.ml0000644000175000017500000006733113022274260014531 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* () | Canonical n -> n.status <- NoMark in UMap.iter iter g.entries let rec cleanup_universes g = try unsafe_cleanup_universes g with e -> (** The only way unsafe_cleanup_universes may raise an exception is when a serious error (stack overflow, out of memory) occurs, or a signal is sent. In this unlikely event, we relaunch the cleanup until we finally succeed. *) cleanup_universes g; raise e (* Every Level.t has a unique canonical arc representative *) (* Low-level function : makes u an alias for v. Does not removes edges from n_edges, but decrements n_nodes. u should be entered as canonical before. *) let enter_equiv g u v = { entries = UMap.modify u (fun _ a -> match a with | Canonical n -> n.status <- NoMark; Equiv v | _ -> assert false) g.entries; index = g.index; n_nodes = g.n_nodes - 1; n_edges = g.n_edges } (* Low-level function : changes data associated with a canonical node. Resets the mutable fields in the old record, in order to avoid breaking invariants for other users of this record. n.univ should already been inserted as a canonical node. *) let change_node g n = { g with entries = UMap.modify n.univ (fun _ a -> match a with | Canonical n' -> n'.status <- NoMark; Canonical n | _ -> assert false) g.entries } (* repr : universes -> Level.t -> canonical_node *) (* canonical representative : we follow the Equiv links *) let rec repr g u = let a = try UMap.find u g.entries with Not_found -> CErrors.anomaly ~label:"Univ.repr" (str"Universe " ++ Level.pr u ++ str" undefined") in match a with | Equiv v -> repr g v | Canonical arc -> arc let get_set_arc g = repr g Level.set let is_set_arc u = Level.is_set u.univ let is_prop_arc u = Level.is_prop u.univ exception AlreadyDeclared (* Reindexes the given universe, using the next available index. *) let use_index g u = let u = repr g u in let g = change_node g { u with ilvl = g.index } in assert (g.index > min_int); { g with index = g.index - 1 } (* [safe_repr] is like [repr] but if the graph doesn't contain the searched universe, we add it. *) let safe_repr g u = let rec safe_repr_rec entries u = match UMap.find u entries with | Equiv v -> safe_repr_rec entries v | Canonical arc -> arc in try g, safe_repr_rec g.entries u with Not_found -> let can = { univ = u; ltle = UMap.empty; gtge = LSet.empty; rank = if Level.is_small u then big_rank else 0; klvl = 0; ilvl = 0; status = NoMark } in let g = { g with entries = UMap.add u (Canonical can) g.entries; n_nodes = g.n_nodes + 1 } in let g = use_index g u in g, repr g u (* Returns 1 if u is higher than v in topological order. -1 lower 0 if u = v *) let topo_compare u v = if u.klvl > v.klvl then 1 else if u.klvl < v.klvl then -1 else if u.ilvl > v.ilvl then 1 else if u.ilvl < v.ilvl then -1 else (assert (u==v); 0) (* Checks most of the invariants of the graph. For debugging purposes. *) let check_universes_invariants g = let n_edges = ref 0 in let n_nodes = ref 0 in UMap.iter (fun l u -> match u with | Canonical u -> UMap.iter (fun v strict -> incr n_edges; let v = repr g v in assert (topo_compare u v = -1); if u.klvl = v.klvl then assert (LSet.mem u.univ v.gtge || LSet.exists (fun l -> u == repr g l) v.gtge)) u.ltle; LSet.iter (fun v -> let v = repr g v in assert (v.klvl = u.klvl && (UMap.mem u.univ v.ltle || UMap.exists (fun l _ -> u == repr g l) v.ltle)) ) u.gtge; assert (u.status = NoMark); assert (Level.equal l u.univ); assert (u.ilvl > g.index); assert (not (UMap.mem u.univ u.ltle)); incr n_nodes | Equiv _ -> assert (not (Level.is_small l))) g.entries; assert (!n_edges = g.n_edges); assert (!n_nodes = g.n_nodes) let clean_ltle g ltle = UMap.fold (fun u strict acc -> let uu = (repr g u).univ in if Level.equal uu u then acc else ( let acc = UMap.remove u (fst acc) in if not strict && UMap.mem uu acc then (acc, true) else (UMap.add uu strict acc, true))) ltle (ltle, false) let clean_gtge g gtge = LSet.fold (fun u acc -> let uu = (repr g u).univ in if Level.equal uu u then acc else LSet.add uu (LSet.remove u (fst acc)), true) gtge (gtge, false) (* [get_ltle] and [get_gtge] return ltle and gtge arcs. Moreover, if one of these lists is dirty (e.g. points to a non-canonical node), these functions clean this node in the graph by removing some duplicate edges *) let get_ltle g u = let ltle, chgt_ltle = clean_ltle g u.ltle in if not chgt_ltle then u.ltle, u, g else let sz = UMap.cardinal u.ltle in let sz2 = UMap.cardinal ltle in let u = { u with ltle } in let g = change_node g u in let g = { g with n_edges = g.n_edges + sz2 - sz } in u.ltle, u, g let get_gtge g u = let gtge, chgt_gtge = clean_gtge g u.gtge in if not chgt_gtge then u.gtge, u, g else let u = { u with gtge } in let g = change_node g u in u.gtge, u, g (* [revert_graph] rollbacks the changes made to mutable fields in nodes in the graph. [to_revert] contains the touched nodes. *) let revert_graph to_revert g = List.iter (fun t -> match UMap.find t g.entries with | Equiv _ -> () | Canonical t -> t.status <- NoMark) to_revert exception AbortBackward of universes exception CycleDetected (* Implementation of the algorithm described in § 5.1 of the following paper: Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A new approach to incremental cycle detection and related problems. arXiv preprint arXiv:1112.0784. The "STEP X" comments contained in this file refers to the corresponding step numbers of the algorithm described in Section 5.1 of this paper. *) (* [delta] is the timeout for backward search. It might be useful to tune a multiplicative constant. *) let get_delta g = int_of_float (min (float_of_int g.n_edges ** 0.5) (float_of_int g.n_nodes ** (2./.3.))) let rec backward_traverse to_revert b_traversed count g x = let x = repr g x in let count = count - 1 in if count < 0 then begin revert_graph to_revert g; raise (AbortBackward g) end; if x.status = NoMark then begin x.status <- Visited; let to_revert = x.univ::to_revert in let gtge, x, g = get_gtge g x in let to_revert, b_traversed, count, g = LSet.fold (fun y (to_revert, b_traversed, count, g) -> backward_traverse to_revert b_traversed count g y) gtge (to_revert, b_traversed, count, g) in to_revert, x.univ::b_traversed, count, g end else to_revert, b_traversed, count, g let rec forward_traverse f_traversed g v_klvl x y = let y = repr g y in if y.klvl < v_klvl then begin let y = { y with klvl = v_klvl; gtge = if x == y then LSet.empty else LSet.singleton x.univ } in let g = change_node g y in let ltle, y, g = get_ltle g y in let f_traversed, g = UMap.fold (fun z _ (f_traversed, g) -> forward_traverse f_traversed g v_klvl y z) ltle (f_traversed, g) in y.univ::f_traversed, g end else if y.klvl = v_klvl && x != y then let g = change_node g { y with gtge = LSet.add x.univ y.gtge } in f_traversed, g else f_traversed, g let rec find_to_merge to_revert g x v = let x = repr g x in match x.status with | Visited -> false, to_revert | ToMerge -> true, to_revert | NoMark -> let to_revert = x::to_revert in if Level.equal x.univ v then begin x.status <- ToMerge; true, to_revert end else begin let merge, to_revert = LSet.fold (fun y (merge, to_revert) -> let merge', to_revert = find_to_merge to_revert g y v in merge' || merge, to_revert) x.gtge (false, to_revert) in x.status <- if merge then ToMerge else Visited; merge, to_revert end | _ -> assert false let get_new_edges g to_merge = (* Computing edge sets. *) let to_merge_lvl = List.fold_left (fun acc u -> UMap.add u.univ u acc) UMap.empty to_merge in let ltle = UMap.fold (fun _ n acc -> UMap.merge (fun _ strict1 strict2 -> match strict1, strict2 with | Some true, _ | _, Some true -> Some true | _, _ -> Some false) acc n.ltle) to_merge_lvl UMap.empty in let ltle, _ = clean_ltle g ltle in let ltle = UMap.merge (fun _ a strict -> match a, strict with | Some _, Some true -> (* There is a lt edge inside the new component. This is a "bad cycle". *) raise CycleDetected | Some _, Some false -> None | _, _ -> strict ) to_merge_lvl ltle in let gtge = UMap.fold (fun _ n acc -> LSet.union acc n.gtge) to_merge_lvl LSet.empty in let gtge, _ = clean_gtge g gtge in let gtge = LSet.diff gtge (UMap.domain to_merge_lvl) in (ltle, gtge) let reorder g u v = (* STEP 2: backward search in the k-level of u. *) let delta = get_delta g in (* [v_klvl] is the chosen future level for u, v and all traversed nodes. *) let b_traversed, v_klvl, g = try let to_revert, b_traversed, _, g = backward_traverse [] [] delta g u in revert_graph to_revert g; let v_klvl = (repr g u).klvl in b_traversed, v_klvl, g with AbortBackward g -> (* Backward search was too long, use the next k-level. *) let v_klvl = (repr g u).klvl + 1 in [], v_klvl, g in let f_traversed, g = (* STEP 3: forward search. Contrary to what is described in the paper, we do not test whether v_klvl = u.klvl nor we assign v_klvl to v.klvl. Indeed, the first call to forward_traverse will do all that. *) forward_traverse [] g v_klvl (repr g v) v in (* STEP 4: merge nodes if needed. *) let to_merge, b_reindex, f_reindex = if (repr g u).klvl = v_klvl then begin let merge, to_revert = find_to_merge [] g u v in let r = if merge then List.filter (fun u -> u.status = ToMerge) to_revert, List.filter (fun u -> (repr g u).status <> ToMerge) b_traversed, List.filter (fun u -> (repr g u).status <> ToMerge) f_traversed else [], b_traversed, f_traversed in List.iter (fun u -> u.status <- NoMark) to_revert; r end else [], b_traversed, f_traversed in let to_reindex, g = match to_merge with | [] -> List.rev_append f_reindex b_reindex, g | n0::q0 -> (* Computing new root. *) let root, rank_rest = List.fold_left (fun ((best, rank_rest) as acc) n -> if n.rank >= best.rank then n, best.rank else acc) (n0, min_int) q0 in let ltle, gtge = get_new_edges g to_merge in (* Inserting the new root. *) let g = change_node g { root with ltle; gtge; rank = max root.rank (rank_rest + 1); } in (* Inserting shortcuts for old nodes. *) let g = List.fold_left (fun g n -> if Level.equal n.univ root.univ then g else enter_equiv g n.univ root.univ) g to_merge in (* Updating g.n_edges *) let oldsz = List.fold_left (fun sz u -> sz+UMap.cardinal u.ltle) 0 to_merge in let sz = UMap.cardinal ltle in let g = { g with n_edges = g.n_edges + sz - oldsz } in (* Not clear in the paper: we have to put the newly created component just between B and F. *) List.rev_append f_reindex (root.univ::b_reindex), g in (* STEP 5: reindex traversed nodes. *) List.fold_left use_index g to_reindex (* Assumes [u] and [v] are already in the graph. *) (* Does NOT assume that ucan != vcan. *) let insert_edge strict ucan vcan g = try let u = ucan.univ and v = vcan.univ in (* STEP 1: do we need to reorder nodes ? *) let g = if topo_compare ucan vcan <= 0 then g else reorder g u v in (* STEP 6: insert the new edge in the graph. *) let u = repr g u in let v = repr g v in if u == v then if strict then raise CycleDetected else g else let g = try let oldstrict = UMap.find v.univ u.ltle in if strict && not oldstrict then change_node g { u with ltle = UMap.add v.univ true u.ltle } else g with Not_found -> { (change_node g { u with ltle = UMap.add v.univ strict u.ltle }) with n_edges = g.n_edges + 1 } in if u.klvl <> v.klvl || LSet.mem u.univ v.gtge then g else let v = { v with gtge = LSet.add u.univ v.gtge } in change_node g v with | CycleDetected as e -> raise e | e -> (** Unlikely event: fatal error or signal *) let () = cleanup_universes g in raise e let add_universe vlev strict g = try let _arcv = UMap.find vlev g.entries in raise AlreadyDeclared with Not_found -> assert (g.index > min_int); let v = { univ = vlev; ltle = LMap.empty; gtge = LSet.empty; rank = 0; klvl = 0; ilvl = g.index; status = NoMark; } in let entries = UMap.add vlev (Canonical v) g.entries in let g = { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } in insert_edge strict (get_set_arc g) v g exception Found_explanation of explanation let get_explanation strict u v g = let v = repr g v in let visited_strict = ref UMap.empty in let rec traverse strict u = if u == v then if strict then None else Some [] else if topo_compare u v = 1 then None else let visited = try not (UMap.find u.univ !visited_strict) || strict with Not_found -> false in if visited then None else begin visited_strict := UMap.add u.univ strict !visited_strict; try UMap.iter (fun u' strictu' -> match traverse (strict && not strictu') (repr g u') with | None -> () | Some exp -> let typ = if strictu' then Lt else Le in raise (Found_explanation ((typ, make u') :: exp))) u.ltle; None with Found_explanation exp -> Some exp end in let u = repr g u in if u == v then [(Eq, make v.univ)] else match traverse strict u with Some exp -> exp | None -> assert false let get_explanation strict u v g = if !Flags.univ_print then Some (get_explanation strict u v g) else None (* To compare two nodes, we simply do a forward search. We implement two improvements: - we ignore nodes that are higher than the destination; - we do a BFS rather than a DFS because we expect to have a short path (typically, the shortest path has length 1) *) exception Found of canonical_node list let search_path strict u v g = let rec loop to_revert todo next_todo = match todo, next_todo with | [], [] -> to_revert (* No path found *) | [], _ -> loop to_revert next_todo [] | (u, strict)::todo, _ -> if u.status = Visited || (u.status = WeakVisited && strict) then loop to_revert todo next_todo else let to_revert = if u.status = NoMark then u::to_revert else to_revert in u.status <- if strict then WeakVisited else Visited; if try UMap.find v.univ u.ltle || not strict with Not_found -> false then raise (Found to_revert) else begin let next_todo = UMap.fold (fun u strictu next_todo -> let strict = not strictu && strict in let u = repr g u in if u == v && not strict then raise (Found to_revert) else if topo_compare u v = 1 then next_todo else (u, strict)::next_todo) u.ltle next_todo in loop to_revert todo next_todo end in if u == v then not strict else try let res, to_revert = try false, loop [] [u, strict] [] with Found to_revert -> true, to_revert in List.iter (fun u -> u.status <- NoMark) to_revert; res with e -> (** Unlikely event: fatal error or signal *) let () = cleanup_universes g in raise e (** Uncomment to debug the cycle detection algorithm. *) (*let insert_edge strict ucan vcan g = check_universes_invariants g; let g = insert_edge strict ucan vcan g in check_universes_invariants g; let ucan = repr g ucan.univ in let vcan = repr g vcan.univ in assert (search_path strict ucan vcan g); g*) (** First, checks on universe levels *) let check_equal g u v = let arcu = repr g u and arcv = repr g v in arcu == arcv let check_eq_level g u v = u == v || check_equal g u v let check_smaller g strict u v = let arcu = repr g u and arcv = repr g v in if strict then search_path true arcu arcv g else is_prop_arc arcu || (is_set_arc arcu && not (is_prop_arc arcv)) || search_path false arcu arcv g (** Then, checks on universes *) type 'a check_function = universes -> 'a -> 'a -> bool let check_smaller_expr g (u,n) (v,m) = let diff = n - m in match diff with | 0 -> check_smaller g false u v | 1 -> check_smaller g true u v | x when x < 0 -> check_smaller g false u v | _ -> false let exists_bigger g ul l = Universe.exists (fun ul' -> check_smaller_expr g ul ul') l let real_check_leq g u v = Universe.for_all (fun ul -> exists_bigger g ul v) u let check_leq g u v = Universe.equal u v || is_type0m_univ u || real_check_leq g u v let check_eq_univs g l1 l2 = real_check_leq g l1 l2 && real_check_leq g l2 l1 let check_eq g u v = Universe.equal u v || check_eq_univs g u v (* enforce_univ_eq g u v will force u=v if possible, will fail otherwise *) let rec enforce_univ_eq u v g = let ucan = repr g u in let vcan = repr g v in if topo_compare ucan vcan = 1 then enforce_univ_eq v u g else let g = insert_edge false ucan vcan g in (* Cannot fail *) try insert_edge false vcan ucan g with CycleDetected -> error_inconsistency Eq v u (get_explanation true u v g) (* enforce_univ_leq g u v will force u<=v if possible, will fail otherwise *) let enforce_univ_leq u v g = let ucan = repr g u in let vcan = repr g v in try insert_edge false ucan vcan g with CycleDetected -> error_inconsistency Le u v (get_explanation true v u g) (* enforce_univ_lt u v will force u error_inconsistency Lt u v (get_explanation false v u g) let empty_universes = let set_arc = Canonical { univ = Level.set; ltle = LMap.empty; gtge = LSet.empty; rank = big_rank; klvl = 0; ilvl = (-1); status = NoMark; } in let prop_arc = Canonical { univ = Level.prop; ltle = LMap.empty; gtge = LSet.empty; rank = big_rank; klvl = 0; ilvl = 0; status = NoMark; } in let entries = UMap.add Level.set set_arc (UMap.singleton Level.prop prop_arc) in let empty = { entries; index = (-2); n_nodes = 2; n_edges = 0 } in enforce_univ_lt Level.prop Level.set empty (* Prop = Set is forbidden here. *) let initial_universes = empty_universes let is_initial_universes g = UMap.equal (==) g.entries initial_universes.entries let enforce_constraint cst g = match cst with | (u,Lt,v) -> enforce_univ_lt u v g | (u,Le,v) -> enforce_univ_leq u v g | (u,Eq,v) -> enforce_univ_eq u v g let merge_constraints c g = Constraint.fold enforce_constraint c g let check_constraint g (l,d,r) = match d with | Eq -> check_equal g l r | Le -> check_smaller g false l r | Lt -> check_smaller g true l r let check_constraints c g = Constraint.for_all (check_constraint g) c (* Normalization *) (** [normalize_universes g] returns a graph where all edges point directly to the canonical representent of their target. The output graph should be equivalent to the input graph from a logical point of view, but optimized. We maintain the invariant that the key of a [Canonical] element is its own name, by keeping [Equiv] edges. *) let normalize_universes g = let g = { g with entries = UMap.map (fun entry -> match entry with | Equiv u -> Equiv ((repr g u).univ) | Canonical ucan -> Canonical { ucan with rank = 1 }) g.entries } in UMap.fold (fun _ u g -> match u with | Equiv u -> g | Canonical u -> let _, u, g = get_ltle g u in let _, _, g = get_gtge g u in g) g.entries g let constraints_of_universes g = let constraints_of u v acc = match v with | Canonical {univ=u; ltle} -> UMap.fold (fun v strict acc-> let typ = if strict then Lt else Le in Constraint.add (u,typ,v) acc) ltle acc | Equiv v -> Constraint.add (u,Eq,v) acc in UMap.fold constraints_of g.entries Constraint.empty let constraints_of_universes g = constraints_of_universes (normalize_universes g) (** [sort_universes g] builds a totally ordered universe graph. The output graph should imply the input graph (and the implication will be strict most of the time), but is not necessarily minimal. Moreover, it adds levels [Type.n] to identify universes at level n. An artificial constraint Set < Type.2 is added to ensure that Type.n and small universes are not merged. Note: the result is unspecified if the input graph already contains [Type.n] nodes (calling a module Type is probably a bad idea anyway). *) let sort_universes g = let cans = UMap.fold (fun _ u l -> match u with | Equiv _ -> l | Canonical can -> can :: l ) g.entries [] in let cans = List.sort topo_compare cans in let lowest_levels = UMap.mapi (fun u _ -> if Level.is_small u then 0 else 2) (UMap.filter (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true) g.entries) in let lowest_levels = List.fold_left (fun lowest_levels can -> let lvl = UMap.find can.univ lowest_levels in UMap.fold (fun u' strict lowest_levels -> let cost = if strict then 1 else 0 in let u' = (repr g u').univ in UMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest_levels) can.ltle lowest_levels) lowest_levels cans in let max_lvl = UMap.fold (fun _ a b -> max a b) lowest_levels 0 in let mp = Names.DirPath.make [Names.Id.of_string "Type"] in let types = Array.init (max_lvl + 1) (function | 0 -> Level.prop | 1 -> Level.set | n -> Level.make mp (n-2)) in let g = Array.fold_left (fun g u -> let g, u = safe_repr g u in change_node g { u with rank = big_rank }) g types in let g = if max_lvl >= 2 then enforce_univ_lt Level.set types.(2) g else g in let g = UMap.fold (fun u lvl g -> enforce_univ_eq u (types.(lvl)) g) lowest_levels g in normalize_universes g (** Instances *) let check_eq_instances g t1 t2 = let t1 = Instance.to_array t1 in let t2 = Instance.to_array t2 in t1 == t2 || (Int.equal (Array.length t1) (Array.length t2) && let rec aux i = (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) in aux 0) (** Pretty-printing *) let pr_arc prl = function | _, Canonical {univ=u; ltle} -> if UMap.is_empty ltle then mt () else prl u ++ str " " ++ v 0 (pr_sequence (fun (v, strict) -> (if strict then str "< " else str "<= ") ++ prl v) (UMap.bindings ltle)) ++ fnl () | u, Equiv v -> prl u ++ str " = " ++ prl v ++ fnl () let pr_universes prl g = let graph = UMap.fold (fun u a l -> (u,a)::l) g.entries [] in prlist (pr_arc prl) graph (* Dumping constraints to a file *) let dump_universes output g = let dump_arc u = function | Canonical {univ=u; ltle} -> let u_str = Level.to_string u in UMap.iter (fun v strict -> let typ = if strict then Lt else Le in output typ u_str (Level.to_string v)) ltle; | Equiv v -> output Eq (Level.to_string u) (Level.to_string v) in UMap.iter dump_arc g.entries (** Profiling *) let merge_constraints = if Flags.profile then let key = Profile.declare_profile "merge_constraints" in Profile.profile2 key merge_constraints else merge_constraints let check_constraints = if Flags.profile then let key = Profile.declare_profile "check_constraints" in Profile.profile2 key check_constraints else check_constraints let check_eq = if Flags.profile then let check_eq_key = Profile.declare_profile "check_eq" in Profile.profile3 check_eq_key check_eq else check_eq let check_leq = if Flags.profile then let check_leq_key = Profile.declare_profile "check_leq" in Profile.profile3 check_leq_key check_leq else check_leq coq-8.6/kernel/uint31.mli0000644000175000017500000000162013022274260014564 0ustar mdenesmdenestype t (* conversion to int *) val to_int : t -> int val of_int : int -> t val of_uint : int -> t (* conversion to a string *) val to_string : t -> string val of_string : string -> t (* logical operations *) val l_sl : t -> t -> t val l_sr : t -> t -> t val l_and : t -> t -> t val l_xor : t -> t -> t val l_or : t -> t -> t (* Arithmetic operations *) val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val div : t -> t -> t val rem : t -> t -> t (* Specific arithmetic operations *) val mulc : t -> t -> t * t val div21 : t -> t -> t -> t * t (* comparison *) val lt : t -> t -> bool val equal : t -> t -> bool val le : t -> t -> bool val compare : t -> t -> int (* head and tail *) val head0 : t -> t val tail0 : t -> t (** Used by retroknowledge *) val add_digit : t -> t -> t coq-8.6/kernel/declareops.ml0000644000175000017500000003216013022274260015414 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let x' = f sub x in if x' == x then ar else RegularArity x' | TemplateArity x -> let x' = g sub x in if x' == x then ar else TemplateArity x' let map_decl_arity f g = function | RegularArity a -> RegularArity (f a) | TemplateArity a -> TemplateArity (g a) let hcons_template_arity ar = { template_param_levels = ar.template_param_levels; (* List.smartmap (Option.smartmap Univ.hcons_univ_level) ar.template_param_levels; *) template_level = Univ.hcons_univ ar.template_level } (** {6 Constants } *) let instantiate cb c = if cb.const_polymorphic then Vars.subst_instance_constr (Univ.UContext.instance cb.const_universes) c else c let body_of_constant otab cb = match cb.const_body with | Undef _ -> None | Def c -> Some (instantiate cb (force_constr c)) | OpaqueDef o -> Some (instantiate cb (Opaqueproof.force_proof otab o)) let type_of_constant cb = match cb.const_type with | RegularArity t as x -> let t' = instantiate cb t in if t' == t then x else RegularArity t' | TemplateArity _ as x -> x let constraints_of_constant otab cb = Univ.Constraint.union (Univ.UContext.constraints cb.const_universes) (match cb.const_body with | Undef _ -> Univ.empty_constraint | Def c -> Univ.empty_constraint | OpaqueDef o -> Univ.ContextSet.constraints (Opaqueproof.force_constraints otab o)) let universes_of_constant otab cb = match cb.const_body with | Undef _ | Def _ -> cb.const_universes | OpaqueDef o -> let body_uctxs = Opaqueproof.force_constraints otab o in assert(not cb.const_polymorphic || Univ.ContextSet.is_empty body_uctxs); let uctxs = Univ.ContextSet.of_context cb.const_universes in Univ.ContextSet.to_context (Univ.ContextSet.union body_uctxs uctxs) let universes_of_polymorphic_constant otab cb = if cb.const_polymorphic then let univs = universes_of_constant otab cb in Univ.instantiate_univ_context univs else Univ.UContext.empty let constant_has_body cb = match cb.const_body with | Undef _ -> false | Def _ | OpaqueDef _ -> true let is_opaque cb = match cb.const_body with | OpaqueDef _ -> true | Undef _ | Def _ -> false (** {7 Constant substitutions } *) let subst_rel_declaration sub = map_constr (subst_mps sub) let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) let subst_template_cst_arity sub (ctx,s as arity) = let ctx' = subst_rel_context sub ctx in if ctx==ctx' then arity else (ctx',s) let subst_const_type sub arity = if is_empty_subst sub then arity else subst_mps sub arity (** No need here to check for physical equality after substitution, at least for Def due to the delayed substitution [subst_constr_subst]. *) let subst_const_def sub def = match def with | Undef _ -> def | Def c -> Def (subst_constr sub c) | OpaqueDef o -> OpaqueDef (Opaqueproof.subst_opaque sub o) let subst_const_proj sub pb = { pb with proj_ind = subst_mind sub pb.proj_ind; proj_type = subst_mps sub pb.proj_type; proj_body = subst_const_type sub pb.proj_body } let subst_const_body sub cb = assert (List.is_empty cb.const_hyps); (* we're outside sections *) if is_empty_subst sub then cb else let body' = subst_const_def sub cb.const_body in let type' = subst_decl_arity subst_const_type subst_template_cst_arity sub cb.const_type in let proj' = Option.smartmap (subst_const_proj sub) cb.const_proj in if body' == cb.const_body && type' == cb.const_type && proj' == cb.const_proj then cb else { const_hyps = []; const_body = body'; const_type = type'; const_proj = proj'; const_body_code = Option.map (Cemitcodes.subst_to_patch_subst sub) cb.const_body_code; const_polymorphic = cb.const_polymorphic; const_universes = cb.const_universes; const_inline_code = cb.const_inline_code; const_typing_flags = cb.const_typing_flags } (** {7 Hash-consing of constants } *) (** This hash-consing is currently quite partial : we only share internal fields (e.g. constr), and not the records themselves. But would it really bring substantial gains ? *) let hcons_rel_decl = map_type Term.hcons_types % map_value Term.hcons_constr % map_name Names.Name.hcons let hcons_rel_context l = List.smartmap hcons_rel_decl l let hcons_regular_const_arity t = Term.hcons_constr t let hcons_template_const_arity (ctx, ar) = (hcons_rel_context ctx, hcons_template_arity ar) let hcons_const_type = map_decl_arity hcons_regular_const_arity hcons_template_const_arity let hcons_const_def = function | Undef inl -> Undef inl | Def l_constr -> let constr = force_constr l_constr in Def (from_val (Term.hcons_constr constr)) | OpaqueDef _ as x -> x (* hashconsed when turned indirect *) let hcons_const_body cb = { cb with const_body = hcons_const_def cb.const_body; const_type = hcons_const_type cb.const_type; const_universes = Univ.hcons_universe_context cb.const_universes } (** {6 Inductive types } *) let eq_recarg r1 r2 = match r1, r2 with | Norec, Norec -> true | Mrec i1, Mrec i2 -> Names.eq_ind i1 i2 | Imbr i1, Imbr i2 -> Names.eq_ind i1 i2 | _ -> false let subst_recarg sub r = match r with | Norec -> r | Mrec (kn,i) -> let kn' = subst_mind sub kn in if kn==kn' then r else Mrec (kn',i) | Imbr (kn,i) -> let kn' = subst_mind sub kn in if kn==kn' then r else Imbr (kn',i) let mk_norec = Rtree.mk_node Norec [||] let mk_paths r recargs = Rtree.mk_node r (Array.map (fun l -> Rtree.mk_node Norec (Array.of_list l)) recargs) let dest_recarg p = fst (Rtree.dest_node p) (* dest_subterms returns the sizes of each argument of each constructor of an inductive object of size [p]. This should never be done for Norec, because the number of sons does not correspond to the number of constructors. *) let dest_subterms p = let (ra,cstrs) = Rtree.dest_node p in assert (match ra with Norec -> false | _ -> true); Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs let recarg_length p j = let (_,cstrs) = Rtree.dest_node p in Array.length (snd (Rtree.dest_node cstrs.(j-1))) let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p (** {7 Substitution of inductive declarations } *) let subst_regular_ind_arity sub s = let uar' = subst_mps sub s.mind_user_arity in if uar' == s.mind_user_arity then s else { mind_user_arity = uar'; mind_sort = s.mind_sort } let subst_template_ind_arity sub s = s (* FIXME records *) let subst_ind_arity = subst_decl_arity subst_regular_ind_arity subst_template_ind_arity let subst_mind_packet sub mbp = { mind_consnames = mbp.mind_consnames; mind_consnrealdecls = mbp.mind_consnrealdecls; mind_consnrealargs = mbp.mind_consnrealargs; mind_typename = mbp.mind_typename; mind_nf_lc = Array.smartmap (subst_mps sub) mbp.mind_nf_lc; mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; mind_arity = subst_ind_arity sub mbp.mind_arity; mind_user_lc = Array.smartmap (subst_mps sub) mbp.mind_user_lc; mind_nrealargs = mbp.mind_nrealargs; mind_nrealdecls = mbp.mind_nrealdecls; mind_kelim = mbp.mind_kelim; mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); mind_nb_constant = mbp.mind_nb_constant; mind_nb_args = mbp.mind_nb_args; mind_reloc_tbl = mbp.mind_reloc_tbl } let subst_mind_record sub (id, ps, pb as r) = let ps' = Array.smartmap (subst_constant sub) ps in let pb' = Array.smartmap (subst_const_proj sub) pb in if ps' == ps && pb' == pb then r else (id, ps', pb') let subst_mind_body sub mib = { mind_record = Option.smartmap (Option.smartmap (subst_mind_record sub)) mib.mind_record ; mind_finite = mib.mind_finite ; mind_ntypes = mib.mind_ntypes ; mind_hyps = (match mib.mind_hyps with [] -> [] | _ -> assert false); mind_nparams = mib.mind_nparams; mind_nparams_rec = mib.mind_nparams_rec; mind_params_ctxt = Context.Rel.map (subst_mps sub) mib.mind_params_ctxt; mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets ; mind_polymorphic = mib.mind_polymorphic; mind_universes = mib.mind_universes; mind_private = mib.mind_private; mind_typing_flags = mib.mind_typing_flags; } let inductive_instance mib = if mib.mind_polymorphic then Univ.UContext.instance mib.mind_universes else Univ.Instance.empty let inductive_context mib = if mib.mind_polymorphic then Univ.instantiate_univ_context mib.mind_universes else Univ.UContext.empty (** {6 Hash-consing of inductive declarations } *) let hcons_regular_ind_arity a = { mind_user_arity = Term.hcons_constr a.mind_user_arity; mind_sort = Term.hcons_sorts a.mind_sort } (** Just as for constants, this hash-consing is quite partial *) let hcons_ind_arity = map_decl_arity hcons_regular_ind_arity hcons_template_arity (** Substitution of inductive declarations *) let hcons_mind_packet oib = let user = Array.smartmap Term.hcons_types oib.mind_user_lc in let nf = Array.smartmap Term.hcons_types oib.mind_nf_lc in (* Special optim : merge [mind_user_lc] and [mind_nf_lc] if possible *) let nf = if Array.equal (==) user nf then user else nf in { oib with mind_typename = Names.Id.hcons oib.mind_typename; mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt; mind_arity = hcons_ind_arity oib.mind_arity; mind_consnames = Array.smartmap Names.Id.hcons oib.mind_consnames; mind_user_lc = user; mind_nf_lc = nf } let hcons_mind mib = { mib with mind_packets = Array.smartmap hcons_mind_packet mib.mind_packets; mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt; mind_universes = Univ.hcons_universe_context mib.mind_universes } (** {6 Stm machinery } *) let string_of_side_effect { Entries.eff } = match eff with | Entries.SEsubproof (c,_,_) -> "P(" ^ Names.string_of_con c ^ ")" | Entries.SEscheme (cl,_) -> "S(" ^ String.concat ", " (List.map (fun (_,c,_,_) -> Names.string_of_con c) cl) ^ ")" (** Hashconsing of modules *) let hcons_functorize hty he hself f = match f with | NoFunctor e -> let e' = he e in if e == e' then f else NoFunctor e' | MoreFunctor (mid, ty, nf) -> (** FIXME *) let mid' = mid in let ty' = hty ty in let nf' = hself nf in if mid == mid' && ty == ty' && nf == nf' then f else MoreFunctor (mid, ty', nf') let hcons_module_alg_expr me = me let rec hcons_structure_field_body sb = match sb with | SFBconst cb -> let cb' = hcons_const_body cb in if cb == cb' then sb else SFBconst cb' | SFBmind mib -> let mib' = hcons_mind mib in if mib == mib' then sb else SFBmind mib' | SFBmodule mb -> let mb' = hcons_module_body mb in if mb == mb' then sb else SFBmodule mb' | SFBmodtype mb -> let mb' = hcons_module_body mb in if mb == mb' then sb else SFBmodtype mb' and hcons_structure_body sb = (** FIXME *) let map (l, sfb as fb) = let l' = Names.Label.hcons l in let sfb' = hcons_structure_field_body sfb in if l == l' && sfb == sfb' then fb else (l', sfb') in List.smartmap map sb and hcons_module_signature ms = hcons_functorize hcons_module_body hcons_structure_body hcons_module_signature ms and hcons_module_expression me = hcons_functorize hcons_module_body hcons_module_alg_expr hcons_module_expression me and hcons_module_implementation mip = match mip with | Abstract -> Abstract | Algebraic me -> let me' = hcons_module_expression me in if me == me' then mip else Algebraic me' | Struct ms -> let ms' = hcons_module_signature ms in if ms == ms' then mip else Struct ms | FullStruct -> FullStruct and hcons_module_body mb = let mp' = mb.mod_mp in let expr' = hcons_module_implementation mb.mod_expr in let type' = hcons_module_signature mb.mod_type in let type_alg' = mb.mod_type_alg in let constraints' = Univ.hcons_universe_context_set mb.mod_constraints in let delta' = mb.mod_delta in let retroknowledge' = mb.mod_retroknowledge in if mb.mod_mp == mp' && mb.mod_expr == expr' && mb.mod_type == type' && mb.mod_type_alg == type_alg' && mb.mod_constraints == constraints' && mb.mod_delta == delta' && mb.mod_retroknowledge == retroknowledge' then mb else { mod_mp = mp'; mod_expr = expr'; mod_type = type'; mod_type_alg = type_alg'; mod_constraints = constraints'; mod_delta = delta'; mod_retroknowledge = retroknowledge'; } coq-8.6/kernel/nativelibrary.ml0000644000175000017500000000522513022274260016150 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let env' = add_structure mp struc empty_delta_resolver env in List.fold_left (translate_field prefix mp env') acc struc | MoreFunctor _ -> acc and translate_field prefix mp env acc (l,x) = match x with | SFBconst cb -> let con = make_con mp empty_dirpath l in (if !Flags.debug then let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in Feedback.msg_debug (Pp.str msg)); compile_constant_field (pre_env env) prefix con acc cb | SFBmind mb -> (if !Flags.debug then let id = mb.mind_packets.(0).mind_typename in let msg = Printf.sprintf "Compiling inductive %s..." (Id.to_string id) in Feedback.msg_debug (Pp.str msg)); compile_mind_field prefix mp l acc mb | SFBmodule md -> let mp = md.mod_mp in (if !Flags.debug then let msg = Printf.sprintf "Compiling module %s..." (ModPath.to_string mp) in Feedback.msg_debug (Pp.str msg)); translate_mod prefix mp env md.mod_type acc | SFBmodtype mdtyp -> let mp = mdtyp.mod_mp in (if !Flags.debug then let msg = Printf.sprintf "Compiling module type %s..." (ModPath.to_string mp) in Feedback.msg_debug (Pp.str msg)); translate_mod prefix mp env mdtyp.mod_type acc let dump_library mp dp env mod_expr = if !Flags.debug then Feedback.msg_debug (Pp.str "Compiling library..."); match mod_expr with | NoFunctor struc -> let env = add_structure mp struc empty_delta_resolver env in let prefix = mod_uid_of_dirpath dp ^ "." in let t0 = Sys.time () in clear_global_tbl (); clear_symbols (); let mlcode = List.fold_left (translate_field prefix mp env) [] struc in let t1 = Sys.time () in let time_info = Format.sprintf "Time spent generating this code: %.5fs" (t1-.t0) in let mlcode = add_header_comment (List.rev mlcode) time_info in mlcode, get_symbols () | _ -> assert false coq-8.6/kernel/entries.mli0000644000175000017500000000774413022274260015127 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let v = mk_rel_accu lvl in conv_val env CONV (lvl+1) (f1 v) (f2 v) cu | Vfun f1, _ -> conv_val env CONV lvl v1 (fun x -> v2 x) cu | _, Vfun f2 -> conv_val env CONV lvl (fun x -> v1 x) v2 cu | Vaccu k1, Vaccu k2 -> conv_accu env pb lvl k1 k2 cu | Vconst i1, Vconst i2 -> if Int.equal i1 i2 then cu else raise NotConvertible | Vblock b1, Vblock b2 -> let n1 = block_size b1 in let n2 = block_size b2 in if not (Int.equal (block_tag b1) (block_tag b2)) || not (Int.equal n1 n2) then raise NotConvertible; let rec aux lvl max b1 b2 i cu = if Int.equal i max then conv_val env CONV lvl (block_field b1 i) (block_field b2 i) cu else let cu = conv_val env CONV lvl (block_field b1 i) (block_field b2 i) cu in aux lvl max b1 b2 (i+1) cu in aux lvl (n1-1) b1 b2 0 cu | Vaccu _, _ | Vconst _, _ | Vblock _, _ -> raise NotConvertible and conv_accu env pb lvl k1 k2 cu = let n1 = accu_nargs k1 in let n2 = accu_nargs k2 in if not (Int.equal n1 n2) then raise NotConvertible; if Int.equal n1 0 then conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu else let cu = conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu in List.fold_right2 (conv_val env CONV lvl) (args_of_accu k1) (args_of_accu k2) cu and conv_atom env pb lvl a1 a2 cu = if a1 == a2 then cu else match a1, a2 with | Ameta _, _ | _, Ameta _ | Aevar _, _ | _, Aevar _ -> assert false | 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 else raise NotConvertible | Aconstant (c1,u1), Aconstant (c2,u2) -> if Constant.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; let cu = conv_accu env CONV lvl ac1 ac2 cu in let tbl = a1.asw_reloc in let len = Array.length tbl in if Int.equal len 0 then conv_val env CONV lvl p1 p2 cu else begin let cu = conv_val env CONV lvl p1 p2 cu in let max = len - 1 in let rec aux i cu = let tag,arity = tbl.(i) in let ci = if Int.equal arity 0 then mk_const tag else mk_block tag (mk_rels_accu lvl arity) in let bi1 = bs1 ci and bi2 = bs2 ci in if Int.equal i max then conv_val env CONV (lvl + arity) bi1 bi2 cu else aux (i+1) (conv_val env CONV (lvl + arity) bi1 bi2 cu) in aux 0 cu end | Afix(t1,f1,rp1,s1), Afix(t2,f2,rp2,s2) -> if not (Int.equal s1 s2) || not (Array.equal Int.equal rp1 rp2) then raise NotConvertible; if f1 == f2 then cu else conv_fix env lvl t1 f1 t2 f2 cu | (Acofix(t1,f1,s1,_) | Acofixe(t1,f1,s1,_)), (Acofix(t2,f2,s2,_) | Acofixe(t2,f2,s2,_)) -> if not (Int.equal s1 s2) then raise NotConvertible; if f1 == f2 then cu else if not (Int.equal (Array.length f1) (Array.length f2)) then raise NotConvertible else conv_fix env lvl t1 f1 t2 f2 cu | Aprod(_,d1,c1), Aprod(_,d2,c2) -> let cu = conv_val env CONV lvl d1 d2 cu in let v = mk_rel_accu lvl in conv_val env pb (lvl + 1) (d1 v) (d2 v) cu | Aproj(p1,ac1), Aproj(p2,ac2) -> if not (Constant.equal p1 p2) then raise NotConvertible else conv_accu env CONV lvl ac1 ac2 cu | Arel _, _ | Aind _, _ | Aconstant _, _ | Asort _, _ | Avar _, _ | Acase _, _ | Afix _, _ | Acofix _, _ | Acofixe _, _ | Aprod _, _ | Aproj _, _ -> raise NotConvertible (* Precondition length t1 = length f1 = length f2 = length t2 *) and conv_fix env lvl t1 f1 t2 f2 cu = let len = Array.length f1 in let max = len - 1 in let fargs = mk_rels_accu lvl len in let flvl = lvl + len in let rec aux i cu = let cu = conv_val env CONV lvl t1.(i) t2.(i) cu in let fi1 = napply f1.(i) fargs in let fi2 = napply f2.(i) fargs in if Int.equal i max then conv_val env CONV flvl fi1 fi2 cu else aux (i+1) (conv_val env CONV flvl fi1 fi2 cu) in aux 0 cu let native_conv_gen pb sigma env univs t1 t2 = let penv = Environ.pre_env env in let ml_filename, prefix = get_ml_filename () in let code, upds = mk_conv_code penv sigma prefix t1 t2 in match compile ml_filename code with | (true, fn) -> begin if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); let t0 = Sys.time () in call_linker ~fatal:true prefix fn (Some upds); let t1 = Sys.time () in let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in if !Flags.debug then Feedback.msg_debug (Pp.str time_info); (* TODO change 0 when we can have deBruijn *) fst (conv_val env pb 0 !rt1 !rt2 univs) end | _ -> anomaly (Pp.str "Compilation failure") let warn_no_native_compiler = let open Pp in CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" (fun () -> strbrk "Native compiler is disabled," ++ strbrk " falling back to VM conversion test.") (* Wrapper for [native_conv] above *) let native_conv cv_pb sigma env t1 t2 = if Coq_config.no_native_compiler then begin warn_no_native_compiler (); vm_conv cv_pb env t1 t2 end else let univs = Environ.universes env in let b = if cv_pb = CUMUL then Constr.leq_constr_univs univs t1 t2 else Constr.eq_constr_univs univs t1 t2 in if not b then let univs = (univs, checked_universes) in let t1 = Term.it_mkLambda_or_LetIn t1 (Environ.rel_context env) in let t2 = Term.it_mkLambda_or_LetIn t2 (Environ.rel_context env) in let _ = native_conv_gen cv_pb sigma env univs t1 t2 in () coq-8.6/kernel/nativevalues.mli0000644000175000017500000001144713022274260016157 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t type accumulator type tag = int type arity = int type reloc_table = (tag * arity) array type annot_sw = { asw_ind : inductive; asw_ci : case_info; asw_reloc : reloc_table; asw_finite : bool; asw_prefix : string } val eq_annot_sw : annot_sw -> annot_sw -> bool val hash_annot_sw : annot_sw -> int type sort_annot = string * int type rec_pos = int array val eq_rec_pos : rec_pos -> rec_pos -> bool type atom = | Arel of int | Aconstant of pconstant | Aind of pinductive | Asort of sorts | Avar of identifier | Acase of annot_sw * accumulator * t * (t -> t) | Afix of t array * t array * rec_pos * int | Acofix of t array * t array * int * t | Acofixe of t array * t array * int * t | Aprod of name * t * (t -> t) | Ameta of metavariable * t | Aevar of existential * t | Aproj of constant * accumulator (* Constructors *) val mk_accu : atom -> t val mk_rel_accu : int -> t val mk_rels_accu : int -> int -> t array val mk_constant_accu : constant -> Univ.Level.t array -> t val mk_ind_accu : inductive -> Univ.Level.t array -> t val mk_sort_accu : sorts -> Univ.Level.t array -> t val mk_var_accu : identifier -> t val mk_sw_accu : annot_sw -> accumulator -> t -> (t -> t) val mk_prod_accu : name -> t -> t -> t val mk_fix_accu : rec_pos -> int -> t array -> t array -> t val mk_cofix_accu : int -> t array -> t array -> t val mk_meta_accu : metavariable -> t val mk_evar_accu : existential -> t -> t val mk_proj_accu : constant -> accumulator -> t val upd_cofix : t -> t -> unit val force_cofix : t -> t val mk_const : tag -> t val mk_block : tag -> t array -> t val mk_bool : bool -> t val mk_int : int -> t val mk_uint : Uint31.t -> t val napply : t -> t array -> t (* Functions over accumulators *) val dummy_value : unit -> t val atom_of_accu : accumulator -> atom val args_of_accu : accumulator -> t list val accu_nargs : accumulator -> int val cast_accu : t -> accumulator (* Functions over block: i.e constructors *) type block val block_size : block -> int val block_field : block -> int -> t val block_tag : block -> int (* kind_of_value *) type kind_of_value = | Vaccu of accumulator | Vfun of (t -> t) | Vconst of int | Vblock of block val kind_of_value : t -> kind_of_value (* *) val is_accu : t -> bool val str_encode : 'a -> string val str_decode : string -> 'a (** Support for machine integers *) val val_to_int : t -> int val is_int : t -> bool (* function with check *) val head0 : t -> t -> t val tail0 : t -> t -> t val add : t -> t -> t -> t val sub : t -> t -> t -> t val mul : t -> t -> t -> t val div : t -> t -> t -> t val rem : t -> t -> t -> t val l_sr : t -> t -> t -> t val l_sl : t -> t -> t -> t val l_and : t -> t -> t -> t val l_xor : t -> t -> t -> t val l_or : t -> t -> t -> t val addc : t -> t -> t -> t val subc : t -> t -> t -> t val addcarryc : t -> t -> t -> t val subcarryc : t -> t -> t -> t val mulc : t -> t -> t -> t val diveucl : t -> t -> t -> t val div21 : t -> t -> t -> t -> t val addmuldiv : t -> t -> t -> t -> t val eq : t -> t -> t -> t val lt : t -> t -> t -> t val le : t -> t -> t -> t val compare : t -> t -> t -> t (* Function without check *) val no_check_head0 : t -> t val no_check_tail0 : t -> t val no_check_add : t -> t -> t val no_check_sub : t -> t -> t val no_check_mul : t -> t -> t val no_check_div : t -> t -> t val no_check_rem : t -> t -> t val no_check_l_sr : t -> t -> t val no_check_l_sl : t -> t -> t val no_check_l_and : t -> t -> t val no_check_l_xor : t -> t -> t val no_check_l_or : t -> t -> t val no_check_addc : t -> t -> t val no_check_subc : t -> t -> t val no_check_addcarryc : t -> t -> t val no_check_subcarryc : t -> t -> t val no_check_mulc : t -> t -> t val no_check_diveucl : t -> t -> t val no_check_div21 : t -> t -> t -> t val no_check_addmuldiv : t -> t -> t -> t val no_check_eq : t -> t -> t val no_check_lt : t -> t -> t val no_check_le : t -> t -> t val no_check_compare : t -> t -> t val mk_I31_accu : t val decomp_uint : t -> t -> t coq-8.6/kernel/mod_subst.ml0000644000175000017500000004320313022274260015272 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* *) let string_of_hint = function | Inline (_,Some _) -> "inline(Some _)" | Inline _ -> "inline()" | Equiv kn -> string_of_kn kn let debug_string_of_delta resolve = let kn_to_string kn hint l = (string_of_kn kn ^ "=>" ^ string_of_hint hint) :: l in let mp_to_string mp mp' l = (string_of_mp mp ^ "=>" ^ string_of_mp mp') :: l in let l = Deltamap.fold mp_to_string kn_to_string resolve [] in String.concat ", " (List.rev l) let list_contents sub = let one_pair (mp,reso) = (string_of_mp mp,debug_string_of_delta reso) in let mp_one_pair mp0 p l = (string_of_mp mp0, one_pair p)::l in let mbi_one_pair mbi p l = (MBId.debug_to_string mbi, one_pair p)::l in Umap.fold mp_one_pair mbi_one_pair sub [] let debug_string_of_subst sub = let l = List.map (fun (s1,(s2,s3)) -> s1^"|->"^s2^"["^s3^"]") (list_contents sub) in "{" ^ String.concat "; " l ^ "}" let debug_pr_delta resolve = str (debug_string_of_delta resolve) let debug_pr_subst sub = let l = list_contents sub in let f (s1,(s2,s3)) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2 ++ spc () ++ str "[" ++ str s3 ++ str "]") in str "{" ++ hov 2 (prlist_with_sep pr_comma f l) ++ str "}" (* *) (** Extending a [delta_resolver] *) let add_inline_delta_resolver kn (lev,oc) = Deltamap.add_kn kn (Inline (lev,oc)) let add_kn_delta_resolver kn kn' = assert (Label.equal (label kn) (label kn')); Deltamap.add_kn kn (Equiv kn') let add_mp_delta_resolver mp1 mp2 = Deltamap.add_mp mp1 mp2 (** Extending a [substitution] without sequential composition *) let add_mbid mbid mp resolve s = Umap.add_mbi mbid (mp,resolve) s let add_mp mp1 mp2 resolve s = Umap.add_mp mp1 (mp2,resolve) s let map_mbid mbid mp resolve = add_mbid mbid mp resolve empty_subst let map_mp mp1 mp2 resolve = add_mp mp1 mp2 resolve empty_subst let mp_in_delta mp = Deltamap.mem_mp mp let kn_in_delta kn resolver = try match Deltamap.find_kn kn resolver with | Equiv _ -> true | Inline _ -> false with Not_found -> false let con_in_delta con resolver = kn_in_delta (Constant.user con) resolver let mind_in_delta mind resolver = kn_in_delta (MutInd.user mind) resolver let mp_of_delta resolve mp = try Deltamap.find_mp mp resolve with Not_found -> mp let find_prefix resolve mp = let rec sub_mp = function | MPdot(mp,l) as mp_sup -> (try Deltamap.find_mp mp_sup resolve with Not_found -> MPdot(sub_mp mp,l)) | p -> Deltamap.find_mp p resolve in try sub_mp mp with Not_found -> mp (** Applying a resolver to a kernel name *) exception Change_equiv_to_inline of (int * constr) let solve_delta_kn resolve kn = try match Deltamap.find_kn kn resolve with | Equiv kn1 -> kn1 | Inline (lev, Some c) -> raise (Change_equiv_to_inline (lev,c)) | Inline (_, None) -> raise Not_found with Not_found -> let mp,dir,l = repr_kn kn in let new_mp = find_prefix resolve mp in if mp == new_mp then kn else make_kn new_mp dir l let kn_of_delta resolve kn = try solve_delta_kn resolve kn with Change_equiv_to_inline _ -> kn (** Try a 1st resolver, and then a 2nd in case it had no effect *) let kn_of_deltas resolve1 resolve2 kn = let kn' = kn_of_delta resolve1 kn in if kn' == kn then kn_of_delta resolve2 kn else kn' let constant_of_delta_kn resolve kn = Constant.make kn (kn_of_delta resolve kn) let constant_of_deltas_kn resolve1 resolve2 kn = Constant.make kn (kn_of_deltas resolve1 resolve2 kn) let mind_of_delta_kn resolve kn = MutInd.make kn (kn_of_delta resolve kn) let mind_of_deltas_kn resolve1 resolve2 kn = MutInd.make kn (kn_of_deltas resolve1 resolve2 kn) let inline_of_delta inline resolver = match inline with | None -> [] | Some inl_lev -> let extract kn hint l = match hint with | Inline (lev,_) -> if lev <= inl_lev then (lev,kn)::l else l | _ -> l in Deltamap.fold_kn extract resolver [] let search_delta_inline resolve kn1 kn2 = let find kn = match Deltamap.find_kn kn resolve with | Inline (_,o) -> o | Equiv _ -> raise Not_found in try find kn1 with Not_found -> if kn1 == kn2 then None else try find kn2 with Not_found -> None let subst_mp0 sub mp = (* 's like subst *) let rec aux mp = match mp with | MPfile sid -> Umap.find_mp mp sub | MPbound bid -> begin try Umap.find_mbi bid sub with Not_found -> Umap.find_mp mp sub end | MPdot (mp1,l) as mp2 -> begin try Umap.find_mp mp2 sub with Not_found -> let mp1',resolve = aux mp1 in MPdot (mp1',l),resolve end in try Some (aux mp) with Not_found -> None let subst_mp sub mp = match subst_mp0 sub mp with None -> mp | Some (mp',_) -> mp' let subst_kn_delta sub kn = let mp,dir,l = repr_kn kn in match subst_mp0 sub mp with Some (mp',resolve) -> solve_delta_kn resolve (make_kn mp' dir l) | None -> kn let subst_kn sub kn = let mp,dir,l = repr_kn kn in match subst_mp0 sub mp with Some (mp',_) -> (make_kn mp' dir l) | None -> kn exception No_subst let subst_dual_mp sub mp1 mp2 = let o1 = subst_mp0 sub mp1 in let o2 = if mp1 == mp2 then o1 else subst_mp0 sub mp2 in match o1, o2 with | None, None -> raise No_subst | Some (mp1',resolve), None -> mp1', mp2, resolve, true | None, Some (mp2',resolve) -> mp1, mp2', resolve, false | Some (mp1',_), Some (mp2',resolve) -> mp1', mp2', resolve, false let progress f x ~orelse = let y = f x in if y != x then y else orelse let subst_mind sub mind = let mpu,dir,l = MutInd.repr3 mind in let mpc = KerName.modpath (MutInd.canonical mind) in try let mpu,mpc,resolve,user = subst_dual_mp sub mpu mpc in let knu = KerName.make mpu dir l in let knc = if mpu == mpc then knu else KerName.make mpc dir l in let knc' = progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc in MutInd.make knu knc' with No_subst -> mind let subst_ind sub (ind,i as indi) = let ind' = subst_mind sub ind in if ind' == ind then indi else ind',i let subst_pind sub (ind,u) = (subst_ind sub ind, u) let subst_con0 sub (cst,u) = let mpu,dir,l = Constant.repr3 cst in let mpc = KerName.modpath (Constant.canonical cst) in let mpu,mpc,resolve,user = subst_dual_mp sub mpu mpc in let knu = KerName.make mpu dir l in let knc = if mpu == mpc then knu else KerName.make mpc dir l in match search_delta_inline resolve knu knc with | Some t -> (* In case of inlining, discard the canonical part (cf #2608) *) Constant.make1 knu, t | None -> let knc' = progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc in let cst' = Constant.make knu knc' in cst', mkConstU (cst',u) let subst_con sub cst = try subst_con0 sub cst with No_subst -> fst cst, mkConstU cst let subst_con_kn sub con = subst_con sub (con,Univ.Instance.empty) let subst_pcon sub (con,u as pcon) = try let con', can = subst_con0 sub pcon in con',u with No_subst -> pcon let subst_pcon_term sub (con,u as pcon) = try let con', can = subst_con0 sub pcon in (con',u), can with No_subst -> pcon, mkConstU pcon let subst_constant sub con = try fst (subst_con0 sub (con,Univ.Instance.empty)) with No_subst -> con (* Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" where X.t is later on instantiated with y? I choose the first interpretation (i.e. an evaluable reference is never expanded). *) let subst_evaluable_reference subst = function | EvalVarRef id -> EvalVarRef id | EvalConstRef kn -> EvalConstRef (subst_constant subst kn) let rec map_kn f f' c = let func = map_kn f f' in match kind_of_term c with | Const kn -> (try snd (f' kn) with No_subst -> c) | Proj (p,t) -> let p' = try Projection.map (fun kn -> fst (f' (kn,Univ.Instance.empty))) p with No_subst -> p in let t' = func t in if p' == p && t' == t then c else mkProj (p', t') | Ind ((kn,i),u) -> let kn' = f kn in if kn'==kn then c else mkIndU ((kn',i),u) | Construct (((kn,i),j),u) -> let kn' = f kn in if kn'==kn then c else mkConstructU (((kn',i),j),u) | Case (ci,p,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in let kn' = f kn in if kn'==kn then ci.ci_ind else kn',i in let p' = func p in let ct' = func ct in let l' = Array.smartmap func l in if (ci.ci_ind==ci_ind && p'==p && l'==l && ct'==ct)then c else mkCase ({ci with ci_ind = ci_ind}, p',ct', l') | Cast (ct,k,t) -> let ct' = func ct in let t'= func t in if (t'==t && ct'==ct) then c else mkCast (ct', k, t') | Prod (na,t,ct) -> let ct' = func ct in let t'= func t in if (t'==t && ct'==ct) then c else mkProd (na, t', ct') | Lambda (na,t,ct) -> let ct' = func ct in let t'= func t in if (t'==t && ct'==ct) then c else mkLambda (na, t', ct') | LetIn (na,b,t,ct) -> let ct' = func ct in let t'= func t in let b'= func b in if (t'==t && ct'==ct && b==b') then c else mkLetIn (na, b', t', ct') | App (ct,l) -> let ct' = func ct in let l' = Array.smartmap func l in if (ct'== ct && l'==l) then c else mkApp (ct',l') | Evar (e,l) -> let l' = Array.smartmap func l in if (l'==l) then c else mkEvar (e,l') | Fix (ln,(lna,tl,bl)) -> let tl' = Array.smartmap func tl in let bl' = Array.smartmap func bl in if (bl == bl'&& tl == tl') then c else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> let tl' = Array.smartmap func tl in let bl' = Array.smartmap func bl in if (bl == bl'&& tl == tl') then c else mkCoFix (ln,(lna,tl',bl')) | _ -> c let subst_mps sub c = if is_empty_subst sub then c else map_kn (subst_mind sub) (subst_con0 sub) c let rec replace_mp_in_mp mpfrom mpto mp = match mp with | _ when mp_eq mp mpfrom -> mpto | MPdot (mp1,l) -> let mp1' = replace_mp_in_mp mpfrom mpto mp1 in if mp1 == mp1' then mp else MPdot (mp1',l) | _ -> mp let replace_mp_in_kn mpfrom mpto kn = let mp,dir,l = repr_kn kn in let mp'' = replace_mp_in_mp mpfrom mpto mp in if mp==mp'' then kn else make_kn mp'' dir l let rec mp_in_mp mp mp1 = match mp1 with | _ when mp_eq mp1 mp -> true | MPdot (mp2,l) -> mp_in_mp mp mp2 | _ -> false let subset_prefixed_by mp resolver = let mp_prefix mkey mequ rslv = if mp_in_mp mp mkey then Deltamap.add_mp mkey mequ rslv else rslv in let kn_prefix kn hint rslv = match hint with | Inline _ -> rslv | Equiv _ -> if mp_in_mp mp (modpath kn) then Deltamap.add_kn kn hint rslv else rslv in Deltamap.fold mp_prefix kn_prefix resolver empty_delta_resolver let subst_dom_delta_resolver subst resolver = let mp_apply_subst mkey mequ rslv = Deltamap.add_mp (subst_mp subst mkey) mequ rslv in let kn_apply_subst kkey hint rslv = Deltamap.add_kn (subst_kn subst kkey) hint rslv in Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver let subst_mp_delta sub mp mkey = match subst_mp0 sub mp with None -> empty_delta_resolver,mp | Some (mp',resolve) -> let mp1 = find_prefix resolve mp' in let resolve1 = subset_prefixed_by mp1 resolve in (subst_dom_delta_resolver (map_mp mp1 mkey empty_delta_resolver) resolve1),mp1 let gen_subst_delta_resolver dom subst resolver = let mp_apply_subst mkey mequ rslv = let mkey' = if dom then subst_mp subst mkey else mkey in let rslv',mequ' = subst_mp_delta subst mequ mkey in Deltamap.join rslv' (Deltamap.add_mp mkey' mequ' rslv) in let kn_apply_subst kkey hint rslv = let kkey' = if dom then subst_kn subst kkey else kkey in let hint' = match hint with | Equiv kequ -> (try Equiv (subst_kn_delta subst kequ) with Change_equiv_to_inline (lev,c) -> Inline (lev,Some c)) | Inline (lev,Some t) -> Inline (lev,Some (subst_mps subst t)) | Inline (_,None) -> hint in Deltamap.add_kn kkey' hint' rslv in Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver let subst_codom_delta_resolver = gen_subst_delta_resolver false let subst_dom_codom_delta_resolver = gen_subst_delta_resolver true let update_delta_resolver resolver1 resolver2 = let mp_apply_rslv mkey mequ rslv = Deltamap.add_mp mkey (find_prefix resolver2 mequ) rslv in let kn_apply_rslv kkey hint1 rslv = let hint = match hint1 with | Equiv kequ -> (try Equiv (solve_delta_kn resolver2 kequ) with Change_equiv_to_inline (lev,c) -> Inline (lev, Some c)) | Inline (_,Some _) -> hint1 | Inline (_,None) -> (try Deltamap.find_kn kkey resolver2 with Not_found -> hint1) in Deltamap.add_kn kkey hint rslv in Deltamap.fold mp_apply_rslv kn_apply_rslv resolver1 resolver2 let add_delta_resolver resolver1 resolver2 = if Deltamap.is_empty resolver2 then resolver1 else update_delta_resolver resolver1 resolver2 let substition_prefixed_by k mp subst = let mp_prefixmp kmp (mp_to,reso) sub = if mp_in_mp mp kmp && not (mp_eq mp kmp) then let new_key = replace_mp_in_mp mp k kmp in Umap.add_mp new_key (mp_to,reso) sub else sub in let mbi_prefixmp mbi _ sub = sub in Umap.fold mp_prefixmp mbi_prefixmp subst empty_subst let join subst1 subst2 = let apply_subst mpk add (mp,resolve) res = let mp',resolve' = match subst_mp0 subst2 mp with | None -> mp, None | Some (mp',resolve') -> mp', Some resolve' in let resolve'' = match resolve' with | Some res -> add_delta_resolver (subst_dom_codom_delta_resolver subst2 resolve) res | None -> subst_codom_delta_resolver subst2 resolve in let prefixed_subst = substition_prefixed_by mpk mp' subst2 in Umap.join prefixed_subst (add (mp',resolve'') res) in let mp_apply_subst mp = apply_subst mp (Umap.add_mp mp) in let mbi_apply_subst mbi = apply_subst (MPbound mbi) (Umap.add_mbi mbi) in let subst = Umap.fold mp_apply_subst mbi_apply_subst subst1 empty_subst in Umap.join subst2 subst let rec occur_in_path mbi = function | MPbound bid' -> MBId.equal mbi bid' | MPdot (mp1,_) -> occur_in_path mbi mp1 | _ -> false let occur_mbid mbi sub = let check_one mbi' (mp,_) = if MBId.equal mbi mbi' || occur_in_path mbi mp then raise Exit in try Umap.iter_mbi check_one sub; false with Exit -> true type 'a substituted = { mutable subst_value : 'a; mutable subst_subst : substitution list; } let from_val x = { subst_value = x; subst_subst = []; } let force fsubst r = match r.subst_subst with | [] -> r.subst_value | s -> let subst = List.fold_left join empty_subst (List.rev s) in let x = fsubst subst r.subst_value in let () = r.subst_subst <- [] in let () = r.subst_value <- x in x let subst_substituted s r = { r with subst_subst = s :: r.subst_subst; } let force_constr = force subst_mps let subst_constr = subst_substituted (* debug *) let repr_substituted r = match r.subst_subst with | [] -> None, r.subst_value | s -> Some s, r.subst_value coq-8.6/kernel/reduction.ml0000644000175000017500000006747713022274260015312 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | Zupdate _::s -> is_empty_stack s | Zshift _::s -> is_empty_stack s | _ -> false (* Compute the lift to be performed on a term placed in a given stack *) let el_stack el stk = let n = List.fold_left (fun i z -> match z with Zshift n -> i+n | _ -> i) 0 stk in el_shft n el let compare_stack_shape stk1 stk2 = let rec compare_rec bal stk1 stk2 = match (stk1,stk2) with ([],[]) -> Int.equal bal 0 | ((Zupdate _|Zshift _)::s1, _) -> compare_rec bal s1 stk2 | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 | (ZcaseT(c1,_,_,_)::s1, ZcaseT(c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 | (_,_) -> false in compare_rec 0 stk1 stk2 type lft_constr_stack_elt = Zlapp of (lift * fconstr) array | Zlproj of constant * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list let rec zlapp v = function Zlapp v2 :: s -> zlapp (Array.append v v2) s | s -> Zlapp v :: s let pure_stack lfts stk = let rec pure_rec lfts stk = match stk with [] -> (lfts,[]) | zi::s -> (match (zi,pure_rec lfts s) with (Zupdate _,lpstk) -> lpstk | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) | (Zapp a, (l,pstk)) -> (l,zlapp (Array.map (fun t -> (l,t)) a) pstk) | (Zproj (n,m,c), (l,pstk)) -> (l, Zlproj (c,l)::pstk) | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) | (ZcaseT(ci,p,br,e),(l,pstk)) -> (l,Zlcase(ci,l,mk_clos e p,Array.map (mk_clos e) br)::pstk)) in snd (pure_rec lfts stk) (****************************************************************************) (* Reduction Functions *) (****************************************************************************) let whd_betaiota env t = whd_val (create_clos_infos betaiota env) (inject t) let nf_betaiota env t = norm_val (create_clos_infos betaiota env) (inject t) let whd_betaiotazeta env x = match kind_of_term x with | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> x | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x) let whd_all env t = match kind_of_term t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> t | _ -> whd_val (create_clos_infos all env) (inject t) let whd_allnolet env t = match kind_of_term t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t | _ -> whd_val (create_clos_infos allnolet env) (inject t) (********************************************************************) (* Conversion *) (********************************************************************) (* Conversion utility functions *) (* functions of this type are called from the kernel *) type 'a kernel_conversion_function = env -> 'a -> 'a -> unit (* functions of this type can be called from outside the kernel *) type 'a extended_conversion_function = ?l2r:bool -> ?reds:Names.transparent_state -> env -> ?evars:((existential->constr option) * UGraph.t) -> 'a -> 'a -> unit exception NotConvertible exception NotConvertibleVect of int (* Convertibility of sorts *) (* The sort cumulativity is Prop <= Set <= Type 1 <= ... <= Type i <= ... and this holds whatever Set is predicative or impredicative *) type conv_pb = | CONV | CUMUL let is_cumul = function CUMUL -> true | CONV -> false type 'a universe_compare = { (* Might raise NotConvertible *) compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a; compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; } type 'a universe_state = 'a * 'a universe_compare type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints let sort_cmp_universes env pb s0 s1 (u, check) = (check.compare env pb s0 s1 u, check) (* [flex] should be true for constants, false for inductive types and constructors. *) let convert_instances ~flex u u' (s, check) = (check.compare_instances ~flex u u' 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' -> if Univ.Instance.equal u u' then cuniv else let flex = evaluable_constant cst (info_env infos) && RedFlags.red_set (info_flags infos) (RedFlags.fCONST cst) in convert_instances ~flex u u' cuniv | VarKey id, VarKey id' when Id.equal id id' -> cuniv | RelKey n, RelKey n' when Int.equal n n' -> cuniv | _ -> raise NotConvertible let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = let rec cmp_rec pstk1 pstk2 cuniv = match (pstk1,pstk2) with | (z1::s1, z2::s2) -> let cu1 = cmp_rec s1 s2 cuniv in (match (z1,z2) with | (Zlapp a1,Zlapp a2) -> Array.fold_right2 f a1 a2 cu1 | (Zlproj (c1,l1),Zlproj (c2,l2)) -> if not (eq_constant 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),Zlcase(ci2,l2,p2,br2)) -> if not (fmind ci1.ci_ind ci2.ci_ind) then raise NotConvertible; let cu2 = f (l1,p1) (l2,p2) cu1 in Array.fold_right2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2 cu2 | _ -> assert false) | _ -> cuniv in if compare_stack_shape stk1 stk2 then cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv else raise NotConvertible let rec no_arg_available = function | [] -> true | Zupdate _ :: stk -> no_arg_available stk | Zshift _ :: stk -> no_arg_available stk | Zapp v :: stk -> Int.equal (Array.length v) 0 && no_arg_available stk | Zproj _ :: _ -> true | ZcaseT _ :: _ -> true | Zfix _ :: _ -> true let rec no_nth_arg_available n = function | [] -> true | Zupdate _ :: stk -> no_nth_arg_available n stk | Zshift _ :: stk -> no_nth_arg_available n stk | Zapp v :: stk -> let k = Array.length v in if n >= k then no_nth_arg_available (n-k) stk else false | Zproj _ :: _ -> true | ZcaseT _ :: _ -> true | Zfix _ :: _ -> true let rec no_case_available = function | [] -> true | Zupdate _ :: stk -> no_case_available stk | Zshift _ :: stk -> no_case_available stk | Zapp _ :: stk -> no_case_available stk | Zproj (_,_,p) :: _ -> false | ZcaseT _ :: _ -> false | Zfix _ :: _ -> true let in_whnf (t,stk) = match fterm_of t with | (FLetIn _ | FCaseT _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false | FLambda _ -> no_arg_available stk | FConstruct _ -> no_case_available stk | FCoFix _ -> no_case_available stk | FFix(((ri,n),(_,_,_)),_) -> no_nth_arg_available ri.(n) stk | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _ | FProj _) -> true | FLOCKED -> assert false let unfold_projection infos p c = let unf = Projection.unfolded p in if unf || RedFlags.red_set infos.i_flags (RedFlags.fCONST (Projection.constant p)) then (match try Some (lookup_projection p (info_env infos)) with Not_found -> None with | Some pb -> let s = Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, Projection.constant p) in Some (c, s) | None -> None) else None (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = Control.check_for_interrupt (); (* First head reduce both terms *) let whd = whd_stack (infos_with_reds infos betaiotazeta) in let rec whd_both (t1,stk1) (t2,stk2) = let st1' = whd t1 stk1 in let st2' = whd t2 stk2 in (* Now, whd_stack on term2 might have modified st1 (due to sharing), and st1 might not be in whnf anymore. If so, we iterate ccnv. *) if in_whnf st1' then (st1',st2') else whd_both st1' st2' in let ((hd1,v1),(hd2,v2)) = whd_both st1 st2 in let appr1 = (lft1,(hd1,v1)) and appr2 = (lft2,(hd2,v2)) in (* compute the lifts that apply to the head of the term (hd1 and hd2) *) let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in match (fterm_of hd1, fterm_of hd2) with (* case of leaves *) | (FAtom a1, FAtom a2) -> (match kind_of_term a1, kind_of_term a2 with | (Sort s1, Sort s2) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (Sort)"); sort_cmp_universes (env_of_infos infos) cv_pb s1 s2 cuniv | (Meta n, Meta m) -> if Int.equal n m then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | _ -> raise NotConvertible) | (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) -> if Evar.equal ev1 ev2 then let cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in convert_vect l2r infos el1 el2 (Array.map (mk_clos env1) args1) (Array.map (mk_clos env2) args2) cuniv else raise NotConvertible (* 2 index known to be bound to no constant *) | (FRel n, FRel m) -> if Int.equal (reloc_rel n el1) (reloc_rel m el2) then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try let cuniv = conv_table_key infos fl1 fl2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with NotConvertible | Univ.UniverseInconsistency _ -> (* else the oracle tells which constant is to be expanded *) let oracle = CClosure.oracle_of_infos infos in let (app1,app2) = if Conv_oracle.oracle_order Univ.out_punivs oracle l2r fl1 fl2 then match unfold_reference infos fl1 with | Some def1 -> ((lft1, whd def1 v1), appr2) | None -> (match unfold_reference infos fl2 with | Some def2 -> (appr1, (lft2, whd def2 v2)) | None -> raise NotConvertible) else match unfold_reference infos fl2 with | Some def2 -> (appr1, (lft2, whd def2 v2)) | None -> (match unfold_reference infos fl1 with | Some def1 -> ((lft1, whd def1 v1), appr2) | None -> raise NotConvertible) in eqappr cv_pb l2r infos app1 app2 cuniv) | (FProj (p1,c1), FProj (p2, c2)) -> (* Projections: prefer unfolding to first-order unification, which will happen naturally if the terms c1, c2 are not in constructor form *) (match unfold_projection infos p1 c1 with | Some (def1,s1) -> eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv | None -> match unfold_projection infos p2 c2 with | Some (def2,s2) -> eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv | None -> if Constant.equal (Projection.constant p1) (Projection.constant p2) && compare_stack_shape v1 v2 then let u1 = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 u1 else (* Two projections in WHNF: unfold *) raise NotConvertible) | (FProj (p1,c1), t2) -> (match unfold_projection infos p1 c1 with | Some (def1,s1) -> eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv | None -> (match t2 with | FFlex fl2 -> (match unfold_reference infos fl2 with | Some def2 -> eqappr cv_pb l2r infos appr1 (lft2, whd def2 v2) cuniv | None -> raise NotConvertible) | _ -> raise NotConvertible)) | (t1, FProj (p2,c2)) -> (match unfold_projection infos p2 c2 with | Some (def2,s2) -> eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv | None -> (match t1 with | FFlex fl1 -> (match unfold_reference infos fl1 with | Some def1 -> eqappr cv_pb l2r infos (lft1, whd def1 v1) appr2 cuniv | None -> raise NotConvertible) | _ -> raise NotConvertible)) (* other constructors *) | (FLambda _, FLambda _) -> (* Inconsistency: we tolerate that v1, v2 contain shift and update but we throw them away *) if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (FLambda)"); let (_,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (FProd)"); (* Luo's system *) let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv (* Eta-expansion on the fly *) | (FLambda _, _) -> let () = match v1 with | [] -> () | _ -> anomaly (Pp.str "conversion was given unreduced term (FLambda)") in let (_,_ty1,bd1) = destFLambda mk_clos hd1 in eqappr CONV l2r infos (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv | (_, FLambda _) -> let () = match v2 with | [] -> () | _ -> anomaly (Pp.str "conversion was given unreduced term (FLambda)") in let (_,_ty2,bd2) = destFLambda mk_clos hd2 in eqappr CONV l2r infos (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv (* only one constant, defined var or defined rel *) | (FFlex fl1, c2) -> (match unfold_reference infos fl1 with | Some def1 -> eqappr cv_pb l2r infos (lft1, whd def1 v1) appr2 cuniv | None -> match c2 with | FConstruct ((ind2,j2),u2) -> (try let v2, v1 = eta_expand_ind_stack (info_env infos) ind2 hd2 v2 (snd appr1) in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | _ -> raise NotConvertible) | (c1, FFlex fl2) -> (match unfold_reference infos fl2 with | Some def2 -> eqappr cv_pb l2r infos appr1 (lft2, whd def2 v2) cuniv | None -> match c1 with | FConstruct ((ind1,j1),u1) -> (try let v1, v2 = eta_expand_ind_stack (info_env infos) ind1 hd1 v1 (snd appr2) in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | _ -> raise NotConvertible) (* Inductive types: MutInd MutConstruct Fix Cofix *) | (FInd (ind1,u1), FInd (ind2,u2)) -> if eq_ind ind1 ind2 then (let cuniv = convert_instances false u1 u2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv) else raise NotConvertible | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) -> if Int.equal j1 j2 && eq_ind ind1 ind2 then (let cuniv = convert_instances false u1 u2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv) else raise NotConvertible (* Eta expansion of records *) | (FConstruct ((ind1,j1),u1), _) -> (try let v1, v2 = eta_expand_ind_stack (info_env infos) ind1 hd1 v1 (snd appr2) in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | (_, FConstruct ((ind2,j2),u2)) -> (try let v2, v1 = eta_expand_ind_stack (info_env infos) ind2 hd2 v2 (snd appr1) in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | (FFix (((op1, i1),(_,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) -> if Int.equal i1 i2 && Array.equal Int.equal op1 op2 then let n = Array.length cl1 in let fty1 = Array.map (mk_clos e1) tys1 in let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = convert_vect l2r infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> if Int.equal op1 op2 then let n = Array.length cl1 in let fty1 = Array.map (mk_clos e1) tys1 in let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = convert_vect l2r infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) | ( (FLetIn _, _) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) | (_, FLetIn _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false (* In all other cases, terms are not convertible *) | _ -> raise NotConvertible and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = compare_stacks (fun (l1,t1) (l2,t2) cuniv -> ccnv CONV l2r infos l1 l2 t1 t2 cuniv) (eq_ind) lft1 stk1 lft2 stk2 cuniv and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = let lv1 = Array.length v1 in let lv2 = Array.length v2 in if Int.equal lv1 lv2 then let rec fold n cuniv = if n >= lv1 then cuniv else let cuniv = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) cuniv in fold (n+1) cuniv in fold 0 cuniv else raise NotConvertible let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let reds = CClosure.RedFlags.red_add_transparent betaiotazeta trans in let infos = create_clos_infos ~evars reds env in ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) univs let check_eq univs u u' = if not (UGraph.check_eq univs u u') then raise NotConvertible let check_leq univs u u' = if not (UGraph.check_leq univs u u') then raise NotConvertible let check_sort_cmp_universes env pb s0 s1 univs = match (s0,s1) with | (Prop c1, Prop c2) when is_cumul pb -> begin match c1, c2 with | Null, _ | _, Pos -> () (* Prop <= Set *) | _ -> raise NotConvertible end | (Prop c1, Prop c2) -> if c1 != c2 then raise NotConvertible | (Prop c1, Type u) -> if not (type_in_type env) then let u0 = univ_of_sort s0 in (match pb with | CUMUL -> check_leq univs u0 u | CONV -> check_eq univs u0 u) | (Type u, Prop c) -> raise NotConvertible | (Type u1, Type u2) -> if not (type_in_type env) then (match pb with | CUMUL -> check_leq univs u1 u2 | CONV -> check_eq univs u1 u2) let checked_sort_cmp_universes env pb s0 s1 univs = check_sort_cmp_universes env pb s0 s1 univs; univs let check_convert_instances ~flex u u' univs = if UGraph.check_eq_instances univs u u' then univs else raise NotConvertible let checked_universes = { compare = checked_sort_cmp_universes; compare_instances = check_convert_instances } let infer_eq (univs, cstrs as cuniv) u u' = if UGraph.check_eq univs u u' then cuniv else univs, (Univ.enforce_eq u u' cstrs) let infer_leq (univs, cstrs as cuniv) u u' = if UGraph.check_leq univs u u' then cuniv else let cstrs' = Univ.enforce_leq u u' cstrs in univs, cstrs' let infer_cmp_universes env pb s0 s1 univs = match (s0,s1) with | (Prop c1, Prop c2) when is_cumul pb -> begin match c1, c2 with | Null, _ | _, Pos -> univs (* Prop <= Set *) | _ -> raise NotConvertible end | (Prop c1, Prop c2) -> if c1 == c2 then univs else raise NotConvertible | (Prop c1, Type u) -> let u0 = univ_of_sort s0 in (match pb with | CUMUL -> infer_leq univs u0 u | CONV -> infer_eq univs u0 u) | (Type u, Prop c) -> raise NotConvertible | (Type u1, Type u2) -> if not (type_in_type env) then (match pb with | CUMUL -> infer_leq univs u1 u2 | CONV -> infer_eq univs u1 u2) else univs let infer_convert_instances ~flex u u' (univs,cstrs) = (univs, Univ.enforce_eq_instances u u' cstrs) let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = { compare = infer_cmp_universes; compare_instances = infer_convert_instances } let gen_conv cv_pb l2r reds env evars univs t1 t2 = let b = if cv_pb = CUMUL then leq_constr_univs univs t1 t2 else eq_constr_univs univs t1 t2 in if b then () else let _ = clos_gen_conv reds cv_pb l2r evars env (univs, checked_universes) t1 t2 in () (* Profiling *) let gen_conv cv_pb ?(l2r=false) ?(reds=full_transparent_state) env ?(evars=(fun _->None), universes env) = let evars, univs = evars in if Flags.profile then let fconv_universes_key = Profile.declare_profile "trans_fconv_universes" in Profile.profile8 fconv_universes_key gen_conv cv_pb l2r reds env evars univs else gen_conv cv_pb l2r reds env evars univs let conv = gen_conv CONV let conv_leq = gen_conv CUMUL let generic_conv cv_pb ~l2r evars reds env univs t1 t2 = let (s, _) = clos_gen_conv reds cv_pb l2r evars env univs t1 t2 in s let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = let b, cstrs = if cv_pb == CUMUL then Constr.leq_constr_univs_infer univs t1 t2 else Constr.eq_constr_univs_infer univs t1 t2 in if b then cstrs else let univs = ((univs, Univ.Constraint.empty), inferred_universes) in let ((_,cstrs), _) = clos_gen_conv reds cv_pb l2r evars env univs t1 t2 in cstrs (* Profiling *) let infer_conv_universes = if Flags.profile then let infer_conv_universes_key = Profile.declare_profile "infer_conv_universes" in Profile.profile8 infer_conv_universes_key infer_conv_universes else infer_conv_universes let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) env univs t1 t2 = infer_conv_universes CONV l2r evars ts env univs t1 t2 let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) env univs t1 t2 = infer_conv_universes CUMUL l2r evars ts env univs t1 t2 (* This reference avoids always having to link C code with the kernel *) let vm_conv = ref (fun cv_pb env -> gen_conv cv_pb env ~evars:((fun _->None), universes env)) let warn_bytecode_compiler_failed = let open Pp in CWarnings.create ~name:"bytecode-compiler-failed" ~category:"bytecode-compiler" (fun () -> strbrk "Bytecode compiler failed, " ++ strbrk "falling back to standard conversion") let set_vm_conv (f:conv_pb -> Term.types kernel_conversion_function) = vm_conv := f let vm_conv cv_pb env t1 t2 = try !vm_conv cv_pb env t1 t2 with Not_found | Invalid_argument _ -> warn_bytecode_compiler_failed (); gen_conv cv_pb env t1 t2 let default_conv cv_pb ?(l2r=false) env t1 t2 = gen_conv cv_pb env t1 t2 let default_conv_leq = default_conv CUMUL (* let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";; let conv_leq env t1 t2 = Profile.profile4 convleqkey conv_leq env t1 t2;; let convkey = Profile.declare_profile "Kernel_reduction.conv";; let conv env t1 t2 = Profile.profile4 convleqkey conv env t1 t2;; *) (* Application with on-the-fly reduction *) let beta_applist c l = let rec app subst c l = match kind_of_term c, l with | Lambda(_,_,c), arg::l -> app (arg::subst) c l | _ -> applist (substl subst c, l) in app [] c l let beta_appvect c v = beta_applist c (Array.to_list v) let beta_app c a = beta_applist c [a] (* Compatibility *) let betazeta_appvect = lambda_appvect_assum (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) (* pseudo-reduction rule: * [hnf_prod_app env (Prod(_,B)) N --> B[N] * with an HNF on the first argument to produce a product. * if this does not work, then we use the string S as part of our * error message. *) let hnf_prod_app env t n = match kind_of_term (whd_all env t) with | Prod (_,_,b) -> subst1 n b | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product") let hnf_prod_applist env t nl = List.fold_left (hnf_prod_app env) t nl (* Dealing with arities *) let dest_prod env = let rec decrec env m c = let t = whd_all env c in match kind_of_term t with | Prod (n,a,c0) -> let d = LocalAssum (n,a) in decrec (push_rel d env) (Context.Rel.add d m) c0 | _ -> m,t in decrec env Context.Rel.empty (* The same but preserving lets in the context, not internal ones. *) let dest_prod_assum env = let rec prodec_rec env l ty = let rty = whd_allnolet env ty in match kind_of_term rty with | Prod (x,t,c) -> let d = LocalAssum (x,t) in prodec_rec (push_rel d env) (Context.Rel.add d l) c | LetIn (x,b,t,c) -> let d = LocalDef (x,b,t) in prodec_rec (push_rel d env) (Context.Rel.add d l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> let rty' = whd_all env rty in if Term.eq_constr rty' rty then l, rty else prodec_rec env l rty' in prodec_rec env Context.Rel.empty let dest_lam_assum env = let rec lamec_rec env l ty = let rty = whd_allnolet env ty in match kind_of_term rty with | Lambda (x,t,c) -> let d = LocalAssum (x,t) in lamec_rec (push_rel d env) (Context.Rel.add d l) c | LetIn (x,b,t,c) -> let d = LocalDef (x,b,t) in lamec_rec (push_rel d env) (Context.Rel.add d l) c | Cast (c,_,_) -> lamec_rec env l c | _ -> l,rty in lamec_rec env Context.Rel.empty exception NotArity let dest_arity env c = let l, c = dest_prod_assum env c in match kind_of_term c with | Sort s -> l,s | _ -> raise NotArity let is_arity env c = try let _ = dest_arity env c in true with NotArity -> false coq-8.6/kernel/context.mli0000644000175000017500000002365113022274260015135 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Name.t (** Return [Some value] for local-declarations and [None] for local-assumptions. *) val get_value : t -> Constr.t option (** Return the type of the name bound by a given declaration. *) val get_type : t -> Constr.t (** Set the name that is bound by a given declaration. *) val set_name : Name.t -> t -> t (** Set the type of the bound variable in a given declaration. *) val set_type : Constr.t -> t -> t (** Return [true] iff a given declaration is a local assumption. *) val is_local_assum : t -> bool (** Return [true] iff a given declaration is a local definition. *) val is_local_def : t -> bool (** Check whether any term in a given declaration satisfies a given predicate. *) val exists : (Constr.t -> bool) -> t -> bool (** Check whether all terms in a given declaration satisfy a given predicate. *) val for_all : (Constr.t -> bool) -> t -> bool (** Check whether the two given declarations are equal. *) val equal : t -> t -> bool (** Map the name bound by a given declaration. *) val map_name : (Name.t -> Name.t) -> t -> t (** For local assumptions, this function returns the original local assumptions. For local definitions, this function maps the value in the local definition. *) val map_value : (Constr.t -> Constr.t) -> t -> t (** Map the type of the name bound by a given declaration. *) val map_type : (Constr.t -> Constr.t) -> t -> t (** Map all terms in a given declaration. *) val map_constr : (Constr.t -> Constr.t) -> t -> t (** Perform a given action on all terms in a given declaration. *) val iter_constr : (Constr.t -> unit) -> t -> unit (** Reduce all terms in a given declaration to a single value. *) val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a val to_tuple : t -> Name.t * Constr.t option * Constr.t val of_tuple : Name.t * Constr.t option * Constr.t -> t end (** Rel-context is represented as a list of declarations. Inner-most declarations are at the beginning of the list. Outer-most declarations are at the end of the list. *) type t = Declaration.t list (** empty rel-context *) val empty : t (** Return a new rel-context enriched by with a given inner-most declaration. *) val add : Declaration.t -> t -> t (** Return the number of {e local declarations} in a given context. *) val length : t -> int (** Check whether given two rel-contexts are equal. *) val equal : t -> t -> bool (** Return the number of {e local assumptions} in a given rel-context. *) val nhyps : t -> int (** Return a declaration designated by a given de Bruijn index. @raise Not_found if the designated de Bruijn index outside the range. *) val lookup : int -> t -> Declaration.t (** Map all terms in a given rel-context. *) val map : (Constr.t -> Constr.t) -> t -> t (** Perform a given action on every declaration in a given rel-context. *) val iter : (Constr.t -> unit) -> t -> unit (** Reduce all terms in a given rel-context to a single value. Innermost declarations are processed first. *) val fold_inside : ('a -> Declaration.t -> 'a) -> init:'a -> t -> 'a (** Reduce all terms in a given rel-context to a single value. Outermost declarations are processed first. *) val fold_outside : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a (** Map a given rel-context to a list where each {e local assumption} is mapped to [true] and each {e local definition} is mapped to [false]. *) val to_tags : t -> bool list (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] with n = |Δ| and with the {e local definitions} of [Γ] skipped in [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) val to_extended_list : int -> t -> Constr.t list (** [extended_vect n Γ] does the same, returning instead an array. *) val to_extended_vect : int -> t -> Constr.t array end (** This module represents contexts that can capture non-anonymous variables. Individual declarations are then designated by the identifiers they bind. *) module Named : sig (** Representation of {e local declarations}. *) module Declaration : sig type t = LocalAssum of Id.t * Constr.t (** identifier, type *) | LocalDef of Id.t * Constr.t * Constr.t (** identifier, value, type *) (** Return the identifier bound by a given declaration. *) val get_id : t -> Id.t (** Return [Some value] for local-declarations and [None] for local-assumptions. *) val get_value : t -> Constr.t option (** Return the type of the name bound by a given declaration. *) val get_type : t -> Constr.t (** Set the identifier that is bound by a given declaration. *) val set_id : Id.t -> t -> t (** Set the type of the bound variable in a given declaration. *) val set_type : Constr.t -> t -> t (** Return [true] iff a given declaration is a local assumption. *) val is_local_assum : t -> bool (** Return [true] iff a given declaration is a local definition. *) val is_local_def : t -> bool (** Check whether any term in a given declaration satisfies a given predicate. *) val exists : (Constr.t -> bool) -> t -> bool (** Check whether all terms in a given declaration satisfy a given predicate. *) val for_all : (Constr.t -> bool) -> t -> bool (** Check whether the two given declarations are equal. *) val equal : t -> t -> bool (** Map the identifier bound by a given declaration. *) val map_id : (Id.t -> Id.t) -> t -> t (** For local assumptions, this function returns the original local assumptions. For local definitions, this function maps the value in the local definition. *) val map_value : (Constr.t -> Constr.t) -> t -> t (** Map the type of the name bound by a given declaration. *) val map_type : (Constr.t -> Constr.t) -> t -> t (** Map all terms in a given declaration. *) val map_constr : (Constr.t -> Constr.t) -> t -> t (** Perform a given action on all terms in a given declaration. *) val iter_constr : (Constr.t -> unit) -> t -> unit (** Reduce all terms in a given declaration to a single value. *) val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a val to_tuple : t -> Id.t * Constr.t option * Constr.t val of_tuple : Id.t * Constr.t option * Constr.t -> t end (** Rel-context is represented as a list of declarations. Inner-most declarations are at the beginning of the list. Outer-most declarations are at the end of the list. *) type t = Declaration.t list (** empty named-context *) val empty : t (** Return a new rel-context enriched by with a given inner-most declaration. *) val add : Declaration.t -> t -> t (** Return the number of {e local declarations} in a given named-context. *) val length : t -> int (** Return a declaration designated by an identifier of the variable bound in that declaration. @raise Not_found if the designated identifier is not bound in a given named-context. *) val lookup : Id.t -> t -> Declaration.t (** Check whether given two rel-contexts are equal. *) val equal : t -> t -> bool (** Map all terms in a given named-context. *) val map : (Constr.t -> Constr.t) -> t -> t (** Perform a given action on every declaration in a given named-context. *) val iter : (Constr.t -> unit) -> t -> unit (** Reduce all terms in a given named-context to a single value. Innermost declarations are processed first. *) val fold_inside : ('a -> Declaration.t -> 'a) -> init:'a -> t -> 'a (** Reduce all terms in a given named-context to a single value. Outermost declarations are processed first. *) val fold_outside : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a (** Return the set of all identifiers bound in a given named-context. *) val to_vars : t -> Id.Set.t (** [instance_from_named_context Ω] builds an instance [args] such that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it gives [Var id1, Var id3]. All [idj] are supposed distinct. *) val to_instance : t -> Constr.t list end module NamedList : sig module Declaration : sig type t = Id.t list * Constr.t option * Constr.t val map_constr : (Constr.t -> Constr.t) -> t -> t end type t = Declaration.t list val fold : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a end type section_context = Named.t coq-8.6/kernel/mod_typing.ml0000644000175000017500000003473713022274260015460 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mp | MEapply (expr,_) -> mp_from_mexpr expr | MEwith (expr,_) -> mp_from_mexpr expr let is_modular = function | SFBmodule _ | SFBmodtype _ -> true | SFBconst _ | SFBmind _ -> false (** Split a [structure_body] at some label corresponding to a modular definition or not. *) let split_struc k m struc = let rec split rev_before = function | [] -> raise Not_found | (k',b)::after when Label.equal k k' && (is_modular b) == (m : bool) -> List.rev rev_before,b,after | h::tail -> split (h::rev_before) tail in split [] struc let discr_resolver mtb = match mtb.mod_type with | NoFunctor _ -> mtb.mod_delta | MoreFunctor _ -> empty_delta_resolver let rec rebuild_mp mp l = match l with | []-> mp | i::r -> rebuild_mp (MPdot(mp,Label.of_id i)) r let (+++) = Univ.ContextSet.union let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let lab,idl = match idl with | [] -> assert false | id::idl -> Label.of_id id, idl in try let modular = not (List.is_empty idl) in let before,spec,after = split_struc lab modular struc in let env' = Modops.add_structure mp before equiv env in if List.is_empty idl then (* Toplevel definition *) let cb = match spec with | SFBconst cb -> cb | _ -> error_not_a_constant lab in (* In the spirit of subtyping.check_constant, we accept any implementations of parameters and opaques terms, as long as they have the right type *) let uctx = Declareops.universes_of_constant (opaque_tables env) cb in let uctx = (* Context of the spec *) if cb.const_polymorphic then Univ.instantiate_univ_context uctx else uctx in let c', univs, ctx' = if not cb.const_polymorphic then let env' = Environ.push_context ~strict:true uctx env' in let env' = Environ.push_context ~strict:true ctx env' in let c',cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in let typ = Typeops.type_of_constant_type env' cb.const_type in let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in j.uj_val, cst' | Def cs -> let c' = Mod_subst.force_constr cs in c, Reduction.infer_conv env' (Environ.universes env') c c' in c', ctx, Univ.ContextSet.add_constraints cst (Univ.ContextSet.of_context ctx) else let cus, ccst = Univ.UContext.dest uctx in let newus, cst = Univ.UContext.dest ctx in let () = if not (Univ.Instance.length cus == Univ.Instance.length newus) then error_incorrect_with_constraint lab in let inst = Univ.Instance.append cus newus in let csti = Univ.enforce_eq_instances cus newus cst in let csta = Univ.Constraint.union csti ccst in let env' = Environ.push_context ~strict:false (Univ.UContext.make (inst, csta)) env in let () = if not (UGraph.check_constraints cst (Environ.universes env')) then error_incorrect_with_constraint lab in let cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in let typ = Typeops.type_of_constant_type env' cb.const_type in let typ = Vars.subst_instance_constr cus typ in let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in cst' | Def cs -> let c' = Vars.subst_instance_constr cus (Mod_subst.force_constr cs) in let cst' = Reduction.infer_conv env' (Environ.universes env') c c' in cst' in if not (Univ.Constraint.is_empty cst) then error_incorrect_with_constraint lab; let subst, ctx = Univ.abstract_universes true ctx in Vars.subst_univs_level_constr subst c, ctx, Univ.ContextSet.empty in let def = Def (Mod_subst.from_val c') in (* let ctx' = Univ.UContext.make (newus, cst) in *) let univs = if cb.const_polymorphic then Some cb.const_universes else None in let cb' = { cb with const_body = def; const_universes = ctx ; const_body_code = Option.map Cemitcodes.from_val (compile_constant_body env' univs def) } in before@(lab,SFBconst(cb'))::after, c', ctx' else (* Definition inside a sub-module *) let mb = match spec with | SFBmodule mb -> mb | _ -> error_not_a_module (Label.to_string lab) in begin match mb.mod_expr with | Abstract -> let struc = Modops.destr_nofunctor mb.mod_type in let struc',c',cst = check_with_def env' struc (idl,(c,ctx)) (MPdot(mp,lab)) mb.mod_delta in let mb' = { mb with mod_type = NoFunctor struc'; mod_type_alg = None } in before@(lab,SFBmodule mb')::after, c', cst | _ -> error_generative_module_expected lab end with | Not_found -> error_no_such_label lab | Reduction.NotConvertible -> error_incorrect_with_constraint lab let rec check_with_mod env struc (idl,mp1) mp equiv = let lab,idl = match idl with | [] -> assert false | id::idl -> Label.of_id id, idl in try let before,spec,after = split_struc lab true struc in let env' = Modops.add_structure mp before equiv env in let old = match spec with | SFBmodule mb -> mb | _ -> error_not_a_module (Label.to_string lab) in if List.is_empty idl then (* Toplevel module definition *) let mb_mp1 = lookup_module mp1 env in let mtb_mp1 = module_type_of_module mb_mp1 in let cst = match old.mod_expr with | Abstract -> begin try let mtb_old = module_type_of_module old in let chk_cst = Subtyping.check_subtypes env' mtb_mp1 mtb_old in Univ.ContextSet.add_constraints chk_cst old.mod_constraints with Failure _ -> (* TODO: where can a Failure come from ??? *) error_incorrect_with_constraint lab end | Algebraic (NoFunctor (MEident(mp'))) -> check_modpath_equiv env' mp1 mp'; old.mod_constraints | _ -> error_generative_module_expected lab in let mp' = MPdot (mp,lab) in let new_mb = strengthen_and_subst_mb mb_mp1 mp' false in let new_mb' = { new_mb with mod_mp = mp'; mod_expr = Algebraic (NoFunctor (MEident mp1)); mod_constraints = cst } in let new_equiv = add_delta_resolver equiv new_mb.mod_delta in (* we propagate the new equality in the rest of the signature with the identity substitution accompagned by the new resolver*) let id_subst = map_mp mp' mp' new_mb.mod_delta in let new_after = subst_structure id_subst after in before@(lab,SFBmodule new_mb')::new_after, new_equiv, cst else (* Module definition of a sub-module *) let mp' = MPdot (mp,lab) in let old = match spec with | SFBmodule msb -> msb | _ -> error_not_a_module (Label.to_string lab) in begin match old.mod_expr with | Abstract -> let struc = destr_nofunctor old.mod_type in let struc',equiv',cst = check_with_mod env' struc (idl,mp1) mp' old.mod_delta in let new_mb = { old with mod_type = NoFunctor struc'; mod_type_alg = None; mod_delta = equiv' } in let new_equiv = add_delta_resolver equiv equiv' in let id_subst = map_mp mp' mp' equiv' in let new_after = subst_structure id_subst after in before@(lab,SFBmodule new_mb)::new_after, new_equiv, cst | Algebraic (NoFunctor (MEident mp0)) -> let mpnew = rebuild_mp mp0 idl in check_modpath_equiv env' mpnew mp; before@(lab,spec)::after, equiv, Univ.ContextSet.empty | _ -> error_generative_module_expected lab end with | Not_found -> error_no_such_label lab | Reduction.NotConvertible -> error_incorrect_with_constraint lab let check_with env mp (sign,alg,reso,cst) = function |WithDef(idl,c) -> let struc = destr_nofunctor sign in let struc',c',cst' = check_with_def env struc (idl,c) mp reso in let wd' = WithDef (idl,(c',Univ.ContextSet.to_context cst')) in NoFunctor struc', MEwith (alg,wd'), reso, cst+++cst' |WithMod(idl,mp1) as wd -> let struc = destr_nofunctor sign in let struc',reso',cst' = check_with_mod env struc (idl,mp1) mp reso in NoFunctor struc', MEwith (alg,wd), reso', cst+++cst' let translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg = let farg_id, farg_b, fbody_b = destr_functor sign in let mtb = module_type_of_module (lookup_module mp1 env) in let cst2 = Subtyping.check_subtypes env mtb farg_b in let mp_delta = discr_resolver mtb in let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in let subst = map_mbid farg_id mp1 mp_delta in let body = subst_signature subst fbody_b in let alg' = mkalg alg mp1 in let reso' = subst_codom_delta_resolver subst reso in body,alg',reso', Univ.ContextSet.add_constraints cst2 cst1 (** Translation of a module struct entry : - We translate to a module when a [module_path] is given, otherwise to a module type. - The first output is the expanded signature - The second output is the algebraic expression, kept for the extraction. *) let mk_alg_app alg arg = MEapply (alg,arg) let rec translate_mse env mpo inl = function |MEident mp1 as me -> let mb = match mpo with |Some mp -> strengthen_and_subst_mb (lookup_module mp1 env) mp false |None -> lookup_modtype mp1 env in mb.mod_type, me, mb.mod_delta, Univ.ContextSet.empty |MEapply (fe,mp1) -> translate_apply env inl (translate_mse env mpo inl fe) mp1 mk_alg_app |MEwith(me, with_decl) -> assert (mpo == None); (* No 'with' syntax for modules *) let mp = mp_from_mexpr me in check_with env mp (translate_mse env None inl me) with_decl let mk_mod mp e ty cst reso = { mod_mp = mp; mod_expr = e; mod_type = ty; mod_type_alg = None; mod_constraints = cst; mod_delta = reso; mod_retroknowledge = [] } let mk_modtype mp ty cst reso = mk_mod mp Abstract ty cst reso let rec translate_mse_funct env mpo inl mse = function |[] -> let sign,alg,reso,cst = translate_mse env mpo inl mse in sign, NoFunctor alg, reso, cst |(mbid, ty) :: params -> let mp_id = MPbound mbid in let mtb = translate_modtype env mp_id inl ([],ty) in let env' = add_module_type mp_id mtb env in let sign,alg,reso,cst = translate_mse_funct env' mpo inl mse params in let alg' = MoreFunctor (mbid,mtb,alg) in MoreFunctor (mbid, mtb, sign), alg',reso, cst +++ mtb.mod_constraints and translate_modtype env mp inl (params,mte) = let sign,alg,reso,cst = translate_mse_funct env None inl mte params in let mtb = mk_modtype (mp_from_mexpr mte) sign cst reso in let mtb' = subst_modtype_and_resolver mtb mp in { mtb' with mod_type_alg = Some alg } (** [finalize_module] : from an already-translated (or interactive) implementation and an (optional) signature entry, produces a final [module_body] *) let finalize_module env mp (sign,alg,reso,cst) restype = match restype with |None -> let impl = match alg with Some e -> Algebraic e | None -> FullStruct in mk_mod mp impl sign cst reso |Some (params_mte,inl) -> let res_mtb = translate_modtype env mp inl params_mte in let auto_mtb = mk_modtype mp sign Univ.ContextSet.empty reso in let cst' = Subtyping.check_subtypes env auto_mtb res_mtb in let impl = match alg with Some e -> Algebraic e | None -> Struct sign in { res_mtb with mod_mp = mp; mod_expr = impl; (** cst from module body typing, cst' from subtyping, constraints from module type. *) mod_constraints = Univ.ContextSet.add_constraints cst' (cst +++ res_mtb.mod_constraints) } let translate_module env mp inl = function |MType (params,ty) -> let mtb = translate_modtype env mp inl (params,ty) in module_body_of_type mp mtb |MExpr (params,mse,oty) -> let (sg,alg,reso,cst) = translate_mse_funct env (Some mp) inl mse params in let restype = Option.map (fun ty -> ((params,ty),inl)) oty in finalize_module env mp (sg,Some alg,reso,cst) restype (** We now forbid any Include of functors with restricted signatures. Otherwise, we could end with the creation of undesired axioms (see #3746). Note that restricted non-functorized modules are ok, thanks to strengthening. *) let rec unfunct = function |NoFunctor me -> me |MoreFunctor(_,_,me) -> unfunct me let rec forbid_incl_signed_functor env = function |MEapply(fe,_) -> forbid_incl_signed_functor env fe |MEwith _ -> assert false (* No 'with' syntax for modules *) |MEident mp1 -> let mb = lookup_module mp1 env in match mb.mod_type, mb.mod_type_alg, mb.mod_expr with |MoreFunctor _, Some _, _ -> (* functor + restricted signature = error *) error_include_restricted_functor mp1 |MoreFunctor _, None, Algebraic me -> (* functor, no signature yet, a definition which may be restricted *) forbid_incl_signed_functor env (unfunct me) |_ -> () let rec translate_mse_inclmod env mp inl = function |MEident mp1 -> let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp true in let sign = clean_bounded_mod_expr mb.mod_type in sign,(),mb.mod_delta,Univ.ContextSet.empty |MEapply (fe,arg) -> let ftrans = translate_mse_inclmod env mp inl fe in translate_apply env inl ftrans arg (fun _ _ -> ()) |MEwith _ -> assert false (* No 'with' syntax for modules *) let translate_mse_incl is_mod env mp inl me = if is_mod then let () = forbid_incl_signed_functor env me in translate_mse_inclmod env mp inl me else let mtb = translate_modtype env mp inl ([],me) in let sign = clean_bounded_mod_expr mtb.mod_type in sign,(),mtb.mod_delta,mtb.mod_constraints coq-8.6/kernel/vconv.mli0000644000175000017500000000172513022274260014602 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* types kernel_conversion_function (** A conversion function parametrized by a universe comparator. Used outside of the kernel. *) val vm_conv_gen : conv_pb -> (types, 'a) generic_conversion_function (** Precompute a VM value from a constr *) val val_of_constr : env -> constr -> values coq-8.6/kernel/nativelambda.mli0000644000175000017500000000301613022274260016071 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr option; evars_typ : existential -> types; evars_metas : metavariable -> types } val empty_evars : evars val decompose_Llam : lambda -> Names.name array * lambda val decompose_Llam_Llet : lambda -> (Names.name * lambda option) array * lambda val is_lazy : prefix -> constr -> bool val mk_lazy : lambda -> lambda val get_mind_prefix : env -> mutual_inductive -> string val get_alias : env -> pconstant -> pconstant val lambda_of_constr : env -> evars -> Constr.constr -> lambda val compile_static_int31 : bool -> Constr.constr array -> lambda val compile_dynamic_int31 : bool -> prefix -> constructor -> lambda array -> lambda val before_match_int31 : inductive -> bool -> prefix -> constructor -> lambda -> lambda val compile_prim : Primitives.t -> constant -> bool -> prefix -> lambda array -> lambda coq-8.6/kernel/univ.mli0000644000175000017500000003107413022274260014430 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool (** Is the universe set or prop? *) val is_prop : t -> bool val is_set : t -> bool (** Is it specifically Prop or Set *) val compare : t -> t -> int (** Comparison function *) val equal : t -> t -> bool (** Equality function *) val hash : t -> int val make : Names.DirPath.t -> int -> t (** Create a new universe level from a unique identifier and an associated module path. *) val pr : t -> Pp.std_ppcmds (** Pretty-printing *) val to_string : t -> string (** Debug printing *) val var : int -> t val var_index : t -> int option end type universe_level = Level.t (** Alias name. *) (** Sets of universe levels *) module LSet : sig include CSig.SetS with type elt = universe_level val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds (** Pretty-printing *) end type universe_set = LSet.t module Universe : sig type t (** Type of universes. A universe is defined as a set of level expressions. A level expression is built from levels and successors of level expressions, i.e.: le ::= l + n, n \in N. A universe is said atomic if it consists of a single level expression with no increment, and algebraic otherwise (think the least upper bound of a set of level expressions). *) val compare : t -> t -> int (** Comparison function *) val equal : t -> t -> bool (** Equality function on formal universes *) val hash : t -> int (** Hash function *) val make : Level.t -> t (** Create a universe representing the given level. *) val pr : t -> Pp.std_ppcmds (** Pretty-printing *) val pr_with : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds val is_level : t -> bool (** Test if the universe is a level or an algebraic universe. *) val is_levels : t -> bool (** Test if the universe is a lub of levels or contains +n's. *) val level : t -> Level.t option (** Try to get a level out of a universe, returns [None] if it is an algebraic universe. *) val levels : t -> LSet.t (** Get the levels inside the universe, forgetting about increments *) val super : t -> t (** The universe strictly above *) val sup : t -> t -> t (** The l.u.b. of 2 universes *) val type0m : t (** image of Prop in the universes hierarchy *) val type0 : t (** image of Set in the universes hierarchy *) val type1 : t (** the universe of the type of Prop/Set *) val exists : (Level.t * int -> bool) -> t -> bool val for_all : (Level.t * int -> bool) -> t -> bool end type universe = Universe.t (** Alias name. *) val pr_uni : universe -> Pp.std_ppcmds (** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *) val type0m_univ : universe val type0_univ : universe val type1_univ : universe val is_type0_univ : universe -> bool val is_type0m_univ : universe -> bool val is_univ_variable : universe -> bool val is_small_univ : universe -> bool val sup : universe -> universe -> universe val super : universe -> universe val universe_level : universe -> universe_level option (** [univ_level_mem l u] Is l is mentionned in u ? *) val univ_level_mem : universe_level -> universe -> bool (** [univ_level_rem u v min] removes [u] from [v], resulting in [min] if [v] was exactly [u]. *) val univ_level_rem : universe_level -> universe -> universe -> universe (** {6 Constraints. } *) type constraint_type = Lt | Le | Eq type univ_constraint = universe_level * constraint_type * universe_level module Constraint : sig include Set.S with type elt = univ_constraint end type constraints = Constraint.t val empty_constraint : constraints val union_constraint : constraints -> constraints -> constraints val eq_constraint : constraints -> constraints -> bool (** A value with universe constraints. *) type 'a constrained = 'a * constraints (** Constrained *) val constraints_of : 'a constrained -> constraints (** Enforcing constraints. *) type 'a constraint_function = 'a -> 'a -> constraints -> constraints val enforce_eq : universe constraint_function val enforce_leq : universe constraint_function val enforce_eq_level : universe_level constraint_function val enforce_leq_level : universe_level constraint_function (** Type explanation is used to decorate error messages to provide useful explanation why a given constraint is rejected. It is composed of a path of universes and relation kinds [(r1,u1);..;(rn,un)] means .. <(r1) u1 <(r2) ... <(rn) un (where <(ri) is the relation symbol denoted by ri, currently only < and <=). The lowest end of the chain is supposed known (see UniverseInconsistency exn). The upper end may differ from the second univ of UniverseInconsistency because all universes in the path are canonical. Note that each step does not necessarily correspond to an actual constraint, but reflect how the system stores the graph and may result from combination of several constraints... *) type explanation = (constraint_type * universe) list type univ_inconsistency = constraint_type * universe * universe * explanation option exception UniverseInconsistency of univ_inconsistency (** {6 Support for universe polymorphism } *) (** Polymorphic maps from universe levels to 'a *) module LMap : sig include CMap.ExtS with type key = universe_level and module Set := LSet val union : 'a t -> 'a t -> 'a t (** [union x y] favors the bindings in the first map. *) val diff : 'a t -> 'a t -> 'a t (** [diff x y] removes bindings from x that appear in y (whatever the value). *) val subst_union : 'a option t -> 'a option t -> 'a option t (** [subst_union x y] favors the bindings of the first map that are [Some], otherwise takes y's bindings. *) val pr : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds (** Pretty-printing *) end type 'a universe_map = 'a LMap.t (** {6 Substitution} *) type universe_subst_fn = universe_level -> universe type universe_level_subst_fn = universe_level -> universe_level (** A full substitution, might involve algebraic universes *) type universe_subst = universe universe_map type universe_level_subst = universe_level universe_map val level_subst_of : universe_subst_fn -> universe_level_subst_fn (** {6 Universe instances} *) module Instance : sig type t (** A universe instance represents a vector of argument universes to a polymorphic definition (constant, inductive or constructor). *) val empty : t val is_empty : t -> bool val of_array : Level.t array -> t val to_array : t -> Level.t array val append : t -> t -> t (** To concatenate two instances, used for discharge *) val equal : t -> t -> bool (** Equality *) val length : t -> int (** Instance length *) val hcons : t -> t (** Hash-consing. *) val hash : t -> int (** Hash value *) val share : t -> t * int (** Simultaneous hash-consing and hash-value computation *) val subst_fn : universe_level_subst_fn -> t -> t (** Substitution by a level-to-level function. *) val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds (** Pretty-printing, no comments *) val levels : t -> LSet.t (** The set of levels in the instance *) end type universe_instance = Instance.t val enforce_eq_instances : universe_instance constraint_function type 'a puniverses = 'a * universe_instance val out_punivs : 'a puniverses -> 'a val in_punivs : 'a -> 'a puniverses val eq_puniverses : ('a -> 'a -> bool) -> 'a puniverses -> 'a puniverses -> bool (** A vector of universe levels with universe constraints, representiong local universe variables and associated constraints *) module UContext : sig type t val make : Instance.t constrained -> t val empty : t val is_empty : t -> bool val instance : t -> Instance.t val constraints : t -> constraints val dest : t -> Instance.t * constraints (** Keeps the order of the instances *) val union : t -> t -> t (* the number of universes in the context *) val size : t -> int end type universe_context = UContext.t (** Universe contexts (as sets) *) module ContextSet : sig type t = universe_set constrained val empty : t val is_empty : t -> bool val singleton : universe_level -> t val of_instance : Instance.t -> t val of_set : universe_set -> t val equal : t -> t -> bool val union : t -> t -> t val append : t -> t -> t (** Variant of {!union} which is more efficient when the left argument is much smaller than the right one. *) val diff : t -> t -> t val add_universe : universe_level -> t -> t val add_constraints : constraints -> t -> t val add_instance : Instance.t -> t -> t (** Arbitrary choice of linear order of the variables *) val to_context : t -> universe_context val of_context : universe_context -> t val constraints : t -> constraints val levels : t -> universe_set end (** A set of universes with universe constraints. We linearize the set to a list after typechecking. Beware, representation could change. *) type universe_context_set = ContextSet.t (** A value in a universe context (resp. context set). *) type 'a in_universe_context = 'a * universe_context type 'a in_universe_context_set = 'a * universe_context_set val empty_level_subst : universe_level_subst val is_empty_level_subst : universe_level_subst -> bool (** Substitution of universes. *) val subst_univs_level_level : universe_level_subst -> universe_level -> universe_level val subst_univs_level_universe : universe_level_subst -> universe -> universe val subst_univs_level_constraints : universe_level_subst -> constraints -> constraints val subst_univs_level_instance : universe_level_subst -> universe_instance -> universe_instance (** Level to universe substitutions. *) val empty_subst : universe_subst val is_empty_subst : universe_subst -> bool val make_subst : universe_subst -> universe_subst_fn val subst_univs_universe : universe_subst_fn -> universe -> universe val subst_univs_constraints : universe_subst_fn -> constraints -> constraints (** Substitution of instances *) val subst_instance_instance : universe_instance -> universe_instance -> universe_instance val subst_instance_universe : universe_instance -> universe -> universe val subst_instance_constraints : universe_instance -> constraints -> constraints val make_instance_subst : universe_instance -> universe_level_subst val make_inverse_instance_subst : universe_instance -> universe_level_subst val abstract_universes : bool -> universe_context -> universe_level_subst * universe_context (** Get the instantiated graph. *) val instantiate_univ_context : universe_context -> universe_context val instantiate_univ_constraints : universe_instance -> universe_context -> constraints (** {6 Pretty-printing of universes. } *) val pr_constraint_type : constraint_type -> Pp.std_ppcmds val pr_constraints : (Level.t -> Pp.std_ppcmds) -> constraints -> Pp.std_ppcmds val pr_universe_context : (Level.t -> Pp.std_ppcmds) -> universe_context -> Pp.std_ppcmds val pr_universe_context_set : (Level.t -> Pp.std_ppcmds) -> universe_context_set -> Pp.std_ppcmds val explain_universe_inconsistency : (Level.t -> Pp.std_ppcmds) -> univ_inconsistency -> Pp.std_ppcmds val pr_universe_level_subst : universe_level_subst -> Pp.std_ppcmds val pr_universe_subst : universe_subst -> Pp.std_ppcmds (** {6 Hash-consing } *) val hcons_univ : universe -> universe val hcons_constraints : constraints -> constraints val hcons_universe_set : universe_set -> universe_set val hcons_universe_context : universe_context -> universe_context val hcons_universe_context_set : universe_context_set -> universe_context_set (******) (* deprecated: use qualified names instead *) val compare_levels : universe_level -> universe_level -> int val eq_levels : universe_level -> universe_level -> bool (** deprecated: Equality of formal universe expressions. *) val equal_universes : universe -> universe -> bool coq-8.6/kernel/retroknowledge.ml0000644000175000017500000001645013022274260016332 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* entry]. *) module Proactive = Map.Make (struct type t = field let compare = compare end) type proactive = entry Proactive.t (* The [reactive] knowledge contains the mapping [entry->field]. Fields are later to be interpreted as a [reactive_info]. *) module EntryOrd = struct type t = entry let compare = Constr.compare end module Reactive = Map.Make (EntryOrd) type reactive_info = {(*information required by the compiler of the VM *) vm_compiling : (*fastcomputation flag -> continuation -> result *) (bool->Cbytecodes.comp_env->constr array -> int->Cbytecodes.bytecodes->Cbytecodes.bytecodes) option; vm_constant_static : (*fastcomputation flag -> constructor -> args -> result*) (bool->constr array->Cbytecodes.structured_constant) option; vm_constant_dynamic : (*fastcomputation flag -> constructor -> reloc -> args -> sz -> cont -> result *) (bool->Cbytecodes.comp_env->Cbytecodes.block array->int-> Cbytecodes.bytecodes->Cbytecodes.bytecodes) option; (* fastcomputation flag -> cont -> result *) vm_before_match : (bool -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) option; (* tag (= compiled int for instance) -> result *) vm_decompile_const : (int -> Term.constr) option; native_compiling : (bool -> Nativeinstr.prefix -> Nativeinstr.lambda array -> Nativeinstr.lambda) option; native_constant_static : (bool -> constr array -> Nativeinstr.lambda) option; native_constant_dynamic : (bool -> Nativeinstr.prefix -> constructor -> Nativeinstr.lambda array -> Nativeinstr.lambda) option; native_before_match : (bool -> Nativeinstr.prefix -> constructor -> Nativeinstr.lambda -> Nativeinstr.lambda) option } and reactive = field Reactive.t and retroknowledge = {flags : flags; proactive : proactive; reactive : reactive} (* This type represent an atomic action of the retroknowledge. It is stored in the compiled libraries *) (* As per now, there is only the possibility of registering things the possibility of unregistering or changing the flag is under study *) type action = | RKRegister of field*entry (*initialisation*) let initial_flags = {fastcomputation = true;} let initial_proactive = (Proactive.empty:proactive) let initial_reactive = (Reactive.empty:reactive) let initial_retroknowledge = {flags = initial_flags; proactive = initial_proactive; reactive = initial_reactive } let empty_reactive_info = { vm_compiling = None ; vm_constant_static = None; vm_constant_dynamic = None; vm_before_match = None; vm_decompile_const = None; native_compiling = None; native_constant_static = None; native_constant_dynamic = None; native_before_match = None; } (* adds a binding [entry<->field]. *) let add_field knowledge field entry = {knowledge with proactive = Proactive.add field entry knowledge.proactive; reactive = Reactive.add entry field knowledge.reactive} (* acces functions for proactive retroknowledge *) let mem knowledge field = Proactive.mem field knowledge.proactive let find knowledge field = Proactive.find field knowledge.proactive let (dispatch,dispatch_hook) = Hook.make () let dispatch_reactive entry retroknowledge = Hook.get dispatch retroknowledge entry (Reactive.find entry retroknowledge.reactive) (*access functions for reactive retroknowledge*) (* used for compiling of functions (add, mult, etc..) *) let get_vm_compiling_info knowledge key = match (dispatch_reactive key knowledge).vm_compiling with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation (* used for compilation of fully applied constructors *) let get_vm_constant_static_info knowledge key = match (dispatch_reactive key knowledge).vm_constant_static with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation (* used for compilation of partially applied constructors *) let get_vm_constant_dynamic_info knowledge key = match (dispatch_reactive key knowledge).vm_constant_dynamic with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation let get_vm_before_match_info knowledge key = match (dispatch_reactive key knowledge).vm_before_match with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation let get_vm_decompile_constant_info knowledge key = match (dispatch_reactive key knowledge).vm_decompile_const with | None -> raise Not_found | Some f -> f let get_native_compiling_info knowledge key = match (dispatch_reactive key knowledge).native_compiling with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation (* used for compilation of fully applied constructors *) let get_native_constant_static_info knowledge key = match (dispatch_reactive key knowledge).native_constant_static with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation (* used for compilation of partially applied constructors *) let get_native_constant_dynamic_info knowledge key = match (dispatch_reactive key knowledge).native_constant_dynamic with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation let get_native_before_match_info knowledge key = match (dispatch_reactive key knowledge).native_before_match with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation coq-8.6/kernel/cbytecodes.ml0000644000175000017500000002543113022274260015422 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Id.compare id1 id2 | FVnamed _, _ -> -1 | FVrel _, FVnamed _ -> 1 | FVrel r1, FVrel r2 -> Int.compare r1 r2 | FVrel _, FVuniv_var _ -> -1 | FVuniv_var i1, FVuniv_var i2 -> Int.compare i1 i2 | FVuniv_var i1, _ -> 1 end module FvMap = Map.Make(Fv_elem) (*spiwack: both type have been moved from Cbytegen because I needed then for the retroknowledge *) type vm_env = { size : int; (* longueur de la liste [n] *) fv_rev : fv_elem list; (* [fvn; ... ;fv1] *) fv_fwd : int FvMap.t; (* reverse mapping *) } type comp_env = { nb_uni_stack : int ; (* number of universes on the stack, *) (* universes are always at the bottom. *) nb_stack : int; (* number of variables on the stack *) in_stack : int list; (* position in the stack *) nb_rec : int; (* number of mutually recursive functions *) pos_rec : instruction list; (* instruction d'acces pour les variables *) (* de point fix ou de cofix *) offset : int; in_env : vm_env ref (* The free variables of the expression *) } (* --- Pretty print *) open Pp open Util let pp_sort s = match family_of_sort s with | InSet -> str "Set" | InProp -> str "Prop" | InType -> str "Type" let rec pp_struct_const = function | Const_sorts s -> pp_sort s | Const_ind (mind, i) -> pr_mind mind ++ str"#" ++ int i | Const_proj p -> Constant.print p | Const_b0 i -> int i | Const_bn (i,t) -> int i ++ surround (prvect_with_sep pr_comma pp_struct_const t) | Const_univ_level l -> Univ.Level.pr l | Const_type u -> str "Type@{" ++ Univ.pr_uni u ++ str "}" let pp_lbl lbl = str "L" ++ int lbl let pp_fv_elem = function | FVnamed id -> str "FVnamed(" ++ Id.print id ++ str ")" | FVrel i -> str "Rel(" ++ int i ++ str ")" | FVuniv_var v -> str "FVuniv(" ++ int v ++ str ")" let rec pp_instr i = match i with | Klabel _ | Ksequence _ -> assert false | Kacc n -> str "acc " ++ int n | Kenvacc n -> str "envacc " ++ int n | Koffsetclosure n -> str "offsetclosure " ++ int n | Kpush -> str "push" | Kpop n -> str "pop " ++ int n | Kpush_retaddr lbl -> str "push_retaddr " ++ pp_lbl lbl | Kapply n -> str "apply " ++ int n | Kappterm(n, m) -> str "appterm " ++ int n ++ str ", " ++ int m | Kreturn n -> str "return " ++ int n | Kjump -> str "jump" | Krestart -> str "restart" | Kgrab n -> str "grab " ++ int n | Kgrabrec n -> str "grabrec " ++ int n | Kclosure(lbl, n) -> str "closure " ++ pp_lbl lbl ++ str ", " ++ int n | Kclosurerec(fv,init,lblt,lblb) -> h 1 (str "closurerec " ++ int fv ++ str ", " ++ int init ++ str " types = " ++ prlist_with_sep spc pp_lbl (Array.to_list lblt) ++ str " bodies = " ++ prlist_with_sep spc pp_lbl (Array.to_list lblb)) | Kclosurecofix (fv,init,lblt,lblb) -> h 1 (str "closurecofix " ++ int fv ++ str ", " ++ int init ++ str " types = " ++ prlist_with_sep spc pp_lbl (Array.to_list lblt) ++ str " bodies = " ++ prlist_with_sep spc pp_lbl (Array.to_list lblb)) | Kgetglobal idu -> str "getglobal " ++ pr_con idu | Kconst sc -> str "const " ++ pp_struct_const sc | Kmakeblock(n, m) -> str "makeblock " ++ int n ++ str ", " ++ int m | Kmakeprod -> str "makeprod" | Kmakeswitchblock(lblt,lbls,_,sz) -> str "makeswitchblock " ++ pp_lbl lblt ++ str ", " ++ pp_lbl lbls ++ str ", " ++ int sz | Kswitch(lblc,lblb) -> h 1 (str "switch " ++ prlist_with_sep spc pp_lbl (Array.to_list lblc) ++ str " | " ++ prlist_with_sep spc pp_lbl (Array.to_list lblb)) | Kpushfields n -> str "pushfields " ++ int n | Kfield n -> str "field " ++ int n | Ksetfield n -> str "set field" ++ int n | Kstop -> str "stop" | Kbranch lbl -> str "branch " ++ pp_lbl lbl | Kproj(n,p) -> str "proj " ++ int n ++ str " " ++ Constant.print p | Kensurestackcapacity size -> str "growstack " ++ int size | Kaddint31 -> str "addint31" | Kaddcint31 -> str "addcint31" | Kaddcarrycint31 -> str "addcarrycint31" | Ksubint31 -> str "subint31" | Ksubcint31 -> str "subcint31" | Ksubcarrycint31 -> str "subcarrycint31" | Kmulint31 -> str "mulint31" | Kmulcint31 -> str "mulcint31" | Kdiv21int31 -> str "div21int31" | Kdivint31 -> str "divint31" | Kcompareint31 -> str "compareint31" | Khead0int31 -> str "head0int31" | Ktail0int31 -> str "tail0int31" | Kaddmuldivint31 -> str "addmuldivint31" | Kisconst lbl -> str "isconst " ++ int lbl | Kareconst(n,lbl) -> str "areconst " ++ int n ++ spc () ++ int lbl | Kcompint31 -> str "compint31" | Kdecompint31 -> str "decompint" | Klorint31 -> str "lorint31" | Klandint31 -> str "landint31" | Klxorint31 -> str "lxorint31" and pp_bytecodes c = match c with | [] -> str "" | Klabel lbl :: c -> str "L" ++ int lbl ++ str ":" ++ fnl () ++ pp_bytecodes c | Ksequence (l1, l2) :: c -> pp_bytecodes l1 ++ pp_bytecodes l2 ++ pp_bytecodes c | i :: c -> tab () ++ pp_instr i ++ fnl () ++ pp_bytecodes c (*spiwack: moved this type in this file because I needed it for retroknowledge which can't depend from cbytegen *) type block = | Bconstr of constr | Bstrconst of structured_constant | Bmakeblock of int * block array | Bconstruct_app of int * int * int * block array (* tag , nparams, arity *) | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array (* spiwack: compilation given by a function *) (* compilation function (see get_vm_constant_dynamic_info in retroknowledge.mli for more info) , argument array *) coq-8.6/kernel/uGraph.mli0000644000175000017500000000411513022274260014671 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a -> 'a -> bool val check_leq : universe check_function val check_eq : universe check_function (** The empty graph of universes *) val empty_universes : universes (** The initial graph of universes: Prop < Set *) val initial_universes : universes val is_initial_universes : universes -> bool val sort_universes : universes -> universes (** Adds a universe to the graph, ensuring it is >= or > Set. @raises AlreadyDeclared if the level is already declared in the graph. *) exception AlreadyDeclared val add_universe : universe_level -> bool -> universes -> universes (** {6 ... } *) (** Merge of constraints in a universes graph. The function [merge_constraints] merges a set of constraints in a given universes graph. It raises the exception [UniverseInconsistency] if the constraints are not satisfiable. *) val enforce_constraint : univ_constraint -> universes -> universes val merge_constraints : constraints -> universes -> universes val constraints_of_universes : universes -> constraints val check_constraint : universes -> univ_constraint -> bool val check_constraints : constraints -> universes -> bool val check_eq_instances : Instance.t check_function (** Check equality of instances w.r.t. a universe graph *) (** {6 Pretty-printing of universes. } *) val pr_universes : (Level.t -> Pp.std_ppcmds) -> universes -> Pp.std_ppcmds (** {6 Dumping to a file } *) val dump_universes : (constraint_type -> string -> string -> unit) -> universes -> unit coq-8.6/kernel/declareops.mli0000644000175000017500000000551713022274260015573 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'c) -> ('b -> 'd) -> ('a, 'b) declaration_arity -> ('c, 'd) declaration_arity (** {6 Constants} *) val subst_const_body : substitution -> constant_body -> constant_body (** Is there a actual body in const_body ? *) val constant_has_body : constant_body -> bool (** Accessing const_body, forcing access to opaque proof term if needed. Only use this function if you know what you're doing. *) val body_of_constant : Opaqueproof.opaquetab -> constant_body -> Term.constr option val type_of_constant : constant_body -> constant_type val constraints_of_constant : Opaqueproof.opaquetab -> constant_body -> Univ.constraints val universes_of_constant : Opaqueproof.opaquetab -> constant_body -> Univ.universe_context (** Return the universe context, in case the definition is polymorphic, otherwise the context is empty. *) val universes_of_polymorphic_constant : Opaqueproof.opaquetab -> constant_body -> Univ.universe_context val is_opaque : constant_body -> bool (** Side effects *) val string_of_side_effect : side_effect -> string (** {6 Inductive types} *) val eq_recarg : recarg -> recarg -> bool val subst_recarg : substitution -> recarg -> recarg val mk_norec : wf_paths val mk_paths : recarg -> wf_paths list array -> wf_paths val dest_recarg : wf_paths -> recarg val dest_subterms : wf_paths -> wf_paths list array val recarg_length : wf_paths -> int -> int val subst_wf_paths : substitution -> wf_paths -> wf_paths val subst_mind_body : substitution -> mutual_inductive_body -> mutual_inductive_body val inductive_instance : mutual_inductive_body -> universe_instance val inductive_context : mutual_inductive_body -> universe_context (** {6 Kernel flags} *) (** A default, safe set of flags for kernel type-checking *) val safe_flags : typing_flags (** {6 Hash-consing} *) (** Here, strictly speaking, we don't perform true hash-consing of the structure, but simply hash-cons all inner constr and other known elements *) val hcons_const_body : constant_body -> constant_body val hcons_mind : mutual_inductive_body -> mutual_inductive_body val hcons_module_body : module_body -> module_body coq-8.6/kernel/nativecode.ml0000644000175000017500000022057513022274260015425 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* String.equal s1 s2 && Univ.eq_puniverses eq_ind ind1 ind2 | Gconstruct (s1, c1), Gconstruct (s2, c2) -> String.equal s1 s2 && Univ.eq_puniverses eq_constructor c1 c2 | Gconstant (s1, c1), Gconstant (s2, c2) -> String.equal s1 s2 && Univ.eq_puniverses Constant.equal c1 c2 | 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 | Gpred (Some l1, i1), Gpred (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2 | Gfixtype (None, i1), Gfixtype (None, i2) -> Int.equal i1 i2 | Gfixtype (Some l1, i1), Gfixtype (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2 | Gnorm (None, i1), Gnorm (None, i2) -> Int.equal i1 i2 | Gnorm (Some l1, i1), Gnorm (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2 | Gnormtbl (None, i1), Gnormtbl (None, i2) -> Int.equal i1 i2 | Gnormtbl (Some l1, i1), Gnormtbl (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2 | Ginternal s1, Ginternal s2 -> String.equal s1 s2 | Grel i1, Grel i2 -> Int.equal i1 i2 | Gnamed id1, Gnamed id2 -> Id.equal id1 id2 | _ -> false let dummy_gname = Grel 0 open Hashset.Combine let gname_hash gn = match gn with | Gind (s, (ind,u)) -> combinesmall 1 (combine3 (String.hash s) (ind_hash ind) (Univ.Instance.hash u)) | Gconstruct (s, (c,u)) -> combinesmall 2 (combine3 (String.hash s) (constructor_hash c) (Univ.Instance.hash u)) | Gconstant (s, (c,u)) -> combinesmall 3 (combine3 (String.hash s) (Constant.hash c) (Univ.Instance.hash u)) | Gcase (l, i) -> combinesmall 4 (combine (Option.hash Label.hash l) (Int.hash i)) | Gpred (l, i) -> combinesmall 5 (combine (Option.hash Label.hash l) (Int.hash i)) | Gfixtype (l, i) -> combinesmall 6 (combine (Option.hash Label.hash l) (Int.hash i)) | Gnorm (l, i) -> combinesmall 7 (combine (Option.hash Label.hash l) (Int.hash i)) | Gnormtbl (l, i) -> combinesmall 8 (combine (Option.hash Label.hash l) (Int.hash i)) | Ginternal s -> combinesmall 9 (String.hash s) | Grel i -> combinesmall 10 (Int.hash i) | Gnamed id -> combinesmall 11 (Id.hash id) | Gproj (s, p) -> combinesmall 12 (combine (String.hash s) (Constant.hash p)) let case_ctr = ref (-1) let reset_gcase () = case_ctr := -1 let fresh_gcase l = incr case_ctr; Gcase (l,!case_ctr) let pred_ctr = ref (-1) let reset_gpred () = pred_ctr := -1 let fresh_gpred l = incr pred_ctr; Gpred (l,!pred_ctr) let fixtype_ctr = ref (-1) let reset_gfixtype () = fixtype_ctr := -1 let fresh_gfixtype l = incr fixtype_ctr; Gfixtype (l,!fixtype_ctr) let norm_ctr = ref (-1) let reset_norm () = norm_ctr := -1 let fresh_gnorm l = incr norm_ctr; Gnorm (l,!norm_ctr) let normtbl_ctr = ref (-1) let reset_normtbl () = normtbl_ctr := -1 let fresh_gnormtbl l = incr normtbl_ctr; Gnormtbl (l,!normtbl_ctr) (** Symbols (pre-computed values) **) type symbol = | SymbValue of Nativevalues.t | SymbSort of sorts | SymbName of name | SymbConst of constant | SymbMatch of annot_sw | SymbInd of inductive | SymbMeta of metavariable | SymbEvar of existential | SymbLevel of Univ.Level.t let dummy_symb = SymbValue (dummy_value ()) let eq_symbol sy1 sy2 = match sy1, sy2 with | SymbValue v1, SymbValue v2 -> Pervasives.(=) 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 | SymbMatch sw1, SymbMatch sw2 -> eq_annot_sw sw1 sw2 | SymbInd ind1, SymbInd ind2 -> eq_ind ind1 ind2 | SymbMeta m1, SymbMeta m2 -> Int.equal m1 m2 | SymbEvar (evk1,args1), SymbEvar (evk2,args2) -> Evar.equal evk1 evk2 && Array.for_all2 eq_constr args1 args2 | SymbLevel l1, SymbLevel l2 -> Univ.Level.equal l1 l2 | _, _ -> false let hash_symbol symb = match symb with | 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) | SymbMatch sw -> combinesmall 5 (hash_annot_sw sw) | SymbInd ind -> combinesmall 6 (ind_hash ind) | SymbMeta m -> combinesmall 7 m | SymbEvar (evk,args) -> let evh = Evar.hash evk in let hl = Array.fold_left (fun h t -> combine h (Constr.hash t)) evh args in combinesmall 8 hl | SymbLevel l -> combinesmall 9 (Univ.Level.hash l) module HashedTypeSymbol = struct type t = symbol let equal = eq_symbol let hash = hash_symbol end module HashtblSymbol = Hashtbl.Make(HashedTypeSymbol) let symb_tbl = HashtblSymbol.create 211 let clear_symbols () = HashtblSymbol.clear symb_tbl type symbols = symbol array let empty_symbols = [||] let get_value tbl i = match tbl.(i) with | SymbValue v -> v | _ -> anomaly (Pp.str "get_value failed") let get_sort tbl i = match tbl.(i) with | SymbSort s -> s | _ -> anomaly (Pp.str "get_sort failed") let get_name tbl i = match tbl.(i) with | SymbName id -> id | _ -> anomaly (Pp.str "get_name failed") let get_const tbl i = match tbl.(i) with | SymbConst kn -> kn | _ -> anomaly (Pp.str "get_const failed") let get_match tbl i = match tbl.(i) with | SymbMatch case_info -> case_info | _ -> anomaly (Pp.str "get_match failed") let get_ind tbl i = match tbl.(i) with | SymbInd ind -> ind | _ -> anomaly (Pp.str "get_ind failed") let get_meta tbl i = match tbl.(i) with | SymbMeta m -> m | _ -> anomaly (Pp.str "get_meta failed") let get_evar tbl i = match tbl.(i) with | SymbEvar ev -> ev | _ -> anomaly (Pp.str "get_evar failed") let get_level tbl i = match tbl.(i) with | SymbLevel u -> u | _ -> anomaly (Pp.str "get_level failed") let push_symbol x = try HashtblSymbol.find symb_tbl x with Not_found -> let i = HashtblSymbol.length symb_tbl in HashtblSymbol.add symb_tbl x i; i let symbols_tbl_name = Ginternal "symbols_tbl" let get_symbols () = let tbl = Array.make (HashtblSymbol.length symb_tbl) dummy_symb in HashtblSymbol.iter (fun x i -> tbl.(i) <- x) symb_tbl; tbl (** Lambda to Mllambda **) type primitive = | Mk_prod | Mk_sort | Mk_ind | Mk_const | Mk_sw | Mk_fix of rec_pos * int | Mk_cofix of int | Mk_rel of int | Mk_var of identifier | Mk_proj | Is_accu | Is_int | Cast_accu | Upd_cofix | Force_cofix | Mk_uint | Mk_int | Mk_bool | Val_to_int | Mk_I31_accu | Decomp_uint | Mk_meta | Mk_evar | MLand | MLle | MLlt | MLinteq | MLlsl | MLlsr | MLland | MLlor | MLlxor | MLadd | MLsub | MLmul | MLmagic | MLarrayget | Mk_empty_instance | Coq_primitive of Primitives.t * (prefix * constant) option let eq_primitive p1 p2 = match p1, p2 with | Mk_prod, Mk_prod -> true | Mk_sort, Mk_sort -> true | Mk_ind, Mk_ind -> true | Mk_const, Mk_const -> true | Mk_sw, Mk_sw -> true | Mk_fix (rp1, i1), Mk_fix (rp2, i2) -> Int.equal i1 i2 && eq_rec_pos rp1 rp2 | Mk_cofix i1, Mk_cofix i2 -> Int.equal i1 i2 | Mk_rel i1, Mk_rel i2 -> Int.equal i1 i2 | Mk_var id1, Mk_var id2 -> Id.equal id1 id2 | Is_accu, Is_accu -> true | Cast_accu, Cast_accu -> true | Upd_cofix, Upd_cofix -> true | Force_cofix, Force_cofix -> true | Mk_meta, Mk_meta -> true | Mk_evar, Mk_evar -> true | Mk_proj, Mk_proj -> true | MLarrayget, MLarrayget -> true | _ -> false let primitive_hash = function | Mk_prod -> 1 | Mk_sort -> 2 | Mk_ind -> 3 | Mk_const -> 4 | Mk_sw -> 5 | Mk_fix (r, i) -> let h = Array.fold_left (fun h i -> combine h (Int.hash i)) 0 r in combinesmall 6 (combine h (Int.hash i)) | Mk_cofix i -> combinesmall 7 (Int.hash i) | Mk_rel i -> combinesmall 8 (Int.hash i) | Mk_var id -> combinesmall 9 (Id.hash id) | Is_accu -> 10 | Is_int -> 11 | Cast_accu -> 12 | Upd_cofix -> 13 | Force_cofix -> 14 | Mk_uint -> 15 | Mk_int -> 16 | Mk_bool -> 17 | Val_to_int -> 18 | Mk_I31_accu -> 19 | Decomp_uint -> 20 | Mk_meta -> 21 | Mk_evar -> 22 | MLand -> 23 | MLle -> 24 | MLlt -> 25 | MLinteq -> 26 | MLlsl -> 27 | MLlsr -> 28 | MLland -> 29 | MLlor -> 30 | MLlxor -> 31 | MLadd -> 32 | MLsub -> 33 | MLmul -> 34 | MLmagic -> 35 | Coq_primitive (prim, None) -> combinesmall 36 (Primitives.hash prim) | Coq_primitive (prim, Some (prefix,kn)) -> combinesmall 37 (combine3 (String.hash prefix) (Constant.hash kn) (Primitives.hash prim)) | Mk_proj -> 38 | MLarrayget -> 39 | Mk_empty_instance -> 40 type mllambda = | MLlocal of lname | MLglobal of gname | MLprimitive of primitive | MLlam of lname array * mllambda | MLletrec of (lname * lname array * mllambda) array * mllambda | MLlet of lname * mllambda * mllambda | MLapp of mllambda * mllambda array | MLif of mllambda * mllambda * mllambda | MLmatch of annot_sw * mllambda * mllambda * mllam_branches (* argument, prefix, accu branch, branches *) | MLconstruct of string * constructor * mllambda array (* prefix, constructor name, arguments *) | MLint of int | MLuint of Uint31.t | MLsetref of string * mllambda | MLsequence of mllambda * mllambda | MLarray of mllambda array and mllam_branches = ((constructor * lname option array) list * mllambda) array let push_lnames n env lns = snd (Array.fold_left (fun (i,r) x -> (i+1, LNmap.add x i r)) (n,env) lns) let opush_lnames n env lns = let oadd x i r = match x with Some ln -> LNmap.add ln i r | None -> r in snd (Array.fold_left (fun (i,r) x -> (i+1, oadd x i r)) (n,env) lns) (* Alpha-equivalence on mllambda *) (* eq_mllambda gn1 gn2 n env1 env2 t1 t2 tests if t1 = t2 modulo gn1 = gn2 *) let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = match t1, t2 with | MLlocal ln1, MLlocal ln2 -> (try Int.equal (LNmap.find ln1 env1) (LNmap.find ln2 env2) with Not_found -> eq_lname ln1 ln2) | MLglobal gn1', MLglobal gn2' -> eq_gname gn1' gn2' || (eq_gname gn1 gn1' && eq_gname gn2 gn2') || (eq_gname gn1 gn2' && eq_gname gn2 gn1') | MLprimitive prim1, MLprimitive prim2 -> eq_primitive prim1 prim2 | MLlam (lns1, ml1), MLlam (lns2, ml2) -> Int.equal (Array.length lns1) (Array.length lns2) && let env1 = push_lnames n env1 lns1 in let env2 = push_lnames n env2 lns2 in eq_mllambda gn1 gn2 (n+Array.length lns1) env1 env2 ml1 ml2 | MLletrec (defs1, body1), MLletrec (defs2, body2) -> Int.equal (Array.length defs1) (Array.length defs2) && let lns1 = Array.map (fun (x,_,_) -> x) defs1 in let lns2 = Array.map (fun (x,_,_) -> x) defs2 in let env1 = push_lnames n env1 lns1 in let env2 = push_lnames n env2 lns2 in let n = n + Array.length defs1 in eq_letrec gn1 gn2 n env1 env2 defs1 defs2 && eq_mllambda gn1 gn2 n env1 env2 body1 body2 | MLlet (ln1, def1, body1), MLlet (ln2, def2, body2) -> eq_mllambda gn1 gn2 n env1 env2 def1 def2 && let env1 = LNmap.add ln1 n env1 in let env2 = LNmap.add ln2 n env2 in eq_mllambda gn1 gn2 (n+1) env1 env2 body1 body2 | MLapp (ml1, args1), MLapp (ml2, args2) -> eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 && Array.equal (eq_mllambda gn1 gn2 n env1 env2) args1 args2 | MLif (cond1,br1,br'1), MLif (cond2,br2,br'2) -> eq_mllambda gn1 gn2 n env1 env2 cond1 cond2 && eq_mllambda gn1 gn2 n env1 env2 br1 br2 && eq_mllambda gn1 gn2 n env1 env2 br'1 br'2 | MLmatch (annot1, c1, accu1, br1), MLmatch (annot2, c2, accu2, br2) -> eq_annot_sw annot1 annot2 && eq_mllambda gn1 gn2 n env1 env2 c1 c2 && eq_mllambda gn1 gn2 n env1 env2 accu1 accu2 && eq_mllam_branches gn1 gn2 n env1 env2 br1 br2 | MLconstruct (pf1, cs1, args1), MLconstruct (pf2, cs2, args2) -> String.equal pf1 pf2 && eq_constructor cs1 cs2 && Array.equal (eq_mllambda gn1 gn2 n env1 env2) args1 args2 | MLint i1, MLint i2 -> Int.equal i1 i2 | MLuint i1, MLuint i2 -> Uint31.equal i1 i2 | MLsetref (id1, ml1), MLsetref (id2, ml2) -> String.equal id1 id2 && eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 | MLsequence (ml1, ml'1), MLsequence (ml2, ml'2) -> eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 && eq_mllambda gn1 gn2 n env1 env2 ml'1 ml'2 | MLarray arr1, MLarray arr2 -> Array.equal (eq_mllambda gn1 gn2 n env1 env2) arr1 arr2 | _, _ -> false and eq_letrec gn1 gn2 n env1 env2 defs1 defs2 = let eq_def (_,args1,ml1) (_,args2,ml2) = Int.equal (Array.length args1) (Array.length args2) && let env1 = push_lnames n env1 args1 in let env2 = push_lnames n env2 args2 in eq_mllambda gn1 gn2 (n + Array.length args1) env1 env2 ml1 ml2 in Array.equal eq_def defs1 defs2 (* we require here that patterns have the same order, which may be too strong *) and eq_mllam_branches gn1 gn2 n env1 env2 br1 br2 = let eq_cargs (cs1, args1) (cs2, args2) body1 body2 = Int.equal (Array.length args1) (Array.length args2) && eq_constructor cs1 cs2 && let env1 = opush_lnames n env1 args1 in let env2 = opush_lnames n env2 args2 in eq_mllambda gn1 gn2 (n + Array.length args1) env1 env2 body1 body2 in let eq_branch (ptl1,body1) (ptl2,body2) = List.equal (fun pt1 pt2 -> eq_cargs pt1 pt2 body1 body2) ptl1 ptl2 in Array.equal eq_branch br1 br2 (* hash_mllambda gn n env t computes the hash for t ignoring occurrences of gn *) let rec hash_mllambda gn n env t = match t with | MLlocal ln -> combinesmall 1 (LNmap.find ln env) | MLglobal gn' -> combinesmall 2 (if eq_gname gn gn' then 0 else gname_hash gn') | MLprimitive prim -> combinesmall 3 (primitive_hash prim) | MLlam (lns, ml) -> let env = push_lnames n env lns in combinesmall 4 (combine (Array.length lns) (hash_mllambda gn (n+1) env ml)) | MLletrec (defs, body) -> let lns = Array.map (fun (x,_,_) -> x) defs in let env = push_lnames n env lns in let n = n + Array.length defs in let h = combine (hash_mllambda gn n env body) (Array.length defs) in combinesmall 5 (hash_mllambda_letrec gn n env h defs) | MLlet (ln, def, body) -> let hdef = hash_mllambda gn n env def in let env = LNmap.add ln n env in combinesmall 6 (combine hdef (hash_mllambda gn (n+1) env body)) | MLapp (ml, args) -> let h = hash_mllambda gn n env ml in combinesmall 7 (hash_mllambda_array gn n env h args) | MLif (cond,br,br') -> let hcond = hash_mllambda gn n env cond in let hbr = hash_mllambda gn n env br in let hbr' = hash_mllambda gn n env br' in combinesmall 8 (combine3 hcond hbr hbr') | MLmatch (annot, c, accu, br) -> let hannot = hash_annot_sw annot in let hc = hash_mllambda gn n env c in let haccu = hash_mllambda gn n env accu in combinesmall 9 (hash_mllam_branches gn n env (combine3 hannot hc haccu) br) | MLconstruct (pf, cs, args) -> let hpf = String.hash pf in let hcs = constructor_hash cs in combinesmall 10 (hash_mllambda_array gn n env (combine hpf hcs) args) | MLint i -> combinesmall 11 i | MLuint i -> combinesmall 12 (Uint31.to_int i) | MLsetref (id, ml) -> let hid = String.hash id in let hml = hash_mllambda gn n env ml in combinesmall 13 (combine hid hml) | MLsequence (ml, ml') -> let hml = hash_mllambda gn n env ml in let hml' = hash_mllambda gn n env ml' in combinesmall 14 (combine hml hml') | MLarray arr -> combinesmall 15 (hash_mllambda_array gn n env 1 arr) and hash_mllambda_letrec gn n env init defs = let hash_def (_,args,ml) = let env = push_lnames n env args in let nargs = Array.length args in combine nargs (hash_mllambda gn (n + nargs) env ml) in Array.fold_left (fun acc t -> combine (hash_def t) acc) init defs and hash_mllambda_array gn n env init arr = Array.fold_left (fun acc t -> combine (hash_mllambda gn n env t) acc) init arr and hash_mllam_branches gn n env init br = let hash_cargs (cs, args) body = let nargs = Array.length args in let hcs = constructor_hash cs in let env = opush_lnames n env args in let hbody = hash_mllambda gn (n + nargs) env body in combine3 nargs hcs hbody in let hash_branch acc (ptl,body) = List.fold_left (fun acc t -> combine (hash_cargs t body) acc) acc ptl in Array.fold_left hash_branch init br let fv_lam l = let rec aux l bind fv = match l with | MLlocal l -> if LNset.mem l bind then fv else LNset.add l fv | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ -> fv | MLlam (ln,body) -> let bind = Array.fold_right LNset.add ln bind in aux body bind fv | MLletrec(bodies,def) -> let bind = Array.fold_right (fun (id,_,_) b -> LNset.add id b) bodies bind in let fv_body (_,ln,body) fv = let bind = Array.fold_right LNset.add ln bind in aux body bind fv in Array.fold_right fv_body bodies (aux def bind fv) | MLlet(l,def,body) -> aux body (LNset.add l bind) (aux def bind fv) | MLapp(f,args) -> let fv_arg arg fv = aux arg bind fv in Array.fold_right fv_arg args (aux f bind fv) | MLif(t,b1,b2) -> aux t bind (aux b1 bind (aux b2 bind fv)) | MLmatch(_,a,p,bs) -> let fv = aux a bind (aux p bind fv) in let fv_bs (cargs, body) fv = let bind = List.fold_right (fun (_,args) bind -> Array.fold_right (fun o bind -> match o with | Some l -> LNset.add l bind | _ -> bind) args bind) cargs bind in aux body bind fv in Array.fold_right fv_bs bs fv (* argument, accu branch, branches *) | MLconstruct (_,_,p) -> Array.fold_right (fun a fv -> aux a bind fv) p fv | MLsetref(_,l) -> aux l bind fv | MLsequence(l1,l2) -> aux l1 bind (aux l2 bind fv) | MLarray arr -> Array.fold_right (fun a fv -> aux a bind fv) arr fv in aux l LNset.empty LNset.empty let mkMLlam params body = if Array.is_empty params then body else match body with | MLlam (params', body) -> MLlam(Array.append params params', body) | _ -> MLlam(params,body) let mkMLapp f args = if Array.is_empty args then f else match f with | MLapp(f,args') -> MLapp(f,Array.append args' args) | _ -> MLapp(f,args) let empty_params = [||] let decompose_MLlam c = match c with | MLlam(ids,c) -> ids,c | _ -> empty_params,c (*s Global declaration *) type global = (* | Gtblname of gname * identifier array *) | Gtblnorm of gname * lname array * mllambda array | Gtblfixtype of gname * lname array * mllambda array | Glet of gname * mllambda | Gletcase of gname * lname array * annot_sw * mllambda * mllambda * mllam_branches | Gopen of string | Gtype of inductive * int array (* ind name, arities of constructors *) | Gcomment of string (* Alpha-equivalence on globals *) let eq_global g1 g2 = match g1, g2 with | Gtblnorm (gn1,lns1,mls1), Gtblnorm (gn2,lns2,mls2) | Gtblfixtype (gn1,lns1,mls1), Gtblfixtype (gn2,lns2,mls2) -> Int.equal (Array.length lns1) (Array.length lns2) && Int.equal (Array.length mls1) (Array.length mls2) && let env1 = push_lnames 0 LNmap.empty lns1 in let env2 = push_lnames 0 LNmap.empty lns2 in Array.for_all2 (eq_mllambda gn1 gn2 (Array.length lns1) env1 env2) mls1 mls2 | Glet (gn1, def1), Glet (gn2, def2) -> eq_mllambda gn1 gn2 0 LNmap.empty LNmap.empty def1 def2 | Gletcase (gn1,lns1,annot1,c1,accu1,br1), Gletcase (gn2,lns2,annot2,c2,accu2,br2) -> Int.equal (Array.length lns1) (Array.length lns2) && let env1 = push_lnames 0 LNmap.empty lns1 in let env2 = push_lnames 0 LNmap.empty lns2 in let t1 = MLmatch (annot1,c1,accu1,br1) in let t2 = MLmatch (annot2,c2,accu2,br2) in 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 && Array.equal Int.equal arr1 arr2 | Gcomment s1, Gcomment s2 -> String.equal s1 s2 | _, _ -> false let hash_global g = match g with | Gtblnorm (gn,lns,mls) -> let nlns = Array.length lns in let nmls = Array.length mls in let env = push_lnames 0 LNmap.empty lns in let hmls = hash_mllambda_array gn nlns env (combine nlns nmls) mls in combinesmall 1 hmls | Gtblfixtype (gn,lns,mls) -> let nlns = Array.length lns in let nmls = Array.length mls in let env = push_lnames 0 LNmap.empty lns in let hmls = hash_mllambda_array gn nlns env (combine nlns nmls) mls in combinesmall 2 hmls | Glet (gn, def) -> combinesmall 3 (hash_mllambda gn 0 LNmap.empty def) | Gletcase (gn,lns,annot,c,accu,br) -> let nlns = Array.length lns in let env = push_lnames 0 LNmap.empty lns in let t = MLmatch (annot,c,accu,br) in combinesmall 4 (combine nlns (hash_mllambda gn nlns env t)) | Gopen s -> combinesmall 5 (String.hash s) | Gtype (ind, arr) -> combinesmall 6 (combine (ind_hash ind) (Array.fold_left combine 0 arr)) | Gcomment s -> combinesmall 7 (String.hash s) let global_stack = ref ([] : global list) module HashedTypeGlobal = struct type t = global let equal = eq_global let hash = hash_global end module HashtblGlobal = Hashtbl.Make(HashedTypeGlobal) let global_tbl = HashtblGlobal.create 19991 let clear_global_tbl () = HashtblGlobal.clear global_tbl let push_global gn t = try HashtblGlobal.find global_tbl t with Not_found -> (global_stack := t :: !global_stack; HashtblGlobal.add global_tbl t gn; gn) let push_global_let gn body = push_global gn (Glet (gn,body)) let push_global_fixtype gn params body = push_global gn (Gtblfixtype (gn,params,body)) let push_global_norm gn params body = push_global gn (Gtblnorm (gn, params, body)) let push_global_case gn params annot a accu bs = push_global gn (Gletcase (gn, params, annot, a, accu, bs)) (* Compares [t1] and [t2] up to alpha-equivalence. [t1] and [t2] may contain free variables. *) let eq_mllambda t1 t2 = eq_mllambda dummy_gname dummy_gname 0 LNmap.empty LNmap.empty t1 t2 (*s Compilation environment *) type env = { env_rel : mllambda list; (* (MLlocal lname) list *) env_bound : int; (* length of env_rel *) (* free variables *) env_urel : (int * mllambda) list ref; (* list of unbound rel *) env_named : (identifier * mllambda) list ref; env_univ : lname option} let empty_env univ () = { env_rel = []; env_bound = 0; env_urel = ref []; env_named = ref []; env_univ = univ } let push_rel env id = let local = fresh_lname id in local, { env with env_rel = MLlocal local :: env.env_rel; env_bound = env.env_bound + 1 } let push_rels env ids = let lnames, env_rel = Array.fold_left (fun (names,env_rel) id -> let local = fresh_lname id in (local::names, MLlocal local::env_rel)) ([],env.env_rel) ids in Array.of_list (List.rev lnames), { env with env_rel = env_rel; env_bound = env.env_bound + Array.length ids } let get_rel env id i = if i <= env.env_bound then List.nth env.env_rel (i-1) else let i = i - env.env_bound in try Int.List.assoc i !(env.env_urel) with Not_found -> let local = MLlocal (fresh_lname id) in env.env_urel := (i,local) :: !(env.env_urel); local let get_var env id = try Id.List.assoc id !(env.env_named) with Not_found -> let local = MLlocal (fresh_lname (Name id)) in env.env_named := (id, local)::!(env.env_named); local let fresh_univ () = fresh_lname (Name (Id.of_string "univ")) (*s Traduction of lambda to mllambda *) let get_prod_name codom = match codom with | MLlam(ids,_) -> ids.(0).lname | _ -> assert false let get_lname (_,l) = match l with | MLlocal id -> id | _ -> invalid_arg "Nativecode.get_lname" (* Collects free variables from env in an array of local names *) let fv_params env = let fvn, fvr = !(env.env_named), !(env.env_urel) in let size = List.length fvn + List.length fvr in let start,params = match env.env_univ with | None -> 0, Array.make size dummy_lname | Some u -> 1, let t = Array.make (size + 1) dummy_lname in t.(0) <- u; t in if Array.is_empty params then empty_params else begin let fvn = ref fvn in let i = ref start in while not (List.is_empty !fvn) do params.(!i) <- get_lname (List.hd !fvn); fvn := List.tl !fvn; incr i done; let fvr = ref fvr in while not (List.is_empty !fvr) do params.(!i) <- get_lname (List.hd !fvr); fvr := List.tl !fvr; incr i done; params end let generalize_fv env body = mkMLlam (fv_params env) body let empty_args = [||] let fv_args env fvn fvr = let size = List.length fvn + List.length fvr in let start,args = match env.env_univ with | None -> 0, Array.make size (MLint 0) | Some u -> 1, let t = Array.make (size + 1) (MLint 0) in t.(0) <- MLlocal u; t in if Array.is_empty args then empty_args else begin let fvn = ref fvn in let i = ref start in while not (List.is_empty !fvn) do args.(!i) <- get_var env (fst (List.hd !fvn)); fvn := List.tl !fvn; incr i done; let fvr = ref fvr in while not (List.is_empty !fvr) do let (k,_ as kml) = List.hd !fvr in let n = get_lname kml in args.(!i) <- get_rel env n.lname k; fvr := List.tl !fvr; incr i done; args end let get_value_code i = MLapp (MLglobal (Ginternal "get_value"), [|MLglobal symbols_tbl_name; MLint i|]) let get_sort_code i = MLapp (MLglobal (Ginternal "get_sort"), [|MLglobal symbols_tbl_name; MLint i|]) let get_name_code i = MLapp (MLglobal (Ginternal "get_name"), [|MLglobal symbols_tbl_name; MLint i|]) let get_const_code i = MLapp (MLglobal (Ginternal "get_const"), [|MLglobal symbols_tbl_name; MLint i|]) let get_match_code i = MLapp (MLglobal (Ginternal "get_match"), [|MLglobal symbols_tbl_name; MLint i|]) let get_ind_code i = MLapp (MLglobal (Ginternal "get_ind"), [|MLglobal symbols_tbl_name; MLint i|]) let get_meta_code i = MLapp (MLglobal (Ginternal "get_meta"), [|MLglobal symbols_tbl_name; MLint i|]) let get_evar_code i = MLapp (MLglobal (Ginternal "get_evar"), [|MLglobal symbols_tbl_name; MLint i|]) let get_level_code i = MLapp (MLglobal (Ginternal "get_level"), [|MLglobal symbols_tbl_name; MLint i|]) type rlist = | Rnil | Rcons of (constructor * lname option array) list ref * LNset.t * mllambda * rlist' and rlist' = rlist ref let rm_params fv params = Array.map (fun l -> if LNset.mem l fv then Some l else None) params let rec insert cargs body rl = match !rl with | Rnil -> let fv = fv_lam body in let (c,params) = cargs in let params = rm_params fv params in rl:= Rcons(ref [(c,params)], fv, body, ref Rnil) | Rcons(l,fv,body',rl) -> if eq_mllambda body body' then let (c,params) = cargs in let params = rm_params fv params in l := (c,params)::!l else insert cargs body rl let rec to_list rl = match !rl with | Rnil -> [] | Rcons(l,_,body,tl) -> (!l,body)::to_list tl let merge_branches t = let newt = ref Rnil in Array.iter (fun (c,args,body) -> insert (c,args) body newt) t; Array.of_list (to_list newt) type prim_aux = | PAprim of string * constant * Primitives.t * prim_aux array | PAml of mllambda let add_check cond args = let aux cond a = match a with | PAml(MLint _) -> cond | PAml ml -> (* FIXME: use explicit equality function *) if List.mem ml cond then cond else ml::cond | _ -> cond in Array.fold_left aux cond args let extract_prim ml_of l = let decl = ref [] in let cond = ref [] in let rec aux l = match l with | Lprim(prefix,kn,p,args) -> let args = Array.map aux args in cond := add_check !cond args; PAprim(prefix,kn,p,args) | Lrel _ | Lvar _ | Luint _ | Lval _ | Lconst _ -> PAml (ml_of l) | _ -> let x = fresh_lname Anonymous in decl := (x,ml_of l)::!decl; PAml (MLlocal x) in let res = aux l in (!decl, !cond, res) let app_prim p args = MLapp(MLprimitive p, args) let to_int v = match v with | MLapp(MLprimitive Mk_uint, t) -> begin match t.(0) with | MLuint i -> MLint (Uint31.to_int i) | _ -> MLapp(MLprimitive Val_to_int, [|v|]) end | MLapp(MLprimitive Mk_int, t) -> t.(0) | _ -> MLapp(MLprimitive Val_to_int, [|v|]) let of_int v = match v with | MLapp(MLprimitive Val_to_int, t) -> t.(0) | _ -> MLapp(MLprimitive Mk_int,[|v|]) let compile_prim decl cond paux = (* let args_to_int args = for i = 0 to Array.length args - 1 do args.(i) <- to_int args.(i) done; args in *) let rec opt_prim_aux paux = match paux with | PAprim(prefix, kn, op, args) -> let args = Array.map opt_prim_aux args in app_prim (Coq_primitive(op,None)) args (* TODO: check if this inlining was useful begin match op with | Int31lt -> if Sys.word_size = 64 then app_prim Mk_bool [|(app_prim MLlt (args_to_int args))|] else app_prim (Coq_primitive (Primitives.Int31lt,None)) args | Int31le -> if Sys.word_size = 64 then app_prim Mk_bool [|(app_prim MLle (args_to_int args))|] else app_prim (Coq_primitive (Primitives.Int31le, None)) args | Int31lsl -> of_int (mk_lsl (args_to_int args)) | Int31lsr -> of_int (mk_lsr (args_to_int args)) | Int31land -> of_int (mk_land (args_to_int args)) | Int31lor -> of_int (mk_lor (args_to_int args)) | Int31lxor -> of_int (mk_lxor (args_to_int args)) | Int31add -> of_int (mk_add (args_to_int args)) | Int31sub -> of_int (mk_sub (args_to_int args)) | Int31mul -> of_int (mk_mul (args_to_int args)) | _ -> app_prim (Coq_primitive(op,None)) args end *) | PAml ml -> ml and naive_prim_aux paux = match paux with | PAprim(prefix, kn, op, args) -> app_prim (Coq_primitive(op, Some (prefix, kn))) (Array.map naive_prim_aux args) | PAml ml -> ml in let compile_cond cond paux = match cond with | [] -> opt_prim_aux paux | [c1] -> MLif(app_prim Is_int [|c1|], opt_prim_aux paux, naive_prim_aux paux) | c1::cond -> let cond = List.fold_left (fun ml c -> app_prim MLland [| ml; to_int c|]) (app_prim MLland [|to_int c1; MLint 0 |]) cond in let cond = app_prim MLmagic [|cond|] in MLif(cond, naive_prim_aux paux, opt_prim_aux paux) in let add_decl decl body = List.fold_left (fun body (x,d) -> MLlet(x,d,body)) body decl in add_decl decl (compile_cond cond paux) let ml_of_instance instance u = let ml_of_level l = match Univ.Level.var_index l with | Some i -> let univ = MLapp(MLprimitive MLmagic, [|MLlocal (Option.get instance)|]) in mkMLapp (MLprimitive MLarrayget) [|univ; MLint i|] | None -> let i = push_symbol (SymbLevel l) in get_level_code i in let u = Univ.Instance.to_array u in if Array.is_empty u then [||] else let u = Array.map ml_of_level u in [|MLapp (MLprimitive MLmagic, [|MLarray u|])|] let rec ml_of_lam env l t = match t with | Lrel(id ,i) -> get_rel env id i | Lvar id -> get_var env id | Lmeta(mv,ty) -> let tyn = fresh_lname Anonymous in let i = push_symbol (SymbMeta mv) in MLapp(MLprimitive Mk_meta, [|get_meta_code i; MLlocal tyn|]) | Levar(ev,ty) -> let tyn = fresh_lname Anonymous in let i = push_symbol (SymbEvar ev) in MLlet(tyn, ml_of_lam env l ty, MLapp(MLprimitive Mk_evar, [|get_evar_code i;MLlocal tyn|])) | Lprod(dom,codom) -> let dom = ml_of_lam env l dom in let codom = ml_of_lam env l codom in let n = get_prod_name codom in let i = push_symbol (SymbName n) in MLapp(MLprimitive Mk_prod, [|get_name_code i;dom;codom|]) | Llam(ids,body) -> let lnames,env = push_rels env ids in MLlam(lnames, ml_of_lam env l body) | Llet(id,def,body) -> let def = ml_of_lam env l def in let lname, env = push_rel env id in let body = ml_of_lam env l body in MLlet(lname,def,body) | Lapp(f,args) -> MLapp(ml_of_lam env l f, Array.map (ml_of_lam env l) args) | Lconst (prefix,c) -> let args = ml_of_instance env.env_univ (snd c) in mkMLapp (MLglobal(Gconstant (prefix,c))) args | Lproj (prefix,c) -> MLglobal(Gproj (prefix,c)) | Lprim _ -> let decl,cond,paux = extract_prim (ml_of_lam env l) t in compile_prim decl cond paux | Lcase (annot,p,a,bs) -> (* let predicate_uid fv_pred = compilation of p let rec case_uid fv a_uid = match a_uid with | Accu _ => mk_sw (predicate_uid fv_pred) (case_uid fv) a_uid | Ci argsi => compilation of branches compile case = case_uid fv (compilation of a) *) (* Compilation of the predicate *) (* Remark: if we do not want to compile the predicate we should a least compute the fv, then store the lambda representation of the predicate (not the mllambda) *) let env_p = empty_env env.env_univ () in let pn = fresh_gpred l in let mlp = ml_of_lam env_p l p in let mlp = generalize_fv env_p mlp in let (pfvn,pfvr) = !(env_p.env_named), !(env_p.env_urel) in let pn = push_global_let pn mlp in (* Compilation of the case *) let env_c = empty_env env.env_univ () in let a_uid = fresh_lname Anonymous in let la_uid = MLlocal a_uid in (* compilation of branches *) let ml_br (c,params, body) = let lnames, env_c = push_rels env_c params in (c, lnames, ml_of_lam env_c l body) in let bs = Array.map ml_br bs in let cn = fresh_gcase l in (* Compilation of accu branch *) let pred = MLapp(MLglobal pn, fv_args env_c pfvn pfvr) in let (fvn, fvr) = !(env_c.env_named), !(env_c.env_urel) in let cn_fv = mkMLapp (MLglobal cn) (fv_args env_c fvn fvr) in (* remark : the call to fv_args does not add free variables in env_c *) let i = push_symbol (SymbMatch annot) in let accu = MLapp(MLprimitive Mk_sw, [| get_match_code i; MLapp (MLprimitive Cast_accu, [|la_uid|]); pred; cn_fv |]) in (* let body = MLlam([|a_uid|], MLmatch(annot, la_uid, accu, bs)) in let case = generalize_fv env_c body in *) let cn = push_global_case cn (Array.append (fv_params env_c) [|a_uid|]) annot la_uid accu (merge_branches bs) in (* Final result *) let arg = ml_of_lam env l a in let force = if annot.asw_finite then arg else MLapp(MLprimitive Force_cofix, [|arg|]) in mkMLapp (MLapp (MLglobal cn, fv_args env fvn fvr)) [|force|] | Lif(t,bt,bf) -> MLif(ml_of_lam env l t, ml_of_lam env l bt, ml_of_lam env l bf) | Lfix ((rec_pos,start), (ids, tt, tb)) -> (* let type_f fvt = [| type fix |] let norm_f1 fv f1 .. fn params1 = body1 .. let norm_fn fv f1 .. fn paramsn = bodyn let norm fv f1 .. fn = [|norm_f1 fv f1 .. fn; ..; norm_fn fv f1 .. fn|] compile fix = let rec f1 params1 = if is_accu rec_pos.(1) then mk_fix (type_f fvt) (norm fv) params1 else norm_f1 fv f1 .. fn params1 and .. and fn paramsn = if is_accu rec_pos.(n) then mk_fix (type_f fvt) (norm fv) paramsn else norm_fn fv f1 .. fv paramsn in start *) (* Compilation of type *) let env_t = empty_env env.env_univ () in let ml_t = Array.map (ml_of_lam env_t l) tt in let params_t = fv_params env_t in let args_t = fv_args env !(env_t.env_named) !(env_t.env_urel) in let gft = fresh_gfixtype l in let gft = push_global_fixtype gft params_t ml_t in let mk_type = MLapp(MLglobal gft, args_t) in (* Compilation of norm_i *) let ndef = Array.length ids in let lf,env_n = push_rels (empty_env env.env_univ ()) ids in let t_params = Array.make ndef [||] in let t_norm_f = Array.make ndef (Gnorm (l,-1)) in let mk_let envi (id,def) t = MLlet (id,def,t) in let mk_lam_or_let (params,lets,env) (id,def) = let ln,env' = push_rel env id in match def with | None -> (ln::params,lets,env') | Some lam -> (params, (ln,ml_of_lam env l lam)::lets,env') in let ml_of_fix i body = let varsi, bodyi = decompose_Llam_Llet body in let paramsi,letsi,envi = Array.fold_left mk_lam_or_let ([],[],env_n) varsi in let paramsi,letsi = Array.of_list (List.rev paramsi), Array.of_list (List.rev letsi) in t_norm_f.(i) <- fresh_gnorm l; let bodyi = ml_of_lam envi l bodyi in t_params.(i) <- paramsi; let bodyi = Array.fold_right (mk_let envi) letsi bodyi in mkMLlam paramsi bodyi in let tnorm = Array.mapi ml_of_fix tb in let fvn,fvr = !(env_n.env_named), !(env_n.env_urel) in let fv_params = fv_params env_n in let fv_args' = Array.map (fun id -> MLlocal id) fv_params in let norm_params = Array.append fv_params lf in let t_norm_f = Array.mapi (fun i body -> push_global_let (t_norm_f.(i)) (mkMLlam norm_params body)) tnorm in let norm = fresh_gnormtbl l in let norm = push_global_norm norm fv_params (Array.map (fun g -> mkMLapp (MLglobal g) fv_args') t_norm_f) in (* Compilation of fix *) let fv_args = fv_args env fvn fvr in let lf, env = push_rels env ids in let lf_args = Array.map (fun id -> MLlocal id) lf in let mk_norm = MLapp(MLglobal norm, fv_args) in let mkrec i lname = let paramsi = t_params.(i) in let reci = MLlocal (paramsi.(rec_pos.(i))) in let pargsi = Array.map (fun id -> MLlocal id) paramsi in let body = MLif(MLapp(MLprimitive Is_accu,[|reci|]), mkMLapp (MLapp(MLprimitive (Mk_fix(rec_pos,i)), [|mk_type; mk_norm|])) pargsi, MLapp(MLglobal t_norm_f.(i), Array.concat [fv_args;lf_args;pargsi])) in (lname, paramsi, body) in MLletrec(Array.mapi mkrec lf, lf_args.(start)) | Lcofix (start, (ids, tt, tb)) -> (* Compilation of type *) let env_t = empty_env env.env_univ () in let ml_t = Array.map (ml_of_lam env_t l) tt in let params_t = fv_params env_t in let args_t = fv_args env !(env_t.env_named) !(env_t.env_urel) in let gft = fresh_gfixtype l in let gft = push_global_fixtype gft params_t ml_t in let mk_type = MLapp(MLglobal gft, args_t) in (* Compilation of norm_i *) let ndef = Array.length ids in let lf,env_n = push_rels (empty_env env.env_univ ()) ids in let t_params = Array.make ndef [||] in let t_norm_f = Array.make ndef (Gnorm (l,-1)) in let ml_of_fix i body = let idsi,bodyi = decompose_Llam body in let paramsi, envi = push_rels env_n idsi in t_norm_f.(i) <- fresh_gnorm l; let bodyi = ml_of_lam envi l bodyi in t_params.(i) <- paramsi; mkMLlam paramsi bodyi in let tnorm = Array.mapi ml_of_fix tb in let fvn,fvr = !(env_n.env_named), !(env_n.env_urel) in let fv_params = fv_params env_n in let fv_args' = Array.map (fun id -> MLlocal id) fv_params in let norm_params = Array.append fv_params lf in let t_norm_f = Array.mapi (fun i body -> push_global_let (t_norm_f.(i)) (mkMLlam norm_params body)) tnorm in let norm = fresh_gnormtbl l in let norm = push_global_norm norm fv_params (Array.map (fun g -> mkMLapp (MLglobal g) fv_args') t_norm_f) in (* Compilation of fix *) let fv_args = fv_args env fvn fvr in let mk_norm = MLapp(MLglobal norm, fv_args) in let lnorm = fresh_lname Anonymous in let ltype = fresh_lname Anonymous in let lf, env = push_rels env ids in let lf_args = Array.map (fun id -> MLlocal id) lf in let upd i lname cont = let paramsi = t_params.(i) in let pargsi = Array.map (fun id -> MLlocal id) paramsi in let uniti = fresh_lname Anonymous in let body = MLlam(Array.append paramsi [|uniti|], MLapp(MLglobal t_norm_f.(i), Array.concat [fv_args;lf_args;pargsi])) in MLsequence(MLapp(MLprimitive Upd_cofix, [|lf_args.(i);body|]), cont) in let upd = Array.fold_right_i upd lf lf_args.(start) in let mk_let i lname cont = MLlet(lname, MLapp(MLprimitive(Mk_cofix i),[| MLlocal ltype; MLlocal lnorm|]), cont) in let init = Array.fold_right_i mk_let lf upd in MLlet(lnorm, mk_norm, MLlet(ltype, mk_type, init)) (* let mkrec i lname = let paramsi = t_params.(i) in let pargsi = Array.map (fun id -> MLlocal id) paramsi in let uniti = fresh_lname Anonymous in let body = MLapp( MLprimitive(Mk_cofix i), [|mk_type;mk_norm; MLlam([|uniti|], MLapp(MLglobal t_norm_f.(i), Array.concat [fv_args;lf_args;pargsi]))|]) in (lname, paramsi, body) in MLletrec(Array.mapi mkrec lf, lf_args.(start)) *) | Lmakeblock (prefix,(cn,u),_,args) -> let args = Array.map (ml_of_lam env l) args in MLconstruct(prefix,cn,args) | Lconstruct (prefix, (cn,u)) -> let uargs = ml_of_instance env.env_univ u in mkMLapp (MLglobal (Gconstruct (prefix, (cn,u)))) uargs | Luint v -> (match v with | UintVal i -> MLapp(MLprimitive Mk_uint, [|MLuint i|]) | UintDigits (prefix,cn,ds) -> let c = MLglobal (Gconstruct (prefix, (cn, Univ.Instance.empty))) in let ds = Array.map (ml_of_lam env l) ds in let i31 = MLapp (MLprimitive Mk_I31_accu, [|c|]) in MLapp(i31, ds) | UintDecomp (prefix,cn,t) -> let c = MLglobal (Gconstruct (prefix, (cn, Univ.Instance.empty))) in let t = ml_of_lam env l t in MLapp (MLprimitive Decomp_uint, [|c;t|])) | Lval v -> let i = push_symbol (SymbValue v) in get_value_code i | Lsort s -> let i = push_symbol (SymbSort s) in let uarg = match env.env_univ with | None -> MLarray [||] | Some u -> MLlocal u in let uarg = MLapp(MLprimitive MLmagic, [|uarg|]) in MLapp(MLprimitive Mk_sort, [|get_sort_code i; uarg|]) | Lind (prefix, pind) -> let uargs = ml_of_instance env.env_univ (snd pind) in mkMLapp (MLglobal (Gind (prefix, pind))) uargs | Llazy -> MLglobal (Ginternal "lazy") | Lforce -> MLglobal (Ginternal "Lazy.force") let mllambda_of_lambda univ auxdefs l t = let env = empty_env univ () in global_stack := auxdefs; let ml = ml_of_lam env l t in let fv_rel = !(env.env_urel) in let fv_named = !(env.env_named) in (* build the free variables *) let get_lname (_,t) = match t with | MLlocal x -> x | _ -> assert false in let params = List.append (List.map get_lname fv_rel) (List.map get_lname fv_named) in if List.is_empty params then (!global_stack, ([],[]), ml) (* final result : global list, fv, ml *) else (!global_stack, (fv_named, fv_rel), mkMLlam (Array.of_list params) ml) (** Code optimization **) (** Optimization of match and fix *) let can_subst l = match l with | MLlocal _ | MLint _ | MLuint _ | MLglobal _ -> true | _ -> false let subst s l = if LNmap.is_empty s then l else let rec aux l = match l with | MLlocal id -> (try LNmap.find id s with Not_found -> l) | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ -> l | MLlam(params,body) -> MLlam(params, aux body) | MLletrec(defs,body) -> let arec (f,params,body) = (f,params,aux body) in MLletrec(Array.map arec defs, aux body) | MLlet(id,def,body) -> MLlet(id,aux def, aux body) | MLapp(f,args) -> MLapp(aux f, Array.map aux args) | MLif(t,b1,b2) -> MLif(aux t, aux b1, aux b2) | MLmatch(annot,a,accu,bs) -> let auxb (cargs,body) = (cargs,aux body) in MLmatch(annot,a,aux accu, Array.map auxb bs) | MLconstruct(prefix,c,args) -> MLconstruct(prefix,c,Array.map aux args) | MLsetref(s,l1) -> MLsetref(s,aux l1) | MLsequence(l1,l2) -> MLsequence(aux l1, aux l2) | MLarray arr -> MLarray (Array.map aux arr) in aux l let add_subst id v s = match v with | MLlocal id' when Int.equal id.luid id'.luid -> s | _ -> LNmap.add id v s let subst_norm params args s = let len = Array.length params in assert (Int.equal (Array.length args) len && Array.for_all can_subst args); let s = ref s in for i = 0 to len - 1 do s := add_subst params.(i) args.(i) !s done; !s let subst_case params args s = let len = Array.length params in assert (len > 0 && Int.equal (Array.length args) len && let r = ref true and i = ref 0 in (* we test all arguments excepted the last *) while !i < len - 1 && !r do r := can_subst args.(!i); incr i done; !r); let s = ref s in for i = 0 to len - 2 do s := add_subst params.(i) args.(i) !s done; !s, params.(len-1), args.(len-1) let empty_gdef = Int.Map.empty, Int.Map.empty let get_norm (gnorm, _) i = Int.Map.find i gnorm let get_case (_, gcase) i = Int.Map.find i gcase let all_lam n bs = let f (_, l) = match l with | MLlam(params, _) -> Int.equal (Array.length params) n | _ -> false in Array.for_all f bs let commutative_cut annot a accu bs args = let mkb (c,b) = match b with | MLlam(params, body) -> (c, Array.fold_left2 (fun body x v -> MLlet(x,v,body)) body params args) | _ -> assert false in MLmatch(annot, a, mkMLapp accu args, Array.map mkb bs) let optimize gdef l = let rec optimize s l = match l with | MLlocal id -> (try LNmap.find id s with Not_found -> l) | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ -> l | MLlam(params,body) -> MLlam(params, optimize s body) | MLletrec(decls,body) -> let opt_rec (f,params,body) = (f,params,optimize s body ) in MLletrec(Array.map opt_rec decls, optimize s body) | MLlet(id,def,body) -> let def = optimize s def in if can_subst def then optimize (add_subst id def s) body else MLlet(id,def,optimize s body) | MLapp(f, args) -> let args = Array.map (optimize s) args in begin match f with | MLglobal (Gnorm (_,i)) -> (try let params,body = get_norm gdef i in let s = subst_norm params args s in optimize s body with Not_found -> MLapp(optimize s f, args)) | MLglobal (Gcase (_,i)) -> (try let params,body = get_case gdef i in let s, id, arg = subst_case params args s in if can_subst arg then optimize (add_subst id arg s) body else MLlet(id, arg, optimize s body) with Not_found -> MLapp(optimize s f, args)) | _ -> let f = optimize s f in match f with | MLmatch (annot,a,accu,bs) -> if all_lam (Array.length args) bs then commutative_cut annot a accu bs args else MLapp(f, args) | _ -> MLapp(f, args) end | MLif(t,b1,b2) -> (* This optimization is critical: it applies to all fixpoints that start by matching on their recursive argument *) let t = optimize s t in let b1 = optimize s b1 in let b2 = optimize s b2 in begin match t, b2 with | MLapp(MLprimitive Is_accu,[| l1 |]), MLmatch(annot, l2, _, bs) when eq_mllambda l1 l2 -> MLmatch(annot, l1, b1, bs) | _, _ -> MLif(t, b1, b2) end | MLmatch(annot,a,accu,bs) -> let opt_b (cargs,body) = (cargs,optimize s body) in MLmatch(annot, optimize s a, subst s accu, Array.map opt_b bs) | MLconstruct(prefix,c,args) -> MLconstruct(prefix,c,Array.map (optimize s) args) | MLsetref(r,l) -> MLsetref(r, optimize s l) | MLsequence(l1,l2) -> MLsequence(optimize s l1, optimize s l2) | MLarray arr -> MLarray (Array.map (optimize s) arr) in optimize LNmap.empty l let optimize_stk stk = let add_global gdef g = match g with | Glet (Gnorm (_,i), body) -> let (gnorm, gcase) = gdef in (Int.Map.add i (decompose_MLlam body) gnorm, gcase) | Gletcase(Gcase (_,i), params, annot,a,accu,bs) -> let (gnorm,gcase) = gdef in (gnorm, Int.Map.add i (params,MLmatch(annot,a,accu,bs)) gcase) | Gletcase _ -> assert false | _ -> gdef in let gdef = List.fold_left add_global empty_gdef stk in let optimize_global g = match g with | Glet(Gconstant (prefix, c), body) -> Glet(Gconstant (prefix, c), optimize gdef body) | _ -> g in List.map optimize_global stk (** Printing to ocaml **) (* Redefine a bunch of functions in module Names to generate names acceptable to OCaml. *) let string_of_id s = Unicode.ascii_of_ident (Id.to_string s) let string_of_label l = string_of_id (Label.to_id l) let string_of_dirpath = function | [] -> "_" | sl -> String.concat "_" (List.rev_map string_of_id sl) (* The first letter of the file name has to be a capital to be accepted by *) (* OCaml as a module identifier. *) let string_of_dirpath s = "N"^string_of_dirpath s let mod_uid_of_dirpath dir = string_of_dirpath (repr_dirpath dir) let link_info_of_dirpath dir = Linked (mod_uid_of_dirpath dir ^ ".") let string_of_name x = match x with | Anonymous -> "anonymous" (* assert false *) | Name id -> string_of_id id let string_of_label_def l = match l with | None -> "" | Some l -> string_of_label l (* Relativization of module paths *) let rec list_of_mp acc = function | MPdot (mp,l) -> list_of_mp (string_of_label l::acc) mp | MPfile dp -> let dp = repr_dirpath dp in string_of_dirpath dp :: acc | MPbound mbid -> ("X"^string_of_id (id_of_mbid mbid))::acc let list_of_mp mp = list_of_mp [] mp let string_of_kn kn = let (mp,dp,l) = repr_kn kn in let mp = list_of_mp mp in String.concat "_" mp ^ "_" ^ string_of_label l let string_of_con c = string_of_kn (user_con c) let string_of_mind mind = string_of_kn (user_mind mind) let string_of_gname g = match g with | Gind (prefix, ((mind,i), _)) -> Format.sprintf "%sindaccu_%s_%i" prefix (string_of_mind mind) i | Gconstruct (prefix, (((mind, i), j), _)) -> Format.sprintf "%sconstruct_%s_%i_%i" prefix (string_of_mind mind) i (j-1) | Gconstant (prefix, (c,_)) -> Format.sprintf "%sconst_%s" prefix (string_of_con c) | Gproj (prefix, c) -> Format.sprintf "%sproj_%s" prefix (string_of_con c) | Gcase (l,i) -> Format.sprintf "case_%s_%i" (string_of_label_def l) i | Gpred (l,i) -> Format.sprintf "pred_%s_%i" (string_of_label_def l) i | Gfixtype (l,i) -> Format.sprintf "fixtype_%s_%i" (string_of_label_def l) i | Gnorm (l,i) -> Format.sprintf "norm_%s_%i" (string_of_label_def l) i | Ginternal s -> Format.sprintf "%s" s | Gnormtbl (l,i) -> Format.sprintf "normtbl_%s_%i" (string_of_label_def l) i | Grel i -> Format.sprintf "rel_%i" i | Gnamed id -> Format.sprintf "named_%s" (string_of_id id) let pp_gname fmt g = Format.fprintf fmt "%s" (string_of_gname g) let pp_lname fmt ln = Format.fprintf fmt "x_%s_%i" (string_of_name ln.lname) ln.luid let pp_ldecls fmt ids = let len = Array.length ids in for i = 0 to len - 1 do Format.fprintf fmt " (%a : Nativevalues.t)" pp_lname ids.(i) done let string_of_construct prefix ((mind,i),j) = let id = Format.sprintf "Construct_%s_%i_%i" (string_of_mind mind) i (j-1) in prefix ^ id let pp_int fmt i = if i < 0 then Format.fprintf fmt "(%i)" i else Format.fprintf fmt "%i" i let pp_mllam fmt l = let rec pp_mllam fmt l = match l with | MLlocal ln -> Format.fprintf fmt "@[%a@]" pp_lname ln | MLglobal g -> Format.fprintf fmt "@[%a@]" pp_gname g | MLprimitive p -> Format.fprintf fmt "@[%a@]" pp_primitive p | MLlam(ids,body) -> Format.fprintf fmt "@[(fun%a@ ->@\n %a)@]" pp_ldecls ids pp_mllam body | MLletrec(defs, body) -> Format.fprintf fmt "@[%a@ in@\n%a@]" pp_letrec defs pp_mllam body | MLlet(id,def,body) -> Format.fprintf fmt "@[(let@ %a@ =@\n %a@ in@\n%a)@]" pp_lname id pp_mllam def pp_mllam body | MLapp(f, args) -> Format.fprintf fmt "@[%a@ %a@]" pp_mllam f (pp_args true) args | MLif(t,l1,l2) -> Format.fprintf fmt "@[(if %a then@\n %a@\nelse@\n %a)@]" pp_mllam t pp_mllam l1 pp_mllam l2 | MLmatch (annot, c, accu_br, br) -> let mind,i = annot.asw_ind in let prefix = annot.asw_prefix in let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in Format.fprintf fmt "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n %a@\n%aend@]" pp_mllam c accu pp_mllam accu_br (pp_branches prefix) br | MLconstruct(prefix,c,args) -> Format.fprintf fmt "@[(Obj.magic (%s%a) : Nativevalues.t)@]" (string_of_construct prefix c) pp_cargs args | MLint i -> pp_int fmt i | MLuint i -> Format.fprintf fmt "(Uint31.of_int %a)" pp_int (Uint31.to_int i) | MLsetref (s, body) -> Format.fprintf fmt "@[%s@ :=@\n %a@]" s pp_mllam body | MLsequence(l1,l2) -> Format.fprintf fmt "@[%a;@\n%a@]" pp_mllam l1 pp_mllam l2 | MLarray arr -> let len = Array.length arr in Format.fprintf fmt "@[[|"; if 0 < len then begin for i = 0 to len - 2 do Format.fprintf fmt "%a;" pp_mllam arr.(i) done; pp_mllam fmt arr.(len-1) end; Format.fprintf fmt "|]@]" and pp_letrec fmt defs = let len = Array.length defs in let pp_one_rec i (fn, argsn, body) = Format.fprintf fmt "%a%a =@\n %a" pp_lname fn pp_ldecls argsn pp_mllam body in Format.fprintf fmt "@[let rec "; pp_one_rec 0 defs.(0); for i = 1 to len - 1 do Format.fprintf fmt "@\nand "; pp_one_rec i defs.(i) done; and pp_blam fmt l = match l with | MLprimitive (Mk_prod | Mk_sort) (* FIXME: why this special case? *) | MLlam _ | MLletrec _ | MLlet _ | MLapp _ | MLif _ -> Format.fprintf fmt "(%a)" pp_mllam l | MLconstruct(_,_,args) when Array.length args > 0 -> Format.fprintf fmt "(%a)" pp_mllam l | _ -> pp_mllam fmt l and pp_args sep fmt args = let sep = if sep then " " else "," in let len = Array.length args in if len > 0 then begin Format.fprintf fmt "%a" pp_blam args.(0); for i = 1 to len - 1 do Format.fprintf fmt "%s%a" sep pp_blam args.(i) done end and pp_cargs fmt args = let len = Array.length args in match len with | 0 -> () | 1 -> Format.fprintf fmt " %a" pp_blam args.(0) | _ -> Format.fprintf fmt "(%a)" (pp_args false) args and pp_cparam fmt param = match param with | Some l -> pp_mllam fmt (MLlocal l) | None -> Format.fprintf fmt "_" and pp_cparams fmt params = let len = Array.length params in match len with | 0 -> () | 1 -> Format.fprintf fmt " %a" pp_cparam params.(0) | _ -> let aux fmt params = Format.fprintf fmt "%a" pp_cparam params.(0); for i = 1 to len - 1 do Format.fprintf fmt ",%a" pp_cparam params.(i) done in Format.fprintf fmt "(%a)" aux params and pp_branches prefix fmt bs = let pp_branch (cargs,body) = let pp_c fmt (cn,args) = Format.fprintf fmt "| %s%a " (string_of_construct prefix cn) pp_cparams args in let rec pp_cargs fmt cargs = match cargs with | [] -> () | cargs::cargs' -> Format.fprintf fmt "%a%a" pp_c cargs pp_cargs cargs' in Format.fprintf fmt "%a ->@\n %a@\n" pp_cargs cargs pp_mllam body in Array.iter pp_branch bs and pp_primitive fmt = function | Mk_prod -> Format.fprintf fmt "mk_prod_accu" | Mk_sort -> Format.fprintf fmt "mk_sort_accu" | Mk_ind -> Format.fprintf fmt "mk_ind_accu" | Mk_const -> Format.fprintf fmt "mk_constant_accu" | Mk_sw -> Format.fprintf fmt "mk_sw_accu" | Mk_fix(rec_pos,start) -> let pp_rec_pos fmt rec_pos = Format.fprintf fmt "@[[| %i" rec_pos.(0); for i = 1 to Array.length rec_pos - 1 do Format.fprintf fmt "; %i" rec_pos.(i) done; Format.fprintf fmt " |]@]" in Format.fprintf fmt "mk_fix_accu %a %i" pp_rec_pos rec_pos start | Mk_cofix(start) -> Format.fprintf fmt "mk_cofix_accu %i" start | Mk_rel i -> Format.fprintf fmt "mk_rel_accu %i" i | Mk_var id -> Format.fprintf fmt "mk_var_accu (Names.id_of_string \"%s\")" (string_of_id id) | Mk_proj -> Format.fprintf fmt "mk_proj_accu" | Is_accu -> Format.fprintf fmt "is_accu" | Is_int -> Format.fprintf fmt "is_int" | Cast_accu -> Format.fprintf fmt "cast_accu" | Upd_cofix -> Format.fprintf fmt "upd_cofix" | Force_cofix -> Format.fprintf fmt "force_cofix" | Mk_uint -> Format.fprintf fmt "mk_uint" | Mk_int -> Format.fprintf fmt "mk_int" | Mk_bool -> Format.fprintf fmt "mk_bool" | Val_to_int -> Format.fprintf fmt "val_to_int" | Mk_I31_accu -> Format.fprintf fmt "mk_I31_accu" | Decomp_uint -> Format.fprintf fmt "decomp_uint" | Mk_meta -> Format.fprintf fmt "mk_meta_accu" | Mk_evar -> Format.fprintf fmt "mk_evar_accu" | MLand -> Format.fprintf fmt "(&&)" | MLle -> Format.fprintf fmt "(<=)" | MLlt -> Format.fprintf fmt "(<)" | MLinteq -> Format.fprintf fmt "(==)" | MLlsl -> Format.fprintf fmt "(lsl)" | MLlsr -> Format.fprintf fmt "(lsr)" | MLland -> Format.fprintf fmt "(land)" | MLlor -> Format.fprintf fmt "(lor)" | MLlxor -> Format.fprintf fmt "(lxor)" | MLadd -> Format.fprintf fmt "(+)" | MLsub -> Format.fprintf fmt "(-)" | MLmul -> Format.fprintf fmt "( * )" | MLmagic -> Format.fprintf fmt "Obj.magic" | MLarrayget -> Format.fprintf fmt "Array.get" | Mk_empty_instance -> Format.fprintf fmt "Univ.Instance.empty" | Coq_primitive (op,None) -> Format.fprintf fmt "no_check_%s" (Primitives.to_string op) | Coq_primitive (op, Some (prefix,kn)) -> let u = Univ.Instance.empty in Format.fprintf fmt "%s %a" (Primitives.to_string op) pp_mllam (MLglobal (Gconstant (prefix,(kn,u)))) in Format.fprintf fmt "@[%a@]" pp_mllam l let pp_array fmt t = let len = Array.length t in Format.fprintf fmt "@[[|"; for i = 0 to len - 2 do Format.fprintf fmt "%a; " pp_mllam t.(i) done; if len > 0 then Format.fprintf fmt "%a" pp_mllam t.(len - 1); Format.fprintf fmt "|]@]" let pp_global fmt g = match g with | Glet (gn, c) -> let ids, c = decompose_MLlam c in Format.fprintf fmt "@[let %a%a =@\n %a@]@\n@." pp_gname gn pp_ldecls ids pp_mllam c | Gopen s -> Format.fprintf fmt "@[open %s@]@." s | Gtype ((mind, i), lar) -> let l = string_of_mind mind in let rec aux s ar = if Int.equal ar 0 then s else aux (s^" * Nativevalues.t") (ar-1) in let pp_const_sig i fmt j ar = let sig_str = if ar > 0 then aux "of Nativevalues.t" (ar-1) else "" in Format.fprintf fmt " | Construct_%s_%i_%i %s@\n" l i j sig_str in let pp_const_sigs i fmt lar = Format.fprintf fmt " | Accu_%s_%i of Nativevalues.t@\n" l i; Array.iteri (pp_const_sig i fmt) lar in Format.fprintf fmt "@[type ind_%s_%i =@\n%a@]@\n@." l i (pp_const_sigs i) lar | Gtblfixtype (g, params, t) -> Format.fprintf fmt "@[let %a %a =@\n %a@]@\n@." pp_gname g pp_ldecls params pp_array t | Gtblnorm (g, params, t) -> Format.fprintf fmt "@[let %a %a =@\n %a@]@\n@." pp_gname g pp_ldecls params pp_array t | Gletcase(gn,params,annot,a,accu,bs) -> Format.fprintf fmt "@[(* Hash = %i *)@\nlet rec %a %a =@\n %a@]@\n@." (hash_global g) pp_gname gn pp_ldecls params pp_mllam (MLmatch(annot,a,accu,bs)) | Gcomment s -> Format.fprintf fmt "@[(* %s *)@]@." s (** Compilation of elements in environment **) let rec compile_with_fv env sigma univ auxdefs l t = let (auxdefs,(fv_named,fv_rel),ml) = mllambda_of_lambda univ auxdefs l t in if List.is_empty fv_named && List.is_empty fv_rel then (auxdefs,ml) else apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml = let get_rel_val (n,_) auxdefs = (* match !(lookup_rel_native_val n env) with | NVKnone -> *) compile_rel env sigma univ auxdefs n (* | NVKvalue (v,d) -> assert false *) in let get_named_val (id,_) auxdefs = (* match !(lookup_named_native_val id env) with | NVKnone -> *) compile_named env sigma univ auxdefs id (* | NVKvalue (v,d) -> assert false *) in let auxdefs = List.fold_right get_rel_val fv_rel auxdefs in let auxdefs = List.fold_right get_named_val fv_named auxdefs in let lvl = Context.Rel.length env.env_rel_context in let fv_rel = List.map (fun (n,_) -> MLglobal (Grel (lvl-n))) fv_rel in let fv_named = List.map (fun (id,_) -> MLglobal (Gnamed id)) fv_named in let aux_name = fresh_lname Anonymous in auxdefs, MLlet(aux_name, ml, mkMLapp (MLlocal aux_name) (Array.of_list (fv_rel@fv_named))) and compile_rel env sigma univ auxdefs n = let open Context.Rel in let n = length env.env_rel_context - n in let open Declaration in match lookup n env.env_rel_context with | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in Glet(Grel n, code)::auxdefs | LocalAssum _ -> Glet(Grel n, MLprimitive (Mk_rel n))::auxdefs and compile_named env sigma univ auxdefs id = let open Context.Named.Declaration in match lookup_named id env with | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in Glet(Gnamed id, code)::auxdefs | LocalAssum _ -> Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs let compile_constant env sigma prefix ~interactive con cb = match cb.const_proj with | None -> let u = if cb.const_polymorphic then Univ.UContext.instance cb.const_universes else Univ.Instance.empty in begin match cb.const_body with | Def t -> let t = Mod_subst.force_constr t in let code = lambda_of_constr env sigma t in if !Flags.debug then Feedback.msg_debug (Pp.str "Generated lambda code"); let is_lazy = is_lazy prefix t in let code = if is_lazy then mk_lazy code else code in let name = if interactive then LinkedInteractive prefix else Linked prefix in let l = con_label con in let auxdefs,code = if Univ.Instance.is_empty u then compile_with_fv env sigma None [] (Some l) code else let univ = fresh_univ () in let (auxdefs,code) = compile_with_fv env sigma (Some univ) [] (Some l) code in (auxdefs,mkMLlam [|univ|] code) in if !Flags.debug then Feedback.msg_debug (Pp.str "Generated mllambda code"); let code = optimize_stk (Glet(Gconstant ("",(con,u)),code)::auxdefs) in if !Flags.debug then Feedback.msg_debug (Pp.str "Optimized mllambda code"); code, name | _ -> let i = push_symbol (SymbConst con) in let args = if Univ.Instance.is_empty u then [|get_const_code i; MLarray [||]|] else [|get_const_code i|] in (* let t = mkMLlam [|univ|] (mkMLapp (MLprimitive Mk_const) *) [Glet(Gconstant ("",(con,u)), mkMLapp (MLprimitive Mk_const) args)], if interactive then LinkedInteractive prefix else Linked prefix end | Some pb -> let u = Univ.Instance.empty in let mind = pb.proj_ind in let ind = (mind,0) in let mib = lookup_mind mind env in let oib = mib.mind_packets.(0) in let tbl = oib.mind_reloc_tbl in (* Building info *) let prefix = get_mind_prefix env mind in let ci = { ci_ind = ind; ci_npar = mib.mind_nparams; ci_cstr_nargs = [|0|]; ci_cstr_ndecls = [||] (*FIXME*); ci_pp_info = { ind_tags = []; cstr_tags = [||] (*FIXME*); style = RegularStyle } } in let asw = { asw_ind = ind; asw_prefix = prefix; asw_ci = ci; asw_reloc = tbl; asw_finite = true } in let c_uid = fresh_lname Anonymous in let _, arity = tbl.(0) in let ci_uid = fresh_lname Anonymous in let cargs = Array.init arity (fun i -> if Int.equal i pb.proj_arg then Some ci_uid else None) in let i = push_symbol (SymbConst con) in let accu = MLapp (MLprimitive Cast_accu, [|MLlocal c_uid|]) in let accu_br = MLapp (MLprimitive Mk_proj, [|get_const_code i;accu|]) in let code = MLmatch(asw,MLlocal c_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in let gn = Gproj ("",con) in let fargs = Array.init (pb.proj_npars + 1) (fun _ -> fresh_lname Anonymous) in let arg = fargs.(pb.proj_npars) in Glet(Gconstant ("",(con,u)), mkMLlam fargs (MLapp (MLglobal gn, [|MLlocal arg|]))):: [Glet(gn, mkMLlam [|c_uid|] code)], Linked prefix module StringOrd = struct type t = string let compare = String.compare end module StringSet = Set.Make(StringOrd) let loaded_native_files = ref StringSet.empty let is_loaded_native_file s = StringSet.mem s !loaded_native_files let register_native_file s = loaded_native_files := StringSet.add s !loaded_native_files let is_code_loaded ~interactive name = match !name with | NotLinked -> false | LinkedInteractive s -> if (interactive && is_loaded_native_file s) then true else (name := NotLinked; false) | Linked s -> if is_loaded_native_file s then true else (name := NotLinked; false) let param_name = Name (id_of_string "params") let arg_name = Name (id_of_string "arg") let compile_mind prefix ~interactive mb mind stack = let u = Declareops.inductive_instance mb in let f i stack ob = let gtype = Gtype((mind, i), Array.map snd ob.mind_reloc_tbl) in let j = push_symbol (SymbInd (mind,i)) in let name = Gind ("", ((mind, i), u)) in let accu = let args = if Univ.Instance.is_empty u then [|get_ind_code j; MLarray [||]|] else [|get_ind_code j|] in Glet(name, MLapp (MLprimitive Mk_ind, args)) in let nparams = mb.mind_nparams in let params = Array.init nparams (fun i -> {lname = param_name; luid = i}) in let add_construct j acc (_,arity) = let args = Array.init arity (fun k -> {lname = arg_name; luid = k}) in let c = (mind,i), (j+1) in Glet(Gconstruct ("",(c,u)), mkMLlam (Array.append params args) (MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc in Array.fold_left_i add_construct (gtype::accu::stack) ob.mind_reloc_tbl in Array.fold_left_i f stack mb.mind_packets type code_location_update = link_info ref * link_info type code_location_updates = code_location_update Mindmap_env.t * code_location_update Cmap_env.t type linkable_code = global list * code_location_updates let empty_updates = Mindmap_env.empty, Cmap_env.empty let compile_mind_deps env prefix ~interactive (comp_stack, (mind_updates, const_updates) as init) mind = let mib,nameref = lookup_mind_key mind env in if is_code_loaded ~interactive nameref || Mindmap_env.mem mind mind_updates then init else let comp_stack = compile_mind prefix ~interactive mib mind comp_stack in let name = if interactive then LinkedInteractive prefix else Linked prefix in let upd = (nameref, name) in let mind_updates = Mindmap_env.add mind upd mind_updates in (comp_stack, (mind_updates, const_updates)) (* This function compiles all necessary dependencies of t, and generates code in reverse order, as well as linking information updates *) let rec compile_deps env sigma prefix ~interactive init t = match kind_of_term t with | Ind ((mind,_),u) -> compile_mind_deps env prefix ~interactive init mind | Const c -> let c,u = get_alias env c in let cb,(nameref,_) = lookup_constant_key c env in let (_, (_, const_updates)) = init in if is_code_loaded ~interactive nameref || (Cmap_env.mem c const_updates) then init else let comp_stack, (mind_updates, const_updates) = match cb.const_proj, cb.const_body with | None, Def t -> compile_deps env sigma prefix ~interactive init (Mod_subst.force_constr t) | Some pb, _ -> let mind = pb.proj_ind in compile_mind_deps env prefix ~interactive init mind | _ -> init in let code, name = compile_constant env sigma prefix ~interactive c cb in let comp_stack = code@comp_stack in let const_updates = Cmap_env.add c (nameref, name) const_updates in comp_stack, (mind_updates, const_updates) | Construct (((mind,_),_),u) -> compile_mind_deps env prefix ~interactive init mind | Proj (p,c) -> let term = mkApp (mkConst (Projection.constant p), [|c|]) in compile_deps env sigma prefix ~interactive init term | Case (ci, p, c, ac) -> let mind = fst ci.ci_ind in let init = compile_mind_deps env prefix ~interactive init mind in fold_constr (compile_deps env sigma prefix ~interactive) init t | _ -> fold_constr (compile_deps env sigma prefix ~interactive) init t let compile_constant_field env prefix con acc cb = let (gl, _) = compile_constant ~interactive:false env empty_evars prefix con cb in gl@acc let compile_mind_field prefix mp l acc mb = let mind = MutInd.make2 mp l in compile_mind prefix ~interactive:false mb mind acc let mk_open s = Gopen s let mk_internal_let s code = Glet(Ginternal s, code) (* ML Code for conversion function *) let mk_conv_code env sigma prefix t1 t2 = clear_symbols (); clear_global_tbl (); let gl, (mind_updates, const_updates) = let init = ([], empty_updates) in compile_deps env sigma prefix ~interactive:true init t1 in let gl, (mind_updates, const_updates) = let init = (gl, (mind_updates, const_updates)) in compile_deps env sigma prefix ~interactive:true init t2 in let code1 = lambda_of_constr env sigma t1 in let code2 = lambda_of_constr env sigma t2 in let (gl,code1) = compile_with_fv env sigma None gl None code1 in let (gl,code2) = compile_with_fv env sigma None gl None code2 in let t1 = mk_internal_let "t1" code1 in let t2 = mk_internal_let "t2" code2 in let g1 = MLglobal (Ginternal "t1") in let g2 = MLglobal (Ginternal "t2") in let setref1 = Glet(Ginternal "_", MLsetref("rt1",g1)) in let setref2 = Glet(Ginternal "_", MLsetref("rt2",g2)) in let gl = List.rev (setref2 :: setref1 :: t2 :: t1 :: gl) in let header = Glet(Ginternal "symbols_tbl", MLapp (MLglobal (Ginternal "get_symbols"), [|MLglobal (Ginternal "()")|])) in header::gl, (mind_updates, const_updates) let mk_norm_code env sigma prefix t = clear_symbols (); clear_global_tbl (); let gl, (mind_updates, const_updates) = let init = ([], empty_updates) in compile_deps env sigma prefix ~interactive:true init t in let code = lambda_of_constr env sigma t in let (gl,code) = compile_with_fv env sigma None gl None code in let t1 = mk_internal_let "t1" code in let g1 = MLglobal (Ginternal "t1") in let setref = Glet(Ginternal "_", MLsetref("rt1",g1)) in let gl = List.rev (setref :: t1 :: gl) in let header = Glet(Ginternal "symbols_tbl", MLapp (MLglobal (Ginternal "get_symbols"), [|MLglobal (Ginternal "()")|])) in header::gl, (mind_updates, const_updates) let mk_library_header dir = let libname = Format.sprintf "(str_decode \"%s\")" (str_encode dir) in [Glet(Ginternal "symbols_tbl", MLapp (MLglobal (Ginternal "get_library_native_symbols"), [|MLglobal (Ginternal libname)|]))] let update_location (r,v) = r := v let update_locations (ind_updates,const_updates) = Mindmap_env.iter (fun _ -> update_location) ind_updates; Cmap_env.iter (fun _ -> update_location) const_updates let add_header_comment mlcode s = Gcomment s :: mlcode (* vim: set filetype=ocaml foldmethod=marker: *) coq-8.6/kernel/sorts.mli0000644000175000017500000000225613022274260014621 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> bool val compare : t -> t -> int val hash : t -> int val is_set : t -> bool val is_prop : t -> bool val is_small : t -> bool val family : t -> family val hcons : t -> t val family_equal : family -> family -> bool module List : sig val mem : family -> family list -> bool val intersect : family list -> family list -> family list end val univ_of_sort : t -> Univ.universe val sort_of_univ : Univ.universe -> t coq-8.6/kernel/fast_typeops.ml0000644000175000017500000003431213022274260016014 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* try conv_leq false env t1 t2 with NotConvertible -> raise (NotConvertibleVect i)) () v1 v2 let check_constraints cst env = if Environ.check_constraints cst env then () else error_unsatisfied_constraints env cst (* This should be a type (a priori without intention to be an assumption) *) let type_judgment env c t = match kind_of_term(whd_all env t) with | Sort s -> {utj_val = c; utj_type = s } | _ -> error_not_type env (make_judge c t) let check_type env c t = match kind_of_term(whd_all env t) with | Sort s -> s | _ -> error_not_type env (make_judge c t) (* This should be a type intended to be assumed. The error message is *) (* not as useful as for [type_judgment]. *) let assumption_of_judgment env t ty = try let _ = check_type env t ty in t with TypeError _ -> error_assumption env (make_judge t ty) (************************************************) (* Incremental typing rules: builds a typing judgment given the *) (* judgments for the subterms. *) (*s Type of sorts *) (* Prop and Set *) let judge_of_prop = mkSort type1_sort let judge_of_prop_contents _ = judge_of_prop (* Type of Type(i). *) let judge_of_type u = let uu = Universe.super u in mkType uu (*s Type of a de Bruijn index. *) let judge_of_relative env n = try let open Context.Rel.Declaration in env |> lookup_rel n |> get_type |> lift n with Not_found -> error_unbound_rel env n (* Type of variables *) let judge_of_variable env id = try named_type id env with Not_found -> error_unbound_var env id (* Management of context of variables. *) (* Checks if a context of variables can be instantiated by the variables of the current env *) (* TODO: check order? *) let check_hyps_inclusion env f c sign = Context.Named.fold_outside (fun decl () -> let open Context.Named.Declaration in let id = get_id decl in let ty1 = get_type decl in try let ty2 = named_type id env in if not (eq_constr ty2 ty1) then raise Exit with Not_found | Exit -> error_reference_variables env id (f c)) sign ~init:() (* Instantiation of terms on real arguments. *) (* Make a type polymorphic if an arity *) (* Type of constants *) let type_of_constant_knowing_parameters_arity env t paramtyps = match t with | RegularArity t -> t | TemplateArity (sign,ar) -> let ctx = List.rev sign in let ctx,s = instantiate_universes env ctx ar paramtyps in mkArity (List.rev ctx,s) let type_of_constant_knowing_parameters env cst paramtyps = let ty, cu = constant_type env cst in type_of_constant_knowing_parameters_arity env ty paramtyps, cu let judge_of_constant_knowing_parameters env (kn,u as cst) args = let cb = lookup_constant kn env in let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in let ty, cu = type_of_constant_knowing_parameters env cst args in let () = check_constraints cu env in ty let judge_of_constant env cst = judge_of_constant_knowing_parameters env cst [||] (* Type of a lambda-abstraction. *) (* [judge_of_abstraction env name var j] implements the rule env, name:typ |- j.uj_val:j.uj_type env, |- (name:typ)j.uj_type : s ----------------------------------------------------------------------- env |- [name:typ]j.uj_val : (name:typ)j.uj_type Since all products are defined in the Calculus of Inductive Constructions and no upper constraint exists on the sort $s$, we don't need to compute $s$ *) let judge_of_abstraction env name var ty = mkProd (name, var, ty) (* Type of an application. *) let make_judgev c t = Array.map2 make_judge c t let judge_of_apply env func funt argsv argstv = let len = Array.length argsv in let rec apply_rec i typ = if Int.equal i len then typ else (match kind_of_term (whd_all env typ) with | Prod (_,c1,c2) -> let arg = argsv.(i) and argt = argstv.(i) in (try let () = conv_leq false env argt c1 in apply_rec (i+1) (subst1 arg c2) with NotConvertible -> error_cant_apply_bad_type env (i+1,c1,argt) (make_judge func funt) (make_judgev argsv argstv)) | _ -> error_cant_apply_not_functional env (make_judge func funt) (make_judgev argsv argstv)) in apply_rec 0 funt (* Type of product *) let sort_of_product env domsort rangsort = match (domsort, rangsort) with (* Product rule (s,Prop,Prop) *) | (_, Prop Null) -> rangsort (* Product rule (Prop/Set,Set,Set) *) | (Prop _, Prop Pos) -> rangsort (* Product rule (Type,Set,?) *) | (Type u1, Prop Pos) -> if is_impredicative_set env then (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) rangsort else (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) Type (Universe.sup Universe.type0 u1) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Null, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) | (Type u1, Type u2) -> Type (Universe.sup u1 u2) (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule env |- typ1:s1 env, name:typ1 |- typ2 : s2 ------------------------------------------------------------------------- s' >= (s1,s2), env |- (name:typ)j.uj_val : s' where j.uj_type is convertible to a sort s2 *) let judge_of_product env name s1 s2 = let s = sort_of_product env s1 s2 in mkSort s (* Type of a type cast *) (* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule env |- c:typ1 env |- typ2:s env |- typ1 <= typ2 --------------------------------------------------------------------- env |- c:typ2 *) let judge_of_cast env c ct k expected_type = try match k with | VMcast -> vm_conv CUMUL env ct expected_type | DEFAULTcast -> default_conv ~l2r:false CUMUL env ct expected_type | REVERTcast -> default_conv ~l2r:true CUMUL env ct expected_type | NATIVEcast -> let sigma = Nativelambda.empty_evars in Nativeconv.native_conv CUMUL sigma env ct expected_type with NotConvertible -> error_actual_type env (make_judge c ct) expected_type (* Inductive types. *) (* The type is parametric over the uniform parameters whose conclusion is in Type; to enforce the internal constraints between the parameters and the instances of Type occurring in the type of the constructors, we use the level variables _statically_ assigned to the conclusions of the parameters as mediators: e.g. if a parameter has conclusion Type(alpha), static constraints of the form alpha<=v exist between alpha and the Type's occurring in the constructor types; when the parameters is finally instantiated by a term of conclusion Type(u), then the constraints u<=alpha is computed in the App case of execute; from this constraints, the expected dynamic constraints of the form u<=v are enforced *) let judge_of_inductive_knowing_parameters env (ind,u as indu) args = let (mib,mip) as spec = lookup_mind_specif env ind in check_hyps_inclusion env mkIndU indu mib.mind_hyps; let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters env (spec,u) args in check_constraints cst env; t let judge_of_inductive env (ind,u as indu) = let (mib,mip) = lookup_mind_specif env ind in check_hyps_inclusion env mkIndU indu mib.mind_hyps; let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in check_constraints cst env; t (* Constructors. *) let judge_of_constructor env (c,u as cu) = let _ = let ((kn,_),_) = c in let mib = lookup_mind kn env in check_hyps_inclusion env mkConstructU cu mib.mind_hyps in let specif = lookup_mind_specif env (inductive_of_constructor c) in let t,cst = constrained_type_of_constructor cu specif in let () = check_constraints cst env in t (* Case. *) let check_branch_types env (ind,u) c ct lft explft = try conv_leq_vecti env lft explft with NotConvertibleVect i -> error_ill_formed_branch env c ((ind,i+1),u) lft.(i) explft.(i) | Invalid_argument _ -> error_number_branches env (make_judge c ct) (Array.length explft) let judge_of_case env ci p pt c ct lf lft = let (pind, _ as indspec) = try find_rectype env ct with Not_found -> error_case_not_inductive env (make_judge c ct) in let _ = check_case_info env pind ci in let (bty,rslty) = type_case_branches env indspec (make_judge p pt) c in let () = check_branch_types env pind c ct lft bty in rslty let judge_of_projection env p c ct = let pb = lookup_projection p env in let (ind,u), args = try find_rectype env ct with Not_found -> error_case_not_inductive env (make_judge c ct) in assert(eq_mind pb.proj_ind (fst ind)); let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in substl (c :: List.rev args) ty (* Fixpoints. *) (* Checks the type of a general (co)fixpoint, i.e. without checking *) (* the specific guard condition. *) let type_fixpoint env lna lar vdef vdeft = let lt = Array.length vdeft in assert (Int.equal (Array.length lar) lt); try conv_leq_vecti env vdeft (Array.map (fun ty -> lift lt ty) lar) with NotConvertibleVect i -> error_ill_typed_rec_body env i lna (make_judgev vdef vdeft) lar (************************************************************************) (************************************************************************) (* The typing machine. *) (* ATTENTION : faudra faire le typage du contexte des Const, Ind et Constructsi un jour cela devient des constructions arbitraires et non plus des variables *) let rec execute env cstr = let open Context.Rel.Declaration in match kind_of_term cstr with (* Atomic terms *) | Sort (Prop c) -> judge_of_prop_contents c | Sort (Type u) -> judge_of_type u | Rel n -> judge_of_relative env n | Var id -> judge_of_variable env id | Const c -> judge_of_constant env c | Proj (p, c) -> let ct = execute env c in judge_of_projection env p c ct (* Lambda calculus operators *) | App (f,args) -> let argst = execute_array env args in let ft = match kind_of_term f with | Ind ind when Environ.template_polymorphic_pind ind env -> (* Template sort-polymorphism of inductive types *) let args = Array.map (fun t -> lazy t) argst in judge_of_inductive_knowing_parameters env ind args | Const cst when Environ.template_polymorphic_pconstant cst env -> (* Template sort-polymorphism of constants *) let args = Array.map (fun t -> lazy t) argst in judge_of_constant_knowing_parameters env cst args | _ -> (* Full or no sort-polymorphism *) execute env f in judge_of_apply env f ft args argst | Lambda (name,c1,c2) -> let _ = execute_is_type env c1 in let env1 = push_rel (LocalAssum (name,c1)) env in let c2t = execute env1 c2 in judge_of_abstraction env name c1 c2t | Prod (name,c1,c2) -> let vars = execute_is_type env c1 in let env1 = push_rel (LocalAssum (name,c1)) env in let vars' = execute_is_type env1 c2 in judge_of_product env name vars vars' | LetIn (name,c1,c2,c3) -> let c1t = execute env c1 in let _c2s = execute_is_type env c2 in let _ = judge_of_cast env c1 c1t DEFAULTcast c2 in let env1 = push_rel (LocalDef (name,c1,c2)) env in let c3t = execute env1 c3 in subst1 c1 c3t | Cast (c,k,t) -> let ct = execute env c in let _ts = execute_type env t in let _ = judge_of_cast env c ct k t in t (* Inductive types *) | Ind ind -> judge_of_inductive env ind | Construct c -> judge_of_constructor env c | Case (ci,p,c,lf) -> let ct = execute env c in let pt = execute env p in let lft = execute_array env lf in judge_of_case env ci p pt c ct lf lft | Fix ((vn,i as vni),recdef) -> let (fix_ty,recdef') = execute_recdef env recdef i in let fix = (vni,recdef') in check_fix env fix; fix_ty | CoFix (i,recdef) -> let (fix_ty,recdef') = execute_recdef env recdef i in let cofix = (i,recdef') in check_cofix env cofix; fix_ty (* Partial proofs: unsupported by the kernel *) | Meta _ -> anomaly (Pp.str "the kernel does not support metavariables") | Evar _ -> anomaly (Pp.str "the kernel does not support existential variables") and execute_is_type env constr = let t = execute env constr in check_type env constr t and execute_type env constr = let t = execute env constr in type_judgment env constr t and execute_recdef env (names,lar,vdef) i = let lart = execute_array env lar in let lara = Array.map2 (assumption_of_judgment env) lar lart in let env1 = push_rec_types (names,lara,vdef) env in let vdeft = execute_array env1 vdef in let () = type_fixpoint env1 names lara vdef vdeft in (lara.(i),(names,lara,vdef)) and execute_array env = Array.map (execute env) (* Derived functions *) let infer env constr = let t = execute env constr in make_judge constr t let infer = if Flags.profile then let infer_key = Profile.declare_profile "Fast_infer" in Profile.profile2 infer_key (fun b c -> infer b c) else (fun b c -> infer b c) let infer_type env constr = execute_type env constr let infer_v env cv = let jv = execute_array env cv in make_judgev cv jv coq-8.6/kernel/uint31.ml0000644000175000017500000000777513022274260014434 0ustar mdenesmdenes (* Invariant: For arch64 all extra bytes are set to 0 *) type t = int (* to be used only on 32 bits architectures *) let maxuint31 = Int32.of_string "0x7FFFFFFF" let uint_32 i = Int32.logand (Int32.of_int i) maxuint31 let select f32 f64 = if Sys.word_size = 64 then f64 else f32 (* conversion to an int *) let to_int i = i let of_int_32 i = i let of_int_64 i = i land 0x7FFFFFFF let of_int = select of_int_32 of_int_64 let of_uint i = i (* conversion of an uint31 to a string *) let to_string_32 i = Int32.to_string (uint_32 i) let to_string_64 = string_of_int let to_string = select to_string_32 to_string_64 let of_string s = let i32 = Int32.of_string s in if Int32.compare Int32.zero i32 <= 0 && Int32.compare i32 maxuint31 <= 0 then Int32.to_int i32 else raise (Failure "int_of_string") (* logical shift *) let l_sl x y = of_int (if 0 <= y && y < 31 then x lsl y else 0) let l_sr x y = if 0 <= y && y < 31 then x lsr y else 0 let l_and x y = x land y let l_or x y = x lor y let l_xor x y = x lxor y (* addition of int31 *) let add x y = of_int (x + y) (* subtraction *) let sub x y = of_int (x - y) (* multiplication *) let mul x y = of_int (x * y) (* exact multiplication *) let mulc_32 x y = let x = Int64.of_int32 (uint_32 x) in let y = Int64.of_int32 (uint_32 y) in let m = Int64.mul x y in let l = Int64.to_int m in let h = Int64.to_int (Int64.shift_right_logical m 31) in h,l let mulc_64 x y = let m = x * y in let l = of_int_64 m in let h = of_int_64 (m lsr 31) in h, l let mulc = select mulc_32 mulc_64 (* division *) let div_32 x y = if y = 0 then 0 else Int32.to_int (Int32.div (uint_32 x) (uint_32 y)) let div_64 x y = if y = 0 then 0 else x / y let div = select div_32 div_64 (* modulo *) let rem_32 x y = if y = 0 then 0 else Int32.to_int (Int32.rem (uint_32 x) (uint_32 y)) let rem_64 x y = if y = 0 then 0 else x mod y let rem = select rem_32 rem_64 (* division of two numbers by one *) let div21_32 xh xl y = if y = 0 then (0,0) else let x = Int64.logor (Int64.shift_left (Int64.of_int32 (uint_32 xh)) 31) (Int64.of_int32 (uint_32 xl)) in let y = Int64.of_int32 (uint_32 y) in let q = Int64.div x y in let r = Int64.rem x y in Int64.to_int q, Int64.to_int r let div21_64 xh xl y = if y = 0 then (0,0) else let x = (xh lsl 31) lor xl in let q = x / y in let r = x mod y in q, r let div21 = select div21_32 div21_64 (* comparison *) let lt_32 x y = (x lxor 0x40000000) < (y lxor 0x40000000) (* Do not remove the type information it is really important for efficiency *) let lt_64 (x:int) (y:int) = x < y let lt = select lt_32 lt_64 let le_32 x y = (x lxor 0x40000000) <= (y lxor 0x40000000) (* Do not remove the type information it is really important for efficiency *) let le_64 (x:int) (y:int) = x <= y let le = select le_32 le_64 let equal (x:int) (y:int) = x == y let cmp_32 x y = Int32.compare (uint_32 x) (uint_32 y) (* Do not remove the type information it is really important for efficiency *) let cmp_64 (x:int) (y:int) = compare x y let compare = select cmp_32 cmp_64 (* head tail *) let head0 x = let r = ref 0 in let x = ref x in if !x land 0x7FFF0000 = 0 then r := !r + 15 else x := !x lsr 15; if !x land 0xFF00 = 0 then (x := !x lsl 8; r := !r + 8); if !x land 0xF000 = 0 then (x := !x lsl 4; r := !r + 4); if !x land 0xC000 = 0 then (x := !x lsl 2; r := !r + 2); if !x land 0x8000 = 0 then (x := !x lsl 1; r := !r + 1); if !x land 0x8000 = 0 then ( r := !r + 1); !r;; let tail0 x = let r = ref 0 in let x = ref x in if !x land 0xFFFF = 0 then (x := !x lsr 16; r := !r + 16); if !x land 0xFF = 0 then (x := !x lsr 8; r := !r + 8); if !x land 0xF = 0 then (x := !x lsr 4; r := !r + 4); if !x land 0x3 = 0 then (x := !x lsr 2; r := !r + 2); if !x land 0x1 = 0 then ( r := !r + 1); !r let add_digit x d = (x lsl 1) lor d coq-8.6/kernel/reduction.mli0000644000175000017500000001122613022274260015440 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> constr val whd_all : env -> constr -> constr val whd_allnolet : env -> constr -> constr val whd_betaiota : env -> constr -> constr val nf_betaiota : env -> constr -> constr (*********************************************************************** s conversion functions *) exception NotConvertible exception NotConvertibleVect of int type 'a kernel_conversion_function = env -> 'a -> 'a -> unit type 'a extended_conversion_function = ?l2r:bool -> ?reds:Names.transparent_state -> env -> ?evars:((existential->constr option) * UGraph.t) -> 'a -> 'a -> unit type conv_pb = CONV | CUMUL type 'a universe_compare = { (* Might raise NotConvertible or UnivInconsistency *) compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a; compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; } type 'a universe_state = 'a * 'a universe_compare type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints val sort_cmp_universes : env -> conv_pb -> sorts -> sorts -> 'a * 'a universe_compare -> 'a * 'a universe_compare (* [flex] should be true for constants, false for inductive types and constructors. *) val convert_instances : flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a * 'a universe_compare -> 'a * 'a universe_compare (** These two never raise UnivInconsistency, inferred_universes just gathers the constraints. *) val checked_universes : UGraph.t universe_compare val inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare (** These two functions can only raise NotConvertible *) val conv : constr extended_conversion_function val conv_leq : types extended_conversion_function (** These conversion functions are used by module subtyping, which needs to infer universe constraints inside the kernel *) val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> ?ts:Names.transparent_state -> constr infer_conversion_function val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> ?ts:Names.transparent_state -> types infer_conversion_function (** Depending on the universe state functions, this might raise [UniverseInconsistency] in addition to [NotConvertible] (for better error messages). *) val generic_conv : conv_pb -> l2r:bool -> (existential->constr option) -> Names.transparent_state -> (constr,'a) generic_conversion_function (** option for conversion *) val set_vm_conv : (conv_pb -> types kernel_conversion_function) -> unit val vm_conv : conv_pb -> types kernel_conversion_function val default_conv : conv_pb -> ?l2r:bool -> types kernel_conversion_function val default_conv_leq : ?l2r:bool -> types kernel_conversion_function (************************************************************************) (** Builds an application node, reducing beta redexes it may produce. *) val beta_applist : constr -> constr list -> constr (** Builds an application node, reducing beta redexes it may produce. *) val beta_appvect : constr -> constr array -> constr (** Builds an application node, reducing beta redexe it may produce. *) val beta_app : constr -> constr -> constr (** Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *) val hnf_prod_applist : env -> types -> constr list -> types (** Compatibility alias for Term.lambda_appvect_assum *) val betazeta_appvect : int -> constr -> constr array -> constr (*********************************************************************** s Recognizing products and arities modulo reduction *) val dest_prod : env -> types -> Context.Rel.t * types val dest_prod_assum : env -> types -> Context.Rel.t * types val dest_lam_assum : env -> types -> Context.Rel.t * types exception NotArity val dest_arity : env -> types -> arity (* raises NotArity if not an arity *) val is_arity : env -> types -> bool val warn_bytecode_compiler_failed : ?loc:Loc.t -> unit -> unit coq-8.6/kernel/make-opcodes0000644000175000017500000000025213022274260015230 0ustar mdenesmdenes$1=="enum" {n=0; next; } {printf("(* THIS FILE IS GENERATED. DON'T EDIT. *)\n\n"); for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}} coq-8.6/kernel/vars.ml0000644000175000017500000002506713022274260014256 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* if m>n then raise LocalOccur | _ -> Constr.iter_with_binders succ closed_rec n c in try closed_rec n c; true with LocalOccur -> false (* [closed0 M] is true iff [M] is a (deBruijn) closed term *) let closed0 c = closedn 0 c (* (noccurn n M) returns true iff (Rel n) does NOT occur in term M *) let noccurn n term = let rec occur_rec n c = match Constr.kind c with | Constr.Rel m -> if Int.equal m n then raise LocalOccur | _ -> Constr.iter_with_binders succ occur_rec n c in try occur_rec n term; true with LocalOccur -> false (* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M for n <= p < n+m *) let noccur_between n m term = let rec occur_rec n c = match Constr.kind c with | Constr.Rel p -> if n<=p && p Constr.iter_with_binders succ occur_rec n c in try occur_rec n term; true with LocalOccur -> false (* Checking function for terms containing existential variables. The function [noccur_with_meta] considers the fact that each existential variable (as well as each isevar) in the term appears applied to its local context, which may contain the CoFix variables. These occurrences of CoFix variables are not considered *) let isMeta c = match Constr.kind c with | Constr.Meta _ -> true | _ -> false let noccur_with_meta n m term = let rec occur_rec n c = match Constr.kind c with | Constr.Rel p -> if n<=p && p (match Constr.kind f with | Constr.Cast (c,_,_) when isMeta c -> () | Constr.Meta _ -> () | _ -> Constr.iter_with_binders succ occur_rec n c) | Constr.Evar (_, _) -> () | _ -> Constr.iter_with_binders succ occur_rec n c in try (occur_rec n term; true) with LocalOccur -> false (*********************) (* Lifting *) (*********************) (* The generic lifting function *) let rec exliftn el c = match Constr.kind c with | Constr.Rel i -> Constr.mkRel(reloc_rel i el) | _ -> Constr.map_with_binders el_lift exliftn el c (* Lifting the binding depth across k bindings *) let liftn n k c = match el_liftn (pred k) (el_shft n el_id) with | ELID -> c | el -> exliftn el c let lift n = liftn n 1 (*********************) (* Substituting *) (*********************) (* (subst1 M c) substitutes M for Rel(1) in c we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel M1,...,Mn for respectively Rel(1),...,Rel(n) in c *) (* 1st : general case *) type info = Closed | Open | Unknown type 'a substituend = { mutable sinfo: info; sit: 'a } let lift_substituend depth s = match s.sinfo with | Closed -> s.sit | Open -> lift depth s.sit | Unknown -> let sit = s.sit in if closed0 sit then let () = s.sinfo <- Closed in sit else let () = s.sinfo <- Open in lift depth sit let make_substituend c = { sinfo=Unknown; sit=c } let substn_many lamv n c = let lv = Array.length lamv in if Int.equal lv 0 then c else let rec substrec depth c = match Constr.kind c with | Constr.Rel k -> if k<=depth then c else if k-depth <= lv then lift_substituend depth (Array.unsafe_get lamv (k-depth-1)) else Constr.mkRel (k-lv) | _ -> Constr.map_with_binders succ substrec depth c in substrec n c (* let substkey = Profile.declare_profile "substn_many";; let substn_many lamv n c = Profile.profile3 substkey substn_many lamv n c;; *) let make_subst = function | [] -> [||] | hd :: tl -> let len = List.length tl in let subst = Array.make (1 + len) (make_substituend hd) in let s = ref tl in for i = 1 to len do match !s with | [] -> assert false | x :: tl -> Array.unsafe_set subst i (make_substituend x); s := tl done; subst (* The type of substitutions, with term substituting most recent binder at the head *) type substl = Constr.t list let substnl laml n c = substn_many (make_subst laml) n c let substl laml c = substn_many (make_subst laml) 0 c let subst1 lam c = substn_many [|make_substituend lam|] 0 c let substnl_decl laml k r = map_constr (fun c -> substnl laml k c) r let substl_decl laml r = map_constr (fun c -> substnl laml 0 c) r let subst1_decl lam r = map_constr (fun c -> subst1 lam c) r (* Build a substitution from an instance, inserting missing let-ins *) let subst_of_rel_context_instance sign l = let rec aux subst sign l = match sign, l with | LocalAssum _ :: sign', a::args' -> aux (a::subst) sign' args' | LocalDef (_,c,_)::sign', args' -> aux (substl subst c :: subst) sign' args' | [], [] -> subst | _ -> CErrors.anomaly (Pp.str "Instance and signature do not match") in aux [] (List.rev sign) l let adjust_subst_to_rel_context sign l = List.rev (subst_of_rel_context_instance sign l) (* (thin_val sigma) removes identity substitutions from sigma *) let rec thin_val = function | [] -> [] | (id, c) :: tl -> match Constr.kind c with | Constr.Var v -> if Id.equal id v then thin_val tl else (id, make_substituend c) :: (thin_val tl) | _ -> (id, make_substituend c) :: (thin_val tl) let rec find_var id = function | [] -> raise Not_found | (idc, c) :: subst -> if Id.equal id idc then c else find_var id subst (* (replace_vars sigma M) applies substitution sigma to term M *) let replace_vars var_alist x = let var_alist = thin_val var_alist in match var_alist with | [] -> x | _ -> let rec substrec n c = match Constr.kind c with | Constr.Var x -> (try lift_substituend n (find_var x var_alist) with Not_found -> c) | _ -> Constr.map_with_binders succ substrec n c in substrec 0 x (* (subst_var str t) substitute (Var str) by (Rel 1) in t *) let subst_var str t = replace_vars [(str, Constr.mkRel 1)] t (* (subst_vars [id1;...;idn] t) substitute (Var idj) by (Rel j) in t *) let substn_vars p vars c = let _,subst = List.fold_left (fun (n,l) var -> ((n+1),(var,Constr.mkRel n)::l)) (p,[]) vars in replace_vars (List.rev subst) c let subst_vars subst c = substn_vars 1 subst c (** Universe substitutions *) open Constr let subst_univs_fn_puniverses fn = let f = Univ.Instance.subst_fn fn in fun ((c, u) as x) -> let u' = f u in if u' == u then x else (c, u') let subst_univs_fn_constr f c = let changed = ref false in let fu = Univ.subst_univs_universe f in let fi = Univ.Instance.subst_fn (Univ.level_subst_of f) in let rec aux t = match kind t with | Sort (Sorts.Type u) -> let u' = fu u in if u' == u then t else (changed := true; mkSort (Sorts.sort_of_univ u')) | Const (c, u) -> let u' = fi u in if u' == u then t else (changed := true; mkConstU (c, u')) | Ind (i, u) -> let u' = fi u in if u' == u then t else (changed := true; mkIndU (i, u')) | Construct (c, u) -> let u' = fi u in if u' == u then t else (changed := true; mkConstructU (c, u')) | _ -> map aux t in let c' = aux c in if !changed then c' else c let subst_univs_constr subst c = if Univ.is_empty_subst subst then c else let f = Univ.make_subst subst in subst_univs_fn_constr f c let subst_univs_constr = if Flags.profile then let subst_univs_constr_key = Profile.declare_profile "subst_univs_constr" in Profile.profile2 subst_univs_constr_key subst_univs_constr else subst_univs_constr let subst_univs_level_constr subst c = if Univ.is_empty_level_subst subst then c else let f = Univ.Instance.subst_fn (Univ.subst_univs_level_level subst) in let changed = ref false in let rec aux t = match kind t with | Const (c, u) -> if Univ.Instance.is_empty u then t else let u' = f u in if u' == u then t else (changed := true; mkConstU (c, u')) | Ind (i, u) -> if Univ.Instance.is_empty u then t else let u' = f u in if u' == u then t else (changed := true; mkIndU (i, u')) | Construct (c, u) -> if Univ.Instance.is_empty u then t else let u' = f u in if u' == u then t else (changed := true; mkConstructU (c, u')) | Sort (Sorts.Type u) -> let u' = Univ.subst_univs_level_universe subst u in if u' == u then t else (changed := true; mkSort (Sorts.sort_of_univ u')) | _ -> Constr.map aux t in let c' = aux c in if !changed then c' else c let subst_univs_level_context s = Context.Rel.map (subst_univs_level_constr s) let subst_instance_constr subst c = if Univ.Instance.is_empty subst then c else let f u = Univ.subst_instance_instance subst u in let changed = ref false in let rec aux t = match kind t with | Const (c, u) -> if Univ.Instance.is_empty u then t else let u' = f u in if u' == u then t else (changed := true; mkConstU (c, u')) | Ind (i, u) -> if Univ.Instance.is_empty u then t else let u' = f u in if u' == u then t else (changed := true; mkIndU (i, u')) | Construct (c, u) -> if Univ.Instance.is_empty u then t else let u' = f u in if u' == u then t else (changed := true; mkConstructU (c, u')) | Sort (Sorts.Type u) -> let u' = Univ.subst_instance_universe subst u in if u' == u then t else (changed := true; mkSort (Sorts.sort_of_univ u')) | _ -> Constr.map aux t in let c' = aux c in if !changed then c' else c (* let substkey = Profile.declare_profile "subst_instance_constr";; *) (* let subst_instance_constr inst c = Profile.profile2 substkey subst_instance_constr inst c;; *) let subst_instance_context s ctx = if Univ.Instance.is_empty s then ctx else Context.Rel.map (fun x -> subst_instance_constr s x) ctx type id_key = constant tableKey let eq_id_key x y = Names.eq_table_key Constant.equal x y coq-8.6/kernel/mod_subst.mli0000644000175000017500000001346313022274260015450 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* module_path -> delta_resolver -> delta_resolver val add_kn_delta_resolver : kernel_name -> kernel_name -> delta_resolver -> delta_resolver val add_inline_delta_resolver : kernel_name -> (int * constr option) -> delta_resolver -> delta_resolver val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver (** Effect of a [delta_resolver] on a module path, on a kernel name *) val mp_of_delta : delta_resolver -> module_path -> module_path val kn_of_delta : delta_resolver -> kernel_name -> kernel_name (** Build a constant whose canonical part is obtained via a resolver *) val constant_of_delta_kn : delta_resolver -> kernel_name -> constant (** Same, but a 2nd resolver is tried if the 1st one had no effect *) val constant_of_deltas_kn : delta_resolver -> delta_resolver -> kernel_name -> constant (** Same for inductive names *) val mind_of_delta_kn : delta_resolver -> kernel_name -> mutual_inductive val mind_of_deltas_kn : delta_resolver -> delta_resolver -> kernel_name -> mutual_inductive (** Extract the set of inlined constant in the resolver *) val inline_of_delta : int option -> delta_resolver -> (int * kernel_name) list (** Does a [delta_resolver] contains a [mp], a constant, an inductive ? *) val mp_in_delta : module_path -> delta_resolver -> bool val con_in_delta : constant -> delta_resolver -> bool val mind_in_delta : mutual_inductive -> delta_resolver -> bool (** {6 Substitution} *) type substitution val empty_subst : substitution val is_empty_subst : substitution -> bool (** add_* add [arg2/arg1]\{arg3\} to the substitution with no sequential composition. Most often this is not what you want. For sequential composition, try [join (map_mbid mp delta) subs] **) val add_mbid : MBId.t -> module_path -> delta_resolver -> substitution -> substitution val add_mp : module_path -> module_path -> delta_resolver -> substitution -> substitution (** map_* create a new substitution [arg2/arg1]\{arg3\} *) val map_mbid : MBId.t -> module_path -> delta_resolver -> substitution val map_mp : module_path -> module_path -> delta_resolver -> substitution (** sequential composition: [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)] *) val join : substitution -> substitution -> substitution (** Apply the substitution on the domain of the resolver *) val subst_dom_delta_resolver : substitution -> delta_resolver -> delta_resolver (** Apply the substitution on the codomain of the resolver *) val subst_codom_delta_resolver : substitution -> delta_resolver -> delta_resolver val subst_dom_codom_delta_resolver : substitution -> delta_resolver -> delta_resolver type 'a substituted val from_val : 'a -> 'a substituted val force : (substitution -> 'a -> 'a) -> 'a substituted -> 'a val subst_substituted : substitution -> 'a substituted -> 'a substituted (**/**) (* debugging *) val debug_string_of_subst : substitution -> string val debug_pr_subst : substitution -> Pp.std_ppcmds val debug_string_of_delta : delta_resolver -> string val debug_pr_delta : delta_resolver -> Pp.std_ppcmds (**/**) (** [subst_mp sub mp] guarantees that whenever the result of the substitution is structutally equal [mp], it is equal by pointers as well [==] *) val subst_mp : substitution -> module_path -> module_path val subst_mind : substitution -> mutual_inductive -> mutual_inductive val subst_ind : substitution -> inductive -> inductive val subst_pind : substitution -> pinductive -> pinductive val subst_kn : substitution -> kernel_name -> kernel_name val subst_con : substitution -> pconstant -> constant * constr val subst_pcon : substitution -> pconstant -> pconstant val subst_pcon_term : substitution -> pconstant -> pconstant * constr val subst_con_kn : substitution -> constant -> constant * constr val subst_constant : substitution -> constant -> constant (** Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" where X.t is later on instantiated with y? I choose the first interpretation (i.e. an evaluable reference is never expanded). *) val subst_evaluable_reference : substitution -> evaluable_global_reference -> evaluable_global_reference (** [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *) val replace_mp_in_kn : module_path -> module_path -> kernel_name -> kernel_name (** [subst_mps sub c] performs the substitution [sub] on all kernel names appearing in [c] *) val subst_mps : substitution -> constr -> constr (** [occur_*id id sub] returns true iff [id] occurs in [sub] on either side *) val occur_mbid : MBId.t -> substitution -> bool (** [repr_substituted r] dumps the representation of a substituted: - [None, a] when r is a value - [Some s, a] when r is a delayed substitution [s] applied to [a] *) val repr_substituted : 'a substituted -> substitution list option * 'a val force_constr : Term.constr substituted -> Term.constr val subst_constr : substitution -> Term.constr substituted -> Term.constr substituted coq-8.6/kernel/cemitcodes.mli0000644000175000017500000000173413022274260015566 0ustar mdenesmdenesopen Names open Cbytecodes type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant | Reloc_getglobal of constant type patch = reloc_info * int (* A virer *) val subst_patch : Mod_subst.substitution -> patch -> patch type emitcodes val length : emitcodes -> int val patch_int : emitcodes -> ((*pos*)int * int) list -> emitcodes type to_patch = emitcodes * (patch list) * fv val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch type body_code = | BCdefined of to_patch | BCalias of constant | BCconstant type to_patch_substituted val from_val : body_code -> to_patch_substituted val force : to_patch_substituted -> body_code val subst_to_patch_subst : Mod_subst.substitution -> to_patch_substituted -> to_patch_substituted val repr_body_code : to_patch_substituted -> Mod_subst.substitution list option * body_code val to_memory : bytecodes * bytecodes * fv -> to_patch (** init code, fun code, fv *) coq-8.6/kernel/kernel.mllib0000644000175000017500000000064113022274260015241 0ustar mdenesmdenesNames Uint31 Univ UGraph Esubst Sorts Evar Constr Context Vars Term Mod_subst Cbytecodes Copcodes Cemitcodes Nativevalues Primitives Opaqueproof Declareops Retroknowledge Conv_oracle Pre_env Cbytegen Nativelambda Nativecode Nativelib Environ CClosure Reduction Nativeconv Type_errors Modops Inductive Typeops Fast_typeops Indtypes Cooking Term_typing Subtyping Mod_typing Nativelibrary Safe_typing Vm Csymtable Vconv coq-8.6/kernel/primitives.ml0000644000175000017500000000375713022274260015500 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 1 | Int31tail0 -> 2 | Int31add -> 3 | Int31sub -> 4 | Int31mul -> 5 | Int31div -> 6 | Int31mod -> 7 (* | Int31lsr -> 8 | Int31lsl -> 9 *) | Int31land -> 10 | Int31lor -> 11 | Int31lxor -> 12 | Int31addc -> 13 | Int31subc -> 14 | Int31addcarryc -> 15 | Int31subcarryc -> 16 | Int31mulc -> 17 | Int31diveucl -> 18 | Int31div21 -> 19 | Int31addmuldiv -> 20 | Int31eq -> 21 | Int31lt -> 22 | Int31le -> 23 | Int31compare -> 24 let to_string = function | Int31head0 -> "head0" | Int31tail0 -> "tail0" | Int31add -> "add" | Int31sub -> "sub" | Int31mul -> "mul" | Int31div -> "div" | Int31mod -> "mod" (* | Int31lsr -> "l_sr" | Int31lsl -> "l_sl" *) | Int31land -> "l_and" | Int31lor -> "l_or" | Int31lxor -> "l_xor" | Int31addc -> "addc" | Int31subc -> "subc" | Int31addcarryc -> "addcarryc" | Int31subcarryc -> "subcarryc" | Int31mulc -> "mulc" | Int31diveucl -> "diveucl" | Int31div21 -> "div21" | Int31addmuldiv -> "addmuldiv" | Int31eq -> "eq" | Int31lt -> "lt" | Int31le -> "le" | Int31compare -> "compare" coq-8.6/kernel/vconv.ml0000644000175000017500000001615713022274260014436 0ustar mdenesmdenesopen Util open Names open Environ open Reduction open Vm open Csymtable let val_of_constr env c = val_of_constr (pre_env env) c (* Test la structure des piles *) let compare_zipper z1 z2 = match z1, z2 with | Zapp args1, Zapp args2 -> Int.equal (nargs args1) (nargs args2) | Zfix(f1,args1), Zfix(f2,args2) -> Int.equal (nargs args1) (nargs args2) | Zswitch _, Zswitch _ | Zproj _, Zproj _ -> true | Zapp _ , _ | Zfix _, _ | Zswitch _, _ | Zproj _, _ -> false let rec compare_stack stk1 stk2 = match stk1, stk2 with | [], [] -> true | z1::stk1, z2::stk2 -> if compare_zipper z1 z2 then compare_stack stk1 stk2 else false | _, _ -> false (* Conversion *) let conv_vect fconv vect1 vect2 cu = let n = Array.length vect1 in if Int.equal n (Array.length vect2) then let rcu = ref cu in for i = 0 to n - 1 do rcu := fconv vect1.(i) vect2.(i) !rcu done; !rcu else raise NotConvertible let rec conv_val env pb k v1 v2 cu = if v1 == v2 then cu else conv_whd env pb k (whd_val v1) (whd_val v2) cu and conv_whd env pb k whd1 whd2 cu = (* Pp.(msg_debug (str "conv_whd(" ++ pr_whd whd1 ++ str ", " ++ pr_whd whd2 ++ str ")")) ; *) match whd1, whd2 with | Vsort s1, Vsort s2 -> sort_cmp_universes env pb s1 s2 cu | Vuniv_level _ , _ | _ , Vuniv_level _ -> (** Both of these are invalid since universes are handled via ** special cases in the code. **) assert false | Vprod p1, Vprod p2 -> let cu = conv_val env CONV k (dom p1) (dom p2) cu in conv_fun env pb k (codom p1) (codom p2) cu | Vfun f1, Vfun f2 -> conv_fun env CONV k f1 f2 cu | Vfix (f1,None), Vfix (f2,None) -> conv_fix env k f1 f2 cu | Vfix (f1,Some args1), Vfix(f2,Some args2) -> if nargs args1 <> nargs args2 then raise NotConvertible else conv_arguments env k args1 args2 (conv_fix env k f1 f2 cu) | Vcofix (cf1,_,None), Vcofix (cf2,_,None) -> conv_cofix env k cf1 cf2 cu | Vcofix (cf1,_,Some args1), Vcofix (cf2,_,Some args2) -> if nargs args1 <> nargs args2 then raise NotConvertible else conv_arguments env k args1 args2 (conv_cofix env k cf1 cf2 cu) | Vconstr_const i1, Vconstr_const i2 -> if Int.equal i1 i2 then cu else raise NotConvertible | Vconstr_block b1, Vconstr_block b2 -> let tag1 = btag b1 and tag2 = btag b2 in let sz = bsize b1 in if Int.equal tag1 tag2 && Int.equal sz (bsize b2) then let rcu = ref cu in for i = 0 to sz - 1 do rcu := conv_val env CONV k (bfield b1 i) (bfield b2 i) !rcu done; !rcu else raise NotConvertible | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> conv_atom env pb k a1 stk1 a2 stk2 cu | Vfun _, _ | _, Vfun _ -> (* on the fly eta expansion *) conv_val env CONV (k+1) (apply_whd k whd1) (apply_whd k whd2) cu | Vsort _, _ | Vprod _, _ | Vfix _, _ | Vcofix _, _ | Vconstr_const _, _ | Vconstr_block _, _ | Vatom_stk _, _ -> raise NotConvertible 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 Environ.polymorphic_ind ind1 env then let mib = Environ.lookup_mind mi env in let ulen = Univ.UContext.size mib.Declarations.mind_universes in match stk1 , stk2 with | [], [] -> assert (Int.equal ulen 0); cu | Zapp args1 :: stk1' , Zapp args2 :: stk2' -> assert (ulen <= nargs args1); assert (ulen <= nargs args2); let u1 = Array.init ulen (fun i -> uni_lvl_val (arg args1 i)) in let u2 = Array.init ulen (fun i -> uni_lvl_val (arg args2 i)) in let u1 = Univ.Instance.of_array u1 in let u2 = Univ.Instance.of_array u2 in let cu = convert_instances ~flex:false u1 u2 cu in conv_arguments env ~from:ulen k args1 args2 (conv_stack env k stk1' stk2' cu) | _, _ -> assert false (* Should not happen if problem is well typed *) else conv_stack env k stk1 stk2 cu else raise NotConvertible | Aid ik1, Aid ik2 -> if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then conv_stack env k stk1 stk2 cu else raise NotConvertible | Atype _ , _ | _, Atype _ -> assert false | Aind _, _ | Aid _, _ -> raise NotConvertible and conv_stack env k stk1 stk2 cu = match stk1, stk2 with | [], [] -> cu | Zapp args1 :: stk1, Zapp args2 :: stk2 -> conv_stack env k stk1 stk2 (conv_arguments env k args1 args2 cu) | Zfix(f1,args1) :: stk1, Zfix(f2,args2) :: stk2 -> conv_stack env k stk1 stk2 (conv_arguments env k args1 args2 (conv_fix env k f1 f2 cu)) | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 -> if check_switch sw1 sw2 then let vt1,vt2 = type_of_switch sw1, type_of_switch sw2 in let rcu = ref (conv_val env CONV k vt1 vt2 cu) in let b1, b2 = branch_of_switch k sw1, branch_of_switch k sw2 in for i = 0 to Array.length b1 - 1 do rcu := conv_val env CONV (k + fst b1.(i)) (snd b1.(i)) (snd b2.(i)) !rcu done; conv_stack env k stk1 stk2 !rcu else raise NotConvertible | Zproj p1 :: stk1, Zproj p2 :: stk2 -> if Constant.equal p1 p2 then conv_stack env k stk1 stk2 cu else raise NotConvertible | [], _ | Zapp _ :: _, _ | Zfix _ :: _, _ | Zswitch _ :: _, _ | Zproj _ :: _, _ -> raise NotConvertible and conv_fun env pb k f1 f2 cu = if f1 == f2 then cu else let arity,b1,b2 = decompose_vfun2 k f1 f2 in conv_val env pb (k+arity) b1 b2 cu and conv_fix env k f1 f2 cu = if f1 == f2 then cu else if check_fix f1 f2 then let bf1, tf1 = reduce_fix k f1 in let bf2, tf2 = reduce_fix k f2 in let cu = conv_vect (conv_val env CONV k) tf1 tf2 cu in conv_vect (conv_fun env CONV (k + Array.length tf1)) bf1 bf2 cu else raise NotConvertible and conv_cofix env k cf1 cf2 cu = if cf1 == cf2 then cu else if check_cofix cf1 cf2 then let bcf1, tcf1 = reduce_cofix k cf1 in let bcf2, tcf2 = reduce_cofix k cf2 in let cu = conv_vect (conv_val env CONV k) tcf1 tcf2 cu in conv_vect (conv_val env CONV (k + Array.length tcf1)) bcf1 bcf2 cu else raise NotConvertible and conv_arguments env ?from:(from=0) k args1 args2 cu = if args1 == args2 then cu else let n = nargs args1 in if Int.equal n (nargs args2) then let rcu = ref cu in for i = from to n - 1 do rcu := conv_val env CONV k (arg args1 i) (arg args2 i) !rcu done; !rcu else raise NotConvertible let vm_conv_gen cv_pb env univs t1 t2 = try let v1 = val_of_constr env t1 in let v2 = val_of_constr env t2 in fst (conv_val env cv_pb (nb_rel env) v1 v2 univs) with Not_found | Invalid_argument _ -> warn_bytecode_compiler_failed (); Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None) full_transparent_state env univs t1 t2 let vm_conv cv_pb env t1 t2 = let univs = Environ.universes env in let b = if cv_pb = CUMUL then Constr.leq_constr_univs univs t1 t2 else Constr.eq_constr_univs univs t1 t2 in if not b then let univs = (univs, checked_universes) in let _ = vm_conv_gen cv_pb env univs t1 t2 in () let _ = Reduction.set_vm_conv vm_conv coq-8.6/kernel/evar.ml0000644000175000017500000000126213022274260014227 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* module_type_body -> module_type_body -> constraints coq-8.6/kernel/nativecode.mli0000644000175000017500000000441713022274260015571 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* global -> unit val mk_open : string -> global (* Precomputed values for a compilation unit *) type symbol type symbols val empty_symbols : symbols val clear_symbols : unit -> unit val get_value : symbols -> int -> Nativevalues.t val get_sort : symbols -> int -> sorts val get_name : symbols -> int -> name val get_const : symbols -> int -> constant val get_match : symbols -> int -> Nativevalues.annot_sw val get_ind : symbols -> int -> inductive val get_meta : symbols -> int -> metavariable val get_evar : symbols -> int -> existential val get_level : symbols -> int -> Univ.Level.t val get_symbols : unit -> symbols type code_location_update type code_location_updates type linkable_code = global list * code_location_updates val clear_global_tbl : unit -> unit val empty_updates : code_location_updates val register_native_file : string -> unit val compile_constant_field : env -> string -> constant -> global list -> constant_body -> global list val compile_mind_field : string -> module_path -> label -> global list -> mutual_inductive_body -> global list val mk_conv_code : env -> evars -> string -> constr -> constr -> linkable_code val mk_norm_code : env -> evars -> string -> constr -> linkable_code val mk_library_header : dir_path -> global list val mod_uid_of_dirpath : dir_path -> string val link_info_of_dirpath : dir_path -> link_info val update_locations : code_location_updates -> unit val add_header_comment : global list -> string -> global list coq-8.6/kernel/opaqueproof.mli0000644000175000017500000000636713022274260016016 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* opaque (** Turn a direct [opaque] into an indirect one, also hashconses constr. * The integer is an hint of the maximum id used so far *) val turn_indirect : DirPath.t -> opaque -> opaquetab -> opaque * opaquetab (** From a [opaque] back to a [constr]. This might use the indirect opaque accessor configured below. *) val force_proof : opaquetab -> opaque -> constr val force_constraints : opaquetab -> opaque -> Univ.universe_context_set val get_proof : opaquetab -> opaque -> Term.constr Future.computation val get_constraints : opaquetab -> opaque -> Univ.universe_context_set Future.computation option val subst_opaque : substitution -> opaque -> opaque val iter_direct_opaque : (constr -> unit) -> opaque -> opaque type work_list = (Univ.Instance.t * Id.t array) Cmap.t * (Univ.Instance.t * Id.t array) Mindmap.t type cooking_info = { modlist : work_list; abstract : Context.Named.t * Univ.universe_level_subst * Univ.UContext.t } (* The type has two caveats: 1) cook_constr is defined after 2) we have to store the input in the [opaque] in order to be able to discharge it when turning a .vi into a .vo *) val discharge_direct_opaque : cook_constr:(constr -> constr) -> cooking_info -> opaque -> opaque val uuid_opaque : opaquetab -> opaque -> Future.UUID.t option val join_opaque : opaquetab -> opaque -> unit val dump : opaquetab -> Constr.t Future.computation array * Univ.universe_context_set Future.computation array * cooking_info list array * int Future.UUIDMap.t (** When stored indirectly, opaque terms are indexed by their library dirpath and an integer index. The following two functions activate this indirect storage, by telling how to store and retrieve terms. Default creator always returns [None], preventing the creation of any indirect link, and default accessor always raises an error. *) val set_indirect_opaque_accessor : (DirPath.t -> int -> Term.constr Future.computation) -> unit val set_indirect_univ_accessor : (DirPath.t -> int -> Univ.universe_context_set Future.computation option) -> unit coq-8.6/kernel/environ.mli0000644000175000017500000002413113022274260015123 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Pre_env.env val env_of_pre_env : Pre_env.env -> env val oracle : env -> Conv_oracle.oracle val set_oracle : env -> Conv_oracle.oracle -> env type named_context_val val eq_named_context_val : named_context_val -> named_context_val -> bool val empty_env : env val universes : env -> UGraph.t val rel_context : env -> Context.Rel.t val named_context : env -> Context.Named.t val named_context_val : env -> named_context_val val opaque_tables : env -> Opaqueproof.opaquetab val set_opaque_tables : env -> Opaqueproof.opaquetab -> env val engagement : env -> engagement val typing_flags : env -> typing_flags val is_impredicative_set : env -> bool val type_in_type : env -> bool val deactivated_guard : env -> bool (** is the local context empty *) val empty_context : env -> bool (** {5 Context of de Bruijn variables ([rel_context]) } *) val nb_rel : env -> int val push_rel : Context.Rel.Declaration.t -> env -> env val push_rel_context : Context.Rel.t -> env -> env val push_rec_types : rec_declaration -> env -> env (** Looks up in the context of local vars referred by indice ([rel_context]) raises [Not_found] if the index points out of the context *) val lookup_rel : int -> env -> Context.Rel.Declaration.t val evaluable_rel : int -> env -> bool (** {6 Recurrence on [rel_context] } *) val fold_rel_context : (env -> Context.Rel.Declaration.t -> 'a -> 'a) -> env -> init:'a -> 'a (** {5 Context of variables (section variables and goal assumptions) } *) val named_context_of_val : named_context_val -> Context.Named.t val val_of_named_context : Context.Named.t -> named_context_val val empty_named_context_val : named_context_val (** [map_named_val f ctxt] apply [f] to the body and the type of each declarations. *** /!\ *** [f t] should be convertible with t *) val map_named_val : (constr -> constr) -> named_context_val -> named_context_val val push_named : Context.Named.Declaration.t -> env -> env val push_named_context : Context.Named.t -> env -> env val push_named_context_val : Context.Named.Declaration.t -> named_context_val -> named_context_val (** Looks up in the context of local vars referred by names ([named_context]) raises [Not_found] if the Id.t is not found *) val lookup_named : variable -> env -> Context.Named.Declaration.t val lookup_named_val : variable -> named_context_val -> Context.Named.Declaration.t val evaluable_named : variable -> env -> bool val named_type : variable -> env -> types val named_body : variable -> env -> constr option (** {6 Recurrence on [named_context]: older declarations processed first } *) val fold_named_context : (env -> Context.Named.Declaration.t -> 'a -> 'a) -> env -> init:'a -> 'a (** Recurrence on [named_context] starting from younger decl *) val fold_named_context_reverse : ('a -> Context.Named.Declaration.t -> 'a) -> init:'a -> env -> 'a (** This forgets named and rel contexts *) val reset_context : env -> env (** This forgets rel context and sets a new named context *) val reset_with_named_context : named_context_val -> env -> env (** This removes the [n] last declarations from the rel context *) val pop_rel_context : int -> env -> env (** {5 Global constants } {6 Add entries to global environment } *) val add_constant : constant -> constant_body -> env -> env val add_constant_key : constant -> constant_body -> Pre_env.link_info -> env -> env (** Looks up in the context of global constant names raises [Not_found] if the required path is not found *) val lookup_constant : constant -> env -> constant_body val evaluable_constant : constant -> env -> bool (** New-style polymorphism *) val polymorphic_constant : constant -> env -> bool val polymorphic_pconstant : pconstant -> env -> bool val type_in_type_constant : constant -> env -> bool (** Old-style polymorphism *) val template_polymorphic_constant : constant -> env -> bool val template_polymorphic_pconstant : pconstant -> env -> bool (** {6 ... } *) (** [constant_value env c] raises [NotEvaluableConst Opaque] if [c] is opaque and [NotEvaluableConst NoBody] if it has no body and [NotEvaluableConst IsProj] if [c] is a projection and [Not_found] if it does not exist in [env] *) type const_evaluation_result = NoBody | Opaque | IsProj exception NotEvaluableConst of const_evaluation_result val constant_value : env -> constant puniverses -> constr constrained val constant_type : env -> constant puniverses -> constant_type constrained val constant_opt_value : env -> constant puniverses -> (constr * Univ.constraints) option val constant_value_and_type : env -> constant puniverses -> constr option * constant_type * Univ.constraints (** The universe context associated to the constant, empty if not polymorphic *) val constant_context : env -> constant -> Univ.universe_context (* These functions should be called under the invariant that [env] already contains the constraints corresponding to the constant application. *) val constant_value_in : env -> constant puniverses -> constr val constant_type_in : env -> constant puniverses -> constant_type val constant_opt_value_in : env -> constant puniverses -> constr option (** {6 Primitive projections} *) val lookup_projection : Names.projection -> env -> projection_body val is_projection : constant -> env -> bool (** {5 Inductive types } *) val add_mind_key : mutual_inductive -> Pre_env.mind_key -> env -> env val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env (** Looks up in the context of global inductive names raises [Not_found] if the required path is not found *) val lookup_mind : mutual_inductive -> env -> mutual_inductive_body (** New-style polymorphism *) val polymorphic_ind : inductive -> env -> bool val polymorphic_pind : pinductive -> env -> bool val type_in_type_ind : inductive -> env -> bool (** Old-style polymorphism *) val template_polymorphic_ind : inductive -> env -> bool val template_polymorphic_pind : pinductive -> env -> bool (** {5 Modules } *) val add_modtype : module_type_body -> env -> env (** [shallow_add_module] does not add module components *) val shallow_add_module : module_body -> env -> env val lookup_module : module_path -> env -> module_body val lookup_modtype : module_path -> env -> module_type_body (** {5 Universe constraints } *) (** Add universe constraints to the environment. @raises UniverseInconsistency *) val add_constraints : Univ.constraints -> env -> env (** Check constraints are satifiable in the environment. *) val check_constraints : Univ.constraints -> env -> bool val push_context : ?strict:bool -> Univ.universe_context -> env -> env val push_context_set : ?strict:bool -> Univ.universe_context_set -> env -> env val push_constraints_to_env : 'a Univ.constrained -> env -> env val set_engagement : engagement -> env -> env val set_typing_flags : typing_flags -> env -> env (** {6 Sets of referred section variables } [global_vars_set env c] returns the list of [id]'s occurring either directly as [Var id] in [c] or indirectly as a section variable dependent in a global reference occurring in [c] *) val global_vars_set : env -> constr -> Id.Set.t (** the constr must be a global reference *) val vars_of_global : env -> constr -> Id.Set.t (** closure of the input id set w.r.t. dependency *) val really_needed : env -> Id.Set.t -> Id.Set.t (** like [really_needed] but computes a well ordered named context *) val keep_hyps : env -> Id.Set.t -> Context.section_context (** {5 Unsafe judgments. } We introduce here the pre-type of judgments, which is actually only a datatype to store a term with its type and the type of its type. *) type unsafe_judgment = { uj_val : constr; uj_type : types } val make_judge : constr -> types -> unsafe_judgment val j_val : unsafe_judgment -> constr val j_type : unsafe_judgment -> types type unsafe_type_judgment = { utj_val : constr; utj_type : sorts } (** {6 Compilation of global declaration } *) val compile_constant_body : env -> constant_universes option -> constant_def -> Cemitcodes.body_code option exception Hyp_not_found (** [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and return [tail::(f head (id,_,_) (rev tail))::head]. the value associated to id should not change *) val apply_to_hyp : named_context_val -> variable -> (Context.Named.t -> Context.Named.Declaration.t -> Context.Named.t -> Context.Named.Declaration.t) -> named_context_val val remove_hyps : Id.Set.t -> (Context.Named.Declaration.t -> Context.Named.Declaration.t) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val open Retroknowledge (** functions manipulating the retroknowledge @author spiwack *) val retroknowledge : (retroknowledge->'a) -> env -> 'a val registered : env -> field -> bool val register : env -> field -> Retroknowledge.entry -> env (** Native compiler *) val no_link_info : Pre_env.link_info coq-8.6/kernel/type_errors.mli0000644000175000017500000000736013022274260016025 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int -> 'a val error_unbound_var : env -> variable -> 'a val error_not_type : env -> unsafe_judgment -> 'a val error_assumption : env -> unsafe_judgment -> 'a val error_reference_variables : env -> identifier -> constr -> 'a val error_elim_arity : env -> pinductive -> sorts_family list -> constr -> unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a val error_number_branches : env -> unsafe_judgment -> int -> 'a val error_ill_formed_branch : env -> constr -> pconstructor -> constr -> constr -> 'a val error_generalization : env -> Name.t * types -> unsafe_judgment -> 'a val error_actual_type : env -> unsafe_judgment -> types -> 'a val error_cant_apply_not_functional : env -> unsafe_judgment -> unsafe_judgment array -> 'a val error_cant_apply_bad_type : env -> int * constr * constr -> unsafe_judgment -> unsafe_judgment array -> 'a val error_ill_formed_rec_body : env -> guard_error -> Name.t array -> int -> env -> unsafe_judgment array -> 'a val error_ill_typed_rec_body : env -> int -> Name.t array -> unsafe_judgment array -> types array -> 'a val error_elim_explain : sorts_family -> sorts_family -> arity_error val error_unsatisfied_constraints : env -> Univ.constraints -> 'a coq-8.6/kernel/cemitcodes.ml0000644000175000017500000003055413022274260015417 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* patch buff p) patches in buff (* Buffering of bytecode *) let out_buffer = ref(String.create 1024) and out_position = ref 0 let out_word b1 b2 b3 b4 = let p = !out_position in if p >= String.length !out_buffer then begin let len = String.length !out_buffer in let new_len = if len <= Sys.max_string_length / 2 then 2 * len else if len = Sys.max_string_length then invalid_arg "String.create" (* Pas la bonne exception .... *) else Sys.max_string_length in let new_buffer = String.create new_len in String.blit !out_buffer 0 new_buffer 0 len; out_buffer := new_buffer end; patch_char4 !out_buffer p (Char.unsafe_chr b1) (Char.unsafe_chr b2) (Char.unsafe_chr b3) (Char.unsafe_chr b4); out_position := p + 4 let out opcode = out_word opcode 0 0 0 let out_int n = out_word n (n asr 8) (n asr 16) (n asr 24) (* Handling of local labels and backpatching *) type label_definition = Label_defined of int | Label_undefined of (int * int) list let label_table = ref ([| |] : label_definition array) (* le ieme element de la table = Label_defined n signifie que l'on a deja rencontrer le label i et qu'il est a l'offset n. = Label_undefined l signifie que l'on a pas encore rencontrer ce label, le premier entier indique ou est l'entier a patcher dans la string, le deuxieme son origine *) let extend_label_table needed = let new_size = ref(Array.length !label_table) in while needed >= !new_size do new_size := 2 * !new_size done; let new_table = Array.make !new_size (Label_undefined []) in Array.blit !label_table 0 new_table 0 (Array.length !label_table); label_table := new_table let backpatch (pos, orig) = let displ = (!out_position - orig) asr 2 in !out_buffer.[pos] <- Char.unsafe_chr displ; !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8); !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16); !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24) let define_label lbl = if lbl >= Array.length !label_table then extend_label_table lbl; match (!label_table).(lbl) with Label_defined _ -> raise(Failure "CEmitcode.define_label") | Label_undefined patchlist -> List.iter backpatch patchlist; (!label_table).(lbl) <- Label_defined !out_position let out_label_with_orig orig lbl = if lbl >= Array.length !label_table then extend_label_table lbl; match (!label_table).(lbl) with Label_defined def -> out_int((def - orig) asr 2) | Label_undefined patchlist -> (* spiwack: patchlist is supposed to be non-empty all the time thus I commented that out. If there is no problem I suggest removing it for next release (cur: 8.1) *) (*if patchlist = [] then *) (!label_table).(lbl) <- Label_undefined((!out_position, orig) :: patchlist); out_int 0 let out_label l = out_label_with_orig !out_position l (* Relocation information *) let reloc_info = ref ([] : (reloc_info * int) list) let enter info = reloc_info := (info, !out_position) :: !reloc_info let slot_for_const c = enter (Reloc_const c); out_int 0 let slot_for_annot a = enter (Reloc_annot a); out_int 0 let slot_for_getglobal p = enter (Reloc_getglobal p); out_int 0 (* Emission of one instruction *) let emit_instr = function | Klabel lbl -> define_label lbl | Kacc n -> if n < 8 then out(opACC0 + n) else (out opACC; out_int n) | Kenvacc n -> if n >= 1 && n <= 4 then out(opENVACC1 + n - 1) else (out opENVACC; out_int n) | Koffsetclosure ofs -> if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2 then out (opOFFSETCLOSURE0 + ofs / 2) else (out opOFFSETCLOSURE; out_int ofs) | Kpush -> out opPUSH | Kpop n -> out opPOP; out_int n | Kpush_retaddr lbl -> out opPUSH_RETADDR; out_label lbl | Kapply n -> if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n) | Kappterm(n, sz) -> if n < 4 then (out(opAPPTERM1 + n - 1); out_int sz) else (out opAPPTERM; out_int n; out_int sz) | Kreturn n -> out opRETURN; out_int n | Kjump -> out opRETURN; out_int 0 | Krestart -> out opRESTART | Kgrab n -> out opGRAB; out_int n | Kgrabrec(rec_arg) -> out opGRABREC; out_int rec_arg | Kclosure(lbl, n) -> out opCLOSURE; out_int n; out_label lbl | Kclosurerec(nfv,init,lbl_types,lbl_bodies) -> out opCLOSUREREC;out_int (Array.length lbl_bodies); out_int nfv; out_int init; let org = !out_position in Array.iter (out_label_with_orig org) lbl_types; let org = !out_position in Array.iter (out_label_with_orig org) lbl_bodies | Kclosurecofix(nfv,init,lbl_types,lbl_bodies) -> out opCLOSURECOFIX;out_int (Array.length lbl_bodies); out_int nfv; out_int init; let org = !out_position in Array.iter (out_label_with_orig org) lbl_types; let org = !out_position in Array.iter (out_label_with_orig org) lbl_bodies | Kgetglobal q -> out opGETGLOBAL; slot_for_getglobal q | Kconst (Const_b0 i) -> if i >= 0 && i <= 3 then out (opCONST0 + i) else (out opCONSTINT; out_int i) | Kconst c -> out opGETGLOBAL; slot_for_const c | Kmakeblock(n, t) -> if Int.equal n 0 then invalid_arg "emit_instr : block size = 0" else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t) else (out opMAKEBLOCK; out_int n; out_int t) | Kmakeprod -> out opMAKEPROD | Kmakeswitchblock(typlbl,swlbl,annot,sz) -> out opMAKESWITCHBLOCK; out_label typlbl; out_label swlbl; slot_for_annot annot;out_int sz | Kswitch (tbl_const, tbl_block) -> let lenb = Array.length tbl_block in let lenc = Array.length tbl_const in assert (lenb < 0x100 && lenc < 0x1000000); out opSWITCH; out_word lenc (lenc asr 8) (lenc asr 16) (lenb); (* out_int (Array.length tbl_const + (Array.length tbl_block lsl 23)); *) let org = !out_position in Array.iter (out_label_with_orig org) tbl_const; Array.iter (out_label_with_orig org) tbl_block | Kpushfields n -> out opPUSHFIELDS;out_int n | Kfield n -> if n <= 1 then out (opGETFIELD0+n) else (out opGETFIELD;out_int n) | Ksetfield n -> if n <= 1 then out (opSETFIELD0+n) else (out opSETFIELD;out_int n) | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr" | Kproj (n,p) -> out opPROJ; out_int n; slot_for_const (Const_proj p) | Kensurestackcapacity size -> out opENSURESTACKCAPACITY; out_int size (* spiwack *) | Kbranch lbl -> out opBRANCH; out_label lbl | Kaddint31 -> out opADDINT31 | Kaddcint31 -> out opADDCINT31 | Kaddcarrycint31 -> out opADDCARRYCINT31 | Ksubint31 -> out opSUBINT31 | Ksubcint31 -> out opSUBCINT31 | Ksubcarrycint31 -> out opSUBCARRYCINT31 | Kmulint31 -> out opMULINT31 | Kmulcint31 -> out opMULCINT31 | Kdiv21int31 -> out opDIV21INT31 | Kdivint31 -> out opDIVINT31 | Kaddmuldivint31 -> out opADDMULDIVINT31 | Kcompareint31 -> out opCOMPAREINT31 | Khead0int31 -> out opHEAD0INT31 | Ktail0int31 -> out opTAIL0INT31 | Kisconst lbl -> out opISCONST; out_label lbl | Kareconst(n,lbl) -> out opARECONST; out_int n; out_label lbl | Kcompint31 -> out opCOMPINT31 | Kdecompint31 -> out opDECOMPINT31 | Klorint31 -> out opORINT31 | Klandint31 -> out opANDINT31 | Klxorint31 -> out opXORINT31 (*/spiwack *) | Kstop -> out opSTOP (* Emission of a list of instructions. Include some peephole optimization. *) let rec emit = function | [] -> () (* Peephole optimizations *) | Kpush :: Kacc n :: c -> if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n); emit c | Kpush :: Kenvacc n :: c -> if n >= 1 && n <= 4 then out(opPUSHENVACC1 + n - 1) else (out opPUSHENVACC; out_int n); emit c | Kpush :: Koffsetclosure ofs :: c -> if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2 then out(opPUSHOFFSETCLOSURE0 + ofs / 2) else (out opPUSHOFFSETCLOSURE; out_int ofs); emit c | Kpush :: Kgetglobal id :: c -> out opPUSHGETGLOBAL; slot_for_getglobal id; emit c | Kpush :: Kconst (Const_b0 i) :: c -> if i >= 0 && i <= 3 then out (opPUSHCONST0 + i) else (out opPUSHCONSTINT; out_int i); emit c | Kpush :: Kconst const :: c -> out opPUSHGETGLOBAL; slot_for_const const; emit c | Kpop n :: Kjump :: c -> out opRETURN; out_int n; emit c | Ksequence(c1,c2)::c -> emit c1; emit c2;emit c (* Default case *) | instr :: c -> emit_instr instr; emit c (* Initialization *) let init () = out_position := 0; label_table := Array.make 16 (Label_undefined []); reloc_info := [] type emitcodes = string let length = String.length type to_patch = emitcodes * (patch list) * fv (* Substitution *) let rec subst_strcst s sc = match sc with | Const_sorts _ | Const_b0 _ | Const_univ_level _ | Const_type _ -> sc | Const_proj p -> Const_proj (subst_constant s p) | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) | Const_ind ind -> let kn,i = ind in Const_ind (subst_mind s kn, i) let subst_patch s (ri,pos) = match ri with | Reloc_annot a -> let (kn,i) = a.ci.ci_ind in let ci = {a.ci with ci_ind = (subst_mind s kn,i)} in (Reloc_annot {a with ci = ci},pos) | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos) | Reloc_getglobal kn -> (Reloc_getglobal (subst_constant s kn), pos) let subst_to_patch s (code,pl,fv) = code,List.rev_map (subst_patch s) pl,fv type body_code = | BCdefined of to_patch | BCalias of Names.constant | BCconstant type to_patch_substituted = | PBCdefined of to_patch substituted | PBCalias of Names.constant substituted | PBCconstant let from_val = function | BCdefined tp -> PBCdefined (from_val tp) | BCalias cu -> PBCalias (from_val cu) | BCconstant -> PBCconstant let force = function | PBCdefined tp -> BCdefined (force subst_to_patch tp) | PBCalias cu -> BCalias (force subst_constant cu) | PBCconstant -> BCconstant let subst_to_patch_subst s = function | PBCdefined tp -> PBCdefined (subst_substituted s tp) | PBCalias cu -> PBCalias (subst_substituted s cu) | PBCconstant -> PBCconstant let repr_body_code = function | PBCdefined tp -> let (s, tp) = repr_substituted tp in (s, BCdefined tp) | PBCalias cu -> let (s, cu) = repr_substituted cu in (s, BCalias cu) | PBCconstant -> (None, BCconstant) let to_memory (init_code, fun_code, fv) = init(); emit init_code; emit fun_code; let code = String.create !out_position in String.unsafe_blit !out_buffer 0 code 0 !out_position; (** Later uses of this string are all purely functional *) let code = CString.hcons code in let reloc = List.rev !reloc_info in Array.iter (fun lbl -> (match lbl with Label_defined _ -> assert true | Label_undefined patchlist -> assert (patchlist = []))) !label_table; (code, reloc, fv) coq-8.6/kernel/type_errors.ml0000644000175000017500000001021213022274260015642 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* NonInformativeToInformative | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *) | _ -> WrongArity let error_unsatisfied_constraints env c = raise (TypeError (env, UnsatisfiedConstraints c)) coq-8.6/kernel/nativelib.mli0000644000175000017500000000227613022274260015426 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string list) ref val load_obj : (string -> unit) ref val get_ml_filename : unit -> string * string val compile : string -> global list -> bool * string val compile_library : Names.dir_path -> global list -> string -> bool val call_linker : ?fatal:bool -> string -> string -> code_location_updates option -> unit val link_library : prefix:string -> dirname:string -> basename:string -> unit val rt1 : Nativevalues.t ref val rt2 : Nativevalues.t ref coq-8.6/kernel/names.ml0000644000175000017500000006553113022274260014406 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* str s) let check_soft ?(warn = true) x = let iter (fatal, x) = if fatal then CErrors.error x else if warn then warn_invalid_identifier x in Option.iter iter (Unicode.ident_refutation x) let is_valid s = match Unicode.ident_refutation s with | None -> true | Some _ -> false let of_string s = let () = check_soft s in let s = String.copy s in String.hcons s let of_string_soft s = let () = check_soft ~warn:false s in let s = String.copy s in String.hcons s let to_string id = String.copy id let print id = str id module Self = struct type t = string let compare = compare end module Set = Set.Make(Self) module Map = CMap.Make(Self) module Pred = Predicate.Make(Self) module List = String.List let hcons = String.hcons end (** Representation and operations on identifiers that are allowed to be anonymous (i.e. "_" in concrete syntax). *) module Name = struct type t = Anonymous (** anonymous identifier *) | Name of Id.t (** non-anonymous identifier *) let is_anonymous = function | Anonymous -> true | Name _ -> false let is_name = not % is_anonymous let compare n1 n2 = match n1, n2 with | Anonymous, Anonymous -> 0 | Name id1, Name id2 -> Id.compare id1 id2 | Anonymous, Name _ -> -1 | Name _, Anonymous -> 1 let equal n1 n2 = match n1, n2 with | Anonymous, Anonymous -> true | Name id1, Name id2 -> String.equal id1 id2 | _ -> false let hash = function | Anonymous -> 0 | Name id -> Id.hash id module Self_Hashcons = struct type _t = t type t = _t type u = Id.t -> Id.t let hashcons hident = function | Name id -> Name (hident id) | n -> n let eq n1 n2 = n1 == n2 || match (n1,n2) with | (Name id1, Name id2) -> id1 == id2 | (Anonymous,Anonymous) -> true | _ -> false let hash = hash end module Hname = Hashcons.Make(Self_Hashcons) let hcons = Hashcons.simple_hcons Hname.generate Hname.hcons Id.hcons end (** Alias, to import constructors. *) type name = Name.t = Anonymous | Name of Id.t (** {6 Various types based on identifiers } *) type variable = Id.t type module_ident = Id.t module ModIdset = Id.Set module ModIdmap = Id.Map (** {6 Directory paths = section names paths } *) (** Dirpaths are lists of module identifiers. The actual representation is reversed to optimise sharing: Coq.A.B is ["B";"A";"Coq"] *) let default_module_name = "If you see this, it's a bug" module DirPath = struct type t = module_ident list let rec compare (p1 : t) (p2 : t) = if p1 == p2 then 0 else begin match p1, p2 with | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | id1 :: p1, id2 :: p2 -> let c = Id.compare id1 id2 in if Int.equal c 0 then compare p1 p2 else c end let rec equal p1 p2 = p1 == p2 || match p1, p2 with | [], [] -> true | id1 :: p1, id2 :: p2 -> Id.equal id1 id2 && equal p1 p2 | _ -> false let rec hash accu = function | [] -> accu | id :: dp -> let accu = Hashset.Combine.combine (Id.hash id) accu in hash accu dp let hash dp = hash 0 dp let make x = x let repr x = x let empty = [] let is_empty d = match d with [] -> true | _ -> false let to_string = function | [] -> "<>" | sl -> String.concat "." (List.rev_map Id.to_string sl) let initial = [default_module_name] module Hdir = Hashcons.Hlist(Id) let hcons = Hashcons.recursive_hcons Hdir.generate Hdir.hcons Id.hcons end (** {6 Unique names for bound modules } *) module MBId = struct type t = int * Id.t * DirPath.t let gen = let seed = ref 0 in fun () -> let ans = !seed in let () = incr seed in ans let make dir s = (gen(), s, dir) let repr mbid = mbid let to_string (i, s, p) = DirPath.to_string p ^ "." ^ s let debug_to_string (i, s, p) = "<"^DirPath.to_string p ^"#" ^ s ^"#"^ string_of_int i^">" let compare (x : t) (y : t) = if x == y then 0 else match (x, y) with | (nl, idl, dpl), (nr, idr, dpr) -> let ans = Int.compare nl nr in if not (Int.equal ans 0) then ans else let ans = Id.compare idl idr in if not (Int.equal ans 0) then ans else DirPath.compare dpl dpr let equal x y = x == y || let (i1, id1, p1) = x in let (i2, id2, p2) = y in Int.equal i1 i2 && Id.equal id1 id2 && DirPath.equal p1 p2 let to_id (_, s, _) = s open Hashset.Combine let hash (i, id, dp) = combine3 (Int.hash i) (Id.hash id) (DirPath.hash dp) module Self_Hashcons = struct type _t = t type t = _t type u = (Id.t -> Id.t) * (DirPath.t -> DirPath.t) let hashcons (hid,hdir) (n,s,dir) = (n,hid s,hdir dir) let eq ((n1,s1,dir1) as x) ((n2,s2,dir2) as y) = (x == y) || (Int.equal n1 n2 && s1 == s2 && dir1 == dir2) let hash = hash end module HashMBId = Hashcons.Make(Self_Hashcons) let hcons = Hashcons.simple_hcons HashMBId.generate HashMBId.hcons (Id.hcons, DirPath.hcons) end module MBImap = CMap.Make(MBId) module MBIset = Set.Make(MBId) (** {6 Names of structure elements } *) module Label = struct include Id let make = Id.of_string let of_id id = id let to_id id = id end (** {6 The module part of the kernel name } *) module ModPath = struct type t = | MPfile of DirPath.t | MPbound of MBId.t | MPdot of t * Label.t type module_path = t let rec is_bound = function | MPbound _ -> true | MPdot(mp,_) -> is_bound mp | _ -> false let rec to_string = function | MPfile sl -> DirPath.to_string sl | MPbound uid -> MBId.to_string uid | MPdot (mp,l) -> to_string mp ^ "." ^ Label.to_string l let rec debug_to_string = function | MPfile sl -> DirPath.to_string sl | MPbound uid -> MBId.debug_to_string uid | MPdot (mp,l) -> debug_to_string mp ^ "." ^ Label.to_string l (** we compare labels first if both are MPdots *) let rec compare mp1 mp2 = if mp1 == mp2 then 0 else match mp1, mp2 with | MPfile p1, MPfile p2 -> DirPath.compare p1 p2 | MPbound id1, MPbound id2 -> MBId.compare id1 id2 | MPdot (mp1, l1), MPdot (mp2, l2) -> let c = String.compare l1 l2 in if not (Int.equal c 0) then c else compare mp1 mp2 | MPfile _, _ -> -1 | MPbound _, MPfile _ -> 1 | MPbound _, MPdot _ -> -1 | MPdot _, _ -> 1 let rec equal mp1 mp2 = mp1 == mp2 || match mp1, mp2 with | MPfile p1, MPfile p2 -> DirPath.equal p1 p2 | MPbound id1, MPbound id2 -> MBId.equal id1 id2 | MPdot (mp1, l1), MPdot (mp2, l2) -> String.equal l1 l2 && equal mp1 mp2 | (MPfile _ | MPbound _ | MPdot _), _ -> false open Hashset.Combine let rec hash = function | MPfile dp -> combinesmall 1 (DirPath.hash dp) | MPbound id -> combinesmall 2 (MBId.hash id) | MPdot (mp, lbl) -> combinesmall 3 (combine (hash mp) (Label.hash lbl)) let initial = MPfile DirPath.initial let rec dp = function | MPfile sl -> sl | MPbound (_,_,dp) -> dp | MPdot (mp,l) -> dp mp module Self_Hashcons = struct type t = module_path type u = (DirPath.t -> DirPath.t) * (MBId.t -> MBId.t) * (string -> string) let rec hashcons (hdir,huniqid,hstr as hfuns) = function | MPfile dir -> MPfile (hdir dir) | MPbound m -> MPbound (huniqid m) | MPdot (md,l) -> MPdot (hashcons hfuns md, hstr l) let eq d1 d2 = d1 == d2 || match d1,d2 with | MPfile dir1, MPfile dir2 -> dir1 == dir2 | MPbound m1, MPbound m2 -> m1 == m2 | MPdot (mod1,l1), MPdot (mod2,l2) -> l1 == l2 && equal mod1 mod2 | _ -> false let hash = hash end module HashMP = Hashcons.Make(Self_Hashcons) let hcons = Hashcons.simple_hcons HashMP.generate HashMP.hcons (DirPath.hcons,MBId.hcons,String.hcons) end module MPset = Set.Make(ModPath) module MPmap = CMap.Make(ModPath) (** {6 Kernel names } *) module KerName = struct type t = { canary : Canary.t; modpath : ModPath.t; dirpath : DirPath.t; knlabel : Label.t; mutable refhash : int; (** Lazily computed hash. If unset, it is set to negative values. *) } let canary = Canary.obj type kernel_name = t let make modpath dirpath knlabel = { modpath; dirpath; knlabel; refhash = -1; canary; } let repr kn = (kn.modpath, kn.dirpath, kn.knlabel) let make2 modpath knlabel = { modpath; dirpath = DirPath.empty; knlabel; refhash = -1; canary; } let modpath kn = kn.modpath let label kn = kn.knlabel let to_string_gen mp_to_string kn = let dp = if DirPath.is_empty kn.dirpath then "." else "#" ^ DirPath.to_string kn.dirpath ^ "#" in mp_to_string kn.modpath ^ dp ^ Label.to_string kn.knlabel let to_string kn = to_string_gen ModPath.to_string kn let debug_to_string kn = to_string_gen ModPath.debug_to_string kn let print kn = str (to_string kn) let compare (kn1 : kernel_name) (kn2 : kernel_name) = if kn1 == kn2 then 0 else let c = String.compare kn1.knlabel kn2.knlabel in if not (Int.equal c 0) then c else let c = DirPath.compare kn1.dirpath kn2.dirpath in if not (Int.equal c 0) then c else ModPath.compare kn1.modpath kn2.modpath let equal kn1 kn2 = let h1 = kn1.refhash in let h2 = kn2.refhash in if 0 <= h1 && 0 <= h2 && not (Int.equal h1 h2) then false else Label.equal kn1.knlabel kn2.knlabel && DirPath.equal kn1.dirpath kn2.dirpath && ModPath.equal kn1.modpath kn2.modpath open Hashset.Combine let hash kn = let h = kn.refhash in if h < 0 then let { modpath = mp; dirpath = dp; knlabel = lbl; } = kn in let h = combine3 (ModPath.hash mp) (DirPath.hash dp) (Label.hash lbl) in (* Ensure positivity on all platforms. *) let h = h land 0x3FFFFFFF in let () = kn.refhash <- h in h else h module Self_Hashcons = struct type t = kernel_name type u = (ModPath.t -> ModPath.t) * (DirPath.t -> DirPath.t) * (string -> string) let hashcons (hmod,hdir,hstr) kn = let { modpath = mp; dirpath = dp; knlabel = l; refhash; } = kn in { modpath = hmod mp; dirpath = hdir dp; knlabel = hstr l; refhash; canary; } let eq kn1 kn2 = kn1.modpath == kn2.modpath && kn1.dirpath == kn2.dirpath && kn1.knlabel == kn2.knlabel let hash = hash end module HashKN = Hashcons.Make(Self_Hashcons) let hcons = Hashcons.simple_hcons HashKN.generate HashKN.hcons (ModPath.hcons,DirPath.hcons,String.hcons) end module KNmap = HMap.Make(KerName) module KNpred = Predicate.Make(KerName) module KNset = KNmap.Set (** {6 Kernel pairs } *) (** 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 we have {% kn1 \rhd_{\delta}^* kn2 \rhd_{\delta} t %} Invariants : - the user and canonical kn may differ only on their [module_path], the dirpaths and labels should be the same - when user and canonical parts differ, we cannot be in a section anymore, hence the dirpath must be empty - two pairs with the same user part should have the same canonical part in a given environment (though with backtracking, the hash-table can contains pairs with same user part but different canonical part from a previous state of the session) Note: since most of the time the canonical and user parts are equal, we handle this case with a particular constructor to spare some memory *) module KerPair = struct type t = | Same of KerName.t (** user = canonical *) | Dual of KerName.t * KerName.t (** user then canonical *) type kernel_pair = t let canonical = function | Same kn -> kn | Dual (_,kn) -> kn let user = function | Same kn -> kn | Dual (kn,_) -> kn let same kn = Same kn let make knu knc = if KerName.equal knu knc then Same knc else Dual (knu,knc) let make1 = same let make2 mp l = same (KerName.make2 mp l) let make3 mp dir l = same (KerName.make mp dir l) let repr3 kp = KerName.repr (user kp) let label kp = KerName.label (user kp) let modpath kp = KerName.modpath (user kp) let change_label kp lbl = let (mp1,dp1,l1) = KerName.repr (user kp) and (mp2,dp2,l2) = KerName.repr (canonical kp) in assert (String.equal l1 l2 && DirPath.equal dp1 dp2); if String.equal lbl l1 then kp else let kn = KerName.make mp1 dp1 lbl in if mp1 == mp2 then same kn else make kn (KerName.make mp2 dp2 lbl) let to_string kp = KerName.to_string (user kp) let print kp = str (to_string kp) let debug_to_string = function | Same kn -> "(" ^ KerName.debug_to_string kn ^ ")" | Dual (knu,knc) -> "(" ^ KerName.debug_to_string knu ^ "," ^ KerName.debug_to_string knc ^ ")" let debug_print kp = str (debug_to_string kp) (** For ordering kernel pairs, both user or canonical parts may make sense, according to your needs: user for the environments, canonical for other uses (ex: non-logical things). *) module UserOrd = struct type t = kernel_pair let compare x y = KerName.compare (user x) (user y) let equal x y = x == y || KerName.equal (user x) (user y) let hash x = KerName.hash (user x) end module CanOrd = struct type t = kernel_pair let compare x y = KerName.compare (canonical x) (canonical y) let equal x y = x == y || KerName.equal (canonical x) (canonical y) let hash x = KerName.hash (canonical x) 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) -> let c = KerName.compare knux knuy in if not (Int.equal c 0) then c else KerName.compare kncx kncy | Same _, _ -> -1 | Dual _, _ -> 1 let equal x y = x == y || compare x y = 0 let hash = function | Same kn -> KerName.hash kn | Dual (knu, knc) -> Hashset.Combine.combine (KerName.hash knu) (KerName.hash knc) end (** Default (logical) comparison and hash is on the canonical part *) let equal = CanOrd.equal let hash = CanOrd.hash module Self_Hashcons = struct type t = kernel_pair type u = KerName.t -> KerName.t let hashcons hkn = function | Same kn -> Same (hkn kn) | Dual (knu,knc) -> make (hkn knu) (hkn knc) let eq x y = (* physical comparison on subterms *) x == y || match x,y with | Same x, Same y -> x == y | Dual (ux,cx), Dual (uy,cy) -> ux == uy && cx == cy | (Same _ | Dual _), _ -> false (** Hash-consing (despite having the same user part implies having the same canonical part is a logical invariant of the system, it is not necessarily an invariant in memory, so we treat kernel names as they are syntactically for hash-consing) *) let hash = function | Same kn -> KerName.hash kn | Dual (knu, knc) -> Hashset.Combine.combine (KerName.hash knu) (KerName.hash knc) end module HashKP = Hashcons.Make(Self_Hashcons) end (** {6 Constant Names} *) module Constant = KerPair module Cmap = HMap.Make(Constant.CanOrd) module Cmap_env = HMap.Make(Constant.UserOrd) module Cpred = Predicate.Make(Constant.CanOrd) module Cset = Cmap.Set module Cset_env = Cmap_env.Set (** {6 Names of mutual inductive types } *) module MutInd = KerPair module Mindmap = HMap.Make(MutInd.CanOrd) module Mindset = Mindmap.Set module Mindmap_env = HMap.Make(MutInd.UserOrd) (** 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. *) (** 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. *) let ind_modpath (mind,_) = MutInd.modpath mind let constr_modpath (ind,_) = ind_modpath ind 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 module InductiveOrdered_env = struct type t = inductive let compare = ind_user_ord end module Indmap = Map.Make(InductiveOrdered) module Indmap_env = Map.Make(InductiveOrdered_env) module ConstructorOrdered = struct type t = constructor let compare = constructor_ord end module ConstructorOrdered_env = struct type t = constructor let compare = constructor_user_ord end module Constrmap = Map.Make(ConstructorOrdered) module Constrmap_env = Map.Make(ConstructorOrdered_env) (* Better to have it here that in closure, since used in grammar.cma *) type evaluable_global_reference = | EvalVarRef of Id.t | EvalConstRef of Constant.t let eq_egr e1 e2 = match e1, e2 with EvalConstRef con1, EvalConstRef con2 -> Constant.equal con1 con2 | EvalVarRef id1, EvalVarRef id2 -> Id.equal id1 id2 | _, _ -> false (** {6 Hash-consing of name objects } *) module Hind = Hashcons.Make( struct type t = inductive type u = MutInd.t -> MutInd.t let hashcons hmind (mind, i) = (hmind mind, i) let eq (mind1,i1) (mind2,i2) = mind1 == mind2 && Int.equal i1 i2 let hash = ind_hash end) module Hconstruct = Hashcons.Make( struct type t = constructor type u = inductive -> inductive let hashcons hind (ind, j) = (hind ind, j) let eq (ind1, j1) (ind2, j2) = ind1 == ind2 && Int.equal j1 j2 let hash = constructor_hash end) let hcons_con = Hashcons.simple_hcons Constant.HashKP.generate Constant.HashKP.hcons KerName.hcons let hcons_mind = Hashcons.simple_hcons MutInd.HashKP.generate MutInd.HashKP.hcons KerName.hcons let hcons_ind = Hashcons.simple_hcons Hind.generate Hind.hcons hcons_mind let hcons_construct = Hashcons.simple_hcons Hconstruct.generate Hconstruct.hcons hcons_ind (*****************) type transparent_state = Id.Pred.t * Cpred.t let empty_transparent_state = (Id.Pred.empty, Cpred.empty) let full_transparent_state = (Id.Pred.full, Cpred.full) let var_full_transparent_state = (Id.Pred.full, Cpred.empty) let cst_full_transparent_state = (Id.Pred.empty, Cpred.full) type 'a tableKey = | ConstKey of 'a | VarKey of Id.t | RelKey of Int.t type inv_rel_key = int (* index in the [rel_context] part of environment starting by the end, {\em inverse} of de Bruijn indice *) let eq_table_key f ik1 ik2 = if ik1 == ik2 then true else match ik1,ik2 with | ConstKey c1, ConstKey c2 -> f c1 c2 | VarKey id1, VarKey id2 -> Id.equal id1 id2 | RelKey k1, RelKey k2 -> Int.equal k1 k2 | _ -> false let eq_con_chk = Constant.UserOrd.equal let eq_mind_chk = MutInd.UserOrd.equal let eq_ind_chk (kn1,i1) (kn2,i2) = Int.equal i1 i2 && eq_mind_chk kn1 kn2 (*******************************************************************) (** Compatibility layers *) (** Backward compatibility for [Id] *) type identifier = Id.t let id_eq = Id.equal let id_ord = Id.compare let string_of_id = Id.to_string let id_of_string = Id.of_string module Idset = Id.Set module Idmap = Id.Map module Idpred = Id.Pred (** Compatibility layer for [Name] *) let name_eq = Name.equal (** Compatibility layer for [DirPath] *) type dir_path = DirPath.t let dir_path_ord = DirPath.compare let dir_path_eq = DirPath.equal let make_dirpath = DirPath.make let repr_dirpath = DirPath.repr let empty_dirpath = DirPath.empty let is_empty_dirpath = DirPath.is_empty let string_of_dirpath = DirPath.to_string let initial_dir = DirPath.initial (** Compatibility layer for [MBId] *) type mod_bound_id = MBId.t let mod_bound_id_ord = MBId.compare let mod_bound_id_eq = MBId.equal let make_mbid = MBId.make let repr_mbid = MBId.repr let debug_string_of_mbid = MBId.debug_to_string let string_of_mbid = MBId.to_string let id_of_mbid = MBId.to_id (** Compatibility layer for [Label] *) type label = Id.t let mk_label = Label.make let string_of_label = Label.to_string let pr_label = Label.print let id_of_label = Label.to_id let label_of_id = Label.of_id let eq_label = Label.equal (** Compatibility layer for [ModPath] *) type module_path = ModPath.t = | MPfile of DirPath.t | MPbound of MBId.t | MPdot of module_path * Label.t let check_bound_mp = ModPath.is_bound let string_of_mp = ModPath.to_string let mp_ord = ModPath.compare let mp_eq = ModPath.equal let initial_path = ModPath.initial (** Compatibility layer for [KerName] *) type kernel_name = KerName.t let make_kn = KerName.make let repr_kn = KerName.repr let modpath = KerName.modpath let label = KerName.label let string_of_kn = KerName.to_string let pr_kn = KerName.print let kn_ord = KerName.compare (** Compatibility layer for [Constant] *) type constant = Constant.t module Projection = struct type t = constant * bool let make c b = (c, b) let constant = fst let unfolded = snd let unfold (c, b as p) = if b then p else (c, true) let equal (c, b) (c', b') = Constant.equal c c' && b == b' let hash (c, b) = (if b then 0 else 1) + Constant.hash c module SyntacticOrd = struct type t = constant * bool let compare (c, b) (c', b') = if b = b' then Constant.SyntacticOrd.compare c c' else -1 let equal (c, b as x) (c', b' as x') = x == x' || b = b' && Constant.SyntacticOrd.equal c c' let hash (c, b) = (if b then 0 else 1) + Constant.SyntacticOrd.hash c end module Self_Hashcons = struct type _t = t type t = _t type u = Constant.t -> Constant.t let hashcons hc (c,b) = (hc c,b) let eq ((c,b) as x) ((c',b') as y) = x == y || (c == c' && b == b') let hash = hash end module HashProjection = Hashcons.Make(Self_Hashcons) let hcons = Hashcons.simple_hcons HashProjection.generate HashProjection.hcons hcons_con let compare (c, b) (c', b') = if b == b' then Constant.CanOrd.compare c c' else if b then 1 else -1 let map f (c, b as x) = let c' = f c in if c' == c then x else (c', b) let to_string p = Constant.to_string (constant p) let print p = Constant.print (constant p) end type projection = Projection.t let constant_of_kn = Constant.make1 let constant_of_kn_equiv = Constant.make let make_con = Constant.make3 let repr_con = Constant.repr3 let canonical_con = Constant.canonical let user_con = Constant.user let con_label = Constant.label let con_modpath = Constant.modpath let eq_constant = Constant.equal let eq_constant_key = Constant.UserOrd.equal let con_ord = Constant.CanOrd.compare let con_user_ord = Constant.UserOrd.compare let string_of_con = Constant.to_string let pr_con = Constant.print let debug_string_of_con = Constant.debug_to_string let debug_pr_con = Constant.debug_print let con_with_label = Constant.change_label (** Compatibility layer for [MutInd] *) type mutual_inductive = MutInd.t let mind_of_kn = MutInd.make1 let mind_of_kn_equiv = MutInd.make let make_mind = MutInd.make3 let canonical_mind = MutInd.canonical let user_mind = MutInd.user let repr_mind = MutInd.repr3 let mind_label = MutInd.label let mind_modpath = MutInd.modpath let eq_mind = MutInd.equal let mind_ord = MutInd.CanOrd.compare let mind_user_ord = MutInd.UserOrd.compare let string_of_mind = MutInd.to_string let pr_mind = MutInd.print let debug_string_of_mind = MutInd.debug_to_string let debug_pr_mind = MutInd.debug_print coq-8.6/kernel/vm.ml0000644000175000017500000005345113022274260013723 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit = "coq_set_drawinstr" (******************************************) (* Utility Functions about Obj ************) (******************************************) external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure" external offset : Obj.t -> int = "coq_offset" (*******************************************) (* Initalization of the abstract machine ***) (*******************************************) external init_vm : unit -> unit = "init_coq_vm" let _ = init_vm () (*******************************************) (* Machine code *** ************************) (*******************************************) type tcode let tcode_of_obj v = ((Obj.obj v):tcode) let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0) external mkAccuCode : int -> tcode = "coq_makeaccu" external mkPopStopCode : int -> tcode = "coq_pushpop" external offset_tcode : tcode -> int -> tcode = "coq_offset_tcode" external int_tcode : tcode -> int -> int = "coq_int_tcode" external accumulate : unit -> tcode = "accumulate_code" let accumulate = accumulate () external is_accumulate : tcode -> bool = "coq_is_accumulate_code" let popstop_tbl = ref (Array.init 30 mkPopStopCode) let popstop_code i = let len = Array.length !popstop_tbl in if i < len then !popstop_tbl.(i) else begin popstop_tbl := Array.init (i+10) (fun j -> if j < len then !popstop_tbl.(j) else mkPopStopCode j); !popstop_tbl.(i) end let stop = popstop_code 0 (******************************************************) (* Abstract data types and utility functions **********) (******************************************************) (* Values of the abstract machine *) let val_of_obj v = ((Obj.obj v):values) let crazy_val = (val_of_obj (Obj.repr 0)) (* Abstract data *) type vprod type vfun type vfix type vcofix type vblock type arguments type vm_env type vstack = values array type vswitch = { sw_type_code : tcode; sw_code : tcode; sw_annot : annot_switch; sw_stk : vstack; sw_env : vm_env } (* Representation of values *) (* + Products : *) (* - vprod = 0_[ dom | codom] *) (* dom : values, codom : vfun *) (* *) (* + Functions have two representations : *) (* - unapplied fun : vf = Ct_[ C | fv1 | ... | fvn] *) (* C:tcode, fvi : values *) (* Remark : a function and its environment is the same value. *) (* - partially applied fun : Ct_[Restart:C| vf | arg1 | ... argn] *) (* *) (* + Fixpoints : *) (* - Ct_[C1|Infix_t|C2|...|Infix_t|Cn|fv1|...|fvn] *) (* One single block to represent all of the fixpoints, each fixpoint *) (* is the pointer to the field holding the pointer to its code, and *) (* the infix tag is used to know where the block starts. *) (* - Partial application follows the scheme of partially applied *) (* functions. Note: only fixpoints not having been applied to its *) (* recursive argument are coded this way. When the rec. arg. is *) (* applied, either it's a constructor and the fix reduces, or it's *) (* and the fix is coded as an accumulator. *) (* *) (* + Cofixpoints : see cbytegen.ml *) (* *) (* + vblock's encode (non constant) constructors as in Ocaml, but *) (* starting from 0 up. tag 0 ( = accu_tag) is reserved for *) (* accumulators. *) (* *) (* + vm_env is the type of the machine environments (i.e. a function or *) (* a fixpoint) *) (* *) (* + Accumulators : At_[accumulate| accu | arg1 | ... | argn ] *) (* - representation of [accu] : tag_[....] *) (* -- tag <= 3 : encoding atom type (sorts, free vars, etc.) *) (* -- 10_[accu|proj name] : a projection blocked by an accu *) (* -- 11_[accu|fix_app] : a fixpoint blocked by an accu *) (* -- 12_[accu|vswitch] : a match blocked by an accu *) (* -- 13_[fcofix] : a cofix function *) (* -- 14_[fcofix|val] : a cofix function, val represent the value *) (* of the function applied to arg1 ... argn *) (* The [arguments] type, which is abstracted as an array, represents : *) (* tag[ _ | _ |v1|... | vn] *) (* Generally the first field is a code pointer. *) (* Do not edit this type without editing C code, especially "coq_values.h" *) type atom = | Aid of Vars.id_key | Aind of inductive | Atype of Univ.universe (* Zippers *) type zipper = | Zapp of arguments | Zfix of vfix*arguments (* Possibly empty *) | Zswitch of vswitch | Zproj of Constant.t (* name of the projection *) type stack = zipper list type to_up = values type whd = | Vsort of sorts | Vprod of vprod | Vfun of vfun | Vfix of vfix * arguments option | Vcofix of vcofix * to_up * arguments option | Vconstr_const of int | Vconstr_block of vblock | Vatom_stk of atom * stack | Vuniv_level of Univ.universe_level (************************************************) (* Abstract machine *****************************) (************************************************) (* gestion de la pile *) external push_ra : tcode -> unit = "coq_push_ra" external push_val : values -> unit = "coq_push_val" external push_arguments : arguments -> unit = "coq_push_arguments" external push_vstack : vstack -> int -> unit = "coq_push_vstack" (* interpreteur *) external interprete : tcode -> values -> vm_env -> int -> values = "coq_interprete_ml" (* Functions over arguments *) let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2 let arg args i = if 0 <= i && i < (nargs args) then val_of_obj (Obj.field (Obj.repr args) (i+2)) else invalid_arg ("Vm.arg size = "^(string_of_int (nargs args))^ " acces "^(string_of_int i)) (* Apply a value to arguments contained in [vargs] *) let apply_arguments vf vargs = let n = nargs vargs in if Int.equal n 0 then vf else begin push_ra stop; push_arguments vargs; interprete (fun_code vf) vf (Obj.magic vf) (n - 1) end (* Apply value [vf] to an array of argument values [varray] *) let apply_varray vf varray = let n = Array.length varray in if Int.equal n 0 then vf else begin push_ra stop; (* The fun code of [vf] will make sure we have enough stack, so we put 0 here. *) push_vstack varray 0; interprete (fun_code vf) vf (Obj.magic vf) (n - 1) end (*************************************************) (* Destructors ***********************************) (*************************************************) let uni_lvl_val (v : values) : Univ.universe_level = let whd = Obj.magic v in match whd with | Vuniv_level lvl -> lvl | _ -> let pr = let open Pp in match whd with | Vsort _ -> str "Vsort" | Vprod _ -> str "Vprod" | Vfun _ -> str "Vfun" | Vfix _ -> str "Vfix" | Vcofix _ -> str "Vcofix" | Vconstr_const i -> str "Vconstr_const" | Vconstr_block b -> str "Vconstr_block" | Vatom_stk (a,stk) -> str "Vatom_stk" | _ -> assert false in CErrors.anomaly Pp.( strbrk "Parsing virtual machine value expected universe level, got " ++ pr) let rec whd_accu a stk = let stk = if Int.equal (Obj.size a) 2 then stk else Zapp (Obj.obj a) :: stk in let at = Obj.field a 1 in match Obj.tag at with | i when Int.equal i type_atom_tag -> begin match stk with | [Zapp args] -> let u = ref (Obj.obj (Obj.field at 0)) in for i = 0 to nargs args - 1 do u := Univ.Universe.sup !u (Univ.Universe.make (uni_lvl_val (arg args i))) done; Vsort (Type !u) | _ -> assert false end | i when i <= max_atom_tag -> Vatom_stk(Obj.magic at, stk) | i when Int.equal i proj_tag -> let zproj = Zproj (Obj.obj (Obj.field at 0)) in whd_accu (Obj.field at 1) (zproj :: stk) | i when Int.equal i fix_app_tag -> let fa = Obj.field at 1 in let zfix = Zfix (Obj.obj (Obj.field fa 1), Obj.obj fa) in whd_accu (Obj.field at 0) (zfix :: stk) | i when Int.equal i switch_tag -> let zswitch = Zswitch (Obj.obj (Obj.field at 1)) in whd_accu (Obj.field at 0) (zswitch :: stk) | i when Int.equal i cofix_tag -> let vcfx = Obj.obj (Obj.field at 0) in let to_up = Obj.obj a in begin match stk with | [] -> Vcofix(vcfx, to_up, None) | [Zapp args] -> Vcofix(vcfx, to_up, Some args) | _ -> assert false end | i when Int.equal i cofix_evaluated_tag -> let vcofix = Obj.obj (Obj.field at 0) in let res = Obj.obj a in begin match stk with | [] -> Vcofix(vcofix, res, None) | [Zapp args] -> Vcofix(vcofix, res, Some args) | _ -> assert false end | tg -> CErrors.anomaly Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg) external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" let whd_val : values -> whd = fun v -> let o = Obj.repr v in if Obj.is_int o then Vconstr_const (Obj.obj o) else let tag = Obj.tag o in if tag = accu_tag then ( if Int.equal (Obj.size o) 1 then Obj.obj o (* sort *) else if is_accumulate (fun_code o) then whd_accu o [] else Vprod(Obj.obj o)) else if tag = Obj.closure_tag || tag = Obj.infix_tag then (match kind_of_closure o with | 0 -> Vfun(Obj.obj o) | 1 -> Vfix(Obj.obj o, None) | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o)) | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work")) else Vconstr_block(Obj.obj o) (**********************************************) (* Constructors *******************************) (**********************************************) let obj_of_atom : atom -> Obj.t = fun a -> let res = Obj.new_block accu_tag 2 in Obj.set_field res 0 (Obj.repr accumulate); Obj.set_field res 1 (Obj.repr a); res (* obj_of_str_const : structured_constant -> Obj.t *) let rec obj_of_str_const str = match str with | Const_sorts s -> Obj.repr (Vsort s) | Const_ind ind -> obj_of_atom (Aind ind) | Const_proj p -> Obj.repr p | Const_b0 tag -> Obj.repr tag | Const_bn(tag, args) -> let len = Array.length args in let res = Obj.new_block tag len in for i = 0 to len - 1 do Obj.set_field res i (obj_of_str_const args.(i)) done; res | Const_univ_level l -> Obj.repr (Vuniv_level l) | Const_type u -> obj_of_atom (Atype u) let val_of_obj o = ((Obj.obj o) : values) let val_of_str_const str = val_of_obj (obj_of_str_const str) let val_of_atom a = val_of_obj (obj_of_atom a) let atom_of_proj kn v = let r = Obj.new_block proj_tag 2 in Obj.set_field r 0 (Obj.repr kn); Obj.set_field r 1 (Obj.repr v); ((Obj.obj r) : atom) let val_of_proj kn v = val_of_atom (atom_of_proj kn v) module IdKeyHash = struct type t = constant tableKey let equal = Names.eq_table_key Constant.equal open Hashset.Combine let hash = function | ConstKey c -> combinesmall 1 (Constant.hash c) | VarKey id -> combinesmall 2 (Id.hash id) | RelKey i -> combinesmall 3 (Int.hash i) end module KeyTable = Hashtbl.Make(IdKeyHash) let idkey_tbl = KeyTable.create 31 let val_of_idkey key = try KeyTable.find idkey_tbl key with Not_found -> let v = val_of_atom (Aid key) in KeyTable.add idkey_tbl key v; v let val_of_rel k = val_of_idkey (RelKey k) let val_of_named id = val_of_idkey (VarKey id) let val_of_constant c = val_of_idkey (ConstKey c) external val_of_annot_switch : annot_switch -> values = "%identity" let mkrel_vstack k arity = let max = k + arity - 1 in Array.init arity (fun i -> val_of_rel (max - i)) (*************************************************) (** Operations manipulating data types ***********) (*************************************************) (* Functions over products *) let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0) let codom : vprod -> vfun = fun p -> (Obj.obj (Obj.field (Obj.repr p) 1)) (* Functions over vfun *) external closure_arity : vfun -> int = "coq_closure_arity" let body_of_vfun k vf = let vargs = mkrel_vstack k 1 in apply_varray (Obj.magic vf) vargs let decompose_vfun2 k vf1 vf2 = let arity = min (closure_arity vf1) (closure_arity vf2) in assert (0 < arity && arity < Sys.max_array_length); let vargs = mkrel_vstack k arity in let v1 = apply_varray (Obj.magic vf1) vargs in let v2 = apply_varray (Obj.magic vf2) vargs in arity, v1, v2 (* Functions over fixpoint *) let first o = (offset_closure o (offset o)) let last o = (Obj.field o (Obj.size o - 1)) let current_fix vf = - (offset (Obj.repr vf) / 2) let unsafe_fb_code fb i = tcode_of_obj (Obj.field (Obj.repr fb) (2 * i)) let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1 let rec_args vf = let fb = first (Obj.repr vf) in let size = Obj.size (last fb) in Array.init size (unsafe_rec_arg fb) exception FALSE let check_fix f1 f2 = let i1, i2 = current_fix f1, current_fix f2 in (* Checking starting point *) if i1 = i2 then let fb1,fb2 = first (Obj.repr f1), first (Obj.repr f2) in let n = Obj.size (last fb1) in (* Checking number of definitions *) if n = Obj.size (last fb2) then (* Checking recursive arguments *) try for i = 0 to n - 1 do if unsafe_rec_arg fb1 i <> unsafe_rec_arg fb2 i then raise FALSE done; true with FALSE -> false else false else false (* Functions over vfix *) external atom_rel : unit -> atom array = "get_coq_atom_tbl" external realloc_atom_rel : int -> unit = "realloc_coq_atom_tbl" let relaccu_tbl = let atom_rel = atom_rel() in let len = Array.length atom_rel in for i = 0 to len - 1 do atom_rel.(i) <- Aid (RelKey i) done; ref (Array.init len mkAccuCode) let relaccu_code i = let len = Array.length !relaccu_tbl in if i < len then !relaccu_tbl.(i) else begin realloc_atom_rel i; let atom_rel = atom_rel () in let nl = Array.length atom_rel in for j = len to nl - 1 do atom_rel.(j) <- Aid(RelKey j) done; relaccu_tbl := Array.init nl (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j); !relaccu_tbl.(i) end let reduce_fix k vf = let fb = first (Obj.repr vf) in (* computing types *) let fc_typ = ((Obj.obj (last fb)) : tcode array) in let ndef = Array.length fc_typ in let et = offset_closure fb (2*(ndef - 1)) in let ftyp = Array.map (fun c -> interprete c crazy_val (Obj.magic et) 0) fc_typ in (* Construction of the environment of fix bodies *) let e = Obj.dup fb in for i = 0 to ndef - 1 do Obj.set_field e (2 * i) (Obj.repr (relaccu_code (k + i))) done; let fix_body i = let jump_grabrec c = offset_tcode c 2 in let c = jump_grabrec (unsafe_fb_code fb i) in let res = Obj.new_block Obj.closure_tag 2 in Obj.set_field res 0 (Obj.repr c); Obj.set_field res 1 (offset_closure e (2*i)); ((Obj.obj res) : vfun) in (Array.init ndef fix_body, ftyp) (* Functions over vcofix *) let get_fcofix vcf i = match whd_val (Obj.obj (Obj.field (Obj.repr vcf) (i+1))) with | Vcofix(vcfi, _, _) -> vcfi | _ -> assert false let current_cofix vcf = let ndef = Obj.size (last (Obj.repr vcf)) in let rec find_cofix pos = if pos < ndef then if get_fcofix vcf pos == vcf then pos else find_cofix (pos+1) else raise Not_found in try find_cofix 0 with Not_found -> assert false let check_cofix vcf1 vcf2 = (current_cofix vcf1 = current_cofix vcf2) && (Obj.size (last (Obj.repr vcf1)) = Obj.size (last (Obj.repr vcf2))) let reduce_cofix k vcf = let fc_typ = ((Obj.obj (last (Obj.repr vcf))) : tcode array) in let ndef = Array.length fc_typ in let ftyp = (* Evaluate types *) Array.map (fun c -> interprete c crazy_val (Obj.magic vcf) 0) fc_typ in (* Construction of the environment of cofix bodies *) let e = Obj.dup (Obj.repr vcf) in for i = 0 to ndef - 1 do Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) done; let cofix_body i = let vcfi = get_fcofix vcf i in let c = Obj.field (Obj.repr vcfi) 0 in Obj.set_field e 0 c; let atom = Obj.new_block cofix_tag 1 in let self = Obj.new_block accu_tag 2 in Obj.set_field self 0 (Obj.repr accumulate); Obj.set_field self 1 (Obj.repr atom); apply_varray (Obj.obj e) [|Obj.obj self|] in (Array.init ndef cofix_body, ftyp) (* Functions over vblock *) let btag : vblock -> int = fun b -> Obj.tag (Obj.repr b) let bsize : vblock -> int = fun b -> Obj.size (Obj.repr b) let bfield b i = if 0 <= i && i < (bsize b) then val_of_obj (Obj.field (Obj.repr b) i) else invalid_arg "Vm.bfield" (* Functions over vswitch *) let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl let case_info sw = sw.sw_annot.ci let type_of_switch sw = (* The fun code of types will make sure we have enough stack, so we put 0 here. *) push_vstack sw.sw_stk 0; interprete sw.sw_type_code crazy_val sw.sw_env 0 let branch_arg k (tag,arity) = if Int.equal arity 0 then ((Obj.magic tag):values) else let b, ofs = if tag < last_variant_tag then Obj.new_block tag arity, 0 else let b = Obj.new_block last_variant_tag (arity+1) in Obj.set_field b 0 (Obj.repr (tag-last_variant_tag)); b,1 in for i = ofs to ofs + arity - 1 do Obj.set_field b i (Obj.repr (val_of_rel (k+i))) done; val_of_obj b let apply_switch sw arg = let tc = sw.sw_annot.tailcall in if tc then (push_ra stop;push_vstack sw.sw_stk sw.sw_annot.max_stack_size) else (push_vstack sw.sw_stk sw.sw_annot.max_stack_size; push_ra (popstop_code (Array.length sw.sw_stk))); interprete sw.sw_code arg sw.sw_env 0 let branch_of_switch k sw = let eval_branch (_,arity as ta) = let arg = branch_arg k ta in let v = apply_switch sw arg in (arity, v) in Array.map eval_branch sw.sw_annot.rtbl (* Apply the term represented by a under stack stk to argument v *) (* t = a stk --> t v *) let rec apply_stack a stk v = match stk with | [] -> apply_varray a [|v|] | Zapp args :: stk -> apply_stack (apply_arguments a args) stk v | Zproj kn :: stk -> apply_stack (val_of_proj kn a) stk v | Zfix(f,args) :: stk -> let a,stk = match stk with | Zapp args' :: stk -> push_ra stop; push_arguments args'; push_val a; push_arguments args; let a = interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args+ nargs args') in a, stk | _ -> push_ra stop; push_val a; push_arguments args; let a = interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args) in a, stk in apply_stack a stk v | Zswitch sw :: stk -> apply_stack (apply_switch sw a) stk v let apply_whd k whd = let v = val_of_rel k in match whd with | Vsort _ | Vprod _ | Vconstr_const _ | Vconstr_block _ -> assert false | Vfun f -> body_of_vfun k f | Vfix(f, None) -> push_ra stop; push_val v; interprete (fun_code f) (Obj.magic f) (Obj.magic f) 0 | Vfix(f, Some args) -> push_ra stop; push_val v; push_arguments args; interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args) | Vcofix(_,to_up,_) -> push_ra stop; push_val v; interprete (fun_code to_up) (Obj.magic to_up) (Obj.magic to_up) 0 | Vatom_stk(a,stk) -> apply_stack (val_of_atom a) stk v | Vuniv_level lvl -> assert false let rec pr_atom a = Pp.(match a with | Aid c -> str "Aid(" ++ (match c with | ConstKey c -> Names.pr_con c | RelKey i -> str "#" ++ int i | _ -> str "...") ++ str ")" | Aind (mi,i) -> str "Aind(" ++ Names.pr_mind mi ++ str "#" ++ int i ++ str ")" | Atype _ -> str "Atype(") and pr_whd w = Pp.(match w with | Vsort _ -> str "Vsort" | Vprod _ -> str "Vprod" | Vfun _ -> str "Vfun" | Vfix _ -> str "Vfix" | Vcofix _ -> str "Vcofix" | Vconstr_const i -> str "Vconstr_const(" ++ int i ++ str ")" | Vconstr_block b -> str "Vconstr_block" | Vatom_stk (a,stk) -> str "Vatom_stk(" ++ pr_atom a ++ str ", " ++ pr_stack stk ++ str ")" | Vuniv_level _ -> assert false) and pr_stack stk = Pp.(match stk with | [] -> str "[]" | s :: stk -> pr_zipper s ++ str " :: " ++ pr_stack stk) and pr_zipper z = Pp.(match z with | Zapp args -> str "Zapp(len = " ++ int (nargs args) ++ str ")" | Zfix (f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")" | Zswitch s -> str "Zswitch(...)" | Zproj c -> str "Zproj(" ++ Names.pr_con c ++ str ")") coq-8.6/kernel/pre_env.mli0000644000175000017500000000600613022274260015102 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (values * Id.Set.t) option val dummy_lazy_val : unit -> lazy_val val build_lazy_val : lazy_val -> (values * Id.Set.t) -> unit type named_context_val = private { env_named_ctx : Context.Named.t; env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; } type env = { env_globals : globals; env_named_context : named_context_val; env_rel_context : Context.Rel.t; env_rel_val : lazy_val list; env_nb_rel : int; env_stratification : stratification; env_typing_flags : typing_flags; env_conv_oracle : Conv_oracle.oracle; retroknowledge : Retroknowledge.retroknowledge; indirect_pterms : Opaqueproof.opaquetab; } val empty_named_context_val : named_context_val val empty_env : env (** Rel context *) val nb_rel : env -> int val push_rel : Context.Rel.Declaration.t -> env -> env val lookup_rel_val : int -> env -> lazy_val val env_of_rel : int -> env -> env (** Named context *) val push_named_context_val : Context.Named.Declaration.t -> named_context_val -> named_context_val val push_named_context_val_val : Context.Named.Declaration.t -> lazy_val -> named_context_val -> named_context_val val match_named_context_val : named_context_val -> (Context.Named.Declaration.t * lazy_val * named_context_val) option val map_named_val : (constr -> constr) -> named_context_val -> named_context_val val push_named : Context.Named.Declaration.t -> env -> env val lookup_named : Id.t -> env -> Context.Named.Declaration.t val lookup_named_val : Id.t -> env -> lazy_val val env_of_named : Id.t -> env -> env (** Global constants *) val lookup_constant_key : constant -> env -> constant_key val lookup_constant : constant -> env -> constant_body (** Mutual Inductives *) val lookup_mind_key : mutual_inductive -> env -> mind_key val lookup_mind : mutual_inductive -> env -> mutual_inductive_body coq-8.6/kernel/opaqueproof.ml0000644000175000017500000001231113022274260015627 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* if not (Int.Map.mem i prfs) then CErrors.anomaly (Pp.str "Indirect in a different table") else CErrors.anomaly (Pp.str "Already an indirect opaque") | Direct (d,cu) -> let cu = Future.chain ~pure:true cu (fun (c, u) -> hcons_constr c, u) in let id = Int.Map.cardinal prfs in let prfs = Int.Map.add id (d,cu) prfs in let ndp = if DirPath.equal dp odp then odp else if DirPath.equal odp DirPath.initial then dp else CErrors.anomaly (Pp.str "Using the same opaque table for multiple dirpaths") in Indirect ([],dp,id), (prfs, ndp) let subst_opaque sub = function | Indirect (s,dp,i) -> Indirect (sub::s,dp,i) | Direct _ -> CErrors.anomaly (Pp.str "Substituting a Direct opaque") let iter_direct_opaque f = function | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque") | Direct (d,cu) -> Direct (d,Future.chain ~pure:true cu (fun (c, u) -> f c; c, u)) let discharge_direct_opaque ~cook_constr ci = function | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque") | Direct (d,cu) -> Direct (ci::d,Future.chain ~pure:true cu (fun (c, u) -> cook_constr c, u)) let join_opaque (prfs,odp) = function | Direct (_,cu) -> ignore(Future.join cu) | Indirect (_,dp,i) -> if DirPath.equal dp odp then let fp = snd (Int.Map.find i prfs) in ignore(Future.join fp) let uuid_opaque (prfs,odp) = function | Direct (_,cu) -> Some (Future.uuid cu) | Indirect (_,dp,i) -> if DirPath.equal dp odp then Some (Future.uuid (snd (Int.Map.find i prfs))) else None let force_proof (prfs,odp) = function | Direct (_,cu) -> fst(Future.force cu) | Indirect (l,dp,i) -> let pt = if DirPath.equal dp odp then Future.chain ~pure:true (snd (Int.Map.find i prfs)) fst else !get_opaque dp i in let c = Future.force pt in force_constr (List.fold_right subst_substituted l (from_val c)) let force_constraints (prfs,odp) = function | Direct (_,cu) -> snd(Future.force cu) | Indirect (_,dp,i) -> if DirPath.equal dp odp then snd (Future.force (snd (Int.Map.find i prfs))) else match !get_univ dp i with | None -> Univ.ContextSet.empty | Some u -> Future.force u let get_constraints (prfs,odp) = function | Direct (_,cu) -> Some(Future.chain ~pure:true cu snd) | Indirect (_,dp,i) -> if DirPath.equal dp odp then Some(Future.chain ~pure:true (snd (Int.Map.find i prfs)) snd) else !get_univ dp i let get_proof (prfs,odp) = function | Direct (_,cu) -> Future.chain ~pure:true cu fst | Indirect (l,dp,i) -> let pt = if DirPath.equal dp odp then Future.chain ~pure:true (snd (Int.Map.find i prfs)) fst else !get_opaque dp i in Future.chain ~pure:true pt (fun c -> force_constr (List.fold_right subst_substituted l (from_val c))) module FMap = Future.UUIDMap let a_constr = Future.from_val (Term.mkRel 1) let a_univ = Future.from_val Univ.ContextSet.empty let a_discharge : cooking_info list = [] let dump (otab,_) = let n = Int.Map.cardinal otab in let opaque_table = Array.make n a_constr in let univ_table = Array.make n a_univ in let disch_table = Array.make n a_discharge in let f2t_map = ref FMap.empty in Int.Map.iter (fun n (d,cu) -> let c, u = Future.split2 ~greedy:true cu in Future.sink u; Future.sink c; opaque_table.(n) <- c; univ_table.(n) <- u; disch_table.(n) <- d; f2t_map := FMap.add (Future.uuid cu) n !f2t_map) otab; opaque_table, univ_table, disch_table, !f2t_map coq-8.6/kernel/declarations.mli0000644000175000017500000002452113022274260016116 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* anomaly (Pp.str "get_load_paths not initialized") : unit -> string list) let open_header = ["Nativevalues"; "Nativecode"; "Nativelib"; "Nativeconv"; "Declaremods"] let open_header = List.map mk_open open_header (* Directory where compiled files are stored *) let output_dir = ".coq-native" (* Extension of genereted ml files, stored for debugging purposes *) let source_ext = ".native" let ( / ) = Filename.concat (* We have to delay evaluation of include_dirs because coqlib cannot be guessed until flags have been properly initialized *) let include_dirs () = [Filename.temp_dir_name; coqlib () / "kernel"; coqlib () / "library"] (* Pointer to the function linking an ML object into coq's toplevel *) let load_obj = ref (fun x -> () : string -> unit) let rt1 = ref (dummy_value ()) let rt2 = ref (dummy_value ()) let get_ml_filename () = let filename = Filename.temp_file "Coq_native" source_ext in let prefix = Filename.chop_extension (Filename.basename filename) ^ "." in filename, prefix let write_ml_code fn ?(header=[]) code = let header = open_header@header in let ch_out = open_out fn in let fmt = Format.formatter_of_out_channel ch_out in List.iter (pp_global fmt) (header@code); close_out ch_out let warn_native_compiler_failed = let print = function | Inl (Unix.WEXITED n) -> Pp.(strbrk "Native compiler exited with status" ++ str" " ++ int n) | Inl (Unix.WSIGNALED n) -> Pp.(strbrk "Native compiler killed by signal" ++ str" " ++ int n) | Inl (Unix.WSTOPPED n) -> Pp.(strbrk "Native compiler stopped by signal" ++ str" " ++ int n) | Inr e -> Pp.(strbrk "Native compiler failed with error: " ++ strbrk (Unix.error_message e)) in CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print let call_compiler ml_filename = let load_path = !get_load_paths () in let load_path = List.map (fun dn -> dn / output_dir) load_path in let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (include_dirs () @ load_path)) in let f = Filename.chop_extension ml_filename in let link_filename = f ^ ".cmo" in let link_filename = Dynlink.adapt_filename link_filename in let remove f = if Sys.file_exists f then Sys.remove f in remove link_filename; remove (f ^ ".cmi"); let args = (if Dynlink.is_native then "opt" else "ocamlc") ::(if Dynlink.is_native then "-shared" else "-c") ::"-o"::link_filename ::"-rectypes" ::"-w"::"a" ::include_dirs @ ["-impl"; ml_filename] in if !Flags.debug then Feedback.msg_debug (Pp.str (ocamlfind () ^ " " ^ (String.concat " " args))); try let res = CUnix.sys_command (ocamlfind ()) args in let res = match res with | Unix.WEXITED 0 -> true | Unix.WEXITED n | Unix.WSIGNALED n | Unix.WSTOPPED n -> warn_native_compiler_failed (Inl res); false in res, link_filename with Unix.Unix_error (e,_,_) -> warn_native_compiler_failed (Inr e); false, link_filename let compile fn code = write_ml_code fn code; let r = call_compiler fn in if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn; r let compile_library dir code fn = let header = mk_library_header dir in let fn = fn ^ source_ext in let basename = Filename.basename fn in let dirname = Filename.dirname fn in let dirname = dirname / output_dir in let () = try Unix.mkdir dirname 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> () in let fn = dirname / basename in write_ml_code fn ~header code; let r = fst (call_compiler fn) in if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn; r (* call_linker links dynamically the code for constants in environment or a *) (* conversion test. *) let call_linker ?(fatal=true) prefix f upds = rt1 := dummy_value (); rt2 := dummy_value (); if not (Sys.file_exists f) then begin let msg = "Cannot find native compiler file " ^ f in if fatal then CErrors.error msg else if !Flags.debug then Feedback.msg_debug (Pp.str msg) end else (try if Dynlink.is_native then Dynlink.loadfile f else !load_obj f; register_native_file prefix with Dynlink.Error e as exn -> let exn = CErrors.push exn in let msg = "Dynlink error, " ^ Dynlink.error_message e in if fatal then (Feedback.msg_error (Pp.str msg); iraise exn) else if !Flags.debug then Feedback.msg_debug (Pp.str msg)); match upds with Some upds -> update_locations upds | _ -> () let link_library ~prefix ~dirname ~basename = let f = dirname / output_dir / basename in call_linker ~fatal:false prefix f None coq-8.6/kernel/environ.ml0000644000175000017500000005405213022274260014757 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | _ -> false let type_in_type env = not (typing_flags env).check_universes let deactivated_guard env = not (typing_flags env).check_guarded let universes env = env.env_stratification.env_universes let named_context env = env.env_named_context.env_named_ctx let named_context_val env = env.env_named_context let rel_context env = env.env_rel_context let opaque_tables env = env.indirect_pterms let set_opaque_tables env indirect_pterms = { env with indirect_pterms } let empty_context env = match env.env_rel_context, env.env_named_context.env_named_ctx with | [], [] -> true | _ -> false (* Rel context *) let lookup_rel n env = Context.Rel.lookup n env.env_rel_context let evaluable_rel n env = is_local_def (lookup_rel n env) let nb_rel env = env.env_nb_rel let push_rel = push_rel let push_rel_context ctxt x = Context.Rel.fold_outside push_rel ctxt ~init:x let push_rec_types (lna,typarray,_) env = let ctxt = Array.map2_i (fun i na t -> LocalAssum (na, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt let fold_rel_context f env ~init = let rec fold_right env = match env.env_rel_context with | [] -> init | rd::rc -> let env = { env with env_rel_context = rc; env_rel_val = List.tl env.env_rel_val; env_nb_rel = env.env_nb_rel - 1 } in f env rd (fold_right env) in fold_right env (* Named context *) let named_context_of_val c = c.env_named_ctx (* [map_named_val f ctxt] apply [f] to the body and the type of each declarations. *** /!\ *** [f t] should be convertible with t *) let map_named_val = map_named_val let empty_named_context = Context.Named.empty let push_named = push_named let push_named_context = List.fold_right push_named let push_named_context_val = push_named_context_val let val_of_named_context ctxt = List.fold_right push_named_context_val ctxt empty_named_context_val let lookup_named = lookup_named let lookup_named_val id ctxt = fst (Id.Map.find id ctxt.env_named_map) let eq_named_context_val c1 c2 = c1 == c2 || Context.Named.equal (named_context_of_val c1) (named_context_of_val c2) (* A local const is evaluable if it is defined *) open Context.Named.Declaration let named_type id env = get_type (lookup_named id env) let named_body id env = get_value (lookup_named id env) let evaluable_named id env = match named_body id env with | Some _ -> true | _ -> false let reset_with_named_context ctxt env = { env with env_named_context = ctxt; env_rel_context = Context.Rel.empty; env_rel_val = []; env_nb_rel = 0 } let reset_context = reset_with_named_context empty_named_context_val let pop_rel_context n env = let ctxt = env.env_rel_context in { env with env_rel_context = List.skipn n ctxt; env_nb_rel = env.env_nb_rel - n } let fold_named_context f env ~init = let rec fold_right env = match match_named_context_val env.env_named_context with | None -> init | Some (d, v, rem) -> let env = reset_with_named_context rem env in f env d (fold_right env) in fold_right env let fold_named_context_reverse f ~init env = Context.Named.fold_inside f ~init:init (named_context env) (* Universe constraints *) let map_universes f env = let s = env.env_stratification in { env with env_stratification = { s with env_universes = f s.env_universes } } let add_constraints c env = if Univ.Constraint.is_empty c then env else map_universes (UGraph.merge_constraints c) env let check_constraints c env = UGraph.check_constraints c env.env_stratification.env_universes let push_constraints_to_env (_,univs) env = add_constraints univs env let add_universes strict ctx g = let g = Array.fold_left (* Be lenient, module typing reintroduces universes and constraints due to includes *) (fun g v -> try UGraph.add_universe v strict g with UGraph.AlreadyDeclared -> g) g (Univ.Instance.to_array (Univ.UContext.instance ctx)) in UGraph.merge_constraints (Univ.UContext.constraints ctx) g let push_context ?(strict=false) ctx env = map_universes (add_universes strict ctx) env let add_universes_set strict ctx g = let g = Univ.LSet.fold (fun v g -> try UGraph.add_universe v strict g with UGraph.AlreadyDeclared -> g) (Univ.ContextSet.levels ctx) g in UGraph.merge_constraints (Univ.ContextSet.constraints ctx) g let push_context_set ?(strict=false) ctx env = map_universes (add_universes_set strict ctx) env let set_engagement c env = (* Unsafe *) { env with env_stratification = { env.env_stratification with env_engagement = c } } let set_typing_flags c env = (* Unsafe *) { env with env_typing_flags = c } (* Global constants *) let lookup_constant = lookup_constant let no_link_info = NotLinked let add_constant_key kn cb linkinfo env = let new_constants = Cmap_env.add kn (cb,(ref linkinfo, ref None)) env.env_globals.env_constants in let new_globals = { env.env_globals with env_constants = new_constants } in { env with env_globals = new_globals } let add_constant kn cb env = add_constant_key kn cb no_link_info env let constraints_of cb u = let univs = cb.const_universes in Univ.subst_instance_constraints u (Univ.UContext.constraints univs) let map_regular_arity f = function | RegularArity a as ar -> let a' = f a in if a' == a then ar else RegularArity a' | TemplateArity _ -> assert false (* constant_type gives the type of a constant *) let constant_type env (kn,u) = let cb = lookup_constant kn env in if cb.const_polymorphic then let csts = constraints_of cb u in (map_regular_arity (subst_instance_constr u) cb.const_type, csts) else cb.const_type, Univ.Constraint.empty let constant_context env kn = let cb = lookup_constant kn env in if cb.const_polymorphic then cb.const_universes else Univ.UContext.empty type const_evaluation_result = NoBody | Opaque | IsProj exception NotEvaluableConst of const_evaluation_result let constant_value env (kn,u) = let cb = lookup_constant kn env in if cb.const_proj = None then match cb.const_body with | Def l_body -> if cb.const_polymorphic then let csts = constraints_of cb u in (subst_instance_constr u (Mod_subst.force_constr l_body), csts) else Mod_subst.force_constr l_body, Univ.Constraint.empty | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) else raise (NotEvaluableConst IsProj) let constant_opt_value env cst = try Some (constant_value env cst) with NotEvaluableConst _ -> None let constant_value_and_type env (kn, u) = let cb = lookup_constant kn env in if cb.const_polymorphic then let cst = constraints_of cb u in let b' = match cb.const_body with | Def l_body -> Some (subst_instance_constr u (Mod_subst.force_constr l_body)) | OpaqueDef _ -> None | Undef _ -> None in b', map_regular_arity (subst_instance_constr u) cb.const_type, cst else let b' = match cb.const_body with | Def l_body -> Some (Mod_subst.force_constr l_body) | OpaqueDef _ -> None | Undef _ -> None in b', cb.const_type, Univ.Constraint.empty (* These functions should be called under the invariant that [env] already contains the constraints corresponding to the constant application. *) (* constant_type gives the type of a constant *) let constant_type_in env (kn,u) = let cb = lookup_constant kn env in if cb.const_polymorphic then map_regular_arity (subst_instance_constr u) cb.const_type else cb.const_type let constant_value_in env (kn,u) = let cb = lookup_constant kn env in match cb.const_body with | Def l_body -> let b = Mod_subst.force_constr l_body in subst_instance_constr u b | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) let constant_opt_value_in env cst = try Some (constant_value_in env cst) with NotEvaluableConst _ -> None (* A global const is evaluable if it is defined and not opaque *) let evaluable_constant kn env = let cb = lookup_constant kn env in match cb.const_body with | Def _ -> true | OpaqueDef _ -> false | Undef _ -> false let polymorphic_constant cst env = (lookup_constant cst env).const_polymorphic let polymorphic_pconstant (cst,u) env = if Univ.Instance.is_empty u then false else polymorphic_constant cst env let type_in_type_constant cst env = not (lookup_constant cst env).const_typing_flags.check_universes let template_polymorphic_constant cst env = match (lookup_constant cst env).const_type with | TemplateArity _ -> true | RegularArity _ -> false let template_polymorphic_pconstant (cst,u) env = if not (Univ.Instance.is_empty u) then false else template_polymorphic_constant cst env let lookup_projection cst env = match (lookup_constant (Projection.constant cst) env).const_proj with | Some pb -> pb | None -> anomaly (Pp.str "lookup_projection: constant is not a projection") let is_projection cst env = match (lookup_constant cst env).const_proj with | Some _ -> true | None -> false (* Mutual Inductives *) let lookup_mind = lookup_mind let polymorphic_ind (mind,i) env = (lookup_mind mind env).mind_polymorphic let polymorphic_pind (ind,u) env = if Univ.Instance.is_empty u then false else polymorphic_ind ind env let type_in_type_ind (mind,i) env = not (lookup_mind mind env).mind_typing_flags.check_universes let template_polymorphic_ind (mind,i) env = match (lookup_mind mind env).mind_packets.(i).mind_arity with | TemplateArity _ -> true | RegularArity _ -> false let template_polymorphic_pind (ind,u) env = if not (Univ.Instance.is_empty u) then false else template_polymorphic_ind ind env let add_mind_key kn mind_key env = let new_inds = Mindmap_env.add kn mind_key env.env_globals.env_inductives in let new_globals = { env.env_globals with env_inductives = new_inds } in { env with env_globals = new_globals } let add_mind kn mib env = let li = ref no_link_info in add_mind_key kn (mib, li) env (* Lookup of section variables *) let lookup_constant_variables c env = let cmap = lookup_constant c env in Context.Named.to_vars cmap.const_hyps let lookup_inductive_variables (kn,i) env = let mis = lookup_mind kn env in Context.Named.to_vars mis.mind_hyps let lookup_constructor_variables (ind,_) env = lookup_inductive_variables ind env (* Returns the list of global variables in a term *) let vars_of_global env constr = match kind_of_term constr with Var id -> Id.Set.singleton id | Const (kn, _) -> lookup_constant_variables kn env | Ind (ind, _) -> lookup_inductive_variables ind env | Construct (cstr, _) -> lookup_constructor_variables cstr env (** FIXME: is Proj missing? *) | _ -> raise Not_found let global_vars_set env constr = let rec filtrec acc c = let acc = match kind_of_term c with | Var _ | Const _ | Ind _ | Construct _ -> Id.Set.union (vars_of_global env c) acc | _ -> acc in fold_constr filtrec acc c in filtrec Id.Set.empty constr (* [keep_hyps env ids] keeps the part of the section context of [env] which contains the variables of the set [ids], and recursively the variables contained in the types of the needed variables. *) let really_needed env needed = Context.Named.fold_inside (fun need decl -> if Id.Set.mem (get_id decl) need then let globc = match decl with | LocalAssum _ -> Id.Set.empty | LocalDef (_,c,_) -> global_vars_set env c in Id.Set.union (global_vars_set env (get_type decl)) (Id.Set.union globc need) else need) ~init:needed (named_context env) let keep_hyps env needed = let really_needed = really_needed env needed in Context.Named.fold_outside (fun d nsign -> if Id.Set.mem (get_id d) really_needed then Context.Named.add d nsign else nsign) (named_context env) ~init:empty_named_context (* Modules *) let add_modtype mtb env = let mp = mtb.mod_mp in let new_modtypes = MPmap.add mp mtb env.env_globals.env_modtypes in let new_globals = { env.env_globals with env_modtypes = new_modtypes } in { env with env_globals = new_globals } let shallow_add_module mb env = let mp = mb.mod_mp in let new_mods = MPmap.add mp mb env.env_globals.env_modules in let new_globals = { env.env_globals with env_modules = new_mods } in { env with env_globals = new_globals } let lookup_module mp env = MPmap.find mp env.env_globals.env_modules let lookup_modtype mp env = MPmap.find mp env.env_globals.env_modtypes (*s Judgments. *) type unsafe_judgment = { uj_val : constr; uj_type : types } let make_judge v tj = { uj_val = v; uj_type = tj } let j_val j = j.uj_val let j_type j = j.uj_type type unsafe_type_judgment = { utj_val : constr; utj_type : sorts } (*s Compilation of global declaration *) let compile_constant_body = Cbytegen.compile_constant_body false exception Hyp_not_found let apply_to_hyp ctxt id f = let rec aux rtail ctxt = match match_named_context_val ctxt with | Some (d, v, ctxt) -> if Id.equal (get_id d) id then push_named_context_val_val (f ctxt.env_named_ctx d rtail) v ctxt else let ctxt' = aux (d::rtail) ctxt in push_named_context_val_val d v ctxt' | None -> raise Hyp_not_found in aux [] ctxt (* To be used in Logic.clear_hyps *) let remove_hyps ids check_context check_value ctxt = let rec remove_hyps ctxt = match match_named_context_val ctxt with | None -> empty_named_context_val, false | Some (d, v, rctxt) -> let (ans, seen) = remove_hyps rctxt in if Id.Set.mem (get_id d) ids then (ans, true) else if not seen then ctxt, false else let rctxt' = ans in let d' = check_context d in let v' = check_value v in if d == d' && v == v' && rctxt == rctxt' then ctxt, true else push_named_context_val_val d' v' rctxt', true in fst (remove_hyps ctxt) (*spiwack: the following functions assemble the pieces of the retroknowledge note that the "consistent" register function is available in the module Safetyping, Environ only synchronizes the proactive and the reactive parts*) open Retroknowledge (* lifting of the "get" functions works also for "mem"*) let retroknowledge f env = f env.retroknowledge let registered env field = retroknowledge mem env field let register_one env field entry = { env with retroknowledge = Retroknowledge.add_field env.retroknowledge field entry } (* [register env field entry] may register several fields when needed *) let register env field entry = match field with | KInt31 (grp, Int31Type) -> let i31c = match kind_of_term entry with | Ind i31t -> mkConstructUi (i31t, 1) | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type") in register_one (register_one env (KInt31 (grp,Int31Constructor)) i31c) field entry | field -> register_one env field entry (* the Environ.register function syncrhonizes the proactive and reactive retroknowledge. *) let dispatch = (* subfunction used for static decompilation of int31 (after a vm_compute, see pretyping/vnorm.ml for more information) *) let constr_of_int31 = let nth_digit_plus_one i n = (* calculates the nth (starting with 0) digit of i and adds 1 to it (nth_digit_plus_one 1 3 = 2) *) if Int.equal (i land (1 lsl n)) 0 then 1 else 2 in fun ind -> fun digit_ind -> fun tag -> let array_of_int i = Array.init 31 (fun n -> mkConstruct (digit_ind, nth_digit_plus_one i (30-n))) in (* We check that no bit above 31 is set to one. This assertion used to fail in the VM, and led to conversion tests failing at Qed. *) assert (Int.equal (tag lsr 31) 0); mkApp(mkConstruct(ind, 1), array_of_int tag) in (* subfunction which dispatches the compiling information of an int31 operation which has a specific vm instruction (associates it to the name of the coq definition in the reactive retroknowledge) *) let int31_op n op prim kn = { empty_reactive_info with vm_compiling = Some (Cbytegen.op_compilation n op kn); native_compiling = Some (Nativelambda.compile_prim prim (Univ.out_punivs kn)); } in fun rk value field -> (* subfunction which shortens the (very common) dispatch of operations *) let int31_op_from_const n op prim = match kind_of_term value with | Const kn -> int31_op n op prim kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant") in let int31_binop_from_const op prim = int31_op_from_const 2 op prim in let int31_unop_from_const op prim = int31_op_from_const 1 op prim in match field with | KInt31 (grp, Int31Type) -> let int31bit = (* invariant : the type of bits is registered, otherwise the function would raise Not_found. The invariant is enforced in safe_typing.ml *) match field with | KInt31 (grp, Int31Type) -> Retroknowledge.find rk (KInt31 (grp,Int31Bits)) | _ -> anomaly ~label:"Environ.register" (Pp.str "add_int31_decompilation_from_type called with an abnormal field") in let i31bit_type = match kind_of_term int31bit with | Ind (i31bit_type,_) -> i31bit_type | _ -> anomaly ~label:"Environ.register" (Pp.str "Int31Bits should be an inductive type") in let int31_decompilation = match kind_of_term value with | Ind (i31t,_) -> constr_of_int31 i31t i31bit_type | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type") in { empty_reactive_info with vm_decompile_const = Some int31_decompilation; vm_before_match = Some Cbytegen.int31_escape_before_match; native_before_match = Some (Nativelambda.before_match_int31 i31bit_type); } | KInt31 (_, Int31Constructor) -> { empty_reactive_info with vm_constant_static = Some Cbytegen.compile_structured_int31; vm_constant_dynamic = Some Cbytegen.dynamic_int31_compilation; native_constant_static = Some Nativelambda.compile_static_int31; native_constant_dynamic = Some Nativelambda.compile_dynamic_int31; } | KInt31 (_, Int31Plus) -> int31_binop_from_const Cbytecodes.Kaddint31 Primitives.Int31add | KInt31 (_, Int31PlusC) -> int31_binop_from_const Cbytecodes.Kaddcint31 Primitives.Int31addc | KInt31 (_, Int31PlusCarryC) -> int31_binop_from_const Cbytecodes.Kaddcarrycint31 Primitives.Int31addcarryc | KInt31 (_, Int31Minus) -> int31_binop_from_const Cbytecodes.Ksubint31 Primitives.Int31sub | KInt31 (_, Int31MinusC) -> int31_binop_from_const Cbytecodes.Ksubcint31 Primitives.Int31subc | KInt31 (_, Int31MinusCarryC) -> int31_binop_from_const Cbytecodes.Ksubcarrycint31 Primitives.Int31subcarryc | KInt31 (_, Int31Times) -> int31_binop_from_const Cbytecodes.Kmulint31 Primitives.Int31mul | KInt31 (_, Int31TimesC) -> int31_binop_from_const Cbytecodes.Kmulcint31 Primitives.Int31mulc | KInt31 (_, Int31Div21) -> int31_op_from_const 3 Cbytecodes.Kdiv21int31 Primitives.Int31div21 | KInt31 (_, Int31Diveucl) -> int31_binop_from_const Cbytecodes.Kdivint31 Primitives.Int31diveucl | KInt31 (_, Int31AddMulDiv) -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31 Primitives.Int31addmuldiv | KInt31 (_, Int31Compare) -> int31_binop_from_const Cbytecodes.Kcompareint31 Primitives.Int31compare | KInt31 (_, Int31Head0) -> int31_unop_from_const Cbytecodes.Khead0int31 Primitives.Int31head0 | KInt31 (_, Int31Tail0) -> int31_unop_from_const Cbytecodes.Ktail0int31 Primitives.Int31tail0 | KInt31 (_, Int31Lor) -> int31_binop_from_const Cbytecodes.Klorint31 Primitives.Int31lor | KInt31 (_, Int31Land) -> int31_binop_from_const Cbytecodes.Klandint31 Primitives.Int31land | KInt31 (_, Int31Lxor) -> int31_binop_from_const Cbytecodes.Klxorint31 Primitives.Int31lxor | _ -> empty_reactive_info let _ = Hook.set Retroknowledge.dispatch_hook dispatch coq-8.6/kernel/context.ml0000644000175000017500000003663613022274260014773 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* na (** Return [Some value] for local-declarations and [None] for local-assumptions. *) let get_value = function | LocalAssum _ -> None | LocalDef (_,v,_) -> Some v (** Return the type of the name bound by a given declaration. *) let get_type = function | LocalAssum (_,ty) | LocalDef (_,_,ty) -> ty (** Set the name that is bound by a given declaration. *) let set_name na = function | LocalAssum (_,ty) -> LocalAssum (na, ty) | LocalDef (_,v,ty) -> LocalDef (na, v, ty) (** Set the type of the bound variable in a given declaration. *) let set_type ty = function | LocalAssum (na,_) -> LocalAssum (na, ty) | LocalDef (na,v,_) -> LocalDef (na, v, ty) (** Return [true] iff a given declaration is a local assumption. *) let is_local_assum = function | LocalAssum _ -> true | LocalDef _ -> false (** Return [true] iff a given declaration is a local definition. *) let is_local_def = function | LocalAssum _ -> false | LocalDef _ -> true (** Check whether any term in a given declaration satisfies a given predicate. *) let exists f = function | LocalAssum (_, ty) -> f ty | LocalDef (_, v, ty) -> f v || f ty (** Check whether all terms in a given declaration satisfy a given predicate. *) let for_all f = function | LocalAssum (_, ty) -> f ty | LocalDef (_, v, ty) -> f v && f ty (** Check whether the two given declarations are equal. *) let equal decl1 decl2 = match decl1, decl2 with | LocalAssum (n1,ty1), LocalAssum (n2, ty2) -> Name.equal n1 n2 && Constr.equal ty1 ty2 | LocalDef (n1,v1,ty1), LocalDef (n2,v2,ty2) -> Name.equal n1 n2 && Constr.equal v1 v2 && Constr.equal ty1 ty2 | _ -> false (** Map the name bound by a given declaration. *) let map_name f = function | LocalAssum (na, ty) as decl -> let na' = f na in if na == na' then decl else LocalAssum (na', ty) | LocalDef (na, v, ty) as decl -> let na' = f na in if na == na' then decl else LocalDef (na', v, ty) (** For local assumptions, this function returns the original local assumptions. For local definitions, this function maps the value in the local definition. *) let map_value f = function | LocalAssum _ as decl -> decl | LocalDef (na, v, t) as decl -> let v' = f v in if v == v' then decl else LocalDef (na, v', t) (** Map the type of the name bound by a given declaration. *) let map_type f = function | LocalAssum (na, ty) as decl -> let ty' = f ty in if ty == ty' then decl else LocalAssum (na, ty') | LocalDef (na, v, ty) as decl -> let ty' = f ty in if ty == ty' then decl else LocalDef (na, v, ty') (** Map all terms in a given declaration. *) let map_constr f = function | LocalAssum (na, ty) as decl -> let ty' = f ty in if ty == ty' then decl else LocalAssum (na, ty') | LocalDef (na, v, ty) as decl -> let v' = f v in let ty' = f ty in if v == v' && ty == ty' then decl else LocalDef (na, v', ty') (** Perform a given action on all terms in a given declaration. *) let iter_constr f = function | LocalAssum (_,ty) -> f ty | LocalDef (_,v,ty) -> f v; f ty (** Reduce all terms in a given declaration to a single value. *) let fold f decl acc = match decl with | LocalAssum (n,ty) -> f ty acc | LocalDef (n,v,ty) -> f ty (f v acc) let to_tuple = function | LocalAssum (na, ty) -> na, None, ty | LocalDef (na, v, ty) -> na, Some v, ty let of_tuple = function | n, None, ty -> LocalAssum (n,ty) | n, Some v, ty -> LocalDef (n,v,ty) end (** Rel-context is represented as a list of declarations. Inner-most declarations are at the beginning of the list. Outer-most declarations are at the end of the list. *) type t = Declaration.t list (** empty rel-context *) let empty = [] (** Return a new rel-context enriched by with a given inner-most declaration. *) let add d ctx = d :: ctx (** Return the number of {e local declarations} in a given context. *) let length = List.length (** [extended_rel_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] with n = |Δ| and with the local definitions of [Γ] skipped in [args]. Example: for [x:T,y:=c,z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) let nhyps = let open Declaration in let rec nhyps acc = function | [] -> acc | LocalAssum _ :: hyps -> nhyps (succ acc) hyps | LocalDef _ :: hyps -> nhyps acc hyps in nhyps 0 (** Return a declaration designated by a given de Bruijn index. @raise Not_found if the designated de Bruijn index is not present in the designated rel-context. *) let rec lookup n ctx = match n, ctx with | 1, decl :: _ -> decl | n, _ :: sign -> lookup (n-1) sign | _, [] -> raise Not_found (** Check whether given two rel-contexts are equal. *) let equal = List.equal Declaration.equal (** Map all terms in a given rel-context. *) let map f = List.smartmap (Declaration.map_constr f) (** Perform a given action on every declaration in a given rel-context. *) let iter f = List.iter (Declaration.iter_constr f) (** Reduce all terms in a given rel-context to a single value. Innermost declarations are processed first. *) let fold_inside f ~init = List.fold_left f init (** Reduce all terms in a given rel-context to a single value. Outermost declarations are processed first. *) let fold_outside f l ~init = List.fold_right f l init (** Map a given rel-context to a list where each {e local assumption} is mapped to [true] and each {e local definition} is mapped to [false]. *) let to_tags = let rec aux l = function | [] -> l | Declaration.LocalDef _ :: ctx -> aux (true::l) ctx | Declaration.LocalAssum _ :: ctx -> aux (false::l) ctx in aux [] (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] with n = |Δ| and with the {e local definitions} of [Γ] skipped in [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) let to_extended_list n = let rec reln l p = function | Declaration.LocalAssum _ :: hyps -> reln (Constr.mkRel (n+p) :: l) (p+1) hyps | Declaration.LocalDef _ :: hyps -> reln l (p+1) hyps | [] -> l in reln [] 1 (** [extended_vect n Γ] does the same, returning instead an array. *) let to_extended_vect n hyps = Array.of_list (to_extended_list n hyps) end (** This module represents contexts that can capture non-anonymous variables. Individual declarations are then designated by the identifiers they bind. *) module Named = struct (** Representation of {e local declarations}. *) module Declaration = struct (** local declaration *) type t = | LocalAssum of Id.t * Constr.t (** identifier, type *) | LocalDef of Id.t * Constr.t * Constr.t (** identifier, value, type *) (** Return the identifier bound by a given declaration. *) let get_id = function | LocalAssum (id,_) -> id | LocalDef (id,_,_) -> id (** Return [Some value] for local-declarations and [None] for local-assumptions. *) let get_value = function | LocalAssum _ -> None | LocalDef (_,v,_) -> Some v (** Return the type of the name bound by a given declaration. *) let get_type = function | LocalAssum (_,ty) | LocalDef (_,_,ty) -> ty (** Set the identifier that is bound by a given declaration. *) let set_id id = function | LocalAssum (_,ty) -> LocalAssum (id, ty) | LocalDef (_, v, ty) -> LocalDef (id, v, ty) (** Set the type of the bound variable in a given declaration. *) let set_type ty = function | LocalAssum (id,_) -> LocalAssum (id, ty) | LocalDef (id,v,_) -> LocalDef (id, v, ty) (** Return [true] iff a given declaration is a local assumption. *) let is_local_assum = function | LocalAssum _ -> true | LocalDef _ -> false (** Return [true] iff a given declaration is a local definition. *) let is_local_def = function | LocalDef _ -> true | LocalAssum _ -> false (** Check whether any term in a given declaration satisfies a given predicate. *) let exists f = function | LocalAssum (_, ty) -> f ty | LocalDef (_, v, ty) -> f v || f ty (** Check whether all terms in a given declaration satisfy a given predicate. *) let for_all f = function | LocalAssum (_, ty) -> f ty | LocalDef (_, v, ty) -> f v && f ty (** Check whether the two given declarations are equal. *) let equal decl1 decl2 = match decl1, decl2 with | LocalAssum (id1, ty1), LocalAssum (id2, ty2) -> Id.equal id1 id2 && Constr.equal ty1 ty2 | LocalDef (id1, v1, ty1), LocalDef (id2, v2, ty2) -> Id.equal id1 id2 && Constr.equal v1 v2 && Constr.equal ty1 ty2 | _ -> false (** Map the identifier bound by a given declaration. *) let map_id f = function | LocalAssum (id, ty) as decl -> let id' = f id in if id == id' then decl else LocalAssum (id', ty) | LocalDef (id, v, ty) as decl -> let id' = f id in if id == id' then decl else LocalDef (id', v, ty) (** For local assumptions, this function returns the original local assumptions. For local definitions, this function maps the value in the local definition. *) let map_value f = function | LocalAssum _ as decl -> decl | LocalDef (na, v, t) as decl -> let v' = f v in if v == v' then decl else LocalDef (na, v', t) (** Map the type of the name bound by a given declaration. *) let map_type f = function | LocalAssum (id, ty) as decl -> let ty' = f ty in if ty == ty' then decl else LocalAssum (id, ty') | LocalDef (id, v, ty) as decl -> let ty' = f ty in if ty == ty' then decl else LocalDef (id, v, ty') (** Map all terms in a given declaration. *) let map_constr f = function | LocalAssum (id, ty) as decl -> let ty' = f ty in if ty == ty' then decl else LocalAssum (id, ty') | LocalDef (id, v, ty) as decl -> let v' = f v in let ty' = f ty in if v == v' && ty == ty' then decl else LocalDef (id, v', ty') (** Perform a given action on all terms in a given declaration. *) let iter_constr f = function | LocalAssum (_, ty) -> f ty | LocalDef (_, v, ty) -> f v; f ty (** Reduce all terms in a given declaration to a single value. *) let fold f decl a = match decl with | LocalAssum (_, ty) -> f ty a | LocalDef (_, v, ty) -> a |> f v |> f ty let to_tuple = function | LocalAssum (id, ty) -> id, None, ty | LocalDef (id, v, ty) -> id, Some v, ty let of_tuple = function | id, None, ty -> LocalAssum (id, ty) | id, Some v, ty -> LocalDef (id, v, ty) end (** Named-context is represented as a list of declarations. Inner-most declarations are at the beginning of the list. Outer-most declarations are at the end of the list. *) type t = Declaration.t list (** empty named-context *) let empty = [] (** empty named-context *) let add d ctx = d :: ctx (** Return the number of {e local declarations} in a given named-context. *) let length = List.length (** Return a declaration designated by a given de Bruijn index. @raise Not_found if the designated identifier is not present in the designated named-context. *) let rec lookup id = function | decl :: _ when Id.equal id (Declaration.get_id decl) -> decl | _ :: sign -> lookup id sign | [] -> raise Not_found (** Check whether given two named-contexts are equal. *) let equal = List.equal Declaration.equal (** Map all terms in a given named-context. *) let map f = List.smartmap (Declaration.map_constr f) (** Perform a given action on every declaration in a given named-context. *) let iter f = List.iter (Declaration.iter_constr f) (** Reduce all terms in a given named-context to a single value. Innermost declarations are processed first. *) let fold_inside f ~init = List.fold_left f init (** Reduce all terms in a given named-context to a single value. Outermost declarations are processed first. *) let fold_outside f l ~init = List.fold_right f l init (** Return the set of all identifiers bound in a given named-context. *) let to_vars = List.fold_left (fun accu decl -> Id.Set.add (Declaration.get_id decl) accu) Id.Set.empty (** [instance_from_named_context Ω] builds an instance [args] such that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it gives [Var id1, Var id3]. All [idj] are supposed distinct. *) let to_instance = let filter = function | Declaration.LocalAssum (id, _) -> Some (Constr.mkVar id) | _ -> None in List.map_filter filter end module NamedList = struct module Declaration = struct type t = Id.t list * Constr.t option * Constr.t let map_constr f (ids, copt, ty as decl) = let copt' = Option.map f copt in let ty' = f ty in if copt == copt' && ty == ty' then decl else (ids, copt', ty') end type t = Declaration.t list let fold f l ~init = List.fold_right f l init end type section_context = Named.t coq-8.6/kernel/cbytecodes.mli0000644000175000017500000001634113022274260015573 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Pp.std_ppcmds type reloc_table = (tag * int) array type annot_switch = {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int} module Label : sig type t = int val no : t val create : unit -> t val reset_label_counter : unit -> unit end type instruction = | Klabel of Label.t | Kacc of int (** accu = sp[n] *) | Kenvacc of int (** accu = coq_env[n] *) | Koffsetclosure of int (** accu = &coq_env[n] *) | Kpush (** sp = accu :: sp *) | Kpop of int (** sp = skipn n sp *) | Kpush_retaddr of Label.t (** sp = pc :: coq_env :: coq_extra_args :: sp ; coq_extra_args = 0 *) | Kapply of int (** number of arguments (arguments on top of stack) *) | Kappterm of int * int (** number of arguments, slot size *) | Kreturn of int (** slot size *) | Kjump | Krestart | Kgrab of int (** number of arguments *) | Kgrabrec of int (** rec arg *) | Kclosure of Label.t * int (** label, number of free variables *) | Kclosurerec of int * int * Label.t array * Label.t array (** nb fv, init, lbl types, lbl bodies *) | Kclosurecofix of int * int * Label.t array * Label.t array (** nb fv, init, lbl types, lbl bodies *) | Kgetglobal of constant | Kconst of structured_constant | Kmakeblock of (* size: *) int * tag (** allocate an ocaml block. Index 0 ** is accu, all others are popped from ** the top of the stack *) | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array (** consts,blocks *) | Kpushfields of int | Kfield of int (** accu = accu[n] *) | Ksetfield of int (** accu[n] = sp[0] ; sp = pop sp *) | Kstop | Ksequence of bytecodes * bytecodes | Kproj of int * Constant.t (** index of the projected argument, name of projection *) | Kensurestackcapacity of int (** spiwack: instructions concerning integers *) | Kbranch of Label.t (** jump to label, is it needed ? *) | Kaddint31 (** adds the int31 in the accu and the one ontop of the stack *) | Kaddcint31 (** makes the sum and keeps the carry *) | Kaddcarrycint31 (** sum +1, keeps the carry *) | Ksubint31 (** subtraction modulo *) | Ksubcint31 (** subtraction, keeps the carry *) | Ksubcarrycint31 (** subtraction -1, keeps the carry *) | Kmulint31 (** multiplication modulo *) | Kmulcint31 (** multiplication, result in two int31, for exact computation *) | Kdiv21int31 (** divides a double size integer (represented by an int31 in the accumulator and one on the top of the stack) by an int31. The result is a pair of the quotient and the rest. If the divisor is 0, it returns 0. *) | Kdivint31 (** euclidian division (returns a pair quotient,rest) *) | Kaddmuldivint31 (** generic operation for shifting and cycling. Takes 3 int31 i j and s, and returns x*2^s+y/(2^(31-s) *) | Kcompareint31 (** unsigned comparison of int31 cf COMPAREINT31 in kernel/byterun/coq_interp.c for more info *) | Khead0int31 (** Give the numbers of 0 in head of a in31*) | Ktail0int31 (** Give the numbers of 0 in tail of a in31 ie low bits *) | Kisconst of Label.t (** conditional jump *) | Kareconst of int*Label.t (** conditional jump *) | Kcompint31 (** dynamic compilation of int31 *) | Kdecompint31 (** dynamix decompilation of int31 *) | Klorint31 (** bitwise operations: or and xor *) | Klandint31 | Klxorint31 and bytecodes = instruction list type fv_elem = FVnamed of Id.t | FVrel of int | FVuniv_var of int type fv = fv_elem array (** spiwack: this exception is expected to be raised by function expecting closed terms. *) exception NotClosed module FvMap : Map.S with type key = fv_elem (*spiwack: both type have been moved from Cbytegen because I needed them for the retroknowledge *) type vm_env = { size : int; (** length of the list [n] *) fv_rev : fv_elem list; (** [fvn; ... ;fv1] *) fv_fwd : int FvMap.t; (** reverse mapping *) } type comp_env = { nb_uni_stack : int ; (** number of universes on the stack *) nb_stack : int; (** number of variables on the stack *) in_stack : int list; (** position in the stack *) nb_rec : int; (** number of mutually recursive functions *) (** (= nbr) *) pos_rec : instruction list; (** instruction d'acces pour les variables *) (** de point fix ou de cofix *) offset : int; in_env : vm_env ref (** the variables that are accessed *) } val pp_bytecodes : bytecodes -> Pp.std_ppcmds val pp_fv_elem : fv_elem -> Pp.std_ppcmds (*spiwack: moved this here because I needed it for retroknowledge *) type block = | Bconstr of constr | Bstrconst of structured_constant | Bmakeblock of int * block array | Bconstruct_app of int * int * int * block array (** tag , nparams, arity *) | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array (** compilation function (see get_vm_constant_dynamic_info in retroknowledge.mli for more info) , argument array *) coq-8.6/kernel/pre_env.ml0000644000175000017500000001357513022274260014742 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* None | VKvalue v -> try Some (CEphemeron.get v) with CEphemeron.InvalidKey -> None let dummy_lazy_val () = ref VKnone let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key) type named_context_val = { env_named_ctx : Context.Named.t; env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; } type env = { env_globals : globals; env_named_context : named_context_val; env_rel_context : Context.Rel.t; env_rel_val : lazy_val list; env_nb_rel : int; env_stratification : stratification; env_typing_flags : typing_flags; env_conv_oracle : Conv_oracle.oracle; retroknowledge : Retroknowledge.retroknowledge; indirect_pterms : Opaqueproof.opaquetab; } let empty_named_context_val = { env_named_ctx = []; env_named_map = Id.Map.empty; } let empty_env = { env_globals = { env_constants = Cmap_env.empty; env_inductives = Mindmap_env.empty; env_modules = MPmap.empty; env_modtypes = MPmap.empty}; env_named_context = empty_named_context_val; env_rel_context = Context.Rel.empty; env_rel_val = []; env_nb_rel = 0; env_stratification = { env_universes = UGraph.initial_universes; env_engagement = PredicativeSet }; env_typing_flags = Declareops.safe_flags; env_conv_oracle = Conv_oracle.empty; retroknowledge = Retroknowledge.initial_retroknowledge; indirect_pterms = Opaqueproof.empty_opaquetab } (* Rel context *) let nb_rel env = env.env_nb_rel let push_rel d env = let rval = ref VKnone in { env with env_rel_context = Context.Rel.add d env.env_rel_context; env_rel_val = rval :: env.env_rel_val; env_nb_rel = env.env_nb_rel + 1 } let lookup_rel_val n env = try List.nth env.env_rel_val (n - 1) with Failure _ -> raise Not_found let env_of_rel n env = { env with env_rel_context = Util.List.skipn n env.env_rel_context; env_rel_val = Util.List.skipn n env.env_rel_val; env_nb_rel = env.env_nb_rel - n } (* Named context *) let push_named_context_val_val d rval ctxt = (* assert (not (Id.Map.mem (get_id d) ctxt.env_named_map)); *) { env_named_ctx = Context.Named.add d ctxt.env_named_ctx; env_named_map = Id.Map.add (get_id d) (d, rval) ctxt.env_named_map; } let push_named_context_val d ctxt = push_named_context_val_val d (ref VKnone) ctxt let match_named_context_val c = match c.env_named_ctx with | [] -> None | decl :: ctx -> let (_, v) = Id.Map.find (get_id decl) c.env_named_map in let map = Id.Map.remove (get_id decl) c.env_named_map in let cval = { env_named_ctx = ctx; env_named_map = map } in Some (decl, v, cval) let map_named_val f ctxt = let open Context.Named.Declaration in let fold accu d = let d' = map_constr f d in let accu = if d == d' then accu else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu in (accu, d') in let map, ctx = List.fold_map fold ctxt.env_named_map ctxt.env_named_ctx in { env_named_ctx = ctx; env_named_map = map } let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); assert (env.env_rel_context = []); *) { env_globals = env.env_globals; env_named_context = push_named_context_val d env.env_named_context; env_rel_context = env.env_rel_context; env_rel_val = env.env_rel_val; env_nb_rel = env.env_nb_rel; env_stratification = env.env_stratification; env_typing_flags = env.env_typing_flags; env_conv_oracle = env.env_conv_oracle; retroknowledge = env.retroknowledge; indirect_pterms = env.indirect_pterms; } let lookup_named id env = fst (Id.Map.find id env.env_named_context.env_named_map) let lookup_named_val id env = snd(Id.Map.find id env.env_named_context.env_named_map) (* Warning all the names should be different *) let env_of_named id env = env (* Global constants *) let lookup_constant_key kn env = Cmap_env.find kn env.env_globals.env_constants let lookup_constant kn env = fst (Cmap_env.find kn env.env_globals.env_constants) (* Mutual Inductives *) let lookup_mind kn env = fst (Mindmap_env.find kn env.env_globals.env_inductives) let lookup_mind_key kn env = Mindmap_env.find kn env.env_globals.env_inductives coq-8.6/kernel/nativevalues.ml0000644000175000017500000003621713022274260016010 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t type accumulator (* = t (* a block [0:code;atom;arguments] *) *) type tag = int type arity = int type reloc_table = (tag * arity) array type annot_sw = { asw_ind : inductive; asw_ci : case_info; asw_reloc : reloc_table; asw_finite : bool; asw_prefix : string } (* 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 && 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) type sort_annot = string * int type rec_pos = int array let eq_rec_pos = Array.equal Int.equal type atom = | Arel of int | Aconstant of pconstant | Aind of pinductive | Asort of sorts | Avar of identifier | Acase of annot_sw * accumulator * t * (t -> t) | Afix of t array * t array * rec_pos * int (* types, bodies, rec_pos, pos *) | Acofix of t array * t array * int * t | Acofixe of t array * t array * int * t | Aprod of name * t * (t -> t) | Ameta of metavariable * t | Aevar of existential * t | Aproj of constant * accumulator let accumulate_tag = 0 let accumulate_code (k:accumulator) (x:t) = let o = Obj.repr k in let osize = Obj.size o in let r = Obj.new_block accumulate_tag (osize + 1) in for i = 0 to osize - 1 do Obj.set_field r i (Obj.field o i) done; Obj.set_field r osize (Obj.repr x); (Obj.obj r:t) let rec accumulate (x:t) = accumulate_code (Obj.magic accumulate) x let mk_accu_gen rcode (a:atom) = (* Format.eprintf "size rcode =%i\n" (Obj.size (Obj.magic rcode)); *) let r = Obj.new_block 0 3 in Obj.set_field r 0 (Obj.field (Obj.magic rcode) 0); Obj.set_field r 1 (Obj.field (Obj.magic rcode) 1); Obj.set_field r 2 (Obj.magic a); (Obj.magic r:t);; let mk_accu (a:atom) = mk_accu_gen accumulate a let mk_rel_accu i = mk_accu (Arel i) let rel_tbl_size = 100 let rel_tbl = Array.init rel_tbl_size mk_rel_accu let mk_rel_accu i = if i < rel_tbl_size then rel_tbl.(i) else mk_rel_accu i let mk_rels_accu lvl len = Array.init len (fun i -> mk_rel_accu (lvl + i)) let napply (f:t) (args: t array) = Array.fold_left (fun f a -> f a) f args let mk_constant_accu kn u = mk_accu (Aconstant (kn,Univ.Instance.of_array u)) let mk_ind_accu ind u = mk_accu (Aind (ind,Univ.Instance.of_array u)) let mk_sort_accu s u = match s with | Prop _ -> mk_accu (Asort s) | Type s -> let u = Univ.Instance.of_array u in let s = Univ.subst_instance_universe u s in mk_accu (Asort (Type s)) let mk_var_accu id = mk_accu (Avar id) let mk_sw_accu annot c p ac = mk_accu (Acase(annot,c,p,ac)) let mk_prod_accu s dom codom = mk_accu (Aprod (s,dom,codom)) let mk_meta_accu mv ty = mk_accu (Ameta (mv,ty)) let mk_evar_accu ev ty = mk_accu (Aevar (ev,ty)) let mk_proj_accu kn c = mk_accu (Aproj (kn,c)) let atom_of_accu (k:accumulator) = (Obj.magic (Obj.field (Obj.magic k) 2) : atom) let set_atom_of_accu (k:accumulator) (a:atom) = Obj.set_field (Obj.magic k) 2 (Obj.magic a) let accu_nargs (k:accumulator) = let nargs = Obj.size (Obj.magic k) - 3 in (* if nargs < 0 then Format.eprintf "nargs = %i\n" nargs; *) assert (nargs >= 0); nargs let args_of_accu (k:accumulator) = let nargs = accu_nargs k in let f i = (Obj.magic (Obj.field (Obj.magic k) (nargs-i+2)) : t) in let t = Array.init nargs f in Array.to_list t let is_accu x = let o = Obj.repr x in Obj.is_block o && Int.equal (Obj.tag o) accumulate_tag let mk_fix_accu rec_pos pos types bodies = mk_accu_gen accumulate (Afix(types,bodies,rec_pos, pos)) let mk_cofix_accu pos types norm = mk_accu_gen accumulate (Acofix(types,norm,pos,(Obj.magic 0 : t))) let upd_cofix (cofix :t) (cofix_fun : t) = let atom = atom_of_accu (Obj.magic cofix) in match atom with | Acofix (typ,norm,pos,_) -> set_atom_of_accu (Obj.magic cofix) (Acofix(typ,norm,pos,cofix_fun)) | _ -> assert false let force_cofix (cofix : t) = if is_accu cofix then let accu = (Obj.magic cofix : accumulator) in let atom = atom_of_accu accu in match atom with | Acofix(typ,norm,pos,f) -> let f = ref f in let args = List.rev (args_of_accu accu) in List.iter (fun x -> f := !f x) args; let v = !f (Obj.magic ()) in set_atom_of_accu accu (Acofixe(typ,norm,pos,v)); v | Acofixe(_,_,_,v) -> v | _ -> cofix else cofix let mk_const tag = Obj.magic tag let mk_block tag args = let nargs = Array.length args in let r = Obj.new_block tag nargs in for i = 0 to nargs - 1 do Obj.set_field r i (Obj.magic args.(i)) done; (Obj.magic r : t) (* Two instances of dummy_value should not be pointer equal, otherwise comparing them as terms would succeed *) let dummy_value : unit -> t = fun () _ -> anomaly ~label:"native" (Pp.str "Evaluation failed") let cast_accu v = (Obj.magic v:accumulator) let mk_int (x : int) = (Obj.magic x : t) (* Coq's booleans are reversed... *) let mk_bool (b : bool) = (Obj.magic (not b) : t) let mk_uint (x : Uint31.t) = (Obj.magic x : t) type block let block_size (b:block) = Obj.size (Obj.magic b) let block_field (b:block) i = (Obj.magic (Obj.field (Obj.magic b) i) : t) let block_tag (b:block) = Obj.tag (Obj.magic b) type kind_of_value = | Vaccu of accumulator | Vfun of (t -> t) | Vconst of int | Vblock of block let kind_of_value (v:t) = let o = Obj.repr v in if Obj.is_int o then Vconst (Obj.magic v) else let tag = Obj.tag o in if Int.equal tag accumulate_tag then Vaccu (Obj.magic v) else if (tag < Obj.lazy_tag) then Vblock (Obj.magic v) else (* assert (tag = Obj.closure_tag || tag = Obj.infix_tag); or ??? what is 1002*) Vfun v (** Support for machine integers *) let is_int (x:t) = let o = Obj.repr x in Obj.is_int o let val_to_int (x:t) = (Obj.magic x : int) let to_uint (x:t) = (Obj.magic x : Uint31.t) let of_uint (x: Uint31.t) = (Obj.magic x : t) let no_check_head0 x = of_uint (Uint31.head0 (to_uint x)) let head0 accu x = if is_int x then no_check_head0 x else accu x let no_check_tail0 x = of_uint (Uint31.tail0 (to_uint x)) let tail0 accu x = if is_int x then no_check_tail0 x else accu x let no_check_add x y = of_uint (Uint31.add (to_uint x) (to_uint y)) let add accu x y = if is_int x && is_int y then no_check_add x y else accu x y let no_check_sub x y = of_uint (Uint31.sub (to_uint x) (to_uint y)) let sub accu x y = if is_int x && is_int y then no_check_sub x y else accu x y let no_check_mul x y = of_uint (Uint31.mul (to_uint x) (to_uint y)) let mul accu x y = if is_int x && is_int y then no_check_mul x y else accu x y let no_check_div x y = of_uint (Uint31.div (to_uint x) (to_uint y)) let div accu x y = if is_int x && is_int y then no_check_div x y else accu x y let no_check_rem x y = of_uint (Uint31.rem (to_uint x) (to_uint y)) let rem accu x y = if is_int x && is_int y then no_check_rem x y else accu x y let no_check_l_sr x y = of_uint (Uint31.l_sr (to_uint x) (to_uint y)) let l_sr accu x y = if is_int x && is_int y then no_check_l_sr x y else accu x y let no_check_l_sl x y = of_uint (Uint31.l_sl (to_uint x) (to_uint y)) let l_sl accu x y = if is_int x && is_int y then no_check_l_sl x y else accu x y let no_check_l_and x y = of_uint (Uint31.l_and (to_uint x) (to_uint y)) let l_and accu x y = if is_int x && is_int y then no_check_l_and x y else accu x y let no_check_l_xor x y = of_uint (Uint31.l_xor (to_uint x) (to_uint y)) let l_xor accu x y = if is_int x && is_int y then no_check_l_xor x y else accu x y let no_check_l_or x y = of_uint (Uint31.l_or (to_uint x) (to_uint y)) let l_or accu x y = if is_int x && is_int y then no_check_l_or x y else accu x y type coq_carry = | Caccu of t | C0 of t | C1 of t type coq_pair = | Paccu of t | PPair of t * t type coq_zn2z = | Zaccu of t | ZW0 | ZWW of t * t let mkCarry b i = if b then (Obj.magic (C1(of_uint i)):t) else (Obj.magic (C0(of_uint i)):t) let no_check_addc x y = let s = Uint31.add (to_uint x) (to_uint y) in mkCarry (Uint31.lt s (to_uint x)) s let addc accu x y = if is_int x && is_int y then no_check_addc x y else accu x y let no_check_subc x y = let s = Uint31.sub (to_uint x) (to_uint y) in mkCarry (Uint31.lt (to_uint x) (to_uint y)) s let subc accu x y = if is_int x && is_int y then no_check_subc x y else accu x y let no_check_addcarryc x y = let s = Uint31.add (Uint31.add (to_uint x) (to_uint y)) (Uint31.of_int 1) in mkCarry (Uint31.le s (to_uint x)) s let addcarryc accu x y = if is_int x && is_int y then no_check_addcarryc x y else accu x y let no_check_subcarryc x y = let s = Uint31.sub (Uint31.sub (to_uint x) (to_uint y)) (Uint31.of_int 1) in mkCarry (Uint31.le (to_uint x) (to_uint y)) s let subcarryc accu x y = if is_int x && is_int y then no_check_subcarryc x y else accu x y let of_pair (x, y) = (Obj.magic (PPair(of_uint x, of_uint y)):t) let zn2z_of_pair (x,y) = if Uint31.equal x (Uint31.of_uint 0) && Uint31.equal y (Uint31.of_uint 0) then Obj.magic ZW0 else (Obj.magic (ZWW(of_uint x, of_uint y)) : t) let no_check_mulc x y = zn2z_of_pair(Uint31.mulc (to_uint x) (to_uint y)) let mulc accu x y = if is_int x && is_int y then no_check_mulc x y else accu x y let no_check_diveucl x y = let i1, i2 = to_uint x, to_uint y in of_pair(Uint31.div i1 i2, Uint31.rem i1 i2) let diveucl accu x y = if is_int x && is_int y then no_check_diveucl x y else accu x y let no_check_div21 x y z = let i1, i2, i3 = to_uint x, to_uint y, to_uint z in of_pair (Uint31.div21 i1 i2 i3) let div21 accu x y z = if is_int x && is_int y && is_int z then no_check_div21 x y z else accu x y z let no_check_addmuldiv x y z = let p, i, j = to_uint x, to_uint y, to_uint z in let p' = Uint31.to_int p in of_uint (Uint31.l_or (Uint31.l_sl i p) (Uint31.l_sr j (Uint31.of_int (31 - p')))) let addmuldiv accu x y z = if is_int x && is_int y && is_int z then no_check_addmuldiv x y z else accu x y z type coq_bool = | Baccu of t | Btrue | Bfalse type coq_cmp = | CmpAccu of t | CmpEq | CmpLt | CmpGt let no_check_eq x y = mk_bool (Uint31.equal (to_uint x) (to_uint y)) let eq accu x y = if is_int x && is_int y then no_check_eq x y else accu x y let no_check_lt x y = mk_bool (Uint31.lt (to_uint x) (to_uint y)) let lt accu x y = if is_int x && is_int y then no_check_lt x y else accu x y let no_check_le x y = mk_bool (Uint31.le (to_uint x) (to_uint y)) let le accu x y = if is_int x && is_int y then no_check_le x y else accu x y let no_check_compare x y = match Uint31.compare (to_uint x) (to_uint y) with | x when x < 0 -> (Obj.magic CmpLt:t) | 0 -> (Obj.magic CmpEq:t) | _ -> (Obj.magic CmpGt:t) let compare accu x y = if is_int x && is_int y then no_check_compare x y else accu x y let hobcnv = Array.init 256 (fun i -> Printf.sprintf "%02x" i) let bohcnv = Array.init 256 (fun i -> i - (if 0x30 <= i then 0x30 else 0) - (if 0x41 <= i then 0x7 else 0) - (if 0x61 <= i then 0x20 else 0)) let hex_of_bin ch = hobcnv.(int_of_char ch) let bin_of_hex s = char_of_int (bohcnv.(int_of_char s.[0]) * 16 + bohcnv.(int_of_char s.[1])) let str_encode expr = let mshl_expr = Marshal.to_string expr [] in let payload = Buffer.create (String.length mshl_expr * 2) in String.iter (fun c -> Buffer.add_string payload (hex_of_bin c)) mshl_expr; Buffer.contents payload let str_decode s = let mshl_expr_len = String.length s / 2 in let mshl_expr = Buffer.create mshl_expr_len in let buf = String.create 2 in for i = 0 to mshl_expr_len - 1 do String.blit s (2*i) buf 0 2; Buffer.add_char mshl_expr (bin_of_hex buf) done; Marshal.from_string (Buffer.contents mshl_expr) 0 (** Retroknowledge, to be removed when we switch to primitive integers *) (* This will be unsafe with 63-bits integers *) let digit_to_uint d = (Obj.magic d : Uint31.t) let mk_I31_accu c x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 = if is_int x0 && is_int x1 && is_int x2 && is_int x3 && is_int x4 && is_int x5 && is_int x6 && is_int x7 && is_int x8 && is_int x9 && is_int x10 && is_int x11 && is_int x12 && is_int x13 && is_int x14 && is_int x15 && is_int x16 && is_int x17 && is_int x18 && is_int x19 && is_int x20 && is_int x21 && is_int x22 && is_int x23 && is_int x24 && is_int x25 && is_int x26 && is_int x27 && is_int x28 && is_int x29 && is_int x30 then let r = digit_to_uint x0 in let r = Uint31.add_digit r (digit_to_uint x1) in let r = Uint31.add_digit r (digit_to_uint x2) in let r = Uint31.add_digit r (digit_to_uint x3) in let r = Uint31.add_digit r (digit_to_uint x4) in let r = Uint31.add_digit r (digit_to_uint x5) in let r = Uint31.add_digit r (digit_to_uint x6) in let r = Uint31.add_digit r (digit_to_uint x7) in let r = Uint31.add_digit r (digit_to_uint x8) in let r = Uint31.add_digit r (digit_to_uint x9) in let r = Uint31.add_digit r (digit_to_uint x10) in let r = Uint31.add_digit r (digit_to_uint x11) in let r = Uint31.add_digit r (digit_to_uint x12) in let r = Uint31.add_digit r (digit_to_uint x13) in let r = Uint31.add_digit r (digit_to_uint x14) in let r = Uint31.add_digit r (digit_to_uint x15) in let r = Uint31.add_digit r (digit_to_uint x16) in let r = Uint31.add_digit r (digit_to_uint x17) in let r = Uint31.add_digit r (digit_to_uint x18) in let r = Uint31.add_digit r (digit_to_uint x19) in let r = Uint31.add_digit r (digit_to_uint x20) in let r = Uint31.add_digit r (digit_to_uint x21) in let r = Uint31.add_digit r (digit_to_uint x22) in let r = Uint31.add_digit r (digit_to_uint x23) in let r = Uint31.add_digit r (digit_to_uint x24) in let r = Uint31.add_digit r (digit_to_uint x25) in let r = Uint31.add_digit r (digit_to_uint x26) in let r = Uint31.add_digit r (digit_to_uint x27) in let r = Uint31.add_digit r (digit_to_uint x28) in let r = Uint31.add_digit r (digit_to_uint x29) in let r = Uint31.add_digit r (digit_to_uint x30) in mk_uint r else c x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 let decomp_uint c v = if is_int v then let r = ref c in let v = val_to_int v in for i = 30 downto 0 do r := (!r) (mk_int ((v lsr i) land 1)); done; !r else v coq-8.6/kernel/univ.ml0000644000175000017500000010214513022274260014255 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int val eq : t -> t -> bool val hcons : t -> t end module HashedList (M : Hashconsed) : sig type t = private Nil | Cons of M.t * int * t val nil : t val cons : M.t -> t -> t end = struct type t = Nil | Cons of M.t * int * t module Self = struct type _t = t type t = _t type u = (M.t -> M.t) let hash = function Nil -> 0 | Cons (_, h, _) -> h let eq l1 l2 = match l1, l2 with | Nil, Nil -> true | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2 | _ -> false let hashcons hc = function | Nil -> Nil | Cons (x, h, l) -> Cons (hc x, h, l) end module Hcons = Hashcons.Make(Self) let hcons = Hashcons.simple_hcons Hcons.generate Hcons.hcons M.hcons (** No recursive call: the interface guarantees that all HLists from this program are already hashconsed. If we get some external HList, we can still reconstruct it by traversing it entirely. *) let nil = Nil let cons x l = let h = M.hash x in let hl = match l with Nil -> 0 | Cons (_, h, _) -> h in let h = Hashset.Combine.combine h hl in hcons (Cons (x, h, l)) end module HList = struct module type S = sig type elt type t = private Nil | Cons of elt * int * t val hash : t -> int val nil : t val cons : elt -> t -> t val tip : elt -> t val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val map : (elt -> elt) -> t -> t val smartmap : (elt -> elt) -> t -> t val exists : (elt -> bool) -> t -> bool val for_all : (elt -> bool) -> t -> bool val for_all2 : (elt -> elt -> bool) -> t -> t -> bool val mem : elt -> t -> bool val remove : elt -> t -> t val to_list : t -> elt list val compare : (elt -> elt -> int) -> t -> t -> int end module Make (H : Hashconsed) : S with type elt = H.t = struct type elt = H.t include HashedList(H) let hash = function Nil -> 0 | Cons (_, h, _) -> h let tip e = cons e nil let rec fold f l accu = match l with | Nil -> accu | Cons (x, _, l) -> fold f l (f x accu) let rec map f = function | Nil -> nil | Cons (x, _, l) -> cons (f x) (map f l) let smartmap = map (** Apriori hashconsing ensures that the map is equal to its argument *) let rec exists f = function | Nil -> false | Cons (x, _, l) -> f x || exists f l let rec for_all f = function | Nil -> true | Cons (x, _, l) -> f x && for_all f l let rec for_all2 f l1 l2 = match l1, l2 with | Nil, Nil -> true | Cons (x1, _, l1), Cons (x2, _, l2) -> f x1 x2 && for_all2 f l1 l2 | _ -> false let rec to_list = function | Nil -> [] | Cons (x, _, l) -> x :: to_list l let rec remove x = function | Nil -> nil | Cons (y, _, l) -> if H.eq x y then l else cons y (remove x l) let rec mem x = function | Nil -> false | Cons (y, _, l) -> H.eq x y || mem x l let rec compare cmp l1 l2 = match l1, l2 with | Nil, Nil -> 0 | Cons (x1, h1, l1), Cons (x2, h2, l2) -> let c = Int.compare h1 h2 in if c == 0 then let c = cmp x1 x2 in if c == 0 then compare cmp l1 l2 else c else c | Cons _, Nil -> 1 | Nil, Cons _ -> -1 end end module RawLevel = struct open Names type t = | Prop | Set | Level of int * DirPath.t | Var of int (* Hash-consing *) let equal x y = x == y || match x, y with | Prop, Prop -> true | Set, Set -> true | Level (n,d), Level (n',d') -> Int.equal n n' && DirPath.equal d d' | Var n, Var n' -> Int.equal n n' | _ -> false let compare u v = match u, v with | Prop,Prop -> 0 | Prop, _ -> -1 | _, Prop -> 1 | Set, Set -> 0 | Set, _ -> -1 | _, Set -> 1 | Level (i1, dp1), Level (i2, dp2) -> if i1 < i2 then -1 else if i1 > i2 then 1 else DirPath.compare dp1 dp2 | Level _, _ -> -1 | _, Level _ -> 1 | Var n, Var m -> Int.compare n m let hequal x y = x == y || match x, y with | Prop, Prop -> true | Set, Set -> true | Level (n,d), Level (n',d') -> n == n' && d == d' | Var n, Var n' -> n == n' | _ -> false let hcons = function | Prop as x -> x | Set as x -> x | Level (n,d) as x -> let d' = Names.DirPath.hcons d in if d' == d then x else Level (n,d') | Var n as x -> x open Hashset.Combine let hash = function | Prop -> combinesmall 1 0 | Set -> combinesmall 1 1 | Var n -> combinesmall 2 n | Level (n, d) -> combinesmall 3 (combine n (Names.DirPath.hash d)) end module Level = struct open Names type raw_level = RawLevel.t = | Prop | Set | Level of int * DirPath.t | Var of int (** Embed levels with their hash value *) type t = { hash : int; data : RawLevel.t } let equal x y = x == y || Int.equal x.hash y.hash && RawLevel.equal x.data y.data let hash x = x.hash let data x = x.data (** Hashcons on levels + their hash *) module Self = struct type _t = t type t = _t type u = unit let eq x y = x.hash == y.hash && RawLevel.hequal x.data y.data let hash x = x.hash let hashcons () x = let data' = RawLevel.hcons x.data in if x.data == data' then x else { x with data = data' } end let hcons = let module H = Hashcons.Make(Self) in Hashcons.simple_hcons H.generate H.hcons () let make l = hcons { hash = RawLevel.hash l; data = l } let set = make Set let prop = make Prop let is_small x = match data x with | Level _ -> false | Var _ -> false | Prop -> true | Set -> true let is_prop x = match data x with | Prop -> true | _ -> false let is_set x = match data x with | Set -> true | _ -> false let compare u v = if u == v then 0 else let c = Int.compare (hash u) (hash v) in if c == 0 then RawLevel.compare (data u) (data v) else c let natural_compare u v = if u == v then 0 else RawLevel.compare (data u) (data v) let to_string x = match data x with | Prop -> "Prop" | Set -> "Set" | Level (n,d) -> Names.DirPath.to_string d^"."^string_of_int n | Var n -> "Var(" ^ string_of_int n ^ ")" let pr u = str (to_string u) let apart u v = match data u, data v with | Prop, Set | Set, Prop -> true | _ -> false let vars = Array.init 20 (fun i -> make (Var i)) let var n = if n < 20 then vars.(n) else make (Var n) let var_index u = match data u with | Var n -> Some n | _ -> None let make m n = make (Level (n, Names.DirPath.hcons m)) end (** Level maps *) module LMap = struct module M = HMap.Make (Level) include M let union l r = merge (fun k l r -> match l, r with | Some _, _ -> l | _, _ -> r) l r let subst_union l r = merge (fun k l r -> match l, r with | Some (Some _), _ -> l | Some None, None -> l | _, _ -> r) l r let diff ext orig = fold (fun u v acc -> if mem u orig then acc else add u v acc) ext empty let pr f m = h 0 (prlist_with_sep fnl (fun (u, v) -> Level.pr u ++ f v) (bindings m)) end module LSet = struct include LMap.Set let pr prl s = str"{" ++ prlist_with_sep spc prl (elements s) ++ str"}" let of_array l = Array.fold_left (fun acc x -> add x acc) empty l end type 'a universe_map = 'a LMap.t type universe_level = Level.t type universe_level_subst_fn = universe_level -> universe_level type universe_set = LSet.t (* An algebraic universe [universe] is either a universe variable [Level.t] or a formal universe known to be greater than some universe variables and strictly greater than some (other) universe variables Universes variables denote universes initially present in the term to type-check and non variable algebraic universes denote the universes inferred while type-checking: it is either the successor of a universe present in the initial term to type-check or the maximum of two algebraic universes *) module Universe = struct (* Invariants: non empty, sorted and without duplicates *) module Expr = struct type t = Level.t * int type _t = t (* Hashing of expressions *) module ExprHash = struct type t = _t type u = Level.t -> Level.t let hashcons hdir (b,n as x) = let b' = hdir b in if b' == b then x else (b',n) let eq l1 l2 = l1 == l2 || match l1,l2 with | (b,n), (b',n') -> b == b' && n == n' let hash (x, n) = n + Level.hash x end module HExpr = struct module H = Hashcons.Make(ExprHash) type t = ExprHash.t let hcons = Hashcons.simple_hcons H.generate H.hcons Level.hcons let hash = ExprHash.hash let eq x y = x == y || (let (u,n) = x and (v,n') = y in Int.equal n n' && Level.equal u v) end let hcons = HExpr.hcons let make l = hcons (l, 0) let compare u v = if u == v then 0 else let (x, n) = u and (x', n') = v in if Int.equal n n' then Level.compare x x' else n - n' let prop = make Level.prop let set = make Level.set let type1 = hcons (Level.set, 1) let is_prop = function | (l,0) -> Level.is_prop l | _ -> false let is_small = function | (l,0) -> Level.is_small l | _ -> false let equal x y = x == y || (let (u,n) = x and (v,n') = y in Int.equal n n' && Level.equal u v) let leq (u,n) (v,n') = let cmp = Level.compare u v in if Int.equal cmp 0 then n <= n' else if n <= n' then (Level.is_prop u && Level.is_small v) else false let successor (u,n) = if Level.is_prop u then type1 else hcons (u, n + 1) let addn k (u,n as x) = if k = 0 then x else if Level.is_prop u then hcons (Level.set,n+k) else hcons (u,n+k) type super_result = SuperSame of bool (* The level expressions are in cumulativity relation. boolean indicates if left is smaller than right? *) | SuperDiff of int (* The level expressions are unrelated, the comparison result is canonical *) (** [super u v] compares two level expressions, returning [SuperSame] if they refer to the same level at potentially different increments or [SuperDiff] if they are different. The booleans indicate if the left expression is "smaller" than the right one in both cases. *) let super (u,n as x) (v,n' as y) = let cmp = Level.compare u v in if Int.equal cmp 0 then SuperSame (n < n') else match x, y with | (l,0), (l',0) -> let open RawLevel in (match Level.data l, Level.data l' with | Prop, Prop -> SuperSame false | Prop, _ -> SuperSame true | _, Prop -> SuperSame false | _, _ -> SuperDiff cmp) | _, _ -> SuperDiff cmp let to_string (v, n) = if Int.equal n 0 then Level.to_string v else Level.to_string v ^ "+" ^ string_of_int n let pr x = str(to_string x) let pr_with f (v, n) = if Int.equal n 0 then f v else f v ++ str"+" ++ int n let is_level = function | (v, 0) -> true | _ -> false let level = function | (v,0) -> Some v | _ -> None let get_level (v,n) = v let map f (v, n as x) = let v' = f v in if v' == v then x else if Level.is_prop v' && n != 0 then hcons (Level.set, n) else hcons (v', n) end let compare_expr = Expr.compare module Huniv = HList.Make(Expr.HExpr) type t = Huniv.t open Huniv let equal x y = x == y || (Huniv.hash x == Huniv.hash y && Huniv.for_all2 Expr.equal x y) let hash = Huniv.hash let compare x y = if x == y then 0 else let hx = Huniv.hash x and hy = Huniv.hash y in let c = Int.compare hx hy in if c == 0 then Huniv.compare (fun e1 e2 -> compare_expr e1 e2) x y else c let rec hcons = function | Nil -> Huniv.nil | Cons (x, _, l) -> Huniv.cons x (hcons l) let make l = Huniv.tip (Expr.make l) let tip x = Huniv.tip x let pr l = match l with | Cons (u, _, Nil) -> Expr.pr u | _ -> str "max(" ++ hov 0 (prlist_with_sep pr_comma Expr.pr (to_list l)) ++ str ")" let pr_with f l = match l with | Cons (u, _, Nil) -> Expr.pr_with f u | _ -> str "max(" ++ hov 0 (prlist_with_sep pr_comma (Expr.pr_with f) (to_list l)) ++ str ")" let is_level l = match l with | Cons (l, _, Nil) -> Expr.is_level l | _ -> false let rec is_levels l = match l with | Cons (l, _, r) -> Expr.is_level l && is_levels r | Nil -> true let level l = match l with | Cons (l, _, Nil) -> Expr.level l | _ -> None let levels l = fold (fun x acc -> LSet.add (Expr.get_level x) acc) l LSet.empty let is_small u = match u with | Cons (l, _, Nil) -> Expr.is_small l | _ -> false (* The lower predicative level of the hierarchy that contains (impredicative) Prop and singleton inductive types *) let type0m = tip Expr.prop (* The level of sets *) let type0 = tip Expr.set (* When typing [Prop] and [Set], there is no constraint on the level, hence the definition of [type1_univ], the type of [Prop] *) let type1 = tip (Expr.successor Expr.set) let is_type0m x = equal type0m x let is_type0 x = equal type0 x (* Returns the formal universe that lies just above the universe variable u. Used to type the sort u. *) let super l = if is_small l then type1 else Huniv.map (fun x -> Expr.successor x) l let addn n l = Huniv.map (fun x -> Expr.addn n x) l let rec merge_univs l1 l2 = match l1, l2 with | Nil, _ -> l2 | _, Nil -> l1 | Cons (h1, _, t1), Cons (h2, _, t2) -> let open Expr in (match super h1 h2 with | SuperSame true (* h1 < h2 *) -> merge_univs t1 l2 | SuperSame false -> merge_univs l1 t2 | SuperDiff c -> if c <= 0 (* h1 < h2 is name order *) then cons h1 (merge_univs t1 l2) else cons h2 (merge_univs l1 t2)) let sort u = let rec aux a l = match l with | Cons (b, _, l') -> let open Expr in (match super a b with | SuperSame false -> aux a l' | SuperSame true -> l | SuperDiff c -> if c <= 0 then cons a l else cons b (aux a l')) | Nil -> cons a l in fold (fun a acc -> aux a acc) u nil (* Returns the formal universe that is greater than the universes u and v. Used to type the products. *) let sup x y = merge_univs x y let empty = nil let exists = Huniv.exists let for_all = Huniv.for_all let smartmap = Huniv.smartmap end type universe = Universe.t (* The level of predicative Set *) let type0m_univ = Universe.type0m let type0_univ = Universe.type0 let type1_univ = Universe.type1 let is_type0m_univ = Universe.is_type0m let is_type0_univ = Universe.is_type0 let is_univ_variable l = Universe.level l != None let is_small_univ = Universe.is_small let pr_uni = Universe.pr let sup = Universe.sup let super = Universe.super open Universe let universe_level = Universe.level type constraint_type = Lt | Le | Eq type explanation = (constraint_type * universe) list let constraint_type_ord c1 c2 = match c1, c2 with | Lt, Lt -> 0 | Lt, _ -> -1 | Le, Lt -> 1 | Le, Le -> 0 | Le, Eq -> -1 | Eq, Eq -> 0 | Eq, _ -> 1 (* Universe inconsistency: error raised when trying to enforce a relation that would create a cycle in the graph of universes. *) type univ_inconsistency = constraint_type * universe * universe * explanation option exception UniverseInconsistency of univ_inconsistency let error_inconsistency o u v (p:explanation option) = raise (UniverseInconsistency (o,make u,make v,p)) (* Constraints and sets of constraints. *) type univ_constraint = Level.t * constraint_type * Level.t let pr_constraint_type op = let op_str = match op with | Lt -> " < " | Le -> " <= " | Eq -> " = " in str op_str module UConstraintOrd = struct type t = univ_constraint let compare (u,c,v) (u',c',v') = let i = constraint_type_ord c c' in if not (Int.equal i 0) then i else let i' = Level.compare u u' in if not (Int.equal i' 0) then i' else Level.compare v v' end module Constraint = struct module S = Set.Make(UConstraintOrd) include S let pr prl c = fold (fun (u1,op,u2) pp_std -> pp_std ++ prl u1 ++ pr_constraint_type op ++ prl u2 ++ fnl () ) c (str "") end let empty_constraint = Constraint.empty let union_constraint = Constraint.union let eq_constraint = Constraint.equal type constraints = Constraint.t module Hconstraint = Hashcons.Make( struct type t = univ_constraint type u = universe_level -> universe_level let hashcons hul (l1,k,l2) = (hul l1, k, hul l2) let eq (l1,k,l2) (l1',k',l2') = l1 == l1' && k == k' && l2 == l2' let hash = Hashtbl.hash end) module Hconstraints = Hashcons.Make( struct type t = constraints type u = univ_constraint -> univ_constraint let hashcons huc s = Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty let eq s s' = List.for_all2eq (==) (Constraint.elements s) (Constraint.elements s') let hash = Hashtbl.hash end) let hcons_constraint = Hashcons.simple_hcons Hconstraint.generate Hconstraint.hcons Level.hcons let hcons_constraints = Hashcons.simple_hcons Hconstraints.generate Hconstraints.hcons hcons_constraint (** A value with universe constraints. *) type 'a constrained = 'a * constraints let constraints_of (_, cst) = cst (** Constraint functions. *) type 'a constraint_function = 'a -> 'a -> constraints -> constraints let enforce_eq_level u v c = (* We discard trivial constraints like u=u *) if Level.equal u v then c else if Level.apart u v then error_inconsistency Eq u v None else Constraint.add (u,Eq,v) c let enforce_eq u v c = match Universe.level u, Universe.level v with | Some u, Some v -> enforce_eq_level u v c | _ -> anomaly (Pp.str "A universe comparison can only happen between variables") let check_univ_eq u v = Universe.equal u v let enforce_eq u v c = if check_univ_eq u v then c else enforce_eq u v c let constraint_add_leq v u c = (* We just discard trivial constraints like u<=u *) if Expr.equal v u then c else match v, u with | (x,n), (y,m) -> let j = m - n in if j = -1 (* n = m+1, v+1 <= u <-> v < u *) then Constraint.add (x,Lt,y) c else if j <= -1 (* n = m+k, v+k <= u <-> v+(k-1) < u *) then if Level.equal x y then (* u+(k+1) <= u *) raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u, None)) else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints") else if j = 0 then Constraint.add (x,Le,y) c else (* j >= 1 *) (* m = n + k, u <= v+k *) if Level.equal x y then c (* u <= u+k, trivial *) else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *) else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints") let check_univ_leq_one u v = Universe.exists (Expr.leq u) v let check_univ_leq u v = Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = let open Universe.Huniv in let rec aux acc v = match v with | Cons (v, _, l) -> aux (fold (fun u -> constraint_add_leq u v) u c) l | Nil -> acc in aux c v let enforce_leq u v c = if check_univ_leq u v then c else enforce_leq u v c let enforce_leq_level u v c = if Level.equal u v then c else Constraint.add (u,Le,v) c let enforce_univ_constraint (u,d,v) = match d with | Eq -> enforce_eq u v | Le -> enforce_leq u v | Lt -> enforce_leq (super u) v (* Miscellaneous functions to remove or test local univ assumed to occur in a universe *) let univ_level_mem u v = Huniv.mem (Expr.make u) v let univ_level_rem u v min = match Universe.level v with | Some u' -> if Level.equal u u' then min else v | None -> Huniv.remove (Universe.Expr.make u) v (* Is u mentionned in v (or equals to v) ? *) (**********************************************************************) (** Universe polymorphism *) (**********************************************************************) (** A universe level substitution, note that no algebraic universes are involved *) type universe_level_subst = universe_level universe_map (** A full substitution might involve algebraic universes *) type universe_subst = universe universe_map let level_subst_of f = fun l -> try let u = f l in match Universe.level u with | None -> l | Some l -> l with Not_found -> l module Instance : sig type t = Level.t array val empty : t val is_empty : t -> bool val of_array : Level.t array -> t val to_array : t -> Level.t array val append : t -> t -> t val equal : t -> t -> bool val length : t -> int val hcons : t -> t val hash : t -> int val share : t -> t * int val subst_fn : universe_level_subst_fn -> t -> t val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds val levels : t -> LSet.t end = struct type t = Level.t array let empty : t = [||] module HInstancestruct = struct type _t = t type t = _t type u = Level.t -> Level.t let hashcons huniv a = let len = Array.length a in if Int.equal len 0 then empty else begin for i = 0 to len - 1 do let x = Array.unsafe_get a i in let x' = huniv x in if x == x' then () else Array.unsafe_set a i x' done; a end let eq t1 t2 = t1 == t2 || (Int.equal (Array.length t1) (Array.length t2) && let rec aux i = (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) in aux 0) let hash a = let accu = ref 0 in for i = 0 to Array.length a - 1 do let l = Array.unsafe_get a i in let h = Level.hash l in accu := Hashset.Combine.combine !accu h; done; (* [h] must be positive. *) let h = !accu land 0x3FFFFFFF in h end module HInstance = Hashcons.Make(HInstancestruct) let hcons = Hashcons.simple_hcons HInstance.generate HInstance.hcons Level.hcons let hash = HInstancestruct.hash let share a = (hcons a, hash a) let empty = hcons [||] let is_empty x = Int.equal (Array.length x) 0 let append x y = if Array.length x = 0 then y else if Array.length y = 0 then x else Array.append x y let of_array a = assert(Array.for_all (fun x -> not (Level.is_prop x)) a); a let to_array a = a let length a = Array.length a let subst_fn fn t = let t' = CArray.smartmap fn t in if t' == t then t else of_array t' let levels x = LSet.of_array x let pr = prvect_with_sep spc let equal t u = t == u || (Array.is_empty t && Array.is_empty u) || (CArray.for_all2 Level.equal t u (* Necessary as universe instances might come from different modules and unmarshalling doesn't preserve sharing *)) end let enforce_eq_instances x y = let ax = Instance.to_array x and ay = Instance.to_array y in if Array.length ax != Array.length ay then anomaly (Pp.(++) (Pp.str "Invalid argument: enforce_eq_instances called with") (Pp.str " instances of different lengths")); CArray.fold_right2 enforce_eq_level ax ay type universe_instance = Instance.t type 'a puniverses = 'a * Instance.t let out_punivs (x, y) = x let in_punivs x = (x, Instance.empty) let eq_puniverses f (x, u) (y, u') = f x y && Instance.equal u u' (** A context of universe levels with universe constraints, representing local universe variables and constraints *) module UContext = struct type t = Instance.t constrained let make x = x (** Universe contexts (variables as a list) *) let empty = (Instance.empty, Constraint.empty) let is_empty (univs, cst) = Instance.is_empty univs && Constraint.is_empty cst let pr prl (univs, cst as ctx) = if is_empty ctx then mt() else h 0 (Instance.pr prl univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) let hcons (univs, cst) = (Instance.hcons univs, hcons_constraints cst) let instance (univs, cst) = univs let constraints (univs, cst) = cst let union (univs, cst) (univs', cst') = Instance.append univs univs', Constraint.union cst cst' let dest x = x let size (x,_) = Instance.length x end type universe_context = UContext.t let hcons_universe_context = UContext.hcons (** A set of universes with universe constraints. We linearize the set to a list after typechecking. Beware, representation could change. *) module ContextSet = struct type t = universe_set constrained let empty = (LSet.empty, Constraint.empty) let is_empty (univs, cst) = LSet.is_empty univs && Constraint.is_empty cst let equal (univs, cst as x) (univs', cst' as y) = x == y || (LSet.equal univs univs' && Constraint.equal cst cst') let of_set s = (s, Constraint.empty) let singleton l = of_set (LSet.singleton l) let of_instance i = of_set (Instance.levels i) let union (univs, cst as x) (univs', cst' as y) = if x == y then x else LSet.union univs univs', Constraint.union cst cst' let append (univs, cst) (univs', cst') = let univs = LSet.fold LSet.add univs univs' in let cst = Constraint.fold Constraint.add cst cst' in (univs, cst) let diff (univs, cst) (univs', cst') = LSet.diff univs univs', Constraint.diff cst cst' let add_universe u (univs, cst) = LSet.add u univs, cst let add_constraints cst' (univs, cst) = univs, Constraint.union cst cst' let add_instance inst (univs, cst) = let v = Instance.to_array inst in let fold accu u = LSet.add u accu in let univs = Array.fold_left fold univs v in (univs, cst) let sort_levels a = Array.sort Level.natural_compare a; a let to_context (ctx, cst) = (Instance.of_array (sort_levels (Array.of_list (LSet.elements ctx))), cst) let of_context (ctx, cst) = (Instance.levels ctx, cst) let pr prl (univs, cst as ctx) = if is_empty ctx then mt() else h 0 (LSet.pr prl univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) let constraints (univs, cst) = cst let levels (univs, cst) = univs end type universe_context_set = ContextSet.t (** A value in a universe context (resp. context set). *) type 'a in_universe_context = 'a * universe_context type 'a in_universe_context_set = 'a * universe_context_set (** Substitutions. *) let empty_subst = LMap.empty let is_empty_subst = LMap.is_empty let empty_level_subst = LMap.empty let is_empty_level_subst = LMap.is_empty (** Substitution functions *) (** With level to level substitutions. *) let subst_univs_level_level subst l = try LMap.find l subst with Not_found -> l let subst_univs_level_universe subst u = let f x = Universe.Expr.map (fun u -> subst_univs_level_level subst u) x in let u' = Universe.smartmap f u in if u == u' then u else Universe.sort u' let subst_univs_level_instance subst i = let i' = Instance.subst_fn (subst_univs_level_level subst) i in if i == i' then i else i' let subst_univs_level_constraint subst (u,d,v) = let u' = subst_univs_level_level subst u and v' = subst_univs_level_level subst v in if d != Lt && Level.equal u' v' then None else Some (u',d,v') let subst_univs_level_constraints subst csts = Constraint.fold (fun c -> Option.fold_right Constraint.add (subst_univs_level_constraint subst c)) csts Constraint.empty (** With level to universe substitutions. *) type universe_subst_fn = universe_level -> universe let make_subst subst = fun l -> LMap.find l subst let subst_univs_expr_opt fn (l,n) = Universe.addn n (fn l) let subst_univs_universe fn ul = let subst, nosubst = Universe.Huniv.fold (fun u (subst,nosubst) -> try let a' = subst_univs_expr_opt fn u in (a' :: subst, nosubst) with Not_found -> (subst, u :: nosubst)) ul ([], []) in if CList.is_empty subst then ul else let substs = List.fold_left Universe.merge_univs Universe.empty subst in List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u)) substs nosubst let subst_univs_level fn l = try Some (fn l) with Not_found -> None let subst_univs_constraint fn (u,d,v as c) cstrs = let u' = subst_univs_level fn u in let v' = subst_univs_level fn v in match u', v' with | None, None -> Constraint.add c cstrs | Some u, None -> enforce_univ_constraint (u,d,make v) cstrs | None, Some v -> enforce_univ_constraint (make u,d,v) cstrs | Some u, Some v -> enforce_univ_constraint (u,d,v) cstrs let subst_univs_constraints subst csts = Constraint.fold (fun c cstrs -> subst_univs_constraint subst c cstrs) csts Constraint.empty let subst_instance_level s l = match l.Level.data with | Level.Var n -> s.(n) | _ -> l let subst_instance_instance s i = Array.smartmap (fun l -> subst_instance_level s l) i let subst_instance_universe s u = let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in let u' = Universe.smartmap f u in if u == u' then u else Universe.sort u' let subst_instance_constraint s (u,d,v as c) = let u' = subst_instance_level s u in let v' = subst_instance_level s v in if u' == u && v' == v then c else (u',d,v') let subst_instance_constraints s csts = Constraint.fold (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) csts Constraint.empty (** Substitute instance inst for ctx in csts *) let instantiate_univ_context (ctx, csts) = (ctx, subst_instance_constraints ctx csts) let instantiate_univ_constraints u (_, csts) = subst_instance_constraints u csts let make_instance_subst i = let arr = Instance.to_array i in Array.fold_left_i (fun i acc l -> LMap.add l (Level.var i) acc) LMap.empty arr let make_inverse_instance_subst i = let arr = Instance.to_array i in Array.fold_left_i (fun i acc l -> LMap.add (Level.var i) l acc) LMap.empty arr let abstract_universes poly ctx = let instance = UContext.instance ctx in if poly then let subst = make_instance_subst instance in let cstrs = subst_univs_level_constraints subst (UContext.constraints ctx) in let ctx = UContext.make (instance, cstrs) in subst, ctx else empty_level_subst, ctx (** Pretty-printing *) let pr_constraints prl = Constraint.pr prl let pr_universe_context = UContext.pr let pr_universe_context_set = ContextSet.pr let pr_universe_subst = LMap.pr (fun u -> str" := " ++ Universe.pr u ++ spc ()) let pr_universe_level_subst = LMap.pr (fun u -> str" := " ++ Level.pr u ++ spc ()) module Huniverse_set = Hashcons.Make( struct type t = universe_set type u = universe_level -> universe_level let hashcons huc s = LSet.fold (fun x -> LSet.add (huc x)) s LSet.empty let eq s s' = LSet.equal s s' let hash = Hashtbl.hash end) let hcons_universe_set = Hashcons.simple_hcons Huniverse_set.generate Huniverse_set.hcons Level.hcons let hcons_universe_context_set (v, c) = (hcons_universe_set v, hcons_constraints c) let hcons_univ x = Universe.hcons x let explain_universe_inconsistency prl (o,u,v,p) = let pr_uni = Universe.pr_with prl in let pr_rel = function | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" in let reason = match p with | None | Some [] -> mt() | Some p -> str " because" ++ spc() ++ pr_uni v ++ prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ pr_uni v) p ++ (if Universe.equal (snd (List.last p)) u then mt() else (spc() ++ str "= " ++ pr_uni u)) in str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++ pr_rel o ++ spc() ++ pr_uni v ++ reason let compare_levels = Level.compare let eq_levels = Level.equal let equal_universes = Universe.equal let subst_instance_constraints = if Flags.profile then let key = Profile.declare_profile "subst_instance_constraints" in Profile.profile2 key subst_instance_constraints else subst_instance_constraints coq-8.6/kernel/vm.mli0000644000175000017500000000451413022274260014070 0ustar mdenesmdenesopen Names open Term open Cbytecodes (** Debug printing *) val set_drawinstr : unit -> unit (** Machine code *) type tcode (** Values *) type vprod type vfun type vfix type vcofix type vblock type vswitch type arguments type atom = | Aid of Vars.id_key | Aind of inductive | Atype of Univ.universe (** Zippers *) type zipper = | Zapp of arguments | Zfix of vfix * arguments (** might be empty *) | Zswitch of vswitch | Zproj of Constant.t (* name of the projection *) type stack = zipper list type to_up type whd = | Vsort of sorts | Vprod of vprod | Vfun of vfun | Vfix of vfix * arguments option | Vcofix of vcofix * to_up * arguments option | Vconstr_const of int | Vconstr_block of vblock | Vatom_stk of atom * stack | Vuniv_level of Univ.universe_level (** For debugging purposes only *) val pr_atom : atom -> Pp.std_ppcmds val pr_whd : whd -> Pp.std_ppcmds val pr_stack : stack -> Pp.std_ppcmds (** Constructors *) val val_of_str_const : structured_constant -> values val val_of_rel : int -> values val val_of_named : Id.t -> values val val_of_constant : constant -> values external val_of_annot_switch : annot_switch -> values = "%identity" (** Destructors *) val whd_val : values -> whd val uni_lvl_val : values -> Univ.universe_level (** Arguments *) val nargs : arguments -> int val arg : arguments -> int -> values (** Product *) val dom : vprod -> values val codom : vprod -> vfun (** Function *) val body_of_vfun : int -> vfun -> values val decompose_vfun2 : int -> vfun -> vfun -> int * values * values (** Fix *) val current_fix : vfix -> int val check_fix : vfix -> vfix -> bool val rec_args : vfix -> int array val reduce_fix : int -> vfix -> vfun array * values array (** bodies , types *) (** CoFix *) val current_cofix : vcofix -> int val check_cofix : vcofix -> vcofix -> bool val reduce_cofix : int -> vcofix -> values array * values array (** bodies , types *) (** Block *) val btag : vblock -> int val bsize : vblock -> int val bfield : vblock -> int -> values (** Switch *) val check_switch : vswitch -> vswitch -> bool val case_info : vswitch -> case_info val type_of_switch : vswitch -> values val branch_of_switch : int -> vswitch -> (int * values) array (** Apply a value *) val apply_whd : int -> whd -> values coq-8.6/kernel/subtyping.ml0000644000175000017500000004644213022274260015327 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Label.Map.add (Label.of_id id) (IndConstr((ip,i+1), mib)) map) oib.mind_consnames map in Label.Map.add (Label.of_id oib.mind_typename) (IndType (ip, mib)) map in Array.fold_right_i add_mip_nameobjects mib.mind_packets map (* creates (namedobject/namedmodule) map for the whole signature *) type labmap = { objs : namedobject Label.Map.t; mods : namedmodule Label.Map.t } let empty_labmap = { objs = Label.Map.empty; mods = Label.Map.empty } let get_obj mp map l = try Label.Map.find l map.objs with Not_found -> error_no_such_label_sub l (string_of_mp mp) let get_mod mp map l = try Label.Map.find l map.mods with Not_found -> error_no_such_label_sub l (string_of_mp mp) let make_labmap mp list = let add_one (l,e) map = match e with | SFBconst cb -> { map with objs = Label.Map.add l (Constant cb) map.objs } | SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs } | SFBmodule mb -> { map with mods = Label.Map.add l (Module mb) map.mods } | SFBmodtype mtb -> { map with mods = Label.Map.add l (Modtype mtb) map.mods } in List.fold_right add_one list empty_labmap let check_conv_error error why cst poly u f env a1 a2 = try let a1 = Vars.subst_instance_constr u a1 in let a2 = Vars.subst_instance_constr u a2 in let cst' = f env (Environ.universes env) a1 a2 in if poly then if Constraint.is_empty cst' then cst else error (IncompatiblePolymorphism (env, a1, a2)) else Constraint.union cst cst' with NotConvertible -> error why (* for now we do not allow reorderings *) let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= let kn1 = KerName.make2 mp1 l in let kn2 = KerName.make2 mp2 l in let error why = error_signature_mismatch l spec2 why in let check_conv why cst poly u f = check_conv_error error why cst poly u f in let mib1 = match info1 with | IndType ((_,0), mib) -> Declareops.subst_mind_body subst1 mib | _ -> error (InductiveFieldExpected mib2) in let poly = if not (mib1.mind_polymorphic == mib2.mind_polymorphic) then error (PolymorphicStatusExpected mib2.mind_polymorphic) else mib2.mind_polymorphic in let u = if poly then CErrors.error ("Checking of subtyping of polymorphic" ^ " inductive types not implemented") else Instance.empty in let mib2 = Declareops.subst_mind_body subst2 mib2 in let check_inductive_type cst name env t1 t2 = (* Due to sort-polymorphism in inductive types, the conclusions of t1 and t2, if in Type, are generated as the least upper bounds of the types of the constructors. By monotonicity of the infered l.u.b. wrt subtyping (i.e. if X:U |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each universe in the conclusion of t1 has an bounding universe in the conclusion of t2, so that we don't need to check the subtyping of the conclusions of t1 and t2. Even if we'd like to recheck it, the inference of constraints is not designed to deal with algebraic constraints of the form max-univ(u1..un) <= max-univ(u'1..u'n), so that it is not easy to recheck it (in short, we would need the actual graph of constraints as input while type checking is currently designed to output a set of constraints instead) *) (* So we cheat and replace the subtyping problem on algebraic constraints of the form max-univ(u1..un) <= max-univ(u'1..u'n) (that we know are necessary true) by trivial constraints that the constraint generator knows how to deal with *) let (ctx1,s1) = dest_arity env t1 in let (ctx2,s2) = dest_arity env t2 in let s1,s2 = match s1, s2 with | Type _, Type _ -> (* shortcut here *) prop_sort, prop_sort | (Prop _, Type _) | (Type _,Prop _) -> error (NotConvertibleInductiveField name) | _ -> (s1, s2) in check_conv (NotConvertibleInductiveField name) cst poly u infer_conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) in let check_packet cst p1 p2 = let check f test why = if not (test (f p1) (f p2)) then error why in check (fun p -> p.mind_consnames) (Array.equal Id.equal) NotSameConstructorNamesField; check (fun p -> p.mind_typename) Id.equal NotSameInductiveNameInBlockField; (* nf_lc later *) (* nf_arity later *) (* user_lc ignored *) (* user_arity ignored *) check (fun p -> p.mind_nrealargs) Int.equal (NotConvertibleInductiveField p2.mind_typename); (* How can it fail since the type of inductive are checked below? [HH] *) (* kelim ignored *) (* listrec ignored *) (* finite done *) (* nparams done *) (* params_ctxt done because part of the inductive types *) (* Don't check the sort of the type if polymorphic *) let ty1, cst1 = constrained_type_of_inductive env ((mib1,p1),u) in let ty2, cst2 = constrained_type_of_inductive env ((mib2,p2),u) in let cst = Constraint.union cst1 (Constraint.union cst2 cst) in let cst = check_inductive_type cst p2.mind_typename env ty1 ty2 in cst in let mind = mind_of_kn kn1 in let check_cons_types i cst p1 p2 = Array.fold_left3 (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst poly u infer_conv env t1 t2) cst p2.mind_consnames (arities_of_specif (mind,u) (mib1,p1)) (arities_of_specif (mind,u) (mib2,p2)) in let check f test why = if not (test (f mib1) (f mib2)) then error (why (f mib2)) in check (fun mib -> mib.mind_finite<>Decl_kinds.CoFinite) (==) (fun x -> FiniteInductiveFieldExpected x); check (fun mib -> mib.mind_ntypes) Int.equal (fun x -> InductiveNumbersFieldExpected x); assert (List.is_empty mib1.mind_hyps && List.is_empty mib2.mind_hyps); assert (Array.length mib1.mind_packets >= 1 && Array.length mib2.mind_packets >= 1); (* Check that the expected numbers of uniform parameters are the same *) (* No need to check the contexts of parameters: it is checked *) (* at the time of checking the inductive arities in check_packet. *) (* Notice that we don't expect the local definitions to match: only *) (* the inductive types and constructors types have to be convertible *) check (fun mib -> mib.mind_nparams) Int.equal (fun x -> InductiveParamsNumberField x); begin let kn2' = kn_of_delta reso2 kn2 in if KerName.equal kn2 kn2' || MutInd.equal (mind_of_delta_kn reso1 kn1) (subst_mind subst2 (MutInd.make kn2 kn2')) then () else error NotEqualInductiveAliases end; (* we check that records and their field names are preserved. *) check (fun mib -> mib.mind_record <> None) (==) (fun x -> RecordFieldExpected x); if mib1.mind_record <> None then begin let rec names_prod_letin t = match kind_of_term t with | Prod(n,_,t) -> n::(names_prod_letin t) | LetIn(n,_,_,t) -> n::(names_prod_letin t) | Cast(t,_,_) -> names_prod_letin t | _ -> [] in assert (Int.equal (Array.length mib1.mind_packets) 1); assert (Int.equal (Array.length mib2.mind_packets) 1); assert (Int.equal (Array.length mib1.mind_packets.(0).mind_user_lc) 1); assert (Int.equal (Array.length mib2.mind_packets.(0).mind_user_lc) 1); check (fun mib -> let nparamdecls = List.length mib.mind_params_ctxt in let names = names_prod_letin (mib.mind_packets.(0).mind_user_lc.(0)) in snd (List.chop nparamdecls names)) (List.equal Name.equal) (fun x -> RecordProjectionsExpected x); end; (* we first check simple things *) let cst = Array.fold_left2 check_packet cst mib1.mind_packets mib2.mind_packets in (* and constructor types in the end *) let cst = Array.fold_left2_i check_cons_types cst mib1.mind_packets mib2.mind_packets in cst let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = let error why = error_signature_mismatch l spec2 why in let check_conv cst poly u f = check_conv_error error cst poly u f in let check_type poly u cst env t1 t2 = let err = NotConvertibleTypeField (env, t1, t2) in (* If the type of a constant is generated, it may mention non-variable algebraic universes that the general conversion algorithm is not ready to handle. Anyway, generated types of constants are functions of the body of the constant. If the bodies are the same in environments that are subtypes one of the other, the types are subtypes too (i.e. if Gamma <= Gamma', Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T'). Hence they don't have to be checked again *) let t1,t2 = if isArity t2 then let (ctx2,s2) = destArity t2 in match s2 with | Type v when not (is_univ_variable v) -> (* The type in the interface is inferred and is made of algebraic universes *) begin try let (ctx1,s1) = dest_arity env t1 in match s1 with | Type u when not (is_univ_variable u) -> (* Both types are inferred, no need to recheck them. We cheat and collapse the types to Prop *) mkArity (ctx1,prop_sort), mkArity (ctx2,prop_sort) | Prop _ -> (* The type in the interface is inferred, it may be the case that the type in the implementation is smaller because the body is more reduced. We safely collapse the upper type to Prop *) mkArity (ctx1,prop_sort), mkArity (ctx2,prop_sort) | Type _ -> (* The type in the interface is inferred and the type in the implementation is not inferred or is inferred but from a more reduced body so that it is just a variable. Since constraints of the form "univ <= max(...)" are not expressible in the system of algebraic universes: we fail (the user has to use an explicit type in the interface *) error NoTypeConstraintExpected with NotArity -> error err end | _ -> t1,t2 else (t1,t2) in check_conv err cst poly u infer_conv_leq env t1 t2 in match info1 with | Constant cb1 -> let () = assert (List.is_empty cb1.const_hyps && List.is_empty cb2.const_hyps) in let cb1 = Declareops.subst_const_body subst1 cb1 in let cb2 = Declareops.subst_const_body subst2 cb2 in (* Start by checking universes *) let poly = if not (cb1.const_polymorphic == cb2.const_polymorphic) then error (PolymorphicStatusExpected cb2.const_polymorphic) else cb2.const_polymorphic in let cst', env', u = if poly then let ctx1 = Univ.instantiate_univ_context cb1.const_universes in let ctx2 = Univ.instantiate_univ_context cb2.const_universes in let inst1, ctx1 = Univ.UContext.dest ctx1 in let inst2, ctx2 = Univ.UContext.dest ctx2 in if not (Univ.Instance.length inst1 == Univ.Instance.length inst2) then error IncompatibleInstances else let cstrs = Univ.enforce_eq_instances inst1 inst2 cst in let cstrs = Univ.Constraint.union cstrs ctx2 in try (* The environment with the expected universes plus equality of the body instances with the expected instance *) let ctxi = Univ.Instance.append inst1 inst2 in let ctx = Univ.UContext.make (ctxi, cstrs) in let env = Environ.push_context ctx env in (* Check that the given definition does not add any constraint over the expected ones, so that it can be used in place of the original. *) if UGraph.check_constraints ctx1 (Environ.universes env) then cstrs, env, inst2 else error (IncompatibleConstraints ctx1) with Univ.UniverseInconsistency incon -> error (IncompatibleUniverses incon) else cst, env, Univ.Instance.empty in (* Now check types *) let typ1 = Typeops.type_of_constant_type env' cb1.const_type in let typ2 = Typeops.type_of_constant_type env' cb2.const_type in let cst = check_type poly u cst env' typ1 typ2 in (* Now we check the bodies: - A transparent constant can only be implemented by a compatible transparent constant. - In the signature, an opaque is handled just as a parameter: anything of the right type can implement it, even if bodies differ. *) (match cb2.const_body with | Undef _ | OpaqueDef _ -> cst | Def lc2 -> (match cb1.const_body with | Undef _ | OpaqueDef _ -> error NotConvertibleBodyField | Def lc1 -> (* NB: cb1 might have been strengthened and appear as transparent. Anyway [check_conv] will handle that afterwards. *) let c1 = Mod_subst.force_constr lc1 in let c2 = Mod_subst.force_constr lc2 in check_conv NotConvertibleBodyField cst poly u infer_conv env' c1 c2)) | IndType ((kn,i),mind1) -> ignore (CErrors.error ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by an inductive type. Hint: you can rename the " ^ "inductive type and give a definition to map the old name to the new " ^ "name.")); let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; let u1 = inductive_instance mind1 in let arity1,cst1 = constrained_type_of_inductive env ((mind1,mind1.mind_packets.(i)),u1) in let cst2 = Declareops.constraints_of_constant (Environ.opaque_tables env) cb2 in let typ2 = Typeops.type_of_constant_type env cb2.const_type in let cst = Constraint.union cst (Constraint.union cst1 cst2) in let error = NotConvertibleTypeField (env, arity1, typ2) in check_conv error cst false Univ.Instance.empty infer_conv_leq env arity1 typ2 | IndConstr (((kn,i),j) as cstr,mind1) -> ignore (CErrors.error ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by a constructor. Hint: you can rename the " ^ "constructor and give a definition to map the old name to the new " ^ "name.")); let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; let u1 = inductive_instance mind1 in let ty1,cst1 = constrained_type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in let cst2 = Declareops.constraints_of_constant (Environ.opaque_tables env) cb2 in let ty2 = Typeops.type_of_constant_type env cb2.const_type in let cst = Constraint.union cst (Constraint.union cst1 cst2) in let error = NotConvertibleTypeField (env, ty1, ty2) in check_conv error cst false Univ.Instance.empty infer_conv env ty1 ty2 let rec check_modules cst env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module msb1 in let mty2 = module_type_of_module msb2 in check_modtypes cst env mty1 mty2 subst1 subst2 false and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2= let map1 = make_labmap mp1 sig1 in let check_one_body cst (l,spec2) = match spec2 with | SFBconst cb2 -> check_constant cst env mp1 l (get_obj mp1 map1 l) cb2 spec2 subst1 subst2 | SFBmind mib2 -> check_inductive cst env mp1 l (get_obj mp1 map1 l) mp2 mib2 spec2 subst1 subst2 reso1 reso2 | SFBmodule msb2 -> begin match get_mod mp1 map1 l with | Module msb -> check_modules cst env msb msb2 subst1 subst2 | _ -> error_signature_mismatch l spec2 ModuleFieldExpected end | SFBmodtype mtb2 -> let mtb1 = match get_mod mp1 map1 l with | Modtype mtb -> mtb | _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected in let env = add_module_type mtb2.mod_mp mtb2 (add_module_type mtb1.mod_mp mtb1 env) in check_modtypes cst env mtb1 mtb2 subst1 subst2 true in List.fold_left check_one_body cst sig2 and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = if mtb1==mtb2 || mtb1.mod_type == mtb2.mod_type then cst else let rec check_structure cst env str1 str2 equiv subst1 subst2 = match str1,str2 with |NoFunctor list1, NoFunctor list2 -> if equiv then let subst2 = add_mp mtb2.mod_mp mtb1.mod_mp mtb1.mod_delta subst2 in let cst1 = check_signatures cst env mtb1.mod_mp list1 mtb2.mod_mp list2 subst1 subst2 mtb1.mod_delta mtb2.mod_delta in let cst2 = check_signatures cst env mtb2.mod_mp list2 mtb1.mod_mp list1 subst2 subst1 mtb2.mod_delta mtb1.mod_delta in Univ.Constraint.union cst1 cst2 else check_signatures cst env mtb1.mod_mp list1 mtb2.mod_mp list2 subst1 subst2 mtb1.mod_delta mtb2.mod_delta |MoreFunctor (arg_id1,arg_t1,body_t1), MoreFunctor (arg_id2,arg_t2,body_t2) -> let mp2 = MPbound arg_id2 in let subst1 = join (map_mbid arg_id1 mp2 arg_t2.mod_delta) subst1 in let cst = check_modtypes cst env arg_t2 arg_t1 subst2 subst1 equiv in (* contravariant *) let env = add_module_type mp2 arg_t2 env in let env = if Modops.is_functor body_t1 then env else add_module {mod_mp = mtb1.mod_mp; mod_expr = Abstract; mod_type = subst_signature subst1 body_t1; mod_type_alg = None; mod_constraints = mtb1.mod_constraints; mod_retroknowledge = []; mod_delta = mtb1.mod_delta} env in check_structure cst env body_t1 body_t2 equiv subst1 subst2 | _ , _ -> error_incompatible_modtypes mtb1 mtb2 in check_structure cst env mtb1.mod_type mtb2.mod_type equiv subst1 subst2 let check_subtypes env sup super = let env = add_module_type sup.mod_mp sup env in let env = Environ.push_context_set ~strict:true super.mod_constraints env in check_modtypes Univ.Constraint.empty env (strengthen sup sup.mod_mp) super empty_subst (map_mp super.mod_mp sup.mod_mp sup.mod_delta) false coq-8.6/kernel/term.ml0000644000175000017500000005712713022274260014254 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* n | _ -> raise DestKO (* Destructs an existential variable *) let destMeta c = match kind_of_term c with | Meta n -> n | _ -> raise DestKO let isMeta c = match kind_of_term c with Meta _ -> true | _ -> false let isMetaOf mv c = match kind_of_term c with Meta mv' -> Int.equal mv mv' | _ -> false (* Destructs a variable *) let destVar c = match kind_of_term c with | Var id -> id | _ -> raise DestKO (* Destructs a type *) let isSort c = match kind_of_term c with | Sort _ -> true | _ -> false let destSort c = match kind_of_term c with | Sort s -> s | _ -> raise DestKO let rec isprop c = match kind_of_term c with | Sort (Prop _) -> true | Cast (c,_,_) -> isprop c | _ -> false let rec is_Prop c = match kind_of_term c with | Sort (Prop Null) -> true | Cast (c,_,_) -> is_Prop c | _ -> false let rec is_Set c = match kind_of_term c with | Sort (Prop Pos) -> true | Cast (c,_,_) -> is_Set c | _ -> false let rec is_Type c = match kind_of_term c with | Sort (Type _) -> true | Cast (c,_,_) -> is_Type c | _ -> false let is_small = Sorts.is_small let iskind c = isprop c || is_Type c (* Tests if an evar *) let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false let isEvar_or_Meta c = match kind_of_term c with | Evar _ | Meta _ -> true | _ -> false (* Destructs a casted term *) let destCast c = match kind_of_term c with | Cast (t1,k,t2) -> (t1,k,t2) | _ -> raise DestKO let isCast c = match kind_of_term c with Cast _ -> true | _ -> false (* Tests if a de Bruijn index *) let isRel c = match kind_of_term c with Rel _ -> true | _ -> false let isRelN n c = match kind_of_term c with Rel n' -> Int.equal n n' | _ -> false (* Tests if a variable *) let isVar c = match kind_of_term c with Var _ -> true | _ -> false let isVarId id c = match kind_of_term c with Var id' -> Id.equal id id' | _ -> false (* Tests if an inductive *) let isInd c = match kind_of_term c with Ind _ -> true | _ -> false (* Destructs the product (x:t1)t2 *) let destProd c = match kind_of_term c with | Prod (x,t1,t2) -> (x,t1,t2) | _ -> raise DestKO let isProd c = match kind_of_term c with | Prod _ -> true | _ -> false (* Destructs the abstraction [x:t1]t2 *) let destLambda c = match kind_of_term c with | Lambda (x,t1,t2) -> (x,t1,t2) | _ -> raise DestKO let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false (* Destructs the let [x:=b:t1]t2 *) let destLetIn c = match kind_of_term c with | LetIn (x,b,t1,t2) -> (x,b,t1,t2) | _ -> raise DestKO let isLetIn c = match kind_of_term c with LetIn _ -> true | _ -> false (* Destructs an application *) let destApp c = match kind_of_term c with | App (f,a) -> (f, a) | _ -> raise DestKO let destApplication = destApp let isApp c = match kind_of_term c with App _ -> true | _ -> false (* Destructs a constant *) let destConst c = match kind_of_term c with | Const kn -> kn | _ -> raise DestKO let isConst c = match kind_of_term c with Const _ -> true | _ -> false (* Destructs an existential variable *) let destEvar c = match kind_of_term c with | Evar (kn, a as r) -> r | _ -> raise DestKO (* Destructs a (co)inductive type named kn *) let destInd c = match kind_of_term c with | Ind (kn, a as r) -> r | _ -> raise DestKO (* Destructs a constructor *) let destConstruct c = match kind_of_term c with | Construct (kn, a as r) -> r | _ -> raise DestKO let isConstruct c = match kind_of_term c with Construct _ -> true | _ -> false (* Destructs a term

Case c of lc1 | lc2 .. | lcn end *) let destCase c = match kind_of_term c with | Case (ci,p,c,v) -> (ci,p,c,v) | _ -> raise DestKO let isCase c = match kind_of_term c with Case _ -> true | _ -> false let isProj c = match kind_of_term c with Proj _ -> true | _ -> false let destProj c = match kind_of_term c with | Proj (p, c) -> (p, c) | _ -> raise DestKO let destFix c = match kind_of_term c with | Fix fix -> fix | _ -> raise DestKO let isFix c = match kind_of_term c with Fix _ -> true | _ -> false let destCoFix c = match kind_of_term c with | CoFix cofix -> cofix | _ -> raise DestKO let isCoFix c = match kind_of_term c with CoFix _ -> true | _ -> false (******************************************************************) (* Cast management *) (******************************************************************) let rec strip_outer_cast c = match kind_of_term c with | Cast (c,_,_) -> strip_outer_cast c | _ -> c (* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *) let under_outer_cast f c = match kind_of_term c with | Cast (b,k,t) -> mkCast (f b, k, f t) | _ -> f c let rec under_casts f c = match kind_of_term c with | Cast (c,k,t) -> mkCast (under_casts f c, k, t) | _ -> f c (******************************************************************) (* Flattening and unflattening of embedded applications and casts *) (******************************************************************) (* flattens application lists throwing casts in-between *) let collapse_appl c = match kind_of_term c with | App (f,cl) -> let rec collapse_rec f cl2 = match kind_of_term (strip_outer_cast f) with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) | _ -> mkApp (f,cl2) in collapse_rec f cl | _ -> c let decompose_app c = match kind_of_term c with | App (f,cl) -> (f, Array.to_list cl) | _ -> (c,[]) let decompose_appvect c = match kind_of_term c with | App (f,cl) -> (f, cl) | _ -> (c,[||]) (****************************************************************************) (* Functions for dealing with constr terms *) (****************************************************************************) (***************************) (* Other term constructors *) (***************************) let mkNamedProd id typ c = mkProd (Name id, typ, subst_var id c) let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c) let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2) (* Constructs either [(x:t)c] or [[x=b:t]c] *) let mkProd_or_LetIn decl c = let open Context.Rel.Declaration in match decl with | LocalAssum (na,t) -> mkProd (na, t, c) | LocalDef (na,b,t) -> mkLetIn (na, b, t, c) let mkNamedProd_or_LetIn decl c = let open Context.Named.Declaration in match decl with | LocalAssum (id,t) -> mkNamedProd id t c | LocalDef (id,b,t) -> mkNamedLetIn id b t c (* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *) let mkProd_wo_LetIn decl c = let open Context.Rel.Declaration in match decl with | LocalAssum (na,t) -> mkProd (na, t, c) | LocalDef (na,b,t) -> subst1 b c let mkNamedProd_wo_LetIn decl c = let open Context.Named.Declaration in match decl with | LocalAssum (id,t) -> mkNamedProd id t c | LocalDef (id,b,t) -> subst1 b (subst_var id c) (* non-dependent product t1 -> t2 *) let mkArrow t1 t2 = mkProd (Anonymous, t1, t2) (* Constructs either [[x:t]c] or [[x=b:t]c] *) let mkLambda_or_LetIn decl c = let open Context.Rel.Declaration in match decl with | LocalAssum (na,t) -> mkLambda (na, t, c) | LocalDef (na,b,t) -> mkLetIn (na, b, t, c) let mkNamedLambda_or_LetIn decl c = let open Context.Named.Declaration in match decl with | LocalAssum (id,t) -> mkNamedLambda id t c | LocalDef (id,b,t) -> mkNamedLetIn id b t c (* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *) let prodn n env b = let rec prodrec = function | (0, env, b) -> b | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) | _ -> assert false in prodrec (n,env,b) (* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *) let compose_prod l b = prodn (List.length l) l b (* lamn n [xn:Tn;..;x1:T1;Gamma] b = [x1:T1]..[xn:Tn]b *) let lamn n env b = let rec lamrec = function | (0, env, b) -> b | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) | _ -> assert false in lamrec (n,env,b) (* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) let compose_lam l b = lamn (List.length l) l b let applist (f,l) = mkApp (f, Array.of_list l) let applistc f l = mkApp (f, Array.of_list l) let appvect = mkApp let appvectc f l = mkApp (f,l) (* to_lambda n (x1:T1)...(xn:Tn)T = * [x1:T1]...[xn:Tn]T *) let rec to_lambda n prod = if Int.equal n 0 then prod else match kind_of_term prod with | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) | Cast (c,_,_) -> to_lambda n c | _ -> errorlabstrm "to_lambda" (mt ()) let rec to_prod n lam = if Int.equal n 0 then lam else match kind_of_term lam with | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd) | Cast (c,_,_) -> to_prod n c | _ -> errorlabstrm "to_prod" (mt ()) let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) (* Application with expected on-the-fly reduction *) let lambda_applist c l = let rec app subst c l = match kind_of_term c, l with | Lambda(_,_,c), arg::l -> app (arg::subst) c l | _, [] -> substl subst c | _ -> anomaly (Pp.str "Not enough lambda's") in app [] c l let lambda_appvect c v = lambda_applist c (Array.to_list v) let lambda_applist_assum n c l = let rec app n subst t l = if Int.equal n 0 then if l == [] then substl subst t else anomaly (Pp.str "Not enough arguments") else match kind_of_term t, l with | Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l | _ -> anomaly (Pp.str "Not enough lambda/let's") in app n [] c l let lambda_appvect_assum n c v = lambda_applist_assum n c (Array.to_list v) (* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *) let prod_applist c l = let rec app subst c l = match kind_of_term c, l with | Prod(_,_,c), arg::l -> app (arg::subst) c l | _, [] -> substl subst c | _ -> anomaly (Pp.str "Not enough prod's") in app [] c l (* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) let prod_appvect c v = prod_applist c (Array.to_list v) let prod_applist_assum n c l = let rec app n subst t l = if Int.equal n 0 then if l == [] then substl subst t else anomaly (Pp.str "Not enough arguments") else match kind_of_term t, l with | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l | _ -> anomaly (Pp.str "Not enough prod/let's") in app n [] c l let prod_appvect_assum n c v = prod_applist_assum n c (Array.to_list v) (*********************************) (* Other term destructors *) (*********************************) (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) let decompose_prod = let rec prodec_rec l c = match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c in prodec_rec [] (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) let decompose_lam = let rec lamdec_rec l c = match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c in lamdec_rec [] (* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T) *) let decompose_prod_n n = if n < 0 then error "decompose_prod_n: integer parameter must be positive"; let rec prodec_rec l n c = if Int.equal n 0 then l,c else match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | _ -> error "decompose_prod_n: not enough products" in prodec_rec [] n (* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T) *) let decompose_lam_n n = if n < 0 then error "decompose_lam_n: integer parameter must be positive"; let rec lamdec_rec l n c = if Int.equal n 0 then l,c else match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c | _ -> error "decompose_lam_n: not enough abstractions" in lamdec_rec [] n (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) let decompose_prod_assum = let open Context.Rel.Declaration in let rec prodec_rec l c = match kind_of_term c with | Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) c | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c in prodec_rec Context.Rel.empty (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) let decompose_lam_assum = let rec lamdec_rec l c = let open Context.Rel.Declaration in match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c in lamdec_rec Context.Rel.empty (* Given a positive integer n, decompose a product or let-in term of the form [forall (x1:T1)..(xi:=ci:Ti)..(xn:Tn), T] into the pair of the quantifying context [(xn,None,Tn);..;(xi,Some ci,Ti);..;(x1,None,T1)] and of the inner type [T]) *) let decompose_prod_n_assum n = if n < 0 then error "decompose_prod_n_assum: integer parameter must be positive"; let rec prodec_rec l n c = if Int.equal n 0 then l,c else let open Context.Rel.Declaration in match kind_of_term c with | Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | c -> error "decompose_prod_n_assum: not enough assumptions" in prodec_rec Context.Rel.empty n (* Given a positive integer n, decompose a lambda or let-in term [fun (x1:T1)..(xi:=ci:Ti)..(xn:Tn) => T] into the pair of the abstracted context [(xn,None,Tn);...;(xi,Some ci,Ti);...;(x1,None,T1)] and of the inner body [T]. Lets in between are not expanded but turn into local definitions, but n is the actual number of destructurated lambdas. *) let decompose_lam_n_assum n = if n < 0 then error "decompose_lam_n_assum: integer parameter must be positive"; let rec lamdec_rec l n c = if Int.equal n 0 then l,c else let open Context.Rel.Declaration in match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) n c | Cast (c,_,_) -> lamdec_rec l n c | c -> error "decompose_lam_n_assum: not enough abstractions" in lamdec_rec Context.Rel.empty n (* Same, counting let-in *) let decompose_lam_n_decls n = if n < 0 then error "decompose_lam_n_decls: integer parameter must be positive"; let rec lamdec_rec l n c = if Int.equal n 0 then l,c else let open Context.Rel.Declaration in match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c | c -> error "decompose_lam_n_decls: not enough abstractions" in lamdec_rec Context.Rel.empty n let prod_assum t = fst (decompose_prod_assum t) let prod_n_assum n t = fst (decompose_prod_n_assum n t) let strip_prod_assum t = snd (decompose_prod_assum t) let strip_prod t = snd (decompose_prod t) let strip_prod_n n t = snd (decompose_prod_n n t) let lam_assum t = fst (decompose_lam_assum t) let lam_n_assum n t = fst (decompose_lam_n_assum n t) let strip_lam_assum t = snd (decompose_lam_assum t) let strip_lam t = snd (decompose_lam t) let strip_lam_n n t = snd (decompose_lam_n n t) (***************************) (* Arities *) (***************************) (* An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort. Such a term can canonically be seen as the pair of a context of types and of a sort *) type arity = Context.Rel.t * sorts let destArity = let open Context.Rel.Declaration in let rec prodec_rec l c = match kind_of_term c with | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) c | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s | _ -> anomaly ~label:"destArity" (Pp.str "not an arity") in prodec_rec [] let mkArity (sign,s) = it_mkProd_or_LetIn (mkSort s) sign let rec isArity c = match kind_of_term c with | Prod (_,_,c) -> isArity c | LetIn (_,b,_,c) -> isArity (subst1 b c) | Cast (c,_,_) -> isArity c | Sort _ -> true | _ -> false (** Kind of type *) (* Experimental, used in Presburger contrib *) type ('constr, 'types) kind_of_type = | SortType of sorts | CastType of 'types * 'types | ProdType of Name.t * 'types * 'types | LetInType of Name.t * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array let kind_of_type t = match kind_of_term t with | Sort s -> SortType s | Cast (c,_,t) -> CastType (c, t) | Prod (na,t,c) -> ProdType (na, t, c) | LetIn (na,b,t,c) -> LetInType (na, b, t, c) | App (c,l) -> AtomicType (c, l) | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Proj _ | Case _ | Fix _ | CoFix _ | Ind _) -> AtomicType (t,[||]) | (Lambda _ | Construct _) -> failwith "Not a type" coq-8.6/kernel/safe_typing.mli0000644000175000017500000001553013022274260015756 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* required:vodigest -> bool (** {6 Safe environments } *) (** Since we are now able to type terms, we can define an abstract type of safe environments, where objects are typed before being added. We also provide functionality for modules : [start_module], [end_module], etc. *) type safe_environment val empty_environment : safe_environment val is_initial : safe_environment -> bool val env_of_safe_env : safe_environment -> Environ.env (** The safe_environment state monad *) type safe_transformer0 = safe_environment -> safe_environment type 'a safe_transformer = safe_environment -> 'a * safe_environment (** {6 Stm machinery } *) type private_constant type private_constants type private_constant_role = | Subproof | Schema of inductive * string val side_effects_of_private_constants : private_constants -> Entries.side_effects val empty_private_constants : private_constants val add_private : private_constant -> private_constants -> private_constants val concat_private : private_constants -> private_constants -> private_constants val private_con_of_con : safe_environment -> constant -> private_constant val private_con_of_scheme : kind:string -> safe_environment -> (inductive * constant) list -> private_constant val mk_pure_proof : Constr.constr -> private_constants Entries.proof_output val inline_private_constants_in_constr : Environ.env -> Constr.constr -> private_constants -> Constr.constr val inline_private_constants_in_definition_entry : Environ.env -> private_constants Entries.definition_entry -> private_constants Entries.definition_entry val universes_of_private : private_constants -> Univ.universe_context_set list val is_curmod_library : safe_environment -> bool (* safe_environment has functional data affected by lazy computations, * thus this function returns a new safe_environment *) val join_safe_environment : ?except:Future.UUIDSet.t -> safe_environment -> safe_environment val is_joined_environment : safe_environment -> bool (** {6 Enriching a safe environment } *) (** Insertion of local declarations (Local or Variables) *) val push_named_assum : (Id.t * Term.types * bool (* polymorphic *)) Univ.in_universe_context_set -> safe_transformer0 (** Returns the full universe context necessary to typecheck the definition (futures are forced) *) val push_named_def : Id.t * private_constants Entries.definition_entry -> Univ.universe_context_set safe_transformer (** Insertion of global axioms or definitions *) type global_declaration = (* bool: export private constants *) | ConstantEntry of bool * private_constants Entries.constant_entry | GlobalRecipe of Cooking.recipe type exported_private_constant = constant * private_constants Entries.constant_entry * private_constant_role (** returns the main constant plus a list of auxiliary constants (empty unless one requires the side effects to be exported) *) val add_constant : DirPath.t -> Label.t -> global_declaration -> (constant * exported_private_constant list) safe_transformer (** Adding an inductive type *) val add_mind : DirPath.t -> Label.t -> Entries.mutual_inductive_entry -> mutual_inductive safe_transformer (** Adding a module or a module type *) val add_module : Label.t -> Entries.module_entry -> Declarations.inline -> (module_path * Mod_subst.delta_resolver) safe_transformer val add_modtype : Label.t -> Entries.module_type_entry -> Declarations.inline -> module_path safe_transformer (** Adding universe constraints *) val push_context_set : bool -> Univ.universe_context_set -> safe_transformer0 val push_context : bool -> Univ.universe_context -> safe_transformer0 val add_constraints : Univ.constraints -> safe_transformer0 (* (\** Generator of universes *\) *) (* val next_universe : int safe_transformer *) (** Setting the type theory flavor *) val set_engagement : Declarations.engagement -> safe_transformer0 val set_typing_flags : Declarations.typing_flags -> safe_transformer0 (** {6 Interactive module functions } *) val start_module : Label.t -> module_path safe_transformer val start_modtype : Label.t -> module_path safe_transformer val add_module_parameter : MBId.t -> Entries.module_struct_entry -> Declarations.inline -> Mod_subst.delta_resolver safe_transformer (** The optional result type is given without its functorial part *) val end_module : Label.t -> (Entries.module_struct_entry * Declarations.inline) option -> (module_path * MBId.t list * Mod_subst.delta_resolver) safe_transformer val end_modtype : Label.t -> (module_path * MBId.t list) safe_transformer val add_include : Entries.module_struct_entry -> bool -> Declarations.inline -> Mod_subst.delta_resolver safe_transformer val current_modpath : safe_environment -> module_path val current_dirpath : safe_environment -> dir_path (** {6 Libraries : loading and saving compilation units } *) type compiled_library type native_library = Nativecode.global list val get_library_native_symbols : safe_environment -> DirPath.t -> Nativecode.symbols val start_library : DirPath.t -> module_path safe_transformer val export : ?except:Future.UUIDSet.t -> safe_environment -> DirPath.t -> module_path * compiled_library * native_library (* Constraints are non empty iff the file is a vi2vo *) val import : compiled_library -> Univ.universe_context_set -> vodigest -> module_path safe_transformer (** {6 Safe typing judgments } *) type judgment val j_val : judgment -> Term.constr val j_type : judgment -> Term.constr (** The safe typing of a term returns a typing judgment. *) val typing : safe_environment -> Term.constr -> judgment (** {6 Queries } *) val exists_objlabel : Label.t -> safe_environment -> bool val delta_of_senv : safe_environment -> Mod_subst.delta_resolver * Mod_subst.delta_resolver (** {6 Retroknowledge / Native compiler } *) open Retroknowledge val retroknowledge : (retroknowledge-> 'a) -> safe_environment -> 'a val register : field -> Retroknowledge.entry -> Term.constr -> safe_transformer0 val register_inline : constant -> safe_transformer0 val set_strategy : safe_environment -> Names.constant Names.tableKey -> Conv_oracle.level -> safe_environment coq-8.6/kernel/inductive.ml0000644000175000017500000013200713022274260015266 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* = Array.length mib.mind_packets then error "Inductive.lookup_mind_specif: invalid inductive index"; (mib, mib.mind_packets.(tyi)) let find_rectype env c = let (t, l) = decompose_app (whd_all env c) in match kind_of_term t with | Ind ind -> (ind, l) | _ -> raise Not_found let find_inductive env c = let (t, l) = decompose_app (whd_all env c) in match kind_of_term t with | Ind ind when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite <> Decl_kinds.CoFinite -> (ind, l) | _ -> raise Not_found let find_coinductive env c = let (t, l) = decompose_app (whd_all env c) in match kind_of_term t with | Ind ind when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite == Decl_kinds.CoFinite -> (ind, l) | _ -> raise Not_found let inductive_params (mib,_) = mib.mind_nparams let inductive_paramdecls (mib,u) = Vars.subst_instance_context u mib.mind_params_ctxt let instantiate_inductive_constraints mib u = if mib.mind_polymorphic then Univ.subst_instance_constraints u (Univ.UContext.constraints mib.mind_universes) else Univ.Constraint.empty (************************************************************************) (* Build the substitution that replaces Rels by the appropriate *) (* inductives *) let ind_subst mind mib u = let ntypes = mib.mind_ntypes in let make_Ik k = mkIndU ((mind,ntypes-k-1),u) in List.init ntypes make_Ik (* Instantiate inductives in constructor type *) let constructor_instantiate mind u mib c = let s = ind_subst mind mib u in substl s (subst_instance_constr u c) let instantiate_params full t u args sign = let fail () = anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in let (rem_args, subs, ty) = Context.Rel.fold_outside (fun decl (largs,subs,ty) -> match (decl, largs, kind_of_term ty) with | (LocalAssum _, a::args, Prod(_,_,t)) -> (args, a::subs, t) | (LocalDef (_,b,_), _, LetIn(_,_,_,t)) -> (largs, (substl subs (subst_instance_constr u b))::subs, t) | (_,[],_) -> if full then fail() else ([], subs, ty) | _ -> fail ()) sign ~init:(args,[],t) in let () = if not (List.is_empty rem_args) then fail () in substl subs ty let full_inductive_instantiate mib u params sign = let dummy = prop_sort in let t = mkArity (Vars.subst_instance_context u sign,dummy) in fst (destArity (instantiate_params true t u params mib.mind_params_ctxt)) let full_constructor_instantiate ((mind,_),u,(mib,_),params) t = let inst_ind = constructor_instantiate mind u mib t in instantiate_params true inst_ind u params mib.mind_params_ctxt (************************************************************************) (************************************************************************) (* Functions to build standard types related to inductive *) (* Computing the actual sort of an applied or partially applied inductive type: I_i: forall uniformparams:utyps, forall otherparams:otyps, Type(a) uniformargs : utyps otherargs : otyps I_1:forall ...,s_1;...I_n:forall ...,s_n |- sort(C_kj(uniformargs)) = s_kj s'_k = max(..s_kj..) merge(..s'_k..) = ..s''_k.. -------------------------------------------------------------------- Gamma |- I_i uniformargs otherargs : phi(s''_i) where - if p=0, phi() = Prop - if p=1, phi(s) = s - if p<>1, phi(s) = sup(Set,s) Remark: Set (predicative) is encoded as Type(0) *) let sort_as_univ = function | Type u -> u | Prop Null -> Universe.type0m | Prop Pos -> Universe.type0 (* Template polymorphism *) (* cons_subst add the mapping [u |-> su] in subst if [u] is not *) (* in the domain or add [u |-> sup x su] if [u] is already mapped *) (* to [x]. *) let cons_subst u su subst = try Univ.LMap.add u (Univ.sup (Univ.LMap.find u subst) su) subst with Not_found -> Univ.LMap.add u su subst (* remember_subst updates the mapping [u |-> x] by [u |-> sup x u] *) (* if it is presents and returns the substitution unchanged if not.*) let remember_subst u subst = try let su = Universe.make u in Univ.LMap.add u (Univ.sup (Univ.LMap.find u subst) su) subst with Not_found -> subst (* Bind expected levels of parameters to actual levels *) (* Propagate the new levels in the signature *) let make_subst env = let rec make subst = function | LocalDef _ :: sign, exp, args -> make subst (sign, exp, args) | d::sign, None::exp, args -> let args = match args with _::args -> args | [] -> [] in make subst (sign, exp, args) | d::sign, Some u::exp, a::args -> (* We recover the level of the argument, but we don't change the *) (* level in the corresponding type in the arity; this level in the *) (* arity is a global level which, at typing time, will be enforce *) (* to be greater than the level of the argument; this is probably *) (* a useless extra constraint *) let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in make (cons_subst u s subst) (sign, exp, args) | LocalAssum (na,t) :: sign, Some u::exp, [] -> (* No more argument here: we add the remaining universes to the *) (* substitution (when [u] is distinct from all other universes in the *) (* template, it is identity substitution otherwise (ie. when u is *) (* already in the domain of the substitution) [remember_subst] will *) (* update its image [x] by [sup x u] in order not to forget the *) (* dependency in [u] that remains to be fullfilled. *) make (remember_subst u subst) (sign, exp, []) | sign, [], _ -> (* Uniform parameters are exhausted *) subst | [], _, _ -> assert false in make Univ.LMap.empty exception SingletonInductiveBecomesProp of Id.t let instantiate_universes env ctx ar argsorts = let args = Array.to_list argsorts in let subst = make_subst env (ctx,ar.template_param_levels,args) in let level = Univ.subst_univs_universe (Univ.make_subst subst) ar.template_level in let ty = (* Singleton type not containing types are interpretable in Prop *) if is_type0m_univ level then prop_sort (* Non singleton type not containing types are interpretable in Set *) else if is_type0_univ level then set_sort (* This is a Type with constraints *) else Type level in (ctx, ty) (* Type of an inductive type *) let type_of_inductive_gen ?(polyprop=true) env ((mib,mip),u) paramtyps = match mip.mind_arity with | RegularArity a -> subst_instance_constr u a.mind_user_arity | TemplateArity ar -> let ctx = List.rev mip.mind_arity_ctxt in let ctx,s = instantiate_universes env ctx ar paramtyps in (* The Ocaml extraction cannot handle (yet?) "Prop-polymorphism", i.e. the situation where a non-Prop singleton inductive becomes Prop when applied to Prop params *) if not polyprop && not (is_type0m_univ ar.template_level) && is_prop_sort s then raise (SingletonInductiveBecomesProp mip.mind_typename); mkArity (List.rev ctx,s) let type_of_inductive env pind = type_of_inductive_gen env pind [||] let constrained_type_of_inductive env ((mib,mip),u as pind) = let ty = type_of_inductive env pind in let cst = instantiate_inductive_constraints mib u in (ty, cst) let constrained_type_of_inductive_knowing_parameters env ((mib,mip),u as pind) args = let ty = type_of_inductive_gen env pind args in let cst = instantiate_inductive_constraints mib u in (ty, cst) let type_of_inductive_knowing_parameters env ?(polyprop=true) mip args = type_of_inductive_gen ~polyprop env mip args (* The max of an array of universes *) let cumulate_constructor_univ u = function | Prop Null -> u | Prop Pos -> Universe.sup Universe.type0 u | Type u' -> Universe.sup u u' let max_inductive_sort = Array.fold_left cumulate_constructor_univ Universe.type0m (************************************************************************) (* Type of a constructor *) let type_of_constructor (cstr, u) (mib,mip) = let ind = inductive_of_constructor cstr in let specif = mip.mind_user_lc in let i = index_of_constructor cstr in let nconstr = Array.length mip.mind_consnames in if i > nconstr then error "Not enough constructors in the type."; constructor_instantiate (fst ind) u mib specif.(i-1) let constrained_type_of_constructor (cstr,u as cstru) (mib,mip as ind) = let ty = type_of_constructor cstru ind in let cst = instantiate_inductive_constraints mib u in (ty, cst) let arities_of_specif (kn,u) (mib,mip) = let specif = mip.mind_nf_lc in Array.map (constructor_instantiate kn u mib) specif let arities_of_constructors ind specif = arities_of_specif (fst (fst ind), snd ind) specif let type_of_constructors (ind,u) (mib,mip) = let specif = mip.mind_user_lc in Array.map (constructor_instantiate (fst ind) u mib) specif (************************************************************************) (* Type of case predicates *) (* Get type of inductive, with parameters instantiated *) let inductive_sort_family mip = match mip.mind_arity with | RegularArity s -> family_of_sort s.mind_sort | TemplateArity _ -> InType let mind_arity mip = mip.mind_arity_ctxt, inductive_sort_family mip let get_instantiated_arity (ind,u) (mib,mip) params = let sign, s = mind_arity mip in full_inductive_instantiate mib u params sign, s let elim_sorts (_,mip) = mip.mind_kelim let is_private (mib,_) = mib.mind_private = Some true let is_primitive_record (mib,_) = match mib.mind_record with | Some (Some _) -> true | _ -> false let build_dependent_inductive ind (_,mip) params = let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in applist (mkIndU ind, List.map (lift mip.mind_nrealdecls) params @ Context.Rel.to_extended_list 0 realargs) (* This exception is local *) exception LocalArity of (sorts_family * sorts_family * arity_error) option let check_allowed_sort ksort specif = let eq_ksort s = match ksort, s with | InProp, InProp | InSet, InSet | InType, InType -> true | _ -> false in if not (List.exists eq_ksort (elim_sorts specif)) then let s = inductive_sort_family (snd specif) in raise (LocalArity (Some(ksort,s,error_elim_explain ksort s))) let is_correct_arity env c pj ind specif params = let arsign,_ = get_instantiated_arity ind specif params in let rec srec env pt ar = let pt' = whd_all env pt in match kind_of_term pt', ar with | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> let () = try conv env a1 a1' with NotConvertible -> raise (LocalArity None) in srec (push_rel (LocalAssum (na1,a1)) env) t ar' (* The last Prod domain is the type of the scrutinee *) | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) let env' = push_rel (LocalAssum (na1,a1)) env in let ksort = match kind_of_term (whd_all env' a2) with | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in let dep_ind = build_dependent_inductive ind specif params in let _ = try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None) in check_allowed_sort ksort specif | _, (LocalDef _ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' | _ -> raise (LocalArity None) in try srec env pj.uj_type (List.rev arsign) with LocalArity kinds -> error_elim_arity env ind (elim_sorts specif) c pj kinds (************************************************************************) (* Type of case branches *) (* [p] is the predicate, [i] is the constructor number (starting from 0), and [cty] is the type of the constructor (params not instantiated) *) let build_branches_type (ind,u) (_,mip as specif) params p = let build_one_branch i cty = let typi = full_constructor_instantiate (ind,u,specif,params) cty in let (cstrsign,ccl) = decompose_prod_assum typi in let nargs = Context.Rel.length cstrsign in let (_,allargs) = decompose_app ccl in let (lparams,vargs) = List.chop (inductive_params specif) allargs in let cargs = let cstr = ith_constructor_of_inductive ind (i+1) in let dep_cstr = applist (mkConstructU (cstr,u),lparams@(Context.Rel.to_extended_list 0 cstrsign)) in vargs @ [dep_cstr] in let base = lambda_appvect_assum (mip.mind_nrealdecls+1) (lift nargs p) (Array.of_list cargs) in it_mkProd_or_LetIn base cstrsign in Array.mapi build_one_branch mip.mind_nf_lc (* [p] is the predicate, [c] is the match object, [realargs] is the list of real args of the inductive type *) let build_case_type env n p c realargs = whd_betaiota env (lambda_appvect_assum (n+1) p (Array.of_list (realargs@[c]))) let type_case_branches env (pind,largs) pj c = let specif = lookup_mind_specif env (fst pind) in let nparams = inductive_params specif in let (params,realargs) = List.chop nparams largs in let p = pj.uj_val in let () = is_correct_arity env c pj pind specif params in let lc = build_branches_type pind specif params p in let ty = build_case_type env (snd specif).mind_nrealdecls p c realargs in (lc, ty) (************************************************************************) (* Checking the case annotation is relevant *) let check_case_info env (indsp,u) ci = let (mib,mip as spec) = lookup_mind_specif env indsp in if not (eq_ind 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) || is_primitive_record spec then raise (TypeError(env,WrongCaseInfo((indsp,u),ci))) (************************************************************************) (************************************************************************) (* Guard conditions for fix and cofix-points *) (* Check if t is a subterm of Rel n, and gives its specification, assuming lst already gives index of subterms with corresponding specifications of recursive arguments *) (* A powerful notion of subterm *) (* To each inductive definition corresponds an array describing the structure of recursive arguments for each constructor, we call it the recursive spec of the type (it has type recargs vect). For checking the guard, we start from the decreasing argument (Rel n) with its recursive spec. During checking the guardness condition, we collect patterns variables corresponding to subterms of n, each of them with its recursive spec. They are organised in a list lst of type (int * recargs) list which is sorted with respect to the first argument. *) (*************************************************************) (* Environment annotated with marks on recursive arguments *) (* tells whether it is a strict or loose subterm *) type size = Large | Strict (* merging information *) let size_glb s1 s2 = match s1,s2 with Strict, Strict -> Strict | _ -> Large (* possible specifications for a term: - Not_subterm: when the size of a term is not related to the recursive argument of the fixpoint - Subterm: when the term is a subterm of the recursive argument the wf_paths argument specifies which subterms are recursive - Dead_code: when the term has been built by elimination over an empty type *) type subterm_spec = Subterm of (size * wf_paths) | Dead_code | Not_subterm let eq_wf_paths = Rtree.equal Declareops.eq_recarg let inter_recarg r1 r2 = match r1, r2 with | Norec, Norec -> Some r1 | Mrec i1, Mrec i2 | Imbr i1, Imbr i2 | Mrec i1, Imbr i2 -> if Names.eq_ind i1 i2 then Some r1 else None | Imbr i1, Mrec i2 -> if Names.eq_ind i1 i2 then Some r2 else None | _ -> None let inter_wf_paths = Rtree.inter Declareops.eq_recarg inter_recarg Norec let incl_wf_paths = Rtree.incl Declareops.eq_recarg inter_recarg Norec let spec_of_tree t = if eq_wf_paths t mk_norec then Not_subterm else Subterm (Strict, t) let inter_spec s1 s2 = match s1, s2 with | _, Dead_code -> s1 | Dead_code, _ -> s2 | Not_subterm, _ -> s1 | _, Not_subterm -> s2 | Subterm (a1,t1), Subterm (a2,t2) -> Subterm (size_glb a1 a2, inter_wf_paths t1 t2) let subterm_spec_glb = Array.fold_left inter_spec Dead_code type guard_env = { env : env; (* dB of last fixpoint *) rel_min : int; (* dB of variables denoting subterms *) genv : subterm_spec Lazy.t list; } let make_renv env recarg tree = { env = env; rel_min = recarg+2; (* recarg = 0 ==> Rel 1 -> recarg; Rel 2 -> fix *) genv = [Lazy.from_val(Subterm(Large,tree))] } let push_var renv (x,ty,spec) = { env = push_rel (LocalAssum (x,ty)) renv.env; rel_min = renv.rel_min+1; genv = spec:: renv.genv } let assign_var_spec renv (i,spec) = { renv with genv = List.assign renv.genv (i-1) spec } let push_var_renv renv (x,ty) = push_var renv (x,ty,lazy Not_subterm) (* Fetch recursive information about a variable p *) let subterm_var p renv = try Lazy.force (List.nth renv.genv (p-1)) with Failure _ | Invalid_argument _ -> Not_subterm let push_ctxt_renv renv ctxt = let n = Context.Rel.length ctxt in { env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv } let push_fix_renv renv (_,v,_ as recdef) = let n = Array.length v in { env = push_rec_types recdef renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv } (* Definition and manipulation of the stack *) type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t let push_stack_closures renv l stack = List.fold_right (fun h b -> (SClosure (renv,h))::b) l stack let push_stack_args l stack = List.fold_right (fun h b -> (SArg h)::b) l stack (******************************) (* {6 Computing the recursive subterms of a term (propagation of size information through Cases).} *) let lookup_subterms env ind = let (_,mip) = lookup_mind_specif env ind in mip.mind_recargs let match_inductive ind ra = match ra with | (Mrec i | Imbr i) -> eq_ind ind i | Norec -> false (* In {match c as z in ci y_s return P with |C_i x_s => t end} [branches_specif renv c_spec ci] returns an array of x_s specs knowing c_spec. *) let branches_specif renv c_spec ci = let car = (* We fetch the regular tree associated to the inductive of the match. This is just to get the number of constructors (and constructor arities) that fit the match branches without forcing c_spec. Note that c_spec might be more precise than [v] below, because of nested inductive types. *) let (_,mip) = lookup_mind_specif renv.env ci.ci_ind in let v = dest_subterms mip.mind_recargs in Array.map List.length v in Array.mapi (fun i nca -> (* i+1-th cstructor has arity nca *) let lvra = lazy (match Lazy.force c_spec with Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) -> let vra = Array.of_list (dest_subterms t).(i) in assert (Int.equal nca (Array.length vra)); Array.map spec_of_tree vra | Dead_code -> Array.make nca Dead_code | _ -> Array.make nca Not_subterm) in List.init nca (fun j -> lazy (Lazy.force lvra).(j))) car let check_inductive_codomain env p = let absctx, ar = dest_lam_assum env p in let env = push_rel_context absctx env in let arctx, s = dest_prod_assum env ar in let env = push_rel_context arctx env in let i,l' = decompose_app (whd_all env s) in isInd i (* The following functions are almost duplicated from indtypes.ml, except that they carry here a poorer environment (containing less information). *) let ienv_push_var (env, lra) (x,a,ra) = (push_rel (LocalAssum (x,a)) env, (Norec,ra)::lra) let ienv_push_inductive (env, ra_env) ((mind,u),lpar) = let mib = Environ.lookup_mind mind env in let ntypes = mib.mind_ntypes in let push_ind specif env = let decl = LocalAssum (Anonymous, hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in push_rel decl env in let env = Array.fold_right push_ind mib.mind_packets env in let rc = Array.mapi (fun j t -> (Imbr (mind,j),t)) (Rtree.mk_rec_calls ntypes) in let lra_ind = Array.rev_to_list rc in let ra_env = List.map (fun (r,t) -> (r,Rtree.lift ntypes t)) ra_env in (env, lra_ind @ ra_env) let rec ienv_decompose_prod (env,_ as ienv) n c = if Int.equal n 0 then (ienv,c) else let c' = whd_all env c in match kind_of_term c' with Prod(na,a,b) -> let ienv' = ienv_push_var ienv (na,a,mk_norec) in ienv_decompose_prod ienv' (n-1) b | _ -> assert false let lambda_implicit_lift n a = let level = Level.make (DirPath.make [Id.of_string "implicit"]) 0 in let implicit_sort = mkType (Universe.make level) in let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in iterate lambda_implicit n (lift n a) (* This removes global parameters of the inductive types in lc (for nested inductive types only ) *) let abstract_mind_lc ntyps npars lc = if Int.equal npars 0 then lc else let make_abs = List.init ntyps (function i -> lambda_implicit_lift npars (mkRel (i+1))) in Array.map (substl make_abs) lc (* [get_recargs_approx env tree ind args] builds an approximation of the recargs tree for ind, knowing args. The argument tree is used to know when candidate nested types should be traversed, pruning the tree otherwise. This code is very close to check_positive in indtypes.ml, but does no positivity check and does not compute the number of recursive arguments. *) let get_recargs_approx env tree ind args = let rec build_recargs (env, ra_env as ienv) tree c = let x,largs = decompose_app (whd_all env c) in match kind_of_term x with | Prod (na,b,d) -> assert (List.is_empty largs); build_recargs (ienv_push_var ienv (na, b, mk_norec)) tree d | Rel k -> (* Free variables are allowed and assigned Norec *) (try snd (List.nth ra_env (k-1)) with Failure _ | Invalid_argument _ -> mk_norec) | Ind ind_kn -> (* When the inferred tree allows it, we consider that we have a potential nested inductive type *) begin match dest_recarg tree with | Imbr kn' | Mrec kn' when eq_ind (fst ind_kn) kn' -> build_recargs_nested ienv tree (ind_kn, largs) | _ -> mk_norec end | err -> mk_norec and build_recargs_nested (env,ra_env as ienv) tree (((mind,i),u), largs) = (* If the inferred tree already disallows recursion, no need to go further *) if eq_wf_paths tree mk_norec then tree else let mib = Environ.lookup_mind mind env in let auxnpar = mib.mind_nparams_rec in let nonrecpar = mib.mind_nparams - auxnpar in let (lpar,_) = List.chop auxnpar largs in let auxntyp = mib.mind_ntypes in (* Extends the environment with a variable corresponding to the inductive def *) let (env',_ as ienv') = ienv_push_inductive ienv ((mind,u),lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in (* In case of mutual inductive types, we use the recargs tree which was computed statically. This is fine because nested inductive types with mutually recursive containers are not supported. *) let trees = if Int.equal auxntyp 1 then [|dest_subterms tree|] else Array.map (fun mip -> dest_subterms mip.mind_recargs) mib.mind_packets in let mk_irecargs j specif = (* The nested inductive type with parameters removed *) let auxlcvect = abstract_mind_lc auxntyp auxnpar specif.mind_nf_lc in let paths = Array.mapi (fun k c -> let c' = hnf_prod_applist env' c lpar' in (* skip non-recursive parameters *) let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in build_recargs_constructors ienv' trees.(j).(k) c') auxlcvect in mk_paths (Imbr (mind,j)) paths in let irecargs = Array.mapi mk_irecargs mib.mind_packets in (Rtree.mk_rec irecargs).(i) and build_recargs_constructors ienv trees c = let rec recargs_constr_rec (env,ra_env as ienv) trees lrec c = let x,largs = decompose_app (whd_all env c) in match kind_of_term x with | Prod (na,b,d) -> let () = assert (List.is_empty largs) in let recarg = build_recargs ienv (List.hd trees) b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in recargs_constr_rec ienv' (List.tl trees) (recarg::lrec) d | hd -> List.rev lrec in recargs_constr_rec ienv trees [] c in (* starting with ra_env = [] seems safe because any unbounded Rel will be assigned Norec *) build_recargs_nested (env,[]) tree (ind, args) (* [restrict_spec env spec p] restricts the size information in spec to what is allowed to flow through a match with predicate p in environment env. *) let restrict_spec env spec p = if spec = Not_subterm then spec else let absctx, ar = dest_lam_assum env p in (* Optimization: if the predicate is not dependent, no restriction is needed and we avoid building the recargs tree. *) if noccur_with_meta 1 (Context.Rel.length absctx) ar then spec else let env = push_rel_context absctx env in let arctx, s = dest_prod_assum env ar in let env = push_rel_context arctx env in let i,args = decompose_app (whd_all env s) in match kind_of_term i with | Ind i -> begin match spec with | Dead_code -> spec | Subterm(st,tree) -> let recargs = get_recargs_approx env tree i args in let recargs = inter_wf_paths tree recargs in Subterm(st,recargs) | _ -> assert false end | _ -> Not_subterm (* [subterm_specif renv t] computes the recursive structure of [t] and compare its size with the size of the initial recursive argument of the fixpoint we are checking. [renv] collects such information about variables. *) let rec subterm_specif renv stack t = (* maybe reduction is not always necessary! *) let f,l = decompose_app (whd_all renv.env t) in match kind_of_term f with | Rel k -> subterm_var k renv | Case (ci,p,c,lbr) -> let stack' = push_stack_closures renv l stack in let cases_spec = branches_specif renv (lazy_subterm_specif renv [] c) ci in let stl = Array.mapi (fun i br' -> let stack_br = push_stack_args (cases_spec.(i)) stack' in subterm_specif renv stack_br br') lbr in let spec = subterm_spec_glb stl in restrict_spec renv.env spec p | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> (* when proving that the fixpoint f(x)=e is less than n, it is enough to prove that e is less than n assuming f is less than n furthermore when f is applied to a term which is strictly less than n, one may assume that x itself is strictly less than n *) if not (check_inductive_codomain renv.env typarray.(i)) then Not_subterm else let (ctxt,clfix) = dest_prod renv.env typarray.(i) in let oind = let env' = push_rel_context ctxt renv.env in try Some(fst(find_inductive env' clfix)) with Not_found -> None in (match oind with None -> Not_subterm (* happens if fix is polymorphic *) | Some (ind, _) -> let nbfix = Array.length typarray in let recargs = lookup_subterms renv.env ind in (* pushing the fixpoints *) let renv' = push_fix_renv renv recdef in let renv' = (* Why Strict here ? To be general, it could also be Large... *) assign_var_spec renv' (nbfix-i, lazy (Subterm(Strict,recargs))) in let decrArg = recindxs.(i) in let theBody = bodies.(i) in let nbOfAbst = decrArg+1 in let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in (* pushing the fix parameters *) let stack' = push_stack_closures renv l stack in let renv'' = push_ctxt_renv renv' sign in let renv'' = if List.length stack' < nbOfAbst then renv'' else let decrArg = List.nth stack' decrArg in let arg_spec = stack_element_specif decrArg in assign_var_spec renv'' (1, arg_spec) in subterm_specif renv'' [] strippedBody) | Lambda (x,a,b) -> let () = assert (List.is_empty l) in let spec,stack' = extract_stack renv a stack in subterm_specif (push_var renv (x,a,spec)) stack' b (* Metas and evars are considered OK *) | (Meta _|Evar _) -> Dead_code | Proj (p, c) -> let subt = subterm_specif renv stack c in (match subt with | Subterm (s, wf) -> (* We take the subterm specs of the constructor of the record *) let wf_args = (dest_subterms wf).(0) in (* We extract the tree of the projected argument *) let kn = Projection.constant p in let cb = lookup_constant kn renv.env in let pb = Option.get cb.const_proj in let n = pb.proj_arg in Subterm (Strict, List.nth wf_args n) | Dead_code -> Dead_code | Not_subterm -> Not_subterm) (* Other terms are not subterms *) | _ -> Not_subterm and lazy_subterm_specif renv stack t = lazy (subterm_specif renv stack t) and stack_element_specif = function |SClosure (h_renv,h) -> lazy_subterm_specif h_renv [] h |SArg x -> x and extract_stack renv a = function | [] -> Lazy.from_val Not_subterm , [] | h::t -> stack_element_specif h, t (* Check term c can be applied to one of the mutual fixpoints. *) let check_is_subterm x tree = match Lazy.force x with | Subterm (Strict,tree') -> incl_wf_paths tree tree' | Dead_code -> true | _ -> false (************************************************************************) exception FixGuardError of env * guard_error let error_illegal_rec_call renv fx (arg_renv,arg) = let (_,le_vars,lt_vars) = List.fold_left (fun (i,le,lt) sbt -> match Lazy.force sbt with (Subterm(Strict,_) | Dead_code) -> (i+1, le, i::lt) | (Subterm(Large,_)) -> (i+1, i::le, lt) | _ -> (i+1, le ,lt)) (1,[],[]) renv.genv in raise (FixGuardError (renv.env, RecursionOnIllegalTerm(fx,(arg_renv.env, arg), le_vars,lt_vars))) let error_partial_apply renv fx = raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx)) let filter_stack_domain env ci p stack = let absctx, ar = dest_lam_assum env p in (* Optimization: if the predicate is not dependent, no restriction is needed and we avoid building the recargs tree. *) if noccur_with_meta 1 (Context.Rel.length absctx) ar then stack else let env = push_rel_context absctx env in let rec filter_stack env ar stack = let t = whd_all env ar in match stack, kind_of_term t with | elt :: stack', Prod (n,a,c0) -> let d = LocalAssum (n,a) in let ty, args = decompose_app (whd_all env a) in let elt = match kind_of_term ty with | Ind ind -> let spec' = stack_element_specif elt in (match (Lazy.force spec') with | Not_subterm | Dead_code -> elt | Subterm(s,path) -> let recargs = get_recargs_approx env path ind args in let path = inter_wf_paths path recargs in SArg (lazy (Subterm(s,path)))) | _ -> (SArg (lazy Not_subterm)) in elt :: filter_stack (push_rel d env) c0 stack' | _,_ -> List.fold_right (fun _ l -> SArg (lazy Not_subterm) :: l) stack [] in filter_stack env ar stack (* Check if [def] is a guarded fixpoint body with decreasing arg. given [recpos], the decreasing arguments of each mutually defined fixpoint. *) let check_one_fix renv recpos trees def = let nfi = Array.length recpos in (* Checks if [t] only make valid recursive calls [stack] is the list of constructor's argument specification and arguments that will be applied after reduction. example u in t where we have (match .. with |.. => t end) u *) let rec check_rec_call renv stack t = (* if [t] does not make recursive calls, it is guarded: *) if noccur_with_meta renv.rel_min nfi t then () else let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in match kind_of_term f with | Rel p -> (* Test if [p] is a fixpoint (recursive call) *) if renv.rel_min <= p && p < renv.rel_min+nfi then begin List.iter (check_rec_call renv []) l; (* the position of the invoked fixpoint: *) let glob = renv.rel_min+nfi-1-p in (* the decreasing arg of the rec call: *) let np = recpos.(glob) in let stack' = push_stack_closures renv l stack in if List.length stack' <= np then error_partial_apply renv glob else (* Retrieve the expected tree for the argument *) (* Check the decreasing arg is smaller *) let z = List.nth stack' np in if not (check_is_subterm (stack_element_specif z) trees.(glob)) then begin match z with |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z') |SArg _ -> error_partial_apply renv glob end end else begin match lookup_rel p renv.env with | LocalAssum _ -> List.iter (check_rec_call renv []) l | LocalDef (_,c,_) -> try List.iter (check_rec_call renv []) l with FixGuardError _ -> check_rec_call renv stack (applist(lift p c,l)) end | Case (ci,p,c_0,lrest) -> List.iter (check_rec_call renv []) (c_0::p::l); (* compute the recarg information for the arguments of each branch *) let case_spec = branches_specif renv (lazy_subterm_specif renv [] c_0) ci in let stack' = push_stack_closures renv l stack in let stack' = filter_stack_domain renv.env ci p stack' in Array.iteri (fun k br' -> let stack_br = push_stack_args case_spec.(k) stack' in check_rec_call renv stack_br br') lrest (* Enables to traverse Fixpoint definitions in a more intelligent way, ie, the rule : if - g = fix g (y1:T1)...(yp:Tp) {struct yp} := e & - f is guarded with respect to the set of pattern variables S in a1 ... am & - f is guarded with respect to the set of pattern variables S in T1 ... Tp & - ap is a sub-term of the formal argument of f & - f is guarded with respect to the set of pattern variables S+{yp} in e then f is guarded with respect to S in (g a1 ... am). Eduardo 7/9/98 *) | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> List.iter (check_rec_call renv []) l; Array.iter (check_rec_call renv []) typarray; let decrArg = recindxs.(i) in let renv' = push_fix_renv renv recdef in let stack' = push_stack_closures renv l stack in Array.iteri (fun j body -> if Int.equal i j && (List.length stack' > decrArg) then let recArg = List.nth stack' decrArg in let arg_sp = stack_element_specif recArg in check_nested_fix_body renv' (decrArg+1) arg_sp body else check_rec_call renv' [] body) bodies | Const (kn,u as cu) -> if evaluable_constant kn renv.env then try List.iter (check_rec_call renv []) l with (FixGuardError _ ) -> let value = (applist(constant_value_in renv.env cu, l)) in check_rec_call renv stack value else List.iter (check_rec_call renv []) l | Lambda (x,a,b) -> let () = assert (List.is_empty l) in check_rec_call renv [] a ; let spec, stack' = extract_stack renv a stack in check_rec_call (push_var renv (x,a,spec)) stack' b | Prod (x,a,b) -> let () = assert (List.is_empty l && List.is_empty stack) in check_rec_call renv [] a; check_rec_call (push_var_renv renv (x,a)) [] b | CoFix (i,(_,typarray,bodies as recdef)) -> List.iter (check_rec_call renv []) l; Array.iter (check_rec_call renv []) typarray; let renv' = push_fix_renv renv recdef in Array.iter (check_rec_call renv' []) bodies | (Ind _ | Construct _) -> List.iter (check_rec_call renv []) l | Proj (p, c) -> List.iter (check_rec_call renv []) l; check_rec_call renv [] c | Var id -> begin let open Context.Named.Declaration in match lookup_named id renv.env with | LocalAssum _ -> List.iter (check_rec_call renv []) l | LocalDef (_,c,_) -> try List.iter (check_rec_call renv []) l with (FixGuardError _) -> check_rec_call renv stack (applist(c,l)) end | Sort _ -> assert (List.is_empty l) (* l is not checked because it is considered as the meta's context *) | (Evar _ | Meta _) -> () | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *) and check_nested_fix_body renv decr recArgsDecrArg body = if Int.equal decr 0 then check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body else match kind_of_term body with | Lambda (x,a,b) -> check_rec_call renv [] a; let renv' = push_var_renv renv (x,a) in check_nested_fix_body renv' (decr-1) recArgsDecrArg b | _ -> anomaly (Pp.str "Not enough abstractions in fix body") in check_rec_call renv [] def let judgment_of_fixpoint (_, types, bodies) = Array.map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = let nbfix = Array.length bodies in if Int.equal nbfix 0 || not (Int.equal (Array.length nvect) nbfix) || not (Int.equal (Array.length types) nbfix) || not (Int.equal (Array.length names) nbfix) || bodynum < 0 || bodynum >= nbfix then anomaly (Pp.str "Ill-formed fix term"); let fixenv = push_rec_types recdef env in let vdefj = judgment_of_fixpoint recdef in let raise_err env i err = error_ill_formed_rec_body env err names i fixenv vdefj in (* Check the i-th definition with recarg k *) let find_ind i k def = (* check fi does not appear in the k+1 first abstractions, gives the type of the k+1-eme abstraction (must be an inductive) *) let rec check_occur env n def = match kind_of_term (whd_all env def) with | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then let env' = push_rel (LocalAssum (x,a)) env in if Int.equal n (k + 1) then (* get the inductive type of the fixpoint *) let (mind, _) = try find_inductive env a with Not_found -> raise_err env i (RecursionNotOnInductiveType a) in (mind, (env', b)) else check_occur env' (n+1) b else anomaly ~label:"check_one_fix" (Pp.str "Bad occurrence of recursive call") | _ -> raise_err env i NotEnoughAbstractionInFixBody in check_occur fixenv 1 def in (* Do it on every fixpoint *) let rv = Array.map2_i find_ind nvect bodies in (Array.map fst rv, Array.map snd rv) let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) = let flags = Environ.typing_flags env in if flags.check_guarded then let (minds, rdef) = inductive_of_mutfix env fix in let get_tree (kn,i) = let mib = Environ.lookup_mind kn env in mib.mind_packets.(i).mind_recargs in let trees = Array.map (fun (mind,_) -> get_tree mind) minds in for i = 0 to Array.length bodies - 1 do let (fenv,body) = rdef.(i) in let renv = make_renv fenv nvect.(i) trees.(i) in try check_one_fix renv nvect trees body with FixGuardError (fixenv,err) -> error_ill_formed_rec_body fixenv err names i (push_rec_types recdef env) (judgment_of_fixpoint recdef) done else () (* let cfkey = Profile.declare_profile "check_fix";; let check_fix env fix = Profile.profile3 cfkey check_fix env fix;; *) (************************************************************************) (* Co-fixpoints. *) exception CoFixGuardError of env * guard_error let anomaly_ill_typed () = anomaly ~label:"check_one_cofix" (Pp.str "too many arguments applied to constructor") let rec codomain_is_coind env c = let b = whd_all env c in match kind_of_term b with | Prod (x,a,b) -> codomain_is_coind (push_rel (LocalAssum (x,a)) env) b | _ -> (try find_coinductive env b with Not_found -> raise (CoFixGuardError (env, CodomainNotInductiveType b))) let check_one_cofix env nbfix def deftype = let rec check_rec_call env alreadygrd n tree vlra t = if not (noccur_with_meta n nbfix t) then let c,args = decompose_app (whd_all env t) in match kind_of_term c with | Rel p when n <= p && p < n+nbfix -> (* recursive call: must be guarded and no nested recursive call allowed *) if not alreadygrd then raise (CoFixGuardError (env,UnguardedRecursiveCall t)) else if not(List.for_all (noccur_with_meta n nbfix) args) then raise (CoFixGuardError (env,NestedRecursiveOccurrences)) | Construct ((_,i as cstr_kn),u) -> let lra = vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in let (mib,mip) = lookup_mind_specif env mI in let realargs = List.skipn mib.mind_nparams args in let rec process_args_of_constr = function | (t::lr), (rar::lrar) -> if eq_wf_paths rar mk_norec then if noccur_with_meta n nbfix t then process_args_of_constr (lr, lrar) else raise (CoFixGuardError (env,RecCallInNonRecArgOfConstructor t)) else begin check_rec_call env true n rar (dest_subterms rar) t; process_args_of_constr (lr, lrar) end | [],_ -> () | _ -> anomaly_ill_typed () in process_args_of_constr (realargs, lra) | Lambda (x,a,b) -> let () = assert (List.is_empty args) in if noccur_with_meta n nbfix a then let env' = push_rel (LocalAssum (x,a)) env in check_rec_call env' alreadygrd (n+1) tree vlra b else raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) | CoFix (j,(_,varit,vdefs as recdef)) -> if List.for_all (noccur_with_meta n nbfix) args then if Array.for_all (noccur_with_meta n nbfix) varit then let nbfix = Array.length vdefs in let env' = push_rec_types recdef env in (Array.iter (check_rec_call env' alreadygrd (n+nbfix) tree vlra) vdefs; List.iter (check_rec_call env alreadygrd n tree vlra) args) else raise (CoFixGuardError (env,RecCallInTypeOfDef c)) else raise (CoFixGuardError (env,UnguardedRecursiveCall c)) | Case (_,p,tm,vrest) -> begin let tree = match restrict_spec env (Subterm (Strict, tree)) p with | Dead_code -> assert false | Subterm (_, tree') -> tree' | _ -> raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c)) in if (noccur_with_meta n nbfix p) then if (noccur_with_meta n nbfix tm) then if (List.for_all (noccur_with_meta n nbfix) args) then let vlra = dest_subterms tree in Array.iter (check_rec_call env alreadygrd n tree vlra) vrest else raise (CoFixGuardError (env,RecCallInCaseFun c)) else raise (CoFixGuardError (env,RecCallInCaseArg c)) else raise (CoFixGuardError (env,RecCallInCasePred c)) end | Meta _ -> () | Evar _ -> List.iter (check_rec_call env alreadygrd n tree vlra) args | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in let ((mind, _),_) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in check_rec_call env false 1 vlra (dest_subterms vlra) def (* The function which checks that the whole block of definitions satisfies the guarded condition *) let check_cofix env (bodynum,(names,types,bodies as recdef)) = let flags = Environ.typing_flags env in if flags.check_guarded then let nbfix = Array.length bodies in for i = 0 to nbfix-1 do let fixenv = push_rec_types recdef env in try check_one_cofix fixenv nbfix bodies.(i) types.(i) with CoFixGuardError (errenv,err) -> error_ill_formed_rec_body errenv err names i fixenv (judgment_of_fixpoint recdef) done else () coq-8.6/kernel/nativeinstr.mli0000644000175000017500000000424313022274260016013 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'b) -> 'a puniverses -> 'b puniverses (** Constructs a constant *) val mkConst : constant -> constr val mkConstU : pconstant -> constr (** Constructs a projection application *) val mkProj : (projection * constr) -> constr (** Inductive types *) (** Constructs the ith (co)inductive type of the block named kn *) val mkInd : inductive -> constr val mkIndU : pinductive -> constr (** Constructs the jth constructor of the ith (co)inductive type of the block named kn. *) val mkConstruct : constructor -> constr val mkConstructU : pconstructor -> constr val mkConstructUi : pinductive * int -> constr (** Constructs a destructor of inductive type. [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] presented as describe in [ci]. [p] stucture is [fun args x -> "return clause"] [ac]{^ ith} element is ith constructor case presented as {e lambda construct_args (without params). case_term } *) val mkCase : case_info * constr * constr * constr array -> constr (** If [recindxs = [|i1,...in|]] [funnames = [|f1,.....fn|]] [typarray = [|t1,...tn|]] [bodies = [|b1,.....bn|]] then [mkFix ((recindxs,i), funnames, typarray, bodies) ] constructs the {% $ %}i{% $ %}th function of the block (counting from 0) [Fixpoint f1 [ctx1] = b1 with f2 [ctx2] = b2 ... with fn [ctxn] = bn.] where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. *) type rec_declaration = Name.t array * types array * constr array type fixpoint = (int array * int) * rec_declaration val mkFix : fixpoint -> constr (** If [funnames = [|f1,.....fn|]] [typarray = [|t1,...tn|]] [bodies = [b1,.....bn]] then [mkCoFix (i, (funnames, typarray, bodies))] constructs the ith function of the block [CoFixpoint f1 = b1 with f2 = b2 ... with fn = bn.] *) type cofixpoint = int * rec_declaration val mkCoFix : cofixpoint -> constr (** {6 Concrete type for making pattern-matching. } *) (** [constr array] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) type 'constr pexistential = existential_key * 'constr array type ('constr, 'types) prec_declaration = Name.t array * 'types array * 'constr array type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration type ('constr, 'types) pcofixpoint = int * ('constr, 'types) prec_declaration type ('constr, 'types) kind_of_term = | Rel of int | Var of Id.t | Meta of metavariable | Evar of 'constr pexistential | Sort of Sorts.t | Cast of 'constr * cast_kind * 'types | Prod of Name.t * 'types * 'types (** Concrete syntax ["forall A:B,C"] is represented as [Prod (A,B,C)]. *) | Lambda of Name.t * 'types * 'constr (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)]. *) | LetIn of Name.t * 'constr * 'types * 'constr (** Concrete syntax ["let A:B := C in D"] is represented as [LetIn (A,B,C,D)]. *) | App of 'constr * 'constr array (** Concrete syntax ["(F P1 P2 ... Pn)"] is represented as [App (F, [|P1; P2; ...; Pn|])]. The {!mkApp} constructor also enforces the following invariant: - [F] itself is not {!App} - and [[|P1;..;Pn|]] is not empty. *) | Const of constant puniverses | Ind of inductive puniverses | Construct of constructor puniverses | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of projection * 'constr (** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative term *) val kind : constr -> (constr, types) kind_of_term (** [equal a b] is true if [a] equals [b] modulo alpha, casts, and application grouping *) val equal : constr -> constr -> bool (** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts, application grouping and the universe equalities in [u]. *) val eq_constr_univs : constr UGraph.check_function (** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo alpha, casts, application grouping and the universe inequalities in [u]. *) val leq_constr_univs : constr UGraph.check_function (** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts, application grouping and the universe equalities in [u]. *) val eq_constr_univs_infer : UGraph.t -> constr -> constr -> bool Univ.constrained (** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo alpha, casts, application grouping and the universe inequalities in [u]. *) val leq_constr_univs_infer : UGraph.t -> constr -> constr -> bool Univ.constrained (** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and ignoring universe instances. *) val eq_constr_nounivs : constr -> constr -> bool (** Total ordering compatible with [equal] *) val compare : constr -> constr -> int (** {6 Functionals working on the immediate subterm of a construction } *) (** [fold f acc c] folds [f] on the immediate subterms of [c] starting from [acc] and proceeding from left to right according to the usual representation of the constructions; it is not recursive *) val fold : ('a -> constr -> 'a) -> 'a -> constr -> 'a (** [map f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) val map : (constr -> constr) -> constr -> constr (** Like {!map}, but also has an additional accumulator. *) val fold_map : ('a -> constr -> 'a * constr) -> 'a -> constr -> 'a * constr (** [map_with_binders g f n c] maps [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) val map_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr (** [iter f c] iters [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) val iter : (constr -> unit) -> constr -> unit (** [iter_with_binders g f n c] iters [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) val iter_with_binders : ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit (** [compare_head f c1 c2] compare [c1] and [c2] using [f] to compare the immediate subterms of [c1] of [c2] if needed; Cast's, binders name and Cases annotations are not taken into account *) val compare_head : (constr -> constr -> bool) -> constr -> constr -> bool (** [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare the immediate subterms of [c1] of [c2] if needed, [u] to compare universe instances (the first boolean tells if they belong to a constant), [s] to compare sorts; Cast's, binders name and Cases annotations are not taken into account *) val compare_head_gen : (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) -> (Sorts.t -> Sorts.t -> bool) -> (constr -> constr -> bool) -> constr -> constr -> bool (** [compare_head_gen_with k1 k2 u s f c1 c2] compares [c1] and [c2] like [compare_head_gen u s f c1 c2], except that [k1] (resp. [k2]) is used,rather than {!kind}, to expose the immediate subterms of [c1] (resp. [c2]). *) val compare_head_gen_with : (constr -> (constr,types) kind_of_term) -> (constr -> (constr,types) kind_of_term) -> (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) -> (Sorts.t -> Sorts.t -> bool) -> (constr -> constr -> bool) -> constr -> constr -> bool (** [compare_head_gen_leq u s f fle c1 c2] compare [c1] and [c2] using [f] to compare the immediate subterms of [c1] of [c2] for conversion, [fle] for cumulativity, [u] to compare universe instances (the first boolean tells if they belong to a constant), [s] to compare sorts for for subtyping; Cast's, binders name and Cases annotations are not taken into account *) val compare_head_gen_leq : (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) -> (Sorts.t -> Sorts.t -> bool) -> (constr -> constr -> bool) -> (constr -> constr -> bool) -> constr -> constr -> bool (** {6 Hashconsing} *) val hash : constr -> int val case_info_hash : case_info -> int (*********************************************************************) val hcons : constr -> constr (**************************************) type values coq-8.6/kernel/nativelibrary.mli0000644000175000017500000000140013022274260016310 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* dir_path -> env -> module_signature -> global list * symbols coq-8.6/tactics/0000755000175000017500000000000013022274260013111 5ustar mdenesmdenescoq-8.6/tactics/contradiction.mli0000644000175000017500000000130113022274260016447 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit Proofview.tactic val contradiction : constr with_bindings option -> unit Proofview.tactic coq-8.6/tactics/leminv.mli0000644000175000017500000000143013022274260015104 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> Id.t list -> unit Proofview.tactic val add_inversion_lemma_exn : Id.t -> constr_expr -> glob_sort -> bool -> (Id.t -> unit Proofview.tactic) -> unit coq-8.6/tactics/term_dnet.mli0000644000175000017500000000512013022274260015573 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> int (** how to substitute them for storage *) val subst : substitution -> t -> t (** how to recover the term from the identifier *) val constr_of : t -> constr end (** Options : *) module type OPT = sig (** pre-treatment to terms before adding or searching *) val reduce : constr -> constr (** direction of post-filtering w.r.t sort subtyping : - true means query <= terms in the structure - false means terms <= query *) val direction : bool end module type S = sig type t type ident val empty : t (** [add c i dn] adds the binding [(c,i)] to [dn]. [c] can be a closed term or a pattern (with untyped Evars). No Metas accepted *) val add : constr -> ident -> t -> t (** merge of dnets. Faster than re-adding all terms *) val union : t -> t -> t val subst : substitution -> t -> t (* * High-level primitives describing specific search problems *) (** [search_pattern dn c] returns all terms/patterns in dn matching/matched by c *) val search_pattern : t -> constr -> ident list (** [find_all dn] returns all idents contained in dn *) val find_all : t -> ident list val map : (ident -> ident) -> t -> t val refresh_metas : t -> t end module Make : functor (Ident : IDENT) -> functor (Opt : OPT) -> S with type ident = Ident.t coq-8.6/tactics/elimschemes.ml0000644000175000017500000001422613022274260015746 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) let rect_scheme_kind_from_prop = declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop" (fun _ x -> build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) let rect_dep_scheme_kind_from_type = declare_individual_scheme_object "_rect" ~aux:"_rect_from_type" (fun _ x -> build_induction_scheme_in_type true InType x, Safe_typing.empty_private_constants) let ind_scheme_kind_from_type = declare_individual_scheme_object "_ind_nodep" (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InProp) let ind_scheme_kind_from_prop = declare_individual_scheme_object "_ind" ~aux:"_ind_from_prop" (optimize_non_type_induction_scheme rect_scheme_kind_from_prop false InProp) let ind_dep_scheme_kind_from_type = declare_individual_scheme_object "_ind" ~aux:"_ind_from_type" (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InProp) let rec_scheme_kind_from_prop = declare_individual_scheme_object "_rec" ~aux:"_rec_from_prop" (optimize_non_type_induction_scheme rect_scheme_kind_from_prop false InSet) let rec_scheme_kind_from_type = declare_individual_scheme_object "_rec_nodep" ~aux:"_rec_nodep_from_type" (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InSet) let rec_dep_scheme_kind_from_type = declare_individual_scheme_object "_rec" ~aux:"_rec_from_type" (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InSet) (* Case analysis *) let build_case_analysis_scheme_in_type dep sort ind = let env = Global.env () in let sigma = Sigma.Unsafe.of_evar_map (Evd.from_env env) in let Sigma (indu, sigma, _) = Sigma.fresh_inductive_instance env sigma ind in let Sigma (c, sigma, _) = build_case_analysis_scheme env sigma indu dep sort in c, Evd.evar_universe_context (Sigma.to_evar_map sigma) let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) let case_scheme_kind_from_prop = declare_individual_scheme_object "_case" ~aux:"_case_from_prop" (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_type = declare_individual_scheme_object "_case" ~aux:"_case_from_type" (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_type_in_prop = declare_individual_scheme_object "_casep_dep" (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_prop = declare_individual_scheme_object "_case_dep" (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_prop_in_prop = declare_individual_scheme_object "_casep" (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) coq-8.6/tactics/term_dnet.ml0000644000175000017500000003070613022274260015432 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* std_ppcmds = function | DRel -> str "*" | DSort -> str "Sort" | DRef _ -> str "Ref" | DCtx (ctx,t) -> f ctx ++ spc() ++ str "|-" ++ spc () ++ f t | DLambda (t1,t2) -> str "fun"++ spc() ++ f t1 ++ spc() ++ str"->" ++ spc() ++ f t2 | DApp (t1,t2) -> f t1 ++ spc() ++ f t2 | DCase (_,t1,t2,ta) -> str "case" | DFix _ -> str "fix" | DCoFix _ -> str "cofix" | DCons ((t,dopt),tl) -> f t ++ (match dopt with Some t' -> str ":=" ++ f t' | None -> str "") ++ spc() ++ str "::" ++ spc() ++ f tl | DNil -> str "[]" (* * Functional iterators for the t datatype * a.k.a boring and error-prone boilerplate code *) let map f = function | (DRel | DSort | DNil | DRef _) as c -> c | DCtx (ctx,c) -> DCtx (f ctx, f c) | DLambda (t,c) -> DLambda (f t, f c) | DApp (t,u) -> DApp (f t,f u) | DCase (ci,p,c,bl) -> DCase (ci, f p, f c, Array.map f bl) | DFix (ia,i,ta,ca) -> DFix (ia,i,Array.map f ta,Array.map f ca) | DCoFix(i,ta,ca) -> DCoFix (i,Array.map f ta,Array.map f ca) | DCons ((t,topt),u) -> DCons ((f t,Option.map f topt), f u) let compare_ci ci1 ci2 = let c = ind_ord 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 let c = Array.compare Int.compare ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls in if c = 0 then Array.compare Int.compare ci1.ci_cstr_nargs ci2.ci_cstr_nargs else c else c else c let compare cmp t1 t2 = match t1, t2 with | DRel, DRel -> 0 | DSort, DSort -> 0 | DRef gr1, DRef gr2 -> RefOrdered.compare gr1 gr2 | DCtx (tl1, tr1), DCtx (tl2, tr2) | DLambda (tl1, tr1), DLambda (tl2, tr2) | DApp (tl1, tr1), DApp (tl2, tr2) -> let c = cmp tl1 tl2 in if c = 0 then cmp tr1 tr2 else c | DCase (ci1, c1, t1, p1), DCase (ci2, c2, t2, p2) -> let c = cmp c1 c2 in if c = 0 then let c = cmp t1 t2 in if c = 0 then let c = Array.compare cmp p1 p2 in if c = 0 then compare_ci ci1 ci2 else c else c else c | DFix (i1, j1, tl1, pl1), DFix (i2, j2, tl2, pl2) -> let c = Int.compare j1 j2 in if c = 0 then let c = Array.compare Int.compare i1 i2 in if c = 0 then let c = Array.compare cmp tl1 tl2 in if c = 0 then Array.compare cmp pl1 pl2 else c else c else c | DCoFix (i1, tl1, pl1), DCoFix (i2, tl2, pl2) -> let c = Int.compare i1 i2 in if c = 0 then let c = Array.compare cmp tl1 tl2 in if c = 0 then Array.compare cmp pl1 pl2 else c else c | _ -> Pervasives.compare t1 t2 (** OK **) let fold f acc = function | (DRel | DNil | DSort | DRef _) -> acc | DCtx (ctx,c) -> f (f acc ctx) c | DLambda (t,c) -> f (f acc t) c | DApp (t,u) -> f (f acc t) u | DCase (ci,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl | DFix (ia,i,ta,ca) -> Array.fold_left f (Array.fold_left f acc ta) ca | DCoFix(i,ta,ca) -> Array.fold_left f (Array.fold_left f acc ta) ca | DCons ((t,topt),u) -> f (Option.fold_left f (f acc t) topt) u let choose f = function | (DRel | DSort | DNil | DRef _) -> invalid_arg "choose" | DCtx (ctx,c) -> f ctx | DLambda (t,c) -> f t | DApp (t,u) -> f u | DCase (ci,p,c,bl) -> f c | DFix (ia,i,ta,ca) -> f ta.(0) | DCoFix (i,ta,ca) -> f ta.(0) | DCons ((t,topt),u) -> f u let dummy_cmp () () = 0 let fold2 (f:'a -> 'b -> 'c -> 'a) (acc:'a) (c1:'b t) (c2:'c t) : 'a = let head w = map (fun _ -> ()) w in if not (Int.equal (compare dummy_cmp (head c1) (head c2)) 0) then invalid_arg "fold2:compare" else match c1,c2 with | (DRel, DRel | DNil, DNil | DSort, DSort | DRef _, DRef _) -> acc | (DCtx (c1,t1), DCtx (c2,t2) | DApp (c1,t1), DApp (c2,t2) | DLambda (c1,t1), DLambda (c2,t2)) -> f (f acc c1 c2) t1 t2 | DCase (ci,p1,c1,bl1),DCase (_,p2,c2,bl2) -> Array.fold_left2 f (f (f acc p1 p2) c1 c2) bl1 bl2 | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2 | DCoFix(i,ta1,ca1), DCoFix(_,ta2,ca2) -> Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2 | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> f (Option.fold_left2 f (f acc t1 t2) topt1 topt2) u1 u2 | _ -> assert false let map2 (f:'a -> 'b -> 'c) (c1:'a t) (c2:'b t) : 'c t = let head w = map (fun _ -> ()) w in if not (Int.equal (compare dummy_cmp (head c1) (head c2)) 0) then invalid_arg "map2_t:compare" else match c1,c2 with | (DRel, DRel | DSort, DSort | DNil, DNil | DRef _, DRef _) as cc -> let (c,_) = cc in c | DCtx (c1,t1), DCtx (c2,t2) -> DCtx (f c1 c2, f t1 t2) | DLambda (t1,c1), DLambda (t2,c2) -> DLambda (f t1 t2, f c1 c2) | DApp (t1,u1), DApp (t2,u2) -> DApp (f t1 t2,f u1 u2) | DCase (ci,p1,c1,bl1), DCase (_,p2,c2,bl2) -> DCase (ci, f p1 p2, f c1 c2, Array.map2 f bl1 bl2) | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> DFix (ia,i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2) | DCoFix (i,ta1,ca1), DCoFix (_,ta2,ca2) -> DCoFix (i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2) | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> DCons ((f t1 t2,Option.lift2 f topt1 topt2), f u1 u2) | _ -> assert false let terminal = function | (DRel | DSort | DNil | DRef _) -> true | _ -> false let compare t1 t2 = compare dummy_cmp t1 t2 end (* * Terms discrimination nets * Uses the general dnet datatype on DTerm.t * (here you can restart reading) *) (* * Construction of the module *) module type IDENT = sig type t val compare : t -> t -> int val subst : substitution -> t -> t val constr_of : t -> constr end module type OPT = sig val reduce : constr -> constr val direction : bool end module Make = functor (Ident : IDENT) -> functor (Opt : OPT) -> struct module TDnet : Dnet.S with type ident=Ident.t and type 'a structure = 'a DTerm.t and type meta = int = Dnet.Make(DTerm)(Ident)(Int) type t = TDnet.t type ident = TDnet.ident (** We will freshen metas on the fly, to cope with the implementation defect of Term_dnet which requires metas to be all distinct. *) let fresh_meta = let index = ref 0 in fun () -> let ans = !index in let () = index := succ ans in ans open DTerm open TDnet let pat_of_constr c : term_pattern = (** To each evar we associate a unique identifier. *) let metas = ref Evar.Map.empty in let rec pat_of_constr c = match kind_of_term c with | Rel _ -> Term DRel | Sort _ -> Term DSort | Var i -> Term (DRef (VarRef i)) | Const (c,u) -> Term (DRef (ConstRef c)) | Ind (i,u) -> Term (DRef (IndRef i)) | Construct (c,u)-> Term (DRef (ConstructRef c)) | Term.Meta _ -> assert false | Evar (i,_) -> let meta = try Evar.Map.find i !metas with Not_found -> let meta = fresh_meta () in let () = metas := Evar.Map.add i meta !metas in meta in Meta meta | Case (ci,c1,c2,ca) -> Term(DCase(ci,pat_of_constr c1,pat_of_constr c2,Array.map pat_of_constr ca)) | Fix ((ia,i),(_,ta,ca)) -> Term(DFix(ia,i,Array.map pat_of_constr ta, Array.map pat_of_constr ca)) | CoFix (i,(_,ta,ca)) -> Term(DCoFix(i,Array.map pat_of_constr ta,Array.map pat_of_constr ca)) | Cast (c,_,_) -> pat_of_constr c | Lambda (_,t,c) -> Term(DLambda (pat_of_constr t, pat_of_constr c)) | (Prod (_,_,_) | LetIn(_,_,_,_)) -> let (ctx,c) = ctx_of_constr (Term DNil) c in Term (DCtx (ctx,c)) | App (f,ca) -> Array.fold_left (fun c a -> Term (DApp (c,a))) (pat_of_constr f) (Array.map pat_of_constr ca) | Proj (p,c) -> Term (DApp (Term (DRef (ConstRef (Projection.constant p))), pat_of_constr c)) and ctx_of_constr ctx c = match kind_of_term c with | Prod (_,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c | LetIn(_,d,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t, Some (pat_of_constr d)),ctx))) c | _ -> ctx,pat_of_constr c in pat_of_constr c let empty_ctx : term_pattern -> term_pattern = function | Meta _ as c -> c | Term (DCtx(_,_)) as c -> c | c -> Term (DCtx (Term DNil, c)) (* * Basic primitives *) let empty = TDnet.empty let subst s t = let sleaf id = Ident.subst s id in let snode = function | DTerm.DRef gr -> DTerm.DRef (fst (subst_global s gr)) | n -> n in TDnet.map sleaf snode t let union = TDnet.union let add (c:constr) (id:Ident.t) (dn:t) = let c = Opt.reduce c in let c = empty_ctx (pat_of_constr c) in TDnet.add dn c id let new_meta () = Meta (fresh_meta ()) let rec remove_cap : term_pattern -> term_pattern = function | Term (DCons (t,u)) -> Term (DCons (t,remove_cap u)) | Term DNil -> new_meta() | Meta _ as m -> m | _ -> assert false let under_prod : term_pattern -> term_pattern = function | Term (DCtx (t,u)) -> Term (DCtx (remove_cap t,u)) | Meta m -> Term (DCtx(new_meta(), Meta m)) | _ -> assert false (* debug *) (* let rec pr_term_pattern p = (fun pr_t -> function | Term t -> pr_t t | Meta m -> str"["++Pp.int (Obj.magic m)++str"]" ) (pr_dconstr pr_term_pattern) p*) let search_pat cpat dpat dn = let whole_c = cpat in (* if we are at the root, add an empty context *) let dpat = under_prod (empty_ctx dpat) in TDnet.Idset.fold (fun id acc -> let c_id = Opt.reduce (Ident.constr_of id) in let (ctx,wc) = try Termops.align_prod_letin whole_c c_id with Invalid_argument _ -> [],c_id in let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in try let _ = Termops.filtering ctx Reduction.CUMUL wc whole_c in id :: acc with Termops.CannotFilter -> (* msgnl(str"recon "++Termops.print_constr_env (Global.env()) wc); *) acc ) (TDnet.find_match dpat dn) [] (* * High-level primitives describing specific search problems *) let search_pattern dn pat = let pat = Opt.reduce pat in search_pat pat (empty_ctx (pat_of_constr pat)) dn let find_all dn = Idset.elements (TDnet.find_all dn) let map f dn = TDnet.map f (fun x -> x) dn let refresh_metas dn = let new_metas = ref Int.Map.empty in let refresh_one_meta i = try Int.Map.find i !new_metas with Not_found -> let new_meta = fresh_meta () in let () = new_metas := Int.Map.add i new_meta !new_metas in new_meta in TDnet.map_metas refresh_one_meta dn end module type S = sig type t type ident val empty : t val add : constr -> ident -> t -> t val union : t -> t -> t val subst : substitution -> t -> t val search_pattern : t -> constr -> ident list val find_all : t -> ident list val map : (ident -> ident) -> t -> t val refresh_metas : t -> t end coq-8.6/tactics/tactic_matching.mli0000644000175000017500000000422713022274260016742 0ustar mdenesmdenes (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Evd.evar_map -> Term.constr -> (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> Tacexpr.glob_tactic_expr t Proofview.tactic (** [match_goal env sigma hyps concl rules] matches the goal [hyps|-concl] with the set of matching rules [rules]. The environment [env] and the evar_map [sigma] are used to check convertibility for pattern variables shared between hypothesis patterns or the conclusion pattern. *) val match_goal: Environ.env -> Evd.evar_map -> Context.Named.t -> Term.constr -> (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> Tacexpr.glob_tactic_expr t Proofview.tactic coq-8.6/tactics/dnet.ml0000644000175000017500000002367713022274260014414 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'b) -> 'a t -> 'b t val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a val compare : unit t -> unit t -> int val terminal : 'a t -> bool val choose : ('a -> 'b) -> 'a t -> 'b end module type S = sig type t type ident type meta type 'a structure module Idset : Set.S with type elt=ident type term_pattern = | Term of term_pattern structure | Meta of meta val empty : t val add : t -> term_pattern -> ident -> t val find_all : t -> Idset.t val fold_pattern : ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a val find_match : term_pattern -> t -> Idset.t val inter : t -> t -> t val union : t -> t -> t val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t val map_metas : (meta -> meta) -> t -> t end module Make = functor (T:Datatype) -> functor (Ident:Set.OrderedType) -> functor (Meta:Set.OrderedType) -> struct type ident = Ident.t type meta = Meta.t type 'a structure = 'a T.t type term_pattern = | Term of term_pattern structure | Meta of meta module Idset = Set.Make(Ident) module Mmap = Map.Make(Meta) module Tmap = Map.Make(struct type t = unit structure let compare = T.compare end) type idset = Idset.t (* we store identifiers at the leaf of the dnet *) type node = | Node of t structure | Terminal of t structure * idset (* at each node, we have a bunch of nodes (actually a map between the bare node and a subnet) and a bunch of metavariables *) and t = Nodes of node Tmap.t * idset Mmap.t let empty : t = Nodes (Tmap.empty, Mmap.empty) (* the head of a data is of type unit structure *) let head w = T.map (fun c -> ()) w (* given a node of the net and a word, returns the subnet with the same head as the word (with the rest of the nodes) *) let split l (w:'a structure) : node * node Tmap.t = let elt : node = Tmap.find (head w) l in (elt, Tmap.remove (head w) l) let select l w = Tmap.find (head w) l let rec add (Nodes (t,m):t) (w:term_pattern) (id:ident) : t = match w with Term w -> ( try let (n,tl) = split t w in let new_node = match n with | Terminal (e,is) -> Terminal (e,Idset.add id is) | Node e -> Node (T.map2 (fun t p -> add t p id) e w) in Nodes ((Tmap.add (head w) new_node tl), m) with Not_found -> let new_content = T.map (fun p -> add empty p id) w in let new_node = if T.terminal w then Terminal (new_content, Idset.singleton id) else Node new_content in Nodes ((Tmap.add (head w) new_node t), m) ) | Meta i -> let m = try Mmap.add i (Idset.add id (Mmap.find i m)) m with Not_found -> Mmap.add i (Idset.singleton id) m in Nodes (t, m) let add t w id = add t w id let rec find_all (Nodes (t,m)) : idset = Idset.union (Mmap.fold (fun _ -> Idset.union) m Idset.empty) (Tmap.fold ( fun _ n acc -> let s2 = match n with | Terminal (_,is) -> is | Node e -> T.choose find_all e in Idset.union acc s2 ) t Idset.empty) (* (\* optimization hack: Not_found is caught in fold_pattern *\) *) (* let fast_inter s1 s2 = *) (* if Idset.is_empty s1 || Idset.is_empty s2 then raise Not_found *) (* else Idset.inter s1 s2 *) (* let option_any2 f s1 s2 = match s1,s2 with *) (* | Some s1, Some s2 -> f s1 s2 *) (* | (Some s, _ | _, Some s) -> s *) (* | _ -> raise Not_found *) (* let fold_pattern ?(complete=true) f acc pat dn = *) (* let deferred = ref [] in *) (* let leafs,metas = ref None, ref None in *) (* let leaf s = leafs := match !leafs with *) (* | None -> Some s *) (* | Some s' -> Some (fast_inter s s') in *) (* let meta s = metas := match !metas with *) (* | None -> Some s *) (* | Some s' -> Some (Idset.union s s') in *) (* let defer c = deferred := c::!deferred in *) (* let rec fp_rec (p:term_pattern) (Nodes(t,m) as dn:t) = *) (* Mmap.iter (fun _ -> meta) m; (\* TODO: gérer patterns nonlin ici *\) *) (* match p with *) (* | Meta m -> defer (m,dn) *) (* | Term w -> *) (* try match select t w with *) (* | Terminal (_,is) -> leaf is *) (* | Node e -> *) (* if complete then T.fold2 (fun _ -> fp_rec) () w e else *) (* if T.fold2 *) (* (fun b p dn -> match p with *) (* | Term _ -> fp_rec p dn; false *) (* | Meta _ -> b *) (* ) true w e *) (* then T.choose (T.choose fp_rec w) e *) (* with Not_found -> *) (* if Mmap.is_empty m then raise Not_found else () *) (* in try *) (* fp_rec pat dn; *) (* (try Some (option_any2 Idset.union !leafs !metas) with Not_found -> None), *) (* List.fold_left (fun acc (m,dn) -> f m dn acc) acc !deferred *) (* with Not_found -> None,acc *) (* Sets with a neutral element for inter *) module OSet (S:Set.S) = struct type t = S.t option let union s1 s2 : t = match s1,s2 with | (None, _ | _, None) -> None | Some a, Some b -> Some (S.union a b) let inter s1 s2 : t = match s1,s2 with | (None, a | a, None) -> a | Some a, Some b -> Some (S.inter a b) let is_empty : t -> bool = function | None -> false | Some s -> S.is_empty s (* optimization hack: Not_found is caught in fold_pattern *) let fast_inter s1 s2 = if is_empty s1 || is_empty s2 then raise Not_found else let r = inter s1 s2 in if is_empty r then raise Not_found else r let full = None let empty = Some S.empty end module OIdset = OSet(Idset) let fold_pattern ?(complete=true) f acc pat dn = let deferred = ref [] in let defer c = deferred := c::!deferred in let rec fp_rec metas p (Nodes(t,m) as dn:t) = (* TODO gérer les dnets non-linéaires *) let metas = Mmap.fold (fun _ -> Idset.union) m metas in match p with | Meta m -> defer (metas,m,dn); OIdset.full | Term w -> let curm = Mmap.fold (fun _ -> Idset.union) m Idset.empty in try match select t w with | Terminal (_,is) -> Some (Idset.union curm is) | Node e -> let ids = if complete then T.fold2 (fun acc w e -> OIdset.fast_inter acc (fp_rec metas w e) ) OIdset.full w e else let (all_metas, res) = T.fold2 (fun (b,acc) w e -> match w with | Term _ -> false, OIdset.fast_inter acc (fp_rec metas w e) | Meta _ -> b, acc ) (true,OIdset.full) w e in if all_metas then T.choose (T.choose (fp_rec metas) w) e else res in OIdset.union ids (Some curm) with Not_found -> if Idset.is_empty metas then raise Not_found else Some curm in let cand = try fp_rec Idset.empty pat dn with Not_found -> OIdset.empty in let res = List.fold_left f acc !deferred in cand, res (* intersection of two dnets. keep only the common pairs *) let rec inter (t1:t) (t2:t) : t = let inter_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = Nodes (Tmap.fold ( fun k e acc -> try Tmap.add k (f e (Tmap.find k t2)) acc with Not_found -> acc ) t1 Tmap.empty, Mmap.fold ( fun m s acc -> try Mmap.add m (Idset.inter s (Mmap.find m m2)) acc with Not_found -> acc ) m1 Mmap.empty ) in inter_map (fun n1 n2 -> match n1,n2 with | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.inter s1 s2) | Node e1, Node e2 -> Node (T.map2 inter e1 e2) | _ -> assert false ) t1 t2 let rec union (t1:t) (t2:t) : t = let union_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = Nodes (Tmap.fold ( fun k e acc -> try Tmap.add k (f e (Tmap.find k acc)) acc with Not_found -> Tmap.add k e acc ) t1 t2, Mmap.fold ( fun m s acc -> try Mmap.add m (Idset.inter s (Mmap.find m acc)) acc with Not_found -> Mmap.add m s acc ) m1 m2 ) in union_map (fun n1 n2 -> match n1,n2 with | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.union s1 s2) | Node e1, Node e2 -> Node (T.map2 union e1 e2) | _ -> assert false ) t1 t2 let find_match (p:term_pattern) (t:t) : idset = let metas = ref Mmap.empty in let (mset,lset) = fold_pattern ~complete:false (fun acc (mset,m,t) -> let all = OIdset.fast_inter acc (Some(let t = try inter t (Mmap.find m !metas) with Not_found -> t in metas := Mmap.add m t !metas; find_all t)) in OIdset.union (Some mset) all ) None p t in Option.get (OIdset.inter mset lset) let fold_pattern f acc p dn = fold_pattern ~complete:true f acc p dn let idset_map f is = Idset.fold (fun e acc -> Idset.add (f e) acc) is Idset.empty let tmap_map f g m = Tmap.fold (fun k e acc -> Tmap.add (f k) (g e) acc) m Tmap.empty let rec map sidset sterm (Nodes (t,m)) : t = let snode = function | Terminal (e,is) -> Terminal (e,idset_map sidset is) | Node e -> Node (T.map (map sidset sterm) e) in Nodes (tmap_map sterm snode t, Mmap.map (idset_map sidset) m) let rec map_metas f (Nodes (t, m)) : t = let f_node = function | Terminal (e, is) -> Terminal (T.map (map_metas f) e, is) | Node e -> Node (T.map (map_metas f) e) in let m' = Mmap.fold (fun m s acc -> Mmap.add (f m) s acc) m Mmap.empty in let t' = Tmap.fold (fun k n acc -> Tmap.add k (f_node n) acc) t Tmap.empty in Nodes (t', m') end coq-8.6/tactics/doc.tex0000644000175000017500000000036613022274260014405 0ustar mdenesmdenes \newpage \section*{The Tactics} \ocwsection \label{tactics} This chapter describes the \Coq\ main tactics. The modules of that chapter are organized as follows. \bigskip \begin{center}\epsfig{file=tactics.dep.ps,width=\linewidth}\end{center} coq-8.6/tactics/autorewrite.ml0000644000175000017500000002673713022274260016034 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* errorlabstrm "AutoRewrite" (str "Rewriting base " ++ str bas ++ str " does not exist.") let find_rewrites bas = List.rev_map snd (HintDN.find_all (find_base bas)) let find_matches bas pat = let base = find_base bas in let res = HintDN.search_pattern base pat in List.map snd res let print_rewrite_hintdb bas = (str "Database " ++ str bas ++ fnl () ++ prlist_with_sep fnl (fun h -> str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ Option.cata (fun tac -> str " then use tactic " ++ Pptactic.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option (* Applies all the rules of one base *) let one_base general_rewrite_maybe_in tac_main bas = let lrul = find_rewrites bas in let try_rewrite dir ctx c tc = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in let c' = Vars.subst_univs_level_constr subst c in let sigma = Sigma.to_evar_map sigma in let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in let tac = general_rewrite_maybe_in dir c' tc in Sigma.Unsafe.of_pair (tac, sigma) end } in let lrul = List.map (fun h -> let tac = match h.rew_tac with | None -> Proofview.tclUNIT () | Some (Genarg.GenArg (Genarg.Glbwit wit, tac)) -> let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) in (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> Tacticals.New.tclTHEN tac (Tacticals.New.tclREPEAT_MAIN (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main))) (Proofview.tclUNIT()) lrul)) (* The AutoRewrite tactic *) let autorewrite ?(conds=Naive) tac_main lbas = Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac bas -> Tacticals.New.tclTHEN tac (one_base (fun dir c tac -> let tac = (tac, conds) in general_rewrite dir AllOccurrences true false ~tac c) tac_main bas)) (Proofview.tclUNIT()) lbas)) let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = Proofview.Goal.nf_enter { enter = begin fun gl -> (* let's check at once if id exists (to raise the appropriate error) *) let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in let general_rewrite_in id = let id = ref id in let to_be_cleared = ref false in fun dir cstr tac gl -> let last_hyp_id = match Tacmach.pf_hyps gl with d :: _ -> Context.Named.Declaration.get_id d | _ -> (* even the hypothesis id is missing *) raise (Logic.RefinerError (Logic.NoSuchHyp !id)) in let gl' = Proofview.V82.of_tactic (general_rewrite_in dir AllOccurrences true ~tac:(tac, conds) false !id cstr false) gl in let gls = gl'.Evd.it in match gls with g::_ -> (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with d ::_ -> let lastid = Context.Named.Declaration.get_id d in if not (Id.equal last_hyp_id lastid) then begin let gl'' = if !to_be_cleared then tclTHEN (fun _ -> gl') (tclTRY (Proofview.V82.of_tactic (clear [!id]))) gl else gl' in id := lastid ; to_be_cleared := true ; gl'' end else begin to_be_cleared := false ; gl' end | _ -> assert false) (* there must be at least an hypothesis *) | _ -> assert false (* rewriting cannot complete a proof *) in let general_rewrite_in x y z w = Proofview.V82.tactic (general_rewrite_in x y z w) in Tacticals.New.tclMAP (fun id -> Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac bas -> Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas))) idl end } let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id] let gen_auto_multi_rewrite conds tac_main lbas cl = let try_do_hyps treat_id l = autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas in if cl.concl_occs != AllOccurrences && cl.concl_occs != NoOccurrences then Tacticals.New.tclZEROMSG (str"The \"at\" syntax isn't available yet for the autorewrite tactic.") else let compose_tac t1 t2 = match cl.onhyps with | Some [] -> t1 | _ -> Tacticals.New.tclTHENFIRST t1 t2 in compose_tac (if cl.concl_occs != NoOccurrences then autorewrite ~conds tac_main lbas else Proofview.tclUNIT ()) (match cl.onhyps with | Some l -> try_do_hyps (fun ((_,id),_) -> id) l | None -> (* try to rewrite in all hypothesis (except maybe the rewritten one) *) Proofview.Goal.nf_enter { enter = begin fun gl -> let ids = Tacmach.New.pf_ids_of_hyps gl in try_do_hyps (fun id -> id) ids end }) let auto_multi_rewrite ?(conds=Naive) lems cl = Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds (Proofview.tclUNIT()) lems cl) let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in match onconcl,cl.Locus.onhyps with | false,Some [_] | true,Some [] | false,Some [] -> (* autorewrite with .... in clause using tac n'est sur que si clause represente soit le but soit UNE hypothese *) Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds tac_main lbas cl) | _ -> Tacticals.New.tclZEROMSG (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") (* Functions necessary to the library object declaration *) let cache_hintrewrite (_,(rbase,lrl)) = let base = try raw_find_base rbase with Not_found -> HintDN.empty in let max = try fst (Util.List.last (HintDN.find_all base)) with Failure _ -> 0 in let lrl = HintDN.refresh_metas lrl in let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in rewtab:=String.Map.add rbase (HintDN.union lrl base) !rewtab let subst_hintrewrite (subst,(rbase,list as node)) = let list' = HintDN.subst subst list in if list' == list then node else (rbase,list') let classify_hintrewrite x = Libobject.Substitute x (* Declaration of the Hint Rewrite library object *) let inHintRewrite : string * HintDN.t -> Libobject.obj = Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with Libobject.cache_function = cache_hintrewrite; Libobject.load_function = (fun _ -> cache_hintrewrite); Libobject.subst_function = subst_hintrewrite; Libobject.classify_function = classify_hintrewrite } open Clenv type hypinfo = { hyp_cl : clausenv; hyp_prf : constr; hyp_ty : types; hyp_car : constr; hyp_rel : constr; hyp_l2r : bool; hyp_left : constr; hyp_right : constr; } let decompose_applied_relation metas env sigma c ctype left2right = let find_rel ty = let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in let eqclause = if metas then eqclause else clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd) in let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in let rec split_last_two = function | [c1;c2] -> [],(c1, c2) | x::y::z -> let l,res = split_last_two (y::z) in x::l, res | _ -> raise Not_found in try let others,(c1,c2) = split_last_two args in let ty1, ty2 = Typing.unsafe_type_of env eqclause.evd c1, Typing.unsafe_type_of env eqclause.evd c2 in (* if not (evd_convertible env eqclause.evd ty1 ty2) then None *) (* else *) Some { hyp_cl=eqclause; hyp_prf=(Clenv.clenv_value eqclause); hyp_ty = ty; hyp_car=ty1; hyp_rel=mkApp (equiv, Array.of_list others); hyp_l2r=left2right; hyp_left=c1; hyp_right=c2; } with Not_found -> None in match find_rel ctype with | Some c -> Some c | None -> let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) match find_rel (it_mkProd_or_LetIn t' ctx) with | Some c -> Some c | None -> None let find_applied_relation metas loc env sigma c left2right = let ctype = Typing.unsafe_type_of env sigma c in match decompose_applied_relation metas env sigma c ctype left2right with | Some c -> c | None -> user_err_loc (loc, "decompose_applied_relation", str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ spc () ++ str"of this term does not end with an applied relation.") (* To add rewriting rules to a base *) let add_rew_rules base lrul = let counter = ref 0 in let env = Global.env () in let sigma = Evd.from_env env in let ist = { Genintern.ltacvars = Id.Set.empty; genv = Global.env () } in let intern tac = snd (Genintern.generic_intern ist tac) in let lrul = List.fold_left (fun dn (loc,(c,ctx),b,t) -> let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in let info = find_applied_relation false loc env sigma c b in let pat = if b then info.hyp_left else info.hyp_right in let rul = { rew_lemma = c; rew_type = info.hyp_ty; rew_pat = pat; rew_ctx = ctx; rew_l2r = b; rew_tac = Option.map intern t} in incr counter; HintDN.add pat (!counter, rul) dn) HintDN.empty lrul in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) coq-8.6/tactics/autorewrite.mli0000644000175000017500000000427413022274260016175 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* raw_rew_rule list -> unit (** The AutoRewrite tactic. The optional conditions tell rewrite how to handle matching and side-condition solving. Default is Naive: first match in the clause, don't look at the side-conditions to tell if the rewrite succeeded. *) val autorewrite : ?conds:conditions -> unit Proofview.tactic -> string list -> unit Proofview.tactic val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> string list -> unit Proofview.tactic (** Rewriting rules *) type rew_rule = { rew_lemma: constr; rew_type: types; rew_pat: constr; rew_ctx: Univ.universe_context_set; rew_l2r: bool; rew_tac: Genarg.glob_generic_argument option } val find_rewrites : string -> rew_rule list val find_matches : string -> constr -> rew_rule list val auto_multi_rewrite : ?conds:conditions -> string list -> Locus.clause -> unit Proofview.tactic val auto_multi_rewrite_with : ?conds:conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic val print_rewrite_hintdb : string -> Pp.std_ppcmds open Clenv type hypinfo = { hyp_cl : clausenv; hyp_prf : constr; hyp_ty : types; hyp_car : constr; hyp_rel : constr; hyp_l2r : bool; hyp_left : constr; hyp_right : constr; } val find_applied_relation : bool -> Loc.t -> Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo coq-8.6/tactics/eqdecide.mli0000644000175000017500000000175713022274260015371 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Constr.t -> unit Proofview.tactic coq-8.6/tactics/equality.ml0000644000175000017500000021420113022274260015300 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !discriminate_introduction); optwrite = (:=) discriminate_introduction } let injection_pattern_l2r_order = ref true let use_injection_pattern_l2r_order () = !injection_pattern_l2r_order && Flags.version_strictly_greater Flags.V8_4 let _ = declare_bool_option { optsync = true; optdepr = false; optname = "injection left-to-right pattern order and clear by default when with introduction pattern"; optkey = ["Injection";"L2R";"Pattern";"Order"]; optread = (fun () -> !injection_pattern_l2r_order) ; optwrite = (fun b -> injection_pattern_l2r_order := b) } let injection_in_context = ref false let use_injection_in_context () = !injection_in_context && Flags.version_strictly_greater Flags.V8_5 let _ = declare_bool_option { optsync = true; optdepr = false; optname = "injection in context"; optkey = ["Structural";"Injection"]; optread = (fun () -> !injection_in_context) ; optwrite = (fun b -> injection_in_context := b) } (* Rewriting tactics *) let tclNOTSAMEGOAL tac = Proofview.V82.tactic (Tacticals.tclNOTSAMEGOAL (Proofview.V82.of_tactic tac)) type dep_proof_flag = bool (* true = support rewriting dependent proofs *) type freeze_evars_flag = bool (* true = don't instantiate existing evars *) type orientation = bool type conditions = | Naive (* Only try the first occurrence of the lemma (default) *) | FirstSolved (* Use the first match whose side-conditions are solved *) | AllMatches (* Rewrite all matches whose side-conditions are solved *) (* Warning : rewriting from left to right only works if there exists in the context a theorem named __r with type (A:)(x:A)(P:A->Prop)(P x)->(y:A)(eqname A y x)->(P y). If another equality myeq is introduced, then corresponding theorems myeq_ind_r, myeq_rec_r and myeq_rect_r have to be proven. See below. -- Eduardo (19/8/97) *) let rewrite_core_unif_flags = { modulo_conv_on_closed_terms = None; use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; modulo_delta = empty_transparent_state; modulo_delta_types = empty_transparent_state; check_applied_meta_types = true; use_pattern_unification = true; use_meta_bound_pattern_unification = true; frozen_evars = Evar.Set.empty; restrict_conv_on_strict_subterms = false; modulo_betaiota = false; modulo_eta = true; } let rewrite_unif_flags = { core_unify_flags = rewrite_core_unif_flags; merge_unify_flags = rewrite_core_unif_flags; subterm_unify_flags = rewrite_core_unif_flags; allow_K_in_toplevel_higher_order_unification = false; (* allow_K does not matter in practice because calls w_typed_unify *) resolve_evars = true } let freeze_initial_evars sigma flags clause = (* We take evars of the type: this may include old evars! For excluding *) (* all old evars, including the ones occurring in the rewriting lemma, *) (* we would have to take the clenv_value *) let newevars = Evd.evars_of_term (clenv_type clause) in let evars = fold_undefined (fun evk _ evars -> if Evar.Set.mem evk newevars then evars else Evar.Set.add evk evars) sigma Evar.Set.empty in {flags with core_unify_flags = {flags.core_unify_flags with frozen_evars = evars}; merge_unify_flags = {flags.merge_unify_flags with frozen_evars = evars}; subterm_unify_flags = {flags.subterm_unify_flags with frozen_evars = evars}} let make_flags frzevars sigma flags clause = if frzevars then freeze_initial_evars sigma flags clause else flags let side_tac tac sidetac = match sidetac with | None -> tac | Some sidetac -> tclTHENSFIRSTn tac [|Proofview.tclUNIT ()|] sidetac let instantiate_lemma_all frzevars gl c ty l l2r concl = let env = Proofview.Goal.env gl in let eqclause = pf_apply Clenv.make_clenv_binding gl (c,ty) l in let (equiv, args) = decompose_appvect (Clenv.clenv_type eqclause) in let arglen = Array.length args in let () = if arglen < 2 then error "The term provided is not an applied relation." in let c1 = args.(arglen - 2) in let c2 = args.(arglen - 1) in let try_occ (evd', c') = Clenvtac.clenv_pose_dependent_evars true {eqclause with evd = evd'} in let flags = make_flags frzevars (Tacmach.New.project gl) rewrite_unif_flags eqclause in let occs = w_unify_to_subterm_all ~flags env eqclause.evd ((if l2r then c1 else c2),concl) in List.map try_occ occs let instantiate_lemma gl c ty l l2r concl = let sigma, ct = pf_type_of gl c in let t = try snd (reduce_to_quantified_ind (pf_env gl) sigma ct) with UserError _ -> ct in let eqclause = Clenv.make_clenv_binding (pf_env gl) sigma (c,t) l in [eqclause] let rewrite_conv_closed_core_unif_flags = { modulo_conv_on_closed_terms = Some full_transparent_state; (* We have this flag for historical reasons, it has e.g. the consequence *) (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) modulo_delta = empty_transparent_state; modulo_delta_types = full_transparent_state; check_applied_meta_types = true; use_pattern_unification = true; (* To rewrite "?n x y" in "y+x=0" when ?n is *) (* a preexisting evar of the goal*) use_meta_bound_pattern_unification = true; frozen_evars = Evar.Set.empty; (* This is set dynamically *) restrict_conv_on_strict_subterms = false; modulo_betaiota = false; modulo_eta = true; } let rewrite_conv_closed_unif_flags = { core_unify_flags = rewrite_conv_closed_core_unif_flags; merge_unify_flags = rewrite_conv_closed_core_unif_flags; subterm_unify_flags = rewrite_conv_closed_core_unif_flags; allow_K_in_toplevel_higher_order_unification = false; resolve_evars = false } let rewrite_keyed_core_unif_flags = { modulo_conv_on_closed_terms = Some full_transparent_state; (* We have this flag for historical reasons, it has e.g. the consequence *) (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) modulo_delta = full_transparent_state; modulo_delta_types = full_transparent_state; check_applied_meta_types = true; use_pattern_unification = true; (* To rewrite "?n x y" in "y+x=0" when ?n is *) (* a preexisting evar of the goal*) use_meta_bound_pattern_unification = true; frozen_evars = Evar.Set.empty; (* This is set dynamically *) restrict_conv_on_strict_subterms = false; modulo_betaiota = true; modulo_eta = true; } let rewrite_keyed_unif_flags = { core_unify_flags = rewrite_keyed_core_unif_flags; merge_unify_flags = rewrite_keyed_core_unif_flags; subterm_unify_flags = rewrite_keyed_core_unif_flags; allow_K_in_toplevel_higher_order_unification = false; resolve_evars = false } let rewrite_elim with_evars frzevars cls c e = Proofview.Goal.enter { enter = begin fun gl -> let flags = if Unification.is_keyed_unification () then rewrite_keyed_unif_flags else rewrite_conv_closed_unif_flags in let flags = make_flags frzevars (Tacmach.New.project gl) flags c in general_elim_clause with_evars flags cls c e end } (* Ad hoc asymmetric general_elim_clause *) let general_elim_clause with_evars frzevars cls rew elim = let open Pretype_errors in Proofview.tclORELSE begin match cls with | None -> (* was tclWEAK_PROGRESS which only fails for tactics generating one subgoal and did not fail for useless conditional rewritings generating an extra condition *) tclNOTSAMEGOAL (rewrite_elim with_evars frzevars cls rew elim) | Some _ -> rewrite_elim with_evars frzevars cls rew elim end begin function (e, info) -> match e with | PretypeError (env, evd, NoOccurrenceFound (c', _)) -> Proofview.tclZERO (PretypeError (env, evd, NoOccurrenceFound (c', cls))) | e -> Proofview.tclZERO ~info e end let general_elim_clause with_evars frzevars tac cls c t l l2r elim = let all, firstonly, tac = match tac with | None -> false, false, None | Some (tac, Naive) -> false, false, Some tac | Some (tac, FirstSolved) -> true, true, Some (tclCOMPLETE tac) | Some (tac, AllMatches) -> true, false, Some (tclCOMPLETE tac) in let try_clause c = side_tac (tclTHEN (Proofview.Unsafe.tclEVARS c.evd) (general_elim_clause with_evars frzevars cls c elim)) tac in Proofview.Goal.enter { enter = begin fun gl -> let instantiate_lemma concl = if not all then instantiate_lemma gl c t l l2r concl else instantiate_lemma_all frzevars gl c t l l2r concl in let typ = match cls with | None -> pf_nf_concl gl | Some id -> pf_get_hyp_typ id (Proofview.Goal.assume gl) in let cs = instantiate_lemma typ in if firstonly then tclFIRST (List.map try_clause cs) else tclMAP try_clause cs end } (* The next function decides in particular whether to try a regular rewrite or a generalized rewrite. Approach is to break everything, if [eq] appears in head position then regular rewrite else try general rewrite. If occurrences are set, use general rewrite. *) let (forward_general_setoid_rewrite_clause, general_setoid_rewrite_clause) = Hook.make () (* Do we have a JMeq instance on twice the same domains ? *) let jmeq_same_dom gl = function | None -> true (* already checked in Hipattern.find_eq_data_decompose *) | Some t -> let rels, t = decompose_prod_assum t in let env = Environ.push_rel_context rels (Proofview.Goal.env gl) in match decompose_app t with | _, [dom1; _; dom2;_] -> is_conv env (Tacmach.New.project gl) dom1 dom2 | _ -> false (* find_elim determines which elimination principle is necessary to eliminate lbeq on sort_of_gl. *) let find_elim hdcncl lft2rgt dep cls ot gl = let inccl = Option.is_empty cls in if (is_global Coqlib.glob_eq hdcncl || (is_global Coqlib.glob_jmeq hdcncl && jmeq_same_dom gl ot)) && not dep || Flags.version_less_or_equal Flags.V8_2 then let c = match kind_of_term hdcncl with | Ind (ind_sp,u) -> let pr1 = lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) in begin match lft2rgt, cls with | Some true, None | Some false, Some _ -> let c1 = destConstRef pr1 in let mp,dp,l = repr_con (constant_of_kn (canonical_con c1)) in let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in let c1' = Global.constant_of_delta_kn (make_kn mp dp l') in begin try let _ = Global.lookup_constant c1' in c1' with Not_found -> errorlabstrm "Equality.find_elim" (str "Cannot find rewrite principle " ++ pr_label l' ++ str ".") end | _ -> destConstRef pr1 end | _ -> (* cannot occur since we checked that we are in presence of Logic.eq or Jmeq just before *) assert false in let Sigma (elim, sigma, p) = Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in Sigma ((elim, Safe_typing.empty_private_constants), sigma, p) else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) | false, Some true, true -> rew_l2r_scheme_kind | false, Some true, false -> rew_r2l_scheme_kind | false, _, false -> rew_l2r_scheme_kind | false, _, true -> rew_r2l_scheme_kind (* Dependent case *) | true, Some true, true -> rew_l2r_dep_scheme_kind | true, Some true, false -> rew_l2r_forward_dep_scheme_kind | true, _, true -> rew_r2l_dep_scheme_kind | true, _, false -> rew_r2l_forward_dep_scheme_kind in match kind_of_term hdcncl with | Ind (ind,u) -> let c, eff = find_scheme scheme_name ind in (* MS: cannot use pf_constr_of_global as the eliminator might be generated by side-effect *) let Sigma (elim, sigma, p) = Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in Sigma ((elim, eff), sigma, p) | _ -> assert false let type_of_clause cls gl = match cls with | None -> Proofview.Goal.concl gl | Some id -> pf_get_hyp_typ id gl let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let evd = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let isatomic = isProd (whd_zeta evd hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun c type_of_cls in let Sigma ((elim, effs), sigma, p) = find_elim hdcncl lft2rgt dep cls (Some t) gl in let tac = Proofview.tclEFFECTS effs <*> general_elim_clause with_evars frzevars tac cls c t l (match lft2rgt with None -> false | Some b -> b) {elimindex = None; elimbody = (elim,NoBindings); elimrename = None} in Sigma (tac, sigma, p) end } let adjust_rewriting_direction args lft2rgt = match args with | [_] -> (* equality to a constant, like in eq_true *) (* more natural to see -> as the rewriting to the constant *) if not lft2rgt then error "Rewriting non-symmetric equality not allowed from right-to-left."; None | _ -> (* other equality *) Some lft2rgt let rewrite_side_tac tac sidetac = side_tac tac (Option.map fst sidetac) (* Main function for dispatching which kind of rewriting it is about *) let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac ((c,l) : constr with_bindings) with_evars = if occs != AllOccurrences then ( rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac) else Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in let rels, t = decompose_prod_assum (whd_betaiotazeta sigma ctype) in match match_with_equality_type t with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t rels) l with_evars frzevars dep_proof_ok hdcncl | None -> Proofview.tclORELSE begin rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac end begin function | (e, info) -> let env' = push_rel_context rels env in let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) match match_with_equality_type t' with | Some (hdcncl,args) -> let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok hdcncl | None -> Proofview.tclZERO ~info e (* error "The provided term does not end with an equality or a declared rewrite relation." *) end end } let general_rewrite_ebindings = general_rewrite_ebindings_clause None let general_rewrite_bindings l2r occs frzevars dep_proof_ok ?tac (c,bl) = general_rewrite_ebindings_clause None l2r occs frzevars dep_proof_ok ?tac (c,bl) let general_rewrite l2r occs frzevars dep_proof_ok ?tac c = general_rewrite_bindings l2r occs frzevars dep_proof_ok ?tac (c,NoBindings) false let general_rewrite_ebindings_in l2r occs frzevars dep_proof_ok ?tac id = general_rewrite_ebindings_clause (Some id) l2r occs frzevars dep_proof_ok ?tac let general_rewrite_bindings_in l2r occs frzevars dep_proof_ok ?tac id (c,bl) = general_rewrite_ebindings_clause (Some id) l2r occs frzevars dep_proof_ok ?tac (c,bl) let general_rewrite_in l2r occs frzevars dep_proof_ok ?tac id c = general_rewrite_ebindings_clause (Some id) l2r occs frzevars dep_proof_ok ?tac (c,NoBindings) let general_rewrite_clause l2r with_evars ?tac c cl = let occs_of = occurrences_map (List.fold_left (fun acc -> function ArgArg x -> x :: acc | ArgVar _ -> acc) []) in match cl.onhyps with | Some l -> (* If a precise list of locations is given, success is mandatory for each of these locations. *) let rec do_hyps = function | [] -> Proofview.tclUNIT () | ((occs,id),_) :: l -> tclTHENFIRST (general_rewrite_ebindings_in l2r (occs_of occs) false true ?tac id c with_evars) (do_hyps l) in if cl.concl_occs == NoOccurrences then do_hyps l else tclTHENFIRST (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) (do_hyps l) | None -> (* Otherwise, if we are told to rewrite in all hypothesis via the syntax "* |-", we fail iff all the different rewrites fail *) let rec do_hyps_atleastonce = function | [] -> tclZEROMSG (Pp.str"Nothing to rewrite.") | id :: l -> tclIFTHENTRYELSEMUST (general_rewrite_ebindings_in l2r AllOccurrences false true ?tac id c with_evars) (do_hyps_atleastonce l) in let do_hyps = (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) let ids gl = let ids_in_c = Environ.global_vars_set (Global.env()) (fst c) in let ids_of_hyps = pf_ids_of_hyps gl in Id.Set.fold (fun id l -> List.remove Id.equal id l) ids_in_c ids_of_hyps in Proofview.Goal.enter { enter = begin fun gl -> do_hyps_atleastonce (ids gl) end } in if cl.concl_occs == NoOccurrences then do_hyps else tclIFTHENTRYELSEMUST (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) do_hyps let apply_special_clear_request clear_flag f = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try let ((c, bl), sigma) = run_delayed env sigma f in apply_clear_request clear_flag (use_clear_hyp_by_default ()) c with e when catchable_exception e -> tclIDTAC end } let general_multi_rewrite with_evars l cl tac = let do1 l2r f = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (c, sigma) = run_delayed env sigma f in tclWITHHOLES with_evars (general_rewrite_clause l2r with_evars ?tac c cl) sigma end } in let rec doN l2r c = function | Precisely n when n <= 0 -> Proofview.tclUNIT () | Precisely 1 -> do1 l2r c | Precisely n -> tclTHENFIRST (do1 l2r c) (doN l2r c (Precisely (n-1))) | RepeatStar -> tclREPEAT_MAIN (do1 l2r c) | RepeatPlus -> tclTHENFIRST (do1 l2r c) (doN l2r c RepeatStar) | UpTo n when n<=0 -> Proofview.tclUNIT () | UpTo n -> tclTHENFIRST (tclTRY (do1 l2r c)) (doN l2r c (UpTo (n-1))) in let rec loop = function | [] -> Proofview.tclUNIT () | (l2r,m,clear_flag,c)::l -> tclTHENFIRST (tclTHEN (doN l2r c m) (apply_special_clear_request clear_flag c)) (loop l) in loop l let rewriteLR = general_rewrite true AllOccurrences true true let rewriteRL = general_rewrite false AllOccurrences true true (* Replacing tactics *) let classes_dirpath = DirPath.make (List.map Id.of_string ["Classes";"Coq"]) let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] let check_setoid cl = Option.fold_left ( List.fold_left (fun b ((occ,_),_) -> b||(Locusops.occurrences_map (fun x -> x) occ <> AllOccurrences) ) ) ((Locusops.occurrences_map (fun x -> x) cl.concl_occs <> AllOccurrences) && (Locusops.occurrences_map (fun x -> x) cl.concl_occs <> NoOccurrences)) cl.onhyps let replace_core clause l2r eq = if check_setoid clause then init_setoid (); tclTHENFIRST (assert_as false None None eq) (onLastHypId (fun id -> tclTHEN (tclTRY (general_rewrite_clause l2r false (mkVar id,NoBindings) clause)) (clear [id]))) (* eq,sym_eq : equality on Type and its symmetry theorem c1 c2 : c1 is to be replaced by c2 unsafe : If true, do not check that c1 and c2 are convertible tac : Used to prove the equality c1 = c2 gl : goal *) let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = let try_prove_eq = match try_prove_eq_opt with | None -> Proofview.tclUNIT () | Some tac -> tclCOMPLETE tac in Proofview.Goal.enter { enter = begin fun gl -> let get_type_of = pf_apply get_type_of gl in let t1 = get_type_of c1 and t2 = get_type_of c2 in let evd = if unsafe then Some (Tacmach.New.project gl) else try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Tacmach.New.project gl)) with Evarconv.UnableToUnify _ -> None in match evd with | None -> tclFAIL 0 (str"Terms do not have convertible types") | Some evd -> let e = build_coq_eq () in let sym = build_coq_eq_sym () in Tacticals.New.pf_constr_of_global sym (fun sym -> Tacticals.New.pf_constr_of_global e (fun e -> let eq = applist (e, [t1;c1;c2]) in tclTHENLAST (replace_core clause l2r eq) (tclFIRST [assumption; tclTHEN (apply sym) assumption; try_prove_eq ]))) end } let replace c1 c2 = replace_using_leibniz onConcl c2 c1 false false None let replace_by c1 c2 tac = replace_using_leibniz onConcl c2 c1 false false (Some tac) let replace_in_clause_maybe_by c1 c2 cl tac_opt = replace_using_leibniz cl c2 c1 false false tac_opt (* End of Eduardo's code. The rest of this file could be improved using the functions match_with_equation, etc that I defined in Pattern.ml. -- Eduardo (19/8/97) *) (* Tactics for equality reasoning with the "eq" relation. This code will work with any equivalence relation which is substitutive *) (* [find_positions t1 t2] will find the positions in the two terms which are suitable for discrimination, or for injection. Obviously, if there is a position which is suitable for discrimination, then we want to exploit it, and not bother with injection. So when we find a position which is suitable for discrimination, we will just raise an exception with that position. So the algorithm goes like this: if [t1] and [t2] start with the same constructor, then we can continue to try to find positions in the arguments of [t1] and [t2]. if [t1] and [t2] do not start with the same constructor, then we have found a discrimination position if one [t1] or [t2] do not start with a constructor and the two terms are not already convertible, then we have found an injection position. A discriminating position consists of a constructor-path and a pair of operators. The constructor-path tells us how to get down to the place where the two operators, which must differ, can be found. An injecting position has two terms instead of the two operators, since these terms are different, but not manifestly so. A constructor-path is a list of pairs of (operator * int), where the int (based at 0) tells us which argument of the operator we descended into. *) exception DiscrFound of (constructor * int) list * constructor * constructor let keep_proof_equalities_for_injection = ref false let _ = declare_bool_option { optsync = true; optdepr = false; optname = "injection on prop arguments"; optkey = ["Keep";"Proof";"Equalities"]; optread = (fun () -> !keep_proof_equalities_for_injection) ; optwrite = (fun b -> keep_proof_equalities_for_injection := b) } let find_positions env sigma t1 t2 = let project env sorts posn t1 t2 = let ty1 = get_type_of env sigma t1 in let s = get_sort_family_of env sigma ty1 in if Sorts.List.mem s sorts then [(List.rev posn,t1,t2)] else [] in let rec findrec sorts posn t1 t2 = let hd1,args1 = whd_all_stack env sigma t1 in let hd2,args2 = whd_all_stack env sigma t2 in match (kind_of_term hd1, kind_of_term hd2) with | Construct (sp1,_), Construct (sp2,_) when Int.equal (List.length args1) (constructor_nallargs_env env sp1) -> let sorts' = Sorts.List.intersect sorts (allowed_sorts env (fst sp1)) in (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) if eq_constructor sp1 sp2 then let nrealargs = constructor_nrealargs_env env sp1 in let rargs1 = List.lastn nrealargs args1 in let rargs2 = List.lastn nrealargs args2 in List.flatten (List.map2_i (fun i -> findrec sorts' ((sp1,i)::posn)) 0 rargs1 rargs2) else if Sorts.List.mem InType sorts' then (* see build_discriminator *) raise (DiscrFound (List.rev posn,sp1,sp2)) else (* if we cannot eliminate to Type, we cannot discriminate but we may still try to project *) project env sorts posn (applist (hd1,args1)) (applist (hd2,args2)) | _ -> let t1_0 = applist (hd1,args1) and t2_0 = applist (hd2,args2) in if is_conv env sigma t1_0 t2_0 then [] else project env sorts posn t1_0 t2_0 in try let sorts = if !keep_proof_equalities_for_injection then [InSet;InType;InProp] else [InSet;InType] in Inr (findrec sorts [] t1 t2) with DiscrFound (path,c1,c2) -> Inl (path,c1,c2) let discriminable env sigma t1 t2 = match find_positions env sigma t1 t2 with | Inl _ -> true | _ -> false let injectable env sigma t1 t2 = match find_positions env sigma t1 t2 with | Inl _ | Inr [] | Inr [([],_,_)] -> false | Inr _ -> true (* Once we have found a position, we need to project down to it. If we are discriminating, then we need to produce False on one of the branches of the discriminator, and True on the other one. So the result type of the case-expressions is always Prop. If we are injecting, then we need to discover the result-type. This can be difficult, since the type of the two terms at the injection-position can be different, and we need to find a dependent sigma-type which generalizes them both. We can get an approximation to the right type to choose by: (0) Before beginning, we reserve a patvar for the default value of the match, to be used in all the bogus branches. (1) perform the case-splits, down to the site of the injection. At each step, we have a term which is the "head" of the next case-split. At the point when we actually reach the end of our path, the "head" is the term to return. We compute its type, and then, backwards, make a sigma-type with every free debruijn reference in that type. We can be finer, and first do a S(TRONG)NF on the type, so that we get the fewest number of references possible. (2) This gives us a closed type for the head, which we use for the types of all the case-splits. (3) Now, we can compute the type of one of T1, T2, and then unify it with the type of the last component of the result-type, and this will give us the bindings for the other arguments of the tuple. *) (* The algorithm, then is to perform successive case-splits. We have the result-type of the case-split, and also the type of that result-type. We have a "direction" we want to follow, i.e. a constructor-number, and in all other "directions", we want to juse use the default-value. After doing the case-split, we call the afterfun, with the updated environment, to produce the term for the desired "direction". The assumption is made here that the result-type is not manifestly functional, so we can just use the length of the branch-type to know how many lambda's to stick in. *) (* [descend_then env sigma head dirn] returns the number of products introduced, and the environment which is active, in the body of the case-branch given by [dirn], along with a continuation, which expects to be fed: (1) the value of the body of the branch given by [dirn] (2) the default-value (3) the type of the default-value, which must also be the type of the body of the [dirn] branch the continuation then constructs the case-split. *) let descend_then env sigma head dirn = let IndType (indf,_) = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> error "Cannot project on an inductive type derived from a dependency." in let indp,_ = (dest_ind_family indf) in let ind, _ = check_privacy env indp in let (mib,mip) = lookup_mind_specif env ind in let cstr = get_constructors env indf in let dirn_nlams = cstr.(dirn-1).cs_nargs in let dirn_env = push_rel_context cstr.(dirn-1).cs_args env in (dirn_nlams, dirn_env, (fun dirnval (dfltval,resty) -> let deparsign = make_arity_signature env true indf in let p = it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in let build_branch i = let result = if Int.equal i dirn then dirnval else dfltval in it_mkLambda_or_LetIn_name env result cstr.(i-1).cs_args in let brl = List.map build_branch (List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in Inductiveops.make_case_or_project env indf ci p head (Array.of_list brl))) (* Now we need to construct the discriminator, given a discriminable position. This boils down to: (1) If the position is directly beneath us, then we need to do a case-split, with result-type Prop, and stick True and False into the branches, as is convenient. (2) If the position is not directly beneath us, then we need to call descend_then, to descend one step, and then recursively construct the discriminator. *) (* [construct_discriminator env sigma dirn c ind special default]] constructs a case-split on [c] of type [ind], with the [dirn]-th branch giving [special], and all the rest giving [default]. *) let build_selector env sigma dirn c ind special default = let IndType(indf,_) = try find_rectype env sigma ind with Not_found -> (* one can find Rel(k) in case of dependent constructors like T := c : (A:Set)A->T and a discrimination on (c bool true) = (c bool false) CP : changed assert false in a more informative error *) errorlabstrm "Equality.construct_discriminator" (str "Cannot discriminate on inductive constructors with \ dependent types.") in let (indp,_) = dest_ind_family indf in let ind, _ = check_privacy env indp in let typ = Retyping.get_type_of env sigma default in let (mib,mip) = lookup_mind_specif env ind in let deparsign = make_arity_signature env true indf in let p = it_mkLambda_or_LetIn typ deparsign in let cstrs = get_constructors env indf in let build_branch i = let endpt = if Int.equal i dirn then special else default in it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args in let brl = List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in mkCase (ci, p, c, Array.of_list brl) let rec build_discriminator env sigma dirn c = function | [] -> let ind = get_type_of env sigma c in let true_0,false_0 = build_coq_True(),build_coq_False() in build_selector env sigma dirn c ind true_0 false_0 | ((sp,cnum),argnum)::l -> let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in let subval = build_discriminator cnum_env sigma dirn newc l in kont subval (build_coq_False (),mkSort (Prop Null)) (* Note: discrimination could be more clever: if some elimination is not allowed because of a large impredicative constructor in the path (see allowed_sorts in find_positions), the positions could still be discrimated by projecting first instead of putting the discrimination combinator inside the projecting combinator. Example of relevant situation: Inductive t:Set := c : forall A:Set, A -> nat -> t. Goal ~ c _ 0 0 = c _ 0 1. intro. discriminate H. *) let gen_absurdity id = Proofview.Goal.enter { enter = begin fun gl -> let hyp_typ = pf_get_hyp_typ id (Proofview.Goal.assume gl) in let hyp_typ = pf_nf_evar gl hyp_typ in if is_empty_type hyp_typ then simplest_elim (mkVar id) else tclZEROMSG (str "Not the negation of an equality.") end } (* Precondition: eq is leibniz equality returns ((eq_elim t t1 P i t2), absurd_term) where P=[e:t]discriminator absurd_term=False *) let ind_scheme_of_eq lbeq = let (mib,mip) = Global.lookup_inductive (destIndRef lbeq.eq) in let kind = inductive_sort_family mip in (* use ind rather than case by compatibility *) let kind = if kind == InProp then Elimschemes.ind_scheme_kind_from_prop else Elimschemes.ind_scheme_kind_from_type in let c, eff = find_scheme kind (destIndRef lbeq.eq) in ConstRef c, eff let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq = let i = build_coq_I () in let absurd_term = build_coq_False () in let eq_elim, eff = ind_scheme_of_eq lbeq in let sigma, eq_elim = Evd.fresh_global (Global.env ()) sigma eq_elim in sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), eff let eq_baseid = Id.of_string "e" let apply_on_clause (f,t) clause = let sigma = clause.evd in let f_clause = mk_clenv_from_env clause.env sigma None (f,t) in let argmv = (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with | Meta mv -> mv | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in clenv_fchain ~with_univs:false argmv f_clause clause let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in let discriminator = build_discriminator e_env sigma dirn (mkVar e) cpath in let sigma,(pf, absurd_term), eff = discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in let pf_ty = mkArrow eqn absurd_term in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in let pf = Clenvtac.clenv_value_cast_meta absurd_clause in Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS eff <*> tclTHENS (assert_after Anonymous absurd_term) [onLastHypId gen_absurdity; (Proofview.V82.tactic (Tacmach.refine pf))] let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in match find_positions env sigma t1 t2 with | Inr _ -> tclZEROMSG (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> discr_positions env sigma u eq_clause cpath dirn end } let onEquality with_evars tac (c,lbindc) = Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of = pf_unsafe_type_of gl in let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in let t = type_of c in let t' = try snd (reduce_to_quantified_ind t) with UserError _ -> t in let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in let eq_clause' = Clenvtac.clenv_pose_dependent_evars with_evars eq_clause in let eqn = clenv_type eq_clause' in let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in tclTHEN (Proofview.Unsafe.tclEVARS eq_clause'.evd) (tac (eq,eqn,eq_args) eq_clause') end } let onNegatedEquality with_evars tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let ccl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in match kind_of_term (hnf_constr env sigma ccl) with | Prod (_,t,u) when is_empty_type u -> tclTHEN introf (onLastHypId (fun id -> onEquality with_evars tac (mkVar id,NoBindings))) | _ -> tclZEROMSG (str "Not a negated primitive equality.") end } let discrSimpleClause with_evars = function | None -> onNegatedEquality with_evars discrEq | Some id -> onEquality with_evars discrEq (mkVar id,NoBindings) let discr with_evars = onEquality with_evars discrEq let discrClause with_evars = onClause (discrSimpleClause with_evars) let discrEverywhere with_evars = (* tclORELSE *) (if discr_do_intro () then (tclTHEN (tclREPEAT introf) (tryAllHyps (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings))))) else (* <= 8.2 compat *) tryAllHypsAndConcl (discrSimpleClause with_evars)) (* (fun gls -> errorlabstrm "DiscrEverywhere" (str"No discriminable equalities.")) *) let discr_tac with_evars = function | None -> discrEverywhere with_evars | Some c -> onInductionArg (fun clear_flag -> discr with_evars) c let discrConcl = discrClause false onConcl let discrHyp id = discrClause false (onHyp id) (* returns the sigma type (sigS, sigT) with the respective constructor depending on the sort *) (* J.F.: correction du bug #1167 en accord avec Hugo. *) let find_sigma_data env s = build_sigma_type () (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser index bound in [rty] Then we build the term [(existT A P (mkRel lind) rterm)] of type [(sigS A P)] where [A] is the type of [mkRel lind] and [P] is [\na:A.rty{1/lind}] *) let make_tuple env sigma (rterm,rty) lind = assert (dependent (mkRel lind) rty); let sigdata = find_sigma_data env (get_sort_of env sigma rty) in let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in let na = Context.Rel.Declaration.get_name (lookup_rel lind env) in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in (* Now [lind] is [mkRel 1] and we abstract on (na:a) *) let p = mkLambda (na, a, rty) in let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in let sigma, sig_term = Evd.fresh_global env sigma sigdata.typ in sigma, (applist(exist_term,[a;p;(mkRel lind);rterm]), applist(sig_term,[a;p])) (* check that the free-references of the type of [c] are contained in the free-references of the normal-form of that type. Strictly computing the exact set of free rels would require full normalization but this is not reasonable (e.g. in presence of records that contains proofs). We restrict ourself to a "simpl" normalization *) let minimal_free_rels env sigma (c,cty) = let cty_rels = free_rels cty in let cty' = simpl env sigma cty in let rels' = free_rels cty' in if Int.Set.subset cty_rels rels' then (cty,cty_rels) else (cty',rels') (* Like the above, but recurse over all the rels found until there are no more rels to be found *) let minimal_free_rels_rec env sigma = let rec minimalrec_free_rels_rec prev_rels (c,cty) = let (cty,direct_rels) = minimal_free_rels env sigma (c,cty) in let combined_rels = Int.Set.union prev_rels direct_rels in let folder rels i = snd (minimalrec_free_rels_rec rels (c, unsafe_type_of env sigma (mkRel i))) in (cty, List.fold_left folder combined_rels (Int.Set.elements (Int.Set.diff direct_rels prev_rels))) in minimalrec_free_rels_rec Int.Set.empty (* [sig_clausal_form siglen ty] Will explode [siglen] [sigS,sigT ]'s on [ty] (depending on the type of ty), and return: (1) a pattern, with meta-variables in it for various arguments, which, when the metavariables are replaced with appropriate terms, will have type [ty] (2) an integer, which is the last argument - the one which we just returned. (3) a pattern, for the type of that last meta (4) a typing for each patvar WARNING: No checking is done to make sure that the sigS(or sigT)'s are actually there. - Only homogeneous pairs are built i.e. pairs where all the dependencies are of the same sort [sig_clausal_form] proceed as follows: the default tuple is constructed by taking the tuple-type, exploding the first [tuplen] [sigS]'s, and replacing at each step the binder in the right-hand-type by a fresh metavariable. In addition, on the way back out, we will construct the pattern for the tuple which uses these meta-vars. This gives us a pattern, which we use to match against the type of [dflt]; if that fails, then against the S(TRONG)NF of that type. If both fail, then we just cannot construct our tuple. If one of those succeed, then we can construct our value easily - we just use the tuple-pattern. *) let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let sigdata = find_sigma_data env sort_of_ty in let evdref = ref (Evd.clear_metas sigma) in let rec sigrec_clausal_form siglen p_i = if Int.equal siglen 0 then (* is the default value typable with the expected type *) let dflt_typ = unsafe_type_of env sigma dflt in try let () = evdref := Evarconv.the_conv_x_leq env dflt_typ p_i !evdref in let () = evdref := Evarconv.solve_unif_constraints_with_heuristics env !evdref in dflt with Evarconv.UnableToUnify _ -> error "Cannot solve a unification problem." else let (a,p_i_minus_1) = match whd_beta_stack !evdref p_i with | (_sigS,[a;p]) -> (a,p) | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type") in let ev = Evarutil.e_new_evar env evdref a in let rty = beta_applist(p_i_minus_1,[ev]) in let tuple_tail = sigrec_clausal_form (siglen-1) rty in match Evd.existential_opt_value !evdref (destEvar ev) with | Some w -> let w_type = unsafe_type_of env sigma w in if Evarconv.e_cumul env evdref w_type a then let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) else error "Cannot solve a unification problem." | None -> (* This at least happens if what has been detected as a dependency is not one; use an evasive error message; even if the problem is upwards: unification should be tried in the first place in make_iterated_tuple instead of approximatively computing the free rels; then unsolved evars would mean not binding rel *) error "Cannot solve a unification problem." in let scf = sigrec_clausal_form siglen ty in !evdref, Evarutil.nf_evar !evdref scf (* The problem is to build a destructor (a generalization of the predecessor) which, when applied to a term made of constructors (say [Ci(e1,Cj(e2,Ck(...,term,...),...),...)]), returns a given subterm of the term (say [term]). Let [typ] be the type of [term]. If [term] has no dependencies in the [e1], [e2], etc, then all is simple. If not, then we need to encapsulated the dependencies into a dependent tuple in such a way that the destructor has not a dependent type and rewriting can then be applied. The destructor has the form [e]Cases e of | ... | Ci (x1,x2,...) => Cases x2 of | ... | Cj (y1,y2,...) => Cases y2 of | ... | Ck (...,z,...) => z | ... end | ... end | ... end and the dependencies is expressed by the fact that [z] has a type dependent in the x1, y1, ... Assume [z] is typed as follows: env |- z:zty If [zty] has no dependencies, this is simple. Otherwise, assume [zty] has free (de Bruijn) variables in,...i1 then the role of [make_iterated_tuple env sigma (term,typ) (z,zty)] is to build the tuple [existT [xn]Pn Rel(in) .. (existT [x2]P2 Rel(i2) (existT [x1]P1 Rel(i1) z))] where P1 is zty[i1/x1], P2 is {x1 | P1[i2/x2]} etc. To do this, we find the free (relative) references of the strong NF of [z]'s type, gather them together in left-to-right order (i.e. highest-numbered is farthest-left), and construct a big iterated pair out of it. This only works when the references are all themselves to members of [Set]s, because we use [sigS] to construct the tuple. Suppose now that our constructed tuple is of length [tuplen]. We need also to construct a default value for the other branches of the destructor. As default value, we take a tuple of the form [existT [xn]Pn ?n (... existT [x2]P2 ?2 (existT [x1]P1 ?1 term))] but for this we have to solve the following unification problem: typ = zty[i1/?1;...;in/?n] This is done by [sig_clausal_form]. *) let make_iterated_tuple env sigma dflt (z,zty) = let (zty,rels) = minimal_free_rels_rec env sigma (z,zty) in let sort_of_zty = get_sort_of env sigma zty in let sorted_rels = Int.Set.elements rels in let sigma, (tuple,tuplety) = List.fold_left (fun (sigma, t) -> make_tuple env sigma t) (sigma, (z,zty)) sorted_rels in assert (closed0 tuplety); let n = List.length sorted_rels in let sigma, dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in sigma, (tuple,tuplety,dfltval) let rec build_injrec env sigma dflt c = function | [] -> make_iterated_tuple env sigma dflt (c,unsafe_type_of env sigma c) | ((sp,cnum),argnum)::l -> try let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in let sigma, (subval,tuplety,dfltval) = build_injrec cnum_env sigma dflt newc l in sigma, (kont subval (dfltval,tuplety), tuplety,dfltval) with UserError _ -> failwith "caught" let build_injector env sigma dflt c cpath = let sigma, (injcode,resty,_) = build_injrec env sigma dflt c cpath in sigma, (injcode,resty) (* let try_delta_expand env sigma t = let whdt = whd_all env sigma t in let rec hd_rec c = match kind_of_term c with | Construct _ -> whdt | App (f,_) -> hd_rec f | Cast (c,_,_) -> hd_rec c | _ -> t in hd_rec whdt *) let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined") let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k) let inject_if_homogenous_dependent_pair ty = Proofview.Goal.nf_enter { enter = begin fun gl -> try let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in (* fetch the informations of the pair *) let ceq = Universes.constr_of_global Coqlib.glob_eq in let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in let existTconstr () = (Coqlib.build_sigma_type()).Coqlib.intro in (* check whether the equality deals with dep pairs or not *) let eqTypeDest = fst (decompose_app t) in if not (Globnames.is_global (sigTconstr()) eqTypeDest) then raise Exit; let hd1,ar1 = decompose_app_vect t1 and hd2,ar2 = decompose_app_vect t2 in if not (Globnames.is_global (existTconstr()) hd1) then raise Exit; if not (Globnames.is_global (existTconstr()) hd2) then raise Exit; let ind,_ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in (* check if the user has declared the dec principle *) (* and compare the fst arguments of the dep pair *) (* Note: should work even if not an inductive type, but the table only *) (* knows inductive types *) if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind) && pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit; Coqlib.check_required_library ["Coq";"Logic";"Eqdep_dec"]; let new_eq_args = [|pf_unsafe_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in let c, eff = find_scheme (!eq_dec_scheme_kind_name()) (Univ.out_punivs ind) in (* cut with the good equality and prove the requested goal *) tclTHENLIST [Proofview.tclEFFECTS eff; intro; onLastHyp (fun hyp -> tclTHENS (cut (mkApp (ceq,new_eq_args))) [clear [destVar hyp]; Proofview.V82.tactic (Tacmach.refine (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|]))) ])] with Exit -> Proofview.tclUNIT () end } (* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it expands then only when the whdnf has a constructor of an inductive type in hd position, otherwise delta expansion is not done *) let simplify_args env sigma t = (* Quick hack to reduce in arguments of eq only *) match decompose_app t with | eq, [t;c1;c2] -> applist (eq,[t;simpl env sigma c1;simpl env sigma c2]) | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma c1;t2;simpl env sigma c2]) | _ -> t let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (LocalAssum (e,t)) env in let evdref = ref sigma in let filter (cpath, t1', t2') = try (* arbitrarily take t1' as the injector default value *) let sigma, (injbody,resty) = build_injector e_env !evdref t1' (mkVar e) cpath in let injfun = mkNamedLambda e t injbody in let sigma,congr = Evd.fresh_global env sigma eq.congr in let pf = applist(congr,[t;resty;injfun;t1;t2]) in let sigma, pf_typ = Typing.type_of env sigma pf in let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in let pf = Clenvtac.clenv_value_cast_meta inj_clause in let ty = simplify_args env sigma (clenv_type inj_clause) in evdref := sigma; Some (pf, ty) with Failure _ -> None in let injectors = List.map_filter filter posns in if List.is_empty injectors then tclZEROMSG (str "Failed to decompose the equality.") else Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Tacticals.New.tclTHENFIRST (Proofview.tclIGNORE (Proofview.Monad.List.map (fun (pf,ty) -> tclTHENS (cut ty) [inject_if_homogenous_dependent_pair ty; Proofview.V82.tactic (Tacmach.refine pf)]) (if l2r then List.rev injectors else injectors))) (tac (List.length injectors))) let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in let env = eq_clause.env in match find_positions env sigma t1 t2 with | Inl _ -> tclZEROMSG (strbrk"This equality is discriminable. You should use the discriminate tactic to solve the goal.") | Inr [] -> let suggestion = if !keep_proof_equalities_for_injection then "" else " You can try to use option Set Keep Proof Equalities." in tclZEROMSG (strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion)) | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 -> tclZEROMSG (str"Nothing to inject.") | Inr posns -> inject_at_positions env sigma l2r u eq_clause posns (tac (clenv_value eq_clause)) let get_previous_hyp_position id gl = let rec aux dest = function | [] -> raise (RefinerError (NoSuchHyp id)) | d :: right -> let hyp = Context.Named.Declaration.get_id d in if Id.equal hyp id then dest else aux (MoveAfter hyp) right in aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let injEq ?(old=false) with_evars clear_flag ipats = (* Decide which compatibility mode to use *) let ipats_style, l2r, dft_clear_flag, bounded_intro = match ipats with | None when not old && use_injection_in_context () -> Some [], true, true, true | None -> None, false, false, false | _ -> let b = use_injection_pattern_l2r_order () in ipats, b, b, b in (* Built the post tactic depending on compatibility mode *) let post_tac c n = match ipats_style with | Some ipats -> Proofview.Goal.enter { enter = begin fun gl -> let destopt = match kind_of_term c with | Var id -> get_previous_hyp_position id gl | _ -> MoveLast in let clear_tac = tclTRY (apply_clear_request clear_flag dft_clear_flag c) in (* Try should be removal if dependency were treated *) let intro_tac = if bounded_intro then intro_patterns_bound_to with_evars n destopt ipats else intro_patterns_to with_evars destopt ipats in tclTHEN clear_tac intro_tac end } | None -> tclIDTAC in injEqThen post_tac l2r let inj ipats with_evars clear_flag = onEquality with_evars (injEq with_evars clear_flag ipats) let injClause ipats with_evars = function | None -> onNegatedEquality with_evars (injEq with_evars None ipats) | Some c -> onInductionArg (inj ipats with_evars) c let simpleInjClause with_evars = function | None -> onNegatedEquality with_evars (injEq ~old:true with_evars None None) | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (injEq ~old:true with_evars clear_flag None)) c let injConcl = injClause None false None let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.ghost,id))) let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = clause.evd in let env = Proofview.Goal.env gl in match find_positions env sigma t1 t2 with | Inl (cpath, (_,dirn), _) -> discr_positions env sigma u clause cpath dirn | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) ntac (clenv_value clause) 0 | Inr posns -> inject_at_positions env sigma true u clause posns (ntac (clenv_value clause)) end } let dEqThen with_evars ntac = function | None -> onNegatedEquality with_evars (decompEqThen (ntac None)) | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (decompEqThen (ntac clear_flag))) c let dEq with_evars = dEqThen with_evars (fun clear_flag c x -> (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) let intro_decomp_eq tac data cl = Proofview.Goal.enter { enter = begin fun gl -> let cl = pf_apply make_clenv_binding gl cl NoBindings in decompEqThen (fun _ -> tac) data cl end } let _ = declare_intro_decomp_eq intro_decomp_eq (* [subst_tuple_term dep_pair B] Given that dep_pair looks like: (existT e1 (existT e2 ... (existT en en+1) ... )) of type {x1:T1 & {x2:T2(x1) & ... {xn:Tn(x1..xn-1) & en+1 } } } and B might contain instances of the ei, we will return the term: ([x1:ty1]...[xn+1:tyn+1]B (projT1 (mkRel 1)) (projT1 (projT2 (mkRel 1))) ... (projT1 (projT2^n (mkRel 1))) (projT2 (projT2^n (mkRel 1))) That is, we will abstract out the terms e1...en+1 of types t1 (=_beta T1), ..., tn+1 (=_beta Tn+1(e1..en)) as usual, but will then produce a term in which the abstraction is on a single term - the debruijn index [mkRel 1], which will be of the same type as dep_pair (note that the abstracted body may not be typable!). ALGORITHM for abstraction: We have a list of terms, [e1]...[en+1], which we want to abstract out of [B]. For each term [ei], going backwards from [n+1], we just do a [subst_term], and then do a lambda-abstraction to the type of the [ei]. *) let decomp_tuple_term env c t = let rec decomprec inner_code ex exty = let iterated_decomp = try let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose ex in let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code]) and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in let cdrtyp = beta_applist (p,[car]) in List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp) with Constr_matching.PatternMatchingFailure -> [] in [((ex,exty),inner_code)]::iterated_decomp in decomprec (mkRel 1) c t let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let sigma = Sigma.to_evar_map sigma in let typ = get_type_of env sigma dep_pair1 in (* We find all possible decompositions *) let decomps1 = decomp_tuple_term env dep_pair1 typ in let decomps2 = decomp_tuple_term env dep_pair2 typ in (* We adjust to the shortest decomposition *) let n = min (List.length decomps1) (List.length decomps2) in let decomp1 = List.nth decomps1 (n-1) in let decomp2 = List.nth decomps2 (n-1) in (* We rewrite dep_pair1 ... *) let e1_list,proj_list = List.split decomp1 in (* ... and use dep_pair2 to compute the expected goal *) let e2_list,_ = List.split decomp2 in (* We build the expected goal *) let abst_B = List.fold_right (fun (e,t) body -> lambda_create env (t,subst_term e body)) e1_list b in let pred_body = beta_applist(abst_B,proj_list) in let body = mkApp (lambda_create env (typ,pred_body),[|dep_pair1|]) in let expected_goal = beta_applist (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) let expected_goal = nf_betaiota sigma expected_goal in (* Retype to get universes right *) let sigma, expected_goal_ty = Typing.type_of env sigma expected_goal in let sigma, _ = Typing.type_of env sigma body in Sigma.Unsafe.of_pair ((body, expected_goal), sigma) (* Like "replace" but decompose dependent equalities *) (* i.e. if equality is "exists t v = exists u w", and goal is "phi(t,u)", *) (* then it uses the predicate "\x.phi(proj1_sig x,proj2_sig x)", and so *) (* on for further iterated sigma-tuples *) let cutSubstInConcl l2r eqn = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_concl gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in let tac = tclTHENFIRST (tclTHENLIST [ (change_concl typ); (* Put in pattern form *) (replace_core onConcl l2r eqn) ]) (change_concl expected) (* Put in normalized form *) in Sigma (tac, sigma, p) end } let cutSubstInHyp l2r eqn id = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_get_hyp_typ id gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in let tac = tclTHENFIRST (tclTHENLIST [ (change_in_hyp None (make_change_arg typ) (id,InHypTypeOnly)); (replace_core (onHyp id) l2r eqn) ]) (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly)) in Sigma (tac, sigma, p) end } let try_rewrite tac = Proofview.tclORELSE tac begin function (e, info) -> match e with | Constr_matching.PatternMatchingFailure -> tclZEROMSG (str "Not a primitive equality here.") | e when catchable_exception e -> tclZEROMSG (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.") | e -> Proofview.tclZERO ~info e end let cutSubstClause l2r eqn cls = match cls with | None -> cutSubstInConcl l2r eqn | Some id -> cutSubstInHyp l2r eqn id let cutRewriteClause l2r eqn cls = try_rewrite (cutSubstClause l2r eqn cls) let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id) let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None let substClause l2r c cls = Proofview.Goal.enter { enter = begin fun gl -> let eq = pf_apply get_type_of gl c in tclTHENS (cutSubstClause l2r eq cls) [Proofview.tclUNIT (); exact_no_check c] end } let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls) let rewriteInHyp l2r c id = rewriteClause l2r c (Some id) let rewriteInConcl l2r c = rewriteClause l2r c None (* Naming scheme for rewrite and cutrewrite tactics give equality give proof of equality / cutSubstClause substClause raw | cutSubstInHyp substInHyp \ cutSubstInConcl substInConcl / cutRewriteClause rewriteClause user| cutRewriteInHyp rewriteInHyp \ cutRewriteInConcl rewriteInConcl raw = raise typing error or PatternMatchingFailure user = raise user error specific to rewrite *) (**********************************************************************) (* Substitutions tactics (JCF) *) let regular_subst_tactic = ref true let _ = declare_bool_option { optsync = true; optdepr = false; optname = "more regular behavior of tactic subst"; optkey = ["Regular";"Subst";"Tactic"]; optread = (fun () -> !regular_subst_tactic); optwrite = (:=) regular_subst_tactic } let restrict_to_eq_and_identity eq = (* compatibility *) if not (is_global glob_eq eq) && not (is_global glob_identity eq) then raise Constr_matching.PatternMatchingFailure exception FoundHyp of (Id.t * constr * bool) (* tests whether hyp [c] is [x = t] or [t = x], [x] not occurring in [t] *) let is_eq_x gl x d = let id = get_id d in try let is_var id c = match kind_of_term c with | Var id' -> Id.equal id id' | _ -> false in let c = pf_nf_evar gl (get_type d) in let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in if (is_var x lhs) && not (local_occur_var x rhs) then raise (FoundHyp (id,rhs,true)); if (is_var x rhs) && not (local_occur_var x lhs) then raise (FoundHyp (id,lhs,false)) with Constr_matching.PatternMatchingFailure -> () (* Rewrite "hyp:x=rhs" or "hyp:rhs=x" (if dir=false) everywhere and erase hyp and x; proceed by generalizing all dep hyps *) let subst_one dep_proof_ok x (hyp,rhs,dir) = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in (* The set of hypotheses using x *) let dephyps = List.rev (pi3 (List.fold_right (fun dcl (dest,deps,allhyps) -> let id = get_id dcl in if not (Id.equal id hyp) && List.exists (fun y -> occur_var_in_decl env y dcl) deps then let id_dest = if !regular_subst_tactic then dest else MoveLast in (dest,id::deps,(id_dest,id)::allhyps) else (MoveBefore id,deps,allhyps)) hyps (MoveBefore x,[x],[]))) in (* In practice, no dep hyps before x, so MoveBefore x is good enough *) (* Decides if x appears in conclusion *) let depconcl = occur_var env x concl in let need_rewrite = not (List.is_empty dephyps) || depconcl in tclTHENLIST ((if need_rewrite then [revert (List.map snd dephyps); general_rewrite dir AllOccurrences true dep_proof_ok (mkVar hyp); (tclMAP (fun (dest,id) -> intro_move (Some id) dest) dephyps)] else [Proofview.tclUNIT ()]) @ [tclTRY (clear [x; hyp])]) end } (* Look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *) let subst_one_var dep_proof_ok x = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let xval = pf_get_hyp x gl |> get_value in (* If x has a body, simply replace x with body and clear x *) if not (Option.is_empty xval) then tclTHEN (unfold_body x) (clear [x]) else (* Find a non-recursive definition for x *) let res = try (** [is_eq_x] ensures nf_evar on its side *) let hyps = Proofview.Goal.hyps gl in let test hyp _ = is_eq_x gl x hyp in Context.Named.fold_outside test ~init:() hyps; errorlabstrm "Subst" (str "Cannot find any non-recursive equality over " ++ pr_id x ++ str".") with FoundHyp res -> res in subst_one dep_proof_ok x res end } let subst_gen dep_proof_ok ids = tclMAP (subst_one_var dep_proof_ok) ids (* For every x, look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *) let subst = subst_gen true type subst_tactic_flags = { only_leibniz : bool; rewrite_dependent_proof : bool } let default_subst_tactic_flags () = if Flags.version_strictly_greater Flags.V8_2 then { only_leibniz = false; rewrite_dependent_proof = true } else { only_leibniz = true; rewrite_dependent_proof = false } let subst_all ?(flags=default_subst_tactic_flags ()) () = if !regular_subst_tactic then (* First step: find hypotheses to treat in linear time *) let find_equations gl = let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in let select_equation_name decl = try let lbeq,u,(_,x,y) = find_eq_data_decompose (get_type decl) in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match kind_of_term x, kind_of_term y with | Var z, _ when not (is_evaluable env (EvalVarRef z)) -> Some (get_id decl) | _, Var z when not (is_evaluable env (EvalVarRef z)) -> Some (get_id decl) | _ -> None with Constr_matching.PatternMatchingFailure -> None in let hyps = Proofview.Goal.hyps gl in List.rev (List.map_filter select_equation_name hyps) in (* Second step: treat equations *) let process hyp = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in let c = pf_get_hyp hyp gl |> get_type in let _,_,(_,x,y) = find_eq_data_decompose c in (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if Term.eq_constr x y then Proofview.tclUNIT () else match kind_of_term x, kind_of_term y with | Var x', _ when not (occur_term x y) && not (is_evaluable env (EvalVarRef x')) -> subst_one flags.rewrite_dependent_proof x' (hyp,y,true) | _, Var y' when not (occur_term y x) && not (is_evaluable env (EvalVarRef y')) -> subst_one flags.rewrite_dependent_proof y' (hyp,x,false) | _ -> Proofview.tclUNIT () end } in Proofview.Goal.nf_enter { enter = begin fun gl -> let ids = find_equations gl in tclMAP process ids end } else (* Old implementation, not able to manage configurations like a=b, a=t, or situations like "a = S b, b = S a", or also accidentally unfolding let-ins *) Proofview.Goal.nf_enter { enter = begin fun gl -> let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = try let lbeq,u,(_,x,y) = find_eq_data_decompose c in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if Term.eq_constr x y then failwith "caught"; match kind_of_term x with Var x -> x | _ -> match kind_of_term y with Var y -> y | _ -> failwith "caught" with Constr_matching.PatternMatchingFailure -> failwith "caught" in let test p = try Some (test p) with Failure _ -> None in let hyps = pf_hyps_types gl in let ids = List.map_filter test hyps in let ids = List.uniquize ids in subst_gen flags.rewrite_dependent_proof ids end } (* Rewrite the first assumption for which a condition holds and gives the direction of the rewrite *) let cond_eq_term_left c t gl = try let (_,x,_) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term_right c t gl = try let (_,_,x) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then false else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term c t gl = try let (_,x,y) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else if pf_conv_x gl c y then false else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let rewrite_assumption_cond cond_eq_term cl = let rec arec hyps gl = match hyps with | [] -> error "No such assumption." | hyp ::rest -> let id = get_id hyp in begin try let dir = cond_eq_term (get_type hyp) gl in general_rewrite_clause dir false (mkVar id,NoBindings) cl with | Failure _ | UserError _ -> arec rest gl end in Proofview.Goal.nf_enter { enter = begin fun gl -> let gl = Proofview.Goal.lift gl Sigma.Unsafe.le in let hyps = Proofview.Goal.hyps gl in arec hyps gl end } (* Generalize "subst x" to substitution of subterm appearing as an equation in the context, but not clearing the hypothesis *) let replace_term dir_opt c = let cond_eq_fun = match dir_opt with | None -> cond_eq_term c | Some true -> cond_eq_term_left c | Some false -> cond_eq_term_right c in rewrite_assumption_cond cond_eq_fun (* Declare rewriting tactic for intro patterns "<-" and "->" *) let _ = let gmr l2r with_evars tac c = general_rewrite_clause l2r with_evars tac c in Hook.set Tactics.general_rewrite_clause gmr let _ = Hook.set Tactics.subst_one subst_one coq-8.6/tactics/dn.mli0000644000175000017500000000221613022274260014216 0ustar mdenesmdenestype 'res lookup_res = Label of 'res | Nothing | Everything module Make : functor (Y : Map.OrderedType) -> functor (Z : Map.OrderedType) -> sig type 'a decompose_fun = 'a -> (Y.t * 'a list) option type t val empty : t (** [add t f (tree,inf)] adds a structured object [tree] together with the associated information [inf] to the table [t]; the function [f] is used to translated [tree] into its prefix decomposition: [f] must decompose any tree into a label characterizing its root node and the list of its subtree *) val add : t -> 'a decompose_fun -> 'a * Z.t -> t val rmv : t -> 'a decompose_fun -> 'a * Z.t -> t type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res (** [lookup t f tree] looks for trees (and their associated information) in table [t] such that the structured object [tree] matches against them; [f] is used to translated [tree] into its prefix decomposition: [f] must decompose any tree into a label characterizing its root node and the list of its subtree *) val lookup : t -> 'term lookup_fun -> 'term -> Z.t list val app : (Z.t -> unit) -> t -> unit end coq-8.6/tactics/auto.ml0000644000175000017500000004661313022274260014425 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Int.equal hint.pri 0) l let compute_secvars gl = let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in secvars_of_hyps hyps (* tell auto not to reuse already instantiated metas in unification (for compatibility, since otherwise, apply succeeds oftener) *) open Unification let auto_core_unif_flags_of st1 st2 useeager = { modulo_conv_on_closed_terms = Some st1; use_metas_eagerly_in_conv_on_closed_terms = useeager; use_evars_eagerly_in_conv_on_closed_terms = false; modulo_delta = st2; modulo_delta_types = full_transparent_state; check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; frozen_evars = Evar.Set.empty; restrict_conv_on_strict_subterms = false; (* Compat *) modulo_betaiota = false; modulo_eta = true; } let auto_unif_flags_of st1 st2 useeager = let flags = auto_core_unif_flags_of st1 st2 useeager in { core_unify_flags = flags; merge_unify_flags = flags; subterm_unify_flags = { flags with modulo_delta = empty_transparent_state }; allow_K_in_toplevel_higher_order_unification = false; resolve_evars = true } let auto_unif_flags = auto_unif_flags_of full_transparent_state empty_transparent_state false (* Try unification with the precompiled clause, then use registered Apply *) let connect_hint_clenv poly (c, _, ctx) clenv gl = (** [clenv] has been generated by a hint-making function, so the only relevant data in its evarmap is the set of metas. The [evar_reset_evd] function below just replaces the metas of sigma by those coming from the clenv. *) let sigma = Tacmach.New.project gl in let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in (** Still, we need to update the universes *) let clenv, c = if poly then (** Refresh the instance of the hint *) let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in let map c = Vars.subst_univs_level_constr subst c in let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in (** Only metas are mentioning the old universes. *) let clenv = { templval = Evd.map_fl map clenv.templval; templtyp = Evd.map_fl map clenv.templtyp; evd = Evd.map_metas map evd; env = Proofview.Goal.env gl; } in clenv, map c else let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in { clenv with evd = evd ; env = Proofview.Goal.env gl }, c in clenv, c let unify_resolve poly flags ((c : raw_hint), clenv) = Proofview.Goal.nf_enter { enter = begin fun gl -> let clenv, c = connect_hint_clenv poly c clenv gl in let clenv = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags clenv gl) gl in Clenvtac.clenv_refine false clenv end } let unify_resolve_nodelta poly h = unify_resolve poly auto_unif_flags h let unify_resolve_gen poly = function | None -> unify_resolve_nodelta poly | Some flags -> unify_resolve poly flags let exact poly (c,clenv) = Proofview.Goal.enter { enter = begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) (exact_check c) end } (* Util *) (* Serait-ce possible de compiler d'abord la tactique puis de faire la substitution sans passer par bdize dont l'objectif est de préparer un terme pour l'affichage ? (HH) *) (* Si on enlève le dernier argument (gl) conclPattern est calculé une fois pour toutes : en particulier si Pattern.somatch produit une UserError Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même si après Intros la conclusion matche le pattern. *) (* conclPattern doit échouer avec error car il est rattraper par tclFIRST *) let conclPattern concl pat tac = let constr_bindings env sigma = match pat with | None -> Proofview.tclUNIT Id.Map.empty | Some pat -> try Proofview.tclUNIT (Constr_matching.matches env sigma pat concl) with Constr_matching.PatternMatchingFailure -> Tacticals.New.tclZEROMSG (str "conclPattern") in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in constr_bindings env sigma >>= fun constr_bindings -> let open Genarg in let open Geninterp in let inj c = match val_tag (topwit Constrarg.wit_constr) with | Val.Base tag -> Val.Dyn (tag, c) | _ -> assert false in let fold id c accu = Id.Map.add id (inj c) accu in let lfun = Id.Map.fold fold constr_bindings Id.Map.empty in let ist = { lfun; extra = TacStore.empty } in match tac with | GenArg (Glbwit wit, tac) -> Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) end } (***********************************************************) (** A debugging / verbosity framework for trivial and auto *) (***********************************************************) (** The following options allow to trigger debugging/verbosity without having to adapt the scripts. Note: if Debug and Info are both activated, Debug take precedence. *) let global_debug_trivial = ref false let global_debug_auto = ref false let global_info_trivial = ref false let global_info_auto = ref false let add_option ls refe = let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = String.concat " " ls; Goptions.optkey = ls; Goptions.optread = (fun () -> !refe); Goptions.optwrite = (:=) refe } in () let _ = add_option ["Debug";"Trivial"] global_debug_trivial; add_option ["Debug";"Auto"] global_debug_auto; add_option ["Info";"Trivial"] global_info_trivial; add_option ["Info";"Auto"] global_info_auto let no_dbg () = (Off,0,ref []) let mk_trivial_dbg debug = let d = if debug == Debug || !global_debug_trivial then Debug else if debug == Info || !global_info_trivial then Info else Off in (d,0,ref []) (** Note : we start the debug depth of auto at 1 to distinguish it for trivial (whose depth is 0). *) let mk_auto_dbg debug = let d = if debug == Debug || !global_debug_auto then Debug else if debug == Info || !global_info_auto then Info else Off in (d,1,ref []) let incr_dbg = function (dbg,depth,trace) -> (dbg,depth+1,trace) (** A tracing tactic for debug/info trivial/auto *) let tclLOG (dbg,depth,trace) pp tac = match dbg with | Off -> tac | Debug -> (* For "debug (trivial/auto)", we directly output messages *) let s = String.make depth '*' in Proofview.V82.tactic begin fun gl -> try let out = Proofview.V82.of_tactic tac gl in Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); out with reraise -> let reraise = CErrors.push reraise in Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); iraise reraise end | Info -> (* For "info (trivial/auto)", we store a log trace *) Proofview.V82.tactic begin fun gl -> try let out = Proofview.V82.of_tactic tac gl in trace := (depth, Some pp) :: !trace; out with reraise -> let reraise = CErrors.push reraise in trace := (depth, None) :: !trace; iraise reraise end (** For info, from the linear trace information, we reconstitute the part of the proof tree we're interested in. The last executed tactic comes first in the trace (and it should be a successful one). [depth] is the root depth of the tree fragment we're visiting. [keep] means we're in a successful tree fragment (the very last tactic has been successful). *) let rec cleanup_info_trace depth acc = function | [] -> acc | (d,Some pp) :: l -> cleanup_info_trace d ((d,pp)::acc) l | l -> cleanup_info_trace depth acc (erase_subtree depth l) and erase_subtree depth = function | [] -> [] | (d,_) :: l -> if Int.equal d depth then l else erase_subtree depth l let pr_info_atom (d,pp) = str (String.make d ' ') ++ pp () ++ str "." let pr_info_trace = function | (Info,_,{contents=(d,Some pp)::l}) -> Feedback.msg_info (prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)) | _ -> () let pr_info_nop = function | (Info,_,_) -> Feedback.msg_info (str "idtac.") | _ -> () let pr_dbg_header = function | (Off,_,_) -> () | (Debug,0,_) -> Feedback.msg_debug (str "(* debug trivial: *)") | (Debug,_,_) -> Feedback.msg_debug (str "(* debug auto: *)") | (Info,0,_) -> Feedback.msg_info (str "(* info trivial: *)") | (Info,_,_) -> Feedback.msg_info (str "(* info auto: *)") let tclTRY_dbg d tac = let delay f = Proofview.tclUNIT () >>= fun () -> f () in let tac = delay (fun () -> pr_dbg_header d; tac) >>= fun () -> pr_info_trace d; Proofview.tclUNIT () in let after = delay (fun () -> pr_info_nop d; Proofview.tclUNIT ()) in Tacticals.New.tclORELSE0 tac after (**************************************************************************) (* The Trivial tactic *) (**************************************************************************) (* local_db is a Hint database containing the hypotheses of current goal *) (* Papageno : cette fonction a été pas mal simplifiée depuis que la base de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) let flags_of_state st = auto_unif_flags_of st st false let auto_flags_of_state st = auto_unif_flags_of full_transparent_state st false let hintmap_of secvars hdc concl = match hdc with | None -> Hint_db.map_none ~secvars | Some hdc -> if occur_existential concl then Hint_db.map_existential ~secvars hdc concl else Hint_db.map_auto ~secvars hdc concl let exists_evaluable_reference env = function | EvalConstRef _ -> true | EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false let dbg_intro dbg = tclLOG dbg (fun () -> str "intro") intro let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption let rec trivial_fail_db dbg mod_delta db_list local_db = let intro_tac = Tacticals.New.tclTHEN (dbg_intro dbg) ( Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let nf c = Evarutil.nf_evar sigma c in let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in let hyp = Context.Named.Declaration.map_constr nf decl in let hintl = make_resolve_hyp env sigma hyp in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list env sigma hintl local_db) end }) in Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in let secvars = compute_secvars gl in Tacticals.New.tclFIRST ((dbg_assumption dbg)::intro_tac:: (List.map Tacticals.New.tclCOMPLETE (trivial_resolve dbg mod_delta db_list local_db secvars concl))) end } and my_find_search_nodelta db_list local_db secvars hdc concl = List.map (fun hint -> (None,hint)) (List.map_append (hintmap_of secvars hdc concl) (local_db::db_list)) and my_find_search mod_delta = if mod_delta then my_find_search_delta else my_find_search_nodelta and my_find_search_delta db_list local_db secvars hdc concl = let f = hintmap_of secvars hdc concl in if occur_existential concl then List.map_append (fun db -> if Hint_db.use_dn db then let flags = flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (Some flags,x)) (f db) else let flags = auto_flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (Some flags,x)) (f db)) (local_db::db_list) else List.map_append (fun db -> if Hint_db.use_dn db then let flags = flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (Some flags, x)) (f db) else let (ids, csts as st) = Hint_db.transparent_state db in let flags, l = let l = match hdc with None -> Hint_db.map_none ~secvars db | Some hdc -> if (Id.Pred.is_empty ids && Cpred.is_empty csts) then Hint_db.map_auto ~secvars hdc concl db else Hint_db.map_existential ~secvars hdc concl db in auto_flags_of_state st, l in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db=dbname})) = let tactic = function | Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl) | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf") | Give_exact (c, cl) -> exact poly (c, cl) | Res_pf_THEN_trivial_fail (c,cl) -> Tacticals.New.tclTHEN (unify_resolve_gen poly flags (c,cl)) (* With "(debug) trivial", we shouldn't end here, and with "debug auto" we don't display the details of inner trivial *) (trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db) | Unfold_nth c -> Proofview.V82.tactic (fun gl -> if exists_evaluable_reference (pf_env gl) c then tclPROGRESS (Proofview.V82.of_tactic (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl)) gl else tclFAIL 0 (str"Unbound reference") gl) | Extern tacast -> conclPattern concl p tacast in let pr_hint () = let origin = match dbname with | None -> mt () | Some n -> str " (in " ++ str n ++ str ")" in pr_hint t ++ origin in tclLOG dbg pr_hint (run_hint t tactic) and trivial_resolve dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound cl in Some hdconstr with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) (priority (my_find_search mod_delta db_list local_db secvars head cl)) with Not_found -> [] (** The use of the "core" database can be de-activated by passing "nocore" amongst the databases. *) let trivial ?(debug=Off) lems dbnames = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = make_db_list dbnames in let d = mk_trivial_dbg debug in let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (trivial_fail_db d false db_list hints) end } let full_trivial ?(debug=Off) lems = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = current_pure_db () in let d = mk_trivial_dbg debug in let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (trivial_fail_db d false db_list hints) end } let gen_trivial ?(debug=Off) lems = function | None -> full_trivial ~debug lems | Some l -> trivial ~debug lems l let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l (**************************************************************************) (* The classical Auto tactic *) (**************************************************************************) let possible_resolve dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound cl in Some hdconstr with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) (my_find_search mod_delta db_list local_db secvars head cl) with Not_found -> [] let extend_local_db decl db gl = let env = Tacmach.New.pf_env gl in let sigma = Tacmach.New.project gl in Hint_db.add_list env sigma (make_resolve_hyp env sigma decl) db (* Introduce an hypothesis, then call the continuation tactic [kont] with the hint db extended with the so-obtained hypothesis *) let intro_register dbg kont db = Tacticals.New.tclTHEN (dbg_intro dbg) (Proofview.Goal.enter { enter = begin fun gl -> let extend_local_db decl db = extend_local_db decl db gl in Tacticals.New.onLastDecl (fun decl -> kont (extend_local_db decl db)) end }) (* n is the max depth of search *) (* local_db contains the local Hypotheses *) let search d n mod_delta db_list local_db = let rec search d n local_db = (* spiwack: the test of [n] to 0 must be done independently in each goal. Hence the [tclEXTEND] *) Proofview.tclEXTEND [] begin if Int.equal n 0 then Tacticals.New.tclZEROMSG (str"BOUND 2") else Tacticals.New.tclORELSE0 (dbg_assumption d) (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) ( Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in let secvars = compute_secvars gl in let d' = incr_dbg d in Tacticals.New.tclFIRST (List.map (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) (possible_resolve d mod_delta db_list local_db secvars concl)) end })) end [] in search d n local_db let default_search_depth = ref 5 let delta_auto debug mod_delta n lems dbnames = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = make_db_list dbnames in let d = mk_auto_dbg debug in let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (search d n mod_delta db_list hints) end } let delta_auto = if Flags.profile then let key = Profile.declare_profile "delta_auto" in Profile.profile5 key delta_auto else delta_auto let auto ?(debug=Off) n = delta_auto debug false n let new_auto ?(debug=Off) n = delta_auto debug true n let default_auto = auto !default_search_depth [] [] let delta_full_auto ?(debug=Off) mod_delta n lems = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = current_pure_db () in let d = mk_auto_dbg debug in let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (search d n mod_delta db_list hints) end } let full_auto ?(debug=Off) n = delta_full_auto ~debug false n let new_full_auto ?(debug=Off) n = delta_full_auto ~debug true n let default_full_auto = full_auto !default_search_depth [] let gen_auto ?(debug=Off) n lems dbnames = let n = match n with None -> !default_search_depth | Some n -> n in match dbnames with | None -> full_auto ~debug n lems | Some l -> auto ~debug n lems l let h_auto ?(debug=Off) n lems l = gen_auto ~debug n lems l coq-8.6/tactics/tacticals.mli0000644000175000017500000003043113022274260015564 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* tactic val tclORELSE0 : tactic -> tactic -> tactic val tclORELSE : tactic -> tactic -> tactic val tclTHEN : tactic -> tactic -> tactic val tclTHENSEQ : tactic list -> tactic val tclTHENLIST : tactic list -> tactic val tclTHEN_i : tactic -> (int -> tactic) -> tactic val tclTHENFIRST : tactic -> tactic -> tactic val tclTHENLAST : tactic -> tactic -> tactic val tclTHENS : tactic -> tactic list -> tactic val tclTHENSV : tactic -> tactic array -> tactic val tclTHENSLASTn : tactic -> tactic -> tactic array -> tactic val tclTHENLASTn : tactic -> tactic array -> tactic val tclTHENSFIRSTn : tactic -> tactic array -> tactic -> tactic val tclTHENFIRSTn : tactic -> tactic array -> tactic val tclREPEAT : tactic -> tactic val tclREPEAT_MAIN : tactic -> tactic val tclFIRST : tactic list -> tactic val tclSOLVE : tactic list -> tactic val tclTRY : tactic -> tactic val tclCOMPLETE : tactic -> tactic val tclAT_LEAST_ONCE : tactic -> tactic val tclFAIL : int -> std_ppcmds -> tactic val tclFAIL_lazy : int -> std_ppcmds Lazy.t -> tactic val tclDO : int -> tactic -> tactic val tclWEAK_PROGRESS : tactic -> tactic val tclPROGRESS : tactic -> tactic val tclSHOWHYPS : tactic -> tactic val tclNOTSAMEGOAL : tactic -> tactic val tclTHENTRY : tactic -> tactic -> tactic val tclMAP : ('a -> tactic) -> 'a list -> tactic val tclIFTHENELSE : tactic -> tactic -> tactic -> tactic val tclIFTHENSELSE : tactic -> tactic list -> tactic -> tactic val tclIFTHENSVELSE : tactic -> tactic array -> tactic -> tactic val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic (** {6 Tacticals applying to hypotheses } *) val onNthHypId : int -> (Id.t -> tactic) -> tactic val onNthHyp : int -> (constr -> tactic) -> tactic val onNthDecl : int -> (Context.Named.Declaration.t -> tactic) -> tactic val onLastHypId : (Id.t -> tactic) -> tactic val onLastHyp : (constr -> tactic) -> tactic val onLastDecl : (Context.Named.Declaration.t -> tactic) -> tactic val onNLastHypsId : int -> (Id.t list -> tactic) -> tactic val onNLastHyps : int -> (constr list -> tactic) -> tactic val onNLastDecls : int -> (Context.Named.t -> tactic) -> tactic val lastHypId : goal sigma -> Id.t val lastHyp : goal sigma -> constr val lastDecl : goal sigma -> Context.Named.Declaration.t val nLastHypsId : int -> goal sigma -> Id.t list val nLastHyps : int -> goal sigma -> constr list val nLastDecls : int -> goal sigma -> Context.Named.t val afterHyp : Id.t -> goal sigma -> Context.Named.t val ifOnHyp : (Id.t * types -> bool) -> (Id.t -> tactic) -> (Id.t -> tactic) -> Id.t -> tactic val onHyps : (goal sigma -> Context.Named.t) -> (Context.Named.t -> tactic) -> tactic (** {6 Tacticals applying to goal components } *) (** A [clause] denotes occurrences and hypotheses in a goal; in particular, it can abstractly refer to the set of hypotheses independently of the effective contents of the current goal *) val onAllHyps : (Id.t -> tactic) -> tactic val onAllHypsAndConcl : (Id.t option -> tactic) -> tactic val onClause : (Id.t option -> tactic) -> clause -> tactic val onClauseLR : (Id.t option -> tactic) -> clause -> tactic (** {6 Elimination tacticals. } *) type branch_args = { ity : pinductive; (** the type we were eliminating on *) largs : constr list; (** its arguments *) branchnum : int; (** the branch number *) pred : constr; (** the predicate we used *) nassums : int; (** number of assumptions/letin to be introduced *) branchsign : bool list; (** the signature of the branch. true=assumption, false=let-in *) branchnames : intro_patterns} type branch_assumptions = { ba : branch_args; (** the branch args *) assums : Context.Named.t} (** the list of assumptions introduced *) (** [get_and_check_or_and_pattern loc pats branchsign] returns an appropriate error message if |pats| <> |branchsign|; extends them if no pattern is given for let-ins in the case of a conjunctive pattern *) val get_and_check_or_and_pattern : Loc.t -> delayed_open_constr or_and_intro_pattern_expr -> bool list array -> intro_patterns array (** Tolerate "[]" to mean a disjunctive pattern of any length *) val fix_empty_or_and_pattern : int -> delayed_open_constr or_and_intro_pattern_expr -> delayed_open_constr or_and_intro_pattern_expr val compute_constructor_signatures : rec_flag -> pinductive -> bool list array (** Useful for [as intro_pattern] modifier *) val compute_induction_names : bool list array -> or_and_intro_pattern option -> intro_patterns array val elimination_sort_of_goal : goal sigma -> sorts_family val elimination_sort_of_hyp : Id.t -> goal sigma -> sorts_family val elimination_sort_of_clause : Id.t option -> goal sigma -> sorts_family val pf_with_evars : (goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic val elim_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic val case_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic (** Tacticals defined directly in term of Proofview *) (** The tacticals in the module [New] are the tactical of Ltac. Their semantics is an extension of the tacticals in this file for the multi-goal backtracking tactics. They do not have the same semantics as the similarly named tacticals in [Proofview]. The tactical of [Proofview] are used in the definition of the tacticals of [Tacticals.New], but they are more atomic. In particular [Tacticals.New.tclORELSE] sees lack of progress as a failure, whereas [Proofview.tclORELSE] doesn't. Additionally every tactic which can catch failure ([tclOR], [tclORELSE], [tclTRY], [tclREPEAt], etc…) are run into each goal independently (failures and backtracks are localised to a given goal). *) module New : sig open Proofview (** [catch_failerror e] fails and decreases the level if [e] is an Ltac error with level more than 0. Otherwise succeeds. *) val catch_failerror : Util.iexn -> unit tactic val tclIDTAC : unit tactic val tclTHEN : unit tactic -> unit tactic -> unit tactic (* [tclFAIL n msg] fails with [msg] as an error message at level [n] (meaning that it will jump over [n] error catching tacticals FROM THIS MODULE. *) val tclFAIL : int -> Pp.std_ppcmds -> 'a tactic val tclZEROMSG : ?loc:Loc.t -> Pp.std_ppcmds -> 'a tactic (** Fail with a [User_Error] containing the given message. *) val tclOR : unit tactic -> unit tactic -> unit tactic val tclORD : unit tactic -> (unit -> unit tactic) -> unit tactic (** Like {!tclOR} but accepts a delayed tactic as a second argument in the form of a function which will be run only in case of backtracking. *) val tclONCE : unit tactic -> unit tactic val tclEXACTLY_ONCE : unit tactic -> unit tactic val tclIFCATCH : unit tactic -> (unit -> unit tactic) -> (unit -> unit tactic) -> unit tactic val tclORELSE0 : unit tactic -> unit tactic -> unit tactic val tclORELSE : unit tactic -> unit tactic -> unit tactic (** [tclTHENS3PARTS tac1 [|t1 ; ... ; tn|] tac2 [|t'1 ; ... ; t'm|] gls] applies the tactic [tac1] to [gls] then, applies [t1], ..., [tn] to the first [n] resulting subgoals, [t'1], ..., [t'm] to the last [m] subgoals and [tac2] to the rest of the subgoals in the middle. Raises an error if the number of resulting subgoals is strictly less than [n+m] *) val tclTHENS3PARTS : unit tactic -> unit tactic array -> unit tactic -> unit tactic array -> unit tactic val tclTHENSFIRSTn : unit tactic -> unit tactic array -> unit tactic -> unit tactic val tclTHENFIRSTn : unit tactic -> unit tactic array -> unit tactic (** [tclTHENFIRST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2] to the first resulting subgoal *) val tclTHENFIRST : unit tactic -> unit tactic -> unit tactic val tclTHENLASTn : unit tactic -> unit tactic array -> unit tactic val tclTHENLAST : unit tactic -> unit tactic -> unit tactic (* [tclTHENS t l = t <*> tclDISPATCH l] *) val tclTHENS : unit tactic -> unit tactic list -> unit tactic (* [tclTHENLIST [t1;…;tn]] is [t1<*>…<*>tn] *) val tclTHENLIST : unit tactic list -> unit tactic (** [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *) val tclMAP : ('a -> unit tactic) -> 'a list -> unit tactic val tclTRY : unit tactic -> unit tactic val tclFIRST : unit tactic list -> unit tactic val tclIFTHENELSE : unit tactic -> unit tactic -> unit tactic -> unit tactic val tclIFTHENSVELSE : unit tactic -> unit tactic array -> unit tactic -> unit tactic val tclIFTHENTRYELSEMUST : unit tactic -> unit tactic -> unit tactic val tclDO : int -> unit tactic -> unit tactic val tclREPEAT : unit tactic -> unit tactic (* Repeat on the first subgoal (no failure if no more subgoal) *) val tclREPEAT_MAIN : unit tactic -> unit tactic val tclCOMPLETE : 'a tactic -> 'a tactic val tclSOLVE : unit tactic list -> unit tactic val tclPROGRESS : unit tactic -> unit tactic val tclSELECT : goal_selector -> 'a tactic -> 'a tactic val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic val tclDELAYEDWITHHOLES : bool -> 'a delayed_open -> ('a -> unit tactic) -> unit tactic val tclTIMEOUT : int -> unit tactic -> unit tactic val tclTIME : string option -> 'a tactic -> 'a tactic val nLastDecls : ([ `NF ], 'r) Proofview.Goal.t -> int -> Context.Named.t val ifOnHyp : (identifier * types -> bool) -> (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) -> identifier -> unit Proofview.tactic val onNthHypId : int -> (identifier -> unit tactic) -> unit tactic val onLastHypId : (identifier -> unit tactic) -> unit tactic val onLastHyp : (constr -> unit tactic) -> unit tactic val onLastDecl : (Context.Named.Declaration.t -> unit tactic) -> unit tactic val onHyps : ([ `NF ], Context.Named.t) Proofview.Goal.enter -> (Context.Named.t -> unit tactic) -> unit tactic val afterHyp : Id.t -> (Context.Named.t -> unit tactic) -> unit tactic val tryAllHyps : (identifier -> unit tactic) -> unit tactic val tryAllHypsAndConcl : (identifier option -> unit tactic) -> unit tactic val onClause : (identifier option -> unit tactic) -> clause -> unit tactic val elimination_sort_of_goal : ('a, 'r) Proofview.Goal.t -> sorts_family val elimination_sort_of_hyp : Id.t -> ('a, 'r) Proofview.Goal.t -> sorts_family val elimination_sort_of_clause : Id.t option -> ('a, 'r) Proofview.Goal.t -> sorts_family val elimination_then : (branch_args -> unit Proofview.tactic) -> constr -> unit Proofview.tactic val case_then_using : or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) -> constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic val case_nodep_then_using : or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) -> constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic val elim_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic val case_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic val pf_constr_of_global : Globnames.global_reference -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic end coq-8.6/tactics/class_tactics.ml0000644000175000017500000017067613022274260016303 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 then true else false let set_typeclasses_verbose = function None -> typeclasses_debug := 0 | Some n -> (:=) typeclasses_debug n let get_typeclasses_verbose () = if !typeclasses_debug = 0 then None else Some !typeclasses_debug let set_typeclasses_depth d = (:=) typeclasses_depth d let get_typeclasses_depth () = !typeclasses_depth open Goptions let _ = declare_bool_option { optsync = true; optdepr = true; optname = "do typeclass search modulo eta conversion"; optkey = ["Typeclasses";"Modulo";"Eta"]; optread = get_typeclasses_modulo_eta; optwrite = set_typeclasses_modulo_eta; } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "do typeclass search avoiding eta-expansions " ^ " in proof terms (expensive)"; optkey = ["Typeclasses";"Limit";"Intros"]; optread = get_typeclasses_limit_intros; optwrite = set_typeclasses_limit_intros; } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "during typeclass resolution, solve instances according to their dependency order"; optkey = ["Typeclasses";"Dependency";"Order"]; optread = get_typeclasses_dependency_order; optwrite = set_typeclasses_dependency_order; } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "use iterative deepening strategy"; optkey = ["Typeclasses";"Iterative";"Deepening"]; optread = get_typeclasses_iterative_deepening; optwrite = set_typeclasses_iterative_deepening; } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "compat"; optkey = ["Typeclasses";"Legacy";"Resolution"]; optread = get_typeclasses_legacy_resolution; optwrite = set_typeclasses_legacy_resolution; } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "compat"; optkey = ["Typeclasses";"Filtered";"Unification"]; optread = get_typeclasses_filtered_unification; optwrite = set_typeclasses_filtered_unification; } let set_typeclasses_debug = declare_bool_option { optsync = true; optdepr = false; optname = "debug output for typeclasses proof search"; optkey = ["Typeclasses";"Debug"]; optread = get_typeclasses_debug; optwrite = set_typeclasses_debug; } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "debug output for typeclasses proof search"; optkey = ["Debug";"Typeclasses"]; optread = get_typeclasses_debug; optwrite = set_typeclasses_debug; } let _ = declare_int_option { optsync = true; optdepr = false; optname = "verbosity of debug output for typeclasses proof search"; optkey = ["Typeclasses";"Debug";"Verbosity"]; optread = get_typeclasses_verbose; optwrite = set_typeclasses_verbose; } let set_typeclasses_depth = declare_int_option { optsync = true; optdepr = false; optname = "depth for typeclasses proof search"; optkey = ["Typeclasses";"Depth"]; optread = get_typeclasses_depth; optwrite = set_typeclasses_depth; } type search_strategy = Dfs | Bfs let set_typeclasses_strategy = function | Dfs -> set_typeclasses_iterative_deepening false | Bfs -> set_typeclasses_iterative_deepening true let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) evs (Evarutil.nf_evar evs (Goal.V82.concl evs ev)) (** Typeclasses instance search tactic / eauto *) open Auto open Unification let auto_core_unif_flags st freeze = { modulo_conv_on_closed_terms = Some st; use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; modulo_delta = st; modulo_delta_types = st; check_applied_meta_types = false; use_pattern_unification = true; use_meta_bound_pattern_unification = true; frozen_evars = freeze; restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = true; modulo_eta = !typeclasses_modulo_eta; } let auto_unif_flags freeze st = let fl = auto_core_unif_flags st freeze in { core_unify_flags = fl; merge_unify_flags = fl; subterm_unify_flags = fl; allow_K_in_toplevel_higher_order_unification = false; resolve_evars = false } let e_give_exact flags poly (c,clenv) gl = let (c, _, _) = c in let c, gl = if poly then let clenv', subst = Clenv.refresh_undefined_univs clenv in let evd = evars_reset_evd ~with_conv_pbs:true gl.sigma clenv'.evd in let c = Vars.subst_univs_level_constr subst c in c, {gl with sigma = evd} else c, gl in let t1 = pf_unsafe_type_of gl c in Proofview.V82.of_tactic (Clenvtac.unify ~flags t1 <*> exact_no_check c) gl let unify_e_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> let clenv', c = connect_hint_clenv poly c clenv gls in let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in Clenvtac.clenv_refine true ~with_classes:false clenv' end } let unify_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> let clenv', _ = connect_hint_clenv poly c clenv gls in let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in Clenvtac.clenv_refine false ~with_classes:false clenv' end } (** Application of a lemma using [refine] instead of the old [w_unify] *) let unify_resolve_refine poly flags gls ((c, t, ctx),n,clenv) = let open Clenv in let env = Proofview.Goal.env gls in let concl = Proofview.Goal.concl gls in Refine.refine ~unsafe:true { Sigma.run = fun sigma -> let sigma = Sigma.to_evar_map sigma in let sigma, term, ty = if poly then let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in let map c = Vars.subst_univs_level_constr subst c in let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in sigma, map c, map t else let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in sigma, c, t in let sigma', cl = Clenv.make_evar_clause env sigma ?len:n ty in let term = applistc term (List.map (fun x -> x.hole_evar) cl.cl_holes) in let sigma' = Evarconv.the_conv_x_leq env ~ts:flags.core_unify_flags.modulo_delta cl.cl_concl concl sigma' in Sigma.here term (Sigma.Unsafe.of_evar_map sigma') } let unify_resolve_refine poly flags gl clenv = Proofview.tclORELSE (unify_resolve_refine poly flags gl clenv) (fun ie -> match fst ie with | Evarconv.UnableToUnify _ -> Tacticals.New.tclZEROMSG (str "Unable to unify") | e when CErrors.noncritical e -> Tacticals.New.tclZEROMSG (str "Unexpected error") | _ -> iraise ie) (** Dealing with goals of the form A -> B and hints of the form C -> A -> B. *) let clenv_of_prods poly nprods (c, clenv) gl = let (c, _, _) = c in if poly || Int.equal nprods 0 then Some (None, clenv) else let ty = Retyping.get_type_of (Proofview.Goal.env gl) (Sigma.to_evar_map (Proofview.Goal.sigma gl)) c in let diff = nb_prod ty - nprods in if Pervasives.(>=) diff 0 then (* Was Some clenv... *) Some (Some diff, Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) else None let with_prods nprods poly (c, clenv) f = if get_typeclasses_limit_intros () then Proofview.Goal.nf_enter { enter = begin fun gl -> try match clenv_of_prods poly nprods (c, clenv) gl with | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") | Some (diff, clenv') -> f.enter gl (c, diff, clenv') with e when CErrors.noncritical e -> Tacticals.New.tclZEROMSG (CErrors.print e) end } else Proofview.Goal.nf_enter { enter = begin fun gl -> if Int.equal nprods 0 then f.enter gl (c, None, clenv) else Tacticals.New.tclZEROMSG (str"Not enough premisses") end } let matches_pattern concl pat = let matches env sigma = match pat with | None -> Proofview.tclUNIT () | Some pat -> let sigma = Sigma.to_evar_map sigma in if Constr_matching.is_matching env sigma pat concl then Proofview.tclUNIT () else Tacticals.New.tclZEROMSG (str "pattern does not match") in Proofview.Goal.enter { enter = fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in matches env sigma } (** Semantics of type class resolution lemma application: - Use unification to find a well-typed substitution. There might be evars in the goal and the lemma. Evars in the goal can get refined. - Independent evars are turned into goals, whatever their kind is. - Dependent evars of the lemma corresponding to arguments which appear in independent goals or the conclusion are turned into subgoals iff they are of typeclass kind. - The remaining dependent evars not of typeclass type are shelved, and resolution must fill them for it to succeed, otherwise we backtrack. *) let pr_gls sigma gls = prlist_with_sep spc (fun ev -> int (Evar.repr ev) ++ spc () ++ pr_ev sigma ev) gls (** Ensure the dependent subgoals are shelved after an apply/eapply. *) let shelve_dependencies gls = let open Proofview in tclEVARMAP >>= fun sigma -> (if !typeclasses_debug > 1 && List.length gls > 0 then Feedback.msg_debug (str" shelving dependent subgoals: " ++ pr_gls sigma gls); shelve_goals gls) let hintmap_of hdc secvars concl = match hdc with | None -> fun db -> Hint_db.map_none secvars db | Some hdc -> fun db -> if Hint_db.use_dn db then (* Using dnet *) Hint_db.map_eauto secvars hdc concl db else Hint_db.map_existential secvars hdc concl db (** Hack to properly solve dependent evars that are typeclasses *) let rec e_trivial_fail_db only_classes db_list local_db secvars = let open Tacticals.New in let open Tacmach.New in let trivial_fail = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let d = pf_last_hyp gl in let hintl = make_resolve_hyp env sigma d in let hints = Hint_db.add_list env sigma hintl local_db in e_trivial_fail_db only_classes db_list hints secvars end } in let trivial_resolve = Proofview.Goal.nf_enter { enter = begin fun gl -> let tacs = e_trivial_resolve db_list local_db secvars only_classes (project gl) (pf_concl gl) in tclFIRST (List.map (fun (x,_,_,_,_) -> x) tacs) end} in let tacl = Eauto.registered_e_assumption :: (tclTHEN Tactics.intro trivial_fail :: [trivial_resolve]) in tclFIRST (List.map tclCOMPLETE tacl) and e_my_find_search db_list local_db secvars hdc complete only_classes sigma concl = let open Proofview.Notations in let prods, concl = decompose_prod_assum concl in let nprods = List.length prods in let freeze = try match hdc with | Some (hd,_) when only_classes -> let cl = Typeclasses.class_info hd in if cl.cl_strict then Evd.evars_of_term concl else Evar.Set.empty | _ -> Evar.Set.empty with e when CErrors.noncritical e -> Evar.Set.empty in let hint_of_db = hintmap_of hdc secvars concl in let hintl = List.map_append (fun db -> let tacs = hint_of_db db in let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in List.map (fun x -> (flags, x)) tacs) (local_db::db_list) in let tac_of_hint = fun (flags, {pri = b; pat = p; poly = poly; code = t; secvars; name = name}) -> let tac = function | Res_pf (term,cl) -> if get_typeclasses_filtered_unification () then let tac = with_prods nprods poly (term,cl) ({ enter = fun gl clenv -> matches_pattern concl p <*> unify_resolve_refine poly flags gl clenv}) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else let tac = with_prods nprods poly (term,cl) (unify_resolve poly flags) in if get_typeclasses_legacy_resolution () then Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else Proofview.tclBIND (Proofview.with_shelf tac) (fun (gls, ()) -> shelve_dependencies gls) | ERes_pf (term,cl) -> if get_typeclasses_filtered_unification () then let tac = (with_prods nprods poly (term,cl) ({ enter = fun gl clenv -> matches_pattern concl p <*> unify_resolve_refine poly flags gl clenv})) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else let tac = with_prods nprods poly (term,cl) (unify_e_resolve poly flags) in if get_typeclasses_legacy_resolution () then Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else Proofview.tclBIND (Proofview.with_shelf tac) (fun (gls, ()) -> shelve_dependencies gls) | Give_exact (c,clenv) -> if get_typeclasses_filtered_unification () then let tac = matches_pattern concl p <*> Proofview.Goal.nf_enter { enter = fun gl -> unify_resolve_refine poly flags gl (c,None,clenv) } in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else Proofview.V82.tactic (e_give_exact flags poly (c,clenv)) | Res_pf_THEN_trivial_fail (term,cl) -> let fst = with_prods nprods poly (term,cl) (unify_e_resolve poly flags) in let snd = if complete then Tacticals.New.tclIDTAC else e_trivial_fail_db only_classes db_list local_db secvars in Tacticals.New.tclTHEN fst snd | Unfold_nth c -> let tac = Proofview.V82.of_tactic (unfold_in_concl [AllOccurrences,c]) in Proofview.V82.tactic (tclWEAK_PROGRESS tac) | Extern tacast -> conclPattern concl p tacast in let tac = run_hint t tac in let tac = if complete then Tacticals.New.tclCOMPLETE tac else tac in let pp = match p with | Some pat when get_typeclasses_filtered_unification () -> str " with pattern " ++ Printer.pr_constr_pattern pat | _ -> mt () in match repr_hint t with | Extern _ -> (tac, b, true, name, lazy (pr_hint t ++ pp)) | _ -> (tac, b, false, name, lazy (pr_hint t ++ pp)) in List.map tac_of_hint hintl and e_trivial_resolve db_list local_db secvars only_classes sigma concl = let hd = try Some (decompose_app_bound concl) with Bound -> None in try e_my_find_search db_list local_db secvars hd true only_classes sigma concl with Not_found -> [] let e_possible_resolve db_list local_db secvars only_classes sigma concl = let hd = try Some (decompose_app_bound concl) with Bound -> None in try e_my_find_search db_list local_db secvars hd false only_classes sigma concl with Not_found -> [] let cut_of_hints h = List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h let catchable = function | Refiner.FailError _ -> true | e -> Logic.catchable_exception e let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l) let is_Prop env sigma concl = let ty = Retyping.get_type_of env sigma concl in match kind_of_term ty with | Sort (Prop Null) -> true | _ -> false let is_unique env concl = try let (cl,u), args = dest_class_app env concl in cl.cl_unique with e when CErrors.noncritical e -> false (** Sort the undefined variables from the least-dependent to most dependent. *) let top_sort evm undefs = let l' = ref [] in let tosee = ref undefs in let rec visit ev evi = let evs = Evarutil.undefined_evars_of_evar_info evm evi in Evar.Set.iter (fun ev -> if Evar.Map.mem ev !tosee then visit ev (Evar.Map.find ev !tosee)) evs; tosee := Evar.Map.remove ev !tosee; l' := ev :: !l'; in while not (Evar.Map.is_empty !tosee) do let ev, evi = Evar.Map.min_binding !tosee in visit ev evi done; List.rev !l' (** We transform the evars that are concerned by this resolution (according to predicate p) into goals. Invariant: function p only manipulates and returns undefined evars *) let evars_to_goals p evm = let goals = ref Evar.Map.empty in let map ev evi = let evi, goal = p evm ev evi in let () = if goal then goals := Evar.Map.add ev evi !goals in evi in let evm = Evd.raw_map_undefined map evm in if Evar.Map.is_empty !goals then None else Some (!goals, evm) (** Making local hints *) let make_resolve_hyp env sigma st flags only_classes pri decl = let open Context.Named.Declaration in let id = get_id decl in let cty = Evarutil.nf_evar sigma (get_type decl) in let rec iscl env ty = let ctx, ar = decompose_prod_assum ty in match kind_of_term (fst (decompose_app ar)) with | Const (c,_) -> is_class (ConstRef c) | Ind (i,_) -> is_class (IndRef i) | _ -> let env' = Environ.push_rel_context ctx env in let ty' = whd_all env' ar in if not (Term.eq_constr ty' ar) then iscl env' ty' else false in let is_class = iscl env cty in let keep = not only_classes || is_class in if keep then let c = mkVar id in let name = PathHints [VarRef id] in let hints = if is_class then let hints = build_subclasses ~check:false env sigma (VarRef id) empty_hint_info in (List.map_append (fun (path,info,c) -> let info = { info with Vernacexpr.hint_pattern = Option.map (Constrintern.intern_constr_pattern env) info.Vernacexpr.hint_pattern } in make_resolves env sigma ~name:(PathHints path) (true,false,Flags.is_verbose()) info false (IsConstr (c,Univ.ContextSet.empty))) hints) else [] in (hints @ List.map_filter (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) with Failure _ | UserError _ -> None) [make_exact_entry ~name env sigma pri false; make_apply_entry ~name env sigma flags pri false]) else [] let make_hints g st only_classes sign = let hintlist = List.fold_left (fun hints hyp -> let consider = let open Context.Named.Declaration in try let t = Global.lookup_named (get_id hyp) |> get_type in (* Section variable, reindex only if the type changed *) not (Term.eq_constr t (get_type hyp)) with Not_found -> true in if consider then let hint = pf_apply make_resolve_hyp g st (true,false,false) only_classes empty_hint_info hyp in hint @ hints else hints) ([]) sign in Hint_db.add_list (pf_env g) (project g) hintlist (Hint_db.empty st true) (** <= 8.5 resolution *) module V85 = struct type autoinfo = { hints : hint_db; is_evar: existential_key option; only_classes: bool; unique : bool; auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t; auto_path : global_reference option list; auto_cut : hints_path } type autogoal = goal * autoinfo type failure = NotApplicable | ReachedLimit type 'ans fk = failure -> 'ans type ('a,'ans) sk = 'a -> 'ans fk -> 'ans type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans } type auto_result = autogoal list sigma type atac = auto_result tac (* Some utility types to avoid the need of -rectypes *) type 'a optionk = | Nonek | Somek of 'a * 'a optionk fk type ('a,'b) optionk2 = | Nonek2 of failure | Somek2 of 'a * 'b * ('a,'b) optionk2 fk let pf_filtered_hyps gls = Goal.V82.hyps gls.Evd.sigma (sig_it gls) let make_autogoal_hints = let cache = ref (true, Environ.empty_named_context_val, Hint_db.empty full_transparent_state true) in fun only_classes ?(st=full_transparent_state) g -> let sign = pf_filtered_hyps g in let (onlyc, sign', cached_hints) = !cache in if onlyc == only_classes && (sign == sign' || Environ.eq_named_context_val sign sign') && Hint_db.transparent_state cached_hints == st then cached_hints else let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in cache := (only_classes, sign, hints); hints let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac = { skft = fun sk fk {it = gl,hints; sigma=s;} -> let res = try Some (tac {it=gl; sigma=s;}) with e when catchable e -> None in match res with | Some gls -> sk (f gls hints) fk | None -> fk NotApplicable } let intro_tac : atac = let tac {it = gls; sigma = s} info = let gls' = List.map (fun g' -> let env = Goal.V82.env s g' in let context = Environ.named_context_of_val (Goal.V82.hyps s g') in let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) (true,false,false) info.only_classes empty_hint_info (List.hd context) in let ldb = Hint_db.add_list env s hint info.hints in (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls in {it = gls'; sigma = s;} in lift_tactic (Proofview.V82.of_tactic Tactics.intro) tac let normevars_tac : atac = { skft = fun sk fk {it = (gl, info); sigma = s;} -> let gl', sigma' = Goal.V82.nf_evar s gl in let info' = { info with auto_last_tac = lazy (str"normevars") } in sk {it = [gl', info']; sigma = sigma';} fk } let merge_failures x y = match x, y with | _, ReachedLimit | ReachedLimit, _ -> ReachedLimit | NotApplicable, NotApplicable -> NotApplicable let or_tac (x : 'a tac) (y : 'a tac) : 'a tac = { skft = fun sk fk gls -> x.skft sk (fun f -> y.skft sk (fun f' -> fk (merge_failures f f')) gls) gls } let or_else_tac (x : 'a tac) (y : failure -> 'a tac) : 'a tac = { skft = fun sk fk gls -> x.skft sk (fun f -> (y f).skft sk fk gls) gls } let needs_backtrack env evd oev concl = if Option.is_empty oev || is_Prop env evd concl then occur_existential concl else true let hints_tac hints sk fk {it = gl,info; sigma = s} = let env = Goal.V82.env s gl in let concl = Goal.V82.concl s gl in let tacgl = {it = gl; sigma = s;} in let secvars = secvars_of_hyps (Environ.named_context_of_val (Goal.V82.hyps s gl)) in let poss = e_possible_resolve hints info.hints secvars info.only_classes s concl in let unique = is_unique env concl in let rec aux i foundone = function | (tac, _, extern, name, pp) :: tl -> let derivs = path_derivate info.auto_cut name in let res = try if path_matches derivs [] then None else Some (Proofview.V82.of_tactic tac tacgl) with e when catchable e -> None in (match res with | None -> aux i foundone tl | Some {it = gls; sigma = s';} -> if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp ++ str" on" ++ spc () ++ pr_ev s gl); let sgls = evars_to_goals (fun evm ev evi -> if Typeclasses.is_resolvable evi && not (Evd.is_undefined s ev) && (not info.only_classes || Typeclasses.is_class_evar evm evi) then Typeclasses.mark_unresolvable evi, true else evi, false) s' in let newgls, s' = let gls' = List.map (fun g -> (None, g)) gls in match sgls with | None -> gls', s' | Some (evgls, s') -> if not !typeclasses_dependency_order then (gls' @ List.map (fun (ev,_) -> (Some ev, ev)) (Evar.Map.bindings evgls), s') else (* Reorder with dependent subgoals. *) let evm = List.fold_left (fun acc g -> Evar.Map.add g (Evd.find_undefined s' g) acc) evgls gls in let gls = top_sort s' evm in (List.map (fun ev -> Some ev, ev) gls, s') in let reindex g = let open Goal.V82 in extern && not (Environ.eq_named_context_val (hyps s' g) (hyps s' gl)) in let gl' j (evar, g) = let hints' = if reindex g then make_autogoal_hints info.only_classes ~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s';} else info.hints in { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp; is_evar = evar; hints = hints'; auto_cut = derivs } in let gls' = List.map_i (fun i g -> snd g, gl' i g) 1 newgls in let glsv = {it = gls'; sigma = s';} in let fk' = (fun e -> let do_backtrack = if unique then occur_existential concl else if info.unique then true else if List.is_empty gls' then needs_backtrack env s' info.is_evar concl else true in let e' = match foundone with None -> e | Some e' -> merge_failures e e' in if !typeclasses_debug > 0 then Feedback.msg_debug ((if do_backtrack then str"Backtracking after " else str "Not backtracking after ") ++ Lazy.force pp); if do_backtrack then aux (succ i) (Some e') tl else fk e') in sk glsv fk') | [] -> if foundone == None && !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth info.auto_depth ++ str": no match for " ++ Printer.pr_constr_env (Goal.V82.env s gl) s concl ++ spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities"); match foundone with | Some e -> fk e | None -> fk NotApplicable in aux 1 None poss let hints_tac hints = { skft = fun sk fk gls -> hints_tac hints sk fk gls } let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk = let rec aux s (acc : autogoal list list) fk = function | (gl,info) :: gls -> Control.check_for_interrupt (); (match info.is_evar with | Some ev when Evd.is_defined s ev -> aux s acc fk gls | _ -> second.skft (fun {it=gls';sigma=s'} fk' -> let fk'' = if not info.unique && List.is_empty gls' && not (needs_backtrack (Goal.V82.env s gl) s info.is_evar (Goal.V82.concl s gl)) then fk else fk' in aux s' (gls'::acc) fk'' gls) fk {it = (gl,info); sigma = s; }) | [] -> Somek2 (List.rev acc, s, fk) in fun {it = gls; sigma = s; } fk -> let rec aux' = function | Nonek2 e -> fk e | Somek2 (res, s', fk') -> let goals' = List.concat res in sk {it = goals'; sigma = s'; } (fun e -> aux' (fk' e)) in aux' (aux s [] (fun e -> Nonek2 e) gls) let then_tac (first : atac) (second : atac) : atac = { skft = fun sk fk -> first.skft (then_list second sk) fk } let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option = t.skft (fun x _ -> Some x) (fun _ -> None) gl type run_list_res = auto_result optionk let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res = (then_list t (fun x fk -> Somek (x, fk))) gl (fun _ -> Nonek) let fail_tac reason : atac = { skft = fun sk fk _ -> fk reason } let rec fix (t : 'a tac) : 'a tac = then_tac t { skft = fun sk fk -> (fix t).skft sk fk } let rec fix_limit limit (t : 'a tac) : 'a tac = if Int.equal limit 0 then fail_tac ReachedLimit else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk } let fix_iterative t = let rec aux depth = or_else_tac (fix_limit depth t) (function | NotApplicable as e -> fail_tac e | ReachedLimit -> aux (succ depth)) in aux 1 let fix_iterative_limit limit (t : 'a tac) : 'a tac = let rec aux depth = if Int.equal limit depth then fail_tac ReachedLimit else or_tac (fix_limit depth t) { skft = fun sk fk -> (aux (succ depth)).skft sk fk } in aux 1 let make_autogoal ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) cut ev g = let hints = make_autogoal_hints only_classes ~st g in (g.it, { hints = hints ; is_evar = ev; unique = unique; only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (str"none"); auto_path = []; auto_cut = cut }) let make_autogoals ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) hints gs evm' = let cut = cut_of_hints hints in let gl i g = let (gl, auto) = make_autogoal ~only_classes ~unique ~st cut (Some g) {it = g; sigma = evm'; } in (gl, { auto with auto_depth = [i]}) in { it = List.map_i gl 1 gs; sigma = evm' } let get_result r = match r with | Nonek -> None | Somek (gls, fk) -> Some (gls.sigma,fk) let run_on_evars ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) p evm hints tac = match evars_to_goals p evm with | None -> None (* This happens only because there's no evar having p *) | Some (goals, evm') -> let goals = if !typeclasses_dependency_order then top_sort evm' goals else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals) in let res = run_list_tac tac p goals (make_autogoals ~only_classes ~unique ~st hints goals evm') in match get_result res with | None -> raise Not_found | Some (evm', fk) -> Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk) let eauto_tac hints = then_tac normevars_tac (or_tac (hints_tac hints) intro_tac) let eauto_tac strategy depth hints = match strategy with | Bfs -> begin match depth with | None -> fix_iterative (eauto_tac hints) | Some depth -> fix_iterative_limit depth (eauto_tac hints) end | Dfs -> match depth with | None -> fix (eauto_tac hints) | Some depth -> fix_limit depth (eauto_tac hints) let real_eauto ?depth strategy unique st hints p evd = let res = run_on_evars ~st ~unique p evd hints (eauto_tac strategy depth hints) in match res with | None -> evd | Some (evd', fk) -> if unique then (match get_result (fk NotApplicable) with | Some (evd'', fk') -> error "Typeclass resolution gives multiple solutions" | None -> evd') else evd' let resolve_all_evars_once debug depth unique p evd = let db = searchtable_map typeclasses_db in let strategy = if get_typeclasses_iterative_deepening () then Bfs else Dfs in real_eauto ?depth strategy unique (Hint_db.transparent_state db) [db] p evd let eauto85 ?(only_classes=true) ?st ?strategy depth hints g = let strategy = match strategy with | None -> if get_typeclasses_iterative_deepening () then Bfs else Dfs | Some s -> s in let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g; } in match run_tac (eauto_tac strategy depth hints) gl with | None -> raise Not_found | Some {it = goals; sigma = s; } -> {it = List.map fst goals; sigma = s;} end (** 8.6 resolution *) module Search = struct type autoinfo = { search_depth : int list; last_tac : Pp.std_ppcmds Lazy.t; search_dep : bool; search_only_classes : bool; search_cut : hints_path; search_hints : hint_db; } (** Local hints *) let autogoal_cache = ref (DirPath.empty, true, Context.Named.empty, Hint_db.empty full_transparent_state true) let make_autogoal_hints only_classes ?(st=full_transparent_state) g = let open Proofview in let open Tacmach.New in let sign = Goal.hyps g in let (dir, onlyc, sign', cached_hints) = !autogoal_cache in let cwd = Lib.cwd () in if DirPath.equal cwd dir && (onlyc == only_classes) && Context.Named.equal sign sign' && Hint_db.transparent_state cached_hints == st then cached_hints else let hints = make_hints {it = Goal.goal g; sigma = project g} st only_classes sign in autogoal_cache := (cwd, only_classes, sign, hints); hints let make_autogoal ?(st=full_transparent_state) only_classes dep cut i g = let hints = make_autogoal_hints only_classes ~st g in { search_hints = hints; search_depth = [i]; last_tac = lazy (str"none"); search_dep = dep; search_only_classes = only_classes; search_cut = cut } (** In the proof engine failures are represented as exceptions *) exception ReachedLimitEx exception NotApplicableEx (** ReachedLimitEx has priority over NotApplicableEx to handle iterative deepening: it should fail when no hints are applicable, but go to a deeper depth otherwise. *) let merge_exceptions e e' = match fst e, fst e' with | ReachedLimitEx, _ -> e | _, ReachedLimitEx -> e' | _, _ -> e (** Determine if backtracking is needed for this goal. If the type class is unique or in Prop and there are no evars in the goal then we do NOT backtrack. *) let needs_backtrack env evd unique concl = if unique || is_Prop env evd concl then occur_existential concl else true let mark_unresolvables sigma goals = List.fold_left (fun sigma gl -> let evi = Evd.find_undefined sigma gl in let evi' = Typeclasses.mark_unresolvable evi in Evd.add sigma gl evi') sigma goals let fail_if_nonclass info = Proofview.Goal.enter { enter = fun gl -> let gl = Proofview.Goal.assume gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in if is_class_type sigma (Proofview.Goal.concl gl) then Proofview.tclUNIT () else (if !typeclasses_debug > 1 then Feedback.msg_debug (pr_depth info.search_depth ++ str": failure due to non-class subgoal " ++ pr_ev sigma (Proofview.Goal.goal gl)); Proofview.tclZERO NotApplicableEx) } (** The general hint application tactic. tac1 + tac2 .... The choice of OR or ORELSE is determined depending on the dependencies of the goal and the unique/Prop status *) let hints_tac_gl hints info kont gl : unit Proofview.tactic = let open Proofview in let open Proofview.Notations in let env = Goal.env gl in let concl = Goal.concl gl in let sigma = Goal.sigma gl in let s = Sigma.to_evar_map sigma in let unique = not info.search_dep || is_unique env concl in let backtrack = needs_backtrack env s unique concl in if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth info.search_depth ++ str": looking for " ++ Printer.pr_constr_env (Goal.env gl) s concl ++ (if backtrack then str" with backtracking" else str" without backtracking")); let secvars = compute_secvars gl in let poss = e_possible_resolve hints info.search_hints secvars info.search_only_classes s concl in (* If no goal depends on the solution of this one or the instances are irrelevant/assumed to be unique, then we don't need to backtrack, as long as no evar appears in the goal This is an overapproximation. Evars could appear in this goal only and not any other *) let ortac = if backtrack then Proofview.tclOR else Proofview.tclORELSE in let idx = ref 1 in let foundone = ref false in let rec onetac e (tac, pat, b, name, pp) tl = let derivs = path_derivate info.search_cut name in let pr_error ie = if !typeclasses_debug > 1 then let msg = pr_depth (!idx :: info.search_depth) ++ str": " ++ Lazy.force pp ++ (if !foundone != true then str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal gl) else mt ()) in Feedback.msg_debug (msg ++ str " failed with " ++ CErrors.iprint ie) else () in let tac_of gls i j = Goal.nf_enter { enter = fun gl' -> let sigma' = Goal.sigma gl' in let s' = Sigma.to_evar_map sigma' in let _concl = Goal.concl gl' in if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth (succ j :: i :: info.search_depth) ++ str" : " ++ pr_ev s' (Proofview.Goal.goal gl')); let hints' = if b && not (Context.Named.equal (Goal.hyps gl') (Goal.hyps gl)) then let st = Hint_db.transparent_state info.search_hints in make_autogoal_hints info.search_only_classes ~st gl' else info.search_hints in let dep' = info.search_dep || Proofview.unifiable s' (Goal.goal gl') gls in let info' = { search_depth = succ j :: i :: info.search_depth; last_tac = pp; search_dep = dep'; search_only_classes = info.search_only_classes; search_hints = hints'; search_cut = derivs } in kont info' } in let rec result (shelf, ()) i k = foundone := true; Proofview.Unsafe.tclGETGOALS >>= fun gls -> let j = List.length gls in (if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth (i :: info.search_depth) ++ str": " ++ Lazy.force pp ++ str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal gl) ++ str", " ++ int j ++ str" subgoal(s)" ++ (Option.cata (fun k -> str " in addition to the first " ++ int k) (mt()) k))); let res = if j = 0 then tclUNIT () else tclDISPATCH (List.init j (fun j' -> (tac_of gls i (Option.default 0 k + j)))) in let finish nestedshelf sigma = let filter ev = try let evi = Evd.find_undefined sigma ev in if info.search_only_classes then Some (ev, not (is_class_type sigma (Evd.evar_concl evi))) else Some (ev, true) with Not_found -> None in let remaining = CList.map_filter filter shelf in (if !typeclasses_debug > 1 then let prunsolved (ev, _) = int (Evar.repr ev) ++ spc () ++ pr_ev sigma ev in let unsolved = prlist_with_sep spc prunsolved remaining in Feedback.msg_debug (pr_depth (i :: info.search_depth) ++ str": after " ++ Lazy.force pp ++ str" finished, " ++ int (List.length remaining) ++ str " goals are shelved and unsolved ( " ++ unsolved ++ str")")); begin (* Some existentials produced by the original tactic were not solved in the subgoals, turn them into subgoals now. *) let shelved, goals = List.partition (fun (ev, s) -> s) remaining in let shelved = List.map fst shelved @ nestedshelf and goals = List.map fst goals in if !typeclasses_debug > 1 && not (List.is_empty shelved && List.is_empty goals) then Feedback.msg_debug (str"Adding shelved subgoals to the search: " ++ prlist_with_sep spc (pr_ev sigma) goals ++ str" while shelving " ++ prlist_with_sep spc (pr_ev sigma) shelved); shelve_goals shelved <*> (if List.is_empty goals then tclUNIT () else let sigma' = mark_unresolvables sigma goals in with_shelf (Unsafe.tclEVARS sigma' <*> Unsafe.tclNEWGOALS goals) >>= fun s -> result s i (Some (Option.default 0 k + j))) end in with_shelf res >>= fun (sh, ()) -> tclEVARMAP >>= finish sh in if path_matches derivs [] then aux e tl else let filter = if false (* in 8.6, still allow non-class subgoals info.search_only_classes *) then fail_if_nonclass info else Proofview.tclUNIT () in ortac (with_shelf (tac <*> filter) >>= fun s -> let i = !idx in incr idx; result s i None) (fun e' -> if CErrors.noncritical (fst e') then (pr_error e'; aux (merge_exceptions e e') tl) else iraise e') and aux e = function | x :: xs -> onetac e x xs | [] -> if !foundone == false && !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth info.search_depth ++ str": no match for " ++ Printer.pr_constr_env (Goal.env gl) s concl ++ spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities"); match e with | (ReachedLimitEx,ie) -> Proofview.tclZERO ~info:ie ReachedLimitEx | (_,ie) -> Proofview.tclZERO ~info:ie NotApplicableEx in if backtrack then aux (NotApplicableEx,Exninfo.null) poss else tclONCE (aux (NotApplicableEx,Exninfo.null) poss) let hints_tac hints info kont : unit Proofview.tactic = Proofview.Goal.nf_enter { enter = fun gl -> hints_tac_gl hints info kont gl } let intro_tac info kont gl = let open Proofview in let open Proofview.Notations in let env = Goal.env gl in let sigma = Goal.sigma gl in let s = Sigma.to_evar_map sigma in let decl = Tacmach.New.pf_last_hyp gl in let hint = make_resolve_hyp env s (Hint_db.transparent_state info.search_hints) (true,false,false) info.search_only_classes empty_hint_info decl in let ldb = Hint_db.add_list env s hint info.search_hints in let info' = { info with search_hints = ldb; last_tac = lazy (str"intro"); search_depth = 1 :: 1 :: info.search_depth } in kont info' let intro info kont = Proofview.tclBIND Tactics.intro (fun _ -> Proofview.Goal.nf_enter { enter = fun gl -> intro_tac info kont gl }) let rec search_tac hints limit depth = let kont info = Proofview.numgoals >>= fun i -> if !typeclasses_debug > 1 then Feedback.msg_debug (str"calling eauto recursively at depth " ++ int (succ depth) ++ str" on " ++ int i ++ str" subgoals"); search_tac hints limit (succ depth) info in fun info -> if Int.equal depth (succ limit) then Proofview.tclZERO ReachedLimitEx else Proofview.tclOR (hints_tac hints info kont) (fun e -> Proofview.tclOR (intro info kont) (fun e' -> let (e, info) = merge_exceptions e e' in Proofview.tclZERO ~info e)) let search_tac_gl ?st only_classes dep hints depth i sigma gls gl : unit Proofview.tactic = let open Proofview in let open Proofview.Notations in if false (* In 8.6, still allow non-class goals only_classes && not (is_class_type sigma (Goal.concl gl)) *) then Tacticals.New.tclZEROMSG (str"Not a subgoal for a class") else let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in search_tac hints depth 1 info let search_tac ?(st=full_transparent_state) only_classes dep hints depth = let open Proofview in let tac sigma gls i = Goal.nf_enter { enter = fun gl -> search_tac_gl ~st only_classes dep hints depth (succ i) sigma gls gl } in Proofview.Unsafe.tclGETGOALS >>= fun gls -> Proofview.tclEVARMAP >>= fun sigma -> let j = List.length gls in (tclDISPATCH (List.init j (fun i -> tac sigma gls i))) let fix_iterative t = let rec aux depth = Proofview.tclOR (t depth) (function | (ReachedLimitEx,_) -> aux (succ depth) | (e,ie) -> Proofview.tclZERO ~info:ie e) in aux 1 let fix_iterative_limit limit t = let open Proofview in let rec aux depth = if Int.equal depth (succ limit) then tclZERO ReachedLimitEx else tclOR (t depth) (function (ReachedLimitEx, _) -> aux (succ depth) | (e,ie) -> Proofview.tclZERO ~info:ie e) in aux 1 let eauto_tac ?(st=full_transparent_state) ?(unique=false) ~only_classes ?strategy ~depth ~dep hints = let open Proofview in let tac = let search = search_tac ~st only_classes dep hints in let dfs = match strategy with | None -> not (get_typeclasses_iterative_deepening ()) | Some Dfs -> true | Some Bfs -> false in if dfs then let depth = match depth with None -> -1 | Some d -> d in search depth else match depth with | None -> fix_iterative search | Some l -> fix_iterative_limit l search in let error (e, ie) = match e with | ReachedLimitEx -> Tacticals.New.tclFAIL 0 (str"Proof search reached its limit") | NotApplicableEx -> Tacticals.New.tclFAIL 0 (str"Proof search failed" ++ (if Option.is_empty depth then mt() else str" without reaching its limit")) | Proofview.MoreThanOneSuccess -> Tacticals.New.tclFAIL 0 (str"Proof search failed: " ++ str"more than one success found") | e -> Proofview.tclZERO ~info:ie e in let tac = Proofview.tclOR tac error in let tac = if unique then Proofview.tclEXACTLY_ONCE Proofview.MoreThanOneSuccess tac else tac in with_shelf numgoals >>= fun (initshelf, i) -> (if !typeclasses_debug > 1 then Feedback.msg_debug (str"Starting resolution with " ++ int i ++ str" goal(s) under focus and " ++ int (List.length initshelf) ++ str " shelved goal(s)" ++ (if only_classes then str " in only_classes mode" else str " in regular mode") ++ match depth with None -> str ", unbounded" | Some i -> str ", with depth limit " ++ int i)); tac let run_on_evars p evm tac = match evars_to_goals p evm with | None -> None (* This happens only because there's no evar having p *) | Some (goals, evm') -> let goals = if !typeclasses_dependency_order then top_sort evm' goals else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals) in let fgoals = Evd.future_goals evm in let pgoal = Evd.principal_future_goal evm in let _, pv = Proofview.init evm' [] in let pv = Proofview.unshelve goals pv in try let (), pv', (unsafe, shelved, gaveup), _ = Proofview.apply (Global.env ()) tac pv in if Proofview.finished pv' then let evm' = Proofview.return pv' in assert(Evd.fold_undefined (fun ev _ acc -> let okev = Evd.mem evm ev || List.mem ev shelved in if not okev then Feedback.msg_debug (str "leaking evar " ++ int (Evar.repr ev) ++ spc () ++ pr_ev evm' ev); acc && okev) evm' true); let evm' = Evd.restore_future_goals evm' (shelved @ fgoals) pgoal in let evm' = evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm in Some evm' else raise Not_found with Logic_monad.TacticFailure _ -> raise Not_found let evars_eauto depth only_classes unique dep st hints p evd = let eauto_tac = eauto_tac ~st ~unique ~only_classes ~depth ~dep:(unique || dep) hints in let res = run_on_evars p evd eauto_tac in match res with | None -> evd | Some evd' -> evd' let typeclasses_eauto ?depth unique st hints p evd = evars_eauto depth true unique false st hints p evd (** Typeclasses eauto is an eauto which tries to resolve only goals of typeclass type, and assumes that the initially selected evars in evd are independent of the rest of the evars *) let typeclasses_resolve debug depth unique p evd = let db = searchtable_map typeclasses_db in typeclasses_eauto ?depth unique (Hint_db.transparent_state db) [db] p evd end (** Binding to either V85 or Search implementations. *) let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) ?strategy ~depth dbs = let dbs = List.map_filter (fun db -> try Some (searchtable_map db) with e when CErrors.noncritical e -> None) dbs in let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in let depth = match depth with None -> get_typeclasses_depth () | Some l -> Some l in if get_typeclasses_legacy_resolution () then Proofview.V82.tactic (fun gl -> try V85.eauto85 depth ~only_classes ~st ?strategy dbs gl with Not_found -> Refiner.tclFAIL 0 (str"Proof search failed") gl) else Search.eauto_tac ~st ~only_classes ?strategy ~depth ~dep:true dbs (** We compute dependencies via a union-find algorithm. Beware of the imperative effects on the partition structure, it should not be shared, but only used locally. *) module Intpart = Unionfind.Make(Evar.Set)(Evar.Map) let deps_of_constraints cstrs evm p = List.iter (fun (_, _, x, y) -> let evx = Evarutil.undefined_evars_of_term evm x in let evy = Evarutil.undefined_evars_of_term evm y in Intpart.union_set (Evar.Set.union evx evy) p) cstrs let evar_dependencies evm p = Evd.fold_undefined (fun ev evi _ -> let evars = Evar.Set.add ev (Evarutil.undefined_evars_of_evar_info evm evi) in Intpart.union_set evars p) evm () (** [split_evars] returns groups of undefined evars according to dependencies *) let split_evars evm = let p = Intpart.create () in evar_dependencies evm p; deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p; Intpart.partition p let is_inference_forced p evd ev = try let evi = Evd.find_undefined evd ev in if Typeclasses.is_resolvable evi && snd (p ev evi) then let (loc, k) = evar_source ev evd in match k with | Evar_kinds.ImplicitArg (_, _, b) -> b | Evar_kinds.QuestionMark _ -> false | _ -> true else true with Not_found -> assert false let is_mandatory p comp evd = Evar.Set.exists (is_inference_forced p evd) comp (** In case of unsatisfiable constraints, build a nice error message *) let error_unresolvable env comp evd = let evd = Evarutil.nf_evar_map_undefined evd in let is_part ev = match comp with | None -> true | Some s -> Evar.Set.mem ev s in let fold ev evi (found, accu) = let ev_class = class_of_constr evi.evar_concl in if not (Option.is_empty ev_class) && is_part ev then (* focus on one instance if only one was searched for *) if not found then (true, Some ev) else (found, None) else (found, accu) in let (_, ev) = Evd.fold_undefined fold evd (true, None) in Pretype_errors.unsatisfiable_constraints (Evarutil.nf_env_evar evd env) evd ev comp (** Check if an evar is concerned by the current resolution attempt, (and in particular is in the current component), and also update its evar_info. Invariant : this should only be applied to undefined evars, and return undefined evar_info *) let select_and_update_evars p oevd in_comp evd ev evi = assert (evi.evar_body == Evar_empty); try let oevi = Evd.find_undefined oevd ev in if Typeclasses.is_resolvable oevi then Typeclasses.mark_unresolvable evi, (in_comp ev && p evd ev evi) else evi, false with Not_found -> Typeclasses.mark_unresolvable evi, p evd ev evi (** Do we still have unresolved evars that should be resolved ? *) let has_undefined p oevd evd = let check ev evi = snd (p oevd ev evi) in Evar.Map.exists check (Evd.undefined_map evd) (** Revert the resolvability status of evars after resolution, potentially unprotecting some evars that were set unresolvable just for this call to resolution. *) let revert_resolvability oevd evd = let map ev evi = try if not (Typeclasses.is_resolvable evi) then let evi' = Evd.find_undefined oevd ev in if Typeclasses.is_resolvable evi' then Typeclasses.mark_resolvable evi else evi else evi with Not_found -> evi in Evd.raw_map_undefined map evd exception Unresolved (** If [do_split] is [true], we try to separate the problem in several components and then solve them separately *) let resolve_all_evars debug depth unique env p oevd do_split fail = let split = if do_split then split_evars oevd else [Evar.Set.empty] in let in_comp comp ev = if do_split then Evar.Set.mem ev comp else true in let rec docomp evd = function | [] -> revert_resolvability oevd evd | comp :: comps -> let p = select_and_update_evars p oevd (in_comp comp) in try let evd' = if get_typeclasses_legacy_resolution () then V85.resolve_all_evars_once debug depth unique p evd else Search.typeclasses_resolve debug depth unique p evd in if has_undefined p oevd evd' then raise Unresolved; docomp evd' comps with Unresolved | Not_found -> if fail && (not do_split || is_mandatory (p evd) comp evd) then (* Unable to satisfy the constraints. *) let comp = if do_split then Some comp else None in error_unresolvable env comp evd else (* Best effort: do nothing on this component *) docomp evd comps in docomp oevd split let initial_select_evars filter = fun evd ev evi -> filter ev (snd evi.Evd.evar_source) && Typeclasses.is_class_evar evd evi let resolve_typeclass_evars debug depth unique env evd filter split fail = let evd = try Evarconv.solve_unif_constraints_with_heuristics ~ts:(Typeclasses.classes_transparent_state ()) env evd with e when CErrors.noncritical e -> evd in resolve_all_evars debug depth unique env (initial_select_evars filter) evd split fail let solve_inst env evd filter unique split fail = resolve_typeclass_evars (get_typeclasses_debug ()) (get_typeclasses_depth ()) unique env evd filter split fail let _ = Hook.set Typeclasses.solve_all_instances_hook solve_inst let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env gl in let (gl,t,sigma) = Goal.V82.mk_goal sigma nc gl Store.empty in let gls = { it = gl ; sigma = sigma; } in let hints = searchtable_map typeclasses_db in let st = Hint_db.transparent_state hints in let depth = get_typeclasses_depth () in let gls' = if get_typeclasses_legacy_resolution () then V85.eauto85 depth ~st [hints] gls else try Proofview.V82.of_tactic (Search.eauto_tac ~st ~only_classes:true ~depth [hints] ~dep:true) gls with Refiner.FailError _ -> raise Not_found in let evd = sig_sig gls' in let t' = let (ev, inst) = destEvar t in mkEvar (ev, Array.of_list subst) in let term = Evarutil.nf_evar evd t' in evd, term let _ = Hook.set Typeclasses.solve_one_instance_hook (fun x y z w -> resolve_one_typeclass x ~sigma:y z w) (** Take the head of the arity of a constr. Used in the partial application tactic. *) let rec head_of_constr t = let t = strip_outer_cast(collapse_appl t) in match kind_of_term t with | Prod (_,_,c2) -> head_of_constr c2 | LetIn (_,_,_,c2) -> head_of_constr c2 | App (f,args) -> head_of_constr f | _ -> t let head_of_constr h c = let c = head_of_constr c in letin_tac None (Name h) c None Locusops.allHyps let not_evar c = Proofview.tclEVARMAP >>= fun sigma -> match Evarutil.kind_of_term_upto sigma c with | Evar _ -> Tacticals.New.tclFAIL 0 (str"Evar") | _ -> Proofview.tclUNIT () let is_ground c gl = if Evarutil.is_ground_term (project gl) c then tclIDTAC gl else tclFAIL 0 (str"Not ground") gl let autoapply c i gl = let flags = auto_unif_flags Evar.Set.empty (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in let cty = pf_unsafe_type_of gl c in let ce = mk_clenv_from gl (c,cty) in let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl ((c,cty,Univ.ContextSet.empty),0,ce) } in Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl coq-8.6/tactics/tactics.ml0000644000175000017500000060220213022274260015077 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* user_err_loc (Loc.ghost, "", print_retype_error e) open Goptions (* Option for 8.2 compatibility *) let dependent_propositions_elimination = ref true let use_dependent_propositions_elimination () = !dependent_propositions_elimination && Flags.version_strictly_greater Flags.V8_2 let _ = declare_bool_option { optsync = true; optdepr = false; optname = "dependent-propositions-elimination tactic"; optkey = ["Dependent";"Propositions";"Elimination"]; optread = (fun () -> !dependent_propositions_elimination) ; optwrite = (fun b -> dependent_propositions_elimination := b) } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "trigger bugged context matching compatibility"; optkey = ["Tactic";"Compat";"Context"]; optread = (fun () -> !Flags.tactic_context_compat) ; optwrite = (fun b -> Flags.tactic_context_compat := b) } let apply_solve_class_goals = ref (false) let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = true; Goptions.optname = "Perform typeclass resolution on apply-generated subgoals."; Goptions.optkey = ["Typeclass";"Resolution";"After";"Apply"]; Goptions.optread = (fun () -> !apply_solve_class_goals); Goptions.optwrite = (fun a -> apply_solve_class_goals:=a); } let clear_hyp_by_default = ref false let use_clear_hyp_by_default () = !clear_hyp_by_default let _ = declare_bool_option { optsync = true; optdepr = false; optname = "default clearing of hypotheses after use"; optkey = ["Default";"Clearing";"Used";"Hypotheses"]; optread = (fun () -> !clear_hyp_by_default) ; optwrite = (fun b -> clear_hyp_by_default := b) } (* Compatibility option useful in developments using apply intensively in ltac code *) let universal_lemma_under_conjunctions = ref false let accept_universal_lemma_under_conjunctions () = !universal_lemma_under_conjunctions let _ = declare_bool_option { optsync = true; optdepr = false; optname = "trivial unification in tactics applying under conjunctions"; optkey = ["Universal";"Lemma";"Under";"Conjunction"]; optread = (fun () -> !universal_lemma_under_conjunctions) ; optwrite = (fun b -> universal_lemma_under_conjunctions := b) } (* Shrinking of abstract proofs. *) let shrink_abstract = ref true let _ = declare_bool_option { optsync = true; optdepr = true; optname = "shrinking of abstracted proofs"; optkey = ["Shrink"; "Abstract"]; optread = (fun () -> !shrink_abstract) ; optwrite = (fun b -> shrink_abstract := b) } (* The following boolean governs what "intros []" do on examples such as "forall x:nat*nat, x=x"; if true, it behaves as "intros [? ?]"; if false, it behaves as "intro H; case H; clear H" for fresh H. Kept as false for compatibility. *) let bracketing_last_or_and_intro_pattern = ref true let use_bracketing_last_or_and_intro_pattern () = !bracketing_last_or_and_intro_pattern && Flags.version_strictly_greater Flags.V8_4 let _ = declare_bool_option { optsync = true; optdepr = false; optname = "bracketing last or-and introduction pattern"; optkey = ["Bracketing";"Last";"Introduction";"Pattern"]; optread = (fun () -> !bracketing_last_or_and_intro_pattern); optwrite = (fun b -> bracketing_last_or_and_intro_pattern := b) } (*********************************************) (* Tactics *) (*********************************************) (******************************************) (* Primitive tactics *) (******************************************) (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) let unsafe_intro env store decl b = let open Context.Named.Declaration in Refine.refine ~unsafe:true { run = begin fun sigma -> let ctx = named_context_val env in let nctx = push_named_context_val decl ctx in let inst = List.map (mkVar % get_id) (named_context env) in let ninst = mkRel 1 :: inst in let nb = subst1 (mkVar (get_id decl)) b in let Sigma (ev, sigma, p) = new_evar_instance nctx sigma nb ~principal:true ~store ninst in Sigma (mkNamedLambda_or_LetIn decl ev, sigma, p) end } let introduction ?(check=true) id = let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let hyps = named_context_val (Proofview.Goal.env gl) in let store = Proofview.Goal.extra gl in let env = Proofview.Goal.env gl in let () = if check && mem_named_context_val id hyps then errorlabstrm "Tactics.introduction" (str "Variable " ++ pr_id id ++ str " is already declared.") in match kind_of_term (whd_evar sigma concl) with | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b | _ -> raise (RefinerError IntroNeedsProduct) end } let refine = Tacmach.refine let convert_concl ?(check=true) ty k = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let conclty = Proofview.Goal.raw_concl gl in Refine.refine ~unsafe:true { run = begin fun sigma -> let Sigma ((), sigma, p) = if check then begin let sigma = Sigma.to_evar_map sigma in ignore (Typing.unsafe_type_of env sigma ty); let sigma,b = Reductionops.infer_conv env sigma ty conclty in if not b then error "Not convertible."; Sigma.Unsafe.of_pair ((), sigma) end else Sigma.here () sigma in let Sigma (x, sigma, q) = Evarutil.new_evar env sigma ~principal:true ~store ty in let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in Sigma (ans, sigma, p +> q) end } end } let convert_hyp ?(check=true) d = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty end } end } let convert_concl_no_check = convert_concl ~check:false let convert_hyp_no_check = convert_hyp ~check:false let convert_gen pb x y = Proofview.Goal.enter { enter = begin fun gl -> try let sigma, b = Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y in if b then Proofview.Unsafe.tclEVARS sigma else Tacticals.New.tclFAIL 0 (str "Not convertible") with (* Reduction.NotConvertible *) _ -> (** FIXME: Sometimes an anomaly is raised from conversion *) Tacticals.New.tclFAIL 0 (str "Not convertible") end } let convert x y = convert_gen Reduction.CONV x y let convert_leq x y = convert_gen Reduction.CUMUL x y let clear_dependency_msg env sigma id = function | Evarutil.OccurHypInSimpleClause None -> pr_id id ++ str " is used in conclusion." | Evarutil.OccurHypInSimpleClause (Some id') -> pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str"." | Evarutil.EvarTypingBreak ev -> str "Cannot remove " ++ pr_id id ++ strbrk " without breaking the typing of " ++ Printer.pr_existential env sigma ev ++ str"." let error_clear_dependency env sigma id err = errorlabstrm "" (clear_dependency_msg env sigma id err) let replacing_dependency_msg env sigma id = function | Evarutil.OccurHypInSimpleClause None -> str "Cannot change " ++ pr_id id ++ str ", it is used in conclusion." | Evarutil.OccurHypInSimpleClause (Some id') -> str "Cannot change " ++ pr_id id ++ strbrk ", it is used in hypothesis " ++ pr_id id' ++ str"." | Evarutil.EvarTypingBreak ev -> str "Cannot change " ++ pr_id id ++ strbrk " without breaking the typing of " ++ Printer.pr_existential env sigma ev ++ str"." let error_replacing_dependency env sigma id err = errorlabstrm "" (replacing_dependency_msg env sigma id err) (* This tactic enables the user to remove hypotheses from the signature. * Some care is taken to prevent him from removing variables that are * subsequently used in other hypotheses or in the conclusion of the * goal. *) let clear_gen fail = function | [] -> Proofview.tclUNIT () | ids -> Proofview.Goal.s_enter { s_enter = begin fun gl -> let ids = List.fold_right Id.Set.add ids Id.Set.empty in (** clear_hyps_in_evi does not require nf terms *) let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let evdref = ref sigma in let (hyps, concl) = try clear_hyps_in_evi env evdref (named_context_val env) concl ids with Evarutil.ClearDependencyError (id,err) -> fail env sigma id err in let env = reset_with_named_context hyps env in let tac = Refine.refine ~unsafe:true { run = fun sigma -> Evarutil.new_evar env sigma ~principal:true concl } in Sigma.Unsafe.of_pair (tac, !evdref) end } let clear ids = clear_gen error_clear_dependency ids let clear_for_replacing ids = clear_gen error_replacing_dependency ids let apply_clear_request clear_flag dft c = let check_isvar c = if not (isVar c) then error "keep/clear modifiers apply only to hypothesis names." in let doclear = match clear_flag with | None -> dft && isVar c | Some true -> check_isvar c; true | Some false -> false in if doclear then clear [destVar c] else Tacticals.New.tclIDTAC (* Moving hypotheses *) let move_hyp id dest = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let ty = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in let sign = named_context_val env in let sign' = move_hyp_in_named_context id dest sign in let env = reset_with_named_context sign' env in Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty end } end } (* Renaming hypotheses *) let rename_hyp repl = let open Context.Named.Declaration in let fold accu (src, dst) = match accu with | None -> None | Some (srcs, dsts) -> if Id.Set.mem src srcs then None else if Id.Set.mem dst dsts then None else let srcs = Id.Set.add src srcs in let dsts = Id.Set.add dst dsts in Some (srcs, dsts) in let init = Some (Id.Set.empty, Id.Set.empty) in let dom = List.fold_left fold init repl in match dom with | None -> Tacticals.New.tclZEROMSG (str "Not a one-to-one name mapping") | Some (src, dst) -> Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let hyps = Proofview.Goal.hyps gl in let concl = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in (** Check that we do not mess variables *) let fold accu decl = Id.Set.add (get_id decl) accu in let vars = List.fold_left fold Id.Set.empty hyps in let () = if not (Id.Set.subset src vars) then let hyp = Id.Set.choose (Id.Set.diff src vars) in raise (RefinerError (NoSuchHyp hyp)) in let mods = Id.Set.diff vars src in let () = try let elt = Id.Set.choose (Id.Set.inter dst mods) in CErrors.errorlabstrm "" (pr_id elt ++ str " is already used") with Not_found -> () in (** All is well *) let make_subst (src, dst) = (src, mkVar dst) in let subst = List.map make_subst repl in let subst c = Vars.replace_vars subst c in let map decl = decl |> map_id (fun id -> try List.assoc_f Id.equal id repl with Not_found -> id) |> map_constr subst in let nhyps = List.map map hyps in let nconcl = subst concl in let nctx = Environ.val_of_named_context nhyps in let instance = List.map (mkVar % get_id) hyps in Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar_instance nctx sigma nconcl ~principal:true ~store instance end } end } (**************************************************************) (* Fresh names *) (**************************************************************) let fresh_id_in_env avoid id env = next_ident_away_in_goal id (avoid@ids_of_named_context (named_context env)) let fresh_id avoid id gl = fresh_id_in_env avoid id (pf_env gl) let new_fresh_id avoid id gl = fresh_id_in_env avoid id (Proofview.Goal.env gl) let id_of_name_with_default id = function | Anonymous -> id | Name id -> id let default_id_of_sort s = if Sorts.is_small s then default_small_ident else default_type_ident let default_id env sigma decl = let open Context.Rel.Declaration in match decl with | LocalAssum (name,t) -> let dft = default_id_of_sort (Retyping.get_sort_of env sigma t) in id_of_name_with_default dft name | LocalDef (name,b,_) -> id_of_name_using_hdchar env b name (* Non primitive introduction tactics are treated by intro_then_gen There is possibly renaming, with possibly names to avoid and possibly a move to do after the introduction *) type name_flag = | NamingAvoid of Id.t list | NamingBasedOn of Id.t * Id.t list | NamingMustBe of Loc.t * Id.t let naming_of_name = function | Anonymous -> NamingAvoid [] | Name id -> NamingMustBe (dloc,id) let find_name mayrepl decl naming gl = match naming with | NamingAvoid idl -> (* this case must be compatible with [find_intro_names] below. *) let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in new_fresh_id idl (default_id env sigma decl) gl | NamingBasedOn (id,idl) -> new_fresh_id idl id gl | NamingMustBe (loc,id) -> (* When name is given, we allow to hide a global name *) let ids_of_hyps = Tacmach.New.pf_ids_of_hyps gl in let id' = next_ident_away id ids_of_hyps in if not mayrepl && not (Id.equal id' id) then user_err_loc (loc,"",pr_id id ++ str" is already used."); id (**************************************************************) (* Cut rule *) (**************************************************************) let assert_before_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENLAST (Proofview.V82.tactic (fun gl -> try Tacmach.internal_cut b id t gl with Evarutil.ClearDependencyError (id,err) -> error_replacing_dependency (pf_env gl) (project gl) id err)) (tac id) end } let assert_before_gen b naming t = assert_before_then_gen b naming t (fun _ -> Proofview.tclUNIT ()) let assert_before na = assert_before_gen false (naming_of_name na) let assert_before_replacing id = assert_before_gen true (NamingMustBe (dloc,id)) let assert_after_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENFIRST (Proofview.V82.tactic (fun gl -> try Tacmach.internal_cut_rev b id t gl with Evarutil.ClearDependencyError (id,err) -> error_replacing_dependency (pf_env gl) (project gl) id err)) (tac id) end } let assert_after_gen b naming t = assert_after_then_gen b naming t (fun _ -> (Proofview.tclUNIT ())) let assert_after na = assert_after_gen false (naming_of_name na) let assert_after_replacing id = assert_after_gen true (NamingMustBe (dloc,id)) (**************************************************************) (* Fixpoints and CoFixpoints *) (**************************************************************) let rec mk_holes : type r s. _ -> r Sigma.t -> (s, r) Sigma.le -> _ -> (_, s) Sigma.sigma = fun env sigma p -> function | [] -> Sigma ([], sigma, p) | arg :: rem -> let Sigma (arg, sigma, q) = Evarutil.new_evar env sigma arg in let Sigma (rem, sigma, r) = mk_holes env sigma (p +> q) rem in Sigma (arg :: rem, sigma, r) let rec check_mutind env sigma k cl = match kind_of_term (strip_outer_cast cl) with | Prod (na, c1, b) -> if Int.equal k 1 then try let ((sp, _), u), _ = find_inductive env sigma c1 in (sp, u) with Not_found -> error "Cannot do a fixpoint on a non inductive type." else let open Context.Rel.Declaration in check_mutind (push_rel (LocalAssum (na, c1)) env) sigma (pred k) b | _ -> error "Not enough products." (* Refine as a fixpoint *) let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let (sp, u) = check_mutind env sigma n concl in let firsts, lasts = List.chop j rest in let all = firsts @ (f, n, concl) :: lasts in let rec mk_sign sign = function | [] -> sign | (f, n, ar) :: oth -> let open Context.Named.Declaration in let (sp', u') = check_mutind env sigma n ar in if not (eq_mind sp sp') then error "Fixpoints should be on the same mutual inductive declaration."; if mem_named_context_val f sign then errorlabstrm "Logic.prim_refiner" (str "Name " ++ pr_id f ++ str " already used in the environment"); mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in Refine.refine { run = begin fun sigma -> let Sigma (evs, sigma, p) = mk_holes nenv sigma Sigma.refl (List.map pi3 all) in let ids = List.map pi1 all in let evs = List.map (Vars.subst_vars (List.rev ids)) evs in let indxs = Array.of_list (List.map (fun n -> n-1) (List.map pi2 all)) in let funnames = Array.of_list (List.map (fun i -> Name i) ids) in let typarray = Array.of_list (List.map pi3 all) in let bodies = Array.of_list evs in let oterm = Term.mkFix ((indxs,0),(funnames,typarray,bodies)) in Sigma (oterm, sigma, p) end } end } let fix ido n = match ido with | None -> Proofview.Goal.enter { enter = begin fun gl -> let name = Pfedit.get_current_proof_name () in let id = new_fresh_id [] name gl in mutual_fix id n [] 0 end } | Some id -> mutual_fix id n [] 0 let rec check_is_mutcoind env sigma cl = let b = whd_all env sigma cl in match kind_of_term b with | Prod (na, c1, b) -> let open Context.Rel.Declaration in check_is_mutcoind (push_rel (LocalAssum (na,c1)) env) sigma b | _ -> try let _ = find_coinductive env sigma b in () with Not_found -> error "All methods must construct elements in coinductive types." (* Refine as a cofixpoint *) let mutual_cofix f others j = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let firsts,lasts = List.chop j others in let all = firsts @ (f, concl) :: lasts in List.iter (fun (_, c) -> check_is_mutcoind env sigma c) all; let rec mk_sign sign = function | [] -> sign | (f, ar) :: oth -> let open Context.Named.Declaration in if mem_named_context_val f sign then error "Name already used in the environment."; mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in Refine.refine { run = begin fun sigma -> let (ids, types) = List.split all in let Sigma (evs, sigma, p) = mk_holes nenv sigma Sigma.refl types in let evs = List.map (Vars.subst_vars (List.rev ids)) evs in let funnames = Array.of_list (List.map (fun i -> Name i) ids) in let typarray = Array.of_list types in let bodies = Array.of_list evs in let oterm = Term.mkCoFix (0, (funnames, typarray, bodies)) in Sigma (oterm, sigma, p) end } end } let cofix ido = match ido with | None -> Proofview.Goal.enter { enter = begin fun gl -> let name = Pfedit.get_current_proof_name () in let id = new_fresh_id [] name gl in mutual_cofix id [] 0 end } | Some id -> mutual_cofix id [] 0 (**************************************************************) (* Reduction and conversion tactics *) (**************************************************************) type tactic_reduction = env -> evar_map -> constr -> constr let pf_reduce_decl redfun where decl gl = let open Context.Named.Declaration in let redfun' = Tacmach.New.pf_apply redfun gl in match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); LocalAssum (id,redfun' ty) | LocalDef (id,b,ty) -> let b' = if where != InHypTypeOnly then redfun' b else b in let ty' = if where != InHypValueOnly then redfun' ty else ty in LocalDef (id,b',ty') (* Possibly equip a reduction with the occurrences mentioned in an occurrence clause *) let error_illegal_clause () = error "\"at\" clause not supported in presence of an occurrence clause." let error_illegal_non_atomic_clause () = error "\"at\" clause not supported in presence of a non atomic \"in\" clause." let error_occurrences_not_unsupported () = error "Occurrences not supported for this reduction tactic." let bind_change_occurrences occs = function | None -> None | Some c -> Some (Redexpr.out_with_occurrences (occs,c)) let bind_red_expr_occurrences occs nbcl redexp = let has_at_clause = function | Unfold l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l | Pattern l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l | Simpl (_,Some (occl,_)) -> occl != AllOccurrences | _ -> false in if occs == AllOccurrences then if nbcl > 1 && has_at_clause redexp then error_illegal_non_atomic_clause () else redexp else match redexp with | Unfold (_::_::_) -> error_illegal_clause () | Unfold [(occl,c)] -> if occl != AllOccurrences then error_illegal_clause () else Unfold [(occs,c)] | Pattern (_::_::_) -> error_illegal_clause () | Pattern [(occl,c)] -> if occl != AllOccurrences then error_illegal_clause () else Pattern [(occs,c)] | Simpl (f,Some (occl,c)) -> if occl != AllOccurrences then error_illegal_clause () else Simpl (f,Some (occs,c)) | CbvVm (Some (occl,c)) -> if occl != AllOccurrences then error_illegal_clause () else CbvVm (Some (occs,c)) | CbvNative (Some (occl,c)) -> if occl != AllOccurrences then error_illegal_clause () else CbvNative (Some (occs,c)) | Red _ | Hnf | Cbv _ | Lazy _ | Cbn _ | ExtraRedExpr _ | Fold _ | Simpl (_,None) | CbvVm None | CbvNative None -> error_occurrences_not_unsupported () | Unfold [] | Pattern [] -> assert false (* The following two tactics apply an arbitrary reduction function either to the conclusion or to a certain hypothesis *) let reduct_in_concl (redfun,sty) = Proofview.Goal.nf_enter { enter = begin fun gl -> convert_concl_no_check (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty end } let reduct_in_hyp ?(check=false) redfun (id,where) = Proofview.Goal.nf_enter { enter = begin fun gl -> convert_hyp ~check (pf_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl) end } let revert_cast (redfun,kind as r) = if kind == DEFAULTcast then (redfun,REVERTcast) else r let reduct_option ?(check=false) redfun = function | Some id -> reduct_in_hyp ~check (fst redfun) id | None -> reduct_in_concl (revert_cast redfun) (** Tactic reduction modulo evars (for universes essentially) *) let pf_e_reduce_decl redfun where decl gl = let open Context.Named.Declaration in let sigma = Proofview.Goal.sigma gl in let redfun sigma c = redfun.e_redfun (Tacmach.New.pf_env gl) sigma c in match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = redfun sigma ty in Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> let Sigma (b', sigma, p) = if where != InHypTypeOnly then redfun sigma b else Sigma.here b sigma in let Sigma (ty', sigma, q) = if where != InHypValueOnly then redfun sigma ty else Sigma.here ty sigma in Sigma (LocalDef (id, b', ty'), sigma, p +> q) let e_reduct_in_concl ~check (redfun, sty) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in Sigma (convert_concl ~check c' sty, sigma, p) end } let e_reduct_in_hyp ?(check=false) redfun (id, where) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let Sigma (decl', sigma, p) = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in Sigma (convert_hyp ~check decl', sigma, p) end } let e_reduct_option ?(check=false) redfun = function | Some id -> e_reduct_in_hyp ~check (fst redfun) id | None -> e_reduct_in_concl ~check (revert_cast redfun) (** Versions with evars to maintain the unification of universes resulting from conversions. *) let e_change_in_concl (redfun,sty) = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in Sigma (convert_concl_no_check c sty, sigma, p) end } let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = let open Context.Named.Declaration in match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma ty in Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> let Sigma (b', sigma, p) = if where != InHypTypeOnly then (redfun true).e_redfun env sigma b else Sigma.here b sigma in let Sigma (ty', sigma, q) = if where != InHypValueOnly then (redfun false).e_redfun env sigma ty else Sigma.here ty sigma in Sigma (LocalDef (id,b',ty'), sigma, p +> q) let e_change_in_hyp redfun (id,where) = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let hyp = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in let Sigma (c, sigma, p) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in Sigma (convert_hyp c, sigma, p) end } type change_arg = Pattern.patvar_map -> constr Sigma.run let make_change_arg c pats = { run = fun sigma -> Sigma.here (replace_vars (Id.Map.bindings pats) c) sigma } let check_types env sigma mayneedglobalcheck deep newc origc = let t1 = Retyping.get_type_of env sigma newc in if deep then begin let t2 = Retyping.get_type_of env sigma origc in let sigma, t2 = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t2 in let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in if not b then if isSort (whd_all env sigma t1) && isSort (whd_all env sigma t2) then (mayneedglobalcheck := true; sigma) else errorlabstrm "convert-check-hyp" (str "Types are incompatible.") else sigma end else if not (isSort (whd_all env sigma t1)) then errorlabstrm "convert-check-hyp" (str "Not a type.") else sigma (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun env sigma c -> let Sigma (t', sigma, p) = t.run sigma in let sigma = Sigma.to_evar_map sigma in let sigma = check_types env sigma mayneedglobalcheck deep t' c in let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in if not b then errorlabstrm "convert-check-hyp" (str "Not convertible."); Sigma.Unsafe.of_pair (t', sigma) end } (* Use cumulativity only if changing the conclusion not a subterm *) let change_on_subterm cv_pb deep t where = { e_redfun = begin fun env sigma c -> let mayneedglobalcheck = ref false in let Sigma (c, sigma, p) = match where with | None -> (change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty)).e_redfun env sigma c | Some occl -> (e_contextually false occl (fun subst -> change_and_check Reduction.CONV mayneedglobalcheck true (t subst))).e_redfun env sigma c in if !mayneedglobalcheck then begin try ignore (Typing.unsafe_type_of env (Sigma.to_evar_map sigma) c) with e when catchable_exception e -> error "Replacement would lead to an ill-typed term." end; Sigma (c, sigma, p) end } let change_in_concl occl t = e_change_in_concl ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast) let change_in_hyp occl t id = e_change_in_hyp (fun x -> change_on_subterm Reduction.CONV x t occl) id let change_option occl t = function | Some id -> change_in_hyp occl t id | None -> change_in_concl occl t let change chg c cls = Proofview.Goal.enter { enter = begin fun gl -> let cls = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in Tacticals.New.tclMAP (function | OnHyp (id,occs,where) -> change_option (bind_change_occurrences occs chg) c (Some (id,where)) | OnConcl occs -> change_option (bind_change_occurrences occs chg) c None) cls end } let change_concl t = change_in_concl None (make_change_arg t) (* Pour usage interne (le niveau User est pris en compte par reduce) *) let red_in_concl = reduct_in_concl (red_product,REVERTcast) let red_in_hyp = reduct_in_hyp red_product let red_option = reduct_option (red_product,REVERTcast) let hnf_in_concl = reduct_in_concl (hnf_constr,REVERTcast) let hnf_in_hyp = reduct_in_hyp hnf_constr let hnf_option = reduct_option (hnf_constr,REVERTcast) let simpl_in_concl = reduct_in_concl (simpl,REVERTcast) let simpl_in_hyp = reduct_in_hyp simpl let simpl_option = reduct_option (simpl,REVERTcast) let normalise_in_concl = reduct_in_concl (compute,REVERTcast) let normalise_in_hyp = reduct_in_hyp compute let normalise_option = reduct_option (compute,REVERTcast) let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast) let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,REVERTcast) let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) let pattern_option l = e_reduct_option (pattern_occs l,DEFAULTcast) (* The main reduction function *) let reduction_clause redexp cl = let nbcl = List.length cl in List.map (function | OnHyp (id,occs,where) -> (Some (id,where), bind_red_expr_occurrences occs nbcl redexp) | OnConcl occs -> (None, bind_red_expr_occurrences occs nbcl redexp)) cl let reduce redexp cl = let trace () = Pp.(hov 2 (Pptactic.pr_atomic_tactic (Global.env()) (TacReduce (redexp,cl)))) in Proofview.Trace.name_tactic trace begin Proofview.Goal.enter { enter = begin fun gl -> let cl' = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in let redexps = reduction_clause redexp cl' in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in Tacticals.New.tclMAP (fun (where,redexp) -> e_reduct_option ~check (Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp) where) redexps end } end (* Unfolding occurrences of a constant *) let unfold_constr = function | ConstRef sp -> unfold_in_concl [AllOccurrences,EvalConstRef sp] | VarRef id -> unfold_in_concl [AllOccurrences,EvalVarRef id] | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.") (*******************************************) (* Introduction tactics *) (*******************************************) (* Returns the names that would be created by intros, without doing intros. This function is supposed to be compatible with an iteration of [find_name] above. As [default_id] checks the sort of the type to build hyp names, we maintain an environment to be able to type dependent hyps. *) let find_intro_names ctxt gl = let _, res = List.fold_right (fun decl acc -> let env,idl = acc in let name = fresh_id idl (default_id env gl.sigma decl) gl in let newenv = push_rel decl env in (newenv,(name::idl))) ctxt (pf_env gl , []) in List.rev res let build_intro_tac id dest tac = match dest with | MoveLast -> Tacticals.New.tclTHEN (introduction id) (tac id) | dest -> Tacticals.New.tclTHENLIST [introduction id; move_hyp id dest; tac id] let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let concl = nf_evar (Tacmach.New.project gl) concl in match kind_of_term concl with | Prod (name,t,u) when not dep_flag || (dependent (mkRel 1) u) -> let name = find_name false (LocalAssum (name,t)) name_flag gl in build_intro_tac name move_flag tac | LetIn (name,b,t,u) when not dep_flag || (dependent (mkRel 1) u) -> let name = find_name false (LocalDef (name,b,t)) name_flag gl in build_intro_tac name move_flag tac | _ -> begin if not force_flag then Proofview.tclZERO (RefinerError IntroNeedsProduct) (* Note: red_in_concl includes betaiotazeta and this was like *) (* this since at least V6.3 (a pity *) (* that intro do betaiotazeta only when reduction is needed; and *) (* probably also a pity that intro does zeta *) else Proofview.tclUNIT () end <*> Proofview.tclORELSE (Tacticals.New.tclTHEN hnf_in_concl (intro_then_gen name_flag move_flag false dep_flag tac)) begin function (e, info) -> match e with | RefinerError IntroNeedsProduct -> Tacticals.New.tclZEROMSG (str "No product even after head-reduction.") | e -> Proofview.tclZERO ~info e end end } let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ()) let intro_mustbe_force id = intro_gen (NamingMustBe (dloc,id)) MoveLast true false let intro_using id = intro_gen (NamingBasedOn (id,[])) MoveLast false false let intro_then = intro_then_gen (NamingAvoid []) MoveLast false false let intro = intro_gen (NamingAvoid []) MoveLast false false let introf = intro_gen (NamingAvoid []) MoveLast true false let intro_avoiding l = intro_gen (NamingAvoid l) MoveLast false false let intro_move_avoid idopt avoid hto = match idopt with | None -> intro_gen (NamingAvoid avoid) hto true false | Some id -> intro_gen (NamingMustBe (dloc,id)) hto true false let intro_move idopt hto = intro_move_avoid idopt [] hto (**** Multiple introduction tactics ****) let rec intros_using = function | [] -> Proofview.tclUNIT() | str::l -> Tacticals.New.tclTHEN (intro_using str) (intros_using l) let intros = Tacticals.New.tclREPEAT intro let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = let rec aux n ids = (* Note: we always use the bound when there is one for "*" and "**" *) if (match bound with None -> true | Some (_,p) -> n < p) then Proofview.tclORELSE begin intro_then_gen name_flag move_flag false dep_flag (fun id -> aux (n+1) (id::ids)) end begin function (e, info) -> match e with | RefinerError IntroNeedsProduct -> tac ids | e -> Proofview.tclZERO ~info e end else tac ids in aux n [] let get_next_hyp_position id gl = let open Context.Named.Declaration in let rec aux = function | [] -> raise (RefinerError (NoSuchHyp id)) | decl :: right -> if Id.equal (get_id decl) id then match right with decl::_ -> MoveBefore (get_id decl) | [] -> MoveLast else aux right in aux (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let get_previous_hyp_position id gl = let open Context.Named.Declaration in let rec aux dest = function | [] -> raise (RefinerError (NoSuchHyp id)) | decl :: right -> let hyp = get_id decl in if Id.equal hyp id then dest else aux (MoveAfter hyp) right in aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let intro_replacing id = Proofview.Goal.enter { enter = begin fun gl -> let next_hyp = get_next_hyp_position id gl in Tacticals.New.tclTHENLIST [ clear_for_replacing [id]; introduction id; move_hyp id next_hyp; ] end } (* We have e.g. [x, y, y', x', y'' |- forall y y' y'', G] and want to reintroduce y, y,' y''. Note that we have to clear y, y' and y'' before introducing y because y' or y'' can e.g. depend on old y. *) (* This version assumes that replacement is actually possible *) (* (ids given in the introduction order) *) (* We keep a sub-optimality in cleaing for compatibility with *) (* the behavior of inversion *) let intros_possibly_replacing ids = let suboptimal = true in Proofview.Goal.enter { enter = begin fun gl -> let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in Tacticals.New.tclTHEN (Tacticals.New.tclMAP (fun id -> Tacticals.New.tclTRY (clear_for_replacing [id])) (if suboptimal then ids else List.rev ids)) (Tacticals.New.tclMAP (fun (id,pos) -> Tacticals.New.tclORELSE (intro_move (Some id) pos) (intro_using id)) posl) end } (* This version assumes that replacement is actually possible *) let intros_replacing ids = Proofview.Goal.enter { enter = begin fun gl -> let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in Tacticals.New.tclTHEN (clear_for_replacing ids) (Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl) end } (* User-level introduction tactics *) let lookup_hypothesis_as_renamed env ccl = function | AnonHyp n -> Detyping.lookup_index_as_renamed env ccl n | NamedHyp id -> Detyping.lookup_name_as_displayed env ccl id let lookup_hypothesis_as_renamed_gen red h gl = let env = Proofview.Goal.env gl in let rec aux ccl = match lookup_hypothesis_as_renamed env ccl h with | None when red -> let (redfun, _) = Redexpr.reduction_of_red_expr env (Red true) in let Sigma (c, _, _) = redfun.e_redfun env (Proofview.Goal.sigma gl) ccl in aux c | x -> x in try aux (Proofview.Goal.concl gl) with Redelimination -> None let is_quantified_hypothesis id gl = match lookup_hypothesis_as_renamed_gen false (NamedHyp id) gl with | Some _ -> true | None -> false let msg_quantified_hypothesis = function | NamedHyp id -> str "quantified hypothesis named " ++ pr_id id | AnonHyp n -> pr_nth n ++ str " non dependent hypothesis" let depth_of_quantified_hypothesis red h gl = match lookup_hypothesis_as_renamed_gen red h gl with | Some depth -> depth | None -> errorlabstrm "lookup_quantified_hypothesis" (str "No " ++ msg_quantified_hypothesis h ++ strbrk " in current goal" ++ (if red then strbrk " even after head-reduction" else mt ()) ++ str".") let intros_until_gen red h = Proofview.Goal.nf_enter { enter = begin fun gl -> let n = depth_of_quantified_hypothesis red h gl in Tacticals.New.tclDO n (if red then introf else intro) end } let intros_until_id id = intros_until_gen false (NamedHyp id) let intros_until_n_gen red n = intros_until_gen red (AnonHyp n) let intros_until = intros_until_gen true let intros_until_n = intros_until_n_gen true let tclCHECKVAR id = Proofview.Goal.enter { enter = begin fun gl -> let _ = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in Proofview.tclUNIT () end } let try_intros_until_id_check id = Tacticals.New.tclORELSE (intros_until_id id) (tclCHECKVAR id) let try_intros_until tac = function | NamedHyp id -> Tacticals.New.tclTHEN (try_intros_until_id_check id) (tac id) | AnonHyp n -> Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHypId tac) let rec intros_move = function | [] -> Proofview.tclUNIT () | (hyp,destopt) :: rest -> Tacticals.New.tclTHEN (intro_gen (NamingMustBe (dloc,hyp)) destopt false false) (intros_move rest) let run_delayed env sigma c = Sigma.run sigma { Sigma.run = fun sigma -> c.delayed env sigma } (* Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) let tactic_infer_flags with_evar = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = true; Pretyping.use_hook = Some solve_by_implicit_tactic; Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true } let onOpenInductionArg env sigma tac = function | clear_flag,ElimOnConstr f -> let (cbl, sigma') = run_delayed env sigma f in let pending = (sigma,sigma') in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma') (tac clear_flag (pending,cbl)) | clear_flag,ElimOnAnonHyp n -> Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHyp (fun c -> Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let pending = (sigma,sigma) in tac clear_flag (pending,(c,NoBindings)) end })) | clear_flag,ElimOnIdent (_,id) -> (* A quantified hypothesis *) Tacticals.New.tclTHEN (try_intros_until_id_check id) (Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let pending = (sigma,sigma) in tac clear_flag (pending,(mkVar id,NoBindings)) end }) let onInductionArg tac = function | clear_flag,ElimOnConstr cbl -> tac clear_flag cbl | clear_flag,ElimOnAnonHyp n -> Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHyp (fun c -> tac clear_flag (c,NoBindings))) | clear_flag,ElimOnIdent (_,id) -> (* A quantified hypothesis *) Tacticals.New.tclTHEN (try_intros_until_id_check id) (tac clear_flag (mkVar id,NoBindings)) let map_destruction_arg f sigma = function | clear_flag,ElimOnConstr g -> let sigma,x = f sigma g in (sigma, (clear_flag,ElimOnConstr x)) | clear_flag,ElimOnAnonHyp n as x -> (sigma,x) | clear_flag,ElimOnIdent id as x -> (sigma,x) let finish_delayed_evar_resolution with_evars env sigma f = let ((c, lbind), sigma') = run_delayed env sigma f in let pending = (sigma,sigma') in let sigma' = Sigma.Unsafe.of_evar_map sigma' in let flags = tactic_infer_flags with_evars in let Sigma (c, sigma', _) = finish_evar_resolution ~flags env sigma' (pending,c) in (Sigma.to_evar_map sigma', (c, lbind)) let with_no_bindings (c, lbind) = if lbind != NoBindings then error "'with' clause not supported here."; c let force_destruction_arg with_evars env sigma c = map_destruction_arg (finish_delayed_evar_resolution with_evars env) sigma c (****************************************) (* tactic "cut" (actually modus ponens) *) (****************************************) let normalize_cut = false let cut c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_nf_concl gl in let is_sort = try (** Backward compat: ensure that [c] is well-typed. *) let typ = Typing.unsafe_type_of env sigma c in let typ = whd_all env sigma typ in match kind_of_term typ with | Sort _ -> true | _ -> false with e when Pretype_errors.precatchable_exception e -> false in if is_sort then let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in (** Backward compat: normalize [c]. *) let c = if normalize_cut then local_strong whd_betaiota sigma c else c in Refine.refine ~unsafe:true { run = begin fun h -> let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in let Sigma (x, h, q) = Evarutil.new_evar env h c in let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in Sigma (f, h, p +> q) end } else Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") end } let error_uninstantiated_metas t clenv = let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in let id = match na with Name id -> id | _ -> anomaly (Pp.str "unnamed dependent meta") in errorlabstrm "" (str "Cannot find an instance for " ++ pr_id id ++ str".") let check_unresolved_evars_of_metas sigma clenv = (* This checks that Metas turned into Evars by *) (* Refiner.pose_all_metas_as_evars are resolved *) List.iter (fun (mv,b) -> match b with | Clval (_,(c,_),_) -> (match kind_of_term c.rebus with | Evar (evk,_) when Evd.is_undefined clenv.evd evk && not (Evd.mem sigma evk) -> error_uninstantiated_metas (mkMeta mv) clenv | _ -> ()) | _ -> ()) (meta_list clenv.evd) let do_replace id = function | NamingMustBe (_,id') when Option.equal Id.equal id (Some id') -> true | _ -> false (* For a clenv expressing some lemma [C[?1:T1,...,?n:Tn] : P] and some goal [G], [clenv_refine_in] returns [n+1] subgoals, the [n] last ones (resp [n] first ones if [sidecond_first] is [true]) being the [Ti] and the first one (resp last one) being [G] whose hypothesis [id] is replaced by P using the proof given by [tac] *) let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) targetid id sigma0 clenv tac = let clenv = Clenvtac.clenv_pose_dependent_evars with_evars clenv in let clenv = if with_classes then { clenv with evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd } else clenv in let new_hyp_typ = clenv_type clenv in if not with_evars then check_unresolved_evars_of_metas sigma0 clenv; if not with_evars && occur_meta new_hyp_typ then error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in let exact_tac = Proofview.V82.tactic (Tacmach.refine_no_check new_hyp_prf) in let naming = NamingMustBe (dloc,targetid) in let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS (clear_metas clenv.evd)) (if sidecond_first then Tacticals.New.tclTHENFIRST (assert_before_then_gen with_clear naming new_hyp_typ tac) exact_tac else Tacticals.New.tclTHENLAST (assert_after_then_gen with_clear naming new_hyp_typ tac) exact_tac) (********************************************) (* Elimination tactics *) (********************************************) let last_arg c = match kind_of_term c with | App (f,cl) -> Array.last cl | _ -> anomaly (Pp.str "last_arg") let nth_arg i c = if Int.equal i (-1) then last_arg c else match kind_of_term c with | App (f,cl) -> cl.(i) | _ -> anomaly (Pp.str "nth_arg") let index_of_ind_arg t = let rec aux i j t = match kind_of_term t with | Prod (_,t,u) -> (* heuristic *) if isInd (fst (decompose_app t)) then aux (Some j) (j+1) u else aux i (j+1) u | _ -> match i with | Some i -> i | None -> error "Could not find inductive argument of elimination scheme." in aux None 0 t let enforce_prop_bound_names rename tac = let open Context.Rel.Declaration in match rename with | Some (isrec,nn) when Namegen.use_h_based_elimination_names () -> (* Rename dependent arguments in Prop with name "H" *) (* so as to avoid having hypothesis such as "t:True", "n:~A" when calling *) (* elim or induction with schemes built by Indrec.build_induction_scheme *) let rec aux env sigma i t = if i = 0 then t else match kind_of_term t with | Prod (Name _ as na,t,t') -> let very_standard = true in let na = if Retyping.get_sort_family_of env sigma t = InProp then (* "very_standard" says that we should have "H" names only, but this would break compatibility even more... *) let s = match Namegen.head_name t with | Some id when not very_standard -> string_of_id id | _ -> "" in Name (add_suffix Namegen.default_prop_ident s) else na in mkProd (na,t,aux (push_rel (LocalAssum (na,t)) env) sigma (i-1) t') | Prod (Anonymous,t,t') -> mkProd (Anonymous,t,aux (push_rel (LocalAssum (Anonymous,t)) env) sigma (i-1) t') | LetIn (na,c,t,t') -> mkLetIn (na,c,t,aux (push_rel (LocalDef (na,c,t)) env) sigma (i-1) t') | _ -> print_int i; Feedback.msg_notice (print_constr t); assert false in let rename_branch i = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let t = Proofview.Goal.concl gl in change_concl (aux env sigma i t) end } in (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) tac (Array.map rename_branch nn) | _ -> tac let rec contract_letin_in_lam_header c = match kind_of_term c with | Lambda (x,t,c) -> mkLambda (x,t,contract_letin_in_lam_header c) | LetIn (x,b,t,c) -> contract_letin_in_lam_header (subst1 b c) | _ -> c let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) rename i (elim, elimty, bindings) indclause = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let elim = contract_letin_in_lam_header elim in let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in let indmv = (match kind_of_term (nth_arg i elimclause.templval.rebus) with | Meta mv -> mv | _ -> errorlabstrm "elimination_clause" (str "The type of elimination clause is not well-formed.")) in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in enforce_prop_bound_names rename (Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags) end } (* * Elimination tactic with bindings and using an arbitrary * elimination constant called elimc. This constant should end * with a clause (x:I)(P .. ), where P is a bound variable. * The term c is of type t, which is a product ending with a type * matching I, lbindc are the expected terms for c arguments *) type eliminator = { elimindex : int option; (* None = find it automatically *) elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *) elimbody : constr with_bindings } let general_elim_clause_gen elimtac indclause elim = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (elimc,lbindelimc) = elim.elimbody in let elimt = Retyping.get_type_of env sigma elimc in let i = match elim.elimindex with None -> index_of_ind_arg elimt | Some i -> i in elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause end } let general_elim with_evars clear_flag (c, lbindc) elim = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ct = Retyping.get_type_of env sigma c in let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in let elimtac = elimination_clause_scheme with_evars in let indclause = make_clenv_binding env sigma (c, t) lbindc in let sigma = meta_merge sigma (clear_metas indclause.evd) in Proofview.Unsafe.tclEVARS sigma <*> Tacticals.New.tclTHEN (general_elim_clause_gen elimtac indclause elim) (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c) end } (* Case analysis tactics *) let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in let sort = Tacticals.New.elimination_sort_of_goal gl in let Sigma (elim, sigma, p) = if occur_term c concl then build_case_analysis_scheme env sigma mind true sort else build_case_analysis_scheme_default env sigma mind sort in let tac = (general_elim with_evars clear_flag (c,lbindc) {elimindex = None; elimbody = (elim,NoBindings); elimrename = Some (false, constructors_nrealdecls (fst mind))}) in Sigma (tac, sigma, p) end } let general_case_analysis with_evars clear_flag (c,lbindc as cx) = match kind_of_term c with | Var id when lbindc == NoBindings -> Tacticals.New.tclTHEN (try_intros_until_id_check id) (general_case_analysis_in_context with_evars clear_flag cx) | _ -> general_case_analysis_in_context with_evars clear_flag cx let simplest_case c = general_case_analysis false None (c,NoBindings) let simplest_ecase c = general_case_analysis true None (c,NoBindings) (* Elimination tactic with bindings but using the default elimination * constant associated with the type. *) exception IsNonrec let is_nonrec mind = (Global.lookup_mind (fst mind)).mind_finite == Decl_kinds.BiFinite let find_ind_eliminator ind s gl = let gr = lookup_eliminator ind s in let evd, c = Tacmach.New.pf_apply Evd.fresh_global gl gr in evd, c let find_eliminator c gl = let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_unsafe_type_of gl c) in if is_nonrec ind then raise IsNonrec; let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in evd, {elimindex = None; elimbody = (c,NoBindings); elimrename = Some (true, constructors_nrealdecls ind)} let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE (Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma, elim = find_eliminator c gl in let tac = (general_elim with_evars clear_flag cx elim) in Sigma.Unsafe.of_pair (tac, sigma) end }) begin function (e, info) -> match e with | IsNonrec -> (* For records, induction principles aren't there by default anymore. Instead, we do a case analysis. *) general_case_analysis with_evars clear_flag cx | e -> Proofview.tclZERO ~info e end let elim_in_context with_evars clear_flag c = function | Some elim -> general_elim with_evars clear_flag c {elimindex = Some (-1); elimbody = elim; elimrename = None} | None -> default_elim with_evars clear_flag c let elim with_evars clear_flag (c,lbindc as cx) elim = match kind_of_term c with | Var id when lbindc == NoBindings -> Tacticals.New.tclTHEN (try_intros_until_id_check id) (elim_in_context with_evars clear_flag cx elim) | _ -> elim_in_context with_evars clear_flag cx elim (* The simplest elimination tactic, with no substitutions at all. *) let simplest_elim c = default_elim false None (c,NoBindings) (* Elimination in hypothesis *) (* Typically, elimclause := (eq_ind ?x ?P ?H ?y ?Heq : ?P ?y) indclause : forall ..., hyps -> a=b (to take place of ?Heq) id : phi(a) (to take place of ?H) and the result is to overwrite id with the proof of phi(b) but this generalizes to any elimination scheme with one constructor (e.g. it could replace id:A->B->C by id:C, knowing A/\B) *) let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = (** The evarmap of elimclause is assumed to be an extension of hypclause, so we do not need to merge the universes coming from hypclause. *) try clenv_fchain ~with_univs:false ~flags mv elimclause hypclause with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> (* Set the hypothesis name in the message *) raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) id rename i (elim, elimty, bindings) indclause = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let elim = contract_letin_in_lam_header elim in let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in let indmv = destMeta (nth_arg i elimclause.templval.rebus) in let hypmv = try match List.remove Int.equal indmv (clenv_independent elimclause) with | [a] -> a | _ -> failwith "" with Failure _ -> errorlabstrm "elimination_clause" (str "The type of elimination clause is not well-formed.") in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in let hyp = mkVar id in let hyp_typ = Retyping.get_type_of env sigma hyp in let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in if Term.eq_constr hyp_typ new_hyp_typ then errorlabstrm "general_rewrite_in" (str "Nothing to rewrite in " ++ pr_id id ++ str"."); clenv_refine_in with_evars id id sigma elimclause'' (fun id -> Proofview.tclUNIT ()) end } let general_elim_clause with_evars flags id c e = let elim = match id with | None -> elimination_clause_scheme with_evars ~with_classes:true ~flags | Some id -> elimination_in_clause_scheme with_evars ~flags id in general_elim_clause_gen elim c e (* Apply a tactic below the products of the conclusion of a lemma *) type conjunction_status = | DefinedRecord of constant option list | NotADefinedRecordUseScheme of constr let make_projection env sigma params cstr sign elim i n c u = let open Context.Rel.Declaration in let elim = match elim with | NotADefinedRecordUseScheme elim -> (* bugs: goes from right to left when i increases! *) let decl = List.nth cstr.cs_args i in let t = get_type decl in let b = match decl with LocalAssum _ -> mkRel (i+1) | LocalDef (_,b,_) -> b in let branch = it_mkLambda_or_LetIn b cstr.cs_args in if (* excludes dependent projection types *) noccur_between 1 (n-i-1) t (* to avoid surprising unifications, excludes flexible projection types or lambda which will be instantiated by Meta/Evar *) && not (isEvar (fst (whd_betaiota_stack sigma t))) && (accept_universal_lemma_under_conjunctions () || not (isRel t)) then let t = lift (i+1-n) t in let abselim = beta_applist (elim,params@[t;branch]) in let c = beta_applist (abselim, [mkApp (c, Context.Rel.to_extended_vect 0 sign)]) in Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) else None | DefinedRecord l -> (* goes from left to right when i increases! *) match List.nth l i with | Some proj -> let args = Context.Rel.to_extended_vect 0 sign in let proj = if Environ.is_projection proj env then mkProj (Projection.make proj false, mkApp (c, args)) else mkApp (mkConstU (proj,u), Array.append (Array.of_list params) [|mkApp (c, args)|]) in let app = it_mkLambda_or_LetIn proj sign in let t = Retyping.get_type_of env sigma app in Some (app, t) | None -> None in elim let descend_in_conjunctions avoid tac (err, info) c = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try let t = Retyping.get_type_of env sigma c in let ((ind,u),t) = reduce_to_quantified_ind env sigma t in let sign,ccl = decompose_prod_assum t in match match_with_tuple ccl with | Some (_,_,isrec) -> let n = (constructors_nrealargs ind).(0) in let sort = Tacticals.New.elimination_sort_of_goal gl in let IndType (indf,_) = find_rectype env sigma ccl in let (_,inst), params = dest_ind_family indf in let cstr = (get_constructors env indf).(0) in let elim = try DefinedRecord (Recordops.lookup_projections ind) with Not_found -> let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (elim, _, _) = build_case_analysis_scheme env sigma (ind,u) false sort in NotADefinedRecordUseScheme elim in Tacticals.New.tclORELSE0 (Tacticals.New.tclFIRST (List.init n (fun i -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match make_projection env sigma params cstr sign elim i n c u with | None -> Tacticals.New.tclFAIL 0 (mt()) | Some (p,pt) -> Tacticals.New.tclTHENS (assert_before_gen false (NamingAvoid avoid) pt) [Proofview.V82.tactic (refine p); (* Might be ill-typed due to forbidden elimination. *) Tacticals.New.onLastHypId (tac (not isrec))] end }))) (Proofview.tclZERO ~info err) | None -> Proofview.tclZERO ~info err with RefinerError _|UserError _ -> Proofview.tclZERO ~info err end } (****************************************************) (* Resolution tactics *) (****************************************************) let solve_remaining_apply_goals = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in if !apply_solve_class_goals then try let env = Proofview.Goal.env gl in let evd = Sigma.to_evar_map sigma in let concl = Proofview.Goal.concl gl in if Typeclasses.is_class_type evd concl then let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in let tac = Refine.refine ~unsafe:true { run = fun h -> Sigma.here c' h } in Sigma.Unsafe.of_pair (tac, evd') else Sigma.here (Proofview.tclUNIT ()) sigma with Not_found -> Sigma.here (Proofview.tclUNIT ()) sigma else Sigma.here (Proofview.tclUNIT ()) sigma end } let tclORELSEOPT t k = Proofview.tclORELSE t (fun e -> match k e with | None -> let (e, info) = e in Proofview.tclZERO ~info e | Some tac -> tac) let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let flags = if with_delta then default_unify_flags () else default_no_delta_unify_flags () in (* The actual type of the theorem. It will be matched against the goal. If this fails, then the head constant will be unfolded step by step. *) let concl_nprod = nb_prod_modulo_zeta concl in let rec try_main_apply with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let thm_ty0 = nf_betaiota sigma (Retyping.get_type_of env sigma c) in let try_apply thm_ty nprod = try let n = nb_prod_modulo_zeta thm_ty - nprod in if n<0 then error "Applied theorem has not enough premisses."; let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in Clenvtac.res_pf clause ~with_evars ~flags with exn when catchable_exception exn -> Proofview.tclZERO exn in let rec try_red_apply thm_ty (exn0, info) = try (* Try to head-reduce the conclusion of the theorem *) let red_thm = try_red_product env sigma thm_ty in tclORELSEOPT (try_apply red_thm concl_nprod) (function (e, info) -> match e with | PretypeError _|RefinerError _|UserError _|Failure _ -> Some (try_red_apply red_thm (exn0, info)) | _ -> None) with Redelimination -> (* Last chance: if the head is a variable, apply may try second order unification *) let info = Loc.add_loc info loc in let tac = if with_destruct then descend_in_conjunctions [] (fun b id -> Tacticals.New.tclTHEN (try_main_apply b (mkVar id)) (clear [id])) (exn0, info) c else Proofview.tclZERO ~info exn0 in if not (Int.equal concl_nprod 0) then tclORELSEOPT (try_apply thm_ty 0) (function (e, info) -> match e with | PretypeError _|RefinerError _|UserError _|Failure _-> Some tac | _ -> None) else tac in tclORELSEOPT (try_apply thm_ty0 concl_nprod) (function (e, info) -> match e with | PretypeError _|RefinerError _|UserError _|Failure _ -> Some (try_red_apply thm_ty0 (e, info)) | _ -> None) end } in Tacticals.New.tclTHENLIST [ try_main_apply with_destruct c; solve_remaining_apply_goals; apply_clear_request clear_flag (use_clear_hyp_by_default ()) c ] end } let rec apply_with_bindings_gen b e = function | [] -> Proofview.tclUNIT () | [k,cb] -> general_apply b b e k cb | (k,cb)::cbl -> Tacticals.New.tclTHENLAST (general_apply b b e k cb) (apply_with_bindings_gen b e cbl) let apply_with_delayed_bindings_gen b e l = let one k (loc, f) = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (cb, sigma) = run_delayed env sigma f in Tacticals.New.tclWITHHOLES e (general_apply b b e k (loc,cb)) sigma end } in let rec aux = function | [] -> Proofview.tclUNIT () | [k,f] -> one k f | (k,f)::cbl -> Tacticals.New.tclTHENLAST (one k f) (aux cbl) in aux l let apply_with_bindings cb = apply_with_bindings_gen false false [None,(dloc,cb)] let eapply_with_bindings cb = apply_with_bindings_gen false true [None,(dloc,cb)] let apply c = apply_with_bindings_gen false false [None,(dloc,(c,NoBindings))] let eapply c = apply_with_bindings_gen false true [None,(dloc,(c,NoBindings))] let apply_list = function | c::l -> apply_with_bindings (c,ImplicitBindings l) | _ -> assert false (* [apply_in hyp c] replaces hyp : forall y1, ti -> t hyp : rho(u) ======================== with ============ and the ======= goal goal rho(ti) assuming that [c] has type [forall x1..xn -> t' -> u] for some [t] unifiable with [t'] with unifier [rho] *) let find_matching_clause unifier clause = let rec find clause = try unifier clause with e when catchable_exception e -> try find (clenv_push_prod clause) with NotExtensibleClause -> failwith "Cannot apply" in find clause let progress_with_clause flags innerclause clause = let ordered_metas = List.rev (clenv_independent clause) in if List.is_empty ordered_metas then error "Statement without assumptions."; let f mv = try Some (find_matching_clause (clenv_fchain ~with_univs:false mv ~flags clause) innerclause) with Failure _ -> None in try List.find_map f ordered_metas with Not_found -> error "Unable to unify." let apply_in_once_main flags innerclause env sigma (d,lbind) = let thm = nf_betaiota sigma (Retyping.get_type_of env sigma d) in let rec aux clause = try progress_with_clause flags innerclause clause with e when CErrors.noncritical e -> let e = CErrors.push e in try aux (clenv_push_prod clause) with NotExtensibleClause -> iraise e in aux (make_clenv_binding env sigma (d,thm) lbind) let apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,(d,lbind))) tac = let open Context.Rel.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let flags = if with_delta then default_unify_flags () else default_no_delta_unify_flags () in let t' = Tacmach.New.pf_get_hyp_typ id gl in let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in let targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in let rec aux idstoclear with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try let clause = apply_in_once_main flags innerclause env sigma (c,lbind) in clenv_refine_in ~sidecond_first with_evars targetid id sigma clause (fun id -> Tacticals.New.tclTHENLIST [ apply_clear_request clear_flag false c; clear idstoclear; tac id ]) with e when with_destruct && CErrors.noncritical e -> let (e, info) = CErrors.push e in (descend_in_conjunctions [targetid] (fun b id -> aux (id::idstoclear) b (mkVar id)) (e, info) c) end } in aux [] with_destruct d end } let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,f)) tac = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (c, sigma) = run_delayed env sigma f in Tacticals.New.tclWITHHOLES with_evars (apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,c)) tac) sigma end } (* A useful resolution tactic which, if c:A->B, transforms |- C into |- B -> C and |- A ------------------- Gamma |- c : A -> B Gamma |- ?2 : A ---------------------------------------- Gamma |- B Gamma |- ?1 : B -> C ----------------------------------------------------- Gamma |- ? : C Ltac lapply c := let ty := check c in match eval hnf in ty with ?A -> ?B => cut B; [ idtac | apply c ] end. *) let cut_and_apply c = Proofview.Goal.nf_enter { enter = begin fun gl -> match kind_of_term (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_unsafe_type_of gl c)) with | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) -> let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in Refine.refine { run = begin fun sigma -> let typ = mkProd (Anonymous, c2, concl) in let Sigma (f, sigma, p) = Evarutil.new_evar env sigma typ in let Sigma (x, sigma, q) = Evarutil.new_evar env sigma c1 in let ans = mkApp (f, [|mkApp (c, [|x|])|]) in Sigma (ans, sigma, p +> q) end } | _ -> error "lapply needs a non-dependent product." end } (********************************************************************) (* Exact tactics *) (********************************************************************) (* let convert_leqkey = Profile.declare_profile "convert_leq";; *) (* let convert_leq = Profile.profile3 convert_leqkey convert_leq *) (* let refine_no_checkkey = Profile.declare_profile "refine_no_check";; *) (* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) let exact_no_check c = Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } let exact_check c = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in (** We do not need to normalize the goal because we just check convertibility *) let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let sigma, ct = Typing.type_of env sigma c in let tac = Tacticals.New.tclTHEN (convert_leq ct concl) (exact_no_check c) in Sigma.Unsafe.of_pair (tac, sigma) end } let cast_no_check cast c = Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in exact_no_check (Term.mkCast (c, cast, concl)) end } let vm_cast_no_check c = cast_no_check Term.VMcast c let native_cast_no_check c = cast_no_check Term.NATIVEcast c let exact_proof c = let open Tacmach.New in Proofview.Goal.nf_enter { enter = begin fun gl -> Refine.refine { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in let (c, ctx) = Constrintern.interp_casted_constr (pf_env gl) sigma c (pf_concl gl) in let sigma = Evd.merge_universe_context sigma ctx in Sigma.Unsafe.of_pair (c, sigma) end } end } let assumption = let open Context.Named.Declaration in let rec arec gl only_eq = function | [] -> if only_eq then let hyps = Proofview.Goal.hyps gl in arec gl false hyps else Tacticals.New.tclZEROMSG (str "No such assumption.") | decl::rest -> let t = get_type decl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let (sigma, is_same_type) = if only_eq then (sigma, Constr.equal t concl) else let env = Proofview.Goal.env gl in infer_conv env sigma t concl in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> exact_no_check (mkVar (get_id decl)) else arec gl only_eq rest in let assumption_tac = { enter = begin fun gl -> let hyps = Proofview.Goal.hyps gl in arec gl true hyps end } in Proofview.Goal.nf_enter assumption_tac (*****************************************************************) (* Modification of a local context *) (*****************************************************************) let on_the_bodies = function | [] -> assert false | [id] -> str " depends on the body of " ++ pr_id id | l -> str " depends on the bodies of " ++ pr_sequence pr_id l exception DependsOnBody of Id.t option let check_is_type env sigma ty = let evdref = ref sigma in try let _ = Typing.e_sort_of env evdref ty in !evdref with e when CErrors.noncritical e -> raise (DependsOnBody None) let check_decl env sigma decl = let open Context.Named.Declaration in let ty = get_type decl in let evdref = ref sigma in try let _ = Typing.e_sort_of env evdref ty in let _ = match decl with | LocalAssum _ -> () | LocalDef (_,c,_) -> Typing.e_check env evdref c ty in !evdref with e when CErrors.noncritical e -> let id = get_id decl in raise (DependsOnBody (Some id)) let clear_body ids = let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let sigma = Tacmach.New.project gl in let ctx = named_context env in let map = function | LocalAssum (id,t) as decl -> let () = if List.mem_f Id.equal id ids then errorlabstrm "" (str "Hypothesis " ++ pr_id id ++ str " is not a local definition") in decl | LocalDef (id,_,t) as decl -> if List.mem_f Id.equal id ids then LocalAssum (id, t) else decl in let ctx = List.map map ctx in let base_env = reset_context env in let env = push_named_context ctx base_env in let check = try let check (env, sigma, seen) decl = (** Do no recheck hypotheses that do not depend *) let sigma = if not seen then sigma else if List.exists (fun id -> occur_var_in_decl env id decl) ids then check_decl env sigma decl else sigma in let seen = seen || List.mem_f Id.equal (get_id decl) ids in (push_named decl env, sigma, seen) in let (env, sigma, _) = List.fold_left check (base_env, sigma, false) (List.rev ctx) in let sigma = if List.exists (fun id -> occur_var env id concl) ids then check_is_type env sigma concl else sigma in Proofview.Unsafe.tclEVARS sigma with DependsOnBody where -> let msg = match where with | None -> str "Conclusion" ++ on_the_bodies ids | Some id -> str "Hypothesis " ++ pr_id id ++ on_the_bodies ids in Tacticals.New.tclZEROMSG msg in check <*> Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar env sigma ~principal:true concl end } end } let clear_wildcards ids = Tacticals.New.tclMAP (fun (loc, id) -> clear [id]) ids (* Takes a list of booleans, and introduces all the variables * quantified in the goal which are associated with a value * true in the boolean list. *) let rec intros_clearing = function | [] -> Proofview.tclUNIT () | (false::tl) -> Tacticals.New.tclTHEN intro (intros_clearing tl) | (true::tl) -> Tacticals.New.tclTHENLIST [ intro; Tacticals.New.onLastHypId (fun id -> clear [id]); intros_clearing tl] (* Keeping only a few hypotheses *) let keep hyps = let open Context.Named.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> Proofview.tclENV >>= fun env -> let ccl = Proofview.Goal.concl gl in let cl,_ = fold_named_context_reverse (fun (clear,keep) decl -> let hyp = get_id decl in if Id.List.mem hyp hyps || List.exists (occur_var_in_decl env hyp) keep || occur_var env hyp ccl then (clear,decl::keep) else (hyp::clear,keep)) ~init:([],[]) (Proofview.Goal.env gl) in clear cl end } (*********************************) (* Basic generalization tactics *) (*********************************) (* Given a type [T] convertible to [forall x1..xn:A1..An(x1..xn-1), G(x1..xn)] and [a1..an:A1..An(a1..an-1)] such that the goal is [G(a1..an)], this generalizes [hyps |- goal] into [hyps |- T] *) let apply_type newcl args = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in Refine.refine { run = begin fun sigma -> let newcl = nf_betaiota (Sigma.to_evar_map sigma) newcl (* As in former Logic.refine *) in let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store newcl in Sigma (applist (ev, args), sigma, p) end } end } (* Given a context [hyps] with domain [x1..xn], possibly with let-ins, and well-typed in the current goal, [bring_hyps hyps] generalizes [ctxt |- G(x1..xn] into [ctxt |- forall hyps, G(x1..xn)] *) let bring_hyps hyps = if List.is_empty hyps then Tacticals.New.tclIDTAC else Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let concl = Tacmach.New.pf_nf_concl gl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in let args = Array.of_list (Context.Named.to_instance hyps) in Refine.refine { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store newcl in Sigma (mkApp (ev, args), sigma, p) end } end } let revert hyps = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in (bring_hyps ctx) <*> (clear hyps) end } (************************) (* Introduction tactics *) (************************) let check_number_of_constructors expctdnumopt i nconstr = if Int.equal i 0 then error "The constructors are numbered starting from 1."; begin match expctdnumopt with | Some n when not (Int.equal n nconstr) -> errorlabstrm "Tactics.check_number_of_constructors" (str "Not an inductive goal with " ++ int n ++ str (String.plural n " constructor") ++ str ".") | _ -> () end; if i > nconstr then error "Not enough constructors." let constructor_tac with_evars expctdnumopt i lbind = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let cl = Tacmach.New.pf_nf_concl gl in let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl in let (mind,redcl) = reduce_to_quantified_ind cl in let nconstr = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; let Sigma (cons, sigma, p) = Sigma.fresh_constructor_instance (Proofview.Goal.env gl) sigma (fst mind, i) in let cons = mkConstructU cons in let apply_tac = general_apply true false with_evars None (dloc,(cons,lbind)) in let tac = (Tacticals.New.tclTHENLIST [ convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) in Sigma (tac, sigma, p) end } let one_constructor i lbind = constructor_tac false None i lbind (* Try to apply the constructor of the inductive definition followed by a tactic t given as an argument. Should be generalize in Constructor (Fun c : I -> tactic) *) let rec tclANY tac = function | [] -> Tacticals.New.tclZEROMSG (str "No applicable tactic.") | arg :: l -> Tacticals.New.tclORD (tac arg) (fun () -> tclANY tac l) let any_constructor with_evars tacopt = let t = match tacopt with None -> Proofview.tclUNIT () | Some t -> t in let tac i = Tacticals.New.tclTHEN (constructor_tac with_evars None i NoBindings) t in Proofview.Goal.enter { enter = begin fun gl -> let cl = Tacmach.New.pf_nf_concl gl in let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl in let mind = fst (reduce_to_quantified_ind cl) in let nconstr = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in if Int.equal nconstr 0 then error "The type has no constructors."; tclANY tac (List.interval 1 nconstr) end } let left_with_bindings with_evars = constructor_tac with_evars (Some 2) 1 let right_with_bindings with_evars = constructor_tac with_evars (Some 2) 2 let split_with_bindings with_evars l = Tacticals.New.tclMAP (constructor_tac with_evars (Some 1) 1) l let left = left_with_bindings false let simplest_left = left NoBindings let right = right_with_bindings false let simplest_right = right NoBindings let split = constructor_tac false (Some 1) 1 let simplest_split = split NoBindings (*****************************) (* Decomposing introductions *) (*****************************) (* Rewriting function for rewriting one hypothesis at the time *) let (forward_general_rewrite_clause, general_rewrite_clause) = Hook.make () (* Rewriting function for substitution (x=t) everywhere at the same time *) let (forward_subst_one, subst_one) = Hook.make () let error_unexpected_extra_pattern loc bound pat = let _,nb = Option.get bound in let s1,s2,s3 = match pat with | IntroNaming (IntroIdentifier _) -> "name", (String.plural nb " introduction pattern"), "no" | _ -> "introduction pattern", "", "none" in user_err_loc (loc,"",str "Unexpected " ++ str s1 ++ str " (" ++ (if Int.equal nb 0 then (str s3 ++ str s2) else (str "at most " ++ int nb ++ str s2)) ++ spc () ++ str (if Int.equal nb 1 then "was" else "were") ++ strbrk " expected in the branch).") let intro_decomp_eq_function = ref (fun _ -> failwith "Not implemented") let declare_intro_decomp_eq f = intro_decomp_eq_function := f let my_find_eq_data_decompose gl t = try Some (find_eq_data_decompose gl t) with e when is_anomaly e (* Hack in case equality is not yet defined... one day, maybe, known equalities will be dynamically registered *) -> None | Constr_matching.PatternMatchingFailure -> None let intro_decomp_eq loc l thin tac id = Proofview.Goal.nf_enter { enter = begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in match my_find_eq_data_decompose gl t with | Some (eq,u,eq_args) -> !intro_decomp_eq_function (fun n -> tac ((dloc,id)::thin) (Some (true,n)) l) (eq,t,eq_args) (c, t) | None -> Tacticals.New.tclZEROMSG (str "Not a primitive equality here.") end } let intro_or_and_pattern loc with_evars bracketed ll thin tac id = Proofview.Goal.enter { enter = begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in let branchsigns = compute_constructor_signatures false ind in let nv_with_let = Array.map List.length branchsigns in let ll = fix_empty_or_and_pattern (Array.length branchsigns) ll in let ll = get_and_check_or_and_pattern loc ll branchsigns in Tacticals.New.tclTHENLASTn (Tacticals.New.tclTHEN (simplest_ecase c) (clear [id])) (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l) nv_with_let ll) end } let rewrite_hyp_then assert_style with_evars thin l2r id tac = let rew_on l2r = Hook.get forward_general_rewrite_clause l2r with_evars (mkVar id,NoBindings) in let subst_on l2r x rhs = Hook.get forward_subst_one true x (id,rhs,l2r) in let clear_var_and_eq id' = clear [id';id] in let early_clear id' thin = List.filter (fun (_,id) -> not (Id.equal id id')) thin in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_all = Tacmach.New.pf_apply whd_all gl in let t = whd_all (type_of (mkVar id)) in let eqtac, thin = match match_with_equality_type t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r && isVar lhs && not (occur_var env (destVar lhs) rhs) then let id' = destVar lhs in subst_on l2r id' rhs, early_clear id' thin else if not l2r && isVar rhs && not (occur_var env (destVar rhs) lhs) then let id' = destVar rhs in subst_on l2r id' lhs, early_clear id' thin else Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), thin | Some (hdcncl,[c]) -> let l2r = not l2r in (* equality of the form eq_true *) if isVar c then let id' = destVar c in Tacticals.New.tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq id'), early_clear id' thin else Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), thin | _ -> Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), thin in (* Skip the side conditions of the rewriting step *) Tacticals.New.tclTHENFIRST eqtac (tac thin) end } let prepare_naming loc = function | IntroIdentifier id -> NamingMustBe (loc,id) | IntroAnonymous -> NamingAvoid [] | IntroFresh id -> NamingBasedOn (id,[]) let rec explicit_intro_names = function | (_, IntroForthcoming _) :: l -> explicit_intro_names l | (_, IntroNaming (IntroIdentifier id)) :: l -> id :: explicit_intro_names l | (_, IntroAction (IntroOrAndPattern l)) :: l' -> let ll = match l with IntroAndPattern l -> [l] | IntroOrPattern ll -> ll in List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll) | (_, IntroAction (IntroInjection l)) :: l' -> explicit_intro_names (l@l') | (_, IntroAction (IntroApplyOn (c,pat))) :: l' -> explicit_intro_names (pat::l') | (_, (IntroNaming (IntroAnonymous | IntroFresh _) | IntroAction (IntroWildcard | IntroRewrite _))) :: l -> explicit_intro_names l | [] -> [] let wild_id = Id.of_string "_tmp" let rec list_mem_assoc_right id = function | [] -> false | (x,id')::l -> Id.equal id id' || list_mem_assoc_right id l let check_thin_clash_then id thin avoid tac = if list_mem_assoc_right id thin then let newid = next_ident_away (add_suffix id "'") avoid in let thin = List.map (on_snd (fun id' -> if Id.equal id id' then newid else id')) thin in Tacticals.New.tclTHEN (rename_hyp [id,newid]) (tac thin) else tac thin let make_tmp_naming avoid l = function (* In theory, we could use a tmp id like "wild_id" for all actions but we prefer to avoid it to avoid this kind of "ugly" names *) (* Alternatively, we could have called check_thin_clash_then on IntroAnonymous, but at the cost of a "renaming"; Note that in the case of IntroFresh, we should use check_thin_clash_then anyway to prevent the case of an IntroFresh precisely using the wild_id *) | IntroWildcard -> NamingBasedOn (wild_id,avoid@explicit_intro_names l) | pat -> NamingAvoid(avoid@explicit_intro_names ((dloc,IntroAction pat)::l)) let fit_bound n = function | None -> true | Some (use_bound,n') -> not use_bound || n = n' let exceed_bound n = function | None -> false | Some (use_bound,n') -> use_bound && n >= n' (* We delay thinning until the completion of the whole intros tactic to ensure that dependent hypotheses are cleared in the right dependency order (see bug #1000); we use fresh names, not used in the tactic, for the hyps to clear *) (* In [intro_patterns_core b avoid ids thin destopt bound n tac patl]: [b]: compatibility flag, if false at toplevel, do not complete incomplete trailing toplevel or_and patterns (as in "intros []", see [bracketing_last_or_and_intro_pattern]) [avoid]: names to avoid when creating an internal name [ids]: collect introduced names for possible use by the [tac] continuation [thin]: collect names to erase at the end [destopt]: position in the context where to introduce the hypotheses [bound]: number of pending intros to do in the current or-and pattern, with remembering of [b] flag if at toplevel [n]: number of introduction done in the current or-and pattern [tac]: continuation tactic [patl]: introduction patterns to interpret *) let rec intro_patterns_core with_evars b avoid ids thin destopt bound n tac = function | [] when fit_bound n bound -> tac ids thin | [] -> (* Behave as IntroAnonymous *) intro_patterns_core with_evars b avoid ids thin destopt bound n tac [dloc,IntroNaming IntroAnonymous] | (loc,pat) :: l -> if exceed_bound n bound then error_unexpected_extra_pattern loc bound pat else match pat with | IntroForthcoming onlydeps -> intro_forthcoming_then_gen (NamingAvoid (avoid@explicit_intro_names l)) destopt onlydeps n bound (fun ids -> intro_patterns_core with_evars b avoid ids thin destopt bound (n+List.length ids) tac l) | IntroAction pat -> intro_then_gen (make_tmp_naming avoid l pat) destopt true false (intro_pattern_action loc with_evars (b || not (List.is_empty l)) false pat thin destopt (fun thin bound' -> intro_patterns_core with_evars b avoid ids thin destopt bound' 0 (fun ids thin -> intro_patterns_core with_evars b avoid ids thin destopt bound (n+1) tac l))) | IntroNaming pat -> intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound (n+1) tac l (* Pi-introduction rule, used backwards *) and intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound n tac l = match pat with | IntroIdentifier id -> check_thin_clash_then id thin avoid (fun thin -> intro_then_gen (NamingMustBe (loc,id)) destopt true false (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l)) | IntroAnonymous -> intro_then_gen (NamingAvoid (avoid@explicit_intro_names l)) destopt true false (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) | IntroFresh id -> (* todo: avoid thinned names to interfere with generation of fresh name *) intro_then_gen (NamingBasedOn (id, avoid@explicit_intro_names l)) destopt true false (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) and intro_pattern_action loc with_evars b style pat thin destopt tac id = match pat with | IntroWildcard -> tac ((loc,id)::thin) None [] | IntroOrAndPattern ll -> intro_or_and_pattern loc with_evars b ll thin tac id | IntroInjection l' -> intro_decomp_eq loc l' thin tac id | IntroRewrite l2r -> rewrite_hyp_then style with_evars thin l2r id (fun thin -> tac thin None []) | IntroApplyOn (f,(loc,pat)) -> let naming,tac_ipat = prepare_intros_loc loc with_evars (IntroIdentifier id) destopt pat in let doclear = if naming = NamingMustBe (loc,id) then Proofview.tclUNIT () (* apply_in_once do a replacement *) else clear [id] in let f = { delayed = fun env sigma -> let Sigma (c, sigma, p) = f.delayed env sigma in Sigma ((c, NoBindings), sigma, p) } in apply_in_delayed_once false true true with_evars naming id (None,(loc,f)) (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) and prepare_intros_loc loc with_evars dft destopt = function | IntroNaming ipat -> prepare_naming loc ipat, (fun id -> move_hyp id destopt) | IntroAction ipat -> prepare_naming loc dft, (let tac thin bound = intro_patterns_core with_evars true [] [] thin destopt bound 0 (fun _ l -> clear_wildcards l) in fun id -> intro_pattern_action loc with_evars true true ipat [] destopt tac id) | IntroForthcoming _ -> user_err_loc (loc,"",str "Introduction pattern for one hypothesis expected.") let intro_patterns_bound_to with_evars n destopt = intro_patterns_core with_evars true [] [] [] destopt (Some (true,n)) 0 (fun _ l -> clear_wildcards l) let intro_patterns_to with_evars destopt = intro_patterns_core with_evars (use_bracketing_last_or_and_intro_pattern ()) [] [] [] destopt None 0 (fun _ l -> clear_wildcards l) let intro_pattern_to with_evars destopt pat = intro_patterns_to with_evars destopt [dloc,pat] let intro_patterns with_evars = intro_patterns_to with_evars MoveLast (* Implements "intros" *) let intros_patterns with_evars = function | [] -> intros | l -> intro_patterns_to with_evars MoveLast l (**************************) (* Forward reasoning *) (**************************) let prepare_intros with_evars dft destopt = function | None -> prepare_naming dloc dft, (fun _id -> Proofview.tclUNIT ()) | Some (loc,ipat) -> prepare_intros_loc loc with_evars dft destopt ipat let ipat_of_name = function | Anonymous -> None | Name id -> Some (dloc, IntroNaming (IntroIdentifier id)) let head_ident c = let c = fst (decompose_app ((strip_lam_assum c))) in if isVar c then Some (destVar c) else None let assert_as first hd ipat t = let naming,tac = prepare_intros false IntroAnonymous MoveLast ipat in let repl = do_replace hd naming in let tac = if repl then (fun id -> Proofview.tclUNIT ()) else tac in if first then assert_before_then_gen repl naming t tac else assert_after_then_gen repl naming t tac (* apply in as *) let general_apply_in sidecond_first with_delta with_destruct with_evars id lemmas ipat = let tac (naming,lemma) tac id = apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id lemma tac in Proofview.Goal.enter { enter = begin fun gl -> let destopt = if with_evars then MoveLast (* evars would depend on the whole context *) else get_previous_hyp_position id gl in let naming,ipat_tac = prepare_intros with_evars (IntroIdentifier id) destopt ipat in let lemmas_target, last_lemma_target = let last,first = List.sep_last lemmas in List.map (fun lem -> (NamingMustBe (dloc,id),lem)) first, (naming,last) in (* We chain apply_in_once, ending with an intro pattern *) List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id end } (* if sidecond_first then (* Skip the side conditions of the applied lemma *) Tacticals.New.tclTHENLAST (tclMAPLAST tac lemmas_target) (ipat_tac id) else Tacticals.New.tclTHENFIRST (tclMAPFIRST tac lemmas_target) (ipat_tac id) *) let apply_in simple with_evars id lemmas ipat = let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, { delayed = fun _ sigma -> Sigma.here l sigma })) lemmas in general_apply_in false simple simple with_evars id lemmas ipat let apply_delayed_in simple with_evars id lemmas ipat = general_apply_in false simple simple with_evars id lemmas ipat (*****************************) (* Tactics abstracting terms *) (*****************************) (* Implementation without generalisation: abbrev will be lost in hyps in *) (* in the extracted proof *) let decode_hyp = function | None -> MoveLast | Some id -> MoveAfter id (* [letin_tac b (... abstract over c ...) gl] transforms [...x1:T1(c),...,x2:T2(c),... |- G(c)] into [...x:T;Heqx:(x=c);x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is false or [...x:=c:T;x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is true *) let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let Sigma (t, sigma, p) = match ty with | Some t -> Sigma.here t sigma | None -> let t = typ_of env sigma c in let sigma, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env (Sigma.to_evar_map sigma) t in Sigma.Unsafe.of_pair (c, sigma) in let Sigma ((newcl, eq_tac), sigma, q) = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl | IntroFresh heq_base -> new_fresh_id [id] heq_base gl | IntroIdentifier id -> id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in let Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let term = mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)) in let sigma = Sigma.to_evar_map sigma in let sigma, _ = Typing.type_of env sigma term in let ans = term, Tacticals.New.tclTHEN (intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false) (clear_body [heq;id]) in Sigma.Unsafe.of_pair (ans, sigma) | None -> Sigma.here (mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) sigma in let tac = Tacticals.New.tclTHENLIST [ convert_concl_no_check newcl DEFAULTcast; intro_gen (NamingMustBe (dloc,id)) (decode_hyp lastlhyp) true false; Tacticals.New.tclMAP convert_hyp_no_check depdecls; eq_tac ] in Sigma (tac, sigma, p +> q) end } let insert_before decls lasthyp env = let open Context.Named.Declaration in match lasthyp with | None -> push_named_context decls env | Some id -> Environ.fold_named_context (fun _ d env -> let env = if Id.equal id (get_id d) then push_named_context decls env else env in push_named d env) ~init:(reset_context env) env (* unsafe *) let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let open Context.Named.Declaration in let t = match ty with Some t -> t | _ -> typ_of env sigma c in let decl = if dep then LocalDef (id,c,t) else LocalAssum (id,t) in match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with | IntroAnonymous -> fresh_id_in_env [id] (add_prefix "Heq" id) env | IntroFresh heq_base -> fresh_id_in_env [id] heq_base env | IntroIdentifier id -> if List.mem id (ids_of_named_context (named_context env)) then user_err_loc (loc,"",pr_id id ++ str" is already used."); id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in let Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store ccl in Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p +> q +> r) | None -> let newenv = insert_before [decl] lastlhyp env in let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store ccl in Sigma (mkNamedLetIn id c t x, sigma, p) let letin_tac with_eq id c ty occs = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let abs = AbstractExact (id,c,ty,occs,true) in let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in (* We keep the original term to match but record the potential side-effects of unifying universes. *) let Sigma (c, sigma, p) = match res with | None -> Sigma.here c sigma | Some (Sigma (_, sigma, p)) -> Sigma (c, sigma, p) in let tac = letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty in Sigma (tac, sigma, p) end } let letin_pat_tac with_eq id c occs = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let check t = true in let abs = AbstractPattern (false,check,id,c,occs,false) in let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in let Sigma (c, sigma, p) = match res with | None -> finish_evar_resolution ~flags:(tactic_infer_flags false) env sigma c | Some res -> res in let tac = (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None) in Sigma (tac, sigma, p) end } (* Tactics "pose proof" (usetac=None) and "assert"/"enough" (otherwise) *) let forward b usetac ipat c = match usetac with | None -> Proofview.Goal.enter { enter = begin fun gl -> let t = Tacmach.New.pf_get_type_of gl c in let hd = head_ident c in Tacticals.New.tclTHENFIRST (assert_as true hd ipat t) (exact_no_check c) end } | Some tac -> let tac = match tac with | None -> Tacticals.New.tclIDTAC | Some tac -> Tacticals.New.tclCOMPLETE tac in if b then Tacticals.New.tclTHENFIRST (assert_as b None ipat c) tac else Tacticals.New.tclTHENS3PARTS (assert_as b None ipat c) [||] tac [|Tacticals.New.tclIDTAC|] let pose_proof na c = forward true None (ipat_of_name na) c let assert_by na t tac = forward true (Some (Some tac)) (ipat_of_name na) t let enough_by na t tac = forward false (Some (Some tac)) (ipat_of_name na) t (***************************) (* Generalization tactics *) (***************************) (* Compute a name for a generalization *) let generalized_name c t ids cl = function | Name id as na -> if Id.List.mem id ids then errorlabstrm "" (pr_id id ++ str " is already used."); na | Anonymous -> match kind_of_term c with | Var id -> (* Keep the name even if not occurring: may be used by intros later *) Name id | _ -> if noccurn 1 cl then Anonymous else (* On ne s'etait pas casse la tete : on avait pris pour nom de variable la premiere lettre du type, meme si "c" avait ete une constante dont on aurait pu prendre directement le nom *) named_hd (Global.env()) t Anonymous (* Abstract over [c] in [forall x1:A1(c)..xi:Ai(c).T(c)] producing [forall x, x1:A1(x1), .., xi:Ai(x). T(x)] with all [c] abtracted in [Ai] but only those at [occs] in [T] *) let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let open Context.Rel.Declaration in let decls,cl = decompose_prod_n_assum i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in let newdecls,_ = decompose_prod_n_assum i (subst_term_gen eq_constr_nounivs c dummy_prod) in let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name c t ids cl' na in let decl = match b with | None -> LocalAssum (na,t) | Some b -> LocalDef (na,b,t) in mkProd_or_LetIn decl cl', sigma' let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = let env = Tacmach.pf_env gl in let ids = Tacmach.pf_ids_of_hyps gl in let sigma, t = Typing.type_of env sigma c in generalize_goal_gen env sigma ids i o t cl let old_generalize_dep ?(with_let=false) c gl = let open Context.Named.Declaration in let env = pf_env gl in let sign = pf_hyps gl in let init_ids = ids_of_named_context (Global.named_context()) in let seek (d:Context.Named.Declaration.t) (toquant:Context.Named.t) = if List.exists (fun d' -> occur_var_in_decl env (get_id d') d) toquant || dependent_in_decl c d then d::toquant else toquant in let to_quantify = Context.Named.fold_outside seek sign ~init:[] in let to_quantify_rev = List.rev to_quantify in let qhyps = List.map get_id to_quantify_rev in let tothin = List.filter (fun id -> not (Id.List.mem id init_ids)) qhyps in let tothin' = match kind_of_term c with | Var id when mem_named_context_val id (val_of_named_context sign) && not (Id.List.mem id init_ids) -> id::tothin | _ -> tothin in let cl' = it_mkNamedProd_or_LetIn (Tacmach.pf_concl gl) to_quantify in let body = if with_let then match kind_of_term c with | Var id -> Tacmach.pf_get_hyp gl id |> get_value | _ -> None else None in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in (** Check that the generalization is indeed well-typed *) let (evd, _) = Typing.type_of env evd cl'' in let args = Context.Named.to_instance to_quantify_rev in tclTHENLIST [tclEVARS evd; Proofview.V82.of_tactic (apply_type cl'' (if Option.is_empty body then c::args else args)); Proofview.V82.of_tactic (clear (List.rev tothin'))] gl let generalize_dep ?(with_let = false) c = Proofview.V82.tactic (old_generalize_dep ~with_let c) (** *) let generalize_gen_let lconstr = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let newcl, evd = List.fold_right_i (Tacmach.New.of_old generalize_goal gl) 0 lconstr (Tacmach.New.pf_concl gl,Tacmach.New.project gl) in let (evd, _) = Typing.type_of env evd newcl in let map ((_, c, b),_) = if Option.is_empty b then Some c else None in let tac = apply_type newcl (List.map_filter map lconstr) in Sigma.Unsafe.of_pair (tac, evd) end } let new_generalize_gen_let lconstr = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let ids = Tacmach.New.pf_ids_of_hyps gl in let newcl, sigma, args = List.fold_right_i (fun i ((_,c,b),_ as o) (cl, sigma, args) -> let sigma, t = Typing.type_of env sigma c in let args = if Option.is_empty b then c :: args else args in let cl, sigma = generalize_goal_gen env sigma ids i o t cl in (cl, sigma, args)) 0 lconstr (concl, sigma, []) in let tac = Refine.refine { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true newcl in Sigma ((applist (ev, args)), sigma, p) end } in Sigma.Unsafe.of_pair (tac, sigma) end } let generalize_gen lconstr = generalize_gen_let (List.map (fun (occs_c,na) -> let (occs,c) = Redexpr.out_with_occurrences occs_c in (occs,c,None),na) lconstr) let new_generalize_gen lconstr = new_generalize_gen_let (List.map (fun ((occs,c),na) -> (occs,c,None),na) lconstr) let generalize l = new_generalize_gen_let (List.map (fun c -> ((AllOccurrences,c,None),Anonymous)) l) (* Faudra-t-il une version avec plusieurs args de generalize_dep ? Cela peut-être troublant de faire "Generalize Dependent H n" dans "n:nat; H:n=n |- P(n)" et d'échouer parce que H a disparu après la généralisation dépendante par n. let quantify lconstr = List.fold_right (fun com tac -> tclTHEN tac (tactic_com generalize_dep c)) lconstr tclIDTAC *) (* Modifying/Adding an hypothesis *) let specialize (c,lbind) ipat = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let sigma, term = if lbind == NoBindings then let sigma = Typeclasses.resolve_typeclasses env sigma in sigma, nf_evar sigma c else let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma c) lbind in let flags = { (default_unify_flags ()) with resolve_evars = true } in let clause = clenv_unify_meta_types ~flags clause in let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in let rec chk = function | [] -> [] | t::l -> if occur_meta t then [] else t :: chk l in let tstack = chk tstack in let term = applist(thd,List.map (nf_evar clause.evd) tstack) in if occur_meta term then errorlabstrm "" (str "Cannot infer an instance for " ++ pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ str "."); clause.evd, term in let typ = Retyping.get_type_of env sigma term in let tac = match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> (* Like assert (id:=id args) but with the concept of specialization *) let naming,tac = prepare_intros false (IntroIdentifier id) MoveLast ipat in let repl = do_replace (Some id) naming in Tacticals.New.tclTHENFIRST (assert_before_then_gen repl naming typ tac) (exact_no_check term) | _ -> match ipat with | None -> (* Like generalize with extra support for "with" bindings *) (* even though the "with" bindings forces full application *) Tacticals.New.tclTHENLAST (cut typ) (exact_no_check term) | Some (loc,ipat) -> (* Like pose proof with extra support for "with" bindings *) (* even though the "with" bindings forces full application *) let naming,tac = prepare_intros_loc loc false IntroAnonymous MoveLast ipat in Tacticals.New.tclTHENFIRST (assert_before_then_gen false naming typ tac) (exact_no_check term) in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac end } (*****************************) (* Ad hoc unfold *) (*****************************) (* The two following functions should already exist, but found nowhere *) (* Unfolds x by its definition everywhere *) let unfold_body x = let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> (** We normalize the given hypothesis immediately. *) let env = Proofview.Goal.env (Proofview.Goal.assume gl) in let xval = match Environ.lookup_named x env with | LocalAssum _ -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis.") | LocalDef (_,xval,_) -> xval in Tacticals.New.afterHyp x begin fun aft -> let hl = List.fold_right (fun decl cl -> (get_id decl, InHyp) :: cl) aft [] in let rfun _ _ c = replace_vars [x, xval] c in let reducth h = reduct_in_hyp rfun h in let reductc = reduct_in_concl (rfun, DEFAULTcast) in Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] end end } (* Either unfold and clear if defined or simply clear if not a definition *) let expand_hyp id = Tacticals.New.tclTRY (unfold_body id) <*> clear [id] (*****************************) (* High-level induction *) (*****************************) (* * A "natural" induction tactic * - [H0:T0, ..., Hi:Ti, hyp0:P->I(args), Hi+1:Ti+1, ..., Hn:Tn |-G] is the goal - [hyp0] is the induction hypothesis - we extract from [args] the variables which are not rigid parameters of the inductive type, this is [indvars] (other terms are forgotten); - we look for all hyps depending of [hyp0] or one of [indvars]: this is [dephyps] of types [deptyps] respectively - [statuslist] tells for each hyps in [dephyps] after which other hyp fixed in the context they must be moved (when induction is done) - [hyp0succ] is the name of the hyp fixed in the context after which to move the subterms of [hyp0succ] in the i-th branch where it is supposed to be the i-th constructor of the inductive type. Strategy: (cf in [induction_with_atomization_of_ind_arg]) - requantify and clear all [dephyps] - apply induction on [hyp0] - clear those of [indvars] that are variables and [hyp0] - in the i-th subgoal, intro the arguments of the i-th constructor of the inductive type after [hyp0succ] (done in [induct_discharge]) let the induction hypotheses on top of the hyps because they may depend on variables between [hyp0] and the top. A counterpart is that the dep hyps programmed to be intro-ed on top must now be intro-ed after the induction hypotheses - move each of [dephyps] at the right place following the [statuslist] *) let warn_unused_intro_pattern = CWarnings.create ~name:"unused-intro-pattern" ~category:"tactics" (fun names -> strbrk"Unused introduction " ++ str (String.plural (List.length names) "pattern") ++ str": " ++ prlist_with_sep spc (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (fst (run_delayed (Global.env()) Evd.empty c)))) names) let check_unused_names names = if not (List.is_empty names) && Flags.is_verbose () then warn_unused_intro_pattern names let intropattern_of_name gl avoid = function | Anonymous -> IntroNaming IntroAnonymous | Name id -> IntroNaming (IntroIdentifier (new_fresh_id avoid id gl)) let rec consume_pattern avoid na isdep gl = function | [] -> ((dloc, intropattern_of_name gl avoid na), []) | (loc,IntroForthcoming true)::names when not isdep -> consume_pattern avoid na isdep gl names | (loc,IntroForthcoming _)::names as fullpat -> let avoid = avoid@explicit_intro_names names in ((loc,intropattern_of_name gl avoid na), fullpat) | (loc,IntroNaming IntroAnonymous)::names -> let avoid = avoid@explicit_intro_names names in ((loc,intropattern_of_name gl avoid na), names) | (loc,IntroNaming (IntroFresh id'))::names -> let avoid = avoid@explicit_intro_names names in ((loc,IntroNaming (IntroIdentifier (new_fresh_id avoid id' gl))), names) | pat::names -> (pat,names) let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) = let tophyp = match tophyp with None -> MoveLast | Some hyp -> MoveAfter hyp in let newlstatus = (* if some IH has taken place at the top of hyps *) List.map (function (hyp,MoveLast) -> (hyp,tophyp) | x -> x) lstatus in Tacticals.New.tclTHEN (intros_move rstatus) (intros_move newlstatus) let dest_intro_patterns with_evars avoid thin dest pat tac = intro_patterns_core with_evars true avoid [] thin dest None 0 tac pat let safe_dest_intro_patterns with_evars avoid thin dest pat tac = Proofview.tclORELSE (dest_intro_patterns with_evars avoid thin dest pat tac) begin function (e, info) -> match e with | UserError ("move_hyp",_) -> (* May happen e.g. with "destruct x using s" with an hypothesis which is morally an induction hypothesis to be "MoveLast" if known as such but which is considered instead as a subterm of a constructor to be move at the place of x. *) dest_intro_patterns with_evars avoid thin MoveLast pat tac | e -> Proofview.tclZERO ~info e end type elim_arg_kind = RecArg | IndArg | OtherArg type recarg_position = | AfterFixedPosition of Id.t option (* None = top of context *) let update_dest (recargdests,tophyp as dests) = function | [] -> dests | hyp::_ -> (match recargdests with | AfterFixedPosition None -> AfterFixedPosition (Some hyp) | x -> x), (match tophyp with None -> Some hyp | x -> x) let get_recarg_dest (recargdests,tophyp) = match recargdests with | AfterFixedPosition None -> MoveLast | AfterFixedPosition (Some id) -> MoveAfter id (* Current policy re-introduces recursive arguments of destructed variable at the place of the original variable while induction hypothesese are introduced at the top of the context. Since in the general case of an inductive scheme, the induction hypotheses can arrive just after the recursive arguments (e.g. as in "forall t1:tree, P t1 -> forall t2:tree, P t2 -> P (node t1 t2)", we need to update the position for t2 after "P t1" is introduced if ever t2 had to be introduced at the top of the context). *) let induct_discharge with_evars dests avoid' tac (avoid,ra) names = let avoid = avoid @ avoid' in let rec peel_tac ra dests names thin = match ra with | (RecArg,_,deprec,recvarname) :: (IndArg,_,depind,hyprecname) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> let (recpat,names) = match names with | [loc,IntroNaming (IntroIdentifier id) as pat] -> let id' = next_ident_away (add_prefix "IH" id) avoid in (pat, [dloc, IntroNaming (IntroIdentifier id')]) | _ -> consume_pattern avoid (Name recvarname) deprec gl names in let dest = get_recarg_dest dests in dest_intro_patterns with_evars avoid thin dest [recpat] (fun ids thin -> Proofview.Goal.enter { enter = begin fun gl -> let (hyprec,names) = consume_pattern avoid (Name hyprecname) depind gl names in dest_intro_patterns with_evars avoid thin MoveLast [hyprec] (fun ids' thin -> peel_tac ra' (update_dest dests ids') names thin) end }) end } | (IndArg,_,dep,hyprecname) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> (* Rem: does not happen in Coq schemes, only in user-defined schemes *) let pat,names = consume_pattern avoid (Name hyprecname) dep gl names in dest_intro_patterns with_evars avoid thin MoveLast [pat] (fun ids thin -> peel_tac ra' (update_dest dests ids) names thin) end } | (RecArg,_,dep,recvarname) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> let (pat,names) = consume_pattern avoid (Name recvarname) dep gl names in let dest = get_recarg_dest dests in dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) end } | (OtherArg,_,dep,_) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> let (pat,names) = consume_pattern avoid Anonymous dep gl names in let dest = get_recarg_dest dests in safe_dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) end } | [] -> check_unused_names names; Tacticals.New.tclTHEN (clear_wildcards thin) (tac dests) in peel_tac ra dests names [] (* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas s'embêter à regarder si un letin_tac ne fait pas des substitutions aussi sur l'argument voisin *) let expand_projections env sigma c = let sigma = Sigma.to_evar_map sigma in let rec aux env c = match kind_of_term c with | Proj (p, c) -> Retyping.expand_projection env sigma p (aux env c) [] | _ -> map_constr_with_full_binders push_rel aux env c in aux env c (* Marche pas... faut prendre en compte l'occurrence précise... *) let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in let reduce_to_quantified_ref = Tacmach.New.pf_apply reduce_to_quantified_ref gl in let typ0 = reduce_to_quantified_ref indref tmptyp0 in let prods, indtyp = decompose_prod_assum typ0 in let hd,argl = decompose_app indtyp in let env' = push_rel_context prods env in let sigma = Proofview.Goal.sigma gl in let params = List.firstn nparams argl in let params' = List.map (expand_projections env' sigma) params in (* le gl est important pour ne pas préévaluer *) let rec atomize_one i args args' avoid = if Int.equal i nparams then let t = applist (hd, params@args) in Tacticals.New.tclTHEN (change_in_hyp None (make_change_arg t) (hyp0,InHypTypeOnly)) (tac avoid) else let c = List.nth argl (i-1) in match kind_of_term c with | Var id when not (List.exists (occur_var env id) args') && not (List.exists (occur_var env id) params') -> (* Based on the knowledge given by the user, all constraints on the variable are generalizable in the current environment so that it is clearable after destruction *) atomize_one (i-1) (c::args) (c::args') (id::avoid) | _ -> let c' = expand_projections env' sigma c in if List.exists (dependent c) params' || List.exists (dependent c) args' then (* This is a case where the argument is constrained in a way which would require some kind of inversion; we follow the (old) discipline of not generalizing over this term, since we don't try to invert the constraint anyway. *) atomize_one (i-1) (c::args) (c'::args') avoid else (* We reason blindly on the term and do as if it were generalizable, ignoring the constraints coming from its structure *) let id = match kind_of_term c with | Var id -> id | _ -> let type_of = Tacmach.New.pf_unsafe_type_of gl in id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) (atomize_one (i-1) (mkVar x::args) (mkVar x::args') (x::avoid)) in atomize_one (List.length argl) [] [] [] end } (* [cook_sign] builds the lists [beforetoclear] (preceding the ind. var.) and [aftertoclear] (coming after the ind. var.) of hyps that must be erased, the lists of hyps to be generalize [decldeps] on the goal together with the places [(lstatus,rstatus)] where to re-intro them after induction. To know where to re-intro the dep hyp, we remember the name of the hypothesis [lhyp] after which (if the dep hyp is more recent than [hyp0]) or [rhyp] before which (if older than [hyp0]) its equivalent must be moved when the induction has been applied. Since computation of dependencies and [rhyp] is from more ancient (on the right) to more recent hyp (on the left) but the computation of [lhyp] progresses from the other way, [cook_hyp] is in two passes (an alternative would have been to write an higher-order algorithm). We use references to reduce the accumulation of arguments. To summarize, the situation looks like this Goal(n,x) -| H6:(Q n); x:A; H5:True; H4:(le O n); H3:(P n); H2:True; n:nat Left Right Induction hypothesis is H4 ([hyp0]) Variable parameters of (le O n) is the singleton list with "n" ([indvars]) The dependent hyps are H3 and H6 ([dephyps]) For H3 the memorized places are H5 ([lhyp]) and H2 ([rhyp]) because these names are among the hyp which are fixed through the induction For H6 the neighbours are None ([lhyp]) and H5 ([rhyp]) For H3, because on the right of H4, we remember rhyp (here H2) For H6, because on the left of H4, we remember lhyp (here None) For H4, we remember lhyp (here H5) The right neighbour is then translated into the left neighbour because move_hyp tactic needs the name of the hyp _after_ which we move the hyp to move. But, say in the 2nd subgoal of the hypotheses, the goal will be (m:nat)((P m)->(Q m)->(Goal m)) -> (P Sm)-> (Q Sm)-> (Goal Sm) ^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^ both go where H4 was goes where goes where H3 was H6 was We have to intro and move m and the recursive hyp first, but then where to move H3 ??? Only the hyp on its right is relevant, but we have to translate it into the name of the hyp on the left Note: this case where some hyp(s) in [dephyps] has(have) the same left neighbour as [hyp0] is the only problematic case with right neighbours. For the other cases (e.g. an hyp H1:(R n) between n and H2 would have posed no problem. But for uniformity, we decided to use the right hyp for all hyps on the right of H4. Other solutions are welcome PC 9 fev 06: Adapted to accept multi argument principle with no main arg hyp. hyp0 is now optional, meaning that it is possible that there is no main induction hypotheses. In this case, we consider the last "parameter" (in [indvars]) as the limit between "left" and "right", BUT it must be included in indhyps. Other solutions are still welcome *) exception Shunt of Id.t move_location let cook_sign hyp0_opt inhyps indvars env = (* First phase from L to R: get [toclear], [decldep] and [statuslist] for the hypotheses before (= more ancient than) hyp0 (see above) *) let open Context.Named.Declaration in let toclear = ref [] in let avoid = ref [] in let decldeps = ref [] in let ldeps = ref [] in let rstatus = ref [] in let lstatus = ref [] in let before = ref true in let maindep = ref false in let seek_deps env decl rhyp = let hyp = get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then begin before:=false; (* Note that if there was no main induction hypotheses, then hyp is one of indvars too *) toclear := hyp::!toclear; MoveFirst (* fake value *) end else if Id.List.mem hyp indvars then begin (* The variables in indvars are such that they don't occur any more after generalization, so declare them to clear. *) toclear := hyp::!toclear; rhyp end else let dephyp0 = List.is_empty inhyps && (Option.cata (fun id -> occur_var_in_decl env id decl) false hyp0_opt) in let depother = List.is_empty inhyps && (List.exists (fun id -> occur_var_in_decl env id decl) indvars || List.exists (fun decl' -> occur_var_in_decl env (get_id decl') decl) !decldeps) in if not (List.is_empty inhyps) && Id.List.mem hyp inhyps || dephyp0 || depother then begin decldeps := decl::!decldeps; avoid := hyp::!avoid; maindep := dephyp0 || !maindep; if !before then begin toclear := hyp::!toclear; rstatus := (hyp,rhyp)::!rstatus end else begin toclear := hyp::!toclear; ldeps := hyp::!ldeps (* status computed in 2nd phase *) end; MoveBefore hyp end else MoveBefore hyp in let _ = fold_named_context seek_deps env ~init:MoveFirst in (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *) let compute_lstatus lhyp decl = let hyp = get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then raise (Shunt lhyp); if Id.List.mem hyp !ldeps then begin lstatus := (hyp,lhyp)::!lstatus; lhyp end else if Id.List.mem hyp !toclear then lhyp else MoveAfter hyp in try let _ = fold_named_context_reverse compute_lstatus ~init:MoveLast env in raise (Shunt MoveLast) (* ?? FIXME *) with Shunt lhyp0 -> let lhyp0 = match lhyp0 with | MoveLast -> None | MoveAfter hyp -> Some hyp | _ -> assert false in let statuslists = (!lstatus,List.rev !rstatus) in let recargdests = AfterFixedPosition (if Option.is_empty hyp0_opt then None else lhyp0) in (statuslists, (recargdests,None), !toclear, !decldeps, !avoid, !maindep) (* The general form of an induction principle is the following: forall prm1 prm2 ... prmp, (induction parameters) forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates) branch1, branch2, ... , branchr, (branches of the principle) forall (x1:Ti_1) (x2:Ti_2) ... (xni:Ti_ni), (induction arguments) (HI: I prm1..prmp x1...xni) (optional main induction arg) -> (Qi x1...xni HI (f prm1...prmp x1...xni)).(conclusion) ^^ ^^^^^^^^^^^^^^^^^^^^^^^^ optional optional argument added if even if HI principle generated by functional present above induction, only if HI does not exist [indarg] [farg] HI is not present when the induction principle does not come directly from an inductive type (like when it is generated by functional induction for example). HI is present otherwise BUT may not appear in the conclusion (dependent principle). HI and (f...) cannot be both present. Principles taken from functional induction have the final (f...).*) (* [rel_contexts] and [rel_declaration] actually contain triples, and lists are actually in reverse order to fit [compose_prod]. *) type elim_scheme = { elimc: constr with_bindings option; elimt: types; indref: global_reference option; params: Context.Rel.t; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) nparams: int; (* number of parameters *) predicates: Context.Rel.t; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) npredicates: int; (* Number of predicates *) branches: Context.Rel.t; (* branchr,...,branch1 *) nbranches: int; (* Number of branches *) args: Context.Rel.t; (* (xni, Ti_ni) ... (x1, Ti_1) *) nargs: int; (* number of arguments *) indarg: Context.Rel.Declaration.t option; (* Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) concl: types; (* Qi x1...xni HI (f...), HI and (f...) are optional and mutually exclusive *) indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) } let empty_scheme = { elimc = None; elimt = mkProp; indref = None; params = []; nparams = 0; predicates = []; npredicates = 0; branches = []; nbranches = 0; args = []; nargs = 0; indarg = None; concl = mkProp; indarg_in_concl = false; farg_in_concl = false; } let make_base n id = if Int.equal n 0 || Int.equal n 1 then id else (* This extends the name to accept new digits if it already ends with *) (* digits *) Id.of_string (atompart_of_id (make_ident (Id.to_string id) (Some 0))) (* Builds two different names from an optional inductive type and a number, also deals with a list of names to avoid. If the inductive type is None, then hyprecname is IHi where i is a number. *) let make_up_names n ind_opt cname = let is_hyp = String.equal (atompart_of_id cname) "H" in let base = Id.to_string (make_base n cname) in let ind_prefix = "IH" in let base_ind = if is_hyp then match ind_opt with | None -> Id.of_string ind_prefix | Some ind_id -> add_prefix ind_prefix (Nametab.basename_of_global ind_id) else add_prefix ind_prefix cname in let hyprecname = make_base n base_ind in let avoid = if Int.equal n 1 (* Only one recursive argument *) || Int.equal n 0 then [] else (* Forbid to use cname, cname0, hyprecname and hyprecname0 *) (* in order to get names such as f1, f2, ... *) let avoid = (make_ident (Id.to_string hyprecname) None) :: (make_ident (Id.to_string hyprecname) (Some 0)) :: [] in if not (String.equal (atompart_of_id cname) "H") then (make_ident base (Some 0)) :: (make_ident base None) :: avoid else avoid in Id.of_string base, hyprecname, avoid let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in errorlabstrm "Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") let glob = Universes.constr_of_global let coq_eq = lazy (glob (Coqlib.build_coq_eq ())) let coq_eq_refl = lazy (glob (Coqlib.build_coq_eq_refl ())) let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq") let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl") let mkEq t x y = mkApp (Lazy.force coq_eq, [| t; x; y |]) let mkRefl t x = mkApp (Lazy.force coq_eq_refl, [| t; x |]) let mkHEq t x u y = mkApp (Lazy.force coq_heq, [| t; x; u; y |]) let mkHRefl t x = mkApp (Lazy.force coq_heq_refl, [| t; x |]) let lift_togethern n l = let l', _ = List.fold_right (fun x (acc, n) -> (lift n x :: acc, succ n)) l ([], n) in l' let lift_list l = List.map (lift 1) l let ids_of_constr ?(all=false) vars c = let rec aux vars c = match kind_of_term c with | Var id -> Id.Set.add id vars | App (f, args) -> (match kind_of_term f with | Construct ((ind,_),_) | Ind (ind,_) -> let (mib,mip) = Global.lookup_inductive ind in Array.fold_left_from (if all then 0 else mib.Declarations.mind_nparams) aux vars args | _ -> fold_constr aux vars c) | _ -> fold_constr aux vars c in aux vars c let decompose_indapp f args = match kind_of_term f with | Construct ((ind,_),_) | Ind (ind,_) -> let (mib,mip) = Global.lookup_inductive ind in let first = mib.Declarations.mind_nparams_rec in let pars, args = Array.chop first args in mkApp (f, pars), args | _ -> f, args let mk_term_eq env sigma ty t ty' t' = let sigma = Sigma.to_evar_map sigma in if Reductionops.is_conv env sigma ty ty' then mkEq ty t t', mkRefl ty' t' else mkHEq ty t ty' t', mkHRefl ty' t' let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = let open Context.Rel.Declaration in Refine.refine { run = begin fun sigma -> let eqslen = List.length eqs in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) let abshypeq, abshypt = if dep then let eq, refl = mk_term_eq (push_rel_context ctx env) sigma (lift 1 c) (mkRel 1) typ (mkVar id) in mkProd (Anonymous, eq, lift 1 concl), [| refl |] else concl, [||] in (* Abstract by equalities *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> LocalAssum (Anonymous, x)) eqs) in let decl = match body with | None -> LocalAssum (Name id, c) | Some body -> LocalDef (Name id, body, c) in (* Abstract by the "generalized" hypothesis. *) let genarg = mkProd_or_LetIn decl abseqs in (* Abstract by the extension of the context *) let genctyp = it_mkProd_or_LetIn genarg ctx in (* The goal will become this product. *) let Sigma (genc, sigma, p) = Evarutil.new_evar env sigma ~principal:true genctyp in (* Apply the old arguments giving the proper instantiation of the hyp *) let instc = mkApp (genc, Array.of_list args) in (* Then apply to the original instantiated hyp. *) let instc = Option.cata (fun _ -> instc) (mkApp (instc, [| mkVar id |])) body in (* Apply the reflexivity proofs on the indices. *) let appeqs = mkApp (instc, Array.of_list refls) in (* Finally, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) Sigma (mkApp (appeqs, abshypt), sigma, p) end } let hyps_of_vars env sign nogen hyps = let open Context.Named.Declaration in if Id.Set.is_empty hyps then [] else let (_,lh) = Context.Named.fold_inside (fun (hs,hl) d -> let x = get_id d in if Id.Set.mem x nogen then (hs,hl) else if Id.Set.mem x hs then (hs,x::hl) else let xvars = global_vars_set_of_decl env d in if not (Id.Set.is_empty (Id.Set.diff xvars hs)) then (Id.Set.add x hs, x :: hl) else (hs, hl)) ~init:(hyps,[]) sign in lh exception Seen let linear vars args = let seen = ref vars in try Array.iter (fun i -> let rels = ids_of_constr ~all:true Id.Set.empty i in let seen' = Id.Set.fold (fun id acc -> if Id.Set.mem id acc then raise Seen else Id.Set.add id acc) rels !seen in seen := seen') args; true with Seen -> false let is_defined_variable env id = let open Context.Named.Declaration in lookup_named id env |> is_local_def let abstract_args gl generalize_vars dep id defined f args = let open Context.Rel.Declaration in let sigma = ref (Tacmach.project gl) in let env = Tacmach.pf_env gl in let concl = Tacmach.pf_concl gl in let dep = dep || dependent (mkVar id) concl in let avoid = ref [] in let get_id name = let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> Id.of_string "gen_x") gl in avoid := id :: !avoid; id in (* Build application generalized w.r.t. the argument plus the necessary eqs. From env |- c : forall G, T and args : G we build (T[G'], G' : ctx, env ; G' |- args' : G, eqs := G'_i = G_i, refls : G' = G, vars to generalize) eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *) *) let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = let name, ty, arity = let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in let decl = List.hd rel in get_name decl, get_type decl, c in let argty = Tacmach.pf_unsafe_type_of gl arg in let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in let () = sigma := sigma' in let lenctx = List.length ctx in let liftargty = lift lenctx argty in let leq = constr_cmp Reduction.CUMUL liftargty ty in match kind_of_term arg with | Var id when not (is_defined_variable env id) && leq && not (Id.Set.mem id nongenvars) -> (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, Id.Set.add id nongenvars, Id.Set.remove id vars, env) | _ -> let name = get_id name in let decl = LocalAssum (Name name, ty) in let ctx = decl :: ctx in let c' = mkApp (lift 1 c, [|mkRel 1|]) in let args = arg :: args in let liftarg = lift (List.length ctx) arg in let eq, refl = if leq then mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl (lift (-lenctx) ty) arg else mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg in let eqs = eq :: lift_list eqs in let refls = refl :: refls in let argvars = ids_of_constr vars arg in (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, nongenvars, Id.Set.union argvars vars, env) in let f', args' = decompose_indapp f args in let dogen, f', args' = let parvars = ids_of_constr ~all:true Id.Set.empty f' in if not (linear parvars args') then true, f, args else match Array.findi (fun i x -> not (isVar x) || is_defined_variable env (destVar x)) args' with | None -> false, f', args' | Some nonvar -> let before, after = Array.chop nonvar args' in true, mkApp (f', before), after in if dogen then let tyf' = Tacmach.pf_unsafe_type_of gl f' in let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' in let args, refls = List.rev args, List.rev refls in let vars = if generalize_vars then let nogen = Id.Set.add id nogen in hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars else [] in let body, c' = if defined then Some c', Retyping.get_type_of ctxenv !sigma c' else None, c' in let typ = Tacmach.pf_get_hyp_typ gl id in let tac = make_abstract_generalize (pf_env gl) id typ concl dep ctx body c' eqs args refls in let tac = Proofview.Unsafe.tclEVARS !sigma <*> tac in Some (tac, dep, succ (List.length ctx), vars) else None let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = let open Context.Named.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> Coqlib.check_required_library Coqlib.jmeq_module_name; let (f, args, def, id, oldid) = let oldid = Tacmach.New.pf_get_new_id id gl in match Tacmach.New.pf_get_hyp id gl with | LocalAssum (_,t) -> let f, args = decompose_app t in (f, args, false, id, oldid) | LocalDef (_,t,_) -> let f, args = decompose_app t in (f, args, true, id, oldid) in if List.is_empty args then Proofview.tclUNIT () else let args = Array.of_list args in let newc = Tacmach.New.of_old (fun gl -> abstract_args gl generalize_vars force_dep id def f args) gl in match newc with | None -> Proofview.tclUNIT () | Some (tac, dep, n, vars) -> let tac = if dep then Tacticals.New.tclTHENLIST [ tac; rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro; generalize_dep ~with_let:true (mkVar oldid)] else Tacticals.New.tclTHENLIST [ tac; clear [id]; Tacticals.New.tclDO n intro] in if List.is_empty vars then tac else Tacticals.New.tclTHEN tac (Tacticals.New.tclFIRST [revert vars ; Tacticals.New.tclMAP (fun id -> Tacticals.New.tclTRY (generalize_dep ~with_let:true (mkVar id))) vars]) end } let rec compare_upto_variables x y = if (isVar x || isRel x) && (isVar y || isRel y) then true else compare_constr compare_upto_variables x y let specialize_eqs id gl = let open Context.Rel.Declaration in let env = Tacmach.pf_env gl in let ty = Tacmach.pf_get_hyp_typ gl id in let evars = ref (project gl) in let unif env evars c1 c2 = compare_upto_variables c1 c2 && Evarconv.e_conv env evars c1 c2 in let rec aux in_eqs ctx acc ty = match kind_of_term ty with | Prod (na, t, b) -> (match kind_of_term t with | App (eq, [| eqty; x; y |]) when Term.eq_constr (Lazy.force coq_eq) eq -> let c = if noccur_between 1 (List.length ctx) x then y else x in let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in if unif (push_rel_context ctx env) evars pt t then aux true ctx (mkApp (acc, [| p |])) (subst1 p b) else acc, in_eqs, ctx, ty | App (heq, [| eqty; x; eqty'; y |]) when Term.eq_constr heq (Lazy.force coq_heq) -> let eqt, c = if noccur_between 1 (List.length ctx) x then eqty', y else eqty, x in let pt = mkApp (Lazy.force coq_heq, [| eqt; c; eqt; c |]) in let p = mkApp (Lazy.force coq_heq_refl, [| eqt; c |]) in if unif (push_rel_context ctx env) evars pt t then aux true ctx (mkApp (acc, [| p |])) (subst1 p b) else acc, in_eqs, ctx, ty | _ -> if in_eqs then acc, in_eqs, ctx, ty else let e = e_new_evar (push_rel_context ctx env) evars t in aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) | t -> acc, in_eqs, ctx, ty in let acc, worked, ctx, ty = aux false [] (mkVar id) ty in let ctx' = nf_rel_context_evar !evars ctx in let ctx'' = List.map (function | LocalDef (n,k,t) when isEvar k -> LocalAssum (n,t) | decl -> decl) ctx' in let ty' = it_mkProd_or_LetIn ty ctx'' in let acc' = it_mkLambda_or_LetIn acc ctx'' in let ty' = Tacred.whd_simpl env !evars ty' and acc' = Tacred.whd_simpl env !evars acc' in let ty' = Evarutil.nf_evar !evars ty' in if worked then tclTHENFIRST (Tacmach.internal_cut true id ty') (Proofview.V82.of_tactic (exact_no_check ((* refresh_universes_strict *) acc'))) gl else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl let specialize_eqs id = Proofview.Goal.nf_enter { enter = begin fun gl -> let msg = str "Specialization not allowed on dependent hypotheses" in Proofview.tclOR (clear [id]) (fun _ -> Tacticals.New.tclZEROMSG msg) >>= fun () -> Proofview.V82.tactic (specialize_eqs id) end } let occur_rel n c = let res = not (noccurn n c) in res (* This function splits the products of the induction scheme [elimt] into four parts: - branches, easily detectable (they are not referred by rels in the subterm) - what was found before branches (acc1) that is: parameters and predicates - what was found after branches (acc3) that is: args and indarg if any if there is no branch, we try to fill in acc3 with args/indargs. We also return the conclusion. *) let decompose_paramspred_branch_args elimt = let open Context.Rel.Declaration in let rec cut_noccur elimt acc2 = match kind_of_term elimt with | Prod(nme,tpe,elimt') -> let hd_tpe,_ = decompose_app ((strip_prod_assum tpe)) in if not (occur_rel 1 elimt') && isRel hd_tpe then cut_noccur elimt' (LocalAssum (nme,tpe)::acc2) else let acc3,ccl = decompose_prod_assum elimt in acc2 , acc3 , ccl | App(_, _) | Rel _ -> acc2 , [] , elimt | _ -> error_ind_scheme "" in let rec cut_occur elimt acc1 = match kind_of_term elimt with | Prod(nme,tpe,c) when occur_rel 1 c -> cut_occur c (LocalAssum (nme,tpe)::acc1) | Prod(nme,tpe,c) -> let acc2,acc3,ccl = cut_noccur elimt [] in acc1,acc2,acc3,ccl | App(_, _) | Rel _ -> acc1,[],[],elimt | _ -> error_ind_scheme "" in let acc1, acc2 , acc3, ccl = cut_occur elimt [] in (* Particular treatment when dealing with a dependent empty type elim scheme: if there is no branch, then acc1 contains all hyps which is wrong (acc1 should contain parameters and predicate only). This happens for an empty type (See for example Empty_set_ind, as False would actually be ok). Then we must find the predicate of the conclusion to separate params_pred from args. We suppose there is only one predicate here. *) match acc2 with | [] -> let hyps,ccl = decompose_prod_assum elimt in let hd_ccl_pred,_ = decompose_app ccl in begin match kind_of_term hd_ccl_pred with | Rel i -> let acc3,acc1 = List.chop (i-1) hyps in acc1 , [] , acc3 , ccl | _ -> error_ind_scheme "" end | _ -> acc1, acc2 , acc3, ccl let exchange_hd_app subst_hd t = let hd,args= decompose_app t in mkApp (subst_hd,Array.of_list args) (* Builds an elim_scheme from its type and calling form (const+binding). We first separate branches. We obtain branches, hyps before (params + preds), hyps after (args <+ indarg if present>) and conclusion. Then we proceed as follows: - separate parameters and predicates in params_preds. For that we build: forall (x1:Ti_1)(xni:Ti_ni) (HI:I prm1..prmp x1...xni), DUMMY x1...xni HI/farg ^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^ optional opt Free rels appearing in this term are parameters (branches should not appear, and the only predicate would have been Qi but we replaced it by DUMMY). We guess this heuristic catches all params. TODO: generalize to the case where args are merged with branches (?) and/or where several predicates are cited in the conclusion. - finish to fill in the elim_scheme: indarg/farg/args and finally indref. *) let compute_elim_sig ?elimc elimt = let open Context.Rel.Declaration in let params_preds,branches,args_indargs,conclusion = decompose_paramspred_branch_args elimt in let ccl = exchange_hd_app (mkVar (Id.of_string "__QI_DUMMY__")) conclusion in let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in let nparams = Int.Set.cardinal (free_rels concl_with_args) in let preds,params = List.chop (List.length params_preds - nparams) params_preds in (* A first approximation, further analysis will tweak it *) let res = ref { empty_scheme with (* This fields are ok: *) elimc = elimc; elimt = elimt; concl = conclusion; predicates = preds; npredicates = List.length preds; branches = branches; nbranches = List.length branches; farg_in_concl = isApp ccl && isApp (last_arg ccl); params = params; nparams = nparams; (* all other fields are unsure at this point. Including these:*) args = args_indargs; nargs = List.length args_indargs; } in try (* Order of tests below is important. Each of them exits if successful. *) (* 1- First see if (f x...) is in the conclusion. *) if !res.farg_in_concl then begin res := { !res with indarg = None; indarg_in_concl = false; farg_in_concl = true }; raise Exit end; (* 2- If no args_indargs (=!res.nargs at this point) then no indarg *) if Int.equal !res.nargs 0 then raise Exit; (* 3- Look at last arg: is it the indarg? *) ignore ( match List.hd args_indargs with | LocalDef (hiname,_,hi) -> error_ind_scheme "" | LocalAssum (hiname,hi) -> let hi_ind, hi_args = decompose_app hi in let hi_is_ind = (* hi est d'un type globalisable *) match kind_of_term hi_ind with | Ind (mind,_) -> true | Var _ -> true | Const _ -> true | Construct _ -> true | _ -> false in let hi_args_enough = (* hi a le bon nbre d'arguments *) Int.equal (List.length hi_args) (List.length params + !res.nargs -1) in (* FIXME: Ces deux tests ne sont pas suffisants. *) if not (hi_is_ind && hi_args_enough) then raise Exit (* No indarg *) else (* Last arg is the indarg *) res := {!res with indarg = Some (List.hd !res.args); indarg_in_concl = occur_rel 1 ccl; args = List.tl !res.args; nargs = !res.nargs - 1; }; raise Exit); raise Exit(* exit anyway *) with Exit -> (* Ending by computing indref: *) match !res.indarg with | None -> !res (* No indref *) | Some (LocalDef _) -> error_ind_scheme "" | Some (LocalAssum (_,ind)) -> let indhd,indargs = decompose_app ind in try {!res with indref = Some (global_of_constr indhd) } with e when CErrors.noncritical e -> error "Cannot find the inductive type of the inductive scheme." let compute_scheme_signature scheme names_info ind_type_guess = let open Context.Rel.Declaration in let f,l = decompose_app scheme.concl in (* Vérifier que les arguments de Qi sont bien les xi. *) let cond, check_concl = match scheme.indarg with | Some (LocalDef _) -> error "Strange letin, cannot recognize an induction scheme." | None -> (* Non standard scheme *) let cond hd = Term.eq_constr hd ind_type_guess && not scheme.farg_in_concl in (cond, fun _ _ -> ()) | Some (LocalAssum (_,ind)) -> (* Standard scheme from an inductive type *) let indhd,indargs = decompose_app ind in let cond hd = Term.eq_constr hd indhd in let check_concl is_pred p = (* Check again conclusion *) let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f == IndArg in let ind_is_ok = List.equal Term.eq_constr (List.lastn scheme.nargs indargs) (Context.Rel.to_extended_list 0 scheme.args) in if not (ccl_arg_ok && ind_is_ok) then error_ind_scheme "the conclusion of" in (cond, check_concl) in let is_pred n c = let hd = fst (decompose_app c) in match kind_of_term hd with | Rel q when n < q && q <= n+scheme.npredicates -> IndArg | _ when cond hd -> RecArg | _ -> OtherArg in let rec check_branch p c = match kind_of_term c with | Prod (_,t,c) -> (is_pred p t, true, dependent (mkRel 1) c) :: check_branch (p+1) c | LetIn (_,_,_,c) -> (OtherArg, false, dependent (mkRel 1) c) :: check_branch (p+1) c | _ when is_pred p c == IndArg -> [] | _ -> raise Exit in let rec find_branches p lbrch = match lbrch with | LocalAssum (_,t) :: brs -> (try let lchck_brch = check_branch p t in let n = List.fold_left (fun n (b,_,_) -> if b == RecArg then n+1 else n) 0 lchck_brch in let recvarname, hyprecname, avoid = make_up_names n scheme.indref names_info in let namesign = List.map (fun (b,is_assum,dep) -> (b,is_assum,dep,if b == IndArg then hyprecname else recvarname)) lchck_brch in (avoid,namesign) :: find_branches (p+1) brs with Exit-> error_ind_scheme "the branches of") | LocalDef _ :: _ -> error_ind_scheme "the branches of" | [] -> check_concl is_pred p; [] in Array.of_list (find_branches 0 (List.rev scheme.branches)) (* Check that the elimination scheme has a form similar to the elimination schemes built by Coq. Schemes may have the standard form computed from an inductive type OR (feb. 2006) a non standard form. That is: with no main induction argument and with an optional extra final argument of the form (f x y ...) in the conclusion. In the non standard case, naming of generated hypos is slightly different. *) let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info = let scheme = compute_elim_sig ~elimc:elimc elimt in evd, (compute_scheme_signature scheme names_info ind_type_guess, scheme) let guess_elim isrec dep s hyp0 gl = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in let mind,_ = Tacmach.New.pf_reduce_to_quantified_ind gl tmptyp0 in let evd, elimc = if isrec && not (is_nonrec (fst mind)) then find_ind_eliminator (fst mind) s gl else let env = Tacmach.New.pf_env gl in let sigma = Sigma.Unsafe.of_evar_map (Tacmach.New.project gl) in if use_dependent_propositions_elimination () && dep then let Sigma (ind, sigma, _) = build_case_analysis_scheme env sigma mind true s in (Sigma.to_evar_map sigma, ind) else let Sigma (ind, sigma, _) = build_case_analysis_scheme_default env sigma mind s in (Sigma.to_evar_map sigma, ind) in let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in evd, ((elimc, NoBindings), elimt), mkIndU mind let given_elim hyp0 (elimc,lbind as e) gl = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in Tacmach.New.project gl, (e, Tacmach.New.pf_unsafe_type_of gl elimc), ind_type_guess type scheme_signature = (Id.t list * (elim_arg_kind * bool * bool * Id.t) list) array type eliminator_source = | ElimUsing of (eliminator * types) * scheme_signature | ElimOver of bool * Id.t let find_induction_type isrec elim hyp0 gl = let scheme,elim = match elim with | None -> let sort = Tacticals.New.elimination_sort_of_goal gl in let _, (elimc,elimt),_ = guess_elim isrec (* dummy: *) true sort hyp0 gl in let scheme = compute_elim_sig ~elimc elimt in (* We drop the scheme waiting to know if it is dependent *) scheme, ElimOver (isrec,hyp0) | Some e -> let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in let scheme = compute_elim_sig ~elimc elimt in if Option.is_empty scheme.indarg then error "Cannot find induction type"; let indsign = compute_scheme_signature scheme hyp0 ind_guess in let elim = ({elimindex = Some(-1); elimbody = elimc; elimrename = None},elimt) in scheme, ElimUsing (elim,indsign) in match scheme.indref with | None -> error_ind_scheme "" | Some ref -> ref, scheme.nparams, elim let get_elim_signature elim hyp0 gl = compute_elim_signature (given_elim hyp0 elim gl) hyp0 let is_functional_induction elimc gl = let scheme = compute_elim_sig ~elimc (Tacmach.New.pf_unsafe_type_of gl (fst elimc)) in (* The test is not safe: with non-functional induction on non-standard induction scheme, this may fail *) Option.is_empty scheme.indarg (* Wait the last moment to guess the eliminator so as to know if we need a dependent one or not *) let get_eliminator elim dep s gl = let open Context.Rel.Declaration in match elim with | ElimUsing (elim,indsign) -> Tacmach.New.project gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in let branchlengthes = List.map (fun d -> assert (is_local_assum d); pi1 (decompose_prod_letin (get_type d))) (List.rev s.branches) in evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l (* Instantiate all meta variables of elimclause using lid, some elts of lid are parameters (first ones), the other are arguments. Returns the clause obtained. *) let recolle_clenv i params args elimclause gl = let _,arr = destApp elimclause.templval.rebus in let lindmv = Array.map (fun x -> match kind_of_term x with | Meta mv -> mv | _ -> errorlabstrm "elimination_clause" (str "The type of the elimination clause is not well-formed.")) arr in let k = match i with -1 -> Array.length lindmv - List.length args | _ -> i in (* parameters correspond to first elts of lid. *) let clauses_params = List.map_i (fun i id -> mkVar id , pf_get_hyp_typ id gl, lindmv.(i)) 0 params in let clauses_args = List.map_i (fun i id -> mkVar id , pf_get_hyp_typ id gl, lindmv.(k+i)) 0 args in let clauses = clauses_params@clauses_args in (* iteration of clenv_fchain with all infos we have. *) List.fold_right (fun e acc -> let x,y,i = e in (* from_n (Some 0) means that x should be taken "as is" without trying to unify (which would lead to trying to apply it to evars if y is a product). *) let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from_n gl (Some 0) (x,y)) gl in let elimclause' = clenv_fchain ~with_univs:false i acc indclause in elimclause') (List.rev clauses) elimclause (* Unification of the goal and the principle applied to meta variables: (elimc ?i ?j ?k...?l). This solves partly meta variables (and may produce new ones). Then refine with the resulting term with holes. *) let induction_tac with_evars params indvars elim = Proofview.Goal.nf_enter { enter = begin fun gl -> let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in let i = match i with None -> index_of_ind_arg elimt | Some i -> i in (* elimclause contains this: (elimc ?i ?j ?k...?l) *) let elimc = contract_letin_in_lam_header elimc in let elimc = mkCast (elimc, DEFAULTcast, elimt) in let elimclause = pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in (* elimclause' is built from elimclause by instanciating all args and params. *) let elimclause' = recolle_clenv i params indvars elimclause gl in (* one last resolution (useless?) *) let resolved = Tacmach.New.of_old (clenv_unique_resolver ~flags:(elim_flags ()) elimclause') gl in enforce_prop_bound_names rename (Clenvtac.clenv_refine with_evars resolved) end } (* Apply induction "in place" taking into account dependent hypotheses from the context, replacing the main hypothesis on which induction applies with the induction hypotheses *) let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_tac = let open Context.Named.Declaration in Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let concl = Tacmach.New.pf_nf_concl gl in let statuslists,lhyp0,toclear,deps,avoid,dep_in_hyps = cook_sign hyp0 inhyps indvars env in let dep_in_concl = Option.cata (fun id -> occur_var env id concl) false hyp0 in let dep = dep_in_hyps || dep_in_concl in let tmpcl = it_mkNamedProd_or_LetIn concl deps in let s = Retyping.get_sort_family_of env sigma tmpcl in let deps_cstr = List.fold_left (fun a decl -> if is_local_assum decl then (mkVar (get_id decl))::a else a) [] deps in let (sigma, isrec, elim, indsign) = get_eliminator elim dep s (Proofview.Goal.assume gl) in let branchletsigns = let f (_,is_not_let,_,_) = is_not_let in Array.map (fun (_,l) -> List.map f l) indsign in let names = compute_induction_names branchletsigns names in let tac = (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) (Tacticals.New.tclTHENLIST [ (* Generalize dependent hyps (but not args) *) if deps = [] then Proofview.tclUNIT () else apply_type tmpcl deps_cstr; (* side-conditions in elim (resp case) schemes come last (resp first) *) induct_tac elim; Tacticals.New.tclMAP expand_hyp toclear; ]) (Array.map2 (induct_discharge with_evars lhyp0 avoid (re_intro_dependent_hypotheses statuslists)) indsign names) in Sigma.Unsafe.of_pair (tac, sigma) end } let induction_with_atomization_of_ind_arg isrec with_evars elim names hyp0 inhyps = Proofview.Goal.enter { enter = begin fun gl -> let elim_info = find_induction_type isrec elim hyp0 (Proofview.Goal.assume gl) in atomize_param_of_ind_then elim_info hyp0 (fun indvars -> apply_induction_in_context with_evars (Some hyp0) inhyps (pi3 elim_info) indvars names (fun elim -> induction_tac with_evars [] [hyp0] elim)) end } let msg_not_right_number_induction_arguments scheme = str"Not the right number of induction arguments (expected " ++ pr_enum (fun x -> x) [ if scheme.farg_in_concl then str "the function name" else mt(); if scheme.nparams != 0 then int scheme.nparams ++ str (String.plural scheme.nparams " parameter") else mt (); if scheme.nargs != 0 then int scheme.nargs ++ str (String.plural scheme.nargs " argument") else mt ()] ++ str ")." (* Induction on a list of induction arguments. Analyze the elim scheme (which is mandatory for multiple ind args), check that all parameters and arguments are given (mandatory too). Main differences with induction_from_context is that there is no main induction argument. On the other hand, all args and params must be given, so we help a bit the unifier by making the "pattern" by hand before calling induction_tac *) let induction_without_atomization isrec with_evars elim names lid = Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma, (indsign,scheme) = get_elim_signature elim (List.hd lid) gl in let nargs_indarg_farg = scheme.nargs + (if scheme.farg_in_concl then 1 else 0) in if not (Int.equal (List.length lid) (scheme.nparams + nargs_indarg_farg)) then Tacticals.New.tclZEROMSG (msg_not_right_number_induction_arguments scheme) else let indvars,lid_params = List.chop nargs_indarg_farg lid in (* terms to patternify we must patternify indarg or farg if present in concl *) let realindvars = List.rev (if scheme.farg_in_concl then List.tl indvars else indvars) in let lidcstr = List.map mkVar (List.rev indvars) in let params = List.rev lid_params in let indvars = (* Temporary hack for compatibility, while waiting for better analysis of the form of induction schemes: a scheme like gt_wf_rec was taken as a functional scheme with no parameters, but by chance, because of the addition of at least hyp0 for cook_sign, it behaved as if there was a real induction arg. *) if indvars = [] then [List.hd lid_params] else indvars in let induct_tac elim = Tacticals.New.tclTHENLIST [ (* pattern to make the predicate appear. *) reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl; (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all possible holes using arguments given by the user (but the functional one). *) (* FIXME: Tester ca avec un principe dependant et non-dependant *) induction_tac with_evars params realindvars elim; ] in let elim = ElimUsing (({elimindex = Some (-1); elimbody = Option.get scheme.elimc; elimrename = None}, scheme.elimt), indsign) in apply_induction_in_context with_evars None [] elim indvars names induct_tac end } (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls = Proofview.Goal.nf_enter { enter = begin fun gl -> let open Context.Named.Declaration in if occur_var (Tacmach.New.pf_env gl) id (Tacmach.New.pf_concl gl) && cls.concl_occs == NoOccurrences then errorlabstrm "" (str "Conclusion must be mentioned: it depends on " ++ pr_id id ++ str "."); match cls.onhyps with | Some hyps -> let to_erase d = let id' = get_id d in if Id.List.mem id' inhyps then (* if selected, do not erase *) None else (* erase if not selected and dependent on id or selected hyps *) let test id = occur_var_in_decl (Tacmach.New.pf_env gl) id d in if List.exists test (id::inhyps) then Some id' else None in let ids = List.map_filter to_erase (Proofview.Goal.hyps gl) in clear ids | None -> Proofview.tclUNIT () end } let use_bindings env sigma elim must_be_closed (c,lbind) typ = let sigma = Sigma.to_evar_map sigma in let typ = if elim == None then (* w/o an scheme, the term has to be applied at least until obtaining an inductive type (even though the arity might be known only by pattern-matching, as in the case of a term of the form "nat_rect ?A ?o ?s n", with ?A to be inferred by matching. *) let sign,t = splay_prod env sigma typ in it_mkProd t sign else (* Otherwise, we exclude the case of an induction argument in an explicitly functional type. Henceforth, we can complete the pattern until it has as type an atomic type (even though this atomic type can hide a functional type, for which the "using" clause has a scheme). *) typ in let rec find_clause typ = try let indclause = make_clenv_binding env sigma (c,typ) lbind in if must_be_closed && occur_meta (clenv_value indclause) then error "Need a fully applied argument."; (* We lose the possibility of coercions in with-bindings *) let (sigma, c) = pose_all_metas_as_evars env indclause.evd (clenv_value indclause) in Sigma.Unsafe.of_pair (c, sigma) with e when catchable_exception e -> try find_clause (try_red_product env sigma typ) with Redelimination -> raise e in find_clause typ let check_expected_type env sigma (elimc,bl) elimt = (* Compute the expected template type of the term in case a using clause is given *) let sign,_ = splay_prod env sigma elimt in let n = List.length sign in if n == 0 then error "Scheme cannot be applied."; let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in let sigma = solve_evar_clause env sigma true cl bl in let (_,u,_) = destProd cl.cl_concl in fun t -> Evarconv.e_cumul env (ref sigma) t u let check_enough_applied env sigma elim = let sigma = Sigma.to_evar_map sigma in (* A heuristic to decide whether the induction arg is enough applied *) match elim with | None -> (* No eliminator given *) fun u -> let t,_ = decompose_app (whd_all env sigma u) in isInd t | Some elimc -> let elimt = Retyping.get_type_of env sigma (fst elimc) in let scheme = compute_elim_sig ~elimc elimt in match scheme.indref with | None -> (* in the absence of information, do not assume it may be partially applied *) fun _ -> true | Some _ -> (* Last argument is supposed to be the induction argument *) check_expected_type env sigma elimc elimt let guard_no_unifiable = Proofview.guard_no_unifiable >>= function | None -> Proofview.tclUNIT () | Some l -> Proofview.tclZERO (RefinerError (UnresolvedBindings l)) let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in let check = check_enough_applied env sigma elim in let Sigma (c, sigma', p) = use_bindings env sigma elim false (c0,lbind) t0 in let abs = AbstractPattern (from_prefix,check,Name id,(pending,c),cls,false) in let (id,sign,_,lastlhyp,ccl,res) = make_abstraction env sigma' ccl abs in match res with | None -> (* pattern not found *) let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* we restart using bindings after having tried type-class resolution etc. on the term given by the user *) let flags = tactic_infer_flags (with_evars && (* do not give a success semantics to edestruct on an open term yet *) false) in let Sigma (c0, sigma, q) = finish_evar_resolution ~flags env sigma (pending,c0) in let tac = (if isrec then (* Historically, induction has side conditions last *) Tacticals.New.tclTHENFIRST else (* and destruct has side conditions first *) Tacticals.New.tclTHENLAST) (Tacticals.New.tclTHENLIST [ Refine.refine ~unsafe:true { run = begin fun sigma -> let b = not with_evars && with_eq != None in let Sigma (c, sigma, p) = use_bindings env sigma elim b (c0,lbind) t0 in let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in let Sigma (ans, sigma, q) = mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) in Sigma (ans, sigma, p +> q) end }; if with_evars then Proofview.shelve_unifiable else guard_no_unifiable; if is_arg_pure_hyp then Tacticals.New.tclTRY (clear [destVar c0]) else Proofview.tclUNIT (); if isrec then Proofview.cycle (-1) else Proofview.tclUNIT () ]) tac in Sigma (tac, sigma, q) | Some (Sigma (c, sigma', q)) -> (* pattern found *) let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* TODO: if ind has predicate parameters, use JMeq instead of eq *) let env = reset_with_named_context sign env in let tac = Tacticals.New.tclTHENLIST [ Refine.refine ~unsafe:true { run = begin fun sigma -> mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None end }; tac ] in Sigma (tac, sigma', p +> q) end } let has_generic_occurrences_but_goal cls id env ccl = clause_with_generic_context_selection cls && (* TODO: whd_evar of goal *) (cls.concl_occs != NoOccurrences || not (occur_var env id ccl)) let induction_gen clear_flag isrec with_evars elim ((_pending,(c,lbind)),(eqname,names) as arg) cls = let inhyps = match cls with | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps | _ -> [] in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let ccl = Proofview.Goal.raw_concl gl in let cls = Option.default allHypsAndConcl cls in let t = typ_of env sigma c in let is_arg_pure_hyp = isVar c && not (mem_named_context_val (destVar c) (Global.named_context_val ())) && lbind == NoBindings && not with_evars && Option.is_empty eqname && clear_flag == None && has_generic_occurrences_but_goal cls (destVar c) env ccl in let enough_applied = check_enough_applied env sigma elim t in if is_arg_pure_hyp && enough_applied then (* First case: induction on a variable already in an inductive type and with maximal abstraction over the variable. This is a situation where the induction argument is a clearable variable of the goal w/o occurrence selection and w/o equality kept: no need to generalize *) let id = destVar c in Tacticals.New.tclTHEN (clear_unselected_context id inhyps cls) (induction_with_atomization_of_ind_arg isrec with_evars elim names id inhyps) else (* Otherwise, we look for the pattern, possibly adding missing arguments and declaring the induction argument as a new local variable *) let id = (* Type not the right one if partially applied but anyway for internal use*) let x = id_of_name_using_hdchar (Global.env()) t Anonymous in new_fresh_id [] x gl in let info_arg = (is_arg_pure_hyp, not enough_applied) in pose_induction_arg_then isrec with_evars info_arg elim id arg t inhyps cls (induction_with_atomization_of_ind_arg isrec with_evars elim names id inhyps) end } (* Induction on a list of arguments. First make induction arguments atomic (using letins), then do induction. The specificity here is that all arguments and parameters of the scheme are given (mandatory for the moment), so we don't need to deal with parameters of the inductive type as in induction_gen. *) let induction_gen_l isrec with_evars elim names lc = let newlc = ref [] in let lc = List.map (function | (c,None) -> c | (c,Some(loc,eqname)) -> user_err_loc (loc,"",str "Do not know what to do with " ++ Miscprint.pr_intro_pattern_naming eqname)) lc in let rec atomize_list l = match l with | [] -> Proofview.tclUNIT () | c::l' -> match kind_of_term c with | Var id when not (mem_named_context_val id (Global.named_context_val ())) && not with_evars -> let _ = newlc:= id::!newlc in atomize_list l' | _ -> Proofview.Goal.enter { enter = begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in let x = id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in let id = new_fresh_id [] x gl in let newl' = List.map (replace_term c (mkVar id)) l' in let _ = newlc:=id::!newlc in Tacticals.New.tclTHEN (letin_tac None (Name id) c None allHypsAndConcl) (atomize_list newl') end } in Tacticals.New.tclTHENLIST [ (atomize_list lc); (Proofview.tclUNIT () >>= fun () -> (* ensure newlc has been computed *) induction_without_atomization isrec with_evars elim names !newlc) ] (* Induction either over a term, over a quantified premisse, or over several quantified premisses (like with functional induction principles). TODO: really unify induction with one and induction with several args *) let induction_destruct isrec with_evars (lc,elim) = match lc with | [] -> assert false (* ensured by syntax, but if called inside caml? *) | [c,(eqname,names as allnames),cls] -> Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match elim with | Some elim when is_functional_induction elim gl -> (* Standard induction on non-standard induction schemes *) (* will be removable when is_functional_induction will be more clever *) if not (Option.is_empty cls) then error "'in' clause not supported here."; let _,c = force_destruction_arg false env sigma c in onInductionArg (fun _clear_flag c -> induction_gen_l isrec with_evars elim names [with_no_bindings c,eqname]) c | _ -> (* standard induction *) onOpenInductionArg env sigma (fun clear_flag c -> induction_gen clear_flag isrec with_evars elim (c,allnames) cls) c end } | _ -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match elim with | None -> (* Several arguments, without "using" clause *) (* TODO: Do as if the arguments after the first one were called with *) (* "destruct", but selecting occurrences on the initial copy of *) (* the goal *) let (a,b,cl) = List.hd lc in let l = List.tl lc in (* TODO *) Tacticals.New.tclTHEN (onOpenInductionArg env sigma (fun clear_flag a -> induction_gen clear_flag isrec with_evars None (a,b) cl) a) (Tacticals.New.tclMAP (fun (a,b,cl) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in onOpenInductionArg env sigma (fun clear_flag a -> induction_gen clear_flag false with_evars None (a,b) cl) a end }) l) | Some elim -> (* Several induction hyps with induction scheme *) let lc = List.map (on_pi1 (fun c -> snd (force_destruction_arg false env sigma c))) lc in let newlc = List.map (fun (x,(eqn,names),cls) -> if cls != None then error "'in' clause not yet supported here."; match x with (* FIXME: should we deal with ElimOnIdent? *) | _clear_flag,ElimOnConstr x -> if eqn <> None then error "'eqn' clause not supported here."; (with_no_bindings x,names) | _ -> error "Don't know where to find some argument.") lc in (* Check that "as", if any, is given only on the last argument *) let names,rest = List.sep_last (List.map snd newlc) in if List.exists (fun n -> not (Option.is_empty n)) rest then error "'as' clause with multiple arguments and 'using' clause can only occur last."; let newlc = List.map (fun (x,_) -> (x,None)) newlc in induction_gen_l isrec with_evars elim names newlc end } let induction ev clr c l e = induction_gen clr true ev e (((Evd.empty,Evd.empty),(c,NoBindings)),(None,l)) None let destruct ev clr c l e = induction_gen clr false ev e (((Evd.empty,Evd.empty),(c,NoBindings)),(None,l)) None (* The registered tactic, which calls the default elimination * if no elimination constant is provided. *) (* Induction tactics *) (* This was Induction before 6.3 (induction only in quantified premisses) *) let simple_induct_id s = Tacticals.New.tclTHEN (intros_until_id s) (Tacticals.New.onLastHyp simplest_elim) let simple_induct_nodep n = Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHyp simplest_elim) let simple_induct = function | NamedHyp id -> simple_induct_id id | AnonHyp n -> simple_induct_nodep n (* Destruction tactics *) let simple_destruct_id s = (Tacticals.New.tclTHEN (intros_until_id s) (Tacticals.New.onLastHyp simplest_case)) let simple_destruct_nodep n = (Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHyp simplest_case)) let simple_destruct = function | NamedHyp id -> simple_destruct_id id | AnonHyp n -> simple_destruct_nodep n (* * Eliminations giving the type instead of the proof. * These tactics use the default elimination constant and * no substitutions at all. * May be they should be integrated into Elim ... *) let elim_scheme_type elim t = Proofview.Goal.nf_enter { enter = begin fun gl -> let clause = Tacmach.New.of_old (fun gl -> mk_clenv_type_of gl elim) gl in match kind_of_term (last_arg clause.templval.rebus) with | Meta mv -> let clause' = (* t is inductive, then CUMUL or CONV is irrelevant *) clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t (clenv_meta_type clause mv) clause in Clenvtac.res_pf clause' ~flags:(elim_flags ()) ~with_evars:false | _ -> anomaly (Pp.str "elim_scheme_type") end } let elim_type t = Proofview.Goal.s_enter { s_enter = begin fun gl -> let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd) end } let case_type t = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Tacmach.New.pf_env gl in let (ind,t) = reduce_to_atomic_ind env (Sigma.to_evar_map sigma) t in let s = Tacticals.New.elimination_sort_of_goal gl in let Sigma (elimc, evd, p) = build_case_analysis_scheme_default env sigma ind s in Sigma (elim_scheme_type elimc t, evd, p) end } (************************************************) (* Tactics related with logic connectives *) (************************************************) (* Reflexivity tactics *) let (forward_setoid_reflexivity, setoid_reflexivity) = Hook.make () let maybe_betadeltaiota_concl allowred gl = let concl = Tacmach.New.pf_nf_concl gl in let sigma = Tacmach.New.project gl in if not allowred then concl else let env = Proofview.Goal.env gl in whd_all env sigma concl let reflexivity_red allowred = Proofview.Goal.enter { enter = begin fun gl -> (* PL: usual reflexivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let concl = maybe_betadeltaiota_concl allowred gl in match match_with_equality_type concl with | None -> Proofview.tclZERO NoEquationFound | Some _ -> one_constructor 1 NoBindings end } let reflexivity = Proofview.tclORELSE (reflexivity_red false) begin function (e, info) -> match e with | NoEquationFound -> Hook.get forward_setoid_reflexivity | e -> Proofview.tclZERO ~info e end let intros_reflexivity = (Tacticals.New.tclTHEN intros reflexivity) (* Symmetry tactics *) (* This tactic first tries to apply a constant named sym_eq, where eq is the name of the equality predicate. If this constant is not defined and the conclusion is a=b, it solves the goal doing (Cut b=a;Intro H;Case H;Constructor 1) *) let (forward_setoid_symmetry, setoid_symmetry) = Hook.make () (* This is probably not very useful any longer *) let prove_symmetry hdcncl eq_kind = let symc = match eq_kind with | MonomorphicLeibnizEq (c1,c2) -> mkApp(hdcncl,[|c2;c1|]) | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp(hdcncl,[|typ;c2;c1|]) | HeterogenousEq (t1,c1,t2,c2) -> mkApp(hdcncl,[|t2;c2;t1;c1|]) in Tacticals.New.tclTHENFIRST (cut symc) (Tacticals.New.tclTHENLIST [ intro; Tacticals.New.onLastHyp simplest_case; one_constructor 1 NoBindings ]) let match_with_equation c = try let res = match_with_equation c in Proofview.tclUNIT res with NoEquationFound -> Proofview.tclZERO NoEquationFound let symmetry_red allowred = Proofview.Goal.enter { enter = begin fun gl -> (* PL: usual symmetry don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let concl = maybe_betadeltaiota_concl allowred gl in match_with_equation concl >>= fun with_eqn -> match with_eqn with | Some eq_data,_,_ -> Tacticals.New.tclTHEN (convert_concl_no_check concl DEFAULTcast) (Tacticals.New.pf_constr_of_global eq_data.sym apply) | None,eq,eq_kind -> prove_symmetry eq eq_kind end } let symmetry = Proofview.tclORELSE (symmetry_red false) begin function (e, info) -> match e with | NoEquationFound -> Hook.get forward_setoid_symmetry | e -> Proofview.tclZERO ~info e end let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make () let symmetry_in id = Proofview.Goal.enter { enter = begin fun gl -> let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in let sign,t = decompose_prod_assum ctype in Proofview.tclORELSE begin match_with_equation t >>= fun (_,hdcncl,eq) -> let symccl = match eq with | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |]) | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |]) | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in Tacticals.New.tclTHENS (cut (it_mkProd_or_LetIn symccl sign)) [ intro_replacing id; Tacticals.New.tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ] end begin function (e, info) -> match e with | NoEquationFound -> Hook.get forward_setoid_symmetry_in id | e -> Proofview.tclZERO ~info e end end } let intros_symmetry = Tacticals.New.onClause (function | None -> Tacticals.New.tclTHEN intros symmetry | Some id -> symmetry_in id) (* Transitivity tactics *) (* This tactic first tries to apply a constant named eq_trans, where eq is the name of the equality predicate. If this constant is not defined and the conclusion is a=b, it solves the goal doing Cut x1=x2; [Cut x2=x3; [Intros e1 e2; Case e2;Assumption | Idtac] | Idtac] --Eduardo (19/8/97) *) let (forward_setoid_transitivity, setoid_transitivity) = Hook.make () (* This is probably not very useful any longer *) let prove_transitivity hdcncl eq_kind t = Proofview.Goal.enter { enter = begin fun gl -> let (eq1,eq2) = match eq_kind with | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |]) | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |]) | HeterogenousEq (typ1,c1,typ2,c2) -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let type_of = Typing.unsafe_type_of env sigma in let typt = type_of t in (mkApp(hdcncl, [| typ1; c1; typt ;t |]), mkApp(hdcncl, [| typt; t; typ2; c2 |])) in Tacticals.New.tclTHENFIRST (cut eq2) (Tacticals.New.tclTHENFIRST (cut eq1) (Tacticals.New.tclTHENLIST [ Tacticals.New.tclDO 2 intro; Tacticals.New.onLastHyp simplest_case; assumption ])) end } let transitivity_red allowred t = Proofview.Goal.enter { enter = begin fun gl -> (* PL: usual transitivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let concl = maybe_betadeltaiota_concl allowred gl in match_with_equation concl >>= fun with_eqn -> match with_eqn with | Some eq_data,_,_ -> Tacticals.New.tclTHEN (convert_concl_no_check concl DEFAULTcast) (match t with | None -> Tacticals.New.pf_constr_of_global eq_data.trans eapply | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans (fun trans -> apply_list [trans;t])) | None,eq,eq_kind -> match t with | None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.") | Some t -> prove_transitivity eq eq_kind t end } let transitivity_gen t = Proofview.tclORELSE (transitivity_red false t) begin function (e, info) -> match e with | NoEquationFound -> Hook.get forward_setoid_transitivity t | e -> Proofview.tclZERO ~info e end let etransitivity = transitivity_gen None let transitivity t = transitivity_gen (Some t) let intros_transitivity n = Tacticals.New.tclTHEN intros (transitivity_gen n) (* tactical to save as name a subproof such that the generalisation of the current goal, abstracted with respect to the local signature, is solved by tac *) (** d1 is the section variable in the global context, d2 in the goal context *) let interpretable_as_section_decl evd d1 d2 = let open Context.Named.Declaration in match d2, d1 with | LocalDef _, LocalAssum _ -> false | LocalDef (_,b1,t1), LocalDef (_,b2,t2) -> e_eq_constr_univs evd b1 b2 && e_eq_constr_univs evd t1 t2 | LocalAssum (_,t1), d2 -> e_eq_constr_univs evd t1 (get_type d2) let rec decompose len c t accu = let open Context.Rel.Declaration in if len = 0 then (c, t, accu) else match kind_of_term c, kind_of_term t with | Lambda (na, u, c), Prod (_, _, t) -> decompose (pred len) c t (LocalAssum (na, u) :: accu) | LetIn (na, b, u, c), LetIn (_, _, _, t) -> decompose (pred len) c t (LocalDef (na, b, u) :: accu) | _ -> assert false let rec shrink ctx sign c t accu = let open Context.Rel.Declaration in match ctx, sign with | [], [] -> (c, t, accu) | p :: ctx, decl :: sign -> if noccurn 1 c && noccurn 1 t then let c = subst1 mkProp c in let t = subst1 mkProp t in shrink ctx sign c t accu else let c = mkLambda_or_LetIn p c in let t = mkProd_or_LetIn p t in let accu = if is_local_assum p then let open Context.Named.Declaration in mkVar (get_id decl) :: accu else accu in shrink ctx sign c t accu | _ -> assert false let shrink_entry sign const = let open Entries in let typ = match const.const_entry_type with | None -> assert false | Some t -> t in (** The body has been forced by the call to [build_constant_by_tactic] *) let () = assert (Future.is_over const.const_entry_body) in let ((body, uctx), eff) = Future.force const.const_entry_body in let (body, typ, ctx) = decompose (List.length sign) body typ [] in let (body, typ, args) = shrink ctx sign body typ [] in let const = { const with const_entry_body = Future.from_val ((body, uctx), eff); const_entry_type = Some typ; } in (const, args) let abstract_subproof id gk tac = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in let open Context.Named.Declaration in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let current_sign = Global.named_context_val () and global_sign = Proofview.Goal.hyps gl in let sigma = Sigma.to_evar_map sigma in let evdref = ref sigma in let sign,secsign = List.fold_right (fun d (s1,s2) -> let id = get_id d in if mem_named_context_val id current_sign && interpretable_as_section_decl evdref (lookup_named_val id current_sign) d then (s1,push_named_context_val d s2) else (Context.Named.add d s1,s2)) global_sign (Context.Named.empty, empty_named_context_val) in let id = next_global_ident_away id (pf_ids_of_hyps gl) in let concl = it_mkNamedProd_or_LetIn (Proofview.Goal.concl gl) sign in let concl = try flush_and_check_evars !evdref concl with Uninstantiated_evar _ -> error "\"abstract\" cannot handle existentials." in let evd, ctx, concl = (* FIXME: should be done only if the tactic succeeds *) let evd, nf = nf_evars_and_universes !evdref in let ctx = Evd.universe_context_set evd in evd, ctx, nf concl in let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac) in let ectx = Evd.evar_universe_context evd in let (const, safe, ectx) = try Pfedit.build_constant_by_tactic ~goal_kind:gk id ectx secsign concl solve_tac with Logic_monad.TacticFailure e as src -> (* if the tactic [tac] fails, it reports a [TacticFailure e], which is an error irrelevant to the proof system (in fact it means that [e] comes from [tac] failing to yield enough success). Hence it reraises [e]. *) let (_, info) = CErrors.push src in iraise (e, info) in let const, args = if !shrink_abstract then shrink_entry sign const else (const, List.rev (Context.Named.to_instance sign)) in let cd = Entries.DefinitionEntry const in let decl = (cd, IsProof Lemma) in let cst () = (** do not compute the implicit arguments, it may be costly *) let () = Impargs.make_implicit_args false in (** ppedrot: seems legit to have abstracted subproofs as local*) Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl in let cst = Impargs.with_implicit_protection cst () in (* let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in *) let lem, ctx = Universes.unsafe_constr_of_global (ConstRef cst) in let evd = Evd.set_universe_context evd ectx in let open Safe_typing in let eff = private_con_of_con (Global.safe_env ()) cst in let effs = add_private eff Entries.(snd (Future.force const.const_entry_body)) in let solve = Proofview.tclEFFECTS effs <*> exact_no_check (applist (lem, args)) in let tac = if not safe then Proofview.mark_as_unsafe <*> solve else solve in Sigma.Unsafe.of_pair (tac, evd) end } let anon_id = Id.of_string "anonymous" let tclABSTRACT name_op tac = let open Proof_global in let default_gk = (Global, false, Proof Theorem) in let s, gk = match name_op with | Some s -> (try let _, gk, _ = current_proof_statement () in s, gk with NoCurrentProof -> s, default_gk) | None -> let name, gk = try let name, gk, _ = current_proof_statement () in name, gk with NoCurrentProof -> anon_id, default_gk in add_suffix name "_subproof", gk in abstract_subproof s gk tac let unify ?(state=full_transparent_state) x y = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in try let core_flags = { (default_unify_flags ()).core_unify_flags with modulo_delta = state; modulo_conv_on_closed_terms = Some state} in (* What to do on merge and subterm flags?? *) let flags = { (default_unify_flags ()) with core_unify_flags = core_flags; merge_unify_flags = core_flags; subterm_unify_flags = { core_flags with modulo_delta = empty_transparent_state } } in let sigma = Sigma.to_evar_map sigma in let sigma = w_unify (Tacmach.New.pf_env gl) sigma Reduction.CONV ~flags x y in Sigma.Unsafe.of_pair (Proofview.tclUNIT (), sigma) with e when CErrors.noncritical e -> Sigma.here (Tacticals.New.tclFAIL 0 (str"Not unifiable")) sigma end } module Simple = struct (** Simplified version of some of the above tactics *) let intro x = intro_move (Some x) MoveLast let apply c = apply_with_bindings_gen false false [None,(Loc.ghost,(c,NoBindings))] let eapply c = apply_with_bindings_gen false true [None,(Loc.ghost,(c,NoBindings))] let elim c = elim false None (c,NoBindings) None let case c = general_case_analysis false None (c,NoBindings) let apply_in id c = apply_in false false id [None,(Loc.ghost, (c, NoBindings))] None end (** Tacticals defined directly in term of Proofview *) module New = struct open Proofview.Notations let exact_proof c = exact_proof c open Genredexpr open Locus let reduce_after_refine = let onhyps = (** We reduced everywhere in the hyps before 8.6 *) if Flags.version_compare !Flags.compat_version Flags.V8_5 == 0 then None else Some [] in reduce (Lazy {rBeta=true;rMatch=true;rFix=true;rCofix=true; rZeta=false;rDelta=false;rConst=[]}) {onhyps; concl_occs=AllOccurrences } let refine ?unsafe c = Refine.refine ?unsafe c <*> reduce_after_refine end coq-8.6/tactics/leminv.ml0000644000175000017500000002341513022274260014742 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (*

Case c of c1 ... cn end *) let n_lhs_rhs = ref [] and v_lhs = ref (None : constr option) and c_lhs = ref (None : constr option) in Array.iteri (fun i ci -> let argsi, bodyi = decompose_lam ci in let nargsi = List.length argsi in (* REL (narg3 + nargsi + 1) is f *) (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *) (* REL 1 to REL nargsi are argsi (reverse order) *) (* First we test if the RHS is the RHS for constants *) if isRel bodyi && Int.equal (destRel bodyi) 1 then c_lhs := Some (compute_lhs (snd (List.hd args3)) i nargsi) (* Then we test if the RHS is the RHS for variables *) else begin match decompose_app bodyi with | vmf, [_; _; a3; a4 ] when isRel a3 && isRel a4 && is_conv vmf (Lazy.force coq_varmap_find)-> v_lhs := Some (compute_lhs (snd (List.hd args3)) i nargsi) (* Third case: this is a normal LHS-RHS *) | _ -> n_lhs_rhs := (compute_lhs (snd (List.hd args3)) i nargsi, compute_rhs bodyi (nargs3 + nargsi + 1)) :: !n_lhs_rhs end) lci; if Option.is_empty !c_lhs && Option.is_empty !v_lhs then i_can't_do_that (); (* The Cases predicate is a lambda; we assume no dependency *) let p = match kind_of_term p with | Lambda (_,_,p) -> Termops.pop p | _ -> p in { normal_lhs_rhs = List.rev !n_lhs_rhs; variable_lhs = !v_lhs; return_type = p; constants = List.fold_right ConstrSet.add cs ConstrSet.empty; constant_lhs = !c_lhs } | _ -> i_can't_do_that () end |_ -> i_can't_do_that () (* TODO for that function: \begin{itemize} \item handle the case where the return type is an argument of the function \item handle the case of simple mutual inductive (for example terms and lists of terms) formulas with the corresponding mutual recursvive interpretation functions. \end{itemize} *) (*s Stuff to build variables map, currently implemented as complete binary search trees (see file \texttt{Quote.v}) *) (* First the function to distinghish between constants (closed terms) and variables (open terms) *) let rec closed_under cset t = (ConstrSet.mem t cset) || (match (kind_of_term t) with | Cast(c,_,_) -> closed_under cset c | App(f,l) -> closed_under cset f && Array.for_all (closed_under cset) l | _ -> false) (*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete binary search tree containing the [ci], that is: \begin{verbatim} c1 / \ c2 c3 / \ c4 c5 \end{verbatim} The second argument is a constr (the common type of the [ci]) *) let btree_of_array a ty = let size_of_a = Array.length a in let semi_size_of_a = size_of_a lsr 1 in let node = Lazy.force coq_Node_vm and empty = mkApp (Lazy.force coq_Empty_vm, [| ty |]) in let rec aux n = if n > size_of_a then empty else if n > semi_size_of_a then mkApp (node, [| ty; a.(n-1); empty; empty |]) else mkApp (node, [| ty; a.(n-1); aux (2*n); aux (2*n+1) |]) in aux 1 (*s [btree_of_array] and [path_of_int] verify the following invariant:\\ {\tt (varmap\_find A dv }[(path_of_int n)] [(btree_of_array a ty)] = [a.(n)]\\ [n] must be [> 0] *) let path_of_int n = (* returns the list of digits of n in reverse order with initial 1 removed *) let rec digits_of_int n = if Int.equal n 1 then [] else (Int.equal (n mod 2) 1)::(digits_of_int (n lsr 1)) in List.fold_right (fun b c -> mkApp ((if b then Lazy.force coq_Right_idx else Lazy.force coq_Left_idx), [| c |])) (List.rev (digits_of_int n)) (Lazy.force coq_End_idx) (*s The tactic works with a list of subterms sharing the same variables map. We need to sort terms in order to avoid than strange things happen during replacement of terms by their 'abstract' counterparties. *) (* [subterm t t'] tests if constr [t'] occurs in [t] *) (* This function does not descend under binders (lambda and Cases) *) let rec subterm gl (t : constr) (t' : constr) = (pf_conv_x gl t t') || (match (kind_of_term t) with | App (f,args) -> Array.exists (fun t -> subterm gl t t') args | Cast(t,_,_) -> (subterm gl t t') | _ -> false) (*s We want to sort the list according to reverse subterm order. *) (* Since it's a partial order the algoritm of Sort.list won't work !! *) let rec sort_subterm gl l = let rec insert c = function | [] -> [c] | (h::t as l) when eq_constr c h -> l (* Avoid doing the same work twice *) | h::t -> if subterm gl c h then c::h::t else h::(insert c t) in match l with | [] -> [] | h::t -> insert h (sort_subterm gl t) module Constrhash = Hashtbl.Make (struct type t = constr let equal = eq_constr let hash = hash_constr end) (*s Now we are able to do the inversion itself. We destructurate the term and use an imperative hashtable to store leafs that are already encountered. The type of arguments is:\\ [ivs : inversion_scheme]\\ [lc: constr list]\\ [gl: goal sigma]\\ *) let quote_terms ivs lc = Coqlib.check_required_library ["Coq";"quote";"Quote"]; let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = let rec auxl l = match l with | (lhs, rhs)::tail -> begin try let s1 = Id.Map.bindings (matches (Global.env ()) Evd.empty rhs c) in let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1 in Termops.subst_meta s2 lhs with PatternMatchingFailure -> auxl tail end | [] -> begin match ivs.variable_lhs with | None -> begin match ivs.constant_lhs with | Some c_lhs -> Termops.subst_meta [1, c] c_lhs | None -> anomaly (Pp.str "invalid inversion scheme for quote") end | Some var_lhs -> begin match ivs.constant_lhs with | Some c_lhs when closed_under ivs.constants c -> Termops.subst_meta [1, c] c_lhs | _ -> begin try Constrhash.find varhash c with Not_found -> let newvar = Termops.subst_meta [1, (path_of_int !counter)] var_lhs in begin incr counter; varlist := c :: !varlist; Constrhash.add varhash c newvar; newvar end end end end in auxl ivs.normal_lhs_rhs in let lp = List.map aux lc in (lp, (btree_of_array (Array.of_list (List.rev !varlist)) ivs.return_type )) (*s actually we could "quote" a list of terms instead of a single term. Ring for example needs that, but Ring doesn't use Quote yet. *) let quote f lid = Proofview.Goal.nf_enter { enter = begin fun gl -> let f = Tacmach.New.pf_global f gl in let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in let ivs = compute_ivs f cl gl in let concl = Proofview.Goal.concl gl in let quoted_terms = quote_terms ivs [concl] in let (p, vm) = match quoted_terms with | [p], vm -> (p,vm) | _ -> assert false in match ivs.variable_lhs with | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast end } let gen_quote cont c f lid = Proofview.Goal.nf_enter { enter = begin fun gl -> let f = Tacmach.New.pf_global f gl in let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in let ivs = compute_ivs f cl gl in let quoted_terms = quote_terms ivs [c] in let (p, vm) = match quoted_terms with | [p], vm -> (p,vm) | _ -> assert false in match ivs.variable_lhs with | None -> cont (mkApp (f, [| p |])) | Some _ -> cont (mkApp (f, [| vm; p |])) end } (*i Just testing ... #use "include.ml";; open Quote;; let r = glob_constr_of_string;; let ivs = { normal_lhs_rhs = [ r "(f_and ?1 ?2)", r "?1/\?2"; r "(f_not ?1)", r "~?1"]; variable_lhs = Some (r "(f_atom ?1)"); return_type = r "Prop"; constants = ConstrSet.empty; constant_lhs = (r "nat") };; let t1 = r "True/\(True /\ ~False)";; let t2 = r "True/\~~False";; quote_term ivs () t1;; quote_term ivs () t2;; let ivs2 = normal_lhs_rhs = [ r "(f_and ?1 ?2)", r "?1/\?2"; r "(f_not ?1)", r "~?1" r "True", r "f_true"]; variable_lhs = Some (r "(f_atom ?1)"); return_type = r "Prop"; constants = ConstrSet.empty; constant_lhs = (r "nat") i*) coq-8.6/plugins/quote/vo.itarget0000644000175000017500000000001013022274260016271 0ustar mdenesmdenesQuote.vocoq-8.6/plugins/extraction/0000755000175000017500000000000013022274260015320 5ustar mdenesmdenescoq-8.6/plugins/extraction/mlutil.mli0000644000175000017500000001033513022274260017333 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val new_meta : 'a -> ml_type val type_subst_list : ml_type list -> ml_type -> ml_type val type_subst_vect : ml_type array -> ml_type -> ml_type val instantiation : ml_schema -> ml_type val needs_magic : ml_type * ml_type -> bool val put_magic_if : bool -> ml_ast -> ml_ast val put_magic : ml_type * ml_type -> ml_ast -> ml_ast val generalizable : ml_ast -> bool (*s ML type environment. *) module Mlenv : sig type t val empty : t (* get the n-th more recently entered schema and instantiate it. *) val get : t -> int -> ml_type (* Adding a type in an environment, after generalizing free meta *) val push_gen : t -> ml_type -> t (* Adding a type with no [Tvar] *) val push_type : t -> ml_type -> t (* Adding a type with no [Tvar] nor [Tmeta] *) val push_std_type : t -> ml_type -> t end (*s Utility functions over ML types without meta *) val type_mem_kn : mutual_inductive -> ml_type -> bool val type_maxvar : ml_type -> int val type_decomp : ml_type -> ml_type list * ml_type val type_recomp : ml_type list * ml_type -> ml_type val var2var' : ml_type -> ml_type type abbrev_map = global_reference -> ml_type option val type_expand : abbrev_map -> ml_type -> ml_type val type_simpl : ml_type -> ml_type val type_to_sign : abbrev_map -> ml_type -> sign val type_to_signature : abbrev_map -> ml_type -> signature val type_expunge : abbrev_map -> ml_type -> ml_type val type_expunge_from_sign : abbrev_map -> signature -> ml_type -> ml_type val eq_ml_type : ml_type -> ml_type -> bool val isTdummy : ml_type -> bool val isMLdummy : ml_ast -> bool val isKill : sign -> bool val case_expunge : signature -> ml_ast -> ml_ident list * ml_ast val term_expunge : signature -> ml_ident list * ml_ast -> ml_ast (*s Special identifiers. [dummy_name] is to be used for dead code and will be printed as [_] in concrete (Caml) code. *) val anonymous_name : Id.t val dummy_name : Id.t val id_of_name : Name.t -> Id.t val id_of_mlid : ml_ident -> Id.t val tmp_id : ml_ident -> ml_ident (*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns the list [idn;...;id1] and the term [t]. *) val collect_lams : ml_ast -> ml_ident list * ml_ast val collect_n_lams : int -> ml_ast -> ml_ident list * ml_ast val remove_n_lams : int -> ml_ast -> ml_ast val nb_lams : ml_ast -> int val named_lams : ml_ident list -> ml_ast -> ml_ast val dummy_lams : ml_ast -> int -> ml_ast val anonym_or_dummy_lams : ml_ast -> signature -> ml_ast val eta_args_sign : int -> signature -> ml_ast list (*s Utility functions over ML terms. *) val mlapp : ml_ast -> ml_ast list -> ml_ast val ast_map : (ml_ast -> ml_ast) -> ml_ast -> ml_ast val ast_map_lift : (int -> ml_ast -> ml_ast) -> int -> ml_ast -> ml_ast val ast_iter : (ml_ast -> unit) -> ml_ast -> unit val ast_occurs : int -> ml_ast -> bool val ast_occurs_itvl : int -> int -> ml_ast -> bool val ast_lift : int -> ml_ast -> ml_ast val ast_pop : ml_ast -> ml_ast val ast_subst : ml_ast -> ml_ast -> ml_ast val ast_glob_subst : ml_ast Refmap'.t -> ml_ast -> ml_ast val dump_unused_vars : ml_ast -> ml_ast val normalize : ml_ast -> ml_ast val optimize_fix : ml_ast -> ml_ast val inline : global_reference -> ml_ast -> bool val is_basic_pattern : ml_pattern -> bool val has_deep_pattern : ml_branch array -> bool val is_regular_match : ml_branch array -> bool exception Impossible (* Classification of signatures *) type sign_kind = | EmptySig | NonLogicalSig (* at least a [Keep] *) | SafeLogicalSig (* only [Kill Ktype] *) | UnsafeLogicalSig (* No [Keep], not all [Kill Ktype] *) val sign_kind : signature -> sign_kind val sign_no_final_keeps : signature -> signature coq-8.6/plugins/extraction/haskell.ml0000644000175000017500000003222213022274260017276 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Id.Set.add (Id.of_string s)) [ "Any"; "case"; "class"; "data"; "default"; "deriving"; "do"; "else"; "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance"; "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__"; "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ] Id.Set.empty let pp_comment s = str "-- " ++ s ++ fnl () let pp_bracket_comment s = str"{- " ++ hov 0 s ++ str" -}" (* Note: do not shorten [str "foo" ++ fnl ()] into [str "foo\n"], the '\n' character interacts badly with the Format boxing mechanism *) let preamble mod_name comment used_modules usf = let pp_import mp = str ("import qualified "^ string_of_modfile mp) ++ fnl () in (if not (usf.magic || usf.tunknown) then mt () else str "{-# OPTIONS_GHC -cpp -XMagicHash #-}" ++ fnl () ++ str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}" ++ fnl2 ()) ++ (match comment with | None -> mt () | Some com -> pp_bracket_comment com ++ fnl2 ()) ++ str "module " ++ pr_upper_id mod_name ++ str " where" ++ fnl2 () ++ str "import qualified Prelude" ++ fnl () ++ prlist pp_import used_modules ++ fnl () ++ (if not (usf.magic || usf.tunknown) then mt () else str "#ifdef __GLASGOW_HASKELL__" ++ fnl () ++ str "import qualified GHC.Base" ++ fnl () ++ str "import qualified GHC.Prim" ++ fnl () ++ str "#else" ++ fnl () ++ str "-- HUGS" ++ fnl () ++ str "import qualified IOExts" ++ fnl () ++ str "#endif" ++ fnl2 ()) ++ (if not usf.magic then mt () else str "#ifdef __GLASGOW_HASKELL__" ++ fnl () ++ str "unsafeCoerce :: a -> b" ++ fnl () ++ str "unsafeCoerce = GHC.Base.unsafeCoerce#" ++ fnl () ++ str "#else" ++ fnl () ++ str "-- HUGS" ++ fnl () ++ str "unsafeCoerce :: a -> b" ++ fnl () ++ str "unsafeCoerce = IOExts.unsafeCoerce" ++ fnl () ++ str "#endif" ++ fnl2 ()) ++ (if not usf.tunknown then mt () else str "#ifdef __GLASGOW_HASKELL__" ++ fnl () ++ str "type Any = GHC.Prim.Any" ++ fnl () ++ str "#else" ++ fnl () ++ str "-- HUGS" ++ fnl () ++ str "type Any = ()" ++ fnl () ++ str "#endif" ++ fnl2 ()) ++ (if not usf.mldummy then mt () else str "__ :: any" ++ fnl () ++ str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) let pp_abst = function | [] -> (mt ()) | l -> (str "\\" ++ prlist_with_sep (fun () -> (str " ")) pr_id l ++ str " ->" ++ spc ()) (*s The pretty-printer for haskell syntax *) let pp_global k r = if is_inline_custom r then str (find_custom r) else str (Common.pp_global k r) (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses are needed or not. *) let rec pp_type par vl t = let rec pp_rec par = function | Tmeta _ | Tvar' _ -> assert false | Tvar i -> (try pr_id (List.nth vl (pred i)) with Failure _ -> (str "a" ++ int i)) | Tglob (r,[]) -> pp_global Type r | Tglob (IndRef(kn,0),l) when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") -> pp_type true vl (List.hd l) | Tglob (r,l) -> pp_par par (pp_global Type r ++ spc () ++ prlist_with_sep spc (pp_type true vl) l) | Tarr (t1,t2) -> pp_par par (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) | Tdummy _ -> str "()" | Tunknown -> str "Any" | Taxiom -> str "() -- AXIOM TO BE REALIZED" ++ fnl () in hov 0 (pp_rec par t) (*s Pretty-printing of expressions. [par] indicates whether parentheses are needed or not. [env] is the list of names for the de Bruijn variables. [args] is the list of collected arguments (already pretty-printed). *) let expr_needs_par = function | MLlam _ -> true | MLcase _ -> false (* now that we use the case ... of { ... } syntax *) | _ -> false let rec pp_expr par env args = let apply st = pp_apply st par args and apply2 st = pp_apply2 st par args in function | MLrel n -> let id = get_db_name n env in (* Try to survive to the occurrence of a Dummy rel. TODO: we should get rid of this hack (cf. #592) *) let id = if Id.equal id dummy_name then Id.of_string "__" else id in apply (pr_id id) | MLapp (f,args') -> let stl = List.map (pp_expr true env []) args' in pp_expr par env (stl @ args) f | MLlam _ as a -> let fl,a' = collect_lams a in let fl,env' = push_vars (List.map id_of_mlid fl) env in let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in apply2 st | MLletin (id,a1,a2) -> let i,env' = push_vars [id_of_mlid id] env in let pp_id = pr_id (List.hd i) and pp_a1 = pp_expr false env [] a1 and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in let pp_def = str "let {" ++ cut () ++ hov 1 (pp_id ++ str " = " ++ pp_a1 ++ str "}") in apply2 (hv 0 (hv 0 (hv 1 pp_def ++ spc () ++ str "in") ++ spc () ++ hov 0 pp_a2)) | MLglob r -> apply (pp_global Term r) | MLcons (_,r,a) as c -> assert (List.is_empty args); begin match a with | _ when is_native_char c -> pp_native_char c | [] -> pp_global Cons r | [a] -> pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a) | _ -> pp_par par (pp_global Cons r ++ spc () ++ prlist_with_sep spc (pp_expr true env []) a) end | MLtuple l -> assert (List.is_empty args); pp_boxed_tuple (pp_expr true env []) l | MLcase (_,t, pv) when is_custom_match pv -> if not (is_regular_match pv) then error "Cannot mix yet user-given match and general patterns."; let mkfun (ids,_,e) = if not (List.is_empty ids) then named_lams (List.rev ids) e else dummy_lams (ast_lift 1 e) 1 in let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in let inner = str (find_custom_match pv) ++ fnl () ++ prvect pp_branch pv ++ pp_expr true env [] t in apply2 (hov 2 inner) | MLcase (typ,t,pv) -> apply2 (v 0 (str "case " ++ pp_expr false env [] t ++ str " of {" ++ fnl () ++ pp_pat env pv)) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' i (Array.of_list (List.rev ids'),defs) args | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) pp_par par (str "Prelude.error" ++ spc () ++ qs s) | MLdummy k -> (* An [MLdummy] may be applied, but I don't really care. *) (match msg_of_implicit k with | "" -> str "__" | s -> str "__" ++ spc () ++ pp_bracket_comment (str s)) | MLmagic a -> pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args) | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"") and pp_cons_pat par r ppl = pp_par par (pp_global Cons r ++ space_if (not (List.is_empty ppl)) ++ prlist_with_sep spc identity ppl) and pp_gen_pat par ids env = function | Pcons (r,l) -> pp_cons_pat par r (List.map (pp_gen_pat true ids env) l) | Pusual r -> pp_cons_pat par r (List.map pr_id ids) | Ptuple l -> pp_boxed_tuple (pp_gen_pat false ids env) l | Pwild -> str "_" | Prel n -> pr_id (get_db_name n env) and pp_one_pat env (ids,p,t) = let ids',env' = push_vars (List.rev_map id_of_mlid ids) env in hov 2 (str " " ++ pp_gen_pat false (List.rev ids') env' p ++ str " ->" ++ spc () ++ pp_expr (expr_needs_par t) env' [] t) and pp_pat env pv = prvecti (fun i x -> pp_one_pat env pv.(i) ++ if Int.equal i (Array.length pv - 1) then str "}" else (str ";" ++ fnl ())) pv (*s names of the functions ([ids]) are already pushed in [env], and passed here just for convenience. *) and pp_fix par env i (ids,bl) args = pp_par par (v 0 (v 1 (str "let {" ++ fnl () ++ prvect_with_sep (fun () -> str ";" ++ fnl ()) (fun (fi,ti) -> pp_function env (pr_id fi) ti) (Array.map2 (fun a b -> a,b) ids bl) ++ str "}") ++ fnl () ++ str "in " ++ pp_apply (pr_id ids.(i)) false args)) and pp_function env f t = let bl,t' = collect_lams t in let bl,env' = push_vars (List.map id_of_mlid bl) env in (f ++ pr_binding (List.rev bl) ++ str " =" ++ fnl () ++ str " " ++ hov 2 (pp_expr false env' [] t')) (*s Pretty-printing of inductive types declaration. *) let pp_logical_ind packet = pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ pp_comment (str "with constructors : " ++ prvect_with_sep spc pr_id packet.ip_consnames) let pp_singleton kn packet = let name = pp_global Type (IndRef (kn,0)) in let l = rename_tvars keywords packet.ip_vars in hov 2 (str "type " ++ name ++ spc () ++ prlist_with_sep spc pr_id l ++ (if not (List.is_empty l) then str " " else mt ()) ++ str "=" ++ spc () ++ pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ pp_comment (str "singleton inductive, whose constructor was " ++ pr_id packet.ip_consnames.(0))) let pp_one_ind ip pl cv = let pl = rename_tvars keywords pl in let pp_constructor (r,l) = (pp_global Cons r ++ match l with | [] -> (mt ()) | _ -> (str " " ++ prlist_with_sep (fun () -> (str " ")) (pp_type true pl) l)) in str (if Array.is_empty cv then "type " else "data ") ++ pp_global Type (IndRef ip) ++ prlist_strict (fun id -> str " " ++ pr_lower_id id) pl ++ str " =" ++ if Array.is_empty cv then str " () -- empty inductive" else (fnl () ++ str " " ++ v 0 (str " " ++ prvect_with_sep (fun () -> fnl () ++ str "| ") pp_constructor (Array.mapi (fun i c -> ConstructRef (ip,i+1),c) cv))) let rec pp_ind first kn i ind = if i >= Array.length ind.ind_packets then if first then mt () else fnl () else let ip = (kn,i) in let p = ind.ind_packets.(i) in if is_custom (IndRef (kn,i)) then pp_ind first kn (i+1) ind else if p.ip_logical then pp_logical_ind p ++ pp_ind first kn (i+1) ind else pp_one_ind ip p.ip_vars p.ip_types ++ fnl () ++ pp_ind false kn (i+1) ind (*s Pretty-printing of a declaration. *) let pp_decl = function | Dind (kn,i) when i.ind_kind == Singleton -> pp_singleton kn i.ind_packets.(0) ++ fnl () | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i) | Dtype (r, l, t) -> if is_inline_custom r then mt () else let l = rename_tvars keywords l in let st = try let ids,s = find_type_custom r in prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s with Not_found -> prlist (fun id -> pr_id id ++ str " ") l ++ if t == Taxiom then str "= () -- AXIOM TO BE REALIZED" ++ fnl () else str "=" ++ spc () ++ pp_type false l t in hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 () | Dfix (rv, defs, typs) -> let names = Array.map (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv in prvecti (fun i r -> let void = is_inline_custom r || (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then mt () else hov 2 (names.(i) ++ str " :: " ++ pp_type false [] typs.(i)) ++ fnl () ++ (if is_custom r then (names.(i) ++ str " = " ++ str (find_custom r)) else (pp_function (empty_env ()) names.(i) defs.(i))) ++ fnl2 ()) rv | Dterm (r, a, t) -> if is_inline_custom r then mt () else let e = pp_global Term r in hov 2 (e ++ str " :: " ++ pp_type false [] t) ++ fnl () ++ if is_custom r then hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ()) else hov 0 (pp_function (empty_env ()) e a ++ fnl2 ()) let rec pp_structure_elem = function | (l,SEdecl d) -> pp_decl d | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr | (l,SEmodtype m) -> mt () (* for the moment we simply discard module type *) and pp_module_expr = function | MEstruct (mp,sel) -> prlist_strict pp_structure_elem sel | MEfunctor _ -> mt () (* for the moment we simply discard unapplied functors *) | MEident _ | MEapply _ -> assert false (* should be expanded in extract_env *) let pp_struct = let pp_sel (mp,sel) = push_visible mp []; let p = prlist_strict pp_structure_elem sel in pop_visible (); p in prlist_strict pp_sel let haskell_descr = { keywords = keywords; file_suffix = ".hs"; file_naming = string_of_modfile; preamble = preamble; pp_struct = pp_struct; sig_suffix = None; sig_preamble = (fun _ _ _ _ -> mt ()); pp_sig = (fun _ -> mt ()); pp_decl = pp_decl; } coq-8.6/plugins/extraction/json.mli0000644000175000017500000000004713022274260016775 0ustar mdenesmdenesval json_descr : Miniml.language_descr coq-8.6/plugins/extraction/extraction.mli0000644000175000017500000000236213022274260020206 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constant -> constant_body -> ml_decl val extract_constant_spec : env -> constant -> constant_body -> ml_spec (** For extracting "module ... with ..." declaration *) val extract_with_type : env -> constr -> ( Id.t list * ml_type ) option val extract_fixpoint : env -> constant array -> (constr, types) prec_declaration -> ml_decl val extract_inductive : env -> mutual_inductive -> ml_ind (** For extraction compute *) val extract_constr : env -> constr -> ml_ast * ml_type (*s Is a [ml_decl] or a [ml_spec] logical ? *) val logical_decl : ml_decl -> bool val logical_spec : ml_spec -> bool coq-8.6/plugins/extraction/common.mli0000644000175000017500000000556613022274260017327 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* std_ppcmds val fnl2 : unit -> std_ppcmds val space_if : bool -> std_ppcmds val pp_par : bool -> std_ppcmds -> std_ppcmds (** [pp_apply] : a head part applied to arguments, possibly with parenthesis *) val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds (** Same as [pp_apply], but with also protection of the head by parenthesis *) val pp_apply2 : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds val pp_tuple_light : (bool -> 'a -> std_ppcmds) -> 'a list -> std_ppcmds val pp_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds val pp_boxed_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds val pr_binding : Id.t list -> std_ppcmds val rename_id : Id.t -> Id.Set.t -> Id.t type env = Id.t list * Id.Set.t val empty_env : unit -> env val rename_vars: Id.Set.t -> Id.t list -> env val rename_tvars: Id.Set.t -> Id.t list -> Id.t list val push_vars : Id.t list -> env -> Id.t list * env val get_db_name : int -> env -> Id.t type phase = Pre | Impl | Intf val set_phase : phase -> unit val get_phase : unit -> phase val opened_libraries : unit -> module_path list type kind = Term | Type | Cons | Mod val pp_global : kind -> global_reference -> string val pp_module : module_path -> string val top_visible_mp : unit -> module_path (* In [push_visible], the [module_path list] corresponds to module parameters, the innermost one coming first in the list *) val push_visible : module_path -> module_path list -> unit val pop_visible : unit -> unit val check_duplicate : module_path -> Label.t -> string type reset_kind = AllButExternal | Everything val reset_renaming_tables : reset_kind -> unit val set_keywords : Id.Set.t -> unit (** For instance: [mk_ind "Coq.Init.Datatypes" "nat"] *) val mk_ind : string -> string -> mutual_inductive (** Special hack for constants of type Ascii.ascii : if an [Extract Inductive ascii => char] has been declared, then the constants are directly turned into chars *) val is_native_char : ml_ast -> bool val get_native_char : ml_ast -> char val pp_native_char : ml_ast -> std_ppcmds coq-8.6/plugins/extraction/modutil.ml0000644000175000017500000003347113022274260017337 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mp | MTwith(mt,_)-> msid_of_mt mt | _ -> anomaly ~label:"extraction" (Pp.str "the With operator isn't applied to a name") (*s Apply some functions upon all [ml_decl] and [ml_spec] found in a [ml_structure]. *) let se_iter do_decl do_spec do_mp = let rec mt_iter = function | MTident mp -> do_mp mp | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt' | MTwith (mt,ML_With_type(idl,l,t))-> let mp_mt = msid_of_mt mt in let l',idl' = List.sep_last idl in let mp_w = List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl' in let r = ConstRef (Constant.make2 mp_w (Label.of_id l')) in mt_iter mt; do_decl (Dtype(r,l,t)) | MTwith (mt,ML_With_module(idl,mp))-> let mp_mt = msid_of_mt mt in let mp_w = List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl in mt_iter mt; do_mp mp_w; do_mp mp | MTsig (_, sign) -> List.iter spec_iter sign and spec_iter = function | (_,Spec s) -> do_spec s | (_,Smodule mt) -> mt_iter mt | (_,Smodtype mt) -> mt_iter mt in let rec se_iter = function | (_,SEdecl d) -> do_decl d | (_,SEmodule m) -> me_iter m.ml_mod_expr; mt_iter m.ml_mod_type | (_,SEmodtype m) -> mt_iter m and me_iter = function | MEident mp -> do_mp mp | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt | MEapply (me,me') -> me_iter me; me_iter me' | MEstruct (msid, sel) -> List.iter se_iter sel in se_iter let struct_iter do_decl do_spec do_mp s = List.iter (function (_,sel) -> List.iter (se_iter do_decl do_spec do_mp) sel) s (*s Apply some fonctions upon all references in [ml_type], [ml_ast], [ml_decl], [ml_spec] and [ml_structure]. *) type do_ref = global_reference -> unit let record_iter_references do_term = function | Record l -> List.iter (Option.iter do_term) l | _ -> () let type_iter_references do_type t = let rec iter = function | Tglob (r,l) -> do_type r; List.iter iter l | Tarr (a,b) -> iter a; iter b | _ -> () in iter t let patt_iter_references do_cons p = let rec iter = function | Pcons (r,l) -> do_cons r; List.iter iter l | Pusual r -> do_cons r | Ptuple l -> List.iter iter l | Prel _ | Pwild -> () in iter p let ast_iter_references do_term do_cons do_type a = let rec iter a = ast_iter iter a; match a with | MLglob r -> do_term r | MLcons (_,r,_) -> do_cons r | MLcase (ty,_,v) -> type_iter_references do_type ty; Array.iter (fun (_,p,_) -> patt_iter_references do_cons p) v | MLrel _ | MLlam _ | MLapp _ | MLletin _ | MLtuple _ | MLfix _ | MLexn _ | MLdummy _ | MLaxiom | MLmagic _ -> () in iter a let ind_iter_references do_term do_cons do_type kn ind = let type_iter = type_iter_references do_type in let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in let packet_iter ip p = do_type (IndRef ip); if lang () == Ocaml then (match ind.ind_equiv with | Miniml.Equiv kne -> do_type (IndRef (mind_of_kn kne, snd ip)); | _ -> ()); Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types in if lang () == Ocaml then record_iter_references do_term ind.ind_kind; Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets let decl_iter_references do_term do_cons do_type = let type_iter = type_iter_references do_type and ast_iter = ast_iter_references do_term do_cons do_type in function | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind | Dtype (r,_,t) -> do_type r; type_iter t | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t | Dfix(rv,c,t) -> Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t let spec_iter_references do_term do_cons do_type = function | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind | Stype (r,_,ot) -> do_type r; Option.iter (type_iter_references do_type) ot | Sval (r,t) -> do_term r; type_iter_references do_type t (*s Searching occurrences of a particular term (no lifting done). *) exception Found let rec ast_search f a = if f a then raise Found else ast_iter (ast_search f) a let decl_ast_search f = function | Dterm (_,a,_) -> ast_search f a | Dfix (_,c,_) -> Array.iter (ast_search f) c | _ -> () let struct_ast_search f s = try struct_iter (decl_ast_search f) (fun _ -> ()) (fun _ -> ()) s; false with Found -> true let rec type_search f = function | Tarr (a,b) -> type_search f a; type_search f b | Tglob (r,l) -> List.iter (type_search f) l | u -> if f u then raise Found let decl_type_search f = function | Dind (_,{ind_packets=p}) -> Array.iter (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p | Dterm (_,_,u) -> type_search f u | Dfix (_,_,v) -> Array.iter (type_search f) v | Dtype (_,_,u) -> type_search f u let spec_type_search f = function | Sind (_,{ind_packets=p}) -> Array.iter (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p | Stype (_,_,ot) -> Option.iter (type_search f) ot | Sval (_,u) -> type_search f u let struct_type_search f s = try struct_iter (decl_type_search f) (spec_type_search f) (fun _ -> ()) s; false with Found -> true (*s Generating the signature. *) let rec msig_of_ms = function | [] -> [] | (l,SEdecl (Dind (kn,i))) :: ms -> (l,Spec (Sind (kn,i))) :: (msig_of_ms ms) | (l,SEdecl (Dterm (r,_,t))) :: ms -> (l,Spec (Sval (r,t))) :: (msig_of_ms ms) | (l,SEdecl (Dtype (r,v,t))) :: ms -> (l,Spec (Stype (r,v,Some t))) :: (msig_of_ms ms) | (l,SEdecl (Dfix (rv,_,tv))) :: ms -> let msig = ref (msig_of_ms ms) in for i = Array.length rv - 1 downto 0 do msig := (l,Spec (Sval (rv.(i),tv.(i))))::!msig done; !msig | (l,SEmodule m) :: ms -> (l,Smodule m.ml_mod_type) :: (msig_of_ms ms) | (l,SEmodtype m) :: ms -> (l,Smodtype m) :: (msig_of_ms ms) let signature_of_structure s = List.map (fun (mp,ms) -> mp,msig_of_ms ms) s let rec mtyp_of_mexpr = function | MEfunctor (id,ty,e) -> MTfunsig (id,ty, mtyp_of_mexpr e) | MEstruct (mp,str) -> MTsig (mp, msig_of_ms str) | _ -> assert false (*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *) let is_modular = function | SEdecl _ -> false | SEmodule _ | SEmodtype _ -> true let rec search_structure l m = function | [] -> raise Not_found | (lab,d)::_ when Label.equal lab l && (is_modular d : bool) == m -> d | _::fields -> search_structure l m fields let get_decl_in_structure r struc = try let base_mp,ll = labels_of_ref r in if not (at_toplevel base_mp) then error_not_visible r; let sel = List.assoc_f ModPath.equal base_mp struc in let rec go ll sel = match ll with | [] -> assert false | l :: ll -> match search_structure l (not (List.is_empty ll)) sel with | SEdecl d -> d | SEmodtype m -> assert false | SEmodule m -> match m.ml_mod_expr with | MEstruct (_,sel) -> go ll sel | _ -> error_not_visible r in go ll sel with Not_found -> anomaly (Pp.str "reference not found in extracted structure") (*s Optimization of a [ml_structure]. *) (* Some transformations of ML terms. [optimize_struct] simplify all beta redexes (when the argument does not occur, it is just thrown away; when it occurs exactly once it is substituted; otherwise a let-in redex is created for clarity) and iota redexes, plus some other optimizations. *) let dfix_to_mlfix rv av i = let rec make_subst n s = if n < 0 then s else make_subst (n-1) (Refmap'.add rv.(n) (n+1) s) in let s = make_subst (Array.length rv - 1) Refmap'.empty in let rec subst n t = match t with | MLglob ((ConstRef kn) as refe) -> (try MLrel (n + (Refmap'.find refe s)) with Not_found -> t) | _ -> ast_map_lift subst n t in let ids = Array.map (fun r -> Label.to_id (label_of_r r)) rv in let c = Array.map (subst 0) av in MLfix(i, ids, c) (* [optim_se] applies the [normalize] function everywhere and does the inlining of code. The inlined functions are kept for the moment in order to preserve the global interface, later [depcheck_se] will get rid of them if possible *) let rec optim_se top to_appear s = function | [] -> [] | (l,SEdecl (Dterm (r,a,t))) :: lse -> let a = normalize (ast_glob_subst !s a) in let i = inline r a in if i then s := Refmap'.add r a !s; let d = match dump_unused_vars (optimize_fix a) with | MLfix (0, _, [|c|]) -> Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) | a -> Dterm (r, a, t) in (l,SEdecl d) :: (optim_se top to_appear s lse) | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in (* This fake body ensures that no fixpoint will be auto-inlined. *) let fake_body = MLfix (0,[||],[||]) in for i = 0 to Array.length rv - 1 do if inline rv.(i) fake_body then s := Refmap'.add rv.(i) (dfix_to_mlfix rv av i) !s done; let av' = Array.map dump_unused_vars av in (l,SEdecl (Dfix (rv, av', tv))) :: (optim_se top to_appear s lse) | (l,SEmodule m) :: lse -> let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr} in (l,SEmodule m) :: (optim_se top to_appear s lse) | se :: lse -> se :: (optim_se top to_appear s lse) and optim_me to_appear s = function | MEstruct (msid, lse) -> MEstruct (msid, optim_se false to_appear s lse) | MEident mp as me -> me | MEapply (me, me') -> MEapply (optim_me to_appear s me, optim_me to_appear s me') | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me to_appear s me) (* After these optimisations, some dependencies may not be needed anymore. For non-library extraction, we recompute a minimal set of dependencies for first-level definitions (no module pruning yet). *) let base_r = function | ConstRef c as r -> r | IndRef (kn,_) -> IndRef (kn,0) | ConstructRef ((kn,_),_) -> IndRef (kn,0) | _ -> assert false let reset_needed, add_needed, add_needed_mp, found_needed, is_needed = let needed = ref Refset'.empty and needed_mps = ref MPset.empty in ((fun () -> needed := Refset'.empty; needed_mps := MPset.empty), (fun r -> needed := Refset'.add (base_r r) !needed), (fun mp -> needed_mps := MPset.add mp !needed_mps), (fun r -> needed := Refset'.remove (base_r r) !needed), (fun r -> let r = base_r r in Refset'.mem r !needed || MPset.mem (modpath_of_r r) !needed_mps)) let declared_refs = function | Dind (kn,_) -> [IndRef (kn,0)] | Dtype (r,_,_) -> [r] | Dterm (r,_,_) -> [r] | Dfix (rv,_,_) -> Array.to_list rv (* Computes the dependencies of a declaration, except in case of custom extraction. *) let compute_deps_decl = function | Dind (kn,ind) -> (* Todo Later : avoid dependencies when Extract Inductive *) ind_iter_references add_needed add_needed add_needed kn ind | Dtype (r,ids,t) -> if not (is_custom r) then type_iter_references add_needed t | Dterm (r,u,t) -> type_iter_references add_needed t; if not (is_custom r) then ast_iter_references add_needed add_needed add_needed u | Dfix _ as d -> decl_iter_references add_needed add_needed add_needed d let compute_deps_spec = function | Sind (kn,ind) -> (* Todo Later : avoid dependencies when Extract Inductive *) ind_iter_references add_needed add_needed add_needed kn ind | Stype (r,ids,t) -> if not (is_custom r) then Option.iter (type_iter_references add_needed) t | Sval (r,t) -> type_iter_references add_needed t let rec depcheck_se = function | [] -> [] | ((l,SEdecl d) as t) :: se -> let se' = depcheck_se se in let refs = declared_refs d in let refs' = List.filter is_needed refs in if List.is_empty refs' then (List.iter remove_info_axiom refs; List.iter remove_opaque refs; se') else begin List.iter found_needed refs'; (* Hack to avoid extracting unused part of a Dfix *) match d with | Dfix (rv,trms,tys) when (List.for_all is_custom refs') -> let trms' = Array.make (Array.length rv) (MLexn "UNUSED") in ((l,SEdecl (Dfix (rv,trms',tys))) :: se') | _ -> (compute_deps_decl d; t::se') end | t :: se -> let se' = depcheck_se se in se_iter compute_deps_decl compute_deps_spec add_needed_mp t; t :: se' let rec depcheck_struct = function | [] -> [] | (mp,lse)::struc -> let struc' = depcheck_struct struc in let lse' = depcheck_se lse in if List.is_empty lse' then struc' else (mp,lse')::struc' exception RemainingImplicit of kill_reason let check_for_remaining_implicits struc = let check = function | MLdummy (Kimplicit _ as k) -> raise (RemainingImplicit k) | _ -> false in try ignore (struct_ast_search check struc) with RemainingImplicit k -> err_or_warn_remaining_implicit k let optimize_struct to_appear struc = let subst = ref (Refmap'.empty : ml_ast Refmap'.t) in let opt_struc = List.map (fun (mp,lse) -> (mp, optim_se true (fst to_appear) subst lse)) struc in let mini_struc = if library () then List.filter (fun (_,lse) -> not (List.is_empty lse)) opt_struc else begin reset_needed (); List.iter add_needed (fst to_appear); List.iter add_needed_mp (snd to_appear); depcheck_struct opt_struc end in let () = check_for_remaining_implicits mini_struc in mini_struc coq-8.6/plugins/extraction/ExtrHaskellString.v0000644000175000017500000000274513022274260021134 0ustar mdenesmdenes(** * Special handling of ascii and strings for extraction to Haskell. *) Require Import Ascii. Require Import String. (** * At the moment, Coq's extraction has no way to add extra import * statements to the extracted Haskell code. You will have to * manually add: * * import qualified Data.Bits * import qualified Data.Char *) Extract Inductive ascii => "Prelude.Char" [ "(\b0 b1 b2 b3 b4 b5 b6 b7 -> Data.Char.chr ( (if b0 then Data.Bits.shiftL 1 0 else 0) Prelude.+ (if b1 then Data.Bits.shiftL 1 1 else 0) Prelude.+ (if b2 then Data.Bits.shiftL 1 2 else 0) Prelude.+ (if b3 then Data.Bits.shiftL 1 3 else 0) Prelude.+ (if b4 then Data.Bits.shiftL 1 4 else 0) Prelude.+ (if b5 then Data.Bits.shiftL 1 5 else 0) Prelude.+ (if b6 then Data.Bits.shiftL 1 6 else 0) Prelude.+ (if b7 then Data.Bits.shiftL 1 7 else 0)))" ] "(\f a -> f (Data.Bits.testBit (Data.Char.ord a) 0) (Data.Bits.testBit (Data.Char.ord a) 1) (Data.Bits.testBit (Data.Char.ord a) 2) (Data.Bits.testBit (Data.Char.ord a) 3) (Data.Bits.testBit (Data.Char.ord a) 4) (Data.Bits.testBit (Data.Char.ord a) 5) (Data.Bits.testBit (Data.Char.ord a) 6) (Data.Bits.testBit (Data.Char.ord a) 7))". Extract Inlined Constant Ascii.ascii_dec => "(Prelude.==)". Extract Inductive string => "Prelude.String" [ "([])" "(:)" ]. Extract Inlined Constant String.string_dec => "(Prelude.==)". coq-8.6/plugins/extraction/mlutil.ml0000644000175000017500000014073413022274260017171 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* anonymous_name | Name id when Id.equal id dummy_name -> anonymous_name | Name id -> id let id_of_mlid = function | Dummy -> dummy_name | Id id -> id | Tmp id -> id let tmp_id = function | Id id -> Tmp id | a -> a let is_tmp = function Tmp _ -> true | _ -> false (*S Operations upon ML types (with meta). *) let meta_count = ref 0 let reset_meta_count () = meta_count := 0 let new_meta _ = incr meta_count; Tmeta {id = !meta_count; contents = None} let rec eq_ml_type t1 t2 = match t1, t2 with | Tarr (tl1, tr1), Tarr (tl2, tr2) -> eq_ml_type tl1 tl2 && eq_ml_type tr1 tr2 | Tglob (gr1, t1), Tglob (gr2, t2) -> eq_gr gr1 gr2 && List.equal eq_ml_type t1 t2 | Tvar i1, Tvar i2 -> Int.equal i1 i2 | Tvar' i1, Tvar' i2 -> Int.equal i1 i2 | Tmeta m1, Tmeta m2 -> eq_ml_meta m1 m2 | Tdummy k1, Tdummy k2 -> k1 == k2 | Tunknown, Tunknown -> true | Taxiom, Taxiom -> true | _ -> false and eq_ml_meta m1 m2 = Int.equal m1.id m2.id && Option.equal eq_ml_type m1.contents m2.contents (* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *) let type_subst_list l t = let rec subst t = match t with | Tvar j -> List.nth l (j-1) | Tmeta {contents=None} -> t | Tmeta {contents=Some u} -> subst u | Tarr (a,b) -> Tarr (subst a, subst b) | Tglob (r, l) -> Tglob (r, List.map subst l) | a -> a in subst t (* Simultaneous substitution of [[|Tvar 1; ... ; Tvar n|]] by [v] in a ML type. *) let type_subst_vect v t = let rec subst t = match t with | Tvar j -> v.(j-1) | Tmeta {contents=None} -> t | Tmeta {contents=Some u} -> subst u | Tarr (a,b) -> Tarr (subst a, subst b) | Tglob (r, l) -> Tglob (r, List.map subst l) | a -> a in subst t (*s From a type schema to a type. All [Tvar] become fresh [Tmeta]. *) let instantiation (nb,t) = type_subst_vect (Array.init nb new_meta) t (*s Occur-check of a free meta in a type *) let rec type_occurs alpha t = match t with | Tmeta {id=beta; contents=None} -> Int.equal alpha beta | Tmeta {contents=Some u} -> type_occurs alpha u | Tarr (t1, t2) -> type_occurs alpha t1 || type_occurs alpha t2 | Tglob (r,l) -> List.exists (type_occurs alpha) l | _ -> false (*s Most General Unificator *) let rec mgu = function | Tmeta m, Tmeta m' when Int.equal m.id m'.id -> () | Tmeta m, t | t, Tmeta m -> (match m.contents with | Some u -> mgu (u, t) | None when type_occurs m.id t -> raise Impossible | None -> m.contents <- Some t) | Tarr(a, b), Tarr(a', b') -> mgu (a, a'); mgu (b, b') | Tglob (r,l), Tglob (r',l') when Globnames.eq_gr r r' -> List.iter mgu (List.combine l l') | (Tdummy _, _ | _, Tdummy _) when lang() == Haskell -> () | Tdummy _, Tdummy _ -> () | Tvar i, Tvar j when Int.equal i j -> () | Tvar' i, Tvar' j when Int.equal i j -> () | Tunknown, Tunknown -> () | Taxiom, Taxiom -> () | _ -> raise Impossible let needs_magic p = try mgu p; false with Impossible -> true let put_magic_if b a = if b && lang () != Scheme then MLmagic a else a let put_magic p a = if needs_magic p && lang () != Scheme then MLmagic a else a let generalizable a = lang () != Ocaml || match a with | MLapp _ -> false | _ -> true (* TODO, this is just an approximation for the moment *) (*S ML type env. *) module Mlenv = struct let meta_cmp m m' = compare m.id m'.id module Metaset = Set.Make(struct type t = ml_meta let compare = meta_cmp end) (* Main MLenv type. [env] is the real environment, whereas [free] (tries to) record the free meta variables occurring in [env]. *) type t = { env : ml_schema list; mutable free : Metaset.t} (* Empty environment. *) let empty = { env = []; free = Metaset.empty } (* [get] returns a instantiated copy of the n-th most recently added type in the environment. *) let get mle n = assert (List.length mle.env >= n); instantiation (List.nth mle.env (n-1)) (* [find_free] finds the free meta in a type. *) let rec find_free set = function | Tmeta m when Option.is_empty m.contents -> Metaset.add m set | Tmeta {contents = Some t} -> find_free set t | Tarr (a,b) -> find_free (find_free set a) b | Tglob (_,l) -> List.fold_left find_free set l | _ -> set (* The [free] set of an environment can be outdate after some unifications. [clean_free] takes care of that. *) let clean_free mle = let rem = ref Metaset.empty and add = ref Metaset.empty in let clean m = match m.contents with | None -> () | Some u -> rem := Metaset.add m !rem; add := find_free !add u in Metaset.iter clean mle.free; mle.free <- Metaset.union (Metaset.diff mle.free !rem) !add (* From a type to a type schema. If a [Tmeta] is still uninstantiated and does appears in the [mle], then it becomes a [Tvar]. *) let generalization mle t = let c = ref 0 in let map = ref (Int.Map.empty : int Int.Map.t) in let add_new i = incr c; map := Int.Map.add i !c !map; !c in let rec meta2var t = match t with | Tmeta {contents=Some u} -> meta2var u | Tmeta ({id=i} as m) -> (try Tvar (Int.Map.find i !map) with Not_found -> if Metaset.mem m mle.free then t else Tvar (add_new i)) | Tarr (t1,t2) -> Tarr (meta2var t1, meta2var t2) | Tglob (r,l) -> Tglob (r, List.map meta2var l) | t -> t in !c, meta2var t (* Adding a type in an environment, after generalizing. *) let push_gen mle t = clean_free mle; { env = generalization mle t :: mle.env; free = mle.free } (* Adding a type with no [Tvar], hence no generalization needed. *) let push_type {env=e;free=f} t = { env = (0,t) :: e; free = find_free f t} (* Adding a type with no [Tvar] nor [Tmeta]. *) let push_std_type {env=e;free=f} t = { env = (0,t) :: e; free = f} end (*S Operations upon ML types (without meta). *) (*s Does a section path occur in a ML type ? *) let rec type_mem_kn kn = function | Tmeta {contents = Some t} -> type_mem_kn kn t | Tglob (r,l) -> occur_kn_in_ref kn r || List.exists (type_mem_kn kn) l | Tarr (a,b) -> (type_mem_kn kn a) || (type_mem_kn kn b) | _ -> false (*s Greatest variable occurring in [t]. *) let type_maxvar t = let rec parse n = function | Tmeta {contents = Some t} -> parse n t | Tvar i -> max i n | Tarr (a,b) -> parse (parse n a) b | Tglob (_,l) -> List.fold_left parse n l | _ -> n in parse 0 t (*s From [a -> b -> c] to [[a;b],c]. *) let rec type_decomp = function | Tmeta {contents = Some t} -> type_decomp t | Tarr (a,b) -> let l,h = type_decomp b in a::l, h | a -> [],a (*s The converse: From [[a;b],c] to [a -> b -> c]. *) let rec type_recomp (l,t) = match l with | [] -> t | a::l -> Tarr (a, type_recomp (l,t)) (*s Translating [Tvar] to [Tvar'] to avoid clash. *) let rec var2var' = function | Tmeta {contents = Some t} -> var2var' t | Tvar i -> Tvar' i | Tarr (a,b) -> Tarr (var2var' a, var2var' b) | Tglob (r,l) -> Tglob (r, List.map var2var' l) | a -> a type abbrev_map = global_reference -> ml_type option (*s Delta-reduction of type constants everywhere in a ML type [t]. [env] is a function of type [ml_type_env]. *) let type_expand env t = let rec expand = function | Tmeta {contents = Some t} -> expand t | Tglob (r,l) -> (match env r with | Some mlt -> expand (type_subst_list l mlt) | None -> Tglob (r, List.map expand l)) | Tarr (a,b) -> Tarr (expand a, expand b) | a -> a in if Table.type_expand () then expand t else t let type_simpl = type_expand (fun _ -> None) (*s Generating a signature from a ML type. *) let type_to_sign env t = match type_expand env t with | Tdummy d when not (conservative_types ()) -> Kill d | _ -> Keep let type_to_signature env t = let rec f = function | Tmeta {contents = Some t} -> f t | Tarr (Tdummy d, b) when not (conservative_types ()) -> Kill d :: f b | Tarr (_, b) -> Keep :: f b | _ -> [] in f (type_expand env t) let isKill = function Kill _ -> true | _ -> false let isTdummy = function Tdummy _ -> true | _ -> false let isMLdummy = function MLdummy _ -> true | _ -> false let sign_of_id = function | Dummy -> Kill Kprop | _ -> Keep (* Classification of signatures *) type sign_kind = | EmptySig | NonLogicalSig (* at least a [Keep] *) | SafeLogicalSig (* only [Kill Ktype] *) | UnsafeLogicalSig (* No [Keep], not all [Kill Ktype] *) let rec sign_kind = function | [] -> EmptySig | Keep :: _ -> NonLogicalSig | Kill k :: s -> match k, sign_kind s with | _, NonLogicalSig -> NonLogicalSig | Ktype, (SafeLogicalSig | EmptySig) -> SafeLogicalSig | _, _ -> UnsafeLogicalSig (* Removing the final [Keep] in a signature *) let rec sign_no_final_keeps = function | [] -> [] | k :: s -> match k, sign_no_final_keeps s with | Keep, [] -> [] | k, l -> k::l (*s Removing [Tdummy] from the top level of a ML type. *) let type_expunge_from_sign env s t = let rec expunge s t = match s, t with | [], _ -> t | Keep :: s, Tarr(a,b) -> Tarr (a, expunge s b) | Kill _ :: s, Tarr(a,b) -> expunge s b | _, Tmeta {contents = Some t} -> expunge s t | _, Tglob (r,l) -> (match env r with | Some mlt -> expunge s (type_subst_list l mlt) | None -> assert false) | _ -> assert false in let t = expunge (sign_no_final_keeps s) t in if lang () != Haskell && sign_kind s == UnsafeLogicalSig then Tarr (Tdummy Kprop, t) else t let type_expunge env t = type_expunge_from_sign env (type_to_signature env t) t (*S Generic functions over ML ast terms. *) let mlapp f a = if List.is_empty a then f else MLapp (f,a) (** Equality *) let eq_ml_ident i1 i2 = match i1, i2 with | Dummy, Dummy -> true | Id id1, Id id2 -> Id.equal id1 id2 | Tmp id1, Tmp id2 -> Id.equal id1 id2 | _ -> false let rec eq_ml_ast t1 t2 = match t1, t2 with | MLrel i1, MLrel i2 -> Int.equal i1 i2 | MLapp (f1, t1), MLapp (f2, t2) -> eq_ml_ast f1 f2 && List.equal eq_ml_ast t1 t2 | MLlam (na1, t1), MLlam (na2, t2) -> eq_ml_ident na1 na2 && eq_ml_ast t1 t2 | MLletin (na1, c1, t1), MLletin (na2, c2, t2) -> eq_ml_ident na1 na2 && eq_ml_ast c1 c2 && eq_ml_ast t1 t2 | MLglob gr1, MLglob gr2 -> eq_gr gr1 gr2 | MLcons (t1, gr1, c1), MLcons (t2, gr2, c2) -> eq_ml_type t1 t2 && eq_gr gr1 gr2 && List.equal eq_ml_ast c1 c2 | MLtuple t1, MLtuple t2 -> List.equal eq_ml_ast t1 t2 | MLcase (t1, c1, p1), MLcase (t2, c2, p2) -> eq_ml_type t1 t2 && eq_ml_ast c1 c2 && Array.equal eq_ml_branch p1 p2 | MLfix (i1, id1, t1), MLfix (i2, id2, t2) -> Int.equal i1 i2 && Array.equal Id.equal id1 id2 && Array.equal eq_ml_ast t1 t2 | MLexn e1, MLexn e2 -> String.equal e1 e2 | MLdummy k1, MLdummy k2 -> k1 == k2 | MLaxiom, MLaxiom -> true | MLmagic t1, MLmagic t2 -> eq_ml_ast t1 t2 | _ -> false and eq_ml_pattern p1 p2 = match p1, p2 with | Pcons (gr1, p1), Pcons (gr2, p2) -> eq_gr gr1 gr2 && List.equal eq_ml_pattern p1 p2 | Ptuple p1, Ptuple p2 -> List.equal eq_ml_pattern p1 p2 | Prel i1, Prel i2 -> Int.equal i1 i2 | Pwild, Pwild -> true | Pusual gr1, Pusual gr2 -> eq_gr gr1 gr2 | _ -> false and eq_ml_branch (id1, p1, t1) (id2, p2, t2) = List.equal eq_ml_ident id1 id2 && eq_ml_pattern p1 p2 && eq_ml_ast t1 t2 (*s [ast_iter_rel f t] applies [f] on every [MLrel] in t. It takes care of the number of bingings crossed before reaching the [MLrel]. *) let ast_iter_rel f = let rec iter n = function | MLrel i -> f (i-n) | MLlam (_,a) -> iter (n+1) a | MLletin (_,a,b) -> iter n a; iter (n+1) b | MLcase (_,a,v) -> iter n a; Array.iter (fun (l,_,t) -> iter (n + (List.length l)) t) v | MLfix (_,ids,v) -> let k = Array.length ids in Array.iter (iter (n+k)) v | MLapp (a,l) -> iter n a; List.iter (iter n) l | MLcons (_,_,l) | MLtuple l -> List.iter (iter n) l | MLmagic a -> iter n a | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> () in iter 0 (*s Map over asts. *) let ast_map_branch f (c,ids,a) = (c,ids,f a) (* Warning: in [ast_map] we assume that [f] does not change the type of [MLcons] and of [MLcase] heads *) let ast_map f = function | MLlam (i,a) -> MLlam (i, f a) | MLletin (i,a,b) -> MLletin (i, f a, f b) | MLcase (typ,a,v) -> MLcase (typ,f a, Array.map (ast_map_branch f) v) | MLfix (i,ids,v) -> MLfix (i, ids, Array.map f v) | MLapp (a,l) -> MLapp (f a, List.map f l) | MLcons (typ,c,l) -> MLcons (typ,c, List.map f l) | MLtuple l -> MLtuple (List.map f l) | MLmagic a -> MLmagic (f a) | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom as a -> a (*s Map over asts, with binding depth as parameter. *) let ast_map_lift_branch f n (ids,p,a) = (ids,p, f (n+(List.length ids)) a) (* Same warning as for [ast_map]... *) let ast_map_lift f n = function | MLlam (i,a) -> MLlam (i, f (n+1) a) | MLletin (i,a,b) -> MLletin (i, f n a, f (n+1) b) | MLcase (typ,a,v) -> MLcase (typ,f n a,Array.map (ast_map_lift_branch f n) v) | MLfix (i,ids,v) -> let k = Array.length ids in MLfix (i,ids,Array.map (f (k+n)) v) | MLapp (a,l) -> MLapp (f n a, List.map (f n) l) | MLcons (typ,c,l) -> MLcons (typ,c, List.map (f n) l) | MLtuple l -> MLtuple (List.map (f n) l) | MLmagic a -> MLmagic (f n a) | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom as a -> a (*s Iter over asts. *) let ast_iter_branch f (c,ids,a) = f a let ast_iter f = function | MLlam (i,a) -> f a | MLletin (i,a,b) -> f a; f b | MLcase (_,a,v) -> f a; Array.iter (ast_iter_branch f) v | MLfix (i,ids,v) -> Array.iter f v | MLapp (a,l) -> f a; List.iter f l | MLcons (_,_,l) | MLtuple l -> List.iter f l | MLmagic a -> f a | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> () (*S Operations concerning De Bruijn indices. *) (*s [ast_occurs k t] returns [true] if [(Rel k)] occurs in [t]. *) let ast_occurs k t = try ast_iter_rel (fun i -> if Int.equal i k then raise Found) t; false with Found -> true (*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)] in [t] with [k<=i<=k'] *) let ast_occurs_itvl k k' t = try ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false with Found -> true (* Number of occurrences of [Rel 1] in [t], with special treatment of match: occurrences in different branches aren't added, but we rather use max. *) let nb_occur_match = let rec nb k = function | MLrel i -> if Int.equal i k then 1 else 0 | MLcase(_,a,v) -> (nb k a) + Array.fold_left (fun r (ids,_,a) -> max r (nb (k+(List.length ids)) a)) 0 v | MLletin (_,a,b) -> (nb k a) + (nb (k+1) b) | MLfix (_,ids,v) -> let k = k+(Array.length ids) in Array.fold_left (fun r a -> r+(nb k a)) 0 v | MLlam (_,a) -> nb (k+1) a | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l | MLcons (_,_,l) | MLtuple l -> List.fold_left (fun r a -> r+(nb k a)) 0 l | MLmagic a -> nb k a | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> 0 in nb 1 (* Replace unused variables by _ *) let dump_unused_vars a = let rec ren env a = match a with | MLrel i -> let () = (List.nth env (i-1)) := true in a | MLlam (id,b) -> let occ_id = ref false in let b' = ren (occ_id::env) b in if !occ_id then if b' == b then a else MLlam(id,b') else MLlam(Dummy,b') | MLletin (id,b,c) -> let occ_id = ref false in let b' = ren env b in let c' = ren (occ_id::env) c in if !occ_id then if b' == b && c' == c then a else MLletin(id,b',c') else (* 'let' without occurrence: shouldn't happen after simpl *) MLletin(Dummy,b',c') | MLcase (t,e,br) -> let e' = ren env e in let br' = Array.smartmap (ren_branch env) br in if e' == e && br' == br then a else MLcase (t,e',br') | MLfix (i,ids,v) -> let env' = List.init (Array.length ids) (fun _ -> ref false) @ env in let v' = Array.smartmap (ren env') v in if v' == v then a else MLfix (i,ids,v') | MLapp (b,l) -> let b' = ren env b and l' = List.smartmap (ren env) l in if b' == b && l' == l then a else MLapp (b',l') | MLcons(t,r,l) -> let l' = List.smartmap (ren env) l in if l' == l then a else MLcons (t,r,l') | MLtuple l -> let l' = List.smartmap (ren env) l in if l' == l then a else MLtuple l' | MLmagic b -> let b' = ren env b in if b' == b then a else MLmagic b' | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> a and ren_branch env ((ids,p,b) as tr) = let occs = List.map (fun _ -> ref false) ids in let b' = ren (List.rev_append occs env) b in let ids' = List.map2 (fun id occ -> if !occ then id else Dummy) ids occs in if b' == b && List.equal eq_ml_ident ids ids' then tr else (ids',p,b') in ren [] a (*s Lifting on terms. [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *) let ast_lift k t = let rec liftrec n = function | MLrel i as a -> if i-n < 1 then a else MLrel (i+k) | a -> ast_map_lift liftrec n a in if Int.equal k 0 then t else liftrec 0 t let ast_pop t = ast_lift (-1) t (*s [permut_rels k k' c] translates [Rel 1 ... Rel k] to [Rel (k'+1) ... Rel (k'+k)] and [Rel (k+1) ... Rel (k+k')] to [Rel 1 ... Rel k'] *) let permut_rels k k' = let rec permut n = function | MLrel i as a -> let i' = i-n in if i'<1 || i'>k+k' then a else if i'<=k then MLrel (i+k') else MLrel (i-k) | a -> ast_map_lift permut n a in permut 0 (*s Substitution. [ml_subst e t] substitutes [e] for [Rel 1] in [t]. Lifting (of one binder) is done at the same time. *) let ast_subst e = let rec subst n = function | MLrel i as a -> let i' = i-n in if Int.equal i' 1 then ast_lift n e else if i'<1 then a else MLrel (i-1) | a -> ast_map_lift subst n a in subst 0 (*s Generalized substitution. [gen_subst v d t] applies to [t] the substitution coded in the [v] array: [(Rel i)] becomes [v.(i-1)]. [d] is the correction applies to [Rel] greater than [Array.length v]. *) let gen_subst v d t = let rec subst n = function | MLrel i as a -> let i'= i-n in if i' < 1 then a else if i' <= Array.length v then match v.(i'-1) with | None -> assert false | Some u -> ast_lift n u else MLrel (i+d) | a -> ast_map_lift subst n a in subst 0 t (*S Operations concerning match patterns *) let is_basic_pattern = function | Prel _ | Pwild -> true | Pusual _ | Pcons _ | Ptuple _ -> false let has_deep_pattern br = let deep = function | Pcons (_,l) | Ptuple l -> not (List.for_all is_basic_pattern l) | Pusual _ | Prel _ | Pwild -> false in Array.exists (function (_,pat,_) -> deep pat) br let is_regular_match br = if Array.is_empty br then false (* empty match becomes MLexn *) else try let get_r (ids,pat,c) = match pat with | Pusual r -> r | Pcons (r,l) -> let is_rel i = function Prel j -> Int.equal i j | _ -> false in if not (List.for_all_i is_rel 1 (List.rev l)) then raise Impossible; r | _ -> raise Impossible in let ind = match get_r br.(0) with | ConstructRef (ind,_) -> ind | _ -> raise Impossible in let is_ref i tr = match get_r tr with | ConstructRef (ind', j) -> eq_ind ind ind' && Int.equal j (i + 1) | _ -> false in Array.for_all_i is_ref 0 br with Impossible -> false (*S Operations concerning lambdas. *) (*s [collect_lams MLlam(id1,...MLlam(idn,t)...)] returns [[idn;...;id1]] and the term [t]. *) let collect_lams = let rec collect acc = function | MLlam(id,t) -> collect (id::acc) t | x -> acc,x in collect [] (*s [collect_n_lams] does the same for a precise number of [MLlam]. *) let collect_n_lams = let rec collect acc n t = if Int.equal n 0 then acc,t else match t with | MLlam(id,t) -> collect (id::acc) (n-1) t | _ -> assert false in collect [] (*s [remove_n_lams] just removes some [MLlam]. *) let rec remove_n_lams n t = if Int.equal n 0 then t else match t with | MLlam(_,t) -> remove_n_lams (n-1) t | _ -> assert false (*s [nb_lams] gives the number of head [MLlam]. *) let rec nb_lams = function | MLlam(_,t) -> succ (nb_lams t) | _ -> 0 (*s [named_lams] does the converse of [collect_lams]. *) let rec named_lams ids a = match ids with | [] -> a | id :: ids -> named_lams ids (MLlam (id,a)) (*s The same for a specific identifier (resp. anonymous, dummy) *) let rec many_lams id a = function | 0 -> a | n -> many_lams id (MLlam (id,a)) (pred n) let anonym_tmp_lams a n = many_lams (Tmp anonymous_name) a n let dummy_lams a n = many_lams Dummy a n (*s mixed according to a signature. *) let rec anonym_or_dummy_lams a = function | [] -> a | Keep :: s -> MLlam(anonymous, anonym_or_dummy_lams a s) | Kill _ :: s -> MLlam(Dummy, anonym_or_dummy_lams a s) (*S Operations concerning eta. *) (*s The following function creates [MLrel n;...;MLrel 1] *) let rec eta_args n = if Int.equal n 0 then [] else (MLrel n)::(eta_args (pred n)) (*s Same, but filtered by a signature. *) let rec eta_args_sign n = function | [] -> [] | Keep :: s -> (MLrel n) :: (eta_args_sign (n-1) s) | Kill _ :: s -> eta_args_sign (n-1) s (*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *) let rec test_eta_args_lift k n = function | [] -> Int.equal n 0 | MLrel m :: q -> Int.equal (k+n) m && (test_eta_args_lift k (pred n) q) | _ -> false (*s Computes an eta-reduction. *) let eta_red e = let ids,t = collect_lams e in let n = List.length ids in if Int.equal n 0 then e else match t with | MLapp (f,a) -> let m = List.length a in let ids,body,args = if Int.equal m n then [], f, a else if m < n then List.skipn m ids, f, a else (* m > n *) let a1,a2 = List.chop (m-n) a in [], MLapp (f,a1), a2 in let p = List.length args in if test_eta_args_lift 0 p args && not (ast_occurs_itvl 1 p body) then named_lams ids (ast_lift (-p) body) else e | _ -> e (*s Computes all head linear beta-reductions possible in [(t a)]. Non-linear head beta-redex become let-in. *) let rec linear_beta_red a t = match a,t with | [], _ -> t | a0::a, MLlam (id,t) -> (match nb_occur_match t with | 0 -> linear_beta_red a (ast_pop t) | 1 -> linear_beta_red a (ast_subst a0 t) | _ -> let a = List.map (ast_lift 1) a in MLletin (id, a0, linear_beta_red a t)) | _ -> MLapp (t, a) let rec tmp_head_lams = function | MLlam (id, t) -> MLlam (tmp_id id, tmp_head_lams t) | e -> e (*s Applies a substitution [s] of constants by their body, plus linear beta reductions at modified positions. Moreover, we mark some lambdas as suitable for later linear reduction (this helps the inlining of recursors). *) let rec ast_glob_subst s t = match t with | MLapp ((MLglob ((ConstRef kn) as refe)) as f, a) -> let a = List.map (fun e -> tmp_head_lams (ast_glob_subst s e)) a in (try linear_beta_red a (Refmap'.find refe s) with Not_found -> MLapp (f, a)) | MLglob ((ConstRef kn) as refe) -> (try Refmap'.find refe s with Not_found -> t) | _ -> ast_map (ast_glob_subst s) t (*S Auxiliary functions used in simplification of ML cases. *) (* Factorisation of some match branches into a common "x -> f x" branch may break types sometimes. Example: [type 'x a = A]. Then [let id = function A -> A] has type ['x a -> 'y a], which is incompatible with the type of [let id x = x]. We now check that the type arguments of the inductive are preserved by our transformation. TODO: this verification should be done someday modulo expansion of type definitions. *) (*s [branch_as_function b typ (l,p,c)] tries to see branch [c] as a function [f] applied to [MLcons(r,l)]. For that it transforms any [MLcons(r,l)] in [MLrel 1] and raises [Impossible] if any variable in [l] occurs outside such a [MLcons] *) let branch_as_fun typ (l,p,c) = let nargs = List.length l in let cons = match p with | Pusual r -> MLcons (typ, r, eta_args nargs) | Pcons (r,pl) -> let pat2rel = function Prel i -> MLrel i | _ -> raise Impossible in MLcons (typ, r, List.map pat2rel pl) | _ -> raise Impossible in let rec genrec n = function | MLrel i as c -> let i' = i-n in if i'<1 then c else if i'>nargs then MLrel (i-nargs+1) else raise Impossible | MLcons _ as cons' when eq_ml_ast cons' (ast_lift n cons) -> MLrel (n+1) | a -> ast_map_lift genrec n a in genrec 0 c (*s [branch_as_cst (l,p,c)] tries to see branch [c] as a constant independent from the pattern [MLcons(r,l)]. For that is raises [Impossible] if any variable in [l] occurs in [c], and otherwise returns [c] lifted to appear like a function with one arg (for uniformity with [branch_as_fun]). NB: [MLcons(r,l)] might occur nonetheless in [c], but only when [l] is empty, i.e. when [r] is a constant constructor *) let branch_as_cst (l,_,c) = let n = List.length l in if ast_occurs_itvl 1 n c then raise Impossible; ast_lift (1-n) c (* A branch [MLcons(r,l)->c] can be seen at the same time as a function branch and a constant branch, either because: - [MLcons(r,l)] doesn't occur in [c]. For example : "A -> B" - this constructor is constant (i.e. [l] is empty). For example "A -> A" When searching for the best factorisation below, we'll try both. *) (* The following structure allows recording which element occurred at what position, and then finally return the most frequent element and its positions. *) let census_add, census_max, census_clean = let h = ref [] in let clearf () = h := [] in let rec add k v = function | [] -> raise Not_found | (k', s) as p :: l -> if eq_ml_ast k k' then (k', Int.Set.add v s) :: l else p :: add k v l in let addf k i = try h := add k i !h with Not_found -> h := (k, Int.Set.singleton i) :: !h in let maxf () = let len = ref 0 and lst = ref Int.Set.empty and elm = ref MLaxiom in List.iter (fun (e, s) -> let n = Int.Set.cardinal s in if n > !len then begin len := n; lst := s; elm := e end) !h; (!elm,!lst) in (addf,maxf,clearf) (* [factor_branches] return the longest possible list of branches that have the same factorization, either as a function or as a constant. *) let is_opt_pat (_,p,_) = match p with | Prel _ | Pwild -> true | _ -> false let factor_branches o typ br = if Array.exists is_opt_pat br then None (* already optimized *) else begin census_clean (); for i = 0 to Array.length br - 1 do if o.opt_case_idr then (try census_add (branch_as_fun typ br.(i)) i with Impossible -> ()); if o.opt_case_cst then (try census_add (branch_as_cst br.(i)) i with Impossible -> ()); done; let br_factor, br_set = census_max () in census_clean (); let n = Int.Set.cardinal br_set in if Int.equal n 0 then None else if Array.length br >= 2 && n < 2 then None else Some (br_factor, br_set) end (*s If all branches are functions, try to permute the case and the functions. *) let rec merge_ids ids ids' = match ids,ids' with | [],l -> l | l,[] -> l | i::ids, i'::ids' -> (if i == Dummy then i' else i) :: (merge_ids ids ids') let is_exn = function MLexn _ -> true | _ -> false let permut_case_fun br acc = let nb = ref max_int in Array.iter (fun (_,_,t) -> let ids, c = collect_lams t in let n = List.length ids in if (n < !nb) && (not (is_exn c)) then nb := n) br; if Int.equal !nb max_int || Int.equal !nb 0 then ([],br) else begin let br = Array.copy br in let ids = ref [] in for i = 0 to Array.length br - 1 do let (l,p,t) = br.(i) in let local_nb = nb_lams t in if local_nb < !nb then (* t = MLexn ... *) br.(i) <- (l,p,remove_n_lams local_nb t) else begin let local_ids,t = collect_n_lams !nb t in ids := merge_ids !ids local_ids; br.(i) <- (l,p,permut_rels !nb (List.length l) t) end done; (!ids,br) end (*S Generalized iota-reduction. *) (* Definition of a generalized iota-redex: it's a [MLcase(e,br)] where the head [e] is a [MLcons] or made of [MLcase]'s with [MLcons] as leaf branches. A generalized iota-redex is transformed into beta-redexes. *) (* In [iota_red], we try to simplify a [MLcase(_,MLcons(typ,r,a),br)]. Argument [i] is the branch we consider, we should lift what comes from [br] by [lift] *) let rec iota_red i lift br ((typ,r,a) as cons) = if i >= Array.length br then raise Impossible; let (ids,p,c) = br.(i) in match p with | Pusual r' | Pcons (r',_) when not (Globnames.eq_gr r' r) -> iota_red (i+1) lift br cons | Pusual r' -> let c = named_lams (List.rev ids) c in let c = ast_lift lift c in MLapp (c,a) | Prel 1 when Int.equal (List.length ids) 1 -> let c = MLlam (List.hd ids, c) in let c = ast_lift lift c in MLapp(c,[MLcons(typ,r,a)]) | Pwild when List.is_empty ids -> ast_lift lift c | _ -> raise Impossible (* TODO: handle some more cases *) (* [iota_gen] is an extension of [iota_red] where we allow to traverse matches in the head of the first match *) let iota_gen br hd = let rec iota k = function | MLcons (typ,r,a) -> iota_red 0 k br (typ,r,a) | MLcase(typ,e,br') -> let new_br = Array.map (fun (i,p,c)->(i,p,iota (k+(List.length i)) c)) br' in MLcase(typ,e,new_br) | _ -> raise Impossible in iota 0 hd let is_atomic = function | MLrel _ | MLglob _ | MLexn _ | MLdummy _ -> true | _ -> false let is_imm_apply = function MLapp (MLrel 1, _) -> true | _ -> false (** Program creates a let-in named "program_branch_NN" for each branch of match. Unfolding them leads to more natural code (and more dummy removal) *) let is_program_branch = function | Tmp _ | Dummy -> false | Id id -> let s = Id.to_string id in try Scanf.sscanf s "program_branch_%d%!" (fun _ -> true) with Scanf.Scan_failure _ | End_of_file -> false let expand_linear_let o id e = o.opt_lin_let || is_tmp id || is_program_branch id || is_imm_apply e (*S The main simplification function. *) (* Some beta-iota reductions + simplifications. *) let rec unmagic = function MLmagic e -> unmagic e | e -> e let is_magic = function MLmagic _ -> true | _ -> false let magic_hd a = match a with | MLmagic _ :: _ -> a | e :: a -> MLmagic e :: a | [] -> assert false let rec simpl o = function | MLapp (f, []) -> simpl o f | MLapp (MLapp(f,a),a') -> simpl o (MLapp(f,a@a')) | MLapp (f, a) -> (* When the head of the application is magic, no need for magic on args *) let a = if is_magic f then List.map unmagic a else a in simpl_app o (List.map (simpl o) a) (simpl o f) | MLcase (typ,e,br) -> let br = Array.map (fun (l,p,t) -> (l,p,simpl o t)) br in simpl_case o typ br (simpl o e) | MLletin(Dummy,_,e) -> simpl o (ast_pop e) | MLletin(id,c,e) -> let e = simpl o e in if (is_atomic c) || (is_atomic e) || (let n = nb_occur_match e in (Int.equal n 0 || (Int.equal n 1 && expand_linear_let o id e))) then simpl o (ast_subst c e) else MLletin(id, simpl o c, e) | MLfix(i,ids,c) -> let n = Array.length ids in if ast_occurs_itvl 1 n c.(i) then MLfix (i, ids, Array.map (simpl o) c) else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *) | MLmagic(MLmagic _ as e) -> simpl o e | MLmagic(MLapp (f,l)) -> simpl o (MLapp (MLmagic f, l)) | MLmagic(MLletin(id,c,e)) -> simpl o (MLletin(id,c,MLmagic e)) | MLmagic(MLcase(typ,e,br)) -> let br' = Array.map (fun (ids,p,c) -> (ids,p,MLmagic c)) br in simpl o (MLcase(typ,e,br')) | MLmagic(MLexn _ as e) -> e | a -> ast_map (simpl o) a (* invariant : list [a] of arguments is non-empty *) and simpl_app o a = function | MLlam (Dummy,t) -> simpl o (MLapp (ast_pop t, List.tl a)) | MLlam (id,t) -> (* Beta redex *) (match nb_occur_match t with | 0 -> simpl o (MLapp (ast_pop t, List.tl a)) | 1 when (is_tmp id || o.opt_lin_beta) -> simpl o (MLapp (ast_subst (List.hd a) t, List.tl a)) | _ -> let a' = List.map (ast_lift 1) (List.tl a) in simpl o (MLletin (id, List.hd a, MLapp (t, a')))) | MLmagic (MLlam (id,t)) -> (* When we've at least one argument, we permute the magic and the lambda, to simplify things a bit (see #2795). Alas, the 1st argument must also be magic then. *) simpl_app o (magic_hd a) (MLlam (id,MLmagic t)) | MLletin (id,e1,e2) when o.opt_let_app -> (* Application of a letin: we push arguments inside *) MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) | MLcase (typ,e,br) when o.opt_case_app -> (* Application of a case: we push arguments inside *) let br' = Array.map (fun (l,p,t) -> let k = List.length l in let a' = List.map (ast_lift k) a in (l, p, simpl o (MLapp (t,a')))) br in simpl o (MLcase (typ,e,br')) | (MLdummy _ | MLexn _) as e -> e (* We just discard arguments in those cases. *) | f -> MLapp (f,a) (* Invariant : all empty matches should now be [MLexn] *) and simpl_case o typ br e = try (* Generalized iota-redex *) if not o.opt_case_iot then raise Impossible; simpl o (iota_gen br e) with Impossible -> (* Swap the case and the lam if possible *) let ids,br = if o.opt_case_fun then permut_case_fun br [] else [],br in let n = List.length ids in if not (Int.equal n 0) then simpl o (named_lams ids (MLcase (typ, ast_lift n e, br))) else (* Can we merge several branches as the same constant or function ? *) if lang() == Scheme || is_custom_match br then MLcase (typ, e, br) else match factor_branches o typ br with | Some (f,ints) when Int.equal (Int.Set.cardinal ints) (Array.length br) -> (* If all branches have been factorized, we remove the match *) simpl o (MLletin (Tmp anonymous_name, e, f)) | Some (f,ints) -> let last_br = if ast_occurs 1 f then ([Tmp anonymous_name], Prel 1, f) else ([], Pwild, ast_pop f) in let brl = Array.to_list br in let brl_opt = List.filteri (fun i _ -> not (Int.Set.mem i ints)) brl in let brl_opt = brl_opt @ [last_br] in MLcase (typ, e, Array.of_list brl_opt) | None -> MLcase (typ, e, br) (*S Local prop elimination. *) (* We try to eliminate as many [prop] as possible inside an [ml_ast]. *) (*s In a list, it selects only the elements corresponding to a [Keep] in the boolean list [l]. *) let rec select_via_bl l args = match l,args with | [],_ -> args | Keep::l,a::args -> a :: (select_via_bl l args) | Kill _::l,a::args -> select_via_bl l args | _ -> assert false (*s [kill_some_lams] removes some head lambdas according to the signature [bl]. This list is build on the identifier list model: outermost lambda is on the right. [Rels] corresponding to removed lambdas are not supposed to occur (except maybe in the case of Kimplicit), and the other [Rels] are made correct via a [gen_subst]. Output is not directly a [ml_ast], compose with [named_lams] if needed. *) let is_impl_kill = function Kill (Kimplicit _) -> true | _ -> false let kill_some_lams bl (ids,c) = let n = List.length bl in let n' = List.fold_left (fun n b -> if b == Keep then (n+1) else n) 0 bl in if Int.equal n n' then ids,c else if Int.equal n' 0 && not (List.exists is_impl_kill bl) then [],ast_lift (-n) c else begin let v = Array.make n None in let rec parse_ids i j = function | [] -> () | Keep :: l -> v.(i) <- Some (MLrel j); parse_ids (i+1) (j+1) l | Kill (Kimplicit _ as k) :: l -> v.(i) <- Some (MLdummy k); parse_ids (i+1) j l | Kill _ :: l -> parse_ids (i+1) j l in parse_ids 0 1 bl; select_via_bl bl ids, gen_subst v (n'-n) c end (*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or if there is no lambda left at all. In addition, it now accepts a signature that may mention some implicits. *) let rec merge_implicits ids s = match ids, s with | [],_ -> [] | _,[] -> List.map sign_of_id ids | Dummy::ids, _::s -> Kill Kprop :: merge_implicits ids s | _::ids, (Kill (Kimplicit _) as k)::s -> k :: merge_implicits ids s | _::ids, _::s -> Keep :: merge_implicits ids s let kill_dummy_lams sign c = let ids,c = collect_lams c in let bl = merge_implicits ids (List.rev sign) in if not (List.memq Keep bl) then raise Impossible; let rec fst_kill n = function | [] -> raise Impossible | Kill _ :: bl -> n | Keep :: bl -> fst_kill (n+1) bl in let skip = max 0 ((fst_kill 0 bl) - 1) in let ids_skip, ids = List.chop skip ids in let _, bl = List.chop skip bl in let c = named_lams ids_skip c in let ids',c = kill_some_lams bl (ids,c) in (ids,bl), named_lams ids' c (*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] and a signature [s] and builds a eta-long version. *) (* For example, if [s = [Keep;Keep;Kill Prop;Keep]] then the output is : [fun idn ... id1 x x _ x -> (c' 4 3 __ 1)] with [c' = lift 4 c] *) let eta_expansion_sign s (ids,c) = let rec abs ids rels i = function | [] -> let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels in ids, MLapp (ast_lift (i-1) c, a) | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l | Kill k :: l -> abs (Dummy :: ids) (MLdummy k :: rels) (i+1) l in abs ids [] 1 s (*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas corresponding to [Kill _] in [s]. *) let case_expunge s e = let m = List.length s in let n = nb_lams e in let p = if m <= n then collect_n_lams m e else eta_expansion_sign (List.skipn n s) (collect_lams e) in kill_some_lams (List.rev s) p (*s [term_expunge] takes a function [fun idn ... id1 -> c] and a signature [s] and remove dummy lams. The difference with [case_expunge] is that we here leave one dummy lambda if all lambdas are logical dummy and the target language is strict. *) let term_expunge s (ids,c) = if List.is_empty s then c else let ids,c = kill_some_lams (List.rev s) (ids,c) in if List.is_empty ids && lang () != Haskell && sign_kind s == UnsafeLogicalSig then MLlam (Dummy, ast_lift 1 c) else named_lams ids c (*s [kill_dummy_args (ids,bl) r t] looks for occurrences of [MLrel r] in [t] and purge the args of [MLrel r] corresponding to a [Kill] in [bl]. It makes eta-expansion if needed. *) let kill_dummy_args (ids,bl) r t = let m = List.length ids in let sign = List.rev bl in let rec found n = function | MLrel r' when Int.equal r' (r + n) -> true | MLmagic e -> found n e | _ -> false in let rec killrec n = function | MLapp(e, a) when found n e -> let k = max 0 (m - (List.length a)) in let a = List.map (killrec n) a in let a = List.map (ast_lift k) a in let a = select_via_bl sign (a @ (eta_args k)) in named_lams (List.firstn k ids) (MLapp (ast_lift k e, a)) | e when found n e -> let a = select_via_bl sign (eta_args m) in named_lams ids (MLapp (ast_lift m e, a)) | e -> ast_map_lift killrec n e in killrec 0 t (*s The main function for local [dummy] elimination. *) let sign_of_args a = List.map (function MLdummy k -> Kill k | _ -> Keep) a let rec kill_dummy = function | MLfix(i,fi,c) -> (try let k,c = kill_dummy_fix i c [] in ast_subst (MLfix (i,fi,c)) (kill_dummy_args k 1 (MLrel 1)) with Impossible -> MLfix (i,fi,Array.map kill_dummy c)) | MLapp (MLfix (i,fi,c),a) -> let a = List.map kill_dummy a in (* Heuristics: if some arguments are implicit args, we try to eliminate the corresponding arguments of the fixpoint *) (try let k,c = kill_dummy_fix i c (sign_of_args a) in let fake = MLapp (MLrel 1, List.map (ast_lift 1) a) in let fake' = kill_dummy_args k 1 fake in ast_subst (MLfix (i,fi,c)) fake' with Impossible -> MLapp(MLfix(i,fi,Array.map kill_dummy c),a)) | MLletin(id, MLfix (i,fi,c),e) -> (try let k,c = kill_dummy_fix i c [] in let e = kill_dummy (kill_dummy_args k 1 e) in MLletin(id, MLfix(i,fi,c),e) with Impossible -> MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e)) | MLletin(id,c,e) -> (try let k,c = kill_dummy_lams [] (kill_dummy_hd c) in let e = kill_dummy (kill_dummy_args k 1 e) in let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy e)) | a -> ast_map kill_dummy a (* Similar function, but acting only on head lambdas and let-ins *) and kill_dummy_hd = function | MLlam(id,e) -> MLlam(id, kill_dummy_hd e) | MLletin(id,c,e) -> (try let k,c = kill_dummy_lams [] (kill_dummy_hd c) in let e = kill_dummy_hd (kill_dummy_args k 1 e) in let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy_hd e)) | a -> a and kill_dummy_fix i c s = let n = Array.length c in let k,ci = kill_dummy_lams s (kill_dummy_hd c.(i)) in let c = Array.copy c in c.(i) <- ci; for j = 0 to (n-1) do c.(j) <- kill_dummy (kill_dummy_args k (n-i) c.(j)) done; k,c (*s Putting things together. *) let normalize a = let o = optims () in let rec norm a = let a' = if o.opt_kill_dum then kill_dummy (simpl o a) else simpl o a in if eq_ml_ast a a' then a else norm a' in norm a (*S Special treatment of fixpoint for pretty-printing purpose. *) let general_optimize_fix f ids n args m c = let v = Array.make n 0 in for i=0 to (n-1) do v.(i)<-i done; let aux i = function | MLrel j when v.(j-1)>=0 -> if ast_occurs (j+1) c then raise Impossible else v.(j-1)<-(-i-1) | _ -> raise Impossible in List.iteri aux args; let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in let new_f = anonym_tmp_lams (MLapp (MLrel (n+m+1),args_f)) m in let new_c = named_lams ids (normalize (MLapp ((ast_subst new_f c),args))) in MLfix(0,[|f|],[|new_c|]) let optimize_fix a = if not (optims()).opt_fix_fun then a else let ids,a' = collect_lams a in let n = List.length ids in if Int.equal n 0 then a else match a' with | MLfix(_,[|f|],[|c|]) -> let new_f = MLapp (MLrel (n+1),eta_args n) in let new_c = named_lams ids (normalize (ast_subst new_f c)) in MLfix(0,[|f|],[|new_c|]) | MLapp(a',args) -> let m = List.length args in (match a' with | MLfix(_,_,_) when (test_eta_args_lift 0 n args) && not (ast_occurs_itvl 1 m a') -> a' | MLfix(_,[|f|],[|c|]) -> (try general_optimize_fix f ids n args m c with Impossible -> a) | _ -> a) | _ -> a (*S Inlining. *) (* Utility functions used in the decision of inlining. *) let ml_size_branch size pv = Array.fold_left (fun a (_,_,t) -> a + size t) 0 pv let rec ml_size = function | MLapp(t,l) -> List.length l + ml_size t + ml_size_list l | MLlam(_,t) -> 1 + ml_size t | MLcons(_,_,l) | MLtuple l -> ml_size_list l | MLcase(_,t,pv) -> 1 + ml_size t + ml_size_branch ml_size pv | MLfix(_,_,f) -> ml_size_array f | MLletin (_,_,t) -> ml_size t | MLmagic t -> ml_size t | MLglob _ | MLrel _ | MLexn _ | MLdummy _ | MLaxiom -> 0 and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l and ml_size_array a = Array.fold_left (fun a t -> a + ml_size t) 0 a let is_fix = function MLfix _ -> true | _ -> false (*s Strictness *) (* A variable is strict if the evaluation of the whole term implies the evaluation of this variable. Non-strict variables can be found behind Match, for example. Expanding a term [t] is a good idea when it begins by at least one non-strict lambda, since the corresponding argument to [t] might be unevaluated in the expanded code. *) exception Toplevel let lift n l = List.map ((+) n) l let pop n l = List.map (fun x -> if x<=n then raise Toplevel else x-n) l (* This function returns a list of de Bruijn indices of non-strict variables, or raises [Toplevel] if it has an internal non-strict variable. In fact, not all variables are checked for strictness, only the ones which de Bruijn index is in the candidates list [cand]. The flag [add] controls the behaviour when going through a lambda: should we add the corresponding variable to the candidates? We use this flag to check only the external lambdas, those that will correspond to arguments. *) let rec non_stricts add cand = function | MLlam (id,t) -> let cand = lift 1 cand in let cand = if add then 1::cand else cand in pop 1 (non_stricts add cand t) | MLrel n -> List.filter (fun m -> not (Int.equal m n)) cand | MLapp (t,l)-> let cand = non_stricts false cand t in List.fold_left (non_stricts false) cand l | MLcons (_,_,l) -> List.fold_left (non_stricts false) cand l | MLletin (_,t1,t2) -> let cand = non_stricts false cand t1 in pop 1 (non_stricts add (lift 1 cand) t2) | MLfix (_,i,f)-> let n = Array.length i in let cand = lift n cand in let cand = Array.fold_left (non_stricts false) cand f in pop n cand | MLcase (_,t,v) -> (* The only interesting case: for a variable to be non-strict, *) (* it is sufficient that it appears non-strict in at least one branch, *) (* so we make an union (in fact a merge). *) let cand = non_stricts false cand t in Array.fold_left (fun c (i,_,t)-> let n = List.length i in let cand = lift n cand in let cand = pop n (non_stricts add cand t) in List.merge Int.compare cand c) [] v (* [merge] may duplicates some indices, but I don't mind. *) | MLmagic t -> non_stricts add cand t | _ -> cand (* The real test: we are looking for internal non-strict variables, so we start with no candidates, and the only positive answer is via the [Toplevel] exception. *) let is_not_strict t = try let _ = non_stricts true [] t in false with Toplevel -> true (*s Inlining decision *) (* [inline_test] answers the following question: If we could inline [t] (the user said nothing special), should we inline ? We expand small terms with at least one non-strict variable (i.e. a variable that may not be evaluated). Furthermore we don't expand fixpoints. Moreover, as mentioned by X. Leroy (bug #2241), inlining a constant from inside an opaque module might break types. To avoid that, we require below that both [r] and its body are globally visible. This isn't fully satisfactory, since [r] might not be visible (functor), and anyway it might be interesting to inline [r] at least inside its own structure. But to be safe, we adopt this restriction for the moment. *) open Declareops let inline_test r t = if not (auto_inline ()) then false else let c = match r with ConstRef c -> c | _ -> assert false in let has_body = try constant_has_body (Global.lookup_constant c) with Not_found -> false in has_body && (let t1 = eta_red t in let t2 = snd (collect_lams t1) in not (is_fix t2) && ml_size t < 12 && is_not_strict t) let con_of_string s = let d, id = Libnames.split_dirpath (dirpath_of_string s) in Constant.make2 (MPfile d) (Label.of_id id) let manual_inline_set = List.fold_right (fun x -> Cset_env.add (con_of_string x)) [ "Coq.Init.Wf.well_founded_induction_type"; "Coq.Init.Wf.well_founded_induction"; "Coq.Init.Wf.Acc_iter"; "Coq.Init.Wf.Fix_F"; "Coq.Init.Wf.Fix"; "Coq.Init.Datatypes.andb"; "Coq.Init.Datatypes.orb"; "Coq.Init.Logic.eq_rec_r"; "Coq.Init.Logic.eq_rect_r"; "Coq.Init.Specif.proj1_sig"; ] Cset_env.empty let manual_inline = function | ConstRef c -> Cset_env.mem c manual_inline_set | _ -> false (* If the user doesn't say he wants to keep [t], we inline in two cases: \begin{itemize} \item the user explicitly requests it \item [expansion_test] answers that the inlining is a good idea, and we are free to act (AutoInline is set) \end{itemize} *) let inline r t = not (to_keep r) (* The user DOES want to keep it *) && not (is_inline_custom r) && (to_inline r (* The user DOES want to inline it *) || (lang () != Haskell && not (is_projection r) && (is_recursor r || manual_inline r || inline_test r t))) coq-8.6/plugins/extraction/ExtrOcamlString.v0000644000175000017500000000267213022274260020603 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* char [ "(* If this appears, you're using Ascii internals. Please don't *) (fun (b0,b1,b2,b3,b4,b5,b6,b7) -> let f b i = if b then 1 lsl i else 0 in Char.chr (f b0 0 + f b1 1 + f b2 2 + f b3 3 + f b4 4 + f b5 5 + f b6 6 + f b7 7))" ] "(* If this appears, you're using Ascii internals. Please don't *) (fun f c -> let n = Char.code c in let h i = (n land (1 lsl i)) <> 0 in f (h 0) (h 1) (h 2) (h 3) (h 4) (h 5) (h 6) (h 7))". Extract Constant zero => "'\000'". Extract Constant one => "'\001'". Extract Constant shift => "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)". Extract Inlined Constant ascii_dec => "(=)". Extract Inductive string => "char list" [ "[]" "(::)" ]. (* Definition test := "ceci est un test"%string. Recursive Extraction test Ascii.zero Ascii.one. *) coq-8.6/plugins/extraction/ExtrOcamlNatBigInt.v0000644000175000017500000000514413022274260021151 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "Big.big_int" [ "Big.zero" "Big.succ" ] "Big.nat_case". (** Efficient (but uncertified) versions for usual [nat] functions *) Extract Constant plus => "Big.add". Extract Constant mult => "Big.mult". Extract Constant pred => "fun n -> Big.max Big.zero (Big.pred n)". Extract Constant minus => "fun n m -> Big.max Big.zero (Big.sub n m)". Extract Constant max => "Big.max". Extract Constant min => "Big.min". (*Extract Constant nat_beq => "Big.eq".*) Extract Constant EqNat.beq_nat => "Big.eq". Extract Constant EqNat.eq_nat_decide => "Big.eq". Extract Constant Peano_dec.eq_nat_dec => "Big.eq". Extract Constant Compare_dec.nat_compare => "Big.compare_case Eq Lt Gt". Extract Constant Compare_dec.leb => "Big.le". Extract Constant Compare_dec.le_lt_dec => "Big.le". Extract Constant Compare_dec.lt_eq_lt_dec => "Big.compare_case (Some false) (Some true) None". Extract Constant Even.even_odd_dec => "fun n -> Big.sign (Big.mod n Big.two) = 0". Extract Constant Div2.div2 => "fun n -> Big.div n Big.two". Extract Inductive Euclid.diveucl => "(Big.big_int * Big.big_int)" [""]. Extract Constant Euclid.eucl_dev => "fun n m -> Big.quomod m n". Extract Constant Euclid.quotient => "fun n m -> Big.div m n". Extract Constant Euclid.modulo => "fun n m -> Big.modulo m n". (* Require Import Euclid. Definition test n m (H:m>0) := let (q,r,_,_) := eucl_dev m H n in nat_compare n (q*m+r). Extraction "/tmp/test.ml" test fact pred minus max min Div2.div2. *) coq-8.6/plugins/extraction/ExtrHaskellNatNum.v0000644000175000017500000000341413022274260021062 0ustar mdenesmdenes(** * Efficient (but uncertified) extraction of usual [nat] functions * into equivalent versions in Haskell's Prelude that are defined * for any [Num] typeclass instances. Useful in combination with * [Extract Inductive nat] that maps [nat] onto a Haskell type that * implements [Num]. *) Require Import Arith. Require Import EqNat. Extract Inlined Constant Nat.add => "(Prelude.+)". Extract Inlined Constant Nat.mul => "(Prelude.*)". Extract Inlined Constant Nat.max => "Prelude.max". Extract Inlined Constant Nat.min => "Prelude.min". Extract Inlined Constant Init.Nat.add => "(Prelude.+)". Extract Inlined Constant Init.Nat.mul => "(Prelude.*)". Extract Inlined Constant Init.Nat.max => "Prelude.max". Extract Inlined Constant Init.Nat.min => "Prelude.min". Extract Inlined Constant Compare_dec.lt_dec => "(Prelude.<)". Extract Inlined Constant Compare_dec.leb => "(Prelude.<=)". Extract Inlined Constant Compare_dec.le_lt_dec => "(Prelude.<=)". Extract Inlined Constant EqNat.beq_nat => "(Prelude.==)". Extract Inlined Constant EqNat.eq_nat_decide => "(Prelude.==)". Extract Inlined Constant Peano_dec.eq_nat_dec => "(Prelude.==)". Extract Constant Nat.pred => "(\n -> Prelude.max 0 (Prelude.pred n))". Extract Constant Nat.sub => "(\n m -> Prelude.max 0 (n Prelude.- m))". Extract Constant Init.Nat.pred => "(\n -> Prelude.max 0 (Prelude.pred n))". Extract Constant Init.Nat.sub => "(\n m -> Prelude.max 0 (n Prelude.- m))". Extract Constant Nat.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". Extract Constant Nat.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)". Extract Constant Init.Nat.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". Extract Constant Init.Nat.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)".coq-8.6/plugins/extraction/modutil.mli0000644000175000017500000000322413022274260017501 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool) -> ml_structure -> bool val struct_type_search : (ml_type -> bool) -> ml_structure -> bool type do_ref = global_reference -> unit val ast_iter_references : do_ref -> do_ref -> do_ref -> ml_ast -> unit val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit val signature_of_structure : ml_structure -> ml_signature val mtyp_of_mexpr : ml_module_expr -> ml_module_type val msid_of_mt : ml_module_type -> module_path val get_decl_in_structure : global_reference -> ml_structure -> ml_decl (* Some transformations of ML terms. [optimize_struct] simplify all beta redexes (when the argument does not occur, it is just thrown away; when it occurs exactly once it is substituted; otherwise a let-in redex is created for clarity) and iota redexes, plus some other optimizations. The first argument is the list of objects we want to appear. *) val optimize_struct : global_reference list * module_path list -> ml_structure -> ml_structure coq-8.6/plugins/extraction/scheme.ml0000644000175000017500000001617613022274260017131 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Id.Set.add (Id.of_string s)) [ "define"; "let"; "lambda"; "lambdas"; "match"; "apply"; "car"; "cdr"; "error"; "delay"; "force"; "_"; "__"] Id.Set.empty let pp_comment s = str";; "++h 0 s++fnl () let pp_header_comment = function | None -> mt () | Some com -> pp_comment com ++ fnl () ++ fnl () let preamble _ comment _ usf = pp_header_comment comment ++ str ";; This extracted scheme code relies on some additional macros\n" ++ str ";; available at http://www.pps.univ-paris-diderot.fr/~letouzey/scheme\n" ++ str "(load \"macros_extr.scm\")\n\n" ++ (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ()) let pr_id id = let s = Id.to_string id in for i = 0 to String.length s - 1 do if s.[i] == '\'' then s.[i] <- '~' done; str s let paren = pp_par true let pp_abst st = function | [] -> assert false | [id] -> paren (str "lambda " ++ paren (pr_id id) ++ spc () ++ st) | l -> paren (str "lambdas " ++ paren (prlist_with_sep spc pr_id l) ++ spc () ++ st) let pp_apply st _ = function | [] -> st | [a] -> hov 2 (paren (st ++ spc () ++ a)) | args -> hov 2 (paren (str "@ " ++ st ++ (prlist_strict (fun x -> spc () ++ x) args))) (*s The pretty-printer for Scheme syntax *) let pp_global k r = str (Common.pp_global k r) (*s Pretty-printing of expressions. *) let rec pp_expr env args = let apply st = pp_apply st true args in function | MLrel n -> let id = get_db_name n env in apply (pr_id id) | MLapp (f,args') -> let stl = List.map (pp_expr env []) args' in pp_expr env (stl @ args) f | MLlam _ as a -> let fl,a' = collect_lams a in let fl,env' = push_vars (List.map id_of_mlid fl) env in apply (pp_abst (pp_expr env' [] a') (List.rev fl)) | MLletin (id,a1,a2) -> let i,env' = push_vars [id_of_mlid id] env in apply (hv 0 (hov 2 (paren (str "let " ++ paren (paren (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1)) ++ spc () ++ hov 0 (pp_expr env' [] a2))))) | MLglob r -> apply (pp_global Term r) | MLcons (_,r,args') -> assert (List.is_empty args); let st = str "`" ++ paren (pp_global Cons r ++ (if List.is_empty args' then mt () else spc ()) ++ prlist_with_sep spc (pp_cons_args env) args') in if is_coinductive r then paren (str "delay " ++ st) else st | MLtuple _ -> error "Cannot handle tuples in Scheme yet." | MLcase (_,_,pv) when not (is_regular_match pv) -> error "Cannot handle general patterns in Scheme yet." | MLcase (_,t,pv) when is_custom_match pv -> let mkfun (ids,_,e) = if not (List.is_empty ids) then named_lams (List.rev ids) e else dummy_lams (ast_lift 1 e) 1 in apply (paren (hov 2 (str (find_custom_match pv) ++ fnl () ++ prvect (fun tr -> pp_expr env [] (mkfun tr) ++ fnl ()) pv ++ pp_expr env [] t))) | MLcase (typ,t, pv) -> let e = if not (is_coinductive_type typ) then pp_expr env [] t else paren (str "force" ++ spc () ++ pp_expr env [] t) in apply (v 3 (paren (str "match " ++ e ++ fnl () ++ pp_pat env pv))) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix env' i (Array.of_list (List.rev ids'),defs) args | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) paren (str "error" ++ spc () ++ qs s) | MLdummy _ -> str "__" (* An [MLdummy] may be applied, but I don't really care. *) | MLmagic a -> pp_expr env args a | MLaxiom -> paren (str "error \"AXIOM TO BE REALIZED\"") and pp_cons_args env = function | MLcons (_,r,args) when is_coinductive r -> paren (pp_global Cons r ++ (if List.is_empty args then mt () else spc ()) ++ prlist_with_sep spc (pp_cons_args env) args) | e -> str "," ++ pp_expr env [] e and pp_one_pat env (ids,p,t) = let r = match p with | Pusual r -> r | Pcons (r,l) -> r (* cf. the check [is_regular_match] above *) | _ -> assert false in let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in let args = if List.is_empty ids then mt () else (str " " ++ prlist_with_sep spc pr_id (List.rev ids)) in (pp_global Cons r ++ args), (pp_expr env' [] t) and pp_pat env pv = prvect_with_sep fnl (fun x -> let s1,s2 = pp_one_pat env x in hov 2 (str "((" ++ s1 ++ str ")" ++ spc () ++ s2 ++ str ")")) pv (*s names of the functions ([ids]) are already pushed in [env], and passed here just for convenience. *) and pp_fix env j (ids,bl) args = paren (str "letrec " ++ (v 0 (paren (prvect_with_sep fnl (fun (fi,ti) -> paren ((pr_id fi) ++ spc () ++ (pp_expr env [] ti))) (Array.map2 (fun id b -> (id,b)) ids bl)) ++ fnl () ++ hov 2 (pp_apply (pr_id (ids.(j))) true args)))) (*s Pretty-printing of a declaration. *) let pp_decl = function | Dind _ -> mt () | Dtype _ -> mt () | Dfix (rv, defs,_) -> let names = Array.map (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv in prvecti (fun i r -> let void = is_inline_custom r || (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then mt () else hov 2 (paren (str "define " ++ names.(i) ++ spc () ++ (if is_custom r then str (find_custom r) else pp_expr (empty_env ()) [] defs.(i))) ++ fnl ()) ++ fnl ()) rv | Dterm (r, a, _) -> if is_inline_custom r then mt () else hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++ (if is_custom r then str (find_custom r) else pp_expr (empty_env ()) [] a))) ++ fnl2 () let rec pp_structure_elem = function | (l,SEdecl d) -> pp_decl d | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr | (l,SEmodtype m) -> mt () (* for the moment we simply discard module type *) and pp_module_expr = function | MEstruct (mp,sel) -> prlist_strict pp_structure_elem sel | MEfunctor _ -> mt () (* for the moment we simply discard unapplied functors *) | MEident _ | MEapply _ -> assert false (* should be expanded in extract_env *) let pp_struct = let pp_sel (mp,sel) = push_visible mp []; let p = prlist_strict pp_structure_elem sel in pop_visible (); p in prlist_strict pp_sel let scheme_descr = { keywords = keywords; file_suffix = ".scm"; file_naming = file_of_modfile; preamble = preamble; pp_struct = pp_struct; sig_suffix = None; sig_preamble = (fun _ _ _ _ -> mt ()); pp_sig = (fun _ -> mt ()); pp_decl = pp_decl; } coq-8.6/plugins/extraction/table.ml0000644000175000017500000007350213022274260016750 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Names.eq_mind kn kn' | ConstRef _ -> false | VarRef _ -> assert false let repr_of_r = function | ConstRef kn -> repr_con kn | IndRef (kn,_) | ConstructRef ((kn,_),_) -> repr_mind kn | VarRef _ -> assert false let modpath_of_r r = let mp,_,_ = repr_of_r r in mp let label_of_r r = let _,_,l = repr_of_r r in l let rec base_mp = function | MPdot (mp,l) -> base_mp mp | mp -> mp let is_modfile = function | MPfile _ -> true | _ -> false let raw_string_of_modfile = function | MPfile f -> String.capitalize (Id.to_string (List.hd (DirPath.repr f))) | _ -> assert false let is_toplevel mp = ModPath.equal mp initial_path || ModPath.equal mp (Lib.current_mp ()) let at_toplevel mp = is_modfile mp || is_toplevel mp let mp_length mp = let mp0 = Lib.current_mp () in let rec len = function | mp when ModPath.equal mp mp0 -> 1 | MPdot (mp,_) -> 1 + len mp | _ -> 1 in len mp let rec prefixes_mp mp = match mp with | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp') | _ -> MPset.singleton mp let rec get_nth_label_mp n = function | MPdot (mp,l) -> if Int.equal n 1 then l else get_nth_label_mp (n-1) mp | _ -> failwith "get_nth_label: not enough MPdot" let common_prefix_from_list mp0 mpl = let prefixes = prefixes_mp mp0 in let rec f = function | [] -> None | mp :: l -> if MPset.mem mp prefixes then Some mp else f l in f mpl let rec parse_labels2 ll mp1 = function | mp when ModPath.equal mp1 mp -> mp,ll | MPdot (mp,l) -> parse_labels2 (l::ll) mp1 mp | mp -> mp,ll let labels_of_ref r = let mp_top = Lib.current_mp () in let mp,_,l = repr_of_r r in parse_labels2 [l] mp_top mp (*S The main tables: constants, inductives, records, ... *) (* Theses tables are not registered within coq save/undo mechanism since we reset their contents at each run of Extraction *) (* We use [constant_body] (resp. [mutual_inductive_body]) as checksum to ensure that the table contents aren't outdated. *) (*s Constants tables. *) let typedefs = ref (Cmap_env.empty : (constant_body * ml_type) Cmap_env.t) let init_typedefs () = typedefs := Cmap_env.empty let add_typedef kn cb t = typedefs := Cmap_env.add kn (cb,t) !typedefs let lookup_typedef kn cb = try let (cb0,t) = Cmap_env.find kn !typedefs in if cb0 == cb then Some t else None with Not_found -> None let cst_types = ref (Cmap_env.empty : (constant_body * ml_schema) Cmap_env.t) let init_cst_types () = cst_types := Cmap_env.empty let add_cst_type kn cb s = cst_types := Cmap_env.add kn (cb,s) !cst_types let lookup_cst_type kn cb = try let (cb0,s) = Cmap_env.find kn !cst_types in if cb0 == cb then Some s else None with Not_found -> None (*s Inductives table. *) let inductives = ref (Mindmap_env.empty : (mutual_inductive_body * ml_ind) Mindmap_env.t) let init_inductives () = inductives := Mindmap_env.empty let add_ind kn mib ml_ind = inductives := Mindmap_env.add kn (mib,ml_ind) !inductives let lookup_ind kn mib = try let (mib0,ml_ind) = Mindmap_env.find kn !inductives in if mib == mib0 then Some ml_ind else None with Not_found -> None let unsafe_lookup_ind kn = snd (Mindmap_env.find kn !inductives) let inductive_kinds = ref (Mindmap_env.empty : inductive_kind Mindmap_env.t) let init_inductive_kinds () = inductive_kinds := Mindmap_env.empty let add_inductive_kind kn k = inductive_kinds := Mindmap_env.add kn k !inductive_kinds let is_coinductive r = let kn = match r with | ConstructRef ((kn,_),_) -> kn | IndRef (kn,_) -> kn | _ -> assert false in try Mindmap_env.find kn !inductive_kinds == Coinductive with Not_found -> false let is_coinductive_type = function | Tglob (r,_) -> is_coinductive r | _ -> false let get_record_fields r = let kn = match r with | ConstructRef ((kn,_),_) -> kn | IndRef (kn,_) -> kn | _ -> assert false in try match Mindmap_env.find kn !inductive_kinds with | Record f -> f | _ -> [] with Not_found -> [] let record_fields_of_type = function | Tglob (r,_) -> get_record_fields r | _ -> [] (*s Recursors table. *) (* NB: here we can use the equivalence between canonical and user constant names. *) let recursors = ref KNset.empty let init_recursors () = recursors := KNset.empty let add_recursors env ind = let kn = MutInd.canonical ind in let mk_kn id = KerName.make (KerName.modpath kn) DirPath.empty (Label.of_id id) in let mib = Environ.lookup_mind ind env in Array.iter (fun mip -> let id = mip.mind_typename in let kn_rec = mk_kn (Nameops.add_suffix id "_rec") and kn_rect = mk_kn (Nameops.add_suffix id "_rect") in recursors := KNset.add kn_rec (KNset.add kn_rect !recursors)) mib.mind_packets let is_recursor = function | ConstRef c -> KNset.mem (Constant.canonical c) !recursors | _ -> false (*s Record tables. *) (* NB: here, working modulo name equivalence is ok *) let projs = ref (Refmap.empty : (inductive*int) Refmap.t) let init_projs () = projs := Refmap.empty let add_projection n kn ip = projs := Refmap.add (ConstRef kn) (ip,n) !projs let is_projection r = Refmap.mem r !projs let projection_arity r = snd (Refmap.find r !projs) let projection_info r = Refmap.find r !projs (*s Table of used axioms *) let info_axioms = ref Refset'.empty let log_axioms = ref Refset'.empty let init_axioms () = info_axioms := Refset'.empty; log_axioms := Refset'.empty let add_info_axiom r = info_axioms := Refset'.add r !info_axioms let remove_info_axiom r = info_axioms := Refset'.remove r !info_axioms let add_log_axiom r = log_axioms := Refset'.add r !log_axioms let opaques = ref Refset'.empty let init_opaques () = opaques := Refset'.empty let add_opaque r = opaques := Refset'.add r !opaques let remove_opaque r = opaques := Refset'.remove r !opaques (*s Extraction modes: modular or monolithic, library or minimal ? Nota: - Recursive Extraction : monolithic, minimal - Separate Extraction : modular, minimal - Extraction Library : modular, library *) let modular_ref = ref false let library_ref = ref false let set_modular b = modular_ref := b let modular () = !modular_ref let set_library b = library_ref := b let library () = !library_ref (*s Printing. *) (* The following functions work even on objects not in [Global.env ()]. Warning: for inductive objects, this only works if an [extract_inductive] have been done earlier, otherwise we can only ask the Nametab about currently visible objects. *) let safe_basename_of_global r = let last_chance r = try Nametab.basename_of_global r with Not_found -> anomaly (Pp.str "Inductive object unknown to extraction and not globally visible") in match r with | ConstRef kn -> Label.to_id (con_label kn) | IndRef (kn,0) -> Label.to_id (mind_label kn) | IndRef (kn,i) -> (try (unsafe_lookup_ind kn).ind_packets.(i).ip_typename with Not_found -> last_chance r) | ConstructRef ((kn,i),j) -> (try (unsafe_lookup_ind kn).ind_packets.(i).ip_consnames.(j-1) with Not_found -> last_chance r) | VarRef _ -> assert false let string_of_global r = try string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty r) with Not_found -> Id.to_string (safe_basename_of_global r) let safe_pr_global r = str (string_of_global r) (* idem, but with qualification, and only for constants. *) let safe_pr_long_global r = try Printer.pr_global r with Not_found -> match r with | ConstRef kn -> let mp,_,l = repr_con kn in str ((string_of_mp mp)^"."^(Label.to_string l)) | _ -> assert false let pr_long_mp mp = let lid = DirPath.repr (Nametab.dirpath_of_module mp) in str (String.concat "." (List.rev_map Id.to_string lid)) let pr_long_global ref = pr_path (Nametab.path_of_global ref) (*S Warning and Error messages. *) let err s = errorlabstrm "Extraction" s let warn_extraction_axiom_to_realize = CWarnings.create ~name:"extraction-axiom-to-realize" ~category:"extraction" (fun axioms -> let s = if Int.equal (List.length axioms) 1 then "axiom" else "axioms" in strbrk ("The following "^s^" must be realized in the extracted code:") ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global axioms) ++ str "." ++ fnl ()) let warn_extraction_logical_axiom = CWarnings.create ~name:"extraction-logical-axiom" ~category:"extraction" (fun axioms -> let s = if Int.equal (List.length axioms) 1 then "axiom was" else "axioms were" in (strbrk ("The following logical "^s^" encountered:") ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global axioms ++ str ".\n") ++ strbrk "Having invalid logical axiom in the environment when extracting" ++ spc () ++ strbrk "may lead to incorrect or non-terminating ML terms." ++ fnl ())) let warning_axioms () = let info_axioms = Refset'.elements !info_axioms in if not (List.is_empty info_axioms) then warn_extraction_axiom_to_realize info_axioms; let log_axioms = Refset'.elements !log_axioms in if not (List.is_empty log_axioms) then warn_extraction_logical_axiom log_axioms let warn_extraction_opaque_accessed = CWarnings.create ~name:"extraction-opaque-accessed" ~category:"extraction" (fun lst -> strbrk "The extraction is currently set to bypass opacity, " ++ strbrk "the following opaque constant bodies have been accessed :" ++ lst ++ str "." ++ fnl ()) let warn_extraction_opaque_as_axiom = CWarnings.create ~name:"extraction-opaque-as-axiom" ~category:"extraction" (fun lst -> strbrk "The extraction now honors the opacity constraints by default, " ++ strbrk "the following opaque constants have been extracted as axioms :" ++ lst ++ str "." ++ fnl () ++ strbrk "If necessary, use \"Set Extraction AccessOpaque\" to change this." ++ fnl ()) let warning_opaques accessed = let opaques = Refset'.elements !opaques in if not (List.is_empty opaques) then let lst = hov 1 (spc () ++ prlist_with_sep spc safe_pr_global opaques) in if accessed then warn_extraction_opaque_accessed lst else warn_extraction_opaque_as_axiom lst let warning_ambiguous_name = CWarnings.create ~name:"extraction-ambiguous-name" ~category:"extraction" (fun (q,mp,r) -> strbrk "The name " ++ pr_qualid q ++ strbrk " is ambiguous, " ++ strbrk "do you mean module " ++ pr_long_mp mp ++ strbrk " or object " ++ pr_long_global r ++ str " ?" ++ fnl () ++ strbrk "First choice is assumed, for the second one please use " ++ strbrk "fully qualified name." ++ fnl ()) let error_axiom_scheme r i = err (str "The type scheme axiom " ++ spc () ++ safe_pr_global r ++ spc () ++ str "needs " ++ int i ++ str " type variable(s).") let warn_extraction_inside_module = CWarnings.create ~name:"extraction-inside-module" ~category:"extraction" (fun () -> strbrk "Extraction inside an opened module is experimental." ++ strbrk "In case of problem, close it first.") let check_inside_module () = if Lib.is_modtype () then err (str "You can't do that within a Module Type." ++ fnl () ++ str "Close it and try again.") else if Lib.is_module () then warn_extraction_inside_module () let check_inside_section () = if Lib.sections_are_opened () then err (str "You can't do that within a section." ++ fnl () ++ str "Close it and try again.") let warn_extraction_reserved_identifier = CWarnings.create ~name:"extraction-reserved-identifier" ~category:"extraction" (fun s -> strbrk ("The identifier "^s^ " contains __ which is reserved for the extraction")) let warning_id s = warn_extraction_reserved_identifier s let error_constant r = err (safe_pr_global r ++ str " is not a constant.") let error_inductive r = err (safe_pr_global r ++ spc () ++ str "is not an inductive type.") let error_nb_cons () = err (str "Not the right number of constructors.") let error_module_clash mp1 mp2 = err (str "The Coq modules " ++ pr_long_mp mp1 ++ str " and " ++ pr_long_mp mp2 ++ str " have the same ML name.\n" ++ str "This is not supported yet. Please do some renaming first.") let error_no_module_expr mp = err (str "The module " ++ pr_long_mp mp ++ str " has no body, it probably comes from\n" ++ str "some Declare Module outside any Module Type.\n" ++ str "This situation is currently unsupported by the extraction.") let error_singleton_become_prop id og = let loc = match og with | Some g -> fnl () ++ str "in " ++ safe_pr_global g ++ str " (or in its mutual block)" | None -> mt () in err (str "The informative inductive type " ++ pr_id id ++ str " has a Prop instance" ++ loc ++ str "." ++ fnl () ++ str "This happens when a sort-polymorphic singleton inductive type\n" ++ str "has logical parameters, such as (I,I) : (True * True) : Prop.\n" ++ str "The Ocaml extraction cannot handle this situation yet.\n" ++ str "Instead, use a sort-monomorphic type such as (True /\\ True)\n" ++ str "or extract to Haskell.") let error_unknown_module m = err (str "Module" ++ spc () ++ pr_qualid m ++ spc () ++ str "not found.") let error_scheme () = err (str "No Scheme modular extraction available yet.") let error_not_visible r = err (safe_pr_global r ++ str " is not directly visible.\n" ++ str "For example, it may be inside an applied functor.\n" ++ str "Use Recursive Extraction to get the whole environment.") let error_MPfile_as_mod mp b = let s1 = if b then "asked" else "required" in let s2 = if b then "extract some objects of this module or\n" else "" in err (str ("Extraction of file "^(raw_string_of_modfile mp)^ ".v as a module is "^s1^".\n"^ "Monolithic Extraction cannot deal with this situation.\n"^ "Please "^s2^"use (Recursive) Extraction Library instead.\n")) let argnames_of_global r = let typ = Global.type_of_global_unsafe r in let rels,_ = decompose_prod (Reduction.whd_all (Global.env ()) typ) in List.rev_map fst rels let msg_of_implicit = function | Kimplicit (r,i) -> let name = match List.nth (argnames_of_global r) (i-1) with | Anonymous -> "" | Name id -> "(" ^ Id.to_string id ^ ") " in (String.ordinal i)^" argument "^name^"of "^(string_of_global r) | Ktype | Kprop -> "" let error_remaining_implicit k = let s = msg_of_implicit k in err (str ("An implicit occurs after extraction : "^s^".") ++ fnl () ++ str "Please check your Extraction Implicit declarations." ++ fnl() ++ str "You might also try Unset Extraction SafeImplicits to force" ++ fnl() ++ str "the extraction of unsafe code and review it manually.") let warn_extraction_remaining_implicit = CWarnings.create ~name:"extraction-remaining-implicit" ~category:"extraction" (fun s -> strbrk ("At least an implicit occurs after extraction : "^s^".") ++ fnl () ++ strbrk "Extraction SafeImplicits is unset, extracting nonetheless," ++ strbrk "but this code is potentially unsafe, please review it manually.") let warning_remaining_implicit k = let s = msg_of_implicit k in warn_extraction_remaining_implicit s let check_loaded_modfile mp = match base_mp mp with | MPfile dp -> if not (Library.library_is_loaded dp) then begin match base_mp (Lib.current_mp ()) with | MPfile dp' when not (DirPath.equal dp dp') -> err (str "Please load library " ++ pr_dirpath dp ++ str " first.") | _ -> () end | _ -> () let info_file f = Flags.if_verbose Feedback.msg_info (str ("The file "^f^" has been created by extraction.")) (*S The Extraction auxiliary commands *) (* The objects defined below should survive an arbitrary time, so we register them to coq save/undo mechanism. *) let my_bool_option name initval = let flag = ref initval in let access = fun () -> !flag in let _ = declare_bool_option {optsync = true; optdepr = false; optname = "Extraction "^name; optkey = ["Extraction"; name]; optread = access; optwrite = (:=) flag } in access (*s Extraction AccessOpaque *) let access_opaque = my_bool_option "AccessOpaque" true (*s Extraction AutoInline *) let auto_inline = my_bool_option "AutoInline" false (*s Extraction TypeExpand *) let type_expand = my_bool_option "TypeExpand" true (*s Extraction KeepSingleton *) let keep_singleton = my_bool_option "KeepSingleton" false (*s Extraction Optimize *) type opt_flag = { opt_kill_dum : bool; (* 1 *) opt_fix_fun : bool; (* 2 *) opt_case_iot : bool; (* 4 *) opt_case_idr : bool; (* 8 *) opt_case_idg : bool; (* 16 *) opt_case_cst : bool; (* 32 *) opt_case_fun : bool; (* 64 *) opt_case_app : bool; (* 128 *) opt_let_app : bool; (* 256 *) opt_lin_let : bool; (* 512 *) opt_lin_beta : bool } (* 1024 *) let kth_digit n k = not (Int.equal (n land (1 lsl k)) 0) let flag_of_int n = { opt_kill_dum = kth_digit n 0; opt_fix_fun = kth_digit n 1; opt_case_iot = kth_digit n 2; opt_case_idr = kth_digit n 3; opt_case_idg = kth_digit n 4; opt_case_cst = kth_digit n 5; opt_case_fun = kth_digit n 6; opt_case_app = kth_digit n 7; opt_let_app = kth_digit n 8; opt_lin_let = kth_digit n 9; opt_lin_beta = kth_digit n 10 } (* For the moment, we allow by default everything except : - the type-unsafe optimization [opt_case_idg], which anyway cannot be activated currently (cf [Mlutil.branch_as_fun]) - the linear let and beta reduction [opt_lin_let] and [opt_lin_beta] (may lead to complexity blow-up, subsumed by finer reductions when inlining recursors). *) let int_flag_init = 1 + 2 + 4 + 8 (*+ 16*) + 32 + 64 + 128 + 256 (*+ 512 + 1024*) let int_flag_ref = ref int_flag_init let opt_flag_ref = ref (flag_of_int int_flag_init) let chg_flag n = int_flag_ref := n; opt_flag_ref := flag_of_int n let optims () = !opt_flag_ref let _ = declare_bool_option {optsync = true; optdepr = false; optname = "Extraction Optimize"; optkey = ["Extraction"; "Optimize"]; optread = (fun () -> not (Int.equal !int_flag_ref 0)); optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))} let _ = declare_int_option { optsync = true; optdepr = false; optname = "Extraction Flag"; optkey = ["Extraction";"Flag"]; optread = (fun _ -> Some !int_flag_ref); optwrite = (function | None -> chg_flag 0 | Some i -> chg_flag (max i 0))} (* This option controls whether "dummy lambda" are removed when a toplevel constant is defined. *) let conservative_types_ref = ref false let conservative_types () = !conservative_types_ref let _ = declare_bool_option {optsync = true; optdepr = false; optname = "Extraction Conservative Types"; optkey = ["Extraction"; "Conservative"; "Types"]; optread = (fun () -> !conservative_types_ref); optwrite = (fun b -> conservative_types_ref := b) } (* Allows to print a comment at the beginning of the output files *) let file_comment_ref = ref "" let file_comment () = !file_comment_ref let _ = declare_string_option {optsync = true; optdepr = false; optname = "Extraction File Comment"; optkey = ["Extraction"; "File"; "Comment"]; optread = (fun () -> !file_comment_ref); optwrite = (fun s -> file_comment_ref := s) } (*s Extraction Lang *) type lang = Ocaml | Haskell | Scheme | JSON let lang_ref = Summary.ref Ocaml ~name:"ExtrLang" let lang () = !lang_ref let extr_lang : lang -> obj = declare_object {(default_object "Extraction Lang") with cache_function = (fun (_,l) -> lang_ref := l); load_function = (fun _ (_,l) -> lang_ref := l)} let extraction_language x = Lib.add_anonymous_leaf (extr_lang x) (*s Extraction Inline/NoInline *) let empty_inline_table = (Refset'.empty,Refset'.empty) let inline_table = Summary.ref empty_inline_table ~name:"ExtrInline" let to_inline r = Refset'.mem r (fst !inline_table) let to_keep r = Refset'.mem r (snd !inline_table) let add_inline_entries b l = let f b = if b then Refset'.add else Refset'.remove in let i,k = !inline_table in inline_table := (List.fold_right (f b) l i), (List.fold_right (f (not b)) l k) (* Registration of operations for rollback. *) let inline_extraction : bool * global_reference list -> obj = declare_object {(default_object "Extraction Inline") with cache_function = (fun (_,(b,l)) -> add_inline_entries b l); load_function = (fun _ (_,(b,l)) -> add_inline_entries b l); classify_function = (fun o -> Substitute o); discharge_function = (fun (_,(b,l)) -> Some (b, List.map pop_global_reference l)); subst_function = (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l))) } (* Grammar entries. *) let extraction_inline b l = let refs = List.map Smartlocate.global_with_alias l in List.iter (fun r -> match r with | ConstRef _ -> () | _ -> error_constant r) refs; Lib.add_anonymous_leaf (inline_extraction (b,refs)) (* Printing part *) let print_extraction_inline () = let (i,n)= !inline_table in let i'= Refset'.filter (function ConstRef _ -> true | _ -> false) i in (str "Extraction Inline:" ++ fnl () ++ Refset'.fold (fun r p -> (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) i' (mt ()) ++ str "Extraction NoInline:" ++ fnl () ++ Refset'.fold (fun r p -> (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) n (mt ())) (* Reset part *) let reset_inline : unit -> obj = declare_object {(default_object "Reset Extraction Inline") with cache_function = (fun (_,_)-> inline_table := empty_inline_table); load_function = (fun _ (_,_)-> inline_table := empty_inline_table)} let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) (*s Extraction Implicit *) let safe_implicit = my_bool_option "SafeImplicits" true let err_or_warn_remaining_implicit k = if safe_implicit () then error_remaining_implicit k else warning_remaining_implicit k type int_or_id = ArgInt of int | ArgId of Id.t let implicits_table = Summary.ref Refmap'.empty ~name:"ExtrImplicit" let implicits_of_global r = try Refmap'.find r !implicits_table with Not_found -> Int.Set.empty let add_implicits r l = let names = argnames_of_global r in let n = List.length names in let add_arg s = function | ArgInt i -> if 1 <= i && i <= n then Int.Set.add i s else err (int i ++ str " is not a valid argument number for " ++ safe_pr_global r) | ArgId id -> try let i = List.index Name.equal (Name id) names in Int.Set.add i s with Not_found -> err (str "No argument " ++ pr_id id ++ str " for " ++ safe_pr_global r) in let ints = List.fold_left add_arg Int.Set.empty l in implicits_table := Refmap'.add r ints !implicits_table (* Registration of operations for rollback. *) let implicit_extraction : global_reference * int_or_id list -> obj = declare_object {(default_object "Extraction Implicit") with cache_function = (fun (_,(r,l)) -> add_implicits r l); load_function = (fun _ (_,(r,l)) -> add_implicits r l); classify_function = (fun o -> Substitute o); subst_function = (fun (s,(r,l)) -> (fst (subst_global s r), l)) } (* Grammar entries. *) let extraction_implicit r l = check_inside_section (); Lib.add_anonymous_leaf (implicit_extraction (Smartlocate.global_with_alias r,l)) (*s Extraction Blacklist of filenames not to use while extracting *) let blacklist_table = Summary.ref Id.Set.empty ~name:"ExtrBlacklist" let modfile_ids = ref [] let modfile_mps = ref MPmap.empty let reset_modfile () = modfile_ids := Id.Set.elements !blacklist_table; modfile_mps := MPmap.empty let string_of_modfile mp = try MPmap.find mp !modfile_mps with Not_found -> let id = Id.of_string (raw_string_of_modfile mp) in let id' = next_ident_away id !modfile_ids in let s' = Id.to_string id' in modfile_ids := id' :: !modfile_ids; modfile_mps := MPmap.add mp s' !modfile_mps; s' (* same as [string_of_modfile], but preserves the capital/uncapital 1st char *) let file_of_modfile mp = let s0 = match mp with | MPfile f -> Id.to_string (List.hd (DirPath.repr f)) | _ -> assert false in let s = String.copy (string_of_modfile mp) in if s.[0] != s0.[0] then s.[0] <- s0.[0]; s let add_blacklist_entries l = blacklist_table := List.fold_right (fun s -> Id.Set.add (Id.of_string (String.capitalize s))) l !blacklist_table (* Registration of operations for rollback. *) let blacklist_extraction : string list -> obj = declare_object {(default_object "Extraction Blacklist") with cache_function = (fun (_,l) -> add_blacklist_entries l); load_function = (fun _ (_,l) -> add_blacklist_entries l); subst_function = (fun (_,x) -> x) } (* Grammar entries. *) let extraction_blacklist l = let l = List.rev_map Id.to_string l in Lib.add_anonymous_leaf (blacklist_extraction l) (* Printing part *) let print_extraction_blacklist () = prlist_with_sep fnl pr_id (Id.Set.elements !blacklist_table) (* Reset part *) let reset_blacklist : unit -> obj = declare_object {(default_object "Reset Extraction Blacklist") with cache_function = (fun (_,_)-> blacklist_table := Id.Set.empty); load_function = (fun _ (_,_)-> blacklist_table := Id.Set.empty)} let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ()) (*s Extract Constant/Inductive. *) (* UGLY HACK: to be defined in [extraction.ml] *) let (use_type_scheme_nb_args, type_scheme_nb_args_hook) = Hook.make () let customs = Summary.ref Refmap'.empty ~name:"ExtrCustom" let add_custom r ids s = customs := Refmap'.add r (ids,s) !customs let is_custom r = Refmap'.mem r !customs let is_inline_custom r = (is_custom r) && (to_inline r) let find_custom r = snd (Refmap'.find r !customs) let find_type_custom r = Refmap'.find r !customs let custom_matchs = Summary.ref Refmap'.empty ~name:"ExtrCustomMatchs" let add_custom_match r s = custom_matchs := Refmap'.add r s !custom_matchs let indref_of_match pv = if Array.is_empty pv then raise Not_found; let (_,pat,_) = pv.(0) in match pat with | Pusual (ConstructRef (ip,_)) -> IndRef ip | Pcons (ConstructRef (ip,_),_) -> IndRef ip | _ -> raise Not_found let is_custom_match pv = try Refmap'.mem (indref_of_match pv) !custom_matchs with Not_found -> false let find_custom_match pv = Refmap'.find (indref_of_match pv) !custom_matchs (* Registration of operations for rollback. *) let in_customs : global_reference * string list * string -> obj = declare_object {(default_object "ML extractions") with cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s); load_function = (fun _ (_,(r,ids,s)) -> add_custom r ids s); classify_function = (fun o -> Substitute o); subst_function = (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str)) } let in_custom_matchs : global_reference * string -> obj = declare_object {(default_object "ML extractions custom matchs") with cache_function = (fun (_,(r,s)) -> add_custom_match r s); load_function = (fun _ (_,(r,s)) -> add_custom_match r s); classify_function = (fun o -> Substitute o); subst_function = (fun (subs,(r,s)) -> (fst (subst_global subs r), s)) } (* Grammar entries. *) let extract_constant_inline inline r ids s = check_inside_section (); let g = Smartlocate.global_with_alias r in match g with | ConstRef kn -> let env = Global.env () in let typ = Global.type_of_global_unsafe (ConstRef kn) in let typ = Reduction.whd_all env typ in if Reduction.is_arity env typ then begin let nargs = Hook.get use_type_scheme_nb_args env typ in if not (Int.equal (List.length ids) nargs) then error_axiom_scheme g nargs end; Lib.add_anonymous_leaf (inline_extraction (inline,[g])); Lib.add_anonymous_leaf (in_customs (g,ids,s)) | _ -> error_constant g let extract_inductive r s l optstr = check_inside_section (); let g = Smartlocate.global_with_alias r in Dumpglob.add_glob (loc_of_reference r) g; match g with | IndRef ((kn,i) as ip) -> let mib = Global.lookup_mind kn in let n = Array.length mib.mind_packets.(i).mind_consnames in if not (Int.equal n (List.length l)) then error_nb_cons (); Lib.add_anonymous_leaf (inline_extraction (true,[g])); Lib.add_anonymous_leaf (in_customs (g,[],s)); Option.iter (fun s -> Lib.add_anonymous_leaf (in_custom_matchs (g,s))) optstr; List.iteri (fun j s -> let g = ConstructRef (ip,succ j) in Lib.add_anonymous_leaf (inline_extraction (true,[g])); Lib.add_anonymous_leaf (in_customs (g,[],s))) l | _ -> error_inductive g (*s Tables synchronization. *) let reset_tables () = init_typedefs (); init_cst_types (); init_inductives (); init_inductive_kinds (); init_recursors (); init_projs (); init_axioms (); init_opaques (); reset_modfile () coq-8.6/plugins/extraction/ExtrOcamlZBigInt.v0000644000175000017500000000662213022274260020642 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "Big.big_int" [ "Big.doubleplusone" "Big.double" "Big.one" ] "Big.positive_case". Extract Inductive Z => "Big.big_int" [ "Big.zero" "" "Big.opp" ] "Big.z_case". Extract Inductive N => "Big.big_int" [ "Big.zero" "" ] "Big.n_case". (** Nota: the "" above is used as an identity function "(fun p->p)" *) (** Efficient (but uncertified) versions for usual functions *) Extract Constant Pos.add => "Big.add". Extract Constant Pos.succ => "Big.succ". Extract Constant Pos.pred => "fun n -> Big.max Big.one (Big.pred n)". Extract Constant Pos.sub => "fun n m -> Big.max Big.one (Big.sub n m)". Extract Constant Pos.mul => "Big.mult". Extract Constant Pos.min => "Big.min". Extract Constant Pos.max => "Big.max". Extract Constant Pos.compare => "fun x y -> Big.compare_case Eq Lt Gt x y". Extract Constant Pos.compare_cont => "fun c x y -> Big.compare_case c Lt Gt x y". Extract Constant N.add => "Big.add". Extract Constant N.succ => "Big.succ". Extract Constant N.pred => "fun n -> Big.max Big.zero (Big.pred n)". Extract Constant N.sub => "fun n m -> Big.max Big.zero (Big.sub n m)". Extract Constant N.mul => "Big.mult". Extract Constant N.min => "Big.min". Extract Constant N.max => "Big.max". Extract Constant N.div => "fun a b -> if Big.eq b Big.zero then Big.zero else Big.div a b". Extract Constant N.modulo => "fun a b -> if Big.eq b Big.zero then Big.zero else Big.modulo a b". Extract Constant N.compare => "Big.compare_case Eq Lt Gt". Extract Constant Z.add => "Big.add". Extract Constant Z.succ => "Big.succ". Extract Constant Z.pred => "Big.pred". Extract Constant Z.sub => "Big.sub". Extract Constant Z.mul => "Big.mult". Extract Constant Z.opp => "Big.opp". Extract Constant Z.abs => "Big.abs". Extract Constant Z.min => "Big.min". Extract Constant Z.max => "Big.max". Extract Constant Z.compare => "Big.compare_case Eq Lt Gt". Extract Constant Z.of_N => "fun p -> p". Extract Constant Z.abs_N => "Big.abs". (** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod). For the moment we don't even try *) (** Test: Require Import ZArith NArith. Extraction "/tmp/test.ml" Pos.add Pos.pred Pos.sub Pos.mul Pos.compare N.pred N.sub N.div N.modulo N.compare Z.add Z.mul Z.compare Z.of_N Z.abs_N Z.div Z.modulo. *) coq-8.6/plugins/extraction/ocaml.mli0000644000175000017500000000106713022274260017122 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string; (* the second argument is a comment to add to the preamble *) preamble : Id.t -> std_ppcmds option -> module_path list -> unsafe_needs -> std_ppcmds; pp_struct : ml_structure -> std_ppcmds; (* Concerning a possible interface file *) sig_suffix : string option; (* the second argument is a comment to add to the preamble *) sig_preamble : Id.t -> std_ppcmds option -> module_path list -> unsafe_needs -> std_ppcmds; pp_sig : ml_signature -> std_ppcmds; (* for an isolated declaration print *) pp_decl : ml_decl -> std_ppcmds; } coq-8.6/plugins/extraction/ExtrHaskellZInt.v0000644000175000017500000000144713022274260020550 0ustar mdenesmdenes(** Extraction of [Z] into Haskell's [Int] *) Require Import ZArith. Require Import ExtrHaskellZNum. (** * Disclaimer: trying to obtain efficient certified programs * by extracting [Z] into [Int] is definitively *not* a good idea. * See comments in [ExtrOcamlNatInt.v]. *) Extract Inductive positive => "Prelude.Int" [ "(\x -> 2 Prelude.* x Prelude.+ 1)" "(\x -> 2 Prelude.* x)" "1" ] "(\fI fO fH n -> if n Prelude.== 1 then fH () else if Prelude.odd n then fI (n `Prelude.div` 2) else fO (n `Prelude.div` 2))". Extract Inductive Z => "Prelude.Int" [ "0" "(\x -> x)" "Prelude.negate" ] "(\fO fP fN n -> if n Prelude.== 0 then fO () else if n Prelude.> 0 then fP n else fN (Prelude.negate n))". coq-8.6/plugins/extraction/README0000644000175000017500000001130013022274260016173 0ustar mdenesmdenes Coq Extraction ============== What is it ? ------------ The extraction is a mechanism that produces functional code (Ocaml/Haskell/Scheme) out of any Coq terms (either programs or proofs). Who did it ? ------------ The current implementation (from version 7.0 up to now) has been done by P. Letouzey during his PhD, helped by J.C. Filliâtre and supervised by C. Paulin. An earlier implementation (versions 6.x) was due to B. Werner and C. Paulin. Where can we find more information ? ------------------------------------ - Coq Reference Manual includes a full chapter about extraction - P. Letouzey's PhD thesis [3] forms a complete document about both theory and implementation and test-cases of Coq-extraction - A more recent article [4] proposes a short overview of extraction - earlier documents [1] [2] may also be useful. Why a complete re-implementation ? ---------------------------------- Extraction code has been completely rewritten since version V6.3. 1) Principles The main goal of the new extraction is to handle any Coq term, even those upon sort Type, and to produce code that always compiles. Thus it will never answer something like "Not an ML type", but rather a dummy term like the ML unit. Translation between Coq and ML is based upon the following principles: - Terms of sort Prop don't have any computational meaning, so they are merged into one ML term "__". This part is done according to P. Letouzey's works [1] and [2]. This dummy constant "__" used to be implemented by the unit (), but we recently found that this constant might be applied in some cases. So "__" is now in Ocaml a fixpoint that forgets its arguments: let __ = let rec f _ = Obj.repr f in Obj.repr f - Terms that are type schemes (i.e. something of type ( : )( : )...s with s a sort ) don't have any ML counterpart at the term level, since they are types transformers. In fact they do not have any computational meaning either. So we also merge them into that dummy term "__". - A Coq term gives a ML term or a ML type depending of its type: type schemes will (try to) give ML types, and all other terms give ML terms. And the rest of the translation is (almost) straightforward: an inductive gives an inductive, etc... This gives ML code that have no special reason to typecheck, due to the incompatibilities between Coq and ML typing systems. In fact most of the time everything goes right. We now verify during extraction that the produced code is typecheckable, and if it is not we insert unsafe type casting at critical points in the code, with either "Obj.magic" in Ocaml or "unsafeCoerce" in Haskell. 2) Differences with previous extraction (V6.3 and before) 2.a) The pros The ability to extract every Coq term, as explain in the previous paragraph. The ability to extract from a file an ML module (cf Extraction Library in the documentation) You can have a taste of extraction directly at the toplevel by using the "Extraction " or the "Recursive Extraction ". This toplevel extraction was already there in V6.3, but was printing Fw terms. It now prints in the language of your choice: Ocaml, Haskell or Scheme. The optimization done on extracted code has been ported between V6.3 and V7 and enhanced, and in particular the mechanism of automatic expansion. 2.b) The cons The presence of some parasite "__" as dummy arguments in functions. This denotes the rests of a proof part. The previous extraction was able to remove them totally. The current implementation removes a good deal of them, but not all. This problem is due to extraction upon Type. For example, let's take this pathological term: (if b then Set else Prop) : Type The only way to know if this is an Set (to keep) or a Prop (to remove) is to compute the boolean b, and we do not want to do that during extraction. There is no more "ML import" feature. You can compensate by using Axioms, and then "Extract Constant ..." [1]: Exécution de termes de preuves: une nouvelle méthode d'extraction pour le Calcul des Constructions Inductives, Pierre Letouzey, DEA thesis, 2000, http://www.pps.jussieu.fr/~letouzey/download/rapport_dea.ps.gz [2]: A New Extraction for Coq, Pierre Letouzey, Types 2002 Post-Workshop Proceedings. http://www.pps.jussieu.fr/~letouzey/download/extraction2002.ps.gz [3]: Programmation fonctionnelle certifiée: l'extraction de programmes dans l'assistant Coq. Pierre Letouzey, PhD thesis, 2004. http://www.pps.jussieu.fr/~letouzey/download/these_letouzey.ps.gz http://www.pps.jussieu.fr/~letouzey/download/these_letouzey_English.ps.gz [4]: Coq Extraction, An overview. Pierre Letouzey. CiE2008. http://www.pps.jussieu.fr/~letouzey/download/letouzey_extr_cie08.pdf coq-8.6/plugins/extraction/extract_env.mli0000644000175000017500000000234413022274260020350 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val full_extraction : string option -> reference list -> unit val separate_extraction : reference list -> unit val extraction_library : bool -> Id.t -> unit (* For debug / external output via coqtop.byte + Drop : *) val mono_environment : global_reference list -> module_path list -> Miniml.ml_structure (* Used by the Relation Extraction plugin *) val print_one_decl : Miniml.ml_structure -> module_path -> Miniml.ml_decl -> Pp.std_ppcmds (* Used by Extraction Compute *) val structure_for_compute : Term.constr -> Miniml.ml_flat_structure * Miniml.ml_ast * Miniml.ml_type coq-8.6/plugins/extraction/ExtrOcamlBasic.v0000644000175000017500000000262713022274260020356 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool [ true false ]. Extract Inductive option => option [ Some None ]. Extract Inductive unit => unit [ "()" ]. Extract Inductive list => list [ "[]" "( :: )" ]. Extract Inductive prod => "( * )" [ "" ]. (** NB: The "" above is a hack, but produce nicer code than "(,)" *) (** Mapping sumbool to bool and sumor to option is not always nicer, but it helps when realizing stuff like [lt_eq_lt_dec] *) Extract Inductive sumbool => bool [ true false ]. Extract Inductive sumor => option [ Some None ]. (** Restore lazyness of andb, orb. NB: without these Extract Constant, andb/orb would be inlined by extraction in order to have lazyness, producing inelegant (if ... then ... else false) and (if ... then true else ...). *) Extract Inlined Constant andb => "(&&)". Extract Inlined Constant orb => "(||)". coq-8.6/plugins/extraction/ExtrHaskellZInteger.v0000644000175000017500000000146113022274260021407 0ustar mdenesmdenes(** Extraction of [Z] into Haskell's [Integer] *) Require Import ZArith. Require Import ExtrHaskellZNum. (** Disclaimer: trying to obtain efficient certified programs by extracting [Z] into [Integer] isn't necessarily a good idea. See comments in [ExtrOcamlNatInt.v]. *) Extract Inductive positive => "Prelude.Integer" [ "(\x -> 2 Prelude.* x Prelude.+ 1)" "(\x -> 2 Prelude.* x)" "1" ] "(\fI fO fH n -> if n Prelude.== 1 then fH () else if Prelude.odd n then fI (n `Prelude.div` 2) else fO (n `Prelude.div` 2))". Extract Inductive Z => "Prelude.Integer" [ "0" "(\x -> x)" "Prelude.negate" ] "(\fO fP fN n -> if n Prelude.== 0 then fO () else if n Prelude.> 0 then fP n else fN (Prelude.negate n))". coq-8.6/plugins/extraction/extraction.ml0000644000175000017500000011707713022274260020047 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* flag_of_type (push_rel (LocalAssum (x,t)) env) c | Sort s when Sorts.is_prop s -> (Logic,TypeScheme) | Sort _ -> (Info,TypeScheme) | _ -> if (sort_of env t) == InProp then (Logic,Default) else (Info,Default) (*s Two particular cases of [flag_of_type]. *) let is_default env t = match flag_of_type env t with | (Info, Default) -> true | _ -> false exception NotDefault of kill_reason let check_default env t = match flag_of_type env t with | _,TypeScheme -> raise (NotDefault Ktype) | Logic,_ -> raise (NotDefault Kprop) | _ -> () let is_info_scheme env t = match flag_of_type env t with | (Info, TypeScheme) -> true | _ -> false (*s [type_sign] gernerates a signature aimed at treating a type application. *) let rec type_sign env c = match kind_of_term (whd_all env none c) with | Prod (n,t,d) -> (if is_info_scheme env t then Keep else Kill Kprop) :: (type_sign (push_rel_assum (n,t) env) d) | _ -> [] let rec type_scheme_nb_args env c = match kind_of_term (whd_all env none c) with | Prod (n,t,d) -> let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in if is_info_scheme env t then n+1 else n | _ -> 0 let _ = Hook.set type_scheme_nb_args_hook type_scheme_nb_args (*s [type_sign_vl] does the same, plus a type var list. *) (* When generating type variables, we avoid any ' in their names (otherwise this may cause a lexer conflict in ocaml with 'a'). We also get rid of unicode characters. Anyway, since type variables are local, the created name is just a matter of taste... See also Bug #3227 *) let make_typvar n vl = let id = id_of_name n in let id' = let s = Id.to_string id in if not (String.contains s '\'') && Unicode.is_basic_ascii s then id else id_of_name Anonymous in next_ident_away id' vl let rec type_sign_vl env c = match kind_of_term (whd_all env none c) with | Prod (n,t,d) -> let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in if not (is_info_scheme env t) then Kill Kprop::s, vl else Keep::s, (make_typvar n vl) :: vl | _ -> [],[] let rec nb_default_params env c = match kind_of_term (whd_all env none c) with | Prod (n,t,d) -> let n = nb_default_params (push_rel_assum (n,t) env) d in if is_default env t then n+1 else n | _ -> 0 (* Enriching a signature with implicit information *) let sign_with_implicits r s nb_params = let implicits = implicits_of_global r in let rec add_impl i = function | [] -> [] | Keep::s when Int.Set.mem i implicits -> Kill (Kimplicit (r,i)) :: add_impl (i+1) s | sign::s -> sign :: add_impl (i+1) s in add_impl (1+nb_params) s (*S Management of type variable contexts. *) (* A De Bruijn variable context (db) is a context for translating Coq [Rel] into ML type [Tvar]. *) (*s From a type signature toward a type variable context (db). *) let db_from_sign s = let rec make i acc = function | [] -> acc | Keep :: l -> make (i+1) (i::acc) l | Kill _ :: l -> make i (0::acc) l in make 1 [] s (*s Create a type variable context from indications taken from an inductive type (see just below). *) let rec db_from_ind dbmap i = if Int.equal i 0 then [] else (try Int.Map.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1)) (*s [parse_ind_args] builds a map: [i->j] iff the i-th Coq argument of a constructor corresponds to the j-th type var of the ML inductive. *) (* \begin{itemize} \item [si] : signature of the inductive \item [i] : counter of Coq args for [(I args)] \item [j] : counter of ML type vars \item [relmax] : total args number of the constructor \end{itemize} *) let parse_ind_args si args relmax = let rec parse i j = function | [] -> Int.Map.empty | Kill _ :: s -> parse (i+1) j s | Keep :: s -> (match kind_of_term args.(i-1) with | Rel k -> Int.Map.add (relmax+1-k) j (parse (i+1) (j+1) s) | _ -> parse (i+1) (j+1) s) in parse 1 1 si (*S Extraction of a type. *) (* [extract_type env db c args] is used to produce an ML type from the coq term [(c args)], which is supposed to be a Coq type. *) (* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *) (* [j] stands for the next ML type var. [j=0] means we do not generate ML type var anymore (in subterms for example). *) let rec extract_type env db j c args = match kind_of_term (whd_betaiotazeta Evd.empty c) with | App (d, args') -> (* We just accumulate the arguments. *) extract_type env db j d (Array.to_list args' @ args) | Lambda (_,_,d) -> (match args with | [] -> assert false (* A lambda cannot be a type. *) | a :: args -> extract_type env db j (subst1 a d) args) | Prod (n,t,d) -> assert (List.is_empty args); let env' = push_rel_assum (n,t) env in (match flag_of_type env t with | (Info, Default) -> (* Standard case: two [extract_type] ... *) let mld = extract_type env' (0::db) j d [] in (match expand env mld with | Tdummy d -> Tdummy d | _ -> Tarr (extract_type env db 0 t [], mld)) | (Info, TypeScheme) when j > 0 -> (* A new type var. *) let mld = extract_type env' (j::db) (j+1) d [] in (match expand env mld with | Tdummy d -> Tdummy d | _ -> Tarr (Tdummy Ktype, mld)) | _,lvl -> let mld = extract_type env' (0::db) j d [] in (match expand env mld with | Tdummy d -> Tdummy d | _ -> let reason = if lvl == TypeScheme then Ktype else Kprop in Tarr (Tdummy reason, mld))) | Sort _ -> Tdummy Ktype (* The two logical cases. *) | _ when sort_of env (applist (c, args)) == InProp -> Tdummy Kprop | Rel n -> (match lookup_rel n env with | LocalDef (_,t,_) -> extract_type env db j (lift n t) args | _ -> (* Asks [db] a translation for [n]. *) if n > List.length db then Tunknown else let n' = List.nth db (n-1) in if Int.equal n' 0 then Tunknown else Tvar n') | Const (kn,u as c) -> let r = ConstRef kn in let cb = lookup_constant kn env in let typ,_ = Typeops.type_of_constant env c in (match flag_of_type env typ with | (Logic,_) -> assert false (* Cf. logical cases above *) | (Info, TypeScheme) -> let mlt = extract_type_app env db (r, type_sign env typ) args in (match cb.const_body with | Undef _ | OpaqueDef _ -> mlt | Def _ when is_custom r -> mlt | Def lbody -> let newc = applist (Mod_subst.force_constr lbody, args) in let mlt' = extract_type env db j newc [] in (* ML type abbreviations interact badly with Coq *) (* reduction, so [mlt] and [mlt'] might be different: *) (* The more precise is [mlt'], extracted after reduction *) (* The shortest is [mlt], which use abbreviations *) (* If possible, we take [mlt], otherwise [mlt']. *) if eq_ml_type (expand env mlt) (expand env mlt') then mlt else mlt') | (Info, Default) -> (* Not an ML type, for example [(c:forall X, X->X) Type nat] *) (match cb.const_body with | Undef _ | OpaqueDef _ -> Tunknown (* Brutal approx ... *) | Def lbody -> (* We try to reduce. *) let newc = applist (Mod_subst.force_constr lbody, args) in extract_type env db j newc [])) | Ind ((kn,i),u) -> let s = (extract_ind env kn).ind_packets.(i).ip_sign in extract_type_app env db (IndRef (kn,i),s) args | Case _ | Fix _ | CoFix _ | Proj _ -> Tunknown | _ -> assert false (*s Auxiliary function dealing with type application. Precondition: [r] is a type scheme represented by the signature [s], and is completely applied: [List.length args = List.length s]. *) and extract_type_app env db (r,s) args = let ml_args = List.fold_right (fun (b,c) a -> if b == Keep then let p = List.length (fst (splay_prod env none (type_of env c))) in let db = iterate (fun l -> 0 :: l) p db in (extract_type_scheme env db c p) :: a else a) (List.combine s args) [] in Tglob (r, ml_args) (*S Extraction of a type scheme. *) (* [extract_type_scheme env db c p] works on a Coq term [c] which is an informative type scheme. It means that [c] is not a Coq type, but will be when applied to sufficiently many arguments ([p] in fact). This function decomposes p lambdas, with eta-expansion if needed. *) (* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *) and extract_type_scheme env db c p = if Int.equal p 0 then extract_type env db 0 c [] else let c = whd_betaiotazeta Evd.empty c in match kind_of_term c with | Lambda (n,t,d) -> extract_type_scheme (push_rel_assum (n,t) env) db d (p-1) | _ -> let rels = fst (splay_prod env none (type_of env c)) in let env = push_rels_assum rels env in let eta_args = List.rev_map mkRel (List.interval 1 p) in extract_type env db 0 (lift p c) eta_args (*S Extraction of an inductive type. *) (* First, a version with cache *) and extract_ind env kn = (* kn is supposed to be in long form *) let mib = Environ.lookup_mind kn env in match lookup_ind kn mib with | Some ml_ind -> ml_ind | None -> try extract_really_ind env kn mib with SingletonInductiveBecomesProp id -> (* TODO : which inductive is concerned in the block ? *) error_singleton_become_prop id (Some (IndRef (kn,0))) (* Then the real function *) and extract_really_ind env kn mib = (* First, if this inductive is aliased via a Module, we process the original inductive if possible. When at toplevel of the monolithic case, we cannot do much (cf Vector and bug #2570) *) let equiv = if lang () != Ocaml || (not (modular ()) && at_toplevel (mind_modpath kn)) || KerName.equal (canonical_mind kn) (user_mind kn) then NoEquiv else begin ignore (extract_ind env (mind_of_kn (canonical_mind kn))); Equiv (canonical_mind kn) end in (* Everything concerning parameters. *) (* We do that first, since they are common to all the [mib]. *) let mip0 = mib.mind_packets.(0) in let npar = mib.mind_nparams in let epar = push_rel_context mib.mind_params_ctxt env in (* First pass: we store inductive signatures together with *) (* their type var list. *) let packets = Array.mapi (fun i mip -> let (_,u),_ = Universes.fresh_inductive_instance env (kn,i) in let ar = Inductive.type_of_inductive env ((mib,mip),u) in let info = (fst (flag_of_type env ar) = Info) in let s,v = if info then type_sign_vl env ar else [],[] in let t = Array.make (Array.length mip.mind_nf_lc) [] in { ip_typename = mip.mind_typename; ip_consnames = mip.mind_consnames; ip_logical = not info; ip_sign = s; ip_vars = v; ip_types = t }, u) mib.mind_packets in add_ind kn mib {ind_kind = Standard; ind_nparams = npar; ind_packets = Array.map fst packets; ind_equiv = equiv }; (* Second pass: we extract constructors *) for i = 0 to mib.mind_ntypes - 1 do let p,u = packets.(i) in if not p.ip_logical then let types = arities_of_constructors env ((kn,i),u) in for j = 0 to Array.length types - 1 do let t = snd (decompose_prod_n npar types.(j)) in let prods,head = dest_prod epar t in let nprods = List.length prods in let args = match kind_of_term head with | App (f,args) -> args (* [kind_of_term f = Ind ip] *) | _ -> [||] in let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in let db = db_from_ind dbmap npar in p.ip_types.(j) <- extract_type_cons epar db dbmap t (npar+1) done done; (* Third pass: we determine special cases. *) let ind_info = try let ip = (kn, 0) in let r = IndRef ip in if is_custom r then raise (I Standard); if mib.mind_finite == Decl_kinds.CoFinite then raise (I Coinductive); if not (Int.equal mib.mind_ntypes 1) then raise (I Standard); let p,u = packets.(0) in if p.ip_logical then raise (I Standard); if not (Int.equal (Array.length p.ip_types) 1) then raise (I Standard); let typ = p.ip_types.(0) in let l = List.filter (fun t -> not (isTdummy (expand env t))) typ in if not (keep_singleton ()) && Int.equal (List.length l) 1 && not (type_mem_kn kn (List.hd l)) then raise (I Singleton); if List.is_empty l then raise (I Standard); if Option.is_empty mib.mind_record then raise (I Standard); (* Now we're sure it's a record. *) (* First, we find its field names. *) let rec names_prod t = match kind_of_term t with | Prod(n,_,t) -> n::(names_prod t) | LetIn(_,_,_,t) -> names_prod t | Cast(t,_,_) -> names_prod t | _ -> [] in let field_names = List.skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in assert (Int.equal (List.length field_names) (List.length typ)); let projs = ref Cset.empty in let mp = MutInd.modpath kn in let rec select_fields l typs = match l,typs with | [],[] -> [] | _::l, typ::typs when isTdummy (expand env typ) -> select_fields l typs | Anonymous::l, typ::typs -> None :: (select_fields l typs) | Name id::l, typ::typs -> let knp = Constant.make2 mp (Label.of_id id) in (* Is it safe to use [id] for projections [foo.id] ? *) if List.for_all ((==) Keep) (type2signature env typ) then projs := Cset.add knp !projs; Some (ConstRef knp) :: (select_fields l typs) | _ -> assert false in let field_glob = select_fields field_names typ in (* Is this record officially declared with its projections ? *) (* If so, we use this information. *) begin try let n = nb_default_params env (Inductive.type_of_inductive env ((mib,mip0),u)) in let check_proj kn = if Cset.mem kn !projs then add_projection n kn ip in List.iter (Option.iter check_proj) (lookup_projections ip) with Not_found -> () end; Record field_glob with (I info) -> info in let i = {ind_kind = ind_info; ind_nparams = npar; ind_packets = Array.map fst packets; ind_equiv = equiv } in add_ind kn mib i; add_inductive_kind kn i.ind_kind; i (*s [extract_type_cons] extracts the type of an inductive constructor toward the corresponding list of ML types. - [db] is a context for translating Coq [Rel] into ML type [Tvar] - [dbmap] is a translation map (produced by a call to [parse_in_args]) - [i] is the rank of the current product (initially [params_nb+1]) *) and extract_type_cons env db dbmap c i = match kind_of_term (whd_all env none c) with | Prod (n,t,d) -> let env' = push_rel_assum (n,t) env in let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in let l = extract_type_cons env' db' dbmap d (i+1) in (extract_type env db 0 t []) :: l | _ -> [] (*s Recording the ML type abbreviation of a Coq type scheme constant. *) and mlt_env env r = match r with | IndRef _ | ConstructRef _ | VarRef _ -> None | ConstRef kn -> let cb = Environ.lookup_constant kn env in match cb.const_body with | Undef _ | OpaqueDef _ -> None | Def l_body -> match lookup_typedef kn cb with | Some _ as o -> o | None -> let typ = Typeops.type_of_constant_type env cb.const_type (* FIXME not sure if we should instantiate univs here *) in match flag_of_type env typ with | Info,TypeScheme -> let body = Mod_subst.force_constr l_body in let s = type_sign env typ in let db = db_from_sign s in let t = extract_type_scheme env db body (List.length s) in add_typedef kn cb t; Some t | _ -> None and expand env = type_expand (mlt_env env) and type2signature env = type_to_signature (mlt_env env) let type2sign env = type_to_sign (mlt_env env) let type_expunge env = type_expunge (mlt_env env) let type_expunge_from_sign env = type_expunge_from_sign (mlt_env env) (*s Extraction of the type of a constant. *) let record_constant_type env kn opt_typ = let cb = lookup_constant kn env in match lookup_cst_type kn cb with | Some schema -> schema | None -> let typ = match opt_typ with | None -> Typeops.type_of_constant_type env cb.const_type | Some typ -> typ in let mlt = extract_type env [] 1 typ [] in let schema = (type_maxvar mlt, mlt) in let () = add_cst_type kn cb schema in schema (*S Extraction of a term. *) (* Precondition: [(c args)] is not a type scheme, and is informative. *) (* [mle] is a ML environment [Mlenv.t]. *) (* [mlt] is the ML type we want our extraction of [(c args)] to have. *) let rec extract_term env mle mlt c args = match kind_of_term c with | App (f,a) -> extract_term env mle mlt f (Array.to_list a @ args) | Lambda (n, t, d) -> let id = id_of_name n in (match args with | a :: l -> (* We make as many [LetIn] as possible. *) let d' = mkLetIn (Name id,a,t,applistc d (List.map (lift 1) l)) in extract_term env mle mlt d' [] | [] -> let env' = push_rel_assum (Name id, t) env in let id, a = try check_default env t; Id id, new_meta() with NotDefault d -> Dummy, Tdummy d in let b = new_meta () in (* If [mlt] cannot be unified with an arrow type, then magic! *) let magic = needs_magic (mlt, Tarr (a, b)) in let d' = extract_term env' (Mlenv.push_type mle a) b d [] in put_magic_if magic (MLlam (id, d'))) | LetIn (n, c1, t1, c2) -> let id = id_of_name n in let env' = push_rel (LocalDef (Name id, c1, t1)) env in (* We directly push the args inside the [LetIn]. TODO: the opt_let_app flag is supposed to prevent that *) let args' = List.map (lift 1) args in (try check_default env t1; let a = new_meta () in let c1' = extract_term env mle a c1 [] in (* The type of [c1'] is generalized and stored in [mle]. *) let mle' = if generalizable c1' then Mlenv.push_gen mle a else Mlenv.push_type mle a in MLletin (Id id, c1', extract_term env' mle' mlt c2 args') with NotDefault d -> let mle' = Mlenv.push_std_type mle (Tdummy d) in ast_pop (extract_term env' mle' mlt c2 args')) | Const (kn,_) -> extract_cst_app env mle mlt kn args | Construct (cp,_) -> extract_cons_app env mle mlt cp args | Proj (p, c) -> let term = Retyping.expand_projection env (Evd.from_env env) p c [] in extract_term env mle mlt term args | Rel n -> (* As soon as the expected [mlt] for the head is known, *) (* we unify it with an fresh copy of the stored type of [Rel n]. *) let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n) in extract_app env mle mlt extract_rel args | Case ({ci_ind=ip},_,c0,br) -> extract_app env mle mlt (extract_case env mle (ip,c0,br)) args | Fix ((_,i),recd) -> extract_app env mle mlt (extract_fix env mle i recd) args | CoFix (i,recd) -> extract_app env mle mlt (extract_fix env mle i recd) args | Cast (c,_,_) -> extract_term env mle mlt c args | Ind _ | Prod _ | Sort _ | Meta _ | Evar _ | Var _ -> assert false (*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *) and extract_maybe_term env mle mlt c = try check_default env (type_of env c); extract_term env mle mlt c [] with NotDefault d -> put_magic (mlt, Tdummy d) (MLdummy d) (*s Generic way to deal with an application. *) (* We first type all arguments starting with unknown meta types. This gives us the expected type of the head. Then we use the [mk_head] to produce the ML head from this type. *) and extract_app env mle mlt mk_head args = let metas = List.map new_meta args in let type_head = type_recomp (metas, mlt) in let mlargs = List.map2 (extract_maybe_term env mle) metas args in mlapp (mk_head type_head) mlargs (*s Auxiliary function used to extract arguments of constant or constructor. *) and make_mlargs env e s args typs = let rec f = function | [], [], _ -> [] | a::la, t::lt, [] -> extract_maybe_term env e t a :: (f (la,lt,[])) | a::la, t::lt, Keep::s -> extract_maybe_term env e t a :: (f (la,lt,s)) | _::la, _::lt, _::s -> f (la,lt,s) | _ -> assert false in f (args,typs,s) (*s Extraction of a constant applied to arguments. *) and extract_cst_app env mle mlt kn args = (* First, the [ml_schema] of the constant, in expanded version. *) let nb,t = record_constant_type env kn None in let schema = nb, expand env t in (* 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 then var2var' (snd schema) else instantiation schema in (* Then the expected type of this constant. *) let a = new_meta () in (* We compare stored and expected types in two steps. *) (* First, can [kn] be applied to all args ? *) let metas = List.map new_meta args in let magic1 = needs_magic (type_recomp (metas, a), instantiated) in (* Second, is the resulting type compatible with the expected type [mlt] ? *) let magic2 = needs_magic (a, mlt) in (* The internal head receives a magic if [magic1] *) let head = put_magic_if magic1 (MLglob (ConstRef kn)) in (* Now, the extraction of the arguments. *) let s_full = type2signature env (snd schema) in let s_full = sign_with_implicits (ConstRef kn) s_full 0 in let s = sign_no_final_keeps s_full in let ls = List.length s in let la = List.length args in (* The ml arguments, already expunged from known logical ones *) let mla = make_mlargs env mle s args metas in let mla = if magic1 || lang () != Ocaml then mla else try (* for better optimisations later, we discard dependent args of projections and replace them by fake args that will be removed during final pretty-print. *) let l,l' = List.chop (projection_arity (ConstRef kn)) mla in if not (List.is_empty l') then (List.map (fun _ -> MLexn "Proj Args") l) @ l' else mla with e when CErrors.noncritical e -> mla in (* For strict languages, purely logical signatures lead to a dummy lam (except when [Kill Ktype] everywhere). So a [MLdummy] is left accordingly. *) let optdummy = match sign_kind s_full with | UnsafeLogicalSig when lang () != Haskell -> [MLdummy Kprop] | _ -> [] in (* Different situations depending of the number of arguments: *) if la >= ls then (* Enough args, cleanup already done in [mla], we only add the additional dummy if needed. *) put_magic_if (magic2 && not magic1) (mlapp head (optdummy @ mla)) else (* Partially applied function with some logical arg missing. We complete via eta and expunge logical args. *) let ls' = ls-la in let s' = List.skipn la s in let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in let e = anonym_or_dummy_lams (mlapp head mla) s' in put_magic_if magic2 (remove_n_lams (List.length optdummy) e) (*s Extraction of an inductive constructor applied to arguments. *) (* \begin{itemize} \item In ML, constructor arguments are uncurryfied. \item We managed to suppress logical parts inside inductive definitions, but they must appears outside (for partial applications for instance) \item We also suppressed all Coq parameters to the inductives, since they are fixed, and thus are not used for the computation. \end{itemize} *) and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = (* First, we build the type of the constructor, stored in small pieces. *) let mi = extract_ind env kn in let params_nb = mi.ind_nparams in let oi = mi.ind_packets.(i) in let nb_tvars = List.length oi.ip_vars and types = List.map (expand env) oi.ip_types.(j-1) in let list_tvar = List.map (fun i -> Tvar i) (List.interval 1 nb_tvars) in let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in let type_cons = instantiation (nb_tvars, type_cons) in (* Then, the usual variables [s], [ls], [la], ... *) let s = List.map (type2sign env) types in let s = sign_with_implicits (ConstructRef cp) s params_nb in let ls = List.length s in let la = List.length args in assert (la <= ls + params_nb); let la' = max 0 (la - params_nb) in let args' = List.lastn la' args in (* Now, we build the expected type of the constructor *) let metas = List.map new_meta args' in (* If stored and expected types differ, then magic! *) let a = new_meta () in let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in let magic2 = needs_magic (a, mlt) in let head mla = if mi.ind_kind == Singleton then put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *) else let typeargs = match snd (type_decomp type_cons) with | Tglob (_,l) -> List.map type_simpl l | _ -> assert false in let typ = Tglob(IndRef ip, typeargs) in put_magic_if magic1 (MLcons (typ, ConstructRef cp, mla)) in (* Different situations depending of the number of arguments: *) if la < params_nb then let head' = head (eta_args_sign ls s) in put_magic_if magic2 (dummy_lams (anonym_or_dummy_lams head' s) (params_nb - la)) else let mla = make_mlargs env mle s args' metas in if Int.equal la (ls + params_nb) then put_magic_if (magic2 && not magic1) (head mla) else (* [ params_nb <= la <= ls + params_nb ] *) let ls' = params_nb + ls - la in let s' = List.lastn ls' s in let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in put_magic_if magic2 (anonym_or_dummy_lams (head mla) s') (*S Extraction of a case. *) and extract_case env mle ((kn,i) as ip,c,br) mlt = (* [br]: bodies of each branch (in functional form) *) (* [ni]: number of arguments without parameters in each branch *) let ni = constructors_nrealargs_env env ip in let br_size = Array.length br in assert (Int.equal (Array.length ni) br_size); if Int.equal br_size 0 then begin add_recursors env kn; (* May have passed unseen if logical ... *) MLexn "absurd case" end else (* [c] has an inductive type, and is not a type scheme type. *) let t = type_of env c in (* The only non-informative case: [c] is of sort [Prop] *) if (sort_of env t) == InProp then begin add_recursors env kn; (* May have passed unseen if logical ... *) (* Logical singleton case: *) (* [match c with C i j k -> t] becomes [t'] *) assert (Int.equal br_size 1); let s = iterate (fun l -> Kill Kprop :: l) ni.(0) [] in let mlt = iterate (fun t -> Tarr (Tdummy Kprop, t)) ni.(0) mlt in let e = extract_maybe_term env mle mlt br.(0) in snd (case_expunge s e) end else let mi = extract_ind env kn in let oi = mi.ind_packets.(i) in let metas = Array.init (List.length oi.ip_vars) new_meta in (* The extraction of the head. *) let type_head = Tglob (IndRef ip, Array.to_list metas) in let a = extract_term env mle type_head c [] in (* The extraction of each branch. *) let extract_branch i = let r = ConstructRef (ip,i+1) in (* The types of the arguments of the corresponding constructor. *) let f t = type_subst_vect metas (expand env t) in let l = List.map f oi.ip_types.(i) in (* the corresponding signature *) let s = List.map (type2sign env) oi.ip_types.(i) in let s = sign_with_implicits r s mi.ind_nparams in (* Extraction of the branch (in functional form). *) let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in (* We suppress dummy arguments according to signature. *) let ids,e = case_expunge s e in (List.rev ids, Pusual r, e) in if mi.ind_kind == Singleton then begin (* Informative singleton case: *) (* [match c with C i -> t] becomes [let i = c' in t'] *) assert (Int.equal br_size 1); let (ids,_,e') = extract_branch 0 in assert (Int.equal (List.length ids) 1); MLletin (tmp_id (List.hd ids),a,e') end else (* Standard case: we apply [extract_branch]. *) let typs = List.map type_simpl (Array.to_list metas) in let typ = Tglob (IndRef ip,typs) in MLcase (typ, a, Array.init br_size extract_branch) (*s Extraction of a (co)-fixpoint. *) and extract_fix env mle i (fi,ti,ci as recd) mlt = let env = push_rec_types recd env in let metas = Array.map new_meta fi in metas.(i) <- mlt; let mle = Array.fold_left Mlenv.push_type mle metas in let ei = Array.map2 (extract_maybe_term env mle) metas ci in MLfix (i, Array.map id_of_name fi, ei) (*S ML declarations. *) (* [decomp_lams_eta env c t] finds the number [n] of products in the type [t], and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *) let decomp_lams_eta_n n m env c t = let rels = fst (splay_prod_n env none n t) in let rels = List.map (fun (LocalAssum (id,c) | LocalDef (id,_,c)) -> (id,c)) rels in let rels',c = decompose_lam c in let d = n - m in (* we'd better keep rels' as long as possible. *) let rels = (List.firstn d rels) @ rels' in let eta_args = List.rev_map mkRel (List.interval 1 d) in rels, applist (lift d c,eta_args) (* Let's try to identify some situation where extracted code will allow generalisation of type variables *) let rec gentypvar_ok c = match kind_of_term c with | Lambda _ | Const _ -> true | App (c,v) -> (* if all arguments are variables, these variables will disappear after extraction (see [empty_s] below) *) Array.for_all isRel v && gentypvar_ok c | Cast (c,_,_) -> gentypvar_ok c | _ -> false (*s From a constant to a ML declaration. *) let extract_std_constant env kn body typ = reset_meta_count (); (* The short type [t] (i.e. possibly with abbreviations). *) let t = snd (record_constant_type env kn (Some typ)) in (* The real type [t']: without head products, expanded, *) (* and with [Tvar] translated to [Tvar'] (not instantiable). *) let l,t' = type_decomp (expand env (var2var' t)) in let s = List.map (type2sign env) l in (* Check for user-declared implicit information *) let s = sign_with_implicits (ConstRef kn) s 0 in (* Decomposing the top level lambdas of [body]. If there isn't enough, it's ok, as long as remaining args aren't to be pruned (and initial lambdas aren't to be all removed if the target language is strict). In other situations, eta-expansions create artificially enough lams (but that may break user's clever let-ins and partial applications). *) let rels, c = let n = List.length s and m = nb_lam body in if n <= m then decompose_lam_n n body else let s,s' = List.chop m s in if List.for_all ((==) Keep) s' && (lang () == Haskell || sign_kind s != UnsafeLogicalSig) then decompose_lam_n m body else decomp_lams_eta_n n m env body typ in (* Should we do one eta-expansion to avoid non-generalizable '_a ? *) let rels, c = let n = List.length rels in let s,s' = List.chop n s in let k = sign_kind s in let empty_s = (k == EmptySig || k == SafeLogicalSig) in if lang () == Ocaml && empty_s && not (gentypvar_ok c) && not (List.is_empty s') && not (Int.equal (type_maxvar t) 0) then decomp_lams_eta_n (n+1) n env body typ else rels,c in let n = List.length rels in let s = List.firstn n s in let l,l' = List.chop n l in let t' = type_recomp (l',t') in (* The initial ML environment. *) let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in (* The lambdas names. *) let ids = List.map (fun (n,_) -> Id (id_of_name n)) rels in (* The according Coq environment. *) let env = push_rels_assum rels env in (* The real extraction: *) let e = extract_term env mle t' c [] in (* Expunging term and type from dummy lambdas. *) let trm = term_expunge s (ids,e) in trm, type_expunge_from_sign env s t (* Extracts the type of an axiom, honors the Extraction Implicit declaration. *) let extract_axiom env kn typ = reset_meta_count (); (* The short type [t] (i.e. possibly with abbreviations). *) let t = snd (record_constant_type env kn (Some typ)) in (* The real type [t']: without head products, expanded, *) (* and with [Tvar] translated to [Tvar'] (not instantiable). *) let l,_ = type_decomp (expand env (var2var' t)) in let s = List.map (type2sign env) l in (* Check for user-declared implicit information *) let s = sign_with_implicits (ConstRef kn) s 0 in type_expunge_from_sign env s t let extract_fixpoint env vkn (fi,ti,ci) = let n = Array.length vkn in let types = Array.make n (Tdummy Kprop) and terms = Array.make n (MLdummy Kprop) in let kns = Array.to_list vkn in current_fixpoints := kns; (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *) let sub = List.rev_map mkConst kns in for i = 0 to n-1 do if sort_of env ti.(i) != InProp then try let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in terms.(i) <- e; types.(i) <- t; with SingletonInductiveBecomesProp id -> error_singleton_become_prop id (Some (ConstRef vkn.(i))) done; current_fixpoints := []; Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types) let extract_constant env kn cb = let r = ConstRef kn in let typ = Typeops.type_of_constant_type env cb.const_type in let warn_info () = if not (is_custom r) then add_info_axiom r in let warn_log () = if not (constant_has_body cb) then add_log_axiom r in let mk_typ_ax () = let n = type_scheme_nb_args env typ in let ids = iterate (fun l -> anonymous_name::l) n [] in Dtype (r, ids, Taxiom) in let mk_typ c = let s,vl = type_sign_vl env typ in let db = db_from_sign s in let t = extract_type_scheme env db c (List.length s) in Dtype (r, vl, t) in let mk_ax () = let t = extract_axiom env kn typ in Dterm (r, MLaxiom, t) in let mk_def c = let e,t = extract_std_constant env kn c typ in Dterm (r,e,t) in try match flag_of_type env typ with | (Logic,TypeScheme) -> warn_log (); Dtype (r, [], Tdummy Ktype) | (Logic,Default) -> warn_log (); Dterm (r, MLdummy Kprop, Tdummy Kprop) | (Info,TypeScheme) -> (match cb.const_body with | Undef _ -> warn_info (); mk_typ_ax () | Def c -> (match cb.const_proj with | None -> mk_typ (Mod_subst.force_constr c) | Some pb -> mk_typ pb.proj_body) | OpaqueDef c -> add_opaque r; if access_opaque () then mk_typ (Opaqueproof.force_proof (Environ.opaque_tables env) c) else mk_typ_ax ()) | (Info,Default) -> (match cb.const_body with | Undef _ -> warn_info (); mk_ax () | Def c -> (match cb.const_proj with | None -> mk_def (Mod_subst.force_constr c) | Some pb -> mk_def pb.proj_body) | OpaqueDef c -> add_opaque r; if access_opaque () then mk_def (Opaqueproof.force_proof (Environ.opaque_tables env) c) else mk_ax ()) with SingletonInductiveBecomesProp id -> error_singleton_become_prop id (Some (ConstRef kn)) let extract_constant_spec env kn cb = let r = ConstRef kn in let typ = Typeops.type_of_constant_type env cb.const_type in try match flag_of_type env typ with | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype)) | (Logic, Default) -> Sval (r, Tdummy Kprop) | (Info, TypeScheme) -> let s,vl = type_sign_vl env typ in (match cb.const_body with | Undef _ | OpaqueDef _ -> Stype (r, vl, None) | Def body -> let db = db_from_sign s in let body = Mod_subst.force_constr body in let t = extract_type_scheme env db body (List.length s) in Stype (r, vl, Some t)) | (Info, Default) -> let t = snd (record_constant_type env kn (Some typ)) in Sval (r, type_expunge env t) with SingletonInductiveBecomesProp id -> error_singleton_become_prop id (Some (ConstRef kn)) let extract_with_type env c = try let typ = type_of env c in match flag_of_type env typ with | (Info, TypeScheme) -> let s,vl = type_sign_vl env typ in let db = db_from_sign s in let t = extract_type_scheme env db c (List.length s) in Some (vl, t) | _ -> None with SingletonInductiveBecomesProp id -> error_singleton_become_prop id None let extract_constr env c = reset_meta_count (); try let typ = type_of env c in match flag_of_type env typ with | (_,TypeScheme) -> MLdummy Ktype, Tdummy Ktype | (Logic,_) -> MLdummy Kprop, Tdummy Kprop | (Info,Default) -> let mlt = extract_type env [] 1 typ [] in extract_term env Mlenv.empty mlt c [], mlt with SingletonInductiveBecomesProp id -> error_singleton_become_prop id None let extract_inductive env kn = let ind = extract_ind env kn in add_recursors env kn; let f i j l = let implicits = implicits_of_global (ConstructRef ((kn,i),j+1)) in let rec filter i = function | [] -> [] | t::l -> let l' = filter (succ i) l in if isTdummy (expand env t) || Int.Set.mem i implicits then l' else t::l' in filter (1+ind.ind_nparams) l in let packets = Array.mapi (fun i p -> { p with ip_types = Array.mapi (f i) p.ip_types }) ind.ind_packets in { ind with ind_packets = packets } (*s Is a [ml_decl] logical ? *) let logical_decl = function | Dterm (_,MLdummy _,Tdummy _) -> true | Dtype (_,[],Tdummy _) -> true | Dfix (_,av,tv) -> (Array.for_all isMLdummy av) && (Array.for_all isTdummy tv) | Dind (_,i) -> Array.for_all (fun ip -> ip.ip_logical) i.ind_packets | _ -> false (*s Is a [ml_spec] logical ? *) let logical_spec = function | Stype (_, [], Some (Tdummy _)) -> true | Sval (_,Tdummy _) -> true | Sind (_,i) -> Array.for_all (fun ip -> ip.ip_logical) i.ind_packets | _ -> false coq-8.6/plugins/extraction/ExtrOcamlZInt.v0000644000175000017500000000622713022274260020221 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int [ "(fun p->1+2*p)" "(fun p->2*p)" "1" ] "(fun f2p1 f2p f1 p -> if p<=1 then f1 () else if p mod 2 = 0 then f2p (p/2) else f2p1 (p/2))". Extract Inductive Z => int [ "0" "" "(~-)" ] "(fun f0 fp fn z -> if z=0 then f0 () else if z>0 then fp z else fn (-z))". Extract Inductive N => int [ "0" "" ] "(fun f0 fp n -> if n=0 then f0 () else fp n)". (** Nota: the "" above is used as an identity function "(fun p->p)" *) (** Efficient (but uncertified) versions for usual functions *) Extract Constant Pos.add => "(+)". Extract Constant Pos.succ => "Pervasives.succ". Extract Constant Pos.pred => "fun n -> Pervasives.max 1 (n-1)". Extract Constant Pos.sub => "fun n m -> Pervasives.max 1 (n-m)". Extract Constant Pos.mul => "( * )". Extract Constant Pos.min => "Pervasives.min". Extract Constant Pos.max => "Pervasives.max". Extract Constant Pos.compare => "fun x y -> if x=y then Eq else if x "fun c x y -> if x=y then c else if x "(+)". Extract Constant N.succ => "Pervasives.succ". Extract Constant N.pred => "fun n -> Pervasives.max 0 (n-1)". Extract Constant N.sub => "fun n m -> Pervasives.max 0 (n-m)". Extract Constant N.mul => "( * )". Extract Constant N.min => "Pervasives.min". Extract Constant N.max => "Pervasives.max". Extract Constant N.div => "fun a b -> if b=0 then 0 else a/b". Extract Constant N.modulo => "fun a b -> if b=0 then a else a mod b". Extract Constant N.compare => "fun x y -> if x=y then Eq else if x "(+)". Extract Constant Z.succ => "Pervasives.succ". Extract Constant Z.pred => "Pervasives.pred". Extract Constant Z.sub => "(-)". Extract Constant Z.mul => "( * )". Extract Constant Z.opp => "(~-)". Extract Constant Z.abs => "Pervasives.abs". Extract Constant Z.min => "Pervasives.min". Extract Constant Z.max => "Pervasives.max". Extract Constant Z.compare => "fun x y -> if x=y then Eq else if x "fun p -> p". Extract Constant Z.abs_N => "Pervasives.abs". (** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod). For the moment we don't even try *) coq-8.6/plugins/extraction/ExtrHaskellZNum.v0000644000175000017500000000154313022274260020552 0ustar mdenesmdenes(** * Efficient (but uncertified) extraction of usual [Z] functions * into equivalent versions in Haskell's Prelude that are defined * for any [Num] typeclass instances. Useful in combination with * [Extract Inductive Z] that maps [Z] onto a Haskell type that * implements [Num]. *) Require Import ZArith. Require Import EqNat. Extract Inlined Constant Z.add => "(Prelude.+)". Extract Inlined Constant Z.sub => "(Prelude.-)". Extract Inlined Constant Z.mul => "(Prelude.*)". Extract Inlined Constant Z.max => "Prelude.max". Extract Inlined Constant Z.min => "Prelude.min". Extract Inlined Constant Z_ge_lt_dec => "(Prelude.>=)". Extract Inlined Constant Z_gt_le_dec => "(Prelude.>)". Extract Constant Z.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". Extract Constant Z.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)". coq-8.6/plugins/extraction/extract_env.ml0000644000175000017500000005641013022274260020202 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let mp,_,l = repr_kn kn in begin match Libobject.object_tag o with | "CONSTANT" -> let constant = Global.lookup_constant (constant_of_kn kn) in Some (l, SFBconst constant) | "INDUCTIVE" -> let inductive = Global.lookup_mind (mind_of_kn kn) in Some (l, SFBmind inductive) | "MODULE" -> let modl = Global.lookup_module (MPdot (mp, l)) in Some (l, SFBmodule modl) | "MODULE TYPE" -> let modtype = Global.lookup_modtype (MPdot (mp, l)) in Some (l, SFBmodtype modtype) | "INCLUDE" -> error "No extraction of toplevel Include yet." | _ -> None end | _ -> None in List.rev (List.map_filter get_reference (Lib.contents ())) let environment_until dir_opt = let rec parse = function | [] when Option.is_empty dir_opt -> [Lib.current_mp (), toplevel_env ()] | [] -> [] | d :: l -> let meb = Modops.destr_nofunctor (Global.lookup_module (MPfile d)).mod_type in match dir_opt with | Some d' when DirPath.equal d d' -> [MPfile d, meb] | _ -> (MPfile d, meb) :: (parse l) in parse (Library.loaded_libraries ()) (*s Visit: a structure recording the needed dependencies for the current extraction *) module type VISIT = sig (* Reset the dependencies by emptying the visit lists *) val reset : unit -> unit (* Add the module_path and all its prefixes to the mp visit list. We'll keep all fields of these modules. *) val add_mp_all : module_path -> unit (* Add reference / ... in the visit lists. These functions silently add the mp of their arg in the mp list *) val add_ref : global_reference -> unit val add_kn : kernel_name -> unit val add_decl_deps : ml_decl -> unit val add_spec_deps : ml_spec -> unit (* Test functions: is a particular object a needed dependency for the current extraction ? *) val needed_ind : mutual_inductive -> bool val needed_cst : constant -> bool val needed_mp : module_path -> bool val needed_mp_all : module_path -> bool end module Visit : VISIT = struct type must_visit = { mutable kn : KNset.t; mutable mp : MPset.t; mutable mp_all : MPset.t } (* the imperative internal visit lists *) let v = { kn = KNset.empty; mp = MPset.empty; mp_all = MPset.empty } (* the accessor functions *) let reset () = v.kn <- KNset.empty; v.mp <- MPset.empty; v.mp_all <- MPset.empty let needed_ind i = KNset.mem (user_mind i) v.kn let needed_cst c = KNset.mem (user_con c) v.kn let needed_mp mp = MPset.mem mp v.mp || MPset.mem mp v.mp_all let needed_mp_all mp = MPset.mem mp v.mp_all let add_mp mp = check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp let add_mp_all mp = check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp; v.mp_all <- MPset.add mp v.mp_all let add_kn kn = v.kn <- KNset.add kn v.kn; add_mp (modpath kn) let add_ref = function | ConstRef c -> add_kn (user_con c) | IndRef (ind,_) | ConstructRef ((ind,_),_) -> add_kn (user_mind ind) | VarRef _ -> assert false let add_decl_deps = decl_iter_references add_ref add_ref add_ref let add_spec_deps = spec_iter_references add_ref add_ref add_ref end let add_field_label mp = function | (lab, (SFBconst _|SFBmind _)) -> Visit.add_kn (KerName.make2 mp lab) | (lab, (SFBmodule _|SFBmodtype _)) -> Visit.add_mp_all (MPdot (mp,lab)) let rec add_labels mp = function | MoreFunctor (_,_,m) -> add_labels mp m | NoFunctor sign -> List.iter (add_field_label mp) sign exception Impossible let check_arity env cb = let t = Typeops.type_of_constant_type env cb.const_type in if Reduction.is_arity env t then raise Impossible let check_fix env cb i = match cb.const_body with | Def lbody -> (match kind_of_term (Mod_subst.force_constr lbody) with | Fix ((_,j),recd) when Int.equal i j -> check_arity env cb; (true,recd) | CoFix (j,recd) when Int.equal i j -> check_arity env cb; (false,recd) | _ -> raise Impossible) | Undef _ | OpaqueDef _ -> raise Impossible let prec_declaration_equal (na1, ca1, ta1) (na2, ca2, ta2) = Array.equal Name.equal na1 na2 && Array.equal eq_constr ca1 ca2 && Array.equal eq_constr ta1 ta2 let factor_fix env l cb msb = let _,recd as check = check_fix env cb 0 in let n = Array.length (let fi,_,_ = recd in fi) in if Int.equal n 1 then [|l|], recd, msb else begin if List.length msb < n-1 then raise Impossible; let msb', msb'' = List.chop (n-1) msb in let labels = Array.make n l in List.iteri (fun j -> function | (l,SFBconst cb') -> let check' = check_fix env cb' (j+1) in if not ((fst check : bool) == (fst check') && prec_declaration_equal (snd check) (snd check')) then raise Impossible; labels.(j+1) <- l; | _ -> raise Impossible) msb'; labels, recd, msb'' end (** Expanding a [module_alg_expr] into a version without abbreviations or functor applications. This is done via a detour to entries (hack proposed by Elie) *) let expand_mexpr env mp me = let inl = Some (Flags.get_inline_level()) in Mod_typing.translate_mse env (Some mp) inl me (** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def]. To check with Elie. *) let rec mp_of_mexpr = function | MEident mp -> mp | MEwith (seb,_) -> mp_of_mexpr seb | _ -> assert false let no_delta = Mod_subst.empty_delta_resolver let env_for_mtb_with_def env mp me idl = let struc = Modops.destr_nofunctor me in let l = Label.of_id (List.hd idl) in let spot = function (l',SFBconst _) -> Label.equal l l' | _ -> false in let before = fst (List.split_when spot struc) in Modops.add_structure mp before no_delta env let make_cst resolver mp l = Mod_subst.constant_of_delta_kn resolver (KerName.make2 mp l) let make_mind resolver mp l = Mod_subst.mind_of_delta_kn resolver (KerName.make2 mp l) (* From a [structure_body] (i.e. a list of [structure_field_body]) to specifications. *) let rec extract_structure_spec env mp reso = function | [] -> [] | (l,SFBconst cb) :: msig -> let c = make_cst reso mp l in let s = extract_constant_spec env c cb in let specs = extract_structure_spec env mp reso msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmind _) :: msig -> let mind = make_mind reso mp l in let s = Sind (mind, extract_inductive env mind) in let specs = extract_structure_spec env mp reso msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmodule mb) :: msig -> let specs = extract_structure_spec env mp reso msig in let spec = extract_mbody_spec env mb.mod_mp mb in (l,Smodule spec) :: specs | (l,SFBmodtype mtb) :: msig -> let specs = extract_structure_spec env mp reso msig in let spec = extract_mbody_spec env mtb.mod_mp mtb in (l,Smodtype spec) :: specs (* From [module_expression] to specifications *) (* Invariant: the [me_alg] given to [extract_mexpr_spec] and [extract_mexpression_spec] should come from a [mod_type_alg] field. This way, any encountered [MEident] should be a true module type. *) and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with | MEident mp -> Visit.add_mp_all mp; MTident mp | MEwith(me',WithDef(idl,(c,ctx)))-> let env' = env_for_mtb_with_def env (mp_of_mexpr me') me_struct idl in let mt = extract_mexpr_spec env mp1 (me_struct,me') in (match extract_with_type env' c with (* cb may contain some kn *) | None -> mt | Some (vl,typ) -> MTwith(mt,ML_With_type(idl,vl,typ))) | MEwith(me',WithMod(idl,mp))-> Visit.add_mp_all mp; MTwith(extract_mexpr_spec env mp1 (me_struct,me'), ML_With_module(idl,mp)) | MEapply _ -> (* No higher-order module type in OCaml : we use the expanded version *) extract_msignature_spec env mp1 no_delta (*TODO*) me_struct and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with | MoreFunctor (mbid, mtb, me_alg') -> let me_struct' = match me_struct with | MoreFunctor (mbid',_,me') when MBId.equal mbid' mbid -> me' | _ -> assert false in let mp = MPbound mbid in let env' = Modops.add_module_type mp mtb env in MTfunsig (mbid, extract_mbody_spec env mp mtb, extract_mexpression_spec env' mp1 (me_struct',me_alg')) | NoFunctor m -> extract_mexpr_spec env mp1 (me_struct,m) and extract_msignature_spec env mp1 reso = function | NoFunctor struc -> let env' = Modops.add_structure mp1 struc reso env in MTsig (mp1, extract_structure_spec env' mp1 reso struc) | MoreFunctor (mbid, mtb, me) -> let mp = MPbound mbid in let env' = Modops.add_module_type mp mtb env in MTfunsig (mbid, extract_mbody_spec env mp mtb, extract_msignature_spec env' mp1 reso me) and extract_mbody_spec env mp mb = match mb.mod_type_alg with | Some ty -> extract_mexpression_spec env mp (mb.mod_type,ty) | None -> extract_msignature_spec env mp mb.mod_delta mb.mod_type (* From a [structure_body] (i.e. a list of [structure_field_body]) to implementations. NB: when [all=false], the evaluation order of the list is important: last to first ensures correct dependencies. *) let rec extract_structure env mp reso ~all = function | [] -> [] | (l,SFBconst cb) :: struc -> (try let vl,recd,struc = factor_fix env l cb struc in let vc = Array.map (make_cst reso mp) vl in let ms = extract_structure env mp reso ~all struc in let b = Array.exists Visit.needed_cst vc in if all || b then let d = extract_fixpoint env vc recd in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms with Impossible -> let ms = extract_structure env mp reso ~all struc in let c = make_cst reso mp l in let b = Visit.needed_cst c in if all || b then let d = extract_constant env c cb in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms) | (l,SFBmind mib) :: struc -> let ms = extract_structure env mp reso ~all struc in let mind = make_mind reso mp l in let b = Visit.needed_ind mind in if all || b then let d = Dind (mind, extract_inductive env mind) in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms | (l,SFBmodule mb) :: struc -> let ms = extract_structure env mp reso ~all struc in let mp = MPdot (mp,l) in let all' = all || Visit.needed_mp_all mp in if all' || Visit.needed_mp mp then (l,SEmodule (extract_module env mp ~all:all' mb)) :: ms else ms | (l,SFBmodtype mtb) :: struc -> let ms = extract_structure env mp reso ~all struc in let mp = MPdot (mp,l) in if all || Visit.needed_mp mp then (l,SEmodtype (extract_mbody_spec env mp mtb)) :: ms else ms (* From [module_expr] and [module_expression] to implementations *) and extract_mexpr env mp = function | MEwith _ -> assert false (* no 'with' syntax for modules *) | me when lang () != Ocaml -> (* In Haskell/Scheme, we expand everything. For now, we also extract everything, dead code will be removed later (see [Modutil.optimize_struct]. *) let sign,_,delta,_ = expand_mexpr env mp me in extract_msignature env mp delta ~all:true sign | MEident mp -> if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; Visit.add_mp_all mp; Miniml.MEident mp | MEapply (me, arg) -> Miniml.MEapply (extract_mexpr env mp me, extract_mexpr env mp (MEident arg)) and extract_mexpression env mp = function | NoFunctor me -> extract_mexpr env mp me | MoreFunctor (mbid, mtb, me) -> let mp1 = MPbound mbid in let env' = Modops.add_module_type mp1 mtb env in Miniml.MEfunctor (mbid, extract_mbody_spec env mp1 mtb, extract_mexpression env' mp me) and extract_msignature env mp reso ~all = function | NoFunctor struc -> let env' = Modops.add_structure mp struc reso env in Miniml.MEstruct (mp,extract_structure env' mp reso ~all struc) | MoreFunctor (mbid, mtb, me) -> let mp1 = MPbound mbid in let env' = Modops.add_module_type mp1 mtb env in Miniml.MEfunctor (mbid, extract_mbody_spec env mp1 mtb, extract_msignature env' mp reso ~all me) and extract_module env mp ~all mb = (* A module has an empty [mod_expr] when : - it is a module variable (for instance X inside a Module F [X:SIG]) - it is a module assumption (Declare Module). Since we look at modules from outside, we shouldn't have variables. But a Declare Module at toplevel seems legal (cf #2525). For the moment we don't support this situation. *) let impl = match mb.mod_expr with | Abstract -> error_no_module_expr mp | Algebraic me -> extract_mexpression env mp me | Struct sign -> (* This module has a signature, otherwise it would be FullStruct. We extract just the elements required by this signature. *) let () = add_labels mp mb.mod_type in extract_msignature env mp mb.mod_delta ~all:false sign | FullStruct -> extract_msignature env mp mb.mod_delta ~all mb.mod_type in (* Slight optimization: for modules without explicit signatures ([FullStruct] case), we build the type out of the extracted implementation *) let typ = match mb.mod_expr with | FullStruct -> assert (Option.is_empty mb.mod_type_alg); mtyp_of_mexpr impl | _ -> extract_mbody_spec env mp mb in { ml_mod_expr = impl; ml_mod_type = typ } let mono_environment refs mpl = Visit.reset (); List.iter Visit.add_ref refs; List.iter Visit.add_mp_all mpl; let env = Global.env () in let l = List.rev (environment_until None) in List.rev_map (fun (mp,struc) -> mp, extract_structure env mp no_delta ~all:(Visit.needed_mp_all mp) struc) l (**************************************) (*S Part II : Input/Output primitives *) (**************************************) let descr () = match lang () with | Ocaml -> Ocaml.ocaml_descr | Haskell -> Haskell.haskell_descr | Scheme -> Scheme.scheme_descr | JSON -> Json.json_descr (* From a filename string "foo.ml" or "foo", builds "foo.ml" and "foo.mli" Works similarly for the other languages. *) let default_id = Id.of_string "Main" let mono_filename f = let d = descr () in match f with | None -> None, None, default_id | Some f -> let f = if Filename.check_suffix f d.file_suffix then Filename.chop_suffix f d.file_suffix else f in let id = if lang () != Haskell then default_id else try Id.of_string (Filename.basename f) with UserError _ -> error "Extraction: provided filename is not a valid identifier" in Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id (* Builds a suitable filename from a module id *) let module_filename mp = let f = file_of_modfile mp in let d = descr () in let p = d.file_naming mp ^ d.file_suffix in Some p, Option.map ((^) f) d.sig_suffix, Id.of_string f (*s Extraction of one decl to stdout. *) let print_one_decl struc mp decl = let d = descr () in reset_renaming_tables AllButExternal; set_phase Pre; ignore (d.pp_struct struc); set_phase Impl; push_visible mp []; let ans = d.pp_decl decl in pop_visible (); v 0 ans (*s Extraction of a ml struct to a file. *) (** For Recursive Extraction, writing directly on stdout won't work with coqide, we use a buffer instead *) let buf = Buffer.create 1000 let formatter dry file = let ft = if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) else match file with | Some f -> Pp_control.with_output_to f | None -> Format.formatter_of_buffer buf in (* We never want to see ellipsis ... in extracted code *) Format.pp_set_max_boxes ft max_int; (* We reuse the width information given via "Set Printing Width" *) (match Pp_control.get_margin () with | None -> () | Some i -> Format.pp_set_margin ft i; Format.pp_set_max_indent ft (i-10)); (* note: max_indent should be < margin above, otherwise it's ignored *) ft let get_comment () = let s = file_comment () in if String.is_empty s then None else let split_comment = Str.split (Str.regexp "[ \t\n]+") s in Some (prlist_with_sep spc str split_comment) let print_structure_to_file (fn,si,mo) dry struc = Buffer.clear buf; let d = descr () in reset_renaming_tables AllButExternal; let unsafe_needs = { mldummy = struct_ast_search Mlutil.isMLdummy struc; tdummy = struct_type_search Mlutil.isTdummy struc; tunknown = struct_type_search ((==) Tunknown) struc; magic = if lang () != Haskell then false else struct_ast_search (function MLmagic _ -> true | _ -> false) struc } in (* First, a dry run, for computing objects to rename or duplicate *) set_phase Pre; let devnull = formatter true None in pp_with devnull (d.pp_struct struc); let opened = opened_libraries () in (* Print the implementation *) let cout = if dry then None else Option.map open_out fn in let ft = formatter dry cout in let comment = get_comment () in begin try (* The real printing of the implementation *) set_phase Impl; pp_with ft (d.preamble mo comment opened unsafe_needs); pp_with ft (d.pp_struct struc); Option.iter close_out cout; with reraise -> Option.iter close_out cout; raise reraise end; if not dry then Option.iter info_file fn; (* Now, let's print the signature *) Option.iter (fun si -> let cout = open_out si in let ft = formatter false (Some cout) in begin try set_phase Intf; pp_with ft (d.sig_preamble mo comment opened unsafe_needs); pp_with ft (d.pp_sig (signature_of_structure struc)); close_out cout; with reraise -> close_out cout; raise reraise end; info_file si) (if dry then None else si); (* Print the buffer content via Coq standard formatter (ok with coqide). *) if not (Int.equal (Buffer.length buf) 0) then begin Feedback.msg_notice (str (Buffer.contents buf)); Buffer.reset buf end (*********************************************) (*s Part III: the actual extraction commands *) (*********************************************) let reset () = Visit.reset (); reset_tables (); reset_renaming_tables Everything let init modular library = check_inside_section (); check_inside_module (); set_keywords (descr ()).keywords; set_modular modular; set_library library; reset (); if modular && lang () == Scheme then error_scheme () let warns () = warning_opaques (access_opaque ()); warning_axioms () (* From a list of [reference], let's retrieve whether they correspond to modules or [global_reference]. Warn the user if both is possible. *) let rec locate_ref = function | [] -> [],[] | r::l -> let q = snd (qualid_of_reference r) in let mpo = try Some (Nametab.locate_module q) with Not_found -> None and ro = try Some (Smartlocate.global_with_alias r) with Nametab.GlobalizationError _ | UserError _ -> None in match mpo, ro with | None, None -> Nametab.error_global_not_found q | None, Some r -> let refs,mps = locate_ref l in r::refs,mps | Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps | Some mp, Some r -> warning_ambiguous_name (q,mp,r); let refs,mps = locate_ref l in refs,mp::mps (*s Recursive extraction in the Coq toplevel. The vernacular command is \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when extracting to a file with the command: \verb!Extraction "file"! [qualid1] ... [qualidn]. *) let full_extr f (refs,mps) = init false false; List.iter (fun mp -> if is_modfile mp then error_MPfile_as_mod mp true) mps; let struc = optimize_struct (refs,mps) (mono_environment refs mps) in warns (); print_structure_to_file (mono_filename f) false struc; reset () let full_extraction f lr = full_extr f (locate_ref lr) (*s Separate extraction is similar to recursive extraction, with the output decomposed in many files, one per Coq .v file *) let separate_extraction lr = init true false; let refs,mps = locate_ref lr in let struc = optimize_struct (refs,mps) (mono_environment refs mps) in warns (); let print = function | (MPfile dir as mp, sel) as e -> print_structure_to_file (module_filename mp) false [e] | _ -> assert false in List.iter print struc; reset () (*s Simple extraction in the Coq toplevel. The vernacular command is \verb!Extraction! [qualid]. *) let simple_extraction r = Vernacentries.dump_global (Misctypes.AN r); match locate_ref [r] with | ([], [mp]) as p -> full_extr None p | [r],[] -> init false false; let struc = optimize_struct ([r],[]) (mono_environment [r] []) in let d = get_decl_in_structure r struc in warns (); let flag = if is_custom r then str "(** User defined extraction *)" ++ fnl() else mt () in let ans = flag ++ print_one_decl struc (modpath_of_r r) d in reset (); Feedback.msg_notice ans | _ -> assert false (*s (Recursive) Extraction of a library. The vernacular command is \verb!(Recursive) Extraction Library! [M]. *) let extraction_library is_rec m = init true true; let dir_m = let q = qualid_of_ident m in try Nametab.full_name_module q with Not_found -> error_unknown_module q in Visit.add_mp_all (MPfile dir_m); let env = Global.env () in let l = List.rev (environment_until (Some dir_m)) in let select l (mp,struc) = if Visit.needed_mp mp then (mp, extract_structure env mp no_delta true struc) :: l else l in let struc = List.fold_left select [] l in let struc = optimize_struct ([],[]) struc in warns (); let print = function | (MPfile dir as mp, sel) as e -> let dry = not is_rec && not (DirPath.equal dir dir_m) in print_structure_to_file (module_filename mp) dry [e] | _ -> assert false in List.iter print struc; reset () let structure_for_compute c = init false false; let env = Global.env () in let ast, mlt = Extraction.extract_constr env c in let ast = Mlutil.normalize ast in let refs = ref Refset.empty in let add_ref r = refs := Refset.add r !refs in let () = ast_iter_references add_ref add_ref add_ref ast in let refs = Refset.elements !refs in let struc = optimize_struct (refs,[]) (mono_environment refs []) in let flatstruc = List.map snd (List.flatten (List.map snd struc)) in flatstruc, ast, mlt coq-8.6/plugins/extraction/json.ml0000644000175000017500000001764713022274260016642 0ustar mdenesmdenesopen Pp open Util open Names open Globnames open Table open Miniml open Mlutil open Common let json_str s = qs s let json_int i = int i let json_bool b = if b then str "true" else str "false" let json_global typ ref = json_str (Common.pp_global typ ref) let json_id id = json_str (Id.to_string id) let json_dict_one (k, v) = json_str k ++ str (": ") ++ v let json_dict_open l = str ("{") ++ fnl () ++ str (" ") ++ hov 0 (prlist_with_sep pr_comma json_dict_one l) let json_dict l = json_dict_open l ++ fnl () ++ str ("}") let json_list l = str ("[") ++ fnl () ++ str (" ") ++ hov 0 (prlist_with_sep pr_comma (fun x -> x) l) ++ fnl () ++ str ("]") let json_listarr a = str ("[") ++ fnl () ++ str (" ") ++ hov 0 (prvect_with_sep pr_comma (fun x -> x) a) ++ fnl () ++ str ("]") let preamble mod_name comment used_modules usf = (match comment with | None -> mt () | Some s -> str "/* " ++ hov 0 s ++ str " */" ++ fnl ()) ++ json_dict_open [ ("what", json_str "module"); ("name", json_id mod_name); ("need_magic", json_bool (usf.magic)); ("need_dummy", json_bool (usf.mldummy)); ("used_modules", json_list (List.map (fun mf -> json_str (file_of_modfile mf)) used_modules)) ] (*s Pretty-printing of types. *) let rec json_type vl = function | Tmeta _ | Tvar' _ -> assert false | Tvar i -> (try let varid = List.nth vl (pred i) in json_dict [ ("what", json_str "type:var"); ("name", json_id varid) ] with Failure _ -> json_dict [ ("what", json_str "type:varidx"); ("name", json_int i) ]) | Tglob (r, l) -> json_dict [ ("what", json_str "type:glob"); ("name", json_global Type r); ("args", json_list (List.map (json_type vl) l)) ] | Tarr (t1,t2) -> json_dict [ ("what", json_str "type:arrow"); ("left", json_type vl t1); ("right", json_type vl t2) ] | Tdummy _ -> json_dict [("what", json_str "type:dummy")] | Tunknown -> json_dict [("what", json_str "type:unknown")] | Taxiom -> json_dict [("what", json_str "type:axiom")] (*s Pretty-printing of expressions. *) let rec json_expr env = function | MLrel n -> json_dict [ ("what", json_str "expr:rel"); ("name", json_id (get_db_name n env)) ] | MLapp (f, args) -> json_dict [ ("what", json_str "expr:apply"); ("func", json_expr env f); ("args", json_list (List.map (json_expr env) args)) ] | MLlam _ as a -> let fl, a' = collect_lams a in let fl, env' = push_vars (List.map id_of_mlid fl) env in json_dict [ ("what", json_str "expr:lambda"); ("argnames", json_list (List.map json_id (List.rev fl))); ("body", json_expr env' a') ] | MLletin (id, a1, a2) -> let i, env' = push_vars [id_of_mlid id] env in json_dict [ ("what", json_str "expr:let"); ("name", json_id (List.hd i)); ("nameval", json_expr env a1); ("body", json_expr env' a2) ] | MLglob r -> json_dict [ ("what", json_str "expr:global"); ("name", json_global Term r) ] | MLcons (_, r, a) -> json_dict [ ("what", json_str "expr:constructor"); ("name", json_global Cons r); ("args", json_list (List.map (json_expr env) a)) ] | MLtuple l -> json_dict [ ("what", json_str "expr:tuple"); ("items", json_list (List.map (json_expr env) l)) ] | MLcase (typ, t, pv) -> json_dict [ ("what", json_str "expr:case"); ("expr", json_expr env t); ("cases", json_listarr (Array.map (fun x -> json_one_pat env x) pv)) ] | MLfix (i, ids, defs) -> let ids', env' = push_vars (List.rev (Array.to_list ids)) env in let ids' = Array.of_list (List.rev ids') in json_dict [ ("what", json_str "expr:fix"); ("funcs", json_listarr (Array.map (fun (fi, ti) -> json_dict [ ("what", json_str "fix:item"); ("name", json_id fi); ("body", json_function env' ti) ]) (Array.map2 (fun a b -> a,b) ids' defs))); ("for", json_int i); ] | MLexn s -> json_dict [ ("what", json_str "expr:exception"); ("msg", json_str s) ] | MLdummy _ -> json_dict [("what", json_str "expr:dummy")] | MLmagic a -> json_dict [ ("what", json_str "expr:coerce"); ("value", json_expr env a) ] | MLaxiom -> json_dict [("what", json_str "expr:axiom")] and json_one_pat env (ids,p,t) = let ids', env' = push_vars (List.rev_map id_of_mlid ids) env in json_dict [ ("what", json_str "case"); ("pat", json_gen_pat (List.rev ids') env' p); ("body", json_expr env' t) ] and json_gen_pat ids env = function | Pcons (r, l) -> json_cons_pat r (List.map (json_gen_pat ids env) l) | Pusual r -> json_cons_pat r (List.map json_id ids) | Ptuple l -> json_dict [ ("what", json_str "pat:tuple"); ("items", json_list (List.map (json_gen_pat ids env) l)) ] | Pwild -> json_dict [("what", json_str "pat:wild")] | Prel n -> json_dict [ ("what", json_str "pat:rel"); ("name", json_id (get_db_name n env)) ] and json_cons_pat r ppl = json_dict [ ("what", json_str "pat:constructor"); ("name", json_global Cons r); ("argnames", json_list ppl) ] and json_function env t = let bl, t' = collect_lams t in let bl, env' = push_vars (List.map id_of_mlid bl) env in json_dict [ ("what", json_str "expr:lambda"); ("argnames", json_list (List.map json_id (List.rev bl))); ("body", json_expr env' t') ] (*s Pretty-printing of inductive types declaration. *) let json_ind ip pl cv = json_dict [ ("what", json_str "decl:ind"); ("name", json_global Type (IndRef ip)); ("argnames", json_list (List.map json_id pl)); ("constructors", json_listarr (Array.mapi (fun idx c -> json_dict [ ("name", json_global Cons (ConstructRef (ip, idx+1))); ("argtypes", json_list (List.map (json_type pl) c)) ]) cv)) ] (*s Pretty-printing of a declaration. *) let pp_decl = function | Dind (kn, defs) -> prvecti_with_sep pr_comma (fun i p -> if p.ip_logical then str "" else json_ind (kn, i) p.ip_vars p.ip_types) defs.ind_packets | Dtype (r, l, t) -> json_dict [ ("what", json_str "decl:type"); ("name", json_global Type r); ("argnames", json_list (List.map json_id l)); ("value", json_type l t) ] | Dfix (rv, defs, typs) -> json_dict [ ("what", json_str "decl:fixgroup"); ("fixlist", json_listarr (Array.mapi (fun i r -> json_dict [ ("what", json_str "fixgroup:item"); ("name", json_global Term rv.(i)); ("type", json_type [] typs.(i)); ("value", json_function (empty_env ()) defs.(i)) ]) rv)) ] | Dterm (r, a, t) -> json_dict [ ("what", json_str "decl:term"); ("name", json_global Term r); ("type", json_type [] t); ("value", json_function (empty_env ()) a) ] let rec pp_structure_elem = function | (l,SEdecl d) -> [ pp_decl d ] | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr | (l,SEmodtype m) -> [] (* for the moment we simply discard module type *) and pp_module_expr = function | MEstruct (mp,sel) -> List.concat (List.map pp_structure_elem sel) | MEfunctor _ -> [] (* for the moment we simply discard unapplied functors *) | MEident _ | MEapply _ -> assert false (* should be expansed in extract_env *) let pp_struct mls = let pp_sel (mp,sel) = push_visible mp []; let p = prlist_with_sep pr_comma identity (List.concat (List.map pp_structure_elem sel)) in pop_visible (); p in str "," ++ fnl () ++ str " " ++ qs "declarations" ++ str ": [" ++ fnl () ++ str " " ++ hov 0 (prlist_with_sep pr_comma pp_sel mls) ++ fnl () ++ str " ]" ++ fnl () ++ str "}" ++ fnl () let json_descr = { keywords = Id.Set.empty; file_suffix = ".json"; file_naming = file_of_modfile; preamble = preamble; pp_struct = pp_struct; sig_suffix = None; sig_preamble = (fun _ _ _ _ -> mt ()); pp_sig = (fun _ -> mt ()); pp_decl = pp_decl; } coq-8.6/plugins/extraction/table.mli0000644000175000017500000001603513022274260017117 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Id.t (*s Warning and Error messages. *) val warning_axioms : unit -> unit val warning_opaques : bool -> unit val warning_ambiguous_name : ?loc:Loc.t -> qualid * module_path * global_reference -> unit val warning_id : string -> unit val error_axiom_scheme : global_reference -> int -> 'a val error_constant : global_reference -> 'a val error_inductive : global_reference -> 'a val error_nb_cons : unit -> 'a val error_module_clash : module_path -> module_path -> 'a val error_no_module_expr : module_path -> 'a val error_singleton_become_prop : Id.t -> global_reference option -> 'a val error_unknown_module : qualid -> 'a val error_scheme : unit -> 'a val error_not_visible : global_reference -> 'a val error_MPfile_as_mod : module_path -> bool -> 'a val check_inside_module : unit -> unit val check_inside_section : unit -> unit val check_loaded_modfile : module_path -> unit val msg_of_implicit : kill_reason -> string val err_or_warn_remaining_implicit : kill_reason -> unit val info_file : string -> unit (*s utilities about [module_path] and [kernel_names] and [global_reference] *) val occur_kn_in_ref : mutual_inductive -> global_reference -> bool val repr_of_r : global_reference -> module_path * DirPath.t * Label.t val modpath_of_r : global_reference -> module_path val label_of_r : global_reference -> Label.t val base_mp : module_path -> module_path val is_modfile : module_path -> bool val string_of_modfile : module_path -> string val file_of_modfile : module_path -> string val is_toplevel : module_path -> bool val at_toplevel : module_path -> bool val mp_length : module_path -> int val prefixes_mp : module_path -> MPset.t val common_prefix_from_list : module_path -> module_path list -> module_path option val get_nth_label_mp : int -> module_path -> Label.t val labels_of_ref : global_reference -> module_path * Label.t list (*s Some table-related operations *) (* For avoiding repeated extraction of the same constant or inductive, we use cache functions below. Indexing by constant name isn't enough, due to modules we could have a same constant name but different content. So we check that the [constant_body] hasn't changed from recording time to retrieving time. Same for inductive : we store [mutual_inductive_body] as checksum. In both case, we should ideally also check the env *) val add_typedef : constant -> constant_body -> ml_type -> unit val lookup_typedef : constant -> constant_body -> ml_type option val add_cst_type : constant -> constant_body -> ml_schema -> unit val lookup_cst_type : constant -> constant_body -> ml_schema option val add_ind : mutual_inductive -> mutual_inductive_body -> ml_ind -> unit val lookup_ind : mutual_inductive -> mutual_inductive_body -> ml_ind option val add_inductive_kind : mutual_inductive -> inductive_kind -> unit val is_coinductive : global_reference -> bool val is_coinductive_type : ml_type -> bool (* What are the fields of a record (empty for a non-record) *) val get_record_fields : global_reference -> global_reference option list val record_fields_of_type : ml_type -> global_reference option list val add_recursors : Environ.env -> mutual_inductive -> unit val is_recursor : global_reference -> bool val add_projection : int -> constant -> inductive -> unit val is_projection : global_reference -> bool val projection_arity : global_reference -> int val projection_info : global_reference -> inductive * int (* arity *) val add_info_axiom : global_reference -> unit val remove_info_axiom : global_reference -> unit val add_log_axiom : global_reference -> unit val add_opaque : global_reference -> unit val remove_opaque : global_reference -> unit val reset_tables : unit -> unit (*s AccessOpaque parameter *) val access_opaque : unit -> bool (*s AutoInline parameter *) val auto_inline : unit -> bool (*s TypeExpand parameter *) val type_expand : unit -> bool (*s KeepSingleton parameter *) val keep_singleton : unit -> bool (*s Optimize parameter *) type opt_flag = { opt_kill_dum : bool; (* 1 *) opt_fix_fun : bool; (* 2 *) opt_case_iot : bool; (* 4 *) opt_case_idr : bool; (* 8 *) opt_case_idg : bool; (* 16 *) opt_case_cst : bool; (* 32 *) opt_case_fun : bool; (* 64 *) opt_case_app : bool; (* 128 *) opt_let_app : bool; (* 256 *) opt_lin_let : bool; (* 512 *) opt_lin_beta : bool } (* 1024 *) val optims : unit -> opt_flag (*s Controls whether dummy lambda are removed *) val conservative_types : unit -> bool (*s A comment to print at the beginning of the files *) val file_comment : unit -> string (*s Target language. *) type lang = Ocaml | Haskell | Scheme | JSON val lang : unit -> lang (*s Extraction modes: modular or monolithic, library or minimal ? Nota: - Recursive Extraction : monolithic, minimal - Separate Extraction : modular, minimal - Extraction Library : modular, library *) val set_modular : bool -> unit val modular : unit -> bool val set_library : bool -> unit val library : unit -> bool (*s Table for custom inlining *) val to_inline : global_reference -> bool val to_keep : global_reference -> bool (*s Table for implicits arguments *) val implicits_of_global : global_reference -> Int.Set.t (*s Table for user-given custom ML extractions. *) (* UGLY HACK: registration of a function defined in [extraction.ml] *) val type_scheme_nb_args_hook : (Environ.env -> Term.constr -> int) Hook.t val is_custom : global_reference -> bool val is_inline_custom : global_reference -> bool val find_custom : global_reference -> string val find_type_custom : global_reference -> string list * string val is_custom_match : ml_branch array -> bool val find_custom_match : ml_branch array -> string (*s Extraction commands. *) val extraction_language : lang -> unit val extraction_inline : bool -> reference list -> unit val print_extraction_inline : unit -> Pp.std_ppcmds val reset_extraction_inline : unit -> unit val extract_constant_inline : bool -> reference -> string list -> string -> unit val extract_inductive : reference -> string -> string list -> string option -> unit type int_or_id = ArgInt of int | ArgId of Id.t val extraction_implicit : reference -> int_or_id list -> unit (*s Table of blacklisted filenames *) val extraction_blacklist : Id.t list -> unit val reset_extraction_blacklist : unit -> unit val print_extraction_blacklist : unit -> Pp.std_ppcmds coq-8.6/plugins/extraction/ExtrOcamlIntConv.v0000644000175000017500000000564113022274260020714 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int. Parameter int_opp : int -> int. Parameter int_twice : int -> int. Extract Inlined Constant int => int. Extract Inlined Constant int_zero => "0". Extract Inlined Constant int_succ => "succ". Extract Inlined Constant int_opp => "-". Extract Inlined Constant int_twice => "2 *". Definition int_of_nat : nat -> int := (fix loop acc n := match n with | O => acc | S n => loop (int_succ acc) n end) int_zero. Fixpoint int_of_pos p := match p with | xH => int_succ int_zero | xO p => int_twice (int_of_pos p) | xI p => int_succ (int_twice (int_of_pos p)) end. Fixpoint int_of_z z := match z with | Z0 => int_zero | Zpos p => int_of_pos p | Zneg p => int_opp (int_of_pos p) end. Fixpoint int_of_n n := match n with | N0 => int_zero | Npos p => int_of_pos p end. (** NB: as for [pred] or [minus], [nat_of_int], [n_of_int] and [pos_of_int] are total and return zero (resp. one) for non-positive inputs. *) Parameter int_natlike_rec : forall A, A -> (A->A) -> int -> A. Extract Constant int_natlike_rec => "fun fO fS -> let rec loop acc i = if i <= 0 then acc else loop (fS acc) (i-1) in loop fO". Definition nat_of_int : int -> nat := int_natlike_rec _ O S. Parameter int_poslike_rec : forall A, A -> (A->A) -> (A->A) -> int -> A. Extract Constant int_poslike_rec => "fun f1 f2x f2x1 -> let rec loop i = if i <= 1 then f1 else if i land 1 = 0 then f2x (loop (i lsr 1)) else f2x1 (loop (i lsr 1)) in loop". Definition pos_of_int : int -> positive := int_poslike_rec _ xH xO xI. Parameter int_zlike_case : forall A, A -> (int->A) -> (int->A) -> int -> A. Extract Constant int_zlike_case => "fun f0 fpos fneg i -> if i = 0 then f0 else if i>0 then fpos i else fneg (-i)". Definition z_of_int : int -> Z := int_zlike_case _ Z0 (fun i => Zpos (pos_of_int i)) (fun i => Zneg (pos_of_int i)). Definition n_of_int : int -> N := int_zlike_case _ N0 (fun i => Npos (pos_of_int i)) (fun _ => N0). (** Warning: [z_of_int] is currently wrong for Ocaml's [min_int], since [min_int] has no positive opposite ([-min_int = min_int]). *) (* Extraction "/tmp/test.ml" nat_of_int int_of_nat pos_of_int int_of_pos z_of_int int_of_z n_of_int int_of_n. *)coq-8.6/plugins/extraction/ExtrOcamlBigIntConv.v0000644000175000017500000000734613022274260021342 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bigint. Parameter bigint_opp : bigint -> bigint. Parameter bigint_twice : bigint -> bigint. Extract Inlined Constant bigint => "Big.big_int". Extract Inlined Constant bigint_zero => "Big.zero". Extract Inlined Constant bigint_succ => "Big.succ". Extract Inlined Constant bigint_opp => "Big.opp". Extract Inlined Constant bigint_twice => "Big.double". Definition bigint_of_nat : nat -> bigint := (fix loop acc n := match n with | O => acc | S n => loop (bigint_succ acc) n end) bigint_zero. Fixpoint bigint_of_pos p := match p with | xH => bigint_succ bigint_zero | xO p => bigint_twice (bigint_of_pos p) | xI p => bigint_succ (bigint_twice (bigint_of_pos p)) end. Fixpoint bigint_of_z z := match z with | Z0 => bigint_zero | Zpos p => bigint_of_pos p | Zneg p => bigint_opp (bigint_of_pos p) end. Fixpoint bigint_of_n n := match n with | N0 => bigint_zero | Npos p => bigint_of_pos p end. (** NB: as for [pred] or [minus], [nat_of_bigint], [n_of_bigint] and [pos_of_bigint] are total and return zero (resp. one) for non-positive inputs. *) Parameter bigint_natlike_rec : forall A, A -> (A->A) -> bigint -> A. Extract Constant bigint_natlike_rec => "Big.nat_rec". Definition nat_of_bigint : bigint -> nat := bigint_natlike_rec _ O S. Parameter bigint_poslike_rec : forall A, (A->A) -> (A->A) -> A -> bigint -> A. Extract Constant bigint_poslike_rec => "Big.positive_rec". Definition pos_of_bigint : bigint -> positive := bigint_poslike_rec _ xI xO xH. Parameter bigint_zlike_case : forall A, A -> (bigint->A) -> (bigint->A) -> bigint -> A. Extract Constant bigint_zlike_case => "Big.z_rec". Definition z_of_bigint : bigint -> Z := bigint_zlike_case _ Z0 (fun i => Zpos (pos_of_bigint i)) (fun i => Zneg (pos_of_bigint i)). Definition n_of_bigint : bigint -> N := bigint_zlike_case _ N0 (fun i => Npos (pos_of_bigint i)) (fun _ => N0). (* Tests: Definition small := 1234%nat. Definition big := 12345678901234567890%positive. Definition nat_0 := nat_of_bigint (bigint_of_nat 0). Definition nat_1 := nat_of_bigint (bigint_of_nat small). Definition pos_1 := pos_of_bigint (bigint_of_pos 1). Definition pos_2 := pos_of_bigint (bigint_of_pos big). Definition n_0 := n_of_bigint (bigint_of_n 0). Definition n_1 := n_of_bigint (bigint_of_n 1). Definition n_2 := n_of_bigint (bigint_of_n (Npos big)). Definition z_0 := z_of_bigint (bigint_of_z 0). Definition z_1 := z_of_bigint (bigint_of_z 1). Definition z_2 := z_of_bigint (bigint_of_z (Zpos big)). Definition z_m1 := z_of_bigint (bigint_of_z (-1)). Definition z_m2 := z_of_bigint (bigint_of_z (Zneg big)). Definition test := (nat_0, nat_1, pos_1, pos_2, n_0, n_1, n_2, z_0, z_1, z_2, z_m1, z_m2). Definition check := (O, small, xH, big, 0%N, 1%N, Npos big, 0%Z, 1%Z, Zpos big, (-1)%Z, Zneg big). Extraction "/tmp/test.ml" check test. ... and we check that test=check *) coq-8.6/plugins/extraction/CHANGES0000644000175000017500000003341713022274260016323 0ustar mdenesmdenes8.0 -> today See the main CHANGES file in the archive 7.4 -> 8.0 No revolution this time. Mostly "behind-the-scene" clean-up and bug-fixes, but also a few steps toward a more user-friendly extraction: * syntax of extraction: - The old (Recursive) Extraction Module M. is now (Recursive) Extraction Library M. The old name was misleading since this command only works with M being a library M.v, and not a module produced by interactive command Module M. - The other commands Extraction foo. Recursive Extraction foo bar. Extraction "myfile.ml" foo bar. now accept that foo can be a module name instead of just a constant name. * Support of type scheme axioms (i.e. axiom whose type is an arity (x1:X1)...(xn:Xn)s with s a sort). For example: Axiom myprod : Set -> Set -> Set. Extract Constant myprod "'a" "'b" => "'a * 'b". Recursive Extraction myprod. -------> type ('a,'b) myprod = 'a * 'b * More flexible support of axioms. When an axiom isn't realized via Extract Constant before extraction, a warning is produced (instead of an error), and the extracted code must be completed later by hand. To find what needs to be completed, search for the following string: AXIOM TO BE REALIZED * Cosmetics: When extraction produces a file, it tells it. * (Experimental) It is allowed to extract under a opened interactive module (but still outside sections). Feature to be used with caution. * A problem has been identified concerning .v files used as normal interactive modules, like in Definition foo :=O. Require A. Module M:=A Extraction M. I might try to support that in the future. In the meanwhile, the current behaviour of extraction is to forbid this. * bug fixes: - many concerning Records. - a Stack Overflow with mutual inductive (PR#320) - some optimizations have been removed since they were not type-safe: For example if e has type: type 'x a = A Then: match e with A -> A -----X----> e To be investigated further. 7.3 -> 7.4 * The two main new features: - Automatic generation of Obj.magic when the extracted code in Ocaml is not directly typable. - An experimental extraction of Coq's new modules to Ocaml modules. * Concerning those Obj.magic: - The extraction now computes the expected type of any terms. Then it compares it with the actual type of the produced code. And when a mismatch is found, a Obj.magic is inserted. - As a rule, any extracted development that was compiling out of the box should not contain any Obj.magic. At the other hand, generation of Obj.magic is not optimized yet: there might be several of them at a place were one would have been enough. - Examples of code needing those Obj.magic: * plugins/extraction/test_extraction.v in the Coq source * in the users' contributions: Lannion Lyon/CIRCUITS Rocq/HIGMAN - As a side-effect of this Obj.magic feature, we now print the types of the extracted terms, both in .ml files as commented documentation and in interfaces .mli files - This feature hasn't been ported yet to Haskell. We are aware of some unsafe casting functions like "unsafeCoerce" on some Haskell implems. So it will eventually be done. * Concerning the extraction of Coq's new modules: - Taking in account the new Coq's modules system has implied a *huge* rewrite of most of the extraction code. - The extraction core (translation from Coq to an abstract mini-ML) is now complete and fairly stable, and supports modules, modules type and functors and all that stuff. - The ocaml pretty-print part, especially the renaming issue, is clearly weaker, and certainly still contains bugs. - Nothing done for translating these Coq Modules to Haskell. - A temporary drawback of this module extraction implementation is that efficiency (especially extraction speed) has been somehow neglected. To improve ... - As an interesting side-effect, definitions are now printed according to the user's original order. No more of this "dependency-correct but weird" order. In particular realized axioms via Extract Constant are now at their right place, and not at the beginning. * Other news: - Records are now printed using the Ocaml record syntax - Syntax output toward Scheme. Quite funny, but quite experimental and not documented. I recommend using the bigloo compiler since it contains natively some pattern matching. - the dummy constant "__" have changed. see README - a few bug-fixes (#191 and others) 7.2 -> 7.3 * Improved documentation in the Reference Manual. * Theoretical bad news: - a naughty example (see the end of test_extraction.v) forced me to stop eliminating lambdas and arguments corresponding to so-called "arity" in the general case. - The dummy constant used in extraction ( let prop = () in ocaml ) may in some cases be applied to arguments. This problem is dealt by generating sufficient abstraction before the (). * Theoretical good news: - there is now a mechanism that remove useless prop/arity lambdas at the top of function declarations. If your function had signature nat -> prop -> nat in the previous extraction, it will now be nat -> nat. So the extractions of common terms should look very much like the old V6.2 one, except in some particular cases (functions as parameters, partial applications, etc). In particular the bad news above have nearly no impact... * By the way there is no more "let prop = ()" in ocaml. Those () are directly inlined. And in Haskell the dummy constant is now __ (two underscore) and is defined by __ = Prelude.error "Logical or arity value used" This dummy constant should never be evaluated when computing an informative value, thanks to the lazy strategy. Hence the error message. * Syntax changes, see Documentation for details: Extraction Language Ocaml. Extraction Language Haskell. Extraction Language Toplevel. That fixes the target language of extraction. Default is Ocaml, even in the coq toplevel: you can now do copy-paste from the coq toplevel without renaming problems. Toplevel language is the ocaml pseudo-language used previously used inside the coq toplevel: coq names are printed with the coq way, i.e. with no renaming. So there is no more particular commands for Haskell, like Haskell Extraction "file" id. Just set your favourite language and go... * Haskell extraction has been tested at last (and corrected...). See specificities in Documentation. * Extraction of CoInductive in Ocaml language is now correct: it uses the Lazy.force and lazy features of Ocaml. * Modular extraction in Ocaml is now far more readable: instead of qualifying everywhere (A.foo), there are now some "open" at the beginning of files. Possible clashes are dealt with. * By default, any recursive function associated with an inductive type (foo_rec and foo_rect when foo is inductive type) will now be inlined in extracted code. * A few constants are explicitly declared to be inlined in extracted code. For the moment there are: Wf.Acc_rec Wf.Acc_rect Wf.well_founded_induction Wf.well_founded_induction_type Those constants does not match the auto-inlining criterion based on strictness. Of course, you can still overide this behaviour via some Extraction NoInline. * There is now a web page showing the extraction of all standard theories: http://www.lri.fr/~letouzey/extraction 7.1 -> 7.2 : * Syntax changes, see Documentation for more details: Set/Unset Extraction Optimize. Default is Set. This control all optimizations made on the ML terms (mostly reduction of dummy beta/iota redexes, but also simplications on Cases, etc). Put this option to Unset if you what a ML term as close as possible to the Coq term. Set/Unset Extraction AutoInline. Default in Set, so by default, the extraction mechanism feels free to inline the bodies of some defined constants, according to some heuristics like size of bodies, useness of some arguments, etc. Those heuristics are not always perfect, you may want to disable this feature, do it by Unset. Extraction Inline toto foo. Extraction NoInline titi faa bor. In addition to the automatic inline feature, you can now tell precisely to inline some more constants by the Extraction Inline command. Conversely, you can forbid the inlining of some specific constants by automatic inlining. Those two commands enable a precise control of what is inlined and what is not. Print Extraction Inline. Sum up the current state of the table recording the custom inlinings (Extraction (No)Inline). Reset Extraction Inline. Put the table recording the custom inlinings back to empty. As a consequence, there is no more need for options inside the commands of extraction: Extraction foo. Recursive Extraction foo bar. Extraction "file" foo bar. Extraction Module Mymodule. Recursive Extraction Module Mymodule. New: The last syntax extracts the module Mymodule and all the modules it depends on. You can also try the Haskell versions (not tested yet): Haskell Extraction foo. Haskell Recursive Extraction foo bar. Haskell Extraction "file" foo bar. Haskell Extraction Module Mymodule. Haskell Recursive Extraction Module Mymodule. And there's still the realization syntax: Extract Constant coq_bla => "caml_bla". Extract Inlined Constant coq_bla => "caml_bla". Extract Inductive myinductive => mycamlind [my_caml_constr1 ... ]. Note that now, the Extract Inlined Constant command is sugar for an Extract Constant followed by a Extraction Inline. So be careful with Reset Extraction Inline. * Lot of works around optimization of produced code. Should make code more readable. - fixpoint definitions : there should be no more stupid printings like let foo x = let rec f x = .... (f y) .... in f x but rather let rec foo x = .... (foo y) .... - generalized iota (in particular iota and permutation cases/cases): A generalized iota redex is a "Cases e of ...." where e is ok. And the recursive predicate "ok" is given by: e is ok if e is a Constructor or a Cases where all branches are ok. In the case of generalized iota redex, it might be good idea to reduce it, so we do it. Example: match (match t with O -> Left | S n -> match n with O -> Right | S m -> Left) with Left -> blabla | Right -> bloblo After simplification, that gives: match t with O -> blabla | S n -> match n with O -> bloblo | S n -> blabla As shown on the example, code duplication can occur. In practice it seems not to happen frequently. - "constant" case: In V7.1 we used to simplify cases where all branches are the same. In V7.2 we can simplify in addition terms like cases e of C1 x y -> f (C x y) | C2 z -> f (C2 z) If x y z don't occur in f, we can produce (f e). - permutation cases/fun: extracted code has frequenty functions in branches of cases: let foo x = match x with O -> fun _ -> .... | S y -> fun _ -> .... the optimization consist in lifting the common "fun _ ->", and that gives let foo x _ = match x with O -> ..... | S y -> .... * Some bug corrections (many thanks in particular to Michel Levy). * Testing in coq contributions: If you are interested in extraction, you can look at the extraction tests I'have put in the following coq contributions Bordeaux/Additions computation of fibonacci(2000) Bordeaux/EXCEPTIONS multiplication using exception. Bordeaux/SearchTrees list -> binary tree. maximum. Dyade/BDDS boolean tautology checker. Lyon/CIRCUITS multiplication via a modelization of a circuit. Lyon/FIRING-SQUAD print the states of the firing squad. Marseille/CIRCUITS compares integers via a modelization of a circuit. Nancy/FOUnify unification of two first-order terms. Rocq/ARITH/Chinese computation of the chinese remainder. Rocq/COC small coc typechecker. (test by B. Barras, not by me) Rocq/HIGMAN run the proof on one example. Rocq/GRAPHS linear constraints checker in Z. Sophia-Antipolis/Stalmarck boolean tautology checker. Suresnes/BDD boolean tautology checker. Just do "make" in those contributions, the extraction test is integrated. More tests will follow on more contributions. 7.0 -> 7.1 : mostly bug corrections. No theoretical problems dealed with. * The semantics of Extract Constant changed: If you provide a extraction for p by Extract Constant p => "0", your generated ML file will begin by a let p = 0. The old semantics, which was to replace p everywhere by the provided terms, is still available via the Extract Inlined Constant p => "0" syntax. * There are more optimizations applied to the generated code: - identity cases: match e with P x y -> P x y | Q z -> Q z | ... is simplified into e. Especially interesting with the sumbool terms: there will be no more match ... with Left -> Left | Right -> Right - constant cases: match e with P x y -> c | Q z -> c | ... is simplified into c as soon as x, y, z do not occur in c. So no more match ... with Left -> Left | Right -> Left. * the extraction at Toplevel (Extraction foo and Recursive Extraction foo), which was only a development tool at the beginning, is now closer to the real extraction to a file. In particular optimizations are done, and constants like recursors ( ..._rec ) are expanded. * the singleton optimization is now protected against circular type. ( Remind : this optimization is the one that simplify type 'a sig = Exists of 'a into type 'a sig = 'a and match e with (Exists c) -> d into let c = e in d ) * Fixed one bug concerning casted code * The inductives generated should now have always correct type-var list ('a,'b,'c...) * Code cleanup until three days before release. Messing-up code in the last three days before release. 6.x -> 7.0 : Everything changed. See README coq-8.6/plugins/extraction/ExtrOcamlNatInt.v0000644000175000017500000000654113022274260020531 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int [ "0" "Pervasives.succ" ] "(fun fO fS n -> if n=0 then fO () else fS (n-1))". (** Efficient (but uncertified) versions for usual [nat] functions *) Extract Constant plus => "(+)". Extract Constant pred => "fun n -> Pervasives.max 0 (n-1)". Extract Constant minus => "fun n m -> Pervasives.max 0 (n-m)". Extract Constant mult => "( * )". Extract Inlined Constant max => "Pervasives.max". Extract Inlined Constant min => "Pervasives.min". (*Extract Inlined Constant nat_beq => "(=)".*) Extract Inlined Constant EqNat.beq_nat => "(=)". Extract Inlined Constant EqNat.eq_nat_decide => "(=)". Extract Inlined Constant Peano_dec.eq_nat_dec => "(=)". Extract Constant Compare_dec.nat_compare => "fun n m -> if n=m then Eq else if n "(<=)". Extract Inlined Constant Compare_dec.le_lt_dec => "(<=)". Extract Inlined Constant Compare_dec.lt_dec => "(<)". Extract Constant Compare_dec.lt_eq_lt_dec => "fun n m -> if n>m then None else Some (n "fun n -> n mod 2 = 0". Extract Constant Div2.div2 => "fun n -> n/2". Extract Inductive Euclid.diveucl => "(int * int)" [ "" ]. Extract Constant Euclid.eucl_dev => "fun n m -> (m/n, m mod n)". Extract Constant Euclid.quotient => "fun n m -> m/n". Extract Constant Euclid.modulo => "fun n m -> m mod n". (* Definition test n m (H:m>0) := let (q,r,_,_) := eucl_dev m H n in nat_compare n (q*m+r). Recursive Extraction test fact. *) coq-8.6/plugins/extraction/scheme.mli0000644000175000017500000000106713022274260017273 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | _ -> false (*s Some pretty-print utility functions. *) let pp_par par st = if par then str "(" ++ st ++ str ")" else st (** [pp_apply] : a head part applied to arguments, possibly with parenthesis *) let pp_apply st par args = match args with | [] -> st | _ -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args)) (** Same as [pp_apply], but with also protection of the head by parenthesis *) let pp_apply2 st par args = let par' = not (List.is_empty args) || par in pp_apply (pp_par par' st) par args let pr_binding = function | [] -> mt () | l -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l let pp_tuple_light f = function | [] -> mt () | [x] -> f true x | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l) let pp_tuple f = function | [] -> mt () | [x] -> f x | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l) let pp_boxed_tuple f = function | [] -> mt () | [x] -> f x | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l)) (** By default, in module Format, you can do horizontal placing of blocks even if they include newlines, as long as the number of chars in the blocks is less that a line length. To avoid this awkward situation, we attach a big virtual size to [fnl] newlines. *) let fnl () = stras (1000000,"") ++ fnl () let fnl2 () = fnl () ++ fnl () let space_if = function true -> str " " | false -> mt () let begins_with s prefix = let len = String.length prefix in String.length s >= len && String.equal (String.sub s 0 len) prefix let begins_with_CoqXX s = let n = String.length s in n >= 4 && s.[0] == 'C' && s.[1] == 'o' && s.[2] == 'q' && let i = ref 3 in try while !i < n do match s.[!i] with | '_' -> i:=n (*Stop*) | '0'..'9' -> incr i | _ -> raise Not_found done; true with Not_found -> false let unquote s = if lang () != Scheme then s else let s = String.copy s in for i=0 to String.length s - 1 do if s.[i] == '\'' then s.[i] <- '~' done; s let rec qualify delim = function | [] -> assert false | [s] -> s | ""::l -> qualify delim l | s::l -> s^delim^(qualify delim l) let dottify = qualify "." let pseudo_qualify = qualify "__" (*s Uppercase/lowercase renamings. *) let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false let lowercase_id id = Id.of_string (String.uncapitalize (ascii_of_id id)) let uppercase_id id = let s = ascii_of_id id in assert (not (String.is_empty s)); if s.[0] == '_' then Id.of_string ("Coq_"^s) else Id.of_string (String.capitalize s) type kind = Term | Type | Cons | Mod module KOrd = struct type t = kind * string let compare (k1, s1) (k2, s2) = let c = Pervasives.compare k1 k2 (** OK *) in if c = 0 then String.compare s1 s2 else c end module KMap = Map.Make(KOrd) let upperkind = function | Type -> lang () == Haskell | Term -> false | Cons | Mod -> true let kindcase_id k id = if upperkind k then uppercase_id id else lowercase_id id (*s de Bruijn environments for programs *) type env = Id.t list * Id.Set.t (*s Generic renaming issues for local variable names. *) let rec rename_id id avoid = if Id.Set.mem id avoid then rename_id (lift_subscript id) avoid else id let rec rename_vars avoid = function | [] -> [], avoid | id :: idl when id == dummy_name -> (* we don't rename dummy binders *) let (idl', avoid') = rename_vars avoid idl in (id :: idl', avoid') | id :: idl -> let (idl, avoid) = rename_vars avoid idl in let id = rename_id (lowercase_id id) avoid in (id :: idl, Id.Set.add id avoid) let rename_tvars avoid l = let rec rename avoid = function | [] -> [],avoid | id :: idl -> let id = rename_id (lowercase_id id) avoid in let idl, avoid = rename (Id.Set.add id avoid) idl in (id :: idl, avoid) in fst (rename avoid l) let push_vars ids (db,avoid) = let ids',avoid' = rename_vars avoid ids in ids', (ids' @ db, avoid') let get_db_name n (db,_) = List.nth db (pred n) (*S Renamings of global objects. *) (*s Tables of global renamings *) let register_cleanup, do_cleanup = let funs = ref [] in (fun f -> funs:=f::!funs), (fun () -> List.iter (fun f -> f ()) !funs) type phase = Pre | Impl | Intf let set_phase, get_phase = let ph = ref Impl in ((:=) ph), (fun () -> !ph) let set_keywords, get_keywords = let k = ref Id.Set.empty in ((:=) k), (fun () -> !k) let add_global_ids, get_global_ids = let ids = ref Id.Set.empty in register_cleanup (fun () -> ids := get_keywords ()); let add s = ids := Id.Set.add s !ids and get () = !ids in (add,get) let empty_env () = [], get_global_ids () (* We might have built [global_reference] whose canonical part is inaccurate. We must hence compare only the user part, hence using a Hashtbl might be incorrect *) let mktable_id autoclean = let m = ref Id.Map.empty in let clear () = m := Id.Map.empty in if autoclean then register_cleanup clear; (fun r v -> m := Id.Map.add r v !m), (fun r -> Id.Map.find r !m), clear let mktable_ref autoclean = let m = ref Refmap'.empty in let clear () = m := Refmap'.empty in if autoclean then register_cleanup clear; (fun r v -> m := Refmap'.add r v !m), (fun r -> Refmap'.find r !m), clear let mktable_modpath autoclean = let m = ref MPmap.empty in let clear () = m := MPmap.empty in if autoclean then register_cleanup clear; (fun r v -> m := MPmap.add r v !m), (fun r -> MPmap.find r !m), clear (* A table recording objects in the first level of all MPfile *) let add_mpfiles_content,get_mpfiles_content,clear_mpfiles_content = mktable_modpath false let get_mpfiles_content mp = try get_mpfiles_content mp with Not_found -> failwith "get_mpfiles_content" (*s The list of external modules that will be opened initially *) let mpfiles_add, mpfiles_mem, mpfiles_list, mpfiles_clear = let m = ref MPset.empty in let add mp = m:=MPset.add mp !m and mem mp = MPset.mem mp !m and list () = MPset.elements !m and clear () = m:=MPset.empty in register_cleanup clear; (add,mem,list,clear) (*s List of module parameters that we should alpha-rename *) let params_ren_add, params_ren_mem = let m = ref MPset.empty in let add mp = m:=MPset.add mp !m and mem mp = MPset.mem mp !m and clear () = m:=MPset.empty in register_cleanup clear; (add,mem) (*s table indicating the visible horizon at a precise moment, i.e. the stack of structures we are inside. - The sequence of [mp] parts should have the following form: a [MPfile] at the beginning, and then more and more [MPdot] over this [MPfile], or [MPbound] when inside the type of a module parameter. - the [params] are the [MPbound] when [mp] is a functor, the innermost [MPbound] coming first in the list. - The [content] part is used to record all the names already seen at this level. *) type visible_layer = { mp : module_path; params : module_path list; mutable content : Label.t KMap.t; } let pop_visible, push_visible, get_visible = let vis = ref [] in register_cleanup (fun () -> vis := []); let pop () = match !vis with | [] -> assert false | v :: vl -> vis := vl; (* we save the 1st-level-content of MPfile for later use *) if get_phase () == Impl && modular () && is_modfile v.mp then add_mpfiles_content v.mp v.content and push mp mps = vis := { mp = mp; params = mps; content = KMap.empty } :: !vis and get () = !vis in (pop,push,get) let get_visible_mps () = List.map (function v -> v.mp) (get_visible ()) let top_visible () = match get_visible () with [] -> assert false | v::_ -> v let top_visible_mp () = (top_visible ()).mp let add_visible ks l = let visible = top_visible () in visible.content <- KMap.add ks l visible.content (* table of local module wrappers used to provide non-ambiguous names *) module DupOrd = struct type t = ModPath.t * Label.t let compare (mp1, l1) (mp2, l2) = let c = Label.compare l1 l2 in if Int.equal c 0 then ModPath.compare mp1 mp2 else c end module DupMap = Map.Make(DupOrd) let add_duplicate, check_duplicate = let index = ref 0 and dups = ref DupMap.empty in register_cleanup (fun () -> index := 0; dups := DupMap.empty); let add mp l = incr index; let ren = "Coq__" ^ string_of_int !index in dups := DupMap.add (mp,l) ren !dups and check mp l = DupMap.find (mp, l) !dups in (add,check) type reset_kind = AllButExternal | Everything let reset_renaming_tables flag = do_cleanup (); if flag == Everything then clear_mpfiles_content () (*S Renaming functions *) (* This function creates from [id] a correct uppercase/lowercase identifier. This is done by adding a [Coq_] or [coq_] prefix. To avoid potential clashes with previous [Coq_id] variable, these prefixes are duplicated if already existing. *) let modular_rename k id = let s = ascii_of_id id in let prefix,is_ok = if upperkind k then "Coq_",is_upper else "coq_",is_lower in if not (is_ok s) || Id.Set.mem id (get_keywords ()) || begins_with s prefix then prefix ^ s else s (*s For monolithic extraction, first-level modules might have to be renamed with unique numbers *) let modfstlev_rename = let add_index,get_index,_ = mktable_id true in fun l -> let id = Label.to_id l in try let n = get_index id in add_index id (n+1); let s = if n == 0 then "" else string_of_int (n-1) in "Coq"^s^"_"^(ascii_of_id id) with Not_found -> let s = ascii_of_id id in if is_lower s || begins_with_CoqXX s then (add_index id 1; "Coq_"^s) else (add_index id 0; s) (*s Creating renaming for a [module_path] : first, the real function ... *) let rec mp_renaming_fun mp = match mp with | _ when not (modular ()) && at_toplevel mp -> [""] | MPdot (mp,l) -> let lmp = mp_renaming mp in let mp = match lmp with | [""] -> modfstlev_rename l | _ -> modular_rename Mod (Label.to_id l) in mp ::lmp | MPbound mbid -> let s = modular_rename Mod (MBId.to_id mbid) in if not (params_ren_mem mp) then [s] else let i,_,_ = MBId.repr mbid in [s^"__"^string_of_int i] | MPfile _ -> assert (modular ()); (* see [at_toplevel] above *) assert (get_phase () == Pre); let current_mpfile = (List.last (get_visible ())).mp in if not (ModPath.equal mp current_mpfile) then mpfiles_add mp; [string_of_modfile mp] (* ... and its version using a cache *) and mp_renaming = let add,get,_ = mktable_modpath true in fun x -> try if is_mp_bound (base_mp x) then raise Not_found; get x with Not_found -> let y = mp_renaming_fun x in add x y; y (*s Renamings creation for a [global_reference]: we build its fully-qualified name in a [string list] form (head is the short name). *) let ref_renaming_fun (k,r) = let mp = modpath_of_r r in let l = mp_renaming mp in let l = if lang () != Ocaml && not (modular ()) then [""] else l in let s = let idg = safe_basename_of_global r in match l with | [""] -> (* this happens only at toplevel of the monolithic case *) let globs = Id.Set.elements (get_global_ids ()) in let id = next_ident_away (kindcase_id k idg) globs in Id.to_string id | _ -> modular_rename k idg in add_global_ids (Id.of_string s); s::l (* Cached version of the last function *) let ref_renaming = let add,get,_ = mktable_ref true in fun ((k,r) as x) -> try if is_mp_bound (base_mp (modpath_of_r r)) then raise Not_found; get r with Not_found -> let y = ref_renaming_fun x in add r y; y (* [visible_clash mp0 (k,s)] checks if [mp0-s] of kind [k] can be printed as [s] in the current context of visible modules. More precisely, we check if there exists a visible [mp] that contains [s]. The verification stops if we encounter [mp=mp0]. *) let rec clash mem mp0 ks = function | [] -> false | mp :: _ when ModPath.equal mp mp0 -> false | mp :: _ when mem mp ks -> true | _ :: mpl -> clash mem mp0 ks mpl let mpfiles_clash mp0 ks = clash (fun mp k -> KMap.mem k (get_mpfiles_content mp)) mp0 ks (List.rev (mpfiles_list ())) let rec params_lookup mp0 ks = function | [] -> false | param :: _ when ModPath.equal mp0 param -> true | param :: params -> let () = match ks with | (Mod, mp) when String.equal (List.hd (mp_renaming param)) mp -> params_ren_add param | _ -> () in params_lookup mp0 ks params let visible_clash mp0 ks = let rec clash = function | [] -> false | v :: _ when ModPath.equal v.mp mp0 -> false | v :: vis -> let b = KMap.mem ks v.content in if b && not (is_mp_bound mp0) then true else begin if b then params_ren_add mp0; if params_lookup mp0 ks v.params then false else clash vis end in clash (get_visible ()) (* Same, but with verbose output (and mp0 shouldn't be a MPbound) *) let visible_clash_dbg mp0 ks = let rec clash = function | [] -> None | v :: _ when ModPath.equal v.mp mp0 -> None | v :: vis -> try Some (v.mp,KMap.find ks v.content) with Not_found -> if params_lookup mp0 ks v.params then None else clash vis in clash (get_visible ()) (* After the 1st pass, we can decide which modules will be opened initially *) let opened_libraries () = if not (modular ()) then [] else let used_files = mpfiles_list () in let used_ks = List.map (fun mp -> Mod,string_of_modfile mp) used_files in (* By default, we open all used files. Ambiguities will be resolved later by using qualified names. Nonetheless, we don't open any file A that contains an immediate submodule A.B hiding another file B : otherwise, after such an open, there's no unambiguous way to refer to objects of B. *) let to_open = List.filter (fun mp -> not (List.exists (fun k -> KMap.mem k (get_mpfiles_content mp)) used_ks)) used_files in mpfiles_clear (); List.iter mpfiles_add to_open; mpfiles_list () (*s On-the-fly qualification issues for both monolithic or modular extraction. *) (* [pp_ocaml_gen] below is a function that factorize the printing of both [global_reference] and module names for ocaml. When [k=Mod] then [olab=None], otherwise it contains the label of the reference to print. [rls] is the string list giving the qualified name, short name at the end. *) (* In Coq, we can qualify [M.t] even if we are inside [M], but in Ocaml we cannot do that. So, if [t] gets hidden and we need a long name for it, we duplicate the _definition_ of t in a Coq__XXX module, and similarly for a sub-module [M.N] *) let pp_duplicate k' prefix mp rls olab = let rls', lbl = if k' != Mod then (* Here rls=[s], the ref to print is ., and olab<>None *) rls, Option.get olab else (* Here rls=s::rls', we search the label for s inside mp *) List.tl rls, get_nth_label_mp (mp_length mp - mp_length prefix) mp in try dottify (check_duplicate prefix lbl :: rls') with Not_found -> assert (get_phase () == Pre); (* otherwise it's too late *) add_duplicate prefix lbl; dottify rls let fstlev_ks k = function | [] -> assert false | [s] -> k,s | s::_ -> Mod,s (* [pp_ocaml_local] : [mp] has something in common with [top_visible ()] but isn't equal to it *) let pp_ocaml_local k prefix mp rls olab = (* what is the largest prefix of [mp] that belongs to [visible]? *) assert (k != Mod || not (ModPath.equal mp prefix)); (* mp as whole module isn't in itself *) let rls' = List.skipn (mp_length prefix) rls in let k's = fstlev_ks k rls' in (* Reference r / module path mp is of the form [.s.<...>]. *) if not (visible_clash prefix k's) then dottify rls' else pp_duplicate (fst k's) prefix mp rls' olab (* [pp_ocaml_bound] : [mp] starts with a [MPbound], and we are not inside (i.e. we are not printing the type of the module parameter) *) let pp_ocaml_bound base rls = (* clash with a MPbound will be detected and fixed by renaming this MPbound *) if get_phase () == Pre then ignore (visible_clash base (Mod,List.hd rls)); dottify rls (* [pp_ocaml_extern] : [mp] isn't local, it is defined in another [MPfile]. *) let pp_ocaml_extern k base rls = match rls with | [] -> assert false | base_s :: rls' -> if (not (modular ())) (* Pseudo qualification with "" *) || (List.is_empty rls') (* Case of a file A.v used as a module later *) || (not (mpfiles_mem base)) (* Module not opened *) || (mpfiles_clash base (fstlev_ks k rls')) (* Conflict in opened files *) || (visible_clash base (fstlev_ks k rls')) (* Local conflict *) then (* We need to fully qualify. Last clash situation is unsupported *) match visible_clash_dbg base (Mod,base_s) with | None -> dottify rls | Some (mp,l) -> error_module_clash base (MPdot (mp,l)) else (* Standard situation : object in an opened file *) dottify rls' (* [pp_ocaml_gen] : choosing between [pp_ocaml_local] or [pp_ocaml_extern] *) let pp_ocaml_gen k mp rls olab = match common_prefix_from_list mp (get_visible_mps ()) with | Some prefix -> pp_ocaml_local k prefix mp rls olab | None -> let base = base_mp mp in if is_mp_bound base then pp_ocaml_bound base rls else pp_ocaml_extern k base rls (* For Haskell, things are simplier: we have removed (almost) all structures *) let pp_haskell_gen k mp rls = match rls with | [] -> assert false | s::rls' -> let str = pseudo_qualify rls' in let str = if is_upper str && not (upperkind k) then ("_"^str) else str in if ModPath.equal (base_mp mp) (top_visible_mp ()) then str else s^"."^str (* Main name printing function for a reference *) let pp_global k r = let ls = ref_renaming (k,r) in assert (List.length ls > 1); let s = List.hd ls in let mp,_,l = repr_of_r r in if ModPath.equal mp (top_visible_mp ()) then (* simpliest situation: definition of r (or use in the same context) *) (* we update the visible environment *) (add_visible (k,s) l; unquote s) else let rls = List.rev ls in (* for what come next it's easier this way *) match lang () with | Scheme -> unquote s (* no modular Scheme extraction... *) | JSON -> dottify (List.map unquote rls) | Haskell -> if modular () then pp_haskell_gen k mp rls else s | Ocaml -> pp_ocaml_gen k mp rls (Some l) (* The next function is used only in Ocaml extraction...*) let pp_module mp = let ls = mp_renaming mp in match mp with | MPdot (mp0,l) when ModPath.equal mp0 (top_visible_mp ()) -> (* simpliest situation: definition of mp (or use in the same context) *) (* we update the visible environment *) let s = List.hd ls in add_visible (Mod,s) l; s | _ -> pp_ocaml_gen Mod mp (List.rev ls) None (** Special hack for constants of type Ascii.ascii : if an [Extract Inductive ascii => char] has been declared, then the constants are directly turned into chars *) let mk_ind path s = MutInd.make2 (MPfile (dirpath_of_string path)) (Label.make s) let ind_ascii = mk_ind "Coq.Strings.Ascii" "ascii" let check_extract_ascii () = try let char_type = match lang () with | Ocaml -> "char" | Haskell -> "Prelude.Char" | _ -> raise Not_found in String.equal (find_custom (IndRef (ind_ascii, 0))) (char_type) with Not_found -> false let is_list_cons l = List.for_all (function MLcons (_,ConstructRef(_,_),[]) -> true | _ -> false) l let is_native_char = function | MLcons(_,ConstructRef ((kn,0),1),l) -> MutInd.equal kn ind_ascii && check_extract_ascii () && is_list_cons l | _ -> false let get_native_char c = let rec cumul = function | [] -> 0 | MLcons(_,ConstructRef(_,j),[])::l -> (2-j) + 2 * (cumul l) | _ -> assert false in let l = match c with MLcons(_,_,l) -> l | _ -> assert false in Char.chr (cumul l) let pp_native_char c = str ("'"^Char.escaped (get_native_char c)^"'") coq-8.6/plugins/extraction/ExtrHaskellNatInt.v0000644000175000017500000000064313022274260021056 0ustar mdenesmdenes(** Extraction of [nat] into Haskell's [Int] *) Require Import Arith. Require Import ExtrHaskellNatNum. (** * Disclaimer: trying to obtain efficient certified programs * by extracting [nat] into [Int] is definitively *not* a good idea. * See comments in [ExtrOcamlNatInt.v]. *) Extract Inductive nat => "Prelude.Int" [ "0" "Prelude.succ" ] "(\fO fS n -> if n Prelude.== 0 then fO () else fS (n Prelude.- 1))". coq-8.6/plugins/extraction/extraction_plugin.mlpack0000644000175000017500000000013213022274260022243 0ustar mdenesmdenesTable Mlutil Modutil Extraction Common Ocaml Haskell Scheme Json Extract_env G_extraction coq-8.6/plugins/extraction/ExtrHaskellBasic.v0000644000175000017500000000134313022274260020700 0ustar mdenesmdenes(** Extraction to Haskell : use of basic Haskell types *) Extract Inductive bool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ]. Extract Inductive option => "Prelude.Maybe" [ "Prelude.Just" "Prelude.Nothing" ]. Extract Inductive unit => "()" [ "()" ]. Extract Inductive list => "([])" [ "([])" "(:)" ]. Extract Inductive prod => "(,)" [ "(,)" ]. Extract Inductive sumbool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ]. Extract Inductive sumor => "Prelude.Maybe" [ "Prelude.Just" "Prelude.Nothing" ]. Extract Inductive sum => "Prelude.Either" [ "Prelude.Left" "Prelude.Right" ]. Extract Inlined Constant andb => "(Prelude.&&)". Extract Inlined Constant orb => "(Prelude.||)". Extract Inlined Constant negb => "Prelude.not". coq-8.6/plugins/extraction/g_extraction.ml40000644000175000017500000001063613022274260020432 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ id ] | [ string(s) ] -> [ s ] END let pr_int_or_id _ _ _ = function | ArgInt i -> int i | ArgId id -> pr_id id ARGUMENT EXTEND int_or_id PRINTED BY pr_int_or_id | [ preident(id) ] -> [ ArgId (Id.of_string id) ] | [ integer(i) ] -> [ ArgInt i ] END let pr_language = function | Ocaml -> str "Ocaml" | Haskell -> str "Haskell" | Scheme -> str "Scheme" | JSON -> str "JSON" VERNAC ARGUMENT EXTEND language PRINTED BY pr_language | [ "Ocaml" ] -> [ Ocaml ] | [ "Haskell" ] -> [ Haskell ] | [ "Scheme" ] -> [ Scheme ] | [ "JSON" ] -> [ JSON ] END (* Extraction commands *) VERNAC COMMAND EXTEND Extraction CLASSIFIED AS QUERY (* Extraction in the Coq toplevel *) | [ "Extraction" global(x) ] -> [ simple_extraction x ] | [ "Recursive" "Extraction" ne_global_list(l) ] -> [ full_extraction None l ] (* Monolithic extraction to a file *) | [ "Extraction" string(f) ne_global_list(l) ] -> [ full_extraction (Some f) l ] END VERNAC COMMAND EXTEND SeparateExtraction CLASSIFIED AS QUERY (* Same, with content splitted in several files *) | [ "Separate" "Extraction" ne_global_list(l) ] -> [ separate_extraction l ] END (* Modular extraction (one Coq library = one ML module) *) VERNAC COMMAND EXTEND ExtractionLibrary CLASSIFIED AS QUERY | [ "Extraction" "Library" ident(m) ] -> [ extraction_library false m ] END VERNAC COMMAND EXTEND RecursiveExtractionLibrary CLASSIFIED AS QUERY | [ "Recursive" "Extraction" "Library" ident(m) ] -> [ extraction_library true m ] END (* Target Language *) VERNAC COMMAND EXTEND ExtractionLanguage CLASSIFIED AS SIDEFF | [ "Extraction" "Language" language(l) ] -> [ extraction_language l ] END VERNAC COMMAND EXTEND ExtractionInline CLASSIFIED AS SIDEFF (* Custom inlining directives *) | [ "Extraction" "Inline" ne_global_list(l) ] -> [ extraction_inline true l ] END VERNAC COMMAND EXTEND ExtractionNoInline CLASSIFIED AS SIDEFF | [ "Extraction" "NoInline" ne_global_list(l) ] -> [ extraction_inline false l ] END VERNAC COMMAND EXTEND PrintExtractionInline CLASSIFIED AS QUERY | [ "Print" "Extraction" "Inline" ] -> [Feedback. msg_info (print_extraction_inline ()) ] END VERNAC COMMAND EXTEND ResetExtractionInline CLASSIFIED AS SIDEFF | [ "Reset" "Extraction" "Inline" ] -> [ reset_extraction_inline () ] END VERNAC COMMAND EXTEND ExtractionImplicit CLASSIFIED AS SIDEFF (* Custom implicit arguments of some csts/inds/constructors *) | [ "Extraction" "Implicit" global(r) "[" int_or_id_list(l) "]" ] -> [ extraction_implicit r l ] END VERNAC COMMAND EXTEND ExtractionBlacklist CLASSIFIED AS SIDEFF (* Force Extraction to not use some filenames *) | [ "Extraction" "Blacklist" ne_ident_list(l) ] -> [ extraction_blacklist l ] END VERNAC COMMAND EXTEND PrintExtractionBlacklist CLASSIFIED AS QUERY | [ "Print" "Extraction" "Blacklist" ] -> [ Feedback.msg_info (print_extraction_blacklist ()) ] END VERNAC COMMAND EXTEND ResetExtractionBlacklist CLASSIFIED AS SIDEFF | [ "Reset" "Extraction" "Blacklist" ] -> [ reset_extraction_blacklist () ] END (* Overriding of a Coq object by an ML one *) VERNAC COMMAND EXTEND ExtractionConstant CLASSIFIED AS SIDEFF | [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ] -> [ extract_constant_inline false x idl y ] END VERNAC COMMAND EXTEND ExtractionInlinedConstant CLASSIFIED AS SIDEFF | [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ] -> [ extract_constant_inline true x [] y ] END VERNAC COMMAND EXTEND ExtractionInductive CLASSIFIED AS SIDEFF | [ "Extract" "Inductive" global(x) "=>" mlname(id) "[" mlname_list(idl) "]" string_opt(o) ] -> [ extract_inductive x id idl o ] END coq-8.6/plugins/extraction/big.ml0000644000175000017500000001326313022274260016420 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 then fp z else fn (opp z) let compare_case e l g x y = let s = compare x y in if s = 0 then e else if s<0 then l else g let nat_rec fO fS = let rec loop acc n = if sign n <= 0 then acc else loop (fS acc) (pred n) in loop fO let positive_rec f2p1 f2p f1 = let rec loop n = if le n one then f1 else let (q,r) = quomod n two in if eq r zero then f2p (loop q) else f2p1 (loop q) in loop let z_rec fO fp fn = z_case (fun _ -> fO) fp fn coq-8.6/plugins/extraction/vo.itarget0000644000175000017500000000050713022274260017327 0ustar mdenesmdenesExtrHaskellBasic.vo ExtrHaskellNatNum.vo ExtrHaskellNatInt.vo ExtrHaskellNatInteger.vo ExtrHaskellZNum.vo ExtrHaskellZInt.vo ExtrHaskellZInteger.vo ExtrHaskellString.vo ExtrOcamlBasic.vo ExtrOcamlIntConv.vo ExtrOcamlBigIntConv.vo ExtrOcamlNatInt.vo ExtrOcamlNatBigInt.vo ExtrOcamlZInt.vo ExtrOcamlZBigInt.vo ExtrOcamlString.vo coq-8.6/plugins/extraction/ocaml.ml0000644000175000017500000006443613022274260016762 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mt () | l -> str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++ str " ->" ++ spc () let pp_parameters l = (pp_boxed_tuple pp_tvar l ++ space_if (not (List.is_empty l))) let pp_string_parameters l = (pp_boxed_tuple str l ++ space_if (not (List.is_empty l))) let pp_letin pat def body = let fstline = str "let " ++ pat ++ str " =" ++ spc () ++ def in hv 0 (hv 0 (hov 2 fstline ++ spc () ++ str "in") ++ spc () ++ hov 0 body) (*s Ocaml renaming issues. *) let keywords = List.fold_right (fun s -> Id.Set.add (Id.of_string s)) [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module"; "mutable"; "new"; "object"; "of"; "open"; "or"; "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true"; "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] Id.Set.empty (* Note: do not shorten [str "foo" ++ fnl ()] into [str "foo\n"], the '\n' character interacts badly with the Format boxing mechanism *) let pp_open mp = str ("open "^ string_of_modfile mp) ++ fnl () let pp_comment s = str "(* " ++ hov 0 s ++ str " *)" let pp_header_comment = function | None -> mt () | Some com -> pp_comment com ++ fnl2 () let then_nl pp = if Pp.is_empty pp then mt () else pp ++ fnl () let pp_tdummy usf = if usf.tdummy || usf.tunknown then str "type __ = Obj.t" ++ fnl () else mt () let pp_mldummy usf = if usf.mldummy then str "let __ = let rec f _ = Obj.repr f in Obj.repr f" ++ fnl () else mt () let preamble _ comment used_modules usf = pp_header_comment comment ++ then_nl (prlist pp_open used_modules) ++ then_nl (pp_tdummy usf ++ pp_mldummy usf) let sig_preamble _ comment used_modules usf = pp_header_comment comment ++ then_nl (prlist pp_open used_modules) ++ then_nl (pp_tdummy usf) (*s The pretty-printer for Ocaml syntax*) (* Beware of the side-effects of [pp_global] and [pp_modname]. They are used to update table of content for modules. Many [let] below should not be altered since they force evaluation order. *) let str_global k r = if is_inline_custom r then find_custom r else Common.pp_global k r let pp_global k r = str (str_global k r) let pp_modname mp = str (Common.pp_module mp) let is_infix r = is_inline_custom r && (let s = find_custom r in let l = String.length s in l >= 2 && s.[0] == '(' && s.[l-1] == ')') let get_infix r = let s = find_custom r in String.sub s 1 (String.length s - 2) let get_ind = function | IndRef _ as r -> r | ConstructRef (ind,_) -> IndRef ind | _ -> assert false let pp_one_field r i = function | Some r -> pp_global Term r | None -> pp_global Type (get_ind r) ++ str "__" ++ int i let pp_field r fields i = pp_one_field r i (List.nth fields i) let pp_fields r fields = List.map_i (pp_one_field r) 0 fields (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses are needed or not. *) let pp_type par vl t = let rec pp_rec par = function | Tmeta _ | Tvar' _ | Taxiom -> assert false | Tvar i -> (try pp_tvar (List.nth vl (pred i)) with Failure _ -> (str "'a" ++ int i)) | Tglob (r,[a1;a2]) when is_infix r -> pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2) | Tglob (r,[]) -> pp_global Type r | Tglob (IndRef(kn,0),l) when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") -> pp_tuple_light pp_rec l | Tglob (r,l) -> pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r | Tarr (t1,t2) -> pp_par par (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) | Tdummy _ -> str "__" | Tunknown -> str "__" in hov 0 (pp_rec par t) (*s Pretty-printing of expressions. [par] indicates whether parentheses are needed or not. [env] is the list of names for the de Bruijn variables. [args] is the list of collected arguments (already pretty-printed). *) let is_bool_patt p s = try let r = match p with | Pusual r -> r | Pcons (r,[]) -> r | _ -> raise Not_found in String.equal (find_custom r) s with Not_found -> false let is_ifthenelse = function | [|([],p1,_);([],p2,_)|] -> is_bool_patt p1 "true" && is_bool_patt p2 "false" | _ -> false let expr_needs_par = function | MLlam _ -> true | MLcase (_,_,[|_|]) -> false | MLcase (_,_,pv) -> not (is_ifthenelse pv) | _ -> false let rec pp_expr par env args = let apply st = pp_apply st par args and apply2 st = pp_apply2 st par args in function | MLrel n -> let id = get_db_name n env in (* Try to survive to the occurrence of a Dummy rel. TODO: we should get rid of this hack (cf. #592) *) let id = if Id.equal id dummy_name then Id.of_string "__" else id in apply (pr_id id) | MLapp (f,args') -> let stl = List.map (pp_expr true env []) args' in pp_expr par env (stl @ args) f | MLlam _ as a -> let fl,a' = collect_lams a in let fl = List.map id_of_mlid fl in let fl,env' = push_vars fl env in let st = pp_abst (List.rev fl) ++ pp_expr false env' [] a' in apply2 st | MLletin (id,a1,a2) -> let i,env' = push_vars [id_of_mlid id] env in let pp_id = pr_id (List.hd i) and pp_a1 = pp_expr false env [] a1 and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in hv 0 (apply2 (pp_letin pp_id pp_a1 pp_a2)) | MLglob r -> (try let args = List.skipn (projection_arity r) args in let record = List.hd args in pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args) with e when CErrors.noncritical e -> apply (pp_global Term r)) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' i (Array.of_list (List.rev ids'),defs) args | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)")) | MLdummy k -> (* An [MLdummy] may be applied, but I don't really care. *) (match msg_of_implicit k with | "" -> str "__" | s -> str "__" ++ spc () ++ str ("(* "^s^" *)")) | MLmagic a -> pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args) | MLaxiom -> pp_par par (str "failwith \"AXIOM TO BE REALIZED\"") | MLcons (_,r,a) as c -> assert (List.is_empty args); begin match a with | _ when is_native_char c -> pp_native_char c | [a1;a2] when is_infix r -> let pp = pp_expr true env [] in pp_par par (pp a1 ++ str (get_infix r) ++ pp a2) | _ when is_coinductive r -> let ne = not (List.is_empty a) in let tuple = space_if ne ++ pp_tuple (pp_expr true env []) a in pp_par par (str "lazy " ++ pp_par ne (pp_global Cons r ++ tuple)) | [] -> pp_global Cons r | _ -> let fds = get_record_fields r in if not (List.is_empty fds) then pp_record_pat (pp_fields r fds, List.map (pp_expr true env []) a) else let tuple = pp_tuple (pp_expr true env []) a in if String.is_empty (str_global Cons r) (* hack Extract Inductive prod *) then tuple else pp_par par (pp_global Cons r ++ spc () ++ tuple) end | MLtuple l -> assert (List.is_empty args); pp_boxed_tuple (pp_expr true env []) l | MLcase (_, t, pv) when is_custom_match pv -> if not (is_regular_match pv) then error "Cannot mix yet user-given match and general patterns."; let mkfun (ids,_,e) = if not (List.is_empty ids) then named_lams (List.rev ids) e else dummy_lams (ast_lift 1 e) 1 in let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in let inner = str (find_custom_match pv) ++ fnl () ++ prvect pp_branch pv ++ pp_expr true env [] t in apply2 (hov 2 inner) | MLcase (typ, t, pv) -> let head = if not (is_coinductive_type typ) then pp_expr false env [] t else (str "Lazy.force" ++ spc () ++ pp_expr true env [] t) in (* First, can this match be printed as a mere record projection ? *) (try pp_record_proj par env typ t pv args with Impossible -> (* Second, can this match be printed as a let-in ? *) if Int.equal (Array.length pv) 1 then let s1,s2 = pp_one_pat env pv.(0) in hv 0 (apply2 (pp_letin s1 head s2)) else (* Third, can this match be printed as [if ... then ... else] ? *) (try apply2 (pp_ifthenelse env head pv) with Not_found -> (* Otherwise, standard match *) apply2 (v 0 (str "match " ++ head ++ str " with" ++ fnl () ++ pp_pat env pv)))) and pp_record_proj par env typ t pv args = (* Can a match be printed as a mere record projection ? *) let fields = record_fields_of_type typ in if List.is_empty fields then raise Impossible; if not (Int.equal (Array.length pv) 1) then raise Impossible; if has_deep_pattern pv then raise Impossible; let (ids,pat,body) = pv.(0) in let n = List.length ids in let no_patvar a = not (List.exists (ast_occurs_itvl 1 n) a) in let rel_i,a = match body with | MLrel i when i <= n -> i,[] | MLapp(MLrel i, a) when i<=n && no_patvar a -> i,a | _ -> raise Impossible in let rec lookup_rel i idx = function | Prel j :: l -> if Int.equal i j then idx else lookup_rel i (idx+1) l | Pwild :: l -> lookup_rel i (idx+1) l | _ -> raise Impossible in let r,idx = match pat with | Pusual r -> r, n-rel_i | Pcons (r,l) -> r, lookup_rel rel_i 0 l | _ -> raise Impossible in if is_infix r then raise Impossible; let env' = snd (push_vars (List.rev_map id_of_mlid ids) env) in let pp_args = (List.map (pp_expr true env' []) a) @ args in let pp_head = pp_expr true env [] t ++ str "." ++ pp_field r fields idx in pp_apply pp_head par pp_args and pp_record_pat (fields, args) = str "{ " ++ prlist_with_sep (fun () -> str ";" ++ spc ()) (fun (f,a) -> f ++ str " =" ++ spc () ++ a) (List.combine fields args) ++ str " }" and pp_cons_pat r ppl = if is_infix r && Int.equal (List.length ppl) 2 then List.hd ppl ++ str (get_infix r) ++ List.hd (List.tl ppl) else let fields = get_record_fields r in if not (List.is_empty fields) then pp_record_pat (pp_fields r fields, ppl) else if String.is_empty (str_global Cons r) then pp_boxed_tuple identity ppl (* Hack Extract Inductive prod *) else pp_global Cons r ++ space_if (not (List.is_empty ppl)) ++ pp_boxed_tuple identity ppl and pp_gen_pat ids env = function | Pcons (r, l) -> pp_cons_pat r (List.map (pp_gen_pat ids env) l) | Pusual r -> pp_cons_pat r (List.map pr_id ids) | Ptuple l -> pp_boxed_tuple (pp_gen_pat ids env) l | Pwild -> str "_" | Prel n -> pr_id (get_db_name n env) and pp_ifthenelse env expr pv = match pv with | [|([],tru,the);([],fal,els)|] when (is_bool_patt tru "true") && (is_bool_patt fal "false") -> hv 0 (hov 2 (str "if " ++ expr) ++ spc () ++ hov 2 (str "then " ++ hov 2 (pp_expr (expr_needs_par the) env [] the)) ++ spc () ++ hov 2 (str "else " ++ hov 2 (pp_expr (expr_needs_par els) env [] els))) | _ -> raise Not_found and pp_one_pat env (ids,p,t) = let ids',env' = push_vars (List.rev_map id_of_mlid ids) env in pp_gen_pat (List.rev ids') env' p, pp_expr (expr_needs_par t) env' [] t and pp_pat env pv = prvecti (fun i x -> let s1,s2 = pp_one_pat env x in hv 2 (hov 4 (str "| " ++ s1 ++ str " ->") ++ spc () ++ hov 2 s2) ++ if Int.equal i (Array.length pv - 1) then mt () else fnl ()) pv and pp_function env t = let bl,t' = collect_lams t in let bl,env' = push_vars (List.map id_of_mlid bl) env in match t' with | MLcase(Tglob(r,_),MLrel 1,pv) when not (is_coinductive r) && List.is_empty (get_record_fields r) && not (is_custom_match pv) -> if not (ast_occurs 1 (MLcase(Tunknown,MLaxiom,pv))) then pr_binding (List.rev (List.tl bl)) ++ str " = function" ++ fnl () ++ v 0 (pp_pat env' pv) else pr_binding (List.rev bl) ++ str " = match " ++ pr_id (List.hd bl) ++ str " with" ++ fnl () ++ v 0 (pp_pat env' pv) | _ -> pr_binding (List.rev bl) ++ str " =" ++ fnl () ++ str " " ++ hov 2 (pp_expr false env' [] t') (*s names of the functions ([ids]) are already pushed in [env], and passed here just for convenience. *) and pp_fix par env i (ids,bl) args = pp_par par (v 0 (str "let rec " ++ prvect_with_sep (fun () -> fnl () ++ str "and ") (fun (fi,ti) -> pr_id fi ++ pp_function env ti) (Array.map2 (fun id b -> (id,b)) ids bl) ++ fnl () ++ hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args))) (* Ad-hoc double-newline in v boxes, with enough negative whitespace to avoid indenting the intermediate blank line *) let cut2 () = brk (0,-100000) ++ brk (0,0) let pp_val e typ = hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++ str " **)") ++ cut2 () (*s Pretty-printing of [Dfix] *) let pp_Dfix (rv,c,t) = let names = Array.map (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv in let rec pp init i = if i >= Array.length rv then mt () else let void = is_inline_custom rv.(i) || (not (is_custom rv.(i)) && match c.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then pp init (i+1) else let def = if is_custom rv.(i) then str " = " ++ str (find_custom rv.(i)) else pp_function (empty_env ()) c.(i) in (if init then mt () else cut2 ()) ++ pp_val names.(i) t.(i) ++ str (if init then "let rec " else "and ") ++ names.(i) ++ def ++ pp false (i+1) in pp true 0 (*s Pretty-printing of inductive types declaration. *) let pp_equiv param_list name = function | NoEquiv, _ -> mt () | Equiv kn, i -> str " = " ++ pp_parameters param_list ++ pp_global Type (IndRef (mind_of_kn kn,i)) | RenEquiv ren, _ -> str " = " ++ pp_parameters param_list ++ str (ren^".") ++ name let pp_one_ind prefix ip_equiv pl name cnames ctyps = let pl = rename_tvars keywords pl in let pp_constructor i typs = (if Int.equal i 0 then mt () else fnl ()) ++ hov 3 (str "| " ++ cnames.(i) ++ (if List.is_empty typs then mt () else str " of ") ++ prlist_with_sep (fun () -> spc () ++ str "* ") (pp_type true pl) typs) in pp_parameters pl ++ str prefix ++ name ++ pp_equiv pl name ip_equiv ++ str " =" ++ if Int.equal (Array.length ctyps) 0 then str " unit (* empty inductive *)" else fnl () ++ v 0 (prvecti pp_constructor ctyps) let pp_logical_ind packet = pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ fnl () ++ pp_comment (str "with constructors : " ++ prvect_with_sep spc pr_id packet.ip_consnames) ++ fnl () let pp_singleton kn packet = let name = pp_global Type (IndRef (kn,0)) in let l = rename_tvars keywords packet.ip_vars in hov 2 (str "type " ++ pp_parameters l ++ name ++ str " =" ++ spc () ++ pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ pp_comment (str "singleton inductive, whose constructor was " ++ pr_id packet.ip_consnames.(0))) let pp_record kn fields ip_equiv packet = let ind = IndRef (kn,0) in let name = pp_global Type ind in let fieldnames = pp_fields ind fields in let l = List.combine fieldnames packet.ip_types.(0) in let pl = rename_tvars keywords packet.ip_vars in str "type " ++ pp_parameters pl ++ name ++ pp_equiv pl name ip_equiv ++ str " = { "++ hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) (fun (p,t) -> p ++ str " : " ++ pp_type true pl t) l) ++ str " }" let pp_coind pl name = let pl = rename_tvars keywords pl in pp_parameters pl ++ name ++ str " = " ++ pp_parameters pl ++ str "__" ++ name ++ str " Lazy.t" ++ fnl() ++ str "and " let pp_ind co kn ind = let prefix = if co then "__" else "" in let initkwd = str "type " in let nextkwd = fnl () ++ str "and " in let names = Array.mapi (fun i p -> if p.ip_logical then mt () else pp_global Type (IndRef (kn,i))) ind.ind_packets in let cnames = Array.mapi (fun i p -> if p.ip_logical then [||] else Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((kn,i),j+1))) p.ip_types) ind.ind_packets in let rec pp i kwd = if i >= Array.length ind.ind_packets then mt () else let ip = (kn,i) in let ip_equiv = ind.ind_equiv, i in let p = ind.ind_packets.(i) in if is_custom (IndRef ip) then pp (i+1) kwd else if p.ip_logical then pp_logical_ind p ++ pp (i+1) kwd else kwd ++ (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ pp_one_ind prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++ pp (i+1) nextkwd in pp 0 initkwd (*s Pretty-printing of a declaration. *) let pp_mind kn i = match i.ind_kind with | Singleton -> pp_singleton kn i.ind_packets.(0) | Coinductive -> pp_ind true kn i | Record fields -> pp_record kn fields (i.ind_equiv,0) i.ind_packets.(0) | Standard -> pp_ind false kn i let pp_decl = function | Dtype (r,_,_) when is_inline_custom r -> mt () | Dterm (r,_,_) when is_inline_custom r -> mt () | Dind (kn,i) -> pp_mind kn i | Dtype (r, l, t) -> let name = pp_global Type r in let l = rename_tvars keywords l in let ids, def = try let ids,s = find_type_custom r in pp_string_parameters ids, str " =" ++ spc () ++ str s with Not_found -> pp_parameters l, if t == Taxiom then str " (* AXIOM TO BE REALIZED *)" else str " =" ++ spc () ++ pp_type false l t in hov 2 (str "type " ++ ids ++ name ++ def) | Dterm (r, a, t) -> let def = if is_custom r then str (" = " ^ find_custom r) else if is_projection r then (prvect str (Array.make (projection_arity r) " _")) ++ str " x = x." else pp_function (empty_env ()) a in let name = pp_global Term r in let postdef = if is_projection r then name else mt () in pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ postdef) | Dfix (rv,defs,typs) -> pp_Dfix (rv,defs,typs) let pp_alias_decl ren = function | Dind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } | Dtype (r, l, _) -> let name = pp_global Type r in let l = rename_tvars keywords l in let ids = pp_parameters l in hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ str (ren^".") ++ name) | Dterm (r, a, t) -> let name = pp_global Term r in hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) | Dfix (rv, _, _) -> prvecti (fun i r -> if is_inline_custom r then mt () else let name = pp_global Term r in hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) ++ fnl ()) rv let pp_spec = function | Sval (r,_) when is_inline_custom r -> mt () | Stype (r,_,_) when is_inline_custom r -> mt () | Sind (kn,i) -> pp_mind kn i | Sval (r,t) -> let def = pp_type false [] t in let name = pp_global Term r in hov 2 (str "val " ++ name ++ str " :" ++ spc () ++ def) | Stype (r,vl,ot) -> let name = pp_global Type r in let l = rename_tvars keywords vl in let ids, def = try let ids, s = find_type_custom r in pp_string_parameters ids, str " =" ++ spc () ++ str s with Not_found -> let ids = pp_parameters l in match ot with | None -> ids, mt () | Some Taxiom -> ids, str " (* AXIOM TO BE REALIZED *)" | Some t -> ids, str " =" ++ spc () ++ pp_type false l t in hov 2 (str "type " ++ ids ++ name ++ def) let pp_alias_spec ren = function | Sind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } | Stype (r,l,_) -> let name = pp_global Type r in let l = rename_tvars keywords l in let ids = pp_parameters l in hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ str (ren^".") ++ name) | Sval _ -> assert false let rec pp_specif = function | (_,Spec (Sval _ as s)) -> pp_spec s | (l,Spec s) -> (try let ren = Common.check_duplicate (top_visible_mp ()) l in hov 1 (str ("module "^ren^" : sig") ++ fnl () ++ pp_spec s) ++ fnl () ++ str "end" ++ fnl () ++ pp_alias_spec ren s with Not_found -> pp_spec s) | (l,Smodule mt) -> let def = pp_module_type [] mt in let def' = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module " ++ name ++ str " :" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ hov 1 (str ("module "^ren^" :") ++ fnl () ++ def') with Not_found -> Pp.mt ()) | (l,Smodtype mt) -> let def = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module type " ++ name ++ str " =" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module type "^ren^" = ") ++ name with Not_found -> Pp.mt ()) and pp_module_type params = function | MTident kn -> pp_modname kn | MTfunsig (mbid, mt, mt') -> let typ = pp_module_type [] mt in let name = pp_modname (MPbound mbid) in let def = pp_module_type (MPbound mbid :: params) mt' in str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def | MTsig (mp, sign) -> push_visible mp params; let try_pp_specif l x = let px = pp_specif x in if Pp.is_empty px then l else px::l in (* We cannot use fold_right here due to side effects in pp_specif *) let l = List.fold_left try_pp_specif [] sign in let l = List.rev l in pop_visible (); str "sig" ++ fnl () ++ v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ fnl () ++ str "end" | MTwith(mt,ML_With_type(idl,vl,typ)) -> let ids = pp_parameters (rename_tvars keywords vl) in let mp_mt = msid_of_mt mt in let l,idl' = List.sep_last idl in let mp_w = List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl' in let r = ConstRef (Constant.make2 mp_w (Label.of_id l)) in push_visible mp_mt []; let pp_w = str " with type " ++ ids ++ pp_global Type r in pop_visible(); pp_module_type [] mt ++ pp_w ++ str " = " ++ pp_type false vl typ | MTwith(mt,ML_With_module(idl,mp)) -> let mp_mt = msid_of_mt mt in let mp_w = List.fold_left (fun mp id -> MPdot(mp,Label.of_id id)) mp_mt idl in push_visible mp_mt []; let pp_w = str " with module " ++ pp_modname mp_w in pop_visible (); pp_module_type [] mt ++ pp_w ++ str " = " ++ pp_modname mp let is_short = function MEident _ | MEapply _ -> true | _ -> false let rec pp_structure_elem = function | (l,SEdecl d) -> (try let ren = Common.check_duplicate (top_visible_mp ()) l in hov 1 (str ("module "^ren^" = struct") ++ fnl () ++ pp_decl d) ++ fnl () ++ str "end" ++ fnl () ++ pp_alias_decl ren d with Not_found -> pp_decl d) | (l,SEmodule m) -> let typ = (* virtual printing of the type, in order to have a correct mli later*) if Common.get_phase () == Pre then str ": " ++ pp_module_type [] m.ml_mod_type else mt () in let def = pp_module_expr [] m.ml_mod_expr in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module " ++ name ++ typ ++ str " =" ++ (if is_short m.ml_mod_expr then spc () else fnl ()) ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module "^ren^" = ") ++ name with Not_found -> mt ()) | (l,SEmodtype m) -> let def = pp_module_type [] m in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module type " ++ name ++ str " =" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module type "^ren^" = ") ++ name with Not_found -> mt ()) and pp_module_expr params = function | MEident mp -> pp_modname mp | MEapply (me, me') -> pp_module_expr [] me ++ str "(" ++ pp_module_expr [] me' ++ str ")" | MEfunctor (mbid, mt, me) -> let name = pp_modname (MPbound mbid) in let typ = pp_module_type [] mt in let def = pp_module_expr (MPbound mbid :: params) me in str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def | MEstruct (mp, sel) -> push_visible mp params; let try_pp_structure_elem l x = let px = pp_structure_elem x in if Pp.is_empty px then l else px::l in (* We cannot use fold_right here due to side effects in pp_structure_elem *) let l = List.fold_left try_pp_structure_elem [] sel in let l = List.rev l in pop_visible (); str "struct" ++ fnl () ++ v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ fnl () ++ str "end" let rec prlist_sep_nonempty sep f = function | [] -> mt () | [h] -> f h | h::t -> let e = f h in let r = prlist_sep_nonempty sep f t in if Pp.is_empty e then r else e ++ sep () ++ r let do_struct f s = let ppl (mp,sel) = push_visible mp []; let p = prlist_sep_nonempty cut2 f sel in (* for monolithic extraction, we try to simulate the unavailability of [MPfile] in names by artificially nesting these [MPfile] *) (if modular () then pop_visible ()); p in let p = prlist_sep_nonempty cut2 ppl s in (if not (modular ()) then repeat (List.length s) pop_visible ()); v 0 p ++ fnl () let pp_struct s = do_struct pp_structure_elem s let pp_signature s = do_struct pp_specif s let ocaml_descr = { keywords = keywords; file_suffix = ".ml"; file_naming = file_of_modfile; preamble = preamble; pp_struct = pp_struct; sig_suffix = Some ".mli"; sig_preamble = sig_preamble; pp_sig = pp_signature; pp_decl = pp_decl; } coq-8.6/plugins/extraction/haskell.mli0000644000175000017500000000107113022274260017445 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "Prelude.Integer" [ "0" "Prelude.succ" ] "(\fO fS n -> if n Prelude.== 0 then fO () else fS (n Prelude.- 1))". coq-8.6/plugins/setoid_ring/0000755000175000017500000000000013022274260015446 5ustar mdenesmdenescoq-8.6/plugins/setoid_ring/newring_ast.mli0000644000175000017500000000376013022274260020477 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* : non commutative polynomials on a commutative ring A *) Set Implicit Arguments. Require Import Setoid. Require Import BinList. Require Import BinPos. Require Import BinNat. Require Import BinInt. Require Export Ring_polynom. (* n'utilise que PExpr *) Require Export Ncring. Section MakeRingPol. Context (C R:Type) `{Rh:Ring_morphism C R}. Variable phiCR_comm: forall (c:C)(x:R), x * [c] == [c] * x. Ltac rsimpl := repeat (gen_rewrite || rewrite phiCR_comm). Ltac add_push := gen_add_push . (* Definition of non commutative multivariable polynomials with coefficients in C : *) Inductive Pol : Type := | Pc : C -> Pol | PX : Pol -> positive -> positive -> Pol -> Pol. (* PX P i n Q represents P * X_i^n + Q *) Definition cO:C . exact ring0. Defined. Definition cI:C . exact ring1. Defined. Definition P0 := Pc 0. Definition P1 := Pc 1. Variable Ceqb:C->C->bool. Class Equalityb (A : Type):= {equalityb : A -> A -> bool}. Notation "x =? y" := (equalityb x y) (at level 70, no associativity). Variable Ceqb_eq: forall x y:C, Ceqb x y = true -> (x == y). Instance equalityb_coef : Equalityb C := {equalityb x y := Ceqb x y}. Fixpoint Peq (P P' : Pol) {struct P'} : bool := match P, P' with | Pc c, Pc c' => c =? c' | PX P i n Q, PX P' i' n' Q' => match Pos.compare i i', Pos.compare n n' with | Eq, Eq => if Peq P P' then Peq Q Q' else false | _,_ => false end | _, _ => false end. Instance equalityb_pol : Equalityb Pol := {equalityb x y := Peq x y}. (* Q a ses variables de queue < i *) Definition mkPX P i n Q := match P with | Pc c => if c =? 0 then Q else PX P i n Q | PX P' i' n' Q' => match Pos.compare i i' with | Eq => if Q' =? P0 then PX P' i (n + n') Q else PX P i n Q | _ => PX P i n Q end end. Definition mkXi i n := PX P1 i n P0. Definition mkX i := mkXi i 1. (** Opposite of addition *) Fixpoint Popp (P:Pol) : Pol := match P with | Pc c => Pc (- c) | PX P i n Q => PX (Popp P) i n (Popp Q) end. Notation "-- P" := (Popp P)(at level 30). (** Addition et subtraction *) Fixpoint PaddCl (c:C)(P:Pol) {struct P} : Pol := match P with | Pc c1 => Pc (c + c1) | PX P i n Q => PX P i n (PaddCl c Q) end. (* Q quelconque *) Section PaddX. Variable Padd:Pol->Pol->Pol. Variable P:Pol. (* Xi^n * P + Q les variables de tete de Q ne sont pas forcement < i mais Q est normalisé : variables de tete decroissantes *) Fixpoint PaddX (i n:positive)(Q:Pol){struct Q}:= match Q with | Pc c => mkPX P i n Q | PX P' i' n' Q' => match Pos.compare i i' with | (* i > i' *) Gt => mkPX P i n Q | (* i < i' *) Lt => mkPX P' i' n' (PaddX i n Q') | (* i = i' *) Eq => match Z.pos_sub n n' with | (* n > n' *) Zpos k => mkPX (PaddX i k P') i' n' Q' | (* n = n' *) Z0 => mkPX (Padd P P') i n Q' | (* n < n' *) Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q' end end end. End PaddX. Fixpoint Padd (P1 P2: Pol) {struct P1} : Pol := match P1 with | Pc c => PaddCl c P2 | PX P' i' n' Q' => PaddX Padd P' i' n' (Padd Q' P2) end. Notation "P ++ P'" := (Padd P P'). Definition Psub(P P':Pol):= P ++ (--P'). Notation "P -- P'" := (Psub P P')(at level 50). (** Multiplication *) Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := match P with | Pc c' => Pc (c' * c) | PX P i n Q => mkPX (PmulC_aux P c) i n (PmulC_aux Q c) end. Definition PmulC P c := if c =? 0 then P0 else if c =? 1 then P else PmulC_aux P c. Fixpoint Pmul (P1 P2 : Pol) {struct P2} : Pol := match P2 with | Pc c => PmulC P1 c | PX P i n Q => PaddX Padd (Pmul P1 P) i n (Pmul P1 Q) end. Notation "P ** P'" := (Pmul P P')(at level 40). Definition Psquare (P:Pol) : Pol := P ** P. (** Evaluation of a polynomial towards R *) Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R := match P with | Pc c => [c] | PX P i n Q => let x := nth 0 i l in let xn := pow_pos x n in (Pphi l P) * xn + (Pphi l Q) end. Reserved Notation "P @ l " (at level 10, no associativity). Notation "P @ l " := (Pphi l P). (** Proofs *) Ltac destr_pos_sub H := match goal with |- context [Z.pos_sub ?x ?y] => assert (H := Z.pos_sub_discr x y); destruct (Z.pos_sub x y) end. Lemma Peq_ok : forall P P', (P =? P') = true -> forall l, P@l == P'@ l. Proof. induction P;destruct P';simpl;intros ;try easy. - now apply ring_morphism_eq, Ceqb_eq. - specialize (IHP1 P'1). specialize (IHP2 P'2). simpl in IHP1, IHP2. destruct (Pos.compare_spec p p1); try discriminate; destruct (Pos.compare_spec p0 p2); try discriminate. destruct (Peq P2 P'1); try discriminate. subst; now rewrite IHP1, IHP2. Qed. Lemma Pphi0 : forall l, P0@l == 0. Proof. intros;simpl. rewrite ring_morphism0. reflexivity. Qed. Lemma Pphi1 : forall l, P1@l == 1. Proof. intros;simpl; rewrite ring_morphism1. reflexivity. Qed. Lemma mkPX_ok : forall l P i n Q, (mkPX P i n Q)@l == P@l * (pow_pos (nth 0 i l) n) + Q@l. Proof. intros l P i n Q;unfold mkPX. destruct P;try (simpl;reflexivity). assert (Hh := ring_morphism_eq c 0). simpl; case_eq (Ceqb c 0);simpl;try reflexivity. intros. rewrite Hh. rewrite ring_morphism0. rsimpl. apply Ceqb_eq. trivial. destruct (Pos.compare_spec i p). assert (Hh := @Peq_ok P3 P0). case_eq (P3=? P0). intro. simpl. rewrite Hh. rewrite Pphi0. rsimpl. rewrite Pos.add_comm. rewrite pow_pos_add;rsimpl. subst;trivial. reflexivity. trivial. intros. simpl. reflexivity. simpl. reflexivity. simpl. reflexivity. Qed. Ltac Esimpl := repeat (progress ( match goal with | |- context [?P@?l] => match P with | P0 => rewrite (Pphi0 l) | P1 => rewrite (Pphi1 l) | (mkPX ?P ?i ?n ?Q) => rewrite (mkPX_ok l P i n Q) end | |- context [[?c]] => match c with | 0 => rewrite ring_morphism0 | 1 => rewrite ring_morphism1 | ?x + ?y => rewrite ring_morphism_add | ?x * ?y => rewrite ring_morphism_mul | ?x - ?y => rewrite ring_morphism_sub | - ?x => rewrite ring_morphism_opp end end)); simpl; rsimpl. Lemma PaddCl_ok : forall c P l, (PaddCl c P)@l == [c] + P@l . Proof. induction P; simpl; intros; Esimpl; try reflexivity. rewrite IHP2. rsimpl. rewrite (ring_add_comm (P2 @ l * pow_pos (nth 0 p l) p0) [c]). reflexivity. Qed. Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c]. Proof. induction P;simpl;intros. rewrite ring_morphism_mul. try reflexivity. simpl. Esimpl. rewrite IHP1;rewrite IHP2;rsimpl. Qed. Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. Proof. intros c P l; unfold PmulC. assert (Hh:= ring_morphism_eq c 0);case_eq (c =? 0). intros. rewrite Hh;Esimpl. apply Ceqb_eq;trivial. assert (H1h:= ring_morphism_eq c 1);case_eq (c =? 1);intros. rewrite H1h;Esimpl. apply Ceqb_eq;trivial. apply PmulC_aux_ok. Qed. Lemma Popp_ok : forall P l, (--P)@l == - P@l. Proof. induction P;simpl;intros. Esimpl. rewrite IHP1;rewrite IHP2;rsimpl. Qed. Ltac Esimpl2 := Esimpl; repeat (progress ( match goal with | |- context [(PaddCl ?c ?P)@?l] => rewrite (PaddCl_ok c P l) | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l) | |- context [(--?P)@?l] => rewrite (Popp_ok P l) end)); Esimpl. Lemma PaddXPX: forall P i n Q, PaddX Padd P i n Q = match Q with | Pc c => mkPX P i n Q | PX P' i' n' Q' => match Pos.compare i i' with | (* i > i' *) Gt => mkPX P i n Q | (* i < i' *) Lt => mkPX P' i' n' (PaddX Padd P i n Q') | (* i = i' *) Eq => match Z.pos_sub n n' with | (* n > n' *) Zpos k => mkPX (PaddX Padd P i k P') i' n' Q' | (* n = n' *) Z0 => mkPX (Padd P P') i n Q' | (* n < n' *) Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q' end end end. induction Q; reflexivity. Qed. Lemma PaddX_ok2 : forall P2, (forall P l, (P2 ++ P) @ l == P2 @ l + P @ l) /\ (forall P k n l, (PaddX Padd P2 k n P) @ l == P2 @ l * pow_pos (nth 0 k l) n + P @ l). induction P2;simpl;intros. split. intros. apply PaddCl_ok. induction P. unfold PaddX. intros. rewrite mkPX_ok. simpl. rsimpl. intros. simpl. destruct (Pos.compare_spec k p) as [Hh|Hh|Hh]. destr_pos_sub H1h. Esimpl2. rewrite Hh; trivial. rewrite H1h. reflexivity. simpl. rewrite mkPX_ok. rewrite IHP1. Esimpl2. rewrite Pos.add_comm in H1h. rewrite H1h. rewrite pow_pos_add. Esimpl2. rewrite Hh; trivial. reflexivity. rewrite mkPX_ok. rewrite PaddCl_ok. Esimpl2. rewrite Pos.add_comm in H1h. rewrite H1h. Esimpl2. rewrite pow_pos_add. Esimpl2. rewrite Hh; trivial. reflexivity. rewrite mkPX_ok. rewrite IHP2. Esimpl2. rewrite (ring_add_comm (P2 @ l * pow_pos (nth 0 p l) p0) ([c] * pow_pos (nth 0 k l) n)). reflexivity. assert (H1h := ring_morphism_eq c 0);case_eq (Ceqb c 0); intros; simpl. rewrite H1h;trivial. Esimpl2. apply Ceqb_eq; trivial. reflexivity. decompose [and] IHP2_1. decompose [and] IHP2_2. clear IHP2_1 IHP2_2. split. intros. rewrite H0. rewrite H1. Esimpl2. induction P. unfold PaddX. intros. rewrite mkPX_ok. simpl. reflexivity. intros. rewrite PaddXPX. destruct (Pos.compare_spec k p1) as [H3h|H3h|H3h]. destr_pos_sub H4h. rewrite mkPX_ok. simpl. rewrite H0. rewrite H1. Esimpl2. rewrite H4h. rewrite H3h;trivial. reflexivity. rewrite mkPX_ok. rewrite IHP1. Esimpl2. rewrite H3h;trivial. rewrite Pos.add_comm in H4h. rewrite H4h. rewrite pow_pos_add. Esimpl2. rewrite mkPX_ok. simpl. rewrite H0. rewrite H1. rewrite mkPX_ok. Esimpl2. rewrite H3h;trivial. rewrite Pos.add_comm in H4h. rewrite H4h. rewrite pow_pos_add. Esimpl2. rewrite mkPX_ok. simpl. rewrite IHP2. Esimpl2. gen_add_push (P2 @ l * pow_pos (nth 0 p1 l) p2). try reflexivity. rewrite mkPX_ok. simpl. reflexivity. Qed. Lemma Padd_ok : forall P Q l, (P ++ Q) @ l == P @ l + Q @ l. intro P. elim (PaddX_ok2 P); auto. Qed. Lemma PaddX_ok : forall P2 P k n l, (PaddX Padd P2 k n P) @ l == P2 @ l * pow_pos (nth 0 k l) n + P @ l. intro P2. elim (PaddX_ok2 P2); auto. Qed. Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. unfold Psub. intros. rewrite Padd_ok. rewrite Popp_ok. rsimpl. Qed. Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. induction P'; simpl; intros. rewrite PmulC_ok. reflexivity. rewrite PaddX_ok. rewrite IHP'1. rewrite IHP'2. Esimpl2. Qed. Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l. Proof. intros. unfold Psquare. apply Pmul_ok. Qed. (** Definition of polynomial expressions *) (* Inductive PExpr : Type := | PEc : C -> PExpr | PEX : positive -> PExpr | PEadd : PExpr -> PExpr -> PExpr | PEsub : PExpr -> PExpr -> PExpr | PEmul : PExpr -> PExpr -> PExpr | PEopp : PExpr -> PExpr | PEpow : PExpr -> N -> PExpr. *) (** Specification of the power function *) Section POWER. Variable Cpow : Set. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Record power_theory : Prop := mkpow_th { rpow_pow_N : forall r n, (rpow r (Cp_phi n))== (pow_N r n) }. End POWER. Variable Cpow : Set. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory Cp_phi rpow. (** evaluation of polynomial expressions towards R *) Fixpoint PEeval (l:list R) (pe:PExpr C) {struct pe} : R := match pe with | PEO => 0 | PEI => 1 | PEc c => [c] | PEX _ j => nth 0 j l | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) | PEopp pe1 => - (PEeval l pe1) | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) end. Strategy expand [PEeval]. Definition mk_X j := mkX j. (** Correctness proofs *) Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l. Proof. destruct p;simpl;intros;Esimpl;trivial. Qed. Ltac Esimpl3 := repeat match goal with | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P1 P2 l) | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P1 P2 l) end;try Esimpl2;try reflexivity;try apply ring_add_comm. (* Power using the chinise algorithm *) Section POWER2. Variable subst_l : Pol -> Pol. Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := match p with | xH => subst_l (Pmul P res) | xO p => Ppow_pos (Ppow_pos res P p) P p | xI p => subst_l (Pmul P (Ppow_pos (Ppow_pos res P p) P p)) end. Definition Ppow_N P n := match n with | N0 => P1 | Npos p => Ppow_pos P1 P p end. Fixpoint pow_pos_gen (R:Type)(m:R->R->R)(x:R) (i:positive) {struct i}: R := match i with | xH => x | xO i => let p := pow_pos_gen m x i in m p p | xI i => let p := pow_pos_gen m x i in m x (m p p) end. Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> forall res P p, (Ppow_pos res P p)@l == (pow_pos_gen Pmul P p)@l * res@l. Proof. intros l subst_l_ok res P p. generalize res;clear res. induction p;simpl;intros. try rewrite subst_l_ok. repeat rewrite Pmul_ok. repeat rewrite IHp. rsimpl. repeat rewrite Pmul_ok. repeat rewrite IHp. rsimpl. try rewrite subst_l_ok. repeat rewrite Pmul_ok. reflexivity. Qed. Definition pow_N_gen (R:Type)(x1:R)(m:R->R->R)(x:R) (p:N) := match p with | N0 => x1 | Npos p => pow_pos_gen m x p end. Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> forall P n, (Ppow_N P n)@l == (pow_N_gen P1 Pmul P n)@l. Proof. destruct n;simpl. reflexivity. rewrite Ppow_pos_ok; trivial. Esimpl. Qed. End POWER2. (** Normalization and rewriting *) Section NORM_SUBST_REC. Let subst_l (P:Pol) := P. Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). Let Ppow_subst := Ppow_N subst_l. Fixpoint norm_aux (pe:PExpr C) : Pol := match pe with | PEO => Pc cO | PEI => Pc cI | PEc c => Pc c | PEX _ j => mk_X j | PEadd pe1 (PEopp pe2) => Psub (norm_aux pe1) (norm_aux pe2) | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) | PEopp pe1 => Popp (norm_aux pe1) | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n end. Definition norm_subst pe := subst_l (norm_aux pe). Lemma norm_aux_spec : forall l pe, PEeval l pe == (norm_aux pe)@l. Proof. intros. induction pe. - now simpl; rewrite <- ring_morphism0. - now simpl; rewrite <- ring_morphism1. - Esimpl3. - Esimpl3. - simpl. rewrite IHpe1;rewrite IHpe2. destruct pe2; Esimpl3. unfold Psub. destruct pe1; destruct pe2; rewrite Padd_ok; rewrite Popp_ok; reflexivity. - simpl. unfold Psub. rewrite IHpe1;rewrite IHpe2. now destruct pe1; [destruct pe2; rewrite Padd_ok; rewrite Popp_ok; Esimpl3 | Esimpl3..]. - simpl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. reflexivity. - now simpl; rewrite IHpe; Esimpl3. - simpl. rewrite Ppow_N_ok; (intros;try reflexivity). rewrite rpow_pow_N; [| now apply pow_th]. induction n;simpl; [now Esimpl3|]. induction p; simpl; trivial. + try rewrite IHp;try rewrite IHpe; repeat rewrite Pms_ok; repeat rewrite Pmul_ok;reflexivity. + rewrite Pmul_ok. try rewrite IHp;try rewrite IHpe; repeat rewrite Pms_ok; repeat rewrite Pmul_ok;reflexivity. Qed. Lemma norm_subst_spec : forall l pe, PEeval l pe == (norm_subst pe)@l. Proof. intros;unfold norm_subst. unfold subst_l. apply norm_aux_spec. Qed. End NORM_SUBST_REC. Fixpoint interp_PElist (l:list R) (lpe:list (PExpr C * PExpr C)) {struct lpe} : Prop := match lpe with | nil => True | (me,pe)::lpe => match lpe with | nil => PEeval l me == PEeval l pe | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe end end. Lemma norm_subst_ok : forall l pe, PEeval l pe == (norm_subst pe)@l. Proof. intros;apply norm_subst_spec. Qed. Lemma ring_correct : forall l pe1 pe2, (norm_subst pe1 =? norm_subst pe2) = true -> PEeval l pe1 == PEeval l pe2. Proof. simpl;intros. do 2 (rewrite (norm_subst_ok l);trivial). apply Peq_ok;trivial. Qed. End MakeRingPol. coq-8.6/plugins/setoid_ring/Rings_Z.v0000644000175000017500000000051013022274260017204 0ustar mdenesmdenesRequire Export Cring. Require Export Integral_domain. Require Export Ncring_initial. Require Export Omega. Instance Zcri: (Cring (Rr:=Zr)). red. exact Z.mul_comm. Defined. Lemma Z_one_zero: 1%Z <> 0%Z. omega. Qed. Instance Zdi : (Integral_domain (Rcr:=Zcri)). constructor. exact Zmult_integral. exact Z_one_zero. Defined. coq-8.6/plugins/setoid_ring/newring.mli0000644000175000017500000000440113022274260017621 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Id.t -> unit Proofview.tactic val protect_tac : string -> unit Proofview.tactic val closed_term : constr -> global_reference list -> unit Proofview.tactic val process_ring_mods : constr_expr ring_mod list -> constr coeff_spec * (constr * constr) option * cst_tac_spec option * raw_tactic_expr option * raw_tactic_expr option * (cst_tac_spec * constr_expr) option * constr_expr option * constr_expr option val add_theory : Id.t -> Evd.evar_map * constr -> (constr * constr) option -> constr coeff_spec -> cst_tac_spec option -> raw_tactic_expr option * raw_tactic_expr option -> (cst_tac_spec * constr_expr) option -> constr_expr option -> constr_expr option -> unit val ic : constr_expr -> Evd.evar_map * constr val from_name : ring_info Spmap.t ref val ring_lookup : Geninterp.Val.t -> constr list -> constr list -> constr -> unit Proofview.tactic val process_field_mods : constr_expr field_mod list -> constr coeff_spec * (constr * constr) option * constr option * cst_tac_spec option * raw_tactic_expr option * raw_tactic_expr option * (cst_tac_spec * constr_expr) option * constr_expr option * constr_expr option val add_field_theory : Id.t -> Evd.evar_map * constr -> (constr * constr) option -> constr coeff_spec -> cst_tac_spec option -> constr option -> raw_tactic_expr option * raw_tactic_expr option -> (cst_tac_spec * constr_expr) option -> constr_expr option -> constr_expr option -> unit val field_from_name : field_info Spmap.t ref val field_lookup : Geninterp.Val.t -> constr list -> constr list -> constr -> unit Proofview.tactic coq-8.6/plugins/setoid_ring/BinList.v0000644000175000017500000000424013022274260017201 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* tl l | xO p => jump p (jump p l) | xI p => jump p (jump p (tl l)) end. Fixpoint nth (p:positive) (l:list A) {struct p} : A:= match p with | xH => hd default l | xO p => nth p (jump p l) | xI p => nth p (jump p (tl l)) end. Lemma jump_tl : forall j l, tl (jump j l) = jump j (tl l). Proof. induction j;simpl;intros; now rewrite ?IHj. Qed. Lemma jump_succ : forall j l, jump (Pos.succ j) l = jump 1 (jump j l). Proof. induction j;simpl;intros. - rewrite !IHj; simpl; now rewrite !jump_tl. - now rewrite !jump_tl. - trivial. Qed. Lemma jump_add : forall i j l, jump (i + j) l = jump i (jump j l). Proof. induction i using Pos.peano_ind; intros. - now rewrite Pos.add_1_l, jump_succ. - now rewrite Pos.add_succ_l, !jump_succ, IHi. Qed. Lemma jump_pred_double : forall i l, jump (Pos.pred_double i) (tl l) = jump i (jump i l). Proof. induction i;intros;simpl. - now rewrite !jump_tl. - now rewrite IHi, <- 2 jump_tl, IHi. - trivial. Qed. Lemma nth_jump : forall p l, nth p (tl l) = hd default (jump p l). Proof. induction p;simpl;intros. - now rewrite <-jump_tl, IHp. - now rewrite <-jump_tl, IHp. - trivial. Qed. Lemma nth_pred_double : forall p l, nth (Pos.pred_double p) (tl l) = nth p (jump p l). Proof. induction p;simpl;intros. - now rewrite !jump_tl. - now rewrite jump_pred_double, <- !jump_tl, IHp. - trivial. Qed. End MakeBinList. coq-8.6/plugins/setoid_ring/InitialRing.v0000644000175000017500000006120713022274260020054 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R->R) (ropp : R -> R). Variable req : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Variable Rsth : Setoid_Theory R req. Add Setoid R req Rsth as R_setoid3. Ltac rrefl := gen_reflexivity Rsth. Variable Reqe : ring_eq_ext radd rmul ropp req. Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed. Fixpoint gen_phiPOS1 (p:positive) : R := match p with | xH => 1 | xO p => (1 + 1) * (gen_phiPOS1 p) | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p)) end. Fixpoint gen_phiPOS (p:positive) : R := match p with | xH => 1 | xO xH => (1 + 1) | xO p => (1 + 1) * (gen_phiPOS p) | xI xH => 1 + (1 +1) | xI p => 1 + ((1 + 1) * (gen_phiPOS p)) end. Definition gen_phiZ1 z := match z with | Zpos p => gen_phiPOS1 p | Z0 => 0 | Zneg p => -(gen_phiPOS1 p) end. Definition gen_phiZ z := match z with | Zpos p => gen_phiPOS p | Z0 => 0 | Zneg p => -(gen_phiPOS p) end. Notation "[ x ]" := (gen_phiZ x). Definition get_signZ z := match z with | Zneg p => Some (Zpos p) | _ => None end. Lemma get_signZ_th : sign_theory Z.opp Zeq_bool get_signZ. Proof. constructor. destruct c;intros;try discriminate. injection H as <-. simpl. unfold Zeq_bool. rewrite Z.compare_refl. trivial. Qed. Section ALMOST_RING. Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. Add Morphism rsub : rsub_ext3. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. Proof. induction x;simpl. rewrite IHx;destruct x;simpl;norm. rewrite IHx;destruct x;simpl;norm. rrefl. Qed. Lemma ARgen_phiPOS_Psucc : forall x, gen_phiPOS1 (Pos.succ x) == 1 + (gen_phiPOS1 x). Proof. induction x;simpl;norm. rewrite IHx;norm. add_push 1;rrefl. Qed. Lemma ARgen_phiPOS_add : forall x y, gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y). Proof. induction x;destruct y;simpl;norm. rewrite Pos.add_carry_spec. rewrite ARgen_phiPOS_Psucc. rewrite IHx;norm. add_push (gen_phiPOS1 y);add_push 1;rrefl. rewrite IHx;norm;add_push (gen_phiPOS1 y);rrefl. rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl. rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;rrefl. rewrite IHx;norm;add_push(gen_phiPOS1 y);rrefl. add_push 1;rrefl. rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl. Qed. Lemma ARgen_phiPOS_mult : forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y. Proof. induction x;intros;simpl;norm. rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm. rewrite IHx;rrefl. Qed. End ALMOST_RING. Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. Let ARth := Rth_ARth Rsth Reqe Rth. Add Morphism rsub : rsub_ext4. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. (*morphisms are extensionally equal*) Lemma same_genZ : forall x, [x] == gen_phiZ1 x. Proof. destruct x;simpl; try rewrite (same_gen ARth);rrefl. Qed. Lemma gen_Zeqb_ok : forall x y, Zeq_bool x y = true -> [x] == [y]. Proof. intros x y H. assert (H1 := Zeq_bool_eq x y H);unfold IDphi in H1. rewrite H1;rrefl. Qed. Lemma gen_phiZ1_pos_sub : forall x y, gen_phiZ1 (Z.pos_sub x y) == gen_phiPOS1 x + -gen_phiPOS1 y. Proof. intros x y. rewrite Z.pos_sub_spec. case Pos.compare_spec; intros H; simpl. rewrite H. rewrite (Ropp_def Rth);rrefl. rewrite <- (Pos.sub_add y x H) at 2. rewrite Pos.add_comm. rewrite (ARgen_phiPOS_add ARth);simpl;norm. rewrite (Ropp_def Rth);norm. rewrite <- (Pos.sub_add x y H) at 2. rewrite (ARgen_phiPOS_add ARth);simpl;norm. add_push (gen_phiPOS1 (x-y));rewrite (Ropp_def Rth); norm. Qed. Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y]. Proof. intros x y; repeat rewrite same_genZ; generalize x y;clear x y. destruct x, y; simpl; norm. apply (ARgen_phiPOS_add ARth). apply gen_phiZ1_pos_sub. rewrite gen_phiZ1_pos_sub. apply (Radd_comm Rth). rewrite (ARgen_phiPOS_add ARth); norm. Qed. Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y]. Proof. intros x y;repeat rewrite same_genZ. destruct x;destruct y;simpl;norm; rewrite (ARgen_phiPOS_mult ARth);try (norm;fail). rewrite (Ropp_opp Rsth Reqe Rth);rrefl. Qed. Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y]. Proof. intros;subst;rrefl. Qed. (*proof that [.] satisfies morphism specifications*) Lemma gen_phiZ_morph : ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) Z.add Z.mul Z.sub Z.opp Zeq_bool gen_phiZ. Proof. assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) Z.add Z.mul Zeq_bool gen_phiZ). apply mkRmorph;simpl;try rrefl. apply gen_phiZ_add. apply gen_phiZ_mul. apply gen_Zeqb_ok. apply (Smorph_morph Rsth Reqe Rth Zth SRmorph gen_phiZ_ext). Qed. End ZMORPHISM. (** N is a semi-ring and a setoid*) Lemma Nsth : Setoid_Theory N (@eq N). Proof (Eqsth N). Lemma Nseqe : sring_eq_ext N.add N.mul (@eq N). Proof (Eq_s_ext N.add N.mul). Lemma Nth : semi_ring_theory 0%N 1%N N.add N.mul (@eq N). Proof. constructor. exact N.add_0_l. exact N.add_comm. exact N.add_assoc. exact N.mul_1_l. exact N.mul_0_l. exact N.mul_comm. exact N.mul_assoc. exact N.mul_add_distr_r. Qed. Definition Nsub := SRsub N.add. Definition Nopp := (@SRopp N). Lemma Neqe : ring_eq_ext N.add N.mul Nopp (@eq N). Proof (SReqe_Reqe Nseqe). Lemma Nath : almost_ring_theory 0%N 1%N N.add N.mul Nsub Nopp (@eq N). Proof (SRth_ARth Nsth Nth). Lemma Neqb_ok : forall x y, N.eqb x y = true -> x = y. Proof. exact (fun x y => proj1 (N.eqb_eq x y)). Qed. (**Same as above : definition of two, extensionally equal, generic morphisms *) (**from N to any semi-ring*) Section NMORPHISM. Variable R : Type. Variable (rO rI : R) (radd rmul: R->R->R). Variable req : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Variable Rsth : Setoid_Theory R req. Add Setoid R req Rsth as R_setoid4. Ltac rrefl := gen_reflexivity Rsth. Variable SReqe : sring_eq_ext radd rmul req. Variable SRth : semi_ring_theory 0 1 radd rmul req. Let ARth := SRth_ARth Rsth SRth. Let Reqe := SReqe_Reqe SReqe. Let ropp := (@SRopp R). Let rsub := (@SRsub R radd). Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Add Morphism radd : radd_ext4. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext4. exact (Rmul_ext Reqe). Qed. Ltac norm := gen_srewrite_sr Rsth Reqe ARth. Definition gen_phiN1 x := match x with | N0 => 0 | Npos x => gen_phiPOS1 1 radd rmul x end. Definition gen_phiN x := match x with | N0 => 0 | Npos x => gen_phiPOS 1 radd rmul x end. Notation "[ x ]" := (gen_phiN x). Lemma same_genN : forall x, [x] == gen_phiN1 x. Proof. destruct x;simpl. reflexivity. now rewrite (same_gen Rsth Reqe ARth). Qed. Lemma gen_phiN_add : forall x y, [x + y] == [x] + [y]. Proof. intros x y;repeat rewrite same_genN. destruct x;destruct y;simpl;norm. apply (ARgen_phiPOS_add Rsth Reqe ARth). Qed. Lemma gen_phiN_mult : forall x y, [x * y] == [x] * [y]. Proof. intros x y;repeat rewrite same_genN. destruct x;destruct y;simpl;norm. apply (ARgen_phiPOS_mult Rsth Reqe ARth). Qed. Lemma gen_phiN_sub : forall x y, [Nsub x y] == [x] - [y]. Proof. exact gen_phiN_add. Qed. (*gen_phiN satisfies morphism specifications*) Lemma gen_phiN_morph : ring_morph 0 1 radd rmul rsub ropp req 0%N 1%N N.add N.mul Nsub Nopp N.eqb gen_phiN. Proof. constructor; simpl; try reflexivity. apply gen_phiN_add. apply gen_phiN_sub. apply gen_phiN_mult. intros x y EQ. apply N.eqb_eq in EQ. now subst. Qed. End NMORPHISM. (* Words on N : initial structure for almost-rings. *) Definition Nword := list N. Definition NwO : Nword := nil. Definition NwI : Nword := 1%N :: nil. Definition Nwcons n (w : Nword) : Nword := match w, n with | nil, 0%N => nil | _, _ => n :: w end. Fixpoint Nwadd (w1 w2 : Nword) {struct w1} : Nword := match w1, w2 with | n1::w1', n2:: w2' => (n1+n2)%N :: Nwadd w1' w2' | nil, _ => w2 | _, nil => w1 end. Definition Nwopp (w:Nword) : Nword := Nwcons 0%N w. Definition Nwsub w1 w2 := Nwadd w1 (Nwopp w2). Fixpoint Nwscal (n : N) (w : Nword) {struct w} : Nword := match w with | m :: w' => (n*m)%N :: Nwscal n w' | nil => nil end. Fixpoint Nwmul (w1 w2 : Nword) {struct w1} : Nword := match w1 with | 0%N::w1' => Nwopp (Nwmul w1' w2) | n1::w1' => Nwsub (Nwscal n1 w2) (Nwmul w1' w2) | nil => nil end. Fixpoint Nw_is0 (w : Nword) : bool := match w with | nil => true | 0%N :: w' => Nw_is0 w' | _ => false end. Fixpoint Nweq_bool (w1 w2 : Nword) {struct w1} : bool := match w1, w2 with | n1::w1', n2::w2' => if N.eqb n1 n2 then Nweq_bool w1' w2' else false | nil, _ => Nw_is0 w2 | _, nil => Nw_is0 w1 end. Section NWORDMORPHISM. Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Variable Rsth : Setoid_Theory R req. Add Setoid R req Rsth as R_setoid5. Ltac rrefl := gen_reflexivity Rsth. Variable Reqe : ring_eq_ext radd rmul ropp req. Add Morphism radd : radd_ext5. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext5. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext5. exact (Ropp_ext Reqe). Qed. Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. Fixpoint gen_phiNword (w : Nword) : R := match w with | nil => 0 | n :: nil => gen_phiN rO rI radd rmul n | N0 :: w' => - gen_phiNword w' | n::w' => gen_phiN rO rI radd rmul n - gen_phiNword w' end. Lemma gen_phiNword0_ok : forall w, Nw_is0 w = true -> gen_phiNword w == 0. Proof. induction w; simpl; intros; auto. reflexivity. destruct a. destruct w. reflexivity. rewrite IHw; trivial. apply (ARopp_zero Rsth Reqe ARth). discriminate. Qed. Lemma gen_phiNword_cons : forall w n, gen_phiNword (n::w) == gen_phiN rO rI radd rmul n - gen_phiNword w. induction w. destruct n; simpl; norm. intros. destruct n; norm. Qed. Lemma gen_phiNword_Nwcons : forall w n, gen_phiNword (Nwcons n w) == gen_phiN rO rI radd rmul n - gen_phiNword w. destruct w; intros. destruct n; norm. unfold Nwcons. rewrite gen_phiNword_cons. reflexivity. Qed. Lemma gen_phiNword_ok : forall w1 w2, Nweq_bool w1 w2 = true -> gen_phiNword w1 == gen_phiNword w2. induction w1; intros. simpl. rewrite (gen_phiNword0_ok _ H). reflexivity. rewrite gen_phiNword_cons. destruct w2. simpl in H. destruct a; try discriminate. rewrite (gen_phiNword0_ok _ H). norm. simpl in H. rewrite gen_phiNword_cons. case_eq (N.eqb a n); intros H0. rewrite H0 in H. apply N.eqb_eq in H0. rewrite <- H0. rewrite (IHw1 _ H). reflexivity. rewrite H0 in H; discriminate H. Qed. Lemma Nwadd_ok : forall x y, gen_phiNword (Nwadd x y) == gen_phiNword x + gen_phiNword y. induction x; intros. simpl. norm. destruct y. simpl Nwadd; norm. simpl Nwadd. repeat rewrite gen_phiNword_cons. rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) by (destruct Reqe; constructor; trivial). rewrite IHx. norm. add_push (- gen_phiNword x); reflexivity. Qed. Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x. simpl. unfold Nwopp; simpl. intros. rewrite gen_phiNword_Nwcons; norm. Qed. Lemma Nwscal_ok : forall n x, gen_phiNword (Nwscal n x) == gen_phiN rO rI radd rmul n * gen_phiNword x. induction x; intros. norm. simpl Nwscal. repeat rewrite gen_phiNword_cons. rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) by (destruct Reqe; constructor; trivial). rewrite IHx. norm. Qed. Lemma Nwmul_ok : forall x y, gen_phiNword (Nwmul x y) == gen_phiNword x * gen_phiNword y. induction x; intros. norm. destruct a. simpl Nwmul. rewrite Nwopp_ok. rewrite IHx. rewrite gen_phiNword_cons. norm. simpl Nwmul. unfold Nwsub. rewrite Nwadd_ok. rewrite Nwscal_ok. rewrite Nwopp_ok. rewrite IHx. rewrite gen_phiNword_cons. norm. Qed. (* Proof that [.] satisfies morphism specifications *) Lemma gen_phiNword_morph : ring_morph 0 1 radd rmul rsub ropp req NwO NwI Nwadd Nwmul Nwsub Nwopp Nweq_bool gen_phiNword. constructor. reflexivity. reflexivity. exact Nwadd_ok. intros. unfold Nwsub. rewrite Nwadd_ok. rewrite Nwopp_ok. norm. exact Nwmul_ok. exact Nwopp_ok. exact gen_phiNword_ok. Qed. End NWORDMORPHISM. Section GEN_DIV. Variables (R : Type) (rO : R) (rI : R) (radd : R -> R -> R) (rmul : R -> R -> R) (rsub : R -> R -> R) (ropp : R -> R) (req : R -> R -> Prop) (C : Type) (cO : C) (cI : C) (cadd : C -> C -> C) (cmul : C -> C -> C) (csub : C -> C -> C) (copp : C -> C) (ceqb : C -> C -> bool) (phi : C -> R). Variable Rsth : Setoid_Theory R req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. Variable morph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. (* Useful tactics *) Add Setoid R req Rsth as R_set1. Ltac rrefl := gen_reflexivity Rsth. Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac rsimpl := gen_srewrite Rsth Reqe ARth. Definition triv_div x y := if ceqb x y then (cI, cO) else (cO, x). Ltac Esimpl :=repeat (progress ( match goal with | |- context [phi cO] => rewrite (morph0 morph) | |- context [phi cI] => rewrite (morph1 morph) | |- context [phi (cadd ?x ?y)] => rewrite ((morph_add morph) x y) | |- context [phi (cmul ?x ?y)] => rewrite ((morph_mul morph) x y) | |- context [phi (csub ?x ?y)] => rewrite ((morph_sub morph) x y) | |- context [phi (copp ?x)] => rewrite ((morph_opp morph) x) end)). Lemma triv_div_th : Ring_theory.div_theory req cadd cmul phi triv_div. Proof. constructor. intros a b;unfold triv_div. assert (X:= morph.(morph_eq) a b);destruct (ceqb a b). Esimpl. rewrite X; trivial. rsimpl. Esimpl; rsimpl. Qed. Variable zphi : Z -> R. Lemma Ztriv_div_th : div_theory req Z.add Z.mul zphi Z.quotrem. Proof. constructor. intros; generalize (Z.quotrem_eq a b); case Z.quotrem; intros; subst. rewrite Z.mul_comm; rsimpl. Qed. Variable nphi : N -> R. Lemma Ntriv_div_th : div_theory req N.add N.mul nphi N.div_eucl. constructor. intros; generalize (N.div_eucl_spec a b); case N.div_eucl; intros; subst. rewrite N.mul_comm; rsimpl. Qed. End GEN_DIV. (* syntaxification of constants in an abstract ring: the inverse of gen_phiPOS *) Ltac inv_gen_phi_pos rI add mul t := let rec inv_cst t := match t with rI => constr:(1%positive) | (add rI rI) => constr:(2%positive) | (add rI (add rI rI)) => constr:(3%positive) | (mul (add rI rI) ?p) => (* 2p *) match inv_cst p with NotConstant => constr:(NotConstant) | 1%positive => constr:(NotConstant) (* 2*1 is not convertible to 2 *) | ?p => constr:(xO p) end | (add rI (mul (add rI rI) ?p)) => (* 1+2p *) match inv_cst p with NotConstant => constr:(NotConstant) | 1%positive => constr:(NotConstant) | ?p => constr:(xI p) end | _ => constr:(NotConstant) end in inv_cst t. (* The (partial) inverse of gen_phiNword *) Ltac inv_gen_phiNword rO rI add mul opp t := match t with rO => constr:(NwO) | _ => match inv_gen_phi_pos rI add mul t with NotConstant => constr:(NotConstant) | ?p => constr:(Npos p::nil) end end. (* The inverse of gen_phiN *) Ltac inv_gen_phiN rO rI add mul t := match t with rO => constr:(0%N) | _ => match inv_gen_phi_pos rI add mul t with NotConstant => constr:(NotConstant) | ?p => constr:(Npos p) end end. (* The inverse of gen_phiZ *) Ltac inv_gen_phiZ rO rI add mul opp t := match t with rO => constr:(0%Z) | (opp ?p) => match inv_gen_phi_pos rI add mul p with NotConstant => constr:(NotConstant) | ?p => constr:(Zneg p) end | _ => match inv_gen_phi_pos rI add mul t with NotConstant => constr:(NotConstant) | ?p => constr:(Zpos p) end end. (* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above are only optimisations that directly returns the reified constant instead of resorting to the constant propagation of the simplification algorithm. *) Ltac inv_gen_phi rO rI cO cI t := match t with | rO => cO | rI => cI end. (* A simple tactic recognizing no constant *) Ltac inv_morph_nothing t := constr:(NotConstant). Ltac coerce_to_almost_ring set ext rspec := match type of rspec with | ring_theory _ _ _ _ _ _ _ => constr:(Rth_ARth set ext rspec) | semi_ring_theory _ _ _ _ _ => constr:(SRth_ARth set rspec) | almost_ring_theory _ _ _ _ _ _ _ => rspec | _ => fail 1 "not a valid ring theory" end. Ltac coerce_to_ring_ext ext := match type of ext with | ring_eq_ext _ _ _ _ => ext | sring_eq_ext _ _ _ => constr:(SReqe_Reqe ext) | _ => fail 1 "not a valid ring_eq_ext theory" end. Ltac abstract_ring_morphism set ext rspec := match type of rspec with | ring_theory _ _ _ _ _ _ _ => constr:(gen_phiZ_morph set ext rspec) | semi_ring_theory _ _ _ _ _ => constr:(gen_phiN_morph set ext rspec) | almost_ring_theory _ _ _ _ _ _ _ => constr:(gen_phiNword_morph set ext rspec) | _ => fail 1 "bad ring structure" end. Record hypo : Type := mkhypo { hypo_type : Type; hypo_proof : hypo_type }. Ltac gen_ring_pow set arth pspec := match pspec with | None => match type of arth with | @almost_ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req => constr:(mkhypo (@pow_N_th R rI rmul req set)) | _ => fail 1 "gen_ring_pow" end | Some ?t => constr:(t) end. Ltac gen_ring_sign morph sspec := match sspec with | None => match type of morph with | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req Z ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => constr:(@mkhypo (sign_theory copp ceqb get_signZ) get_signZ_th) | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => constr:(mkhypo (@get_sign_None_th C copp ceqb)) | _ => fail 2 "ring anomaly : default_sign_spec" end | Some ?t => constr:(t) end. Ltac default_div_spec set reqe arth morph := match type of morph with | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req Z ?c0 ?c1 Z.add Z.mul ?csub ?copp ?ceq_b ?phi => constr:(mkhypo (Ztriv_div_th set phi)) | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req N ?c0 ?c1 N.add N.mul ?csub ?copp ?ceq_b ?phi => constr:(mkhypo (Ntriv_div_th set phi)) | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => constr:(mkhypo (triv_div_th set reqe arth morph)) | _ => fail 1 "ring anomaly : default_sign_spec" end. Ltac gen_ring_div set reqe arth morph dspec := match dspec with | None => default_div_spec set reqe arth morph | Some ?t => constr:(t) end. Ltac ring_elements set ext rspec pspec sspec dspec rk := let arth := coerce_to_almost_ring set ext rspec in let ext_r := coerce_to_ring_ext ext in let morph := match rk with | Abstract => abstract_ring_morphism set ext rspec | @Computational ?reqb_ok => match type of arth with | almost_ring_theory ?rO ?rI ?add ?mul ?sub ?opp _ => constr:(IDmorph rO rI add mul sub opp set _ reqb_ok) | _ => fail 2 "ring anomaly" end | @Morphism ?m => match type of m with | ring_morph _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => m | @semi_morph _ _ _ _ _ _ _ _ _ _ _ _ _ => constr:(SRmorph_Rmorph set m) | _ => fail 2 "ring anomaly" end | _ => fail 1 "ill-formed ring kind" end in let p_spec := gen_ring_pow set arth pspec in let s_spec := gen_ring_sign morph sspec in let d_spec := gen_ring_div set ext_r arth morph dspec in fun f => f arth ext_r morph p_spec s_spec d_spec. (* Given a ring structure and the kind of morphism, returns 2 lemmas (one for ring, and one for ring_simplify). *) Ltac ring_lemmas set ext rspec pspec sspec dspec rk := let gen_lemma2 := match pspec with | None => constr:(ring_rw_correct) | Some _ => constr:(ring_rw_pow_correct) end in ring_elements set ext rspec pspec sspec dspec rk ltac:(fun arth ext_r morph p_spec s_spec d_spec => match type of morph with | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => let gen_lemma2_0 := constr:(gen_lemma2 R r0 rI radd rmul rsub ropp req set ext_r arth C c0 c1 cadd cmul csub copp ceq_b phi morph) in match p_spec with | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec => let gen_lemma2_1 := constr:(gen_lemma2_0 _ Cp_phi rpow pp_spec) in match d_spec with | @mkhypo (div_theory _ _ _ _ ?cdiv) ?dd_spec => let gen_lemma2_2 := constr:(gen_lemma2_1 cdiv dd_spec) in match s_spec with | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec => let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in let lemma1 := constr:(ring_correct set ext_r arth morph pp_spec dd_spec) in fun f => f arth ext_r morph lemma1 lemma2 | _ => fail 4 "ring: bad sign specification" end | _ => fail 3 "ring: bad coefficient division specification" end | _ => fail 2 "ring: bad power specification" end | _ => fail 1 "ring internal error: ring_lemmas, please report" end). (* Tactic for constant *) Ltac isnatcst t := match t with O => constr:(true) | S ?p => isnatcst p | _ => constr:(false) end. Ltac isPcst t := match t with | xI ?p => isPcst p | xO ?p => isPcst p | xH => constr:(true) (* nat -> positive *) | Pos.of_succ_nat ?n => isnatcst n | _ => constr:(false) end. Ltac isNcst t := match t with N0 => constr:(true) | Npos ?p => isPcst p | _ => constr:(false) end. Ltac isZcst t := match t with Z0 => constr:(true) | Zpos ?p => isPcst p | Zneg ?p => isPcst p (* injection nat -> Z *) | Z.of_nat ?n => isnatcst n (* injection N -> Z *) | Z.of_N ?n => isNcst n (* *) | _ => constr:(false) end. coq-8.6/plugins/setoid_ring/ZArithRing.v0000644000175000017500000000300613022274260017655 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t | _ => constr:(NotConstant) end. Ltac isZpow_coef t := match t with | Zpos ?p => isPcst p | Z0 => constr:(true) | _ => constr:(false) end. Notation N_of_Z := Z.to_N (only parsing). Ltac Zpow_tac t := match isZpow_coef t with | true => constr:(N_of_Z t) | _ => constr:(NotConstant) end. Ltac Zpower_neg := repeat match goal with | [|- ?G] => match G with | context c [Z.pow _ (Zneg _)] => let t := context c [Z0] in change t end end. Add Ring Zr : Zth (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Z.succ], power_tac Zpower_theory [Zpow_tac], (* The following two options are not needed; they are the default choice when the set of coefficient is the usual ring Z *) div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)), sign get_signZ_th). coq-8.6/plugins/setoid_ring/Ncring.v0000644000175000017500000002241013022274260017054 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* T->T} {mul:T->T->T} {sub:T->T->T} {opp:T->T} {ring_eq:T->T->Prop}. Instance zero_notation(T:Type)`{Ring_ops T}:Zero T:= ring0. Instance one_notation(T:Type)`{Ring_ops T}:One T:= ring1. Instance add_notation(T:Type)`{Ring_ops T}:Addition T:= add. Instance mul_notation(T:Type)`{Ring_ops T}:@Multiplication T T:= mul. Instance sub_notation(T:Type)`{Ring_ops T}:Subtraction T:= sub. Instance opp_notation(T:Type)`{Ring_ops T}:Opposite T:= opp. Instance eq_notation(T:Type)`{Ring_ops T}:@Equality T:= ring_eq. Class Ring `{Ro:Ring_ops}:={ ring_setoid: Equivalence _==_; ring_plus_comp: Proper (_==_ ==> _==_ ==>_==_) _+_; ring_mult_comp: Proper (_==_ ==> _==_ ==>_==_) _*_; ring_sub_comp: Proper (_==_ ==> _==_ ==>_==_) _-_; ring_opp_comp: Proper (_==_==>_==_) -_; ring_add_0_l : forall x, 0 + x == x; ring_add_comm : forall x y, x + y == y + x; ring_add_assoc : forall x y z, x + (y + z) == (x + y) + z; ring_mul_1_l : forall x, 1 * x == x; ring_mul_1_r : forall x, x * 1 == x; ring_mul_assoc : forall x y z, x * (y * z) == (x * y) * z; ring_distr_l : forall x y z, (x + y) * z == x * z + y * z; ring_distr_r : forall x y z, z * ( x + y) == z * x + z * y; ring_sub_def : forall x y, x - y == x + -y; ring_opp_def : forall x, x + -x == 0 }. (* inutile! je sais plus pourquoi j'ai mis ca... Instance ring_Ring_ops(R:Type)`{Ring R} :@Ring_ops R 0 1 addition multiplication subtraction opposite equality. *) Existing Instance ring_setoid. Existing Instance ring_plus_comp. Existing Instance ring_mult_comp. Existing Instance ring_sub_comp. Existing Instance ring_opp_comp. Section Ring_power. Context {R:Type}`{Ring R}. Fixpoint pow_pos (x:R) (i:positive) {struct i}: R := match i with | xH => x | xO i => let p := pow_pos x i in p * p | xI i => let p := pow_pos x i in x * (p * p) end. Definition pow_N (x:R) (p:N) := match p with | N0 => 1 | Npos p => pow_pos x p end. End Ring_power. Definition ZN(x:Z):= match x with Z0 => N0 |Zpos p | Zneg p => Npos p end. Instance power_ring {R:Type}`{Ring R} : Power:= {power x y := pow_N x (ZN y)}. (** Interpretation morphisms definition*) Class Ring_morphism (C R:Type)`{Cr:Ring C} `{Rr:Ring R}`{Rh:Bracket C R}:= { ring_morphism0 : [0] == 0; ring_morphism1 : [1] == 1; ring_morphism_add : forall x y, [x + y] == [x] + [y]; ring_morphism_sub : forall x y, [x - y] == [x] - [y]; ring_morphism_mul : forall x y, [x * y] == [x] * [y]; ring_morphism_opp : forall x, [-x] == -[x]; ring_morphism_eq : forall x y, x == y -> [x] == [y]}. Section Ring. Context {R:Type}`{Rr:Ring R}. (* Powers *) Lemma pow_pos_comm : forall x j, x * pow_pos x j == pow_pos x j * x. Proof. induction j; simpl. rewrite <- ring_mul_assoc. rewrite <- ring_mul_assoc. rewrite <- IHj. rewrite (ring_mul_assoc (pow_pos x j) x (pow_pos x j)). rewrite <- IHj. rewrite <- ring_mul_assoc. reflexivity. rewrite <- ring_mul_assoc. rewrite <- IHj. rewrite ring_mul_assoc. rewrite IHj. rewrite <- ring_mul_assoc. rewrite IHj. reflexivity. reflexivity. Qed. Lemma pow_pos_succ : forall x j, pow_pos x (Pos.succ j) == x * pow_pos x j. Proof. induction j; simpl. rewrite IHj. rewrite <- (ring_mul_assoc x (pow_pos x j) (x * pow_pos x j)). rewrite (ring_mul_assoc (pow_pos x j) x (pow_pos x j)). rewrite <- pow_pos_comm. rewrite <- ring_mul_assoc. reflexivity. reflexivity. reflexivity. Qed. Lemma pow_pos_add : forall x i j, pow_pos x (i + j) == pow_pos x i * pow_pos x j. Proof. intro x;induction i;intros. rewrite Pos.xI_succ_xO;rewrite <- Pos.add_1_r. rewrite <- Pos.add_diag;repeat rewrite <- Pos.add_assoc. repeat rewrite IHi. rewrite Pos.add_comm;rewrite Pos.add_1_r; rewrite pow_pos_succ. simpl;repeat rewrite ring_mul_assoc. reflexivity. rewrite <- Pos.add_diag;repeat rewrite <- Pos.add_assoc. repeat rewrite IHi. rewrite ring_mul_assoc. reflexivity. rewrite Pos.add_comm;rewrite Pos.add_1_r;rewrite pow_pos_succ. simpl. reflexivity. Qed. Definition id_phi_N (x:N) : N := x. Lemma pow_N_pow_N : forall x n, pow_N x (id_phi_N n) == pow_N x n. Proof. intros; reflexivity. Qed. (** Identity is a morphism *) (* Instance IDmorph : Ring_morphism _ _ _ (fun x => x). Proof. apply (Build_Ring_morphism H6 H6 (fun x => x));intros; try reflexivity. trivial. Qed. *) (** rings are almost rings*) Lemma ring_mul_0_l : forall x, 0 * x == 0. Proof. intro x. setoid_replace (0*x) with ((0+1)*x + -x). rewrite ring_add_0_l. rewrite ring_mul_1_l . rewrite ring_opp_def . fold zero. reflexivity. rewrite ring_distr_l . rewrite ring_mul_1_l . rewrite <- ring_add_assoc ; rewrite ring_opp_def . rewrite ring_add_comm ; rewrite ring_add_0_l ;reflexivity. Qed. Lemma ring_mul_0_r : forall x, x * 0 == 0. Proof. intro x; setoid_replace (x*0) with (x*(0+1) + -x). rewrite ring_add_0_l ; rewrite ring_mul_1_r . rewrite ring_opp_def ; fold zero; reflexivity. rewrite ring_distr_r ;rewrite ring_mul_1_r . rewrite <- ring_add_assoc ; rewrite ring_opp_def . rewrite ring_add_comm ; rewrite ring_add_0_l ;reflexivity. Qed. Lemma ring_opp_mul_l : forall x y, -(x * y) == -x * y. Proof. intros x y;rewrite <- (ring_add_0_l (- x * y)). rewrite ring_add_comm . rewrite <- (ring_opp_def (x*y)). rewrite ring_add_assoc . rewrite <- ring_distr_l. rewrite (ring_add_comm (-x));rewrite ring_opp_def . rewrite ring_mul_0_l;rewrite ring_add_0_l ;reflexivity. Qed. Lemma ring_opp_mul_r : forall x y, -(x * y) == x * -y. Proof. intros x y;rewrite <- (ring_add_0_l (x * - y)). rewrite ring_add_comm . rewrite <- (ring_opp_def (x*y)). rewrite ring_add_assoc . rewrite <- ring_distr_r . rewrite (ring_add_comm (-y));rewrite ring_opp_def . rewrite ring_mul_0_r;rewrite ring_add_0_l ;reflexivity. Qed. Lemma ring_opp_add : forall x y, -(x + y) == -x + -y. Proof. intros x y;rewrite <- (ring_add_0_l (-(x+y))). rewrite <- (ring_opp_def x). rewrite <- (ring_add_0_l (x + - x + - (x + y))). rewrite <- (ring_opp_def y). rewrite (ring_add_comm x). rewrite (ring_add_comm y). rewrite <- (ring_add_assoc (-y)). rewrite <- (ring_add_assoc (- x)). rewrite (ring_add_assoc y). rewrite (ring_add_comm y). rewrite <- (ring_add_assoc (- x)). rewrite (ring_add_assoc y). rewrite (ring_add_comm y);rewrite ring_opp_def . rewrite (ring_add_comm (-x) 0);rewrite ring_add_0_l . rewrite ring_add_comm; reflexivity. Qed. Lemma ring_opp_opp : forall x, - -x == x. Proof. intros x; rewrite <- (ring_add_0_l (- -x)). rewrite <- (ring_opp_def x). rewrite <- ring_add_assoc ; rewrite ring_opp_def . rewrite (ring_add_comm x); rewrite ring_add_0_l . reflexivity. Qed. Lemma ring_sub_ext : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2. Proof. intros. setoid_replace (x1 - y1) with (x1 + -y1). setoid_replace (x2 - y2) with (x2 + -y2). rewrite H;rewrite H0;reflexivity. rewrite ring_sub_def. reflexivity. rewrite ring_sub_def. reflexivity. Qed. Ltac mrewrite := repeat first [ rewrite ring_add_0_l | rewrite <- (ring_add_comm 0) | rewrite ring_mul_1_l | rewrite ring_mul_0_l | rewrite ring_distr_l | reflexivity ]. Lemma ring_add_0_r : forall x, (x + 0) == x. Proof. intros; mrewrite. Qed. Lemma ring_add_assoc1 : forall x y z, (x + y) + z == (y + z) + x. Proof. intros;rewrite <- (ring_add_assoc x). rewrite (ring_add_comm x);reflexivity. Qed. Lemma ring_add_assoc2 : forall x y z, (y + x) + z == (y + z) + x. Proof. intros; repeat rewrite <- ring_add_assoc. rewrite (ring_add_comm x); reflexivity. Qed. Lemma ring_opp_zero : -0 == 0. Proof. rewrite <- (ring_mul_0_r 0). rewrite ring_opp_mul_l. repeat rewrite ring_mul_0_r. reflexivity. Qed. End Ring. (** Some simplification tactics*) Ltac gen_reflexivity := reflexivity. Ltac gen_rewrite := repeat first [ reflexivity | progress rewrite ring_opp_zero | rewrite ring_add_0_l | rewrite ring_add_0_r | rewrite ring_mul_1_l | rewrite ring_mul_1_r | rewrite ring_mul_0_l | rewrite ring_mul_0_r | rewrite ring_distr_l | rewrite ring_distr_r | rewrite ring_add_assoc | rewrite ring_mul_assoc | progress rewrite ring_opp_add | progress rewrite ring_sub_def | progress rewrite <- ring_opp_mul_l | progress rewrite <- ring_opp_mul_r ]. Ltac gen_add_push x := repeat (match goal with | |- context [(?y + x) + ?z] => progress rewrite (ring_add_assoc2 x y z) | |- context [(x + ?y) + ?z] => progress rewrite (ring_add_assoc1 x y z) end). coq-8.6/plugins/setoid_ring/Integral_domain.v0000644000175000017500000000243013022274260020730 0ustar mdenesmdenesRequire Export Cring. (* Definition of integral domains: commutative ring without zero divisor *) Class Integral_domain {R : Type}`{Rcr:Cring R} := { integral_domain_product: forall x y, x * y == 0 -> x == 0 \/ y == 0; integral_domain_one_zero: not (1 == 0)}. Section integral_domain. Context {R:Type}`{Rid:Integral_domain R}. Lemma integral_domain_minus_one_zero: ~ - (1:R) == 0. red;intro. apply integral_domain_one_zero. assert (0 == - (0:R)). cring. rewrite H0. rewrite <- H. cring. Qed. Definition pow (r : R) (n : nat) := Ring_theory.pow_N 1 mul r (N.of_nat n). Lemma pow_not_zero: forall p n, pow p n == 0 -> p == 0. induction n. unfold pow; simpl. intros. absurd (1 == 0). simpl. apply integral_domain_one_zero. trivial. setoid_replace (pow p (S n)) with (p * (pow p n)). intros. case (integral_domain_product p (pow p n) H). trivial. trivial. unfold pow; simpl. clear IHn. induction n; simpl; try cring. rewrite Ring_theory.pow_pos_succ. cring. apply ring_setoid. apply ring_mult_comp. apply ring_mul_assoc. Qed. Lemma Rintegral_domain_pow: forall c p r, ~c == 0 -> c * (pow p r) == ring0 -> p == ring0. intros. case (integral_domain_product c (pow p r) H0). intros; absurd (c == ring0); auto. intros. apply pow_not_zero with r. trivial. Qed. End integral_domain. coq-8.6/plugins/setoid_ring/ArithRing.v0000644000175000017500000000336713022274260017535 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr:(N.of_nat t) | _ => constr:(InitialRing.NotConstant) end. Ltac Ss_to_add f acc := match f with | S ?f1 => Ss_to_add f1 (S acc) | _ => constr:((acc + f)%nat) end. Ltac natprering := match goal with |- context C [S ?p] => match p with O => fail 1 (* avoid replacing 1 with 1+0 ! *) | p => match isnatcst p with | true => fail 1 | false => let v := Ss_to_add p (S 0) in fold v; natprering end end | _ => idtac end. Add Ring natr : natSRth (morphism nat_morph_N, constants [natcst], preprocess [natprering]). coq-8.6/plugins/setoid_ring/Ring_polynom.v0000644000175000017500000012406513022274260020321 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R->R) (ropp : R->R). Variable req : R -> R -> Prop. (* Ring properties *) Variable Rsth : Equivalence req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. (* Coefficients *) Variable C: Type. Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). Variable ceqb : C->C->bool. Variable phi : C -> R. Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. (* Power coefficients *) Variable Cpow : Type. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. (* division is ok *) Variable cdiv: C -> C -> C * C. Variable div_th: div_theory req cadd cmul phi cdiv. (* R notations *) Notation "0" := rO. Notation "1" := rI. Infix "+" := radd. Infix "*" := rmul. Infix "-" := rsub. Notation "- x" := (ropp x). Infix "==" := req. Infix "^" := (pow_pos rmul). (* C notations *) Infix "+!" := cadd. Infix "*!" := cmul. Infix "-! " := csub. Notation "-! x" := (copp x). Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). (* Useful tactics *) Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac rsimpl := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. Ltac add_permut_rec t := match t with | ?x + ?y => add_permut_rec y || add_permut_rec x | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity] end. Ltac add_permut := repeat (reflexivity || match goal with |- ?t == _ => add_permut_rec t end). Ltac mul_permut_rec t := match t with | ?x * ?y => mul_permut_rec y || mul_permut_rec x | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity] end. Ltac mul_permut := repeat (reflexivity || match goal with |- ?t == _ => mul_permut_rec t end). (* Definition of multivariable polynomials with coefficients in C : Type [Pol] represents [X1 ... Xn]. The representation is Horner's where a [n] variable polynomial (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients are polynomials with [n-1] variables (C[X2..Xn]). There are several optimisations to make the repr compacter: - [Pc c] is the constant polynomial of value c == c*X1^0*..*Xn^0 - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. variable indices are shifted of j in Q. == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} - [PX P i Q] is an optimised Horner form of P*X^i + Q with P not the null polynomial == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} In addition: - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden since they can be represented by the simpler form (PX P (i+j) Q) - (Pinj i (Pinj j P)) is (Pinj (i+j) P) - (Pinj i (Pc c)) is (Pc c) *) Inductive Pol : Type := | Pc : C -> Pol | Pinj : positive -> Pol -> Pol | PX : Pol -> positive -> Pol -> Pol. Definition P0 := Pc cO. Definition P1 := Pc cI. Fixpoint Peq (P P' : Pol) {struct P'} : bool := match P, P' with | Pc c, Pc c' => c ?=! c' | Pinj j Q, Pinj j' Q' => match j ?= j' with | Eq => Peq Q Q' | _ => false end | PX P i Q, PX P' i' Q' => match i ?= i' with | Eq => if Peq P P' then Peq Q Q' else false | _ => false end | _, _ => false end. Infix "?==" := Peq. Definition mkPinj j P := match P with | Pc _ => P | Pinj j' Q => Pinj (j + j') Q | _ => Pinj j P end. Definition mkPinj_pred j P:= match j with | xH => P | xO j => Pinj (Pos.pred_double j) P | xI j => Pinj (xO j) P end. Definition mkPX P i Q := match P with | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q | Pinj _ _ => PX P i Q | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q end. Definition mkXi i := PX P1 i P0. Definition mkX := mkXi 1. (** Opposite of addition *) Fixpoint Popp (P:Pol) : Pol := match P with | Pc c => Pc (-! c) | Pinj j Q => Pinj j (Popp Q) | PX P i Q => PX (Popp P) i (Popp Q) end. Notation "-- P" := (Popp P). (** Addition et subtraction *) Fixpoint PaddC (P:Pol) (c:C) : Pol := match P with | Pc c1 => Pc (c1 +! c) | Pinj j Q => Pinj j (PaddC Q c) | PX P i Q => PX P i (PaddC Q c) end. Fixpoint PsubC (P:Pol) (c:C) : Pol := match P with | Pc c1 => Pc (c1 -! c) | Pinj j Q => Pinj j (PsubC Q c) | PX P i Q => PX P i (PsubC Q c) end. Section PopI. Variable Pop : Pol -> Pol -> Pol. Variable Q : Pol. Fixpoint PaddI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PaddC Q c) | Pinj j' Q' => match Z.pos_sub j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PaddI k Q') end | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) | xO j => PX P i (PaddI (Pos.pred_double j) Q') | xI j => PX P i (PaddI (xO j) Q') end end. Fixpoint PsubI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PaddC (--Q) c) | Pinj j' Q' => match Z.pos_sub j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PsubI k Q') end | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) | xO j => PX P i (PsubI (Pos.pred_double j) Q') | xI j => PX P i (PsubI (xO j) Q') end end. Variable P' : Pol. Fixpoint PaddX (i':positive) (P:Pol) : Pol := match P with | Pc c => PX P' i' P | Pinj j Q' => match j with | xH => PX P' i' Q' | xO j => PX P' i' (Pinj (Pos.pred_double j) Q') | xI j => PX P' i' (Pinj (xO j) Q') end | PX P i Q' => match Z.pos_sub i i' with | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' | Z0 => mkPX (Pop P P') i Q' | Zneg k => mkPX (PaddX k P) i Q' end end. Fixpoint PsubX (i':positive) (P:Pol) : Pol := match P with | Pc c => PX (--P') i' P | Pinj j Q' => match j with | xH => PX (--P') i' Q' | xO j => PX (--P') i' (Pinj (Pos.pred_double j) Q') | xI j => PX (--P') i' (Pinj (xO j) Q') end | PX P i Q' => match Z.pos_sub i i' with | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' | Z0 => mkPX (Pop P P') i Q' | Zneg k => mkPX (PsubX k P) i Q' end end. End PopI. Fixpoint Padd (P P': Pol) {struct P'} : Pol := match P' with | Pc c' => PaddC P c' | Pinj j' Q' => PaddI Padd Q' j' P | PX P' i' Q' => match P with | Pc c => PX P' i' (PaddC Q' c) | Pinj j Q => match j with | xH => PX P' i' (Padd Q Q') | xO j => PX P' i' (Padd (Pinj (Pos.pred_double j) Q) Q') | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') end | PX P i Q => match Z.pos_sub i i' with | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') | Z0 => mkPX (Padd P P') i (Padd Q Q') | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') end end end. Infix "++" := Padd. Fixpoint Psub (P P': Pol) {struct P'} : Pol := match P' with | Pc c' => PsubC P c' | Pinj j' Q' => PsubI Psub Q' j' P | PX P' i' Q' => match P with | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) | Pinj j Q => match j with | xH => PX (--P') i' (Psub Q Q') | xO j => PX (--P') i' (Psub (Pinj (Pos.pred_double j) Q) Q') | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') end | PX P i Q => match Z.pos_sub i i' with | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') | Z0 => mkPX (Psub P P') i (Psub Q Q') | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') end end end. Infix "--" := Psub. (** Multiplication *) Fixpoint PmulC_aux (P:Pol) (c:C) : Pol := match P with | Pc c' => Pc (c' *! c) | Pinj j Q => mkPinj j (PmulC_aux Q c) | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c) end. Definition PmulC P c := if c ?=! cO then P0 else if c ?=! cI then P else PmulC_aux P c. Section PmulI. Variable Pmul : Pol -> Pol -> Pol. Variable Q : Pol. Fixpoint PmulI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PmulC Q c) | Pinj j' Q' => match Z.pos_sub j' j with | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) | Z0 => mkPinj j (Pmul Q' Q) | Zneg k => mkPinj j' (PmulI k Q') end | PX P' i' Q' => match j with | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) | xO j' => mkPX (PmulI j P') i' (PmulI (Pos.pred_double j') Q') | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') end end. End PmulI. Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := match P'' with | Pc c => PmulC P c | Pinj j' Q' => PmulI Pmul Q' j' P | PX P' i' Q' => match P with | Pc c => PmulC P'' c | Pinj j Q => let QQ' := match j with | xH => Pmul Q Q' | xO j => Pmul (Pinj (Pos.pred_double j) Q) Q' | xI j => Pmul (Pinj (xO j) Q) Q' end in mkPX (Pmul P P') i' QQ' | PX P i Q=> let QQ' := Pmul Q Q' in let PQ' := PmulI Pmul Q' xH P in let QP' := Pmul (mkPinj xH Q) P' in let PP' := Pmul P P' in (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' end end. Infix "**" := Pmul. (** Monomial **) (** A monomial is X1^k1...Xi^ki. Its representation is a simplified version of the polynomial representation: - [mon0] correspond to the polynom [P1]. - [(zmon j M)] corresponds to [(Pinj j ...)], i.e. skip j variable indices. - [(vmon i M)] is X^i*M with X the current variable, its corresponds to (PX P1 i ...)] *) Inductive Mon: Set := | mon0: Mon | zmon: positive -> Mon -> Mon | vmon: positive -> Mon -> Mon. Definition mkZmon j M := match M with mon0 => mon0 | _ => zmon j M end. Definition zmon_pred j M := match j with xH => M | _ => mkZmon (Pos.pred j) M end. Definition mkVmon i M := match M with | mon0 => vmon i mon0 | zmon j m => vmon i (zmon_pred j m) | vmon i' m => vmon (i+i') m end. Fixpoint CFactor (P: Pol) (c: C) {struct P}: Pol * Pol := match P with | Pc c1 => let (q,r) := cdiv c1 c in (Pc r, Pc q) | Pinj j1 P1 => let (R,S) := CFactor P1 c in (mkPinj j1 R, mkPinj j1 S) | PX P1 i Q1 => let (R1, S1) := CFactor P1 c in let (R2, S2) := CFactor Q1 c in (mkPX R1 i R2, mkPX S1 i S2) end. Fixpoint MFactor (P: Pol) (c: C) (M: Mon) {struct P}: Pol * Pol := match P, M with _, mon0 => if (ceqb c cI) then (Pc cO, P) else CFactor P c | Pc _, _ => (P, Pc cO) | Pinj j1 P1, zmon j2 M1 => match j1 ?= j2 with Eq => let (R,S) := MFactor P1 c M1 in (mkPinj j1 R, mkPinj j1 S) | Lt => let (R,S) := MFactor P1 c (zmon (j2 - j1) M1) in (mkPinj j1 R, mkPinj j1 S) | Gt => (P, Pc cO) end | Pinj _ _, vmon _ _ => (P, Pc cO) | PX P1 i Q1, zmon j M1 => let M2 := zmon_pred j M1 in let (R1, S1) := MFactor P1 c M in let (R2, S2) := MFactor Q1 c M2 in (mkPX R1 i R2, mkPX S1 i S2) | PX P1 i Q1, vmon j M1 => match i ?= j with Eq => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in (mkPX R1 i Q1, S1) | Lt => let (R1,S1) := MFactor P1 c (vmon (j - i) M1) in (mkPX R1 i Q1, S1) | Gt => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) end end. Definition POneSubst (P1: Pol) (cM1: C * Mon) (P2: Pol): option Pol := let (c,M1) := cM1 in let (Q1,R1) := MFactor P1 c M1 in match R1 with (Pc c) => if c ?=! cO then None else Some (Padd Q1 (Pmul P2 R1)) | _ => Some (Padd Q1 (Pmul P2 R1)) end. Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) : Pol := match POneSubst P1 cM1 P2 with Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end | _ => P1 end. Definition PNSubst (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat): option Pol := match POneSubst P1 cM1 P2 with Some P3 => match n with S n1 => Some (PNSubst1 P3 cM1 P2 n1) | _ => None end | _ => None end. Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) : Pol := match LM1 with cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n | _ => P1 end. Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) : option Pol := match LM1 with cons (M1,P2) LM2 => match PNSubst P1 M1 P2 n with Some P3 => Some (PSubstL1 P3 LM2 n) | None => PSubstL P1 LM2 n end | _ => None end. Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) : Pol := match PSubstL P1 LM1 n with Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end | _ => P1 end. (** Evaluation of a polynomial towards R *) Local Notation hd := (List.hd 0). Fixpoint Pphi(l:list R) (P:Pol) : R := match P with | Pc c => [c] | Pinj j Q => Pphi (jump j l) Q | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q end. Reserved Notation "P @ l " (at level 10, no associativity). Notation "P @ l " := (Pphi l P). Definition Pequiv (P Q : Pol) := forall l, P@l == Q@l. Infix "===" := Pequiv (at level 70, no associativity). Instance Pequiv_eq : Equivalence Pequiv. Proof. unfold Pequiv; split; red; intros; [reflexivity|now symmetry|now etransitivity]. Qed. Instance Pphi_ext : Proper (eq ==> Pequiv ==> req) Pphi. Proof. now intros l l' <- P Q H. Qed. Instance Pinj_ext : Proper (eq ==> Pequiv ==> Pequiv) Pinj. Proof. intros i j <- P P' HP l. simpl. now rewrite HP. Qed. Instance PX_ext : Proper (Pequiv ==> eq ==> Pequiv ==> Pequiv) PX. Proof. intros P P' HP p p' <- Q Q' HQ l. simpl. now rewrite HP, HQ. Qed. (** Evaluation of a monomial towards R *) Fixpoint Mphi(l:list R) (M: Mon) : R := match M with | mon0 => rI | zmon j M1 => Mphi (jump j l) M1 | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i end. Notation "M @@ l" := (Mphi l M) (at level 10, no associativity). (** Proofs *) Ltac destr_pos_sub := match goal with |- context [Z.pos_sub ?x ?y] => generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y) end. Lemma jump_add' i j (l:list R) : jump (i + j) l = jump j (jump i l). Proof. rewrite Pos.add_comm. apply jump_add. Qed. Lemma Peq_ok P P' : (P ?== P') = true -> P === P'. Proof. unfold Pequiv. revert P';induction P;destruct P';simpl; intros H l; try easy. - now apply (morph_eq CRmorph). - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. now rewrite IHP. - specialize (IHP1 P'1); specialize (IHP2 P'2). destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. destruct (P2 ?== P'1); [|easy]. rewrite H in *. now rewrite IHP1, IHP2. Qed. Lemma Peq_spec P P' : BoolSpec (P === P') True (P ?== P'). Proof. generalize (Peq_ok P P'). destruct (P ?== P'); auto. Qed. Lemma Pphi0 l : P0@l == 0. Proof. simpl;apply (morph0 CRmorph). Qed. Lemma Pphi1 l : P1@l == 1. Proof. simpl;apply (morph1 CRmorph). Qed. Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l). Proof. destruct P;simpl;rsimpl. now rewrite jump_add'. Qed. Instance mkPinj_ext : Proper (eq ==> Pequiv ==> Pequiv) mkPinj. Proof. intros i j <- P Q H l. now rewrite !mkPinj_ok. Qed. Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. Proof. rewrite Pos.add_comm. apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). Qed. Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). Proof. generalize (morph_eq CRmorph c c'). destruct (c ?=! c'); auto. Qed. Lemma mkPX_ok l P i Q : (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l). Proof. unfold mkPX. destruct P. - case ceqb_spec; intros H; simpl; try reflexivity. rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl. - reflexivity. - case Peq_spec; intros H; simpl; try reflexivity. rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl. Qed. Instance mkPX_ext : Proper (Pequiv ==> eq ==> Pequiv ==> Pequiv) mkPX. Proof. intros P P' HP i i' <- Q Q' HQ l. now rewrite !mkPX_ok, HP, HQ. Qed. Hint Rewrite Pphi0 Pphi1 mkPinj_ok mkPX_ok (morph0 CRmorph) (morph1 CRmorph) (morph0 CRmorph) (morph_add CRmorph) (morph_mul CRmorph) (morph_sub CRmorph) (morph_opp CRmorph) : Esimpl. (* Quicker than autorewrite with Esimpl :-) *) Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl. Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c]. Proof. revert l;induction P;simpl;intros;Esimpl;trivial. rewrite IHP2;rsimpl. Qed. Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c]. Proof. revert l;induction P;simpl;intros. - Esimpl. - rewrite IHP;rsimpl. - rewrite IHP2;rsimpl. Qed. Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c]. Proof. revert l;induction P;simpl;intros;Esimpl;trivial. rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut. Qed. Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c]. Proof. unfold PmulC. case ceqb_spec; intros H. - rewrite H; Esimpl. - case ceqb_spec; intros H'. + rewrite H'; Esimpl. + apply PmulC_aux_ok. Qed. Lemma Popp_ok P l : (--P)@l == - P@l. Proof. revert l;induction P;simpl;intros. - Esimpl. - apply IHP. - rewrite IHP1, IHP2;rsimpl. Qed. Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl. Lemma PaddX_ok P' P k l : (forall P l, (P++P')@l == P@l + P'@l) -> (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k. Proof. intros IHP'. revert k l. induction P;simpl;intros. - add_permut. - destruct p; simpl; rewrite ?jump_pred_double; add_permut. - destr_pos_sub; intros ->; Esimpl. + rewrite IHP';rsimpl. add_permut. + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + rewrite IHP1, pow_pos_add;rsimpl. add_permut. Qed. Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l. Proof. revert P l; induction P';simpl;intros;Esimpl. - revert p l; induction P;simpl;intros. + Esimpl; add_permut. + destr_pos_sub; intros ->;Esimpl. * now rewrite IHP'. * rewrite IHP';Esimpl. now rewrite jump_add'. * rewrite IHP. now rewrite jump_add'. + destruct p0;simpl. * rewrite IHP2;simpl. rsimpl. * rewrite IHP2;simpl. rewrite jump_pred_double. rsimpl. * rewrite IHP'. rsimpl. - destruct P;simpl. + Esimpl. add_permut. + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. * rsimpl. add_permut. * rewrite jump_pred_double. rsimpl. add_permut. * rsimpl. add_permut. + destr_pos_sub; intros ->; Esimpl. * rewrite IHP'1, IHP'2;rsimpl. add_permut. * rewrite IHP'1, IHP'2;simpl;Esimpl. rewrite pow_pos_add;rsimpl. add_permut. * rewrite PaddX_ok by trivial; rsimpl. rewrite IHP'2, pow_pos_add; rsimpl. add_permut. Qed. Lemma Psub_opp P' P : P -- P' === P ++ (--P'). Proof. revert P; induction P'; simpl; intros. - intro l; Esimpl. - revert p; induction P; simpl; intros; try reflexivity. + destr_pos_sub; intros ->; now apply mkPinj_ext. + destruct p0; now apply PX_ext. - destruct P; simpl; try reflexivity. + destruct p0; now apply PX_ext. + destr_pos_sub; intros ->; apply mkPX_ext; auto. revert p1. induction P2; simpl; intros; try reflexivity. destr_pos_sub; intros ->; now apply mkPX_ext. Qed. Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l. Proof. rewrite Psub_opp, Padd_ok, Popp_ok. rsimpl. Qed. Lemma PmulI_ok P' : (forall P l, (Pmul P P') @ l == P @ l * P' @ l) -> forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). Proof. intros IHP'. induction P;simpl;intros. - Esimpl; mul_permut. - destr_pos_sub; intros ->;Esimpl. + now rewrite IHP'. + now rewrite IHP', jump_add'. + now rewrite IHP, jump_add'. - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl. + f_equiv. mul_permut. + rewrite jump_pred_double. f_equiv. mul_permut. + rewrite IHP'. f_equiv. mul_permut. Qed. Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l. Proof. revert P l;induction P';simpl;intros. - apply PmulC_ok. - apply PmulI_ok;trivial. - destruct P. + rewrite (ARmul_comm ARth). Esimpl. + Esimpl. f_equiv. rewrite IHP'1; Esimpl. destruct p0;rewrite IHP'2;Esimpl. rewrite jump_pred_double; Esimpl. + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok, !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl. add_permut; f_equiv; mul_permut. Qed. Lemma mkZmon_ok M j l : (mkZmon j M) @@ l == (zmon j M) @@ l. Proof. destruct M; simpl; rsimpl. Qed. Lemma zmon_pred_ok M j l : (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l. Proof. destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl. rewrite jump_pred_double; rsimpl. Qed. Lemma mkVmon_ok M i l : (mkVmon i M)@@l == M@@l * (hd l)^i. Proof. destruct M;simpl;intros;rsimpl. - rewrite zmon_pred_ok;simpl;rsimpl. - rewrite pow_pos_add;rsimpl. Qed. Ltac destr_factor := match goal with | H : context [CFactor ?P _] |- context [CFactor ?P ?c] => destruct (CFactor P c); destr_factor; rewrite H; clear H | H : context [MFactor ?P _ _] |- context [MFactor ?P ?c ?M] => specialize (H M); destruct (MFactor P c M); destr_factor; rewrite H; clear H | _ => idtac end. Lemma Mcphi_ok P c l : let (Q,R) := CFactor P c in P@l == Q@l + [c] * R@l. Proof. revert l. induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. - assert (H := div_th.(div_eucl_th) c0 c). destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - destr_factor. Esimpl. - destr_factor. Esimpl. add_permut. Qed. Lemma Mphi_ok P (cM: C * Mon) l : let (c,M) := cM in let (Q,R) := MFactor P c M in P@l == Q@l + [c] * M@@l * R@l. Proof. destruct cM as (c,M). revert M l. induction P; destruct M; intros l; simpl; auto; try (case ceqb_spec; intro He); try (case Pos.compare_spec; intros He); rewrite ?He; destr_factor; simpl; Esimpl. - assert (H := div_th.(div_eucl_th) c0 c). destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - assert (H := Mcphi_ok P c). destr_factor. Esimpl. - now rewrite <- jump_add, Pos.sub_add. - assert (H2 := Mcphi_ok P2 c). assert (H3 := Mcphi_ok P3 c). destr_factor. Esimpl. add_permut. - rewrite zmon_pred_ok. simpl. add_permut. - rewrite mkZmon_ok. simpl. add_permut. mul_permut. - add_permut. mul_permut. rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl. - rewrite mkZmon_ok. simpl. Esimpl. add_permut. mul_permut. rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl. Qed. Lemma POneSubst_ok P1 cM1 P2 P3 l : POneSubst P1 cM1 P2 = Some P3 -> [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == P3@l. Proof. destruct cM1 as (cc,M1). unfold POneSubst. assert (H := Mphi_ok P1 (cc, M1) l). simpl in H. destruct MFactor as (R1,S1); simpl. rewrite H. clear H. intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1). - rewrite EQ', Padd_ok, Pmul_ok; rsimpl. - revert EQ. destruct S1; try now injection 1. case ceqb_spec; now inversion 2. Qed. Lemma PNSubst1_ok n P1 cM1 P2 l : [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == (PNSubst1 P1 cM1 P2 n)@l. Proof. revert P1. induction n; simpl; intros P1; generalize (POneSubst_ok P1 cM1 P2); destruct POneSubst; intros; rewrite <- ?IHn; auto; reflexivity. Qed. Lemma PNSubst_ok n P1 cM1 P2 l P3 : PNSubst P1 cM1 P2 n = Some P3 -> [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == P3@l. Proof. unfold PNSubst. assert (H := POneSubst_ok P1 cM1 P2); destruct POneSubst; try discriminate. destruct n; inversion_clear 1. intros. rewrite <- PNSubst1_ok; auto. Qed. Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) : Prop := match LM1 with | (M1,P2) :: LM2 => ([fst M1] * (snd M1)@@l == P2@l) /\ MPcond LM2 l | _ => True end. Lemma PSubstL1_ok n LM1 P1 l : MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. Proof. revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. - reflexivity. - rewrite <- IH by intuition; now apply PNSubst1_ok. Qed. Lemma PSubstL_ok n LM1 P1 P2 l : PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. Proof. revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros. - discriminate. - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. * injection H as <-. rewrite <- PSubstL1_ok; intuition. * now apply IH. Qed. Lemma PNSubstL_ok m n LM1 P1 l : MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. Proof. revert LM1 P1. induction m; simpl; intros; assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL; auto; try reflexivity. rewrite <- IHm; auto. Qed. (** Definition of polynomial expressions *) Inductive PExpr : Type := | PEO : PExpr | PEI : PExpr | PEc : C -> PExpr | PEX : positive -> PExpr | PEadd : PExpr -> PExpr -> PExpr | PEsub : PExpr -> PExpr -> PExpr | PEmul : PExpr -> PExpr -> PExpr | PEopp : PExpr -> PExpr | PEpow : PExpr -> N -> PExpr. (** evaluation of polynomial expressions towards R *) Definition mk_X j := mkPinj_pred j mkX. (** evaluation of polynomial expressions towards R *) Fixpoint PEeval (l:list R) (pe:PExpr) {struct pe} : R := match pe with | PEO => rO | PEI => rI | PEc c => phi c | PEX j => nth 0 j l | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) | PEopp pe1 => - (PEeval l pe1) | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) end. Strategy expand [PEeval]. (** Correctness proofs *) Lemma mkX_ok p l : nth 0 p l == (mk_X p) @ l. Proof. destruct p;simpl;intros;Esimpl;trivial. - now rewrite <-jump_tl, nth_jump. - now rewrite <- nth_jump, nth_pred_double. Qed. Hint Rewrite Padd_ok Psub_ok : Esimpl. Section POWER. Variable subst_l : Pol -> Pol. Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol := match p with | xH => subst_l (res ** P) | xO p => Ppow_pos (Ppow_pos res P p) P p | xI p => subst_l ((Ppow_pos (Ppow_pos res P p) P p) ** P) end. Definition Ppow_N P n := match n with | N0 => P1 | Npos p => Ppow_pos P1 P p end. Lemma Ppow_pos_ok l : (forall P, subst_l P@l == P@l) -> forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. Proof. intros subst_l_ok res P p. revert res. induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; mul_permut. Qed. Lemma Ppow_N_ok l : (forall P, subst_l P@l == P@l) -> forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. Proof. destruct n;simpl. - reflexivity. - rewrite Ppow_pos_ok by trivial. Esimpl. Qed. End POWER. (** Normalization and rewriting *) Section NORM_SUBST_REC. Variable n : nat. Variable lmp:list (C*Mon*Pol). Let subst_l P := PNSubstL P lmp n n. Let Pmul_subst P1 P2 := subst_l (P1 ** P2). Let Ppow_subst := Ppow_N subst_l. Fixpoint norm_aux (pe:PExpr) : Pol := match pe with | PEO => Pc cO | PEI => Pc cI | PEc c => Pc c | PEX j => mk_X j | PEadd (PEopp pe1) pe2 => (norm_aux pe2) -- (norm_aux pe1) | PEadd pe1 (PEopp pe2) => (norm_aux pe1) -- (norm_aux pe2) | PEadd pe1 pe2 => (norm_aux pe1) ++ (norm_aux pe2) | PEsub pe1 pe2 => (norm_aux pe1) -- (norm_aux pe2) | PEmul pe1 pe2 => (norm_aux pe1) ** (norm_aux pe2) | PEopp pe1 => -- (norm_aux pe1) | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n end. Definition norm_subst pe := subst_l (norm_aux pe). (** Internally, [norm_aux] is expanded in a large number of cases. To speed-up proofs, we use an alternative definition. *) Definition get_PEopp pe := match pe with | PEopp pe' => Some pe' | _ => None end. Lemma norm_aux_PEadd pe1 pe2 : norm_aux (PEadd pe1 pe2) = match get_PEopp pe1, get_PEopp pe2 with | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1') | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2') | None, None => (norm_aux pe1) ++ (norm_aux pe2) end. Proof. simpl (norm_aux (PEadd _ _)). destruct pe1; [ | | | | | | | reflexivity | ]; destruct pe2; simpl get_PEopp; reflexivity. Qed. Lemma norm_aux_PEopp pe : match get_PEopp pe with | Some pe' => norm_aux pe = -- (norm_aux pe') | None => True end. Proof. now destruct pe. Qed. Arguments norm_aux !pe : simpl nomatch. Lemma norm_aux_spec l pe : PEeval l pe == (norm_aux pe)@l. Proof. intros. induction pe; cbn. - now rewrite (morph0 CRmorph). - now rewrite (morph1 CRmorph). - reflexivity. - apply mkX_ok. - rewrite IHpe1, IHpe2. assert (H1 := norm_aux_PEopp pe1). assert (H2 := norm_aux_PEopp pe2). rewrite norm_aux_PEadd. do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut. - rewrite IHpe1, IHpe2. Esimpl. - rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - rewrite IHpe. Esimpl. - rewrite Ppow_N_ok by reflexivity. rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl. induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. Lemma norm_subst_spec : forall l pe, MPcond lmp l -> PEeval l pe == (norm_subst pe)@l. Proof. intros;unfold norm_subst. unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. Qed. End NORM_SUBST_REC. Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop := match lpe with | nil => True | (me,pe)::lpe => match lpe with | nil => PEeval l me == PEeval l pe | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe end end. Fixpoint mon_of_pol (P:Pol) : option (C * Mon) := match P with | Pc c => if (c ?=! cO) then None else Some (c, mon0) | Pinj j P => match mon_of_pol P with | None => None | Some (c,m) => Some (c, mkZmon j m) end | PX P i Q => if Peq Q P0 then match mon_of_pol P with | None => None | Some (c,m) => Some (c, mkVmon i m) end else None end. Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (C*Mon*Pol) := match lpe with | nil => nil | (me,pe)::lpe => match mon_of_pol (norm_subst 0 nil me) with | None => mk_monpol_list lpe | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe end end. Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m -> forall l, [fst m] * Mphi l (snd m) == P@l. Proof. induction P;simpl;intros;Esimpl. assert (H1 := (morph_eq CRmorph) c cO). destruct (c ?=! cO). discriminate. inversion H;trivial;Esimpl. generalize H;clear H;case_eq (mon_of_pol P). intros (c1,P2) H0 H1; inversion H1; Esimpl. generalize (IHP (c1, P2) H0 (jump p l)). rewrite mkZmon_ok;simpl;auto. intros; discriminate. generalize H;clear H;change match P3 with | Pc c => c ?=! cO | Pinj _ _ => false | PX _ _ _ => false end with (P3 ?== P0). assert (H := Peq_ok P3 P0). destruct (P3 ?== P0). case_eq (mon_of_pol P2);try intros (cc, pp); intros. inversion H1. simpl. rewrite mkVmon_ok;simpl. rewrite H;trivial;Esimpl. generalize (IHP1 _ H0); simpl; intros HH; rewrite HH; rsimpl. discriminate. intros;discriminate. Qed. Lemma interp_PElist_ok : forall l lpe, interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l. Proof. induction lpe;simpl. trivial. destruct a;simpl;intros. assert (HH:=mon_of_pol_ok (norm_subst 0 nil p)); destruct (mon_of_pol (norm_subst 0 nil p)). split. rewrite <- norm_subst_spec by exact I. destruct lpe;try destruct H;rewrite <- H; rewrite (norm_subst_spec 0 nil); try exact I;apply HH;trivial. apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. Qed. Lemma norm_subst_ok : forall n l lpe pe, interp_PElist l lpe -> PEeval l pe == (norm_subst n (mk_monpol_list lpe) pe)@l. Proof. intros;apply norm_subst_spec. apply interp_PElist_ok;trivial. Qed. Lemma ring_correct : forall n l lpe pe1 pe2, interp_PElist l lpe -> (let lmp := mk_monpol_list lpe in norm_subst n lmp pe1 ?== norm_subst n lmp pe2) = true -> PEeval l pe1 == PEeval l pe2. Proof. simpl;intros. do 2 (rewrite (norm_subst_ok n l lpe);trivial). apply Peq_ok;trivial. Qed. (** Generic evaluation of polynomial towards R avoiding parenthesis *) Variable get_sign : C -> option C. Variable get_sign_spec : sign_theory copp ceqb get_sign. Section EVALUATION. (* [mkpow x p] = x^p *) Variable mkpow : R -> positive -> R. (* [mkpow x p] = -(x^p) *) Variable mkopp_pow : R -> positive -> R. (* [mkmult_pow r x p] = r * x^p *) Variable mkmult_pow : R -> R -> positive -> R. Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R := match lm with | nil => r | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t end. Definition mkmult1 lm := match lm with | nil => 1 | cons (x,p) t => mkmult_rec (mkpow x p) t end. Definition mkmultm1 lm := match lm with | nil => ropp rI | cons (x,p) t => mkmult_rec (mkopp_pow x p) t end. Definition mkmult_c_pos c lm := if c ?=! cI then mkmult1 (rev' lm) else mkmult_rec [c] (rev' lm). Definition mkmult_c c lm := match get_sign c with | None => mkmult_c_pos c lm | Some c' => if c' ?=! cI then mkmultm1 (rev' lm) else mkmult_rec [c] (rev' lm) end. Definition mkadd_mult rP c lm := match get_sign c with | None => rP + mkmult_c_pos c lm | Some c' => rP - mkmult_c_pos c' lm end. Definition add_pow_list (r:R) n l := match n with | N0 => l | Npos p => (r,p)::l end. Fixpoint add_mult_dev (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R := match P with | Pc c => let lm := add_pow_list (hd fv) n lm in mkadd_mult rP c lm | Pinj j Q => add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd fv) n lm) | PX P i Q => let rP := add_mult_dev rP P fv (N.add (Npos i) n) lm in if Q ?== P0 then rP else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd fv) n lm) end. Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) (lm:list (R*positive)) {struct P} : R := (* P@l * (hd 0 l)^n * lm *) match P with | Pc c => mkmult_c c (add_pow_list (hd fv) n lm) | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd fv) n lm) | PX P i Q => let rP := mult_dev P fv (N.add (Npos i) n) lm in if Q ?== P0 then rP else let lmq := add_pow_list (hd fv) n lm in add_mult_dev rP Q (tail fv) N0 lmq end. Definition Pphi_avoid fv P := mult_dev P fv N0 nil. Fixpoint r_list_pow (l:list (R*positive)) : R := match l with | nil => rI | cons (r,p) l => pow_pos rmul r p * r_list_pow l end. Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p. Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p. Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm. Proof. induction lm;intros;simpl;Esimpl. destruct a as (x,p);Esimpl. rewrite IHlm. rewrite mkmult_pow_spec. Esimpl. Qed. Lemma mkmult1_ok : forall lm, mkmult1 lm == r_list_pow lm. Proof. destruct lm;simpl;Esimpl. destruct p. rewrite mkmult_rec_ok;rewrite mkpow_spec;Esimpl. Qed. Lemma mkmultm1_ok : forall lm, mkmultm1 lm == - r_list_pow lm. Proof. destruct lm;simpl;Esimpl. destruct p;rewrite mkmult_rec_ok. rewrite mkopp_pow_spec;Esimpl. Qed. Lemma r_list_pow_rev : forall l, r_list_pow (rev' l) == r_list_pow l. Proof. assert (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l). induction l;intros;simpl;Esimpl. destruct a;rewrite IHl;Esimpl. rewrite (ARmul_comm ARth (pow_pos rmul r p)). reflexivity. intros;unfold rev'. rewrite H;simpl;Esimpl. Qed. Lemma mkmult_c_pos_ok : forall c lm, mkmult_c_pos c lm == [c]* r_list_pow lm. Proof. intros;unfold mkmult_c_pos;simpl. assert (H := (morph_eq CRmorph) c cI). rewrite <- r_list_pow_rev; destruct (c ?=! cI). rewrite H;trivial;Esimpl. apply mkmult1_ok. apply mkmult_rec_ok. Qed. Lemma mkmult_c_ok : forall c lm, mkmult_c c lm == [c] * r_list_pow lm. Proof. intros;unfold mkmult_c;simpl. case_eq (get_sign c);intros. assert (H1 := (morph_eq CRmorph) c0 cI). destruct (c0 ?=! cI). rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H)). Esimpl. rewrite H1;trivial. rewrite <- r_list_pow_rev;trivial;Esimpl. apply mkmultm1_ok. rewrite <- r_list_pow_rev; apply mkmult_rec_ok. apply mkmult_c_pos_ok. Qed. Lemma mkadd_mult_ok : forall rP c lm, mkadd_mult rP c lm == rP + [c]*r_list_pow lm. Proof. intros;unfold mkadd_mult. case_eq (get_sign c);intros. rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H));Esimpl. rewrite mkmult_c_pos_ok;Esimpl. rewrite mkmult_c_pos_ok;Esimpl. Qed. Lemma add_pow_list_ok : forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l. Proof. destruct n;simpl;intros;Esimpl. Qed. Lemma add_mult_dev_ok : forall P rP fv n lm, add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd fv) n * r_list_pow lm. Proof. induction P;simpl;intros. rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl. rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl. change (match P3 with | Pc c => c ?=! cO | Pinj _ _ => false | PX _ _ _ => false end) with (Peq P3 P0). change match n with | N0 => Npos p | Npos q => Npos (p + q) end with (N.add (Npos p) n);trivial. assert (H := Peq_ok P3 P0). destruct (P3 ?== P0). rewrite (H eq_refl). rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. add_permut. mul_permut. rewrite IHP2. rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. add_permut. mul_permut. Qed. Lemma mult_dev_ok : forall P fv n lm, mult_dev P fv n lm == P@fv * pow_N rI rmul (hd fv) n * r_list_pow lm. Proof. induction P;simpl;intros;Esimpl. rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl. rewrite IHP. simpl;rewrite add_pow_list_ok;Esimpl. change (match P3 with | Pc c => c ?=! cO | Pinj _ _ => false | PX _ _ _ => false end) with (Peq P3 P0). change match n with | N0 => Npos p | Npos q => Npos (p + q) end with (N.add (Npos p) n);trivial. assert (H := Peq_ok P3 P0). destruct (P3 ?== P0). rewrite (H eq_refl). rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. mul_permut. rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. add_permut; mul_permut. Qed. Lemma Pphi_avoid_ok : forall P fv, Pphi_avoid fv P == P@fv. Proof. unfold Pphi_avoid;intros;rewrite mult_dev_ok;simpl;Esimpl. Qed. End EVALUATION. Definition Pphi_pow := let mkpow x p := match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in let mkopp_pow x p := ropp (mkpow x p) in let mkmult_pow r x p := rmul r (mkpow x p) in Pphi_avoid mkpow mkopp_pow mkmult_pow. Lemma local_mkpow_ok r p : match p with | xI _ => rpow r (Cp_phi (Npos p)) | xO _ => rpow r (Cp_phi (Npos p)) | 1 => r end == pow_pos rmul r p. Proof. destruct p; now rewrite ?pow_th.(rpow_pow_N). Qed. Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. Proof. unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros; now rewrite ?local_mkpow_ok. Qed. Lemma ring_rw_pow_correct : forall n lH l, interp_PElist l lH -> forall lmp, mk_monpol_list lH = lmp -> forall pe npe, norm_subst n lmp pe = npe -> PEeval l pe == Pphi_pow l npe. Proof. intros n lH l H1 lmp Heq1 pe npe Heq2. rewrite Pphi_pow_ok, <- Heq2, <- Heq1. apply norm_subst_ok. trivial. Qed. Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := match p with | xH => r*x | xO p => mkmult_pow (mkmult_pow r x p) x p | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p end. Definition mkpow x p := match p with | xH => x | xO p => mkmult_pow x x (Pos.pred_double p) | xI p => mkmult_pow x x (xO p) end. Definition mkopp_pow x p := match p with | xH => -x | xO p => mkmult_pow (-x) x (Pos.pred_double p) | xI p => mkmult_pow (-x) x (xO p) end. Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow. Lemma mkmult_pow_ok p r x : mkmult_pow r x p == r * x^p. Proof. revert r; induction p;intros;simpl;Esimpl;rewrite !IHp;Esimpl. Qed. Lemma mkpow_ok p x : mkpow x p == x^p. Proof. destruct p;simpl;intros;Esimpl. - rewrite !mkmult_pow_ok;Esimpl. - rewrite mkmult_pow_ok;Esimpl. change x with (x^1) at 1. now rewrite <- pow_pos_add, Pos.add_1_r, Pos.succ_pred_double. Qed. Lemma mkopp_pow_ok p x : mkopp_pow x p == - x^p. Proof. destruct p;simpl;intros;Esimpl. - rewrite !mkmult_pow_ok;Esimpl. - rewrite mkmult_pow_ok;Esimpl. change x with (x^1) at 1. now rewrite <- pow_pos_add, Pos.add_1_r, Pos.succ_pred_double. Qed. Lemma Pphi_dev_ok : forall P fv, Pphi_dev fv P == P@fv. Proof. unfold Pphi_dev;intros;apply Pphi_avoid_ok. - intros;apply mkpow_ok. - intros;apply mkopp_pow_ok. - intros;apply mkmult_pow_ok. Qed. Lemma ring_rw_correct : forall n lH l, interp_PElist l lH -> forall lmp, mk_monpol_list lH = lmp -> forall pe npe, norm_subst n lmp pe = npe -> PEeval l pe == Pphi_dev l npe. Proof. intros n lH l H1 lmp Heq1 pe npe Heq2. rewrite Pphi_dev_ok. rewrite <- Heq2;rewrite <- Heq1. apply norm_subst_ok. trivial. Qed. End MakeRingPol. Arguments PEO [C]. Arguments PEI [C]. coq-8.6/plugins/setoid_ring/Field.v0000644000175000017500000000110513022274260016655 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* _ => R | _ => fail 1000 "Equality has no relation type" end. Ltac Get_goal := match goal with [|- ?G] => G end. (********************************************************************) (* Tacticals to build reflexive tactics *) Ltac OnEquation req := match goal with | |- req ?lhs ?rhs => (fun f => f lhs rhs) | _ => (fun _ => fail "Goal is not an equation (of expected equality)") end. Ltac OnEquationHyp req h := match type of h with | req ?lhs ?rhs => fun f => f lhs rhs | _ => (fun _ => fail "Hypothesis is not an equation (of expected equality)") end. (* Note: auxiliary subgoals in reverse order *) Ltac OnMainSubgoal H ty := match ty with | _ -> ?ty' => let subtac := OnMainSubgoal H ty' in fun kont => lapply H; [clear H; intro H; subtac kont | idtac] | _ => (fun kont => kont()) end. (* A generic pattern to have reflexive tactics do some computation: lemmas of the form [forall x', x=x' -> P(x')] are understood as: compute the normal form of x, instantiate x' with it, prove hypothesis x=x' with vm_compute and reflexivity, and pass the instantiated lemma to the continuation. *) Ltac ProveLemmaHyp lemma := match type of lemma with forall x', ?x = x' -> _ => (fun kont => let x' := fresh "res" in let H := fresh "res_eq" in compute_assertion H x' x; let lemma' := constr:(lemma x' H) in kont lemma'; (clear H||idtac"ProveLemmaHyp: cleanup failed"); subst x') | _ => (fun _ => fail "ProveLemmaHyp: lemma not of the expected form") end. Ltac ProveLemmaHyps lemma := match type of lemma with forall x', ?x = x' -> _ => (fun kont => let x' := fresh "res" in let H := fresh "res_eq" in compute_assertion H x' x; let lemma' := constr:(lemma x' H) in ProveLemmaHyps lemma' kont; (clear H||idtac"ProveLemmaHyps: cleanup failed"); subst x') | _ => (fun kont => kont lemma) end. (* Ltac ProveLemmaHyps lemma := (* expects a continuation *) let try_step := ProveLemmaHyp lemma in (fun kont => try_step ltac:(fun lemma' => ProveLemmaHyps lemma' kont) || kont lemma). *) Ltac ApplyLemmaThen lemma expr kont := let lem := constr:(lemma expr) in ProveLemmaHyp lem ltac:(fun lem' => let Heq := fresh "thm" in assert (Heq:=lem'); OnMainSubgoal Heq ltac:(type of Heq) ltac:(fun _ => kont Heq); (clear Heq||idtac"ApplyLemmaThen: cleanup failed")). (* Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg := let pe := match type of (lemma expr) with forall pe', ?pe = pe' -> _ => pe | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression" end in let pe' := fresh "expr_nf" in let nf_pe := fresh "pe_eq" in compute_assertion nf_pe pe' pe; let Heq := fresh "thm" in (assert (Heq:=lemma pe pe' H) || fail "anomaly: failed to apply lemma"); clear nf_pe; OnMainSubgoal Heq ltac:(type of Heq) ltac:(try tac Heq; clear Heq pe';CONT_tac cont_arg)). *) Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac := ApplyLemmaThen lemma expr ltac:(fun lemma' => try tac lemma'; CONT_tac()). (* General scheme of reflexive tactics using of correctness lemma that involves normalisation of one expression - [FV_tac term fv] is a tactic that adds the atomic expressions of [term] into [fv] - [SYN_tac term fv] reifies [term] given the list of atomic expressions - [LEMMA_tac fv kont] computes the correctness lemma and passes it to continuation kont - [MAIN_tac H] process H which is the conclusion of the correctness lemma instantiated with each reified term - [fv] is the initial value of atomic expressions (to be completed by the reification of the terms - [terms] the list (a constr of type list) of terms to reify and process. *) Ltac ReflexiveRewriteTactic FV_tac SYN_tac LEMMA_tac MAIN_tac fv terms := (* extend the atom list *) let fv := list_fold_left FV_tac fv terms in let RW_tac lemma := let fcons term CONT_tac := let expr := SYN_tac term fv in let main H := match type of H with | (?req _ ?rhs) => change (req term rhs) in H end; MAIN_tac H in (ApplyLemmaThenAndCont lemma expr main CONT_tac) in (* rewrite steps *) lazy_list_fold_right fcons ltac:(fun _=>idtac) terms in LEMMA_tac fv RW_tac. (********************************************************) Ltac FV_hypo_tac mkFV req lH := let R := relation_carrier req in let FV_hypo_l_tac h := match h with @mkhypo (req ?pe _) _ => mkFV pe end in let FV_hypo_r_tac h := match h with @mkhypo (req _ ?pe) _ => mkFV pe end in let fv := list_fold_right FV_hypo_l_tac (@nil R) lH in list_fold_right FV_hypo_r_tac fv lH. Ltac mkHyp_tac C req Reify lH := let mkHyp h res := match h with | @mkhypo (req ?r1 ?r2) _ => let pe1 := Reify r1 in let pe2 := Reify r2 in constr:(cons (pe1,pe2) res) | _ => fail 1 "hypothesis is not a ring equality" end in list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH. Ltac proofHyp_tac lH := let get_proof h := match h with | @mkhypo _ ?p => p end in let rec bh l := match l with | nil => constr:(I) | cons ?h nil => get_proof h | cons ?h ?tl => let l := get_proof h in let r := bh tl in constr:(conj l r) end in bh lH. Ltac get_MonPol lemma := match type of lemma with | context [(mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _)] => constr:(mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb) | _ => fail 1 "ring/field anomaly: bad correctness lemma (get_MonPol)" end. (********************************************************) (* Building the atom list of a ring expression *) (* We do not assume that Cst recognizes the rO and rI terms as constants, as *) (* the tactic could be used to discriminate occurrences of an opaque *) (* constant phi, with (phi 0) not convertible to 0 for instance *) Ltac FV Cst CstPow rO rI add mul sub opp pow t fv := let rec TFV t fv := let f := match Cst t with | NotConstant => match t with | rO => fun _ => fv | rI => fun _ => fv | (add ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) | (mul ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) | (sub ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) | (opp ?t1) => fun _ => TFV t1 fv | (pow ?t1 ?n) => match CstPow n with | InitialRing.NotConstant => fun _ => AddFvTail t fv | _ => fun _ => TFV t1 fv end | _ => fun _ => AddFvTail t fv end | _ => fun _ => fv end in f() in TFV t fv. (* syntaxification of ring expressions *) (* We do not assume that Cst recognizes the rO and rI terms as constants, as *) (* the tactic could be used to discriminate occurrences of an opaque *) (* constant phi, with (phi 0) not convertible to 0 for instance *) Ltac mkPolexpr C Cst CstPow rO rI radd rmul rsub ropp rpow t fv := let rec mkP t := let f := match Cst t with | InitialRing.NotConstant => match t with | rO => fun _ => constr:(@PEO C) | rI => fun _ => constr:(@PEI C) | (radd ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(@PEadd C e1 e2) | (rmul ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(@PEmul C e1 e2) | (rsub ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(@PEsub C e1 e2) | (ropp ?t1) => fun _ => let e1 := mkP t1 in constr:(@PEopp C e1) | (rpow ?t1 ?n) => match CstPow n with | InitialRing.NotConstant => fun _ => let p := Find_at t fv in constr:(PEX C p) | ?c => fun _ => let e1 := mkP t1 in constr:(@PEpow C e1 c) end | _ => fun _ => let p := Find_at t fv in constr:(PEX C p) end | ?c => fun _ => constr:(@PEc C c) end in f () in mkP t. (* packaging the ring structure *) Ltac PackRing F req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post := let RNG := match type of lemma1 with | context [@PEeval ?R ?r0 ?r1 ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] => (fun proj => proj cst_tac pow_tac pre post R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2) | _ => fail 1 "field anomaly: bad correctness lemma (parse)" end in F RNG. Ltac get_Carrier RNG := RNG ltac:(fun cst_tac pow_tac pre post R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => R). Ltac get_Eq RNG := RNG ltac:(fun cst_tac pow_tac pre post R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => req). Ltac get_Pre RNG := RNG ltac:(fun cst_tac pow_tac pre post R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => pre). Ltac get_Post RNG := RNG ltac:(fun cst_tac pow_tac pre post R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => post). Ltac get_NormLemma RNG := RNG ltac:(fun cst_tac pow_tac pre post R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => lemma1). Ltac get_SimplifyLemma RNG := RNG ltac:(fun cst_tac pow_tac pre post R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => lemma2). Ltac get_RingFV RNG := RNG ltac:(fun cst_tac pow_tac pre post R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => FV cst_tac pow_tac r0 r1 add mul sub opp pow). Ltac get_RingMeta RNG := RNG ltac:(fun cst_tac pow_tac pre post R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => mkPolexpr C cst_tac pow_tac r0 r1 add mul sub opp pow). Ltac get_RingHypTac RNG := RNG ltac:(fun cst_tac pow_tac pre post R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => let mkPol := mkPolexpr C cst_tac pow_tac r0 r1 add mul sub opp pow in fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH). (* ring tactics *) Definition ring_subst_niter := (10*10*10)%nat. Ltac Ring RNG lemma lH := let req := get_Eq RNG in OnEquation req ltac:(fun lhs rhs => let mkFV := get_RingFV RNG in let mkPol := get_RingMeta RNG in let mkHyp := get_RingHypTac RNG in let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in let fv := mkFV lhs fv in let fv := mkFV rhs fv in check_fv fv; let pe1 := mkPol lhs fv in let pe2 := mkPol rhs fv in let lpe := mkHyp fv lH in let vlpe := fresh "hyp_list" in let vfv := fresh "fv_list" in pose (vlpe := lpe); pose (vfv := fv); (apply (lemma vfv vlpe pe1 pe2) || fail "typing error while applying ring"); [ ((let prh := proofHyp_tac lH in exact prh) || idtac "can not automatically prove hypothesis :"; [> idtac " maybe a left member of a hypothesis is not a monomial"..]) | vm_compute; (exact (eq_refl true) || fail "not a valid ring equation")]). Ltac Ring_norm_gen f RNG lemma lH rl := let mkFV := get_RingFV RNG in let mkPol := get_RingMeta RNG in let mkHyp := get_RingHypTac RNG in let mk_monpol := get_MonPol lemma in let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in let lemma_tac fv kont := let lpe := mkHyp fv lH in let vlpe := fresh "list_hyp" in let vlmp := fresh "list_hyp_norm" in let vlmp_eq := fresh "list_hyp_norm_eq" in let prh := proofHyp_tac lH in pose (vlpe := lpe); compute_assertion vlmp_eq vlmp (mk_monpol vlpe); let H := fresh "ring_lemma" in (assert (H := lemma vlpe fv prh vlmp vlmp_eq) || fail "type error when build the rewriting lemma"); clear vlmp_eq; kont H; (clear H||idtac"Ring_norm_gen: cleanup failed"); subst vlpe vlmp in let simpl_ring H := (protect_fv "ring" in H; f H) in ReflexiveRewriteTactic mkFV mkPol lemma_tac simpl_ring fv rl. Ltac Ring_gen RNG lH rl := let lemma := get_NormLemma RNG in get_Pre RNG (); Ring RNG (lemma ring_subst_niter) lH. Tactic Notation (at level 0) "ring" := let G := Get_goal in ring_lookup (PackRing Ring_gen) [] G. Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" := let G := Get_goal in ring_lookup (PackRing Ring_gen) [lH] G. (* Simplification *) Ltac Ring_simplify_gen f RNG lH rl := let lemma := get_SimplifyLemma RNG in let l := fresh "to_rewrite" in pose (l:= rl); generalize (eq_refl l); unfold l at 2; get_Pre RNG (); let rl := match goal with | [|- l = ?RL -> _ ] => RL | _ => fail 1 "ring_simplify anomaly: bad goal after pre" end in let Heq := fresh "Heq" in intros Heq;clear Heq l; Ring_norm_gen f RNG (lemma ring_subst_niter) lH rl; get_Post RNG (). Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H). Tactic Notation (at level 0) "ring_simplify" constr_list(rl) := let G := Get_goal in ring_lookup (PackRing Ring_simplify) [] rl G. Tactic Notation (at level 0) "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := let G := Get_goal in ring_lookup (PackRing Ring_simplify) [lH] rl G. Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= let G := Get_goal in let t := type of H in let g := fresh "goal" in set (g:= G); generalize H;clear H; ring_lookup (PackRing Ring_simplify) [] rl t; intro H; unfold g;clear g. Tactic Notation "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):= let G := Get_goal in let t := type of H in let g := fresh "goal" in set (g:= G); generalize H;clear H; ring_lookup (PackRing Ring_simplify) [lH] rl t; intro H; unfold g;clear g. coq-8.6/plugins/setoid_ring/Algebra_syntax.v0000644000175000017500000000163413022274260020604 0ustar mdenesmdenes Class Zero (A : Type) := zero : A. Notation "0" := zero. Class One (A : Type) := one : A. Notation "1" := one. Class Addition (A : Type) := addition : A -> A -> A. Notation "_+_" := addition. Notation "x + y" := (addition x y). Class Multiplication {A B : Type} := multiplication : A -> B -> B. Notation "_*_" := multiplication. Notation "x * y" := (multiplication x y). Class Subtraction (A : Type) := subtraction : A -> A -> A. Notation "_-_" := subtraction. Notation "x - y" := (subtraction x y). Class Opposite (A : Type) := opposite : A -> A. Notation "-_" := opposite. Notation "- x" := (opposite(x)). Class Equality {A : Type}:= equality : A -> A -> Prop. Notation "_==_" := equality. Notation "x == y" := (equality x y) (at level 70, no associativity). Class Bracket (A B: Type):= bracket : A -> B. Notation "[ x ]" := (bracket(x)). Class Power {A B: Type} := power : A -> B -> A. Notation "x ^ y" := (power x y). coq-8.6/plugins/setoid_ring/Ring_theory.v0000644000175000017500000004374713022274260020145 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R -> R. Variable req : R -> R -> Prop. Variable Rsth : Equivalence req. Infix "*" := rmul. Infix "==" := req. Hypothesis mul_ext : Proper (req ==> req ==> req) rmul. Hypothesis mul_assoc : forall x y z, x * (y * z) == (x * y) * z. Fixpoint pow_pos (x:R) (i:positive) : R := match i with | xH => x | xO i => let p := pow_pos x i in p * p | xI i => let p := pow_pos x i in x * (p * p) end. Lemma pow_pos_swap x j : pow_pos x j * x == x * pow_pos x j. Proof. induction j; simpl; rewrite <- ?mul_assoc. - f_equiv. now do 2 (rewrite IHj, mul_assoc). - now do 2 (rewrite IHj, mul_assoc). - reflexivity. Qed. Lemma pow_pos_succ x j : pow_pos x (Pos.succ j) == x * pow_pos x j. Proof. induction j; simpl; try reflexivity. rewrite IHj, <- mul_assoc; f_equiv. now rewrite mul_assoc, pow_pos_swap, mul_assoc. Qed. Lemma pow_pos_add x i j : pow_pos x (i + j) == pow_pos x i * pow_pos x j. Proof. induction i using Pos.peano_ind. - now rewrite Pos.add_1_l, pow_pos_succ. - now rewrite Pos.add_succ_l, !pow_pos_succ, IHi, mul_assoc. Qed. Definition pow_N (x:R) (p:N) := match p with | N0 => rI | Npos p => pow_pos x p end. Definition id_phi_N (x:N) : N := x. Lemma pow_N_pow_N x n : pow_N x (id_phi_N n) == pow_N x n. Proof. reflexivity. Qed. End Power. Section DEFINITIONS. Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Infix "==" := req. Infix "+" := radd. Infix "*" := rmul. Infix "-" := rsub. Notation "- x" := (ropp x). (** Semi Ring *) Record semi_ring_theory : Prop := mk_srt { SRadd_0_l : forall n, 0 + n == n; SRadd_comm : forall n m, n + m == m + n ; SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p; SRmul_1_l : forall n, 1*n == n; SRmul_0_l : forall n, 0*n == 0; SRmul_comm : forall n m, n*m == m*n; SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p; SRdistr_l : forall n m p, (n + m)*p == n*p + m*p }. (** Almost Ring *) (*Almost ring are no ring : Ropp_def is missing **) Record almost_ring_theory : Prop := mk_art { ARadd_0_l : forall x, 0 + x == x; ARadd_comm : forall x y, x + y == y + x; ARadd_assoc : forall x y z, x + (y + z) == (x + y) + z; ARmul_1_l : forall x, 1 * x == x; ARmul_0_l : forall x, 0 * x == 0; ARmul_comm : forall x y, x * y == y * x; ARmul_assoc : forall x y z, x * (y * z) == (x * y) * z; ARdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); ARopp_mul_l : forall x y, -(x * y) == -x * y; ARopp_add : forall x y, -(x + y) == -x + -y; ARsub_def : forall x y, x - y == x + -y }. (** Ring *) Record ring_theory : Prop := mk_rt { Radd_0_l : forall x, 0 + x == x; Radd_comm : forall x y, x + y == y + x; Radd_assoc : forall x y z, x + (y + z) == (x + y) + z; Rmul_1_l : forall x, 1 * x == x; Rmul_comm : forall x y, x * y == y * x; Rmul_assoc : forall x y z, x * (y * z) == (x * y) * z; Rdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); Rsub_def : forall x y, x - y == x + -y; Ropp_def : forall x, x + (- x) == 0 }. (** Equality is extensional *) Record sring_eq_ext : Prop := mk_seqe { (* SRing operators are compatible with equality *) SRadd_ext : Proper (req ==> req ==> req) radd; SRmul_ext : Proper (req ==> req ==> req) rmul }. Record ring_eq_ext : Prop := mk_reqe { (* Ring operators are compatible with equality *) Radd_ext : Proper (req ==> req ==> req) radd; Rmul_ext : Proper (req ==> req ==> req) rmul; Ropp_ext : Proper (req ==> req) ropp }. (** Interpretation morphisms definition*) Section MORPHISM. Variable C:Type. Variable (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C). Variable ceqb : C->C->bool. (* [phi] est un morphisme de [C] dans [R] *) Variable phi : C -> R. Infix "+!" := cadd. Infix "-!" := csub. Infix "*!" := cmul. Notation "-! x" := (copp x). Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). (*for semi rings*) Record semi_morph : Prop := mkRmorph { Smorph0 : [cO] == 0; Smorph1 : [cI] == 1; Smorph_add : forall x y, [x +! y] == [x]+[y]; Smorph_mul : forall x y, [x *! y] == [x]*[y]; Smorph_eq : forall x y, x?=!y = true -> [x] == [y] }. (* for rings*) Record ring_morph : Prop := mkmorph { morph0 : [cO] == 0; morph1 : [cI] == 1; morph_add : forall x y, [x +! y] == [x]+[y]; morph_sub : forall x y, [x -! y] == [x]-[y]; morph_mul : forall x y, [x *! y] == [x]*[y]; morph_opp : forall x, [-!x] == -[x]; morph_eq : forall x y, x?=!y = true -> [x] == [y] }. Section SIGN. Variable get_sign : C -> option C. Record sign_theory : Prop := mksign_th { sign_spec : forall c c', get_sign c = Some c' -> c ?=! -! c' = true }. End SIGN. Definition get_sign_None (c:C) := @None C. Lemma get_sign_None_th : sign_theory get_sign_None. Proof. constructor;intros;discriminate. Qed. Section DIV. Variable cdiv: C -> C -> C*C. Record div_theory : Prop := mkdiv_th { div_eucl_th : forall a b, let (q,r) := cdiv a b in [a] == [b *! q +! r] }. End DIV. End MORPHISM. (** Identity is a morphism *) Variable Rsth : Equivalence req. Variable reqb : R->R->bool. Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y. Definition IDphi (x:R) := x. Lemma IDmorph : ring_morph rO rI radd rmul rsub ropp reqb IDphi. Proof. now apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi). Qed. (** Specification of the power function *) Section POWER. Variable Cpow : Type. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Record power_theory : Prop := mkpow_th { rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n) }. End POWER. Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth). End DEFINITIONS. Section ALMOST_RING. Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Infix "==" := req. Infix "+" := radd. Infix "* " := rmul. (** Leibniz equality leads to a setoid theory and is extensional*) Lemma Eqsth : Equivalence (@eq R). Proof. exact eq_equivalence. Qed. Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R). Proof. constructor;solve_proper. Qed. Lemma Eq_ext : ring_eq_ext radd rmul ropp (@eq R). Proof. constructor;solve_proper. Qed. Variable Rsth : Equivalence req. Section SEMI_RING. Variable SReqe : sring_eq_ext radd rmul req. Add Morphism radd : radd_ext1. exact (SRadd_ext SReqe). Qed. Add Morphism rmul : rmul_ext1. exact (SRmul_ext SReqe). Qed. Variable SRth : semi_ring_theory 0 1 radd rmul req. (** Every semi ring can be seen as an almost ring, by taking : -x = x and x - y = x + y *) Definition SRopp (x:R) := x. Notation "- x" := (SRopp x). Definition SRsub x y := x + -y. Infix "-" := SRsub. Lemma SRopp_ext : forall x y, x == y -> -x == -y. Proof. intros x y H; exact H. Qed. Lemma SReqe_Reqe : ring_eq_ext radd rmul SRopp req. Proof. constructor. - exact (SRadd_ext SReqe). - exact (SRmul_ext SReqe). - exact SRopp_ext. Qed. Lemma SRopp_mul_l : forall x y, -(x * y) == -x * y. Proof. reflexivity. Qed. Lemma SRopp_add : forall x y, -(x + y) == -x + -y. Proof. reflexivity. Qed. Lemma SRsub_def : forall x y, x - y == x + -y. Proof. reflexivity. Qed. Lemma SRth_ARth : almost_ring_theory 0 1 radd rmul SRsub SRopp req. Proof (mk_art 0 1 radd rmul SRsub SRopp req (SRadd_0_l SRth) (SRadd_comm SRth) (SRadd_assoc SRth) (SRmul_1_l SRth) (SRmul_0_l SRth) (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth) SRopp_mul_l SRopp_add SRsub_def). (** Identity morphism for semi-ring equipped with their almost-ring structure*) Variable reqb : R->R->bool. Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y. Definition SRIDmorph : ring_morph 0 1 radd rmul SRsub SRopp req 0 1 radd rmul SRsub SRopp reqb (@IDphi R). Proof. now apply mkmorph. Qed. (* a semi_morph can be extended to a ring_morph for the almost_ring derived from a semi_ring, provided the ring is a setoid (we only need reflexivity) *) Variable C : Type. Variable (cO cI : C) (cadd cmul: C->C->C). Variable (ceqb : C -> C -> bool). Variable phi : C -> R. Variable Smorph : semi_morph rO rI radd rmul req cO cI cadd cmul ceqb phi. Lemma SRmorph_Rmorph : ring_morph rO rI radd rmul SRsub SRopp req cO cI cadd cmul cadd (fun x => x) ceqb phi. Proof. case Smorph; now constructor. Qed. End SEMI_RING. Infix "-" := rsub. Notation "- x" := (ropp x). Variable Reqe : ring_eq_ext radd rmul ropp req. Add Morphism radd : radd_ext2. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext2. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext2. exact (Ropp_ext Reqe). Qed. Section RING. Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. (** Rings are almost rings*) Lemma Rmul_0_l x : 0 * x == 0. Proof. setoid_replace (0*x) with ((0+1)*x + -x). now rewrite (Radd_0_l Rth), (Rmul_1_l Rth), (Ropp_def Rth). rewrite (Rdistr_l Rth), (Rmul_1_l Rth). rewrite <- (Radd_assoc Rth), (Ropp_def Rth). now rewrite (Radd_comm Rth), (Radd_0_l Rth). Qed. Lemma Ropp_mul_l x y : -(x * y) == -x * y. Proof. rewrite <-(Radd_0_l Rth (- x * y)). rewrite (Radd_comm Rth), <-(Ropp_def Rth (x*y)). rewrite (Radd_assoc Rth), <- (Rdistr_l Rth). rewrite (Rth.(Radd_comm) (-x)), (Ropp_def Rth). now rewrite Rmul_0_l, (Radd_0_l Rth). Qed. Lemma Ropp_add x y : -(x + y) == -x + -y. Proof. rewrite <- ((Radd_0_l Rth) (-(x+y))). rewrite <- ((Ropp_def Rth) x). rewrite <- ((Radd_0_l Rth) (x + - x + - (x + y))). rewrite <- ((Ropp_def Rth) y). rewrite ((Radd_comm Rth) x). rewrite ((Radd_comm Rth) y). rewrite <- ((Radd_assoc Rth) (-y)). rewrite <- ((Radd_assoc Rth) (- x)). rewrite ((Radd_assoc Rth) y). rewrite ((Radd_comm Rth) y). rewrite <- ((Radd_assoc Rth) (- x)). rewrite ((Radd_assoc Rth) y). rewrite ((Radd_comm Rth) y), (Ropp_def Rth). rewrite ((Radd_comm Rth) (-x) 0), (Radd_0_l Rth). now apply (Radd_comm Rth). Qed. Lemma Ropp_opp x : - -x == x. Proof. rewrite <- (Radd_0_l Rth (- -x)). rewrite <- (Ropp_def Rth x). rewrite <- (Radd_assoc Rth), (Ropp_def Rth). rewrite ((Radd_comm Rth) x); now apply (Radd_0_l Rth). Qed. Lemma Rth_ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. Proof (mk_art 0 1 radd rmul rsub ropp req (Radd_0_l Rth) (Radd_comm Rth) (Radd_assoc Rth) (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth) Ropp_mul_l Ropp_add (Rsub_def Rth)). (** Every semi morphism between two rings is a morphism*) Variable C : Type. Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C). Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool). Variable phi : C -> R. Infix "+!" := cadd. Infix "*!" := cmul. Infix "-!" := csub. Notation "-! x" := (copp x). Notation "?=!" := ceqb. Notation "[ x ]" := (phi x). Variable Csth : Equivalence ceq. Variable Ceqe : ring_eq_ext cadd cmul copp ceq. Add Setoid C ceq Csth as C_setoid. Add Morphism cadd : cadd_ext. exact (Radd_ext Ceqe). Qed. Add Morphism cmul : cmul_ext. exact (Rmul_ext Ceqe). Qed. Add Morphism copp : copp_ext. exact (Ropp_ext Ceqe). Qed. Variable Cth : ring_theory cO cI cadd cmul csub copp ceq. Variable Smorph : semi_morph 0 1 radd rmul req cO cI cadd cmul ceqb phi. Variable phi_ext : forall x y, ceq x y -> [x] == [y]. Add Morphism phi : phi_ext1. exact phi_ext. Qed. Lemma Smorph_opp x : [-!x] == -[x]. Proof. rewrite <- (Rth.(Radd_0_l) [-!x]). rewrite <- ((Ropp_def Rth) [x]). rewrite ((Radd_comm Rth) [x]). rewrite <- (Radd_assoc Rth). rewrite <- (Smorph_add Smorph). rewrite (Ropp_def Cth). rewrite (Smorph0 Smorph). rewrite (Radd_comm Rth (-[x])). now apply (Radd_0_l Rth). Qed. Lemma Smorph_sub x y : [x -! y] == [x] - [y]. Proof. rewrite (Rsub_def Cth), (Rsub_def Rth). now rewrite (Smorph_add Smorph), Smorph_opp. Qed. Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. Proof (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi (Smorph0 Smorph) (Smorph1 Smorph) (Smorph_add Smorph) Smorph_sub (Smorph_mul Smorph) Smorph_opp (Smorph_eq Smorph)). End RING. (** Useful lemmas on almost ring *) Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. Lemma ARth_SRth : semi_ring_theory 0 1 radd rmul req. Proof. elim ARth; intros. constructor; trivial. Qed. Instance ARsub_ext : Proper (req ==> req ==> req) rsub. Proof. intros x1 x2 Ex y1 y2 Ey. now rewrite !(ARsub_def ARth), Ex, Ey. Qed. Ltac mrewrite := repeat first [ rewrite (ARadd_0_l ARth) | rewrite <- ((ARadd_comm ARth) 0) | rewrite (ARmul_1_l ARth) | rewrite <- ((ARmul_comm ARth) 1) | rewrite (ARmul_0_l ARth) | rewrite <- ((ARmul_comm ARth) 0) | rewrite (ARdistr_l ARth) | reflexivity | match goal with | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y)) end]. Lemma ARadd_0_r x : x + 0 == x. Proof. mrewrite. Qed. Lemma ARmul_1_r x : x * 1 == x. Proof. mrewrite. Qed. Lemma ARmul_0_r x : x * 0 == 0. Proof. mrewrite. Qed. Lemma ARdistr_r x y z : z * (x + y) == z*x + z*y. Proof. mrewrite. now rewrite !(ARth.(ARmul_comm) z). Qed. Lemma ARadd_assoc1 x y z : (x + y) + z == (y + z) + x. Proof. now rewrite <-(ARth.(ARadd_assoc) x), (ARth.(ARadd_comm) x). Qed. Lemma ARadd_assoc2 x y z : (y + x) + z == (y + z) + x. Proof. now rewrite <- !(ARadd_assoc ARth), ((ARadd_comm ARth) x). Qed. Lemma ARmul_assoc1 x y z : (x * y) * z == (y * z) * x. Proof. now rewrite <- ((ARmul_assoc ARth) x), ((ARmul_comm ARth) x). Qed. Lemma ARmul_assoc2 x y z : (y * x) * z == (y * z) * x. Proof. now rewrite <- !(ARmul_assoc ARth), ((ARmul_comm ARth) x). Qed. Lemma ARopp_mul_r x y : - (x * y) == x * -y. Proof. rewrite ((ARmul_comm ARth) x y), (ARopp_mul_l ARth). now apply (ARmul_comm ARth). Qed. Lemma ARopp_zero : -0 == 0. Proof. now rewrite <- (ARmul_0_r 0), (ARopp_mul_l ARth), !ARmul_0_r. Qed. End ALMOST_RING. Section AddRing. (* Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. *) Inductive ring_kind : Type := | Abstract | Computational (R:Type) (req : R -> R -> Prop) (reqb : R -> R -> bool) (_ : forall x y, (reqb x y) = true -> req x y) | Morphism (R : Type) (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R) (req : R -> R -> Prop) (C : Type) (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C) (ceqb : C->C->bool) phi (_ : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi). End AddRing. (** Some simplification tactics*) Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth). Ltac gen_srewrite Rsth Reqe ARth := repeat first [ gen_reflexivity Rsth | progress rewrite (ARopp_zero Rsth Reqe ARth) | rewrite (ARadd_0_l ARth) | rewrite (ARadd_0_r Rsth ARth) | rewrite (ARmul_1_l ARth) | rewrite (ARmul_1_r Rsth ARth) | rewrite (ARmul_0_l ARth) | rewrite (ARmul_0_r Rsth ARth) | rewrite (ARdistr_l ARth) | rewrite (ARdistr_r Rsth Reqe ARth) | rewrite (ARadd_assoc ARth) | rewrite (ARmul_assoc ARth) | progress rewrite (ARopp_add ARth) | progress rewrite (ARsub_def ARth) | progress rewrite <- (ARopp_mul_l ARth) | progress rewrite <- (ARopp_mul_r Rsth Reqe ARth) ]. Ltac gen_srewrite_sr Rsth Reqe ARth := repeat first [ gen_reflexivity Rsth | progress rewrite (ARopp_zero Rsth Reqe ARth) | rewrite (ARadd_0_l ARth) | rewrite (ARadd_0_r Rsth ARth) | rewrite (ARmul_1_l ARth) | rewrite (ARmul_1_r Rsth ARth) | rewrite (ARmul_0_l ARth) | rewrite (ARmul_0_r Rsth ARth) | rewrite (ARdistr_l ARth) | rewrite (ARdistr_r Rsth Reqe ARth) | rewrite (ARadd_assoc ARth) | rewrite (ARmul_assoc ARth) ]. Ltac gen_add_push add Rsth Reqe ARth x := repeat (match goal with | |- context [add (add ?y x) ?z] => progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z) | |- context [add (add x ?y) ?z] => progress rewrite (ARadd_assoc1 Rsth ARth x y z) | |- context [(add x ?y)] => progress rewrite (ARadd_comm ARth x y) end). Ltac gen_mul_push mul Rsth Reqe ARth x := repeat (match goal with | |- context [mul (mul ?y x) ?z] => progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z) | |- context [mul (mul x ?y) ?z] => progress rewrite (ARmul_assoc1 Rsth ARth x y z) | |- context [(mul x ?y)] => progress rewrite (ARmul_comm ARth x y) end). coq-8.6/plugins/setoid_ring/RealField.v0000644000175000017500000000624713022274260017475 0ustar mdenesmdenesRequire Import Nnat. Require Import ArithRing. Require Export Ring Field. Require Import Rdefinitions. Require Import Rpow_def. Require Import Raxioms. Local Open Scope R_scope. Lemma RTheory : ring_theory 0 1 Rplus Rmult Rminus Ropp (eq (A:=R)). Proof. constructor. intro; apply Rplus_0_l. exact Rplus_comm. symmetry ; apply Rplus_assoc. intro; apply Rmult_1_l. exact Rmult_comm. symmetry ; apply Rmult_assoc. intros m n p. rewrite Rmult_comm. rewrite (Rmult_comm n p). rewrite (Rmult_comm m p). apply Rmult_plus_distr_l. reflexivity. exact Rplus_opp_r. Qed. Lemma Rfield : field_theory 0 1 Rplus Rmult Rminus Ropp Rdiv Rinv (eq(A:=R)). Proof. constructor. exact RTheory. exact R1_neq_R0. reflexivity. exact Rinv_l. Qed. Lemma Rlt_n_Sn : forall x, x < x + 1. Proof. intro. elim archimed with x; intros. destruct H0. apply Rlt_trans with (IZR (up x)); trivial. replace (IZR (up x)) with (x + (IZR (up x) - x))%R. apply Rplus_lt_compat_l; trivial. unfold Rminus. rewrite (Rplus_comm (IZR (up x)) (- x)). rewrite <- Rplus_assoc. rewrite Rplus_opp_r. apply Rplus_0_l. elim H0. unfold Rminus. rewrite (Rplus_comm (IZR (up x)) (- x)). rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_0_l; trivial. Qed. Notation Rset := (Eqsth R). Notation Rext := (Eq_ext Rplus Rmult Ropp). Lemma Rlt_0_2 : 0 < 2. apply Rlt_trans with (0 + 1). apply Rlt_n_Sn. rewrite Rplus_comm. apply Rplus_lt_compat_l. replace 1 with (0 + 1). apply Rlt_n_Sn. apply Rplus_0_l. Qed. Lemma Rgen_phiPOS : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x > 0. unfold Rgt. induction x; simpl; intros. apply Rlt_trans with (1 + 0). rewrite Rplus_comm. apply Rlt_n_Sn. apply Rplus_lt_compat_l. rewrite <- (Rmul_0_l Rset Rext RTheory 2). rewrite Rmult_comm. apply Rmult_lt_compat_l. apply Rlt_0_2. trivial. rewrite <- (Rmul_0_l Rset Rext RTheory 2). rewrite Rmult_comm. apply Rmult_lt_compat_l. apply Rlt_0_2. trivial. replace 1 with (0 + 1). apply Rlt_n_Sn. apply Rplus_0_l. Qed. Lemma Rgen_phiPOS_not_0 : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x <> 0. red; intros. specialize (Rgen_phiPOS x). rewrite H; intro. apply (Rlt_asym 0 0); trivial. Qed. Lemma Zeq_bool_complete : forall x y, InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x = InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y -> Zeq_bool x y = true. Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0. Lemma Rdef_pow_add : forall (x:R) (n m:nat), pow x (n + m) = pow x n * pow x m. Proof. intros x n; elim n; simpl; auto with real. intros n0 H' m; rewrite H'; auto with real. Qed. Lemma R_power_theory : power_theory 1%R Rmult (@eq R) N.to_nat pow. Proof. constructor. destruct n. reflexivity. simpl. induction p. - rewrite Pos2Nat.inj_xI. simpl. now rewrite plus_0_r, Rdef_pow_add, IHp. - rewrite Pos2Nat.inj_xO. simpl. now rewrite plus_0_r, Rdef_pow_add, IHp. - simpl. rewrite Rmult_comm;apply Rmult_1_l. Qed. Ltac Rpow_tac t := match isnatcst t with | false => constr:(InitialRing.NotConstant) | _ => constr:(N.of_nat t) end. Add Field RField : Rfield (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]). coq-8.6/plugins/setoid_ring/Field_theory.v0000644000175000017500000015110713022274260020257 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R->R) (ropp : R->R). Variable (rdiv : R->R->R) (rinv : R->R). Variable req : R -> R -> Prop. Notation "0" := rO : R_scope. Notation "1" := rI : R_scope. Infix "+" := radd : R_scope. Infix "-" := rsub : R_scope. Infix "*" := rmul : R_scope. Infix "/" := rdiv : R_scope. Notation "- x" := (ropp x) : R_scope. Notation "/ x" := (rinv x) : R_scope. Infix "==" := req (at level 70, no associativity) : R_scope. (* Equality properties *) Variable Rsth : Equivalence req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable SRinv_ext : forall p q, p == q -> / p == / q. (* Field properties *) Record almost_field_theory : Prop := mk_afield { AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req; AF_1_neq_0 : ~ 1 == 0; AFdiv_def : forall p q, p / q == p * / q; AFinv_l : forall p, ~ p == 0 -> / p * p == 1 }. Section AlmostField. Variable AFth : almost_field_theory. Let ARth := AFth.(AF_AR). Let rI_neq_rO := AFth.(AF_1_neq_0). Let rdiv_def := AFth.(AFdiv_def). Let rinv_l := AFth.(AFinv_l). Add Morphism radd : radd_ext. Proof. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext. Proof. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext. Proof. exact (Ropp_ext Reqe). Qed. Add Morphism rsub : rsub_ext. Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. Add Morphism rinv : rinv_ext. Proof. exact SRinv_ext. Qed. Let eq_trans := Setoid.Seq_trans _ _ Rsth. Let eq_sym := Setoid.Seq_sym _ _ Rsth. Let eq_refl := Setoid.Seq_refl _ _ Rsth. Let radd_0_l := ARadd_0_l ARth. Let radd_comm := ARadd_comm ARth. Let radd_assoc := ARadd_assoc ARth. Let rmul_1_l := ARmul_1_l ARth. Let rmul_0_l := ARmul_0_l ARth. Let rmul_comm := ARmul_comm ARth. Let rmul_assoc := ARmul_assoc ARth. Let rdistr_l := ARdistr_l ARth. Let ropp_mul_l := ARopp_mul_l ARth. Let ropp_add := ARopp_add ARth. Let rsub_def := ARsub_def ARth. Let radd_0_r := ARadd_0_r Rsth ARth. Let rmul_0_r := ARmul_0_r Rsth ARth. Let rmul_1_r := ARmul_1_r Rsth ARth. Let ropp_0 := ARopp_zero Rsth Reqe ARth. Let rdistr_r := ARdistr_r Rsth Reqe ARth. (* Coefficients : C *) Variable C: Type. Bind Scope C_scope with C. Delimit Scope C_scope with coef. Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). Variable ceqb : C->C->bool. Variable phi : C -> R. Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. Notation "0" := cO : C_scope. Notation "1" := cI : C_scope. Infix "+" := cadd : C_scope. Infix "-" := csub : C_scope. Infix "*" := cmul : C_scope. Notation "- x" := (copp x) : C_scope. Infix "=?" := ceqb : C_scope. Notation "[ x ]" := (phi x) (at level 0). Let phi_0 := CRmorph.(morph0). Let phi_1 := CRmorph.(morph1). Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c =? c')%coef. Proof. generalize (CRmorph.(morph_eq) c c'). destruct (c =? c')%coef; auto. Qed. (* Power coefficients : Cpow *) Variable Cpow : Type. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. (* sign function *) Variable get_sign : C -> option C. Variable get_sign_spec : sign_theory copp ceqb get_sign. Variable cdiv:C -> C -> C*C. Variable cdiv_th : div_theory req cadd cmul phi cdiv. Let rpow_pow := pow_th.(rpow_pow_N). (* Polynomial expressions : (PExpr C) *) Bind Scope PE_scope with PExpr. Delimit Scope PE_scope with poly. Notation NPEeval := (PEeval rO rI radd rmul rsub ropp phi Cp_phi rpow). Notation "P @ l" := (NPEeval l P) (at level 10, no associativity). Arguments PEc _ _%coef. Notation "0" := (PEc 0) : PE_scope. Notation "1" := (PEc 1) : PE_scope. Infix "+" := PEadd : PE_scope. Infix "-" := PEsub : PE_scope. Infix "*" := PEmul : PE_scope. Notation "- e" := (PEopp e) : PE_scope. Infix "^" := PEpow : PE_scope. Definition NPEequiv e e' := forall l, e@l == e'@l. Infix "===" := NPEequiv (at level 70, no associativity) : PE_scope. Instance NPEequiv_eq : Equivalence NPEequiv. Proof. split; red; unfold NPEequiv; intros; [reflexivity|symmetry|etransitivity]; eauto. Qed. Instance NPEeval_ext : Proper (eq ==> NPEequiv ==> req) NPEeval. Proof. intros l l' <- e e' He. now rewrite (He l). Qed. Notation Nnorm := (norm_subst cO cI cadd cmul csub copp ceqb cdiv). Notation NPphi_dev := (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign). Notation NPphi_pow := (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign). (* add abstract semi-ring to help with some proofs *) Add Ring Rring : (ARth_SRth ARth). (* additional ring properties *) Lemma rsub_0_l r : 0 - r == - r. Proof. rewrite rsub_def; ring. Qed. Lemma rsub_0_r r : r - 0 == r. Proof. rewrite rsub_def, ropp_0; ring. Qed. (*************************************************************************** Properties of division ***************************************************************************) Theorem rdiv_simpl p q : ~ q == 0 -> q * (p / q) == p. Proof. intros. rewrite rdiv_def. transitivity (/ q * q * p); [ ring | ]. now rewrite rinv_l. Qed. Instance rdiv_ext: Proper (req ==> req ==> req) rdiv. Proof. intros p1 p2 Ep q1 q2 Eq. now rewrite !rdiv_def, Ep, Eq. Qed. Lemma rmul_reg_l p q1 q2 : ~ p == 0 -> p * q1 == p * q2 -> q1 == q2. Proof. intros H EQ. assert (H' : p * (q1 / p) == p * (q2 / p)). { now rewrite !rdiv_def, !rmul_assoc, EQ. } now rewrite !rdiv_simpl in H'. Qed. Theorem field_is_integral_domain r1 r2 : ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0. Proof. intros H1 H2. contradict H2. transitivity (/r1 * r1 * r2). - now rewrite rinv_l. - now rewrite <- rmul_assoc, H2. Qed. Theorem ropp_neq_0 r : ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0. Proof. intros. setoid_replace (- r) with (- (1) * r). - apply field_is_integral_domain; trivial. - now rewrite <- ropp_mul_l, rmul_1_l. Qed. Theorem rdiv_r_r r : ~ r == 0 -> r / r == 1. Proof. intros. rewrite rdiv_def, rmul_comm. now apply rinv_l. Qed. Theorem rdiv1 r : r == r / 1. Proof. transitivity (1 * (r / 1)). - symmetry; apply rdiv_simpl. apply rI_neq_rO. - apply rmul_1_l. Qed. Theorem rdiv2 a b c d : ~ b == 0 -> ~ d == 0 -> a / b + c / d == (a * d + c * b) / (b * d). Proof. intros H H0. assert (~ b * d == 0) by now apply field_is_integral_domain. apply rmul_reg_l with (b * d); trivial. rewrite rdiv_simpl; trivial. rewrite rdistr_r. apply radd_ext. - now rewrite <- rmul_assoc, (rmul_comm d), rmul_assoc, rdiv_simpl. - now rewrite (rmul_comm c), <- rmul_assoc, rdiv_simpl. Qed. Theorem rdiv2b a b c d e : ~ (b*e) == 0 -> ~ (d*e) == 0 -> a / (b*e) + c / (d*e) == (a * d + c * b) / (b * (d * e)). Proof. intros H H0. assert (~ b == 0) by (contradict H; rewrite H; ring). assert (~ e == 0) by (contradict H; rewrite H; ring). assert (~ d == 0) by (contradict H0; rewrite H0; ring). assert (~ b * (d * e) == 0) by (repeat apply field_is_integral_domain; trivial). apply rmul_reg_l with (b * (d * e)); trivial. rewrite rdiv_simpl; trivial. rewrite rdistr_r. apply radd_ext. - transitivity ((b * e) * (a / (b * e)) * d); [ ring | now rewrite rdiv_simpl ]. - transitivity ((d * e) * (c / (d * e)) * b); [ ring | now rewrite rdiv_simpl ]. Qed. Theorem rdiv5 a b : - (a / b) == - a / b. Proof. now rewrite !rdiv_def, ropp_mul_l. Qed. Theorem rdiv3b a b c d e : ~ (b * e) == 0 -> ~ (d * e) == 0 -> a / (b*e) - c / (d*e) == (a * d - c * b) / (b * (d * e)). Proof. intros H H0. rewrite !rsub_def, rdiv5, ropp_mul_l. now apply rdiv2b. Qed. Theorem rdiv6 a b : ~ a == 0 -> ~ b == 0 -> / (a / b) == b / a. Proof. intros H H0. assert (Hk : ~ a / b == 0). { contradict H. transitivity (b * (a / b)). - now rewrite rdiv_simpl. - rewrite H. apply rmul_0_r. } apply rmul_reg_l with (a / b); trivial. rewrite (rmul_comm (a / b)), rinv_l; trivial. rewrite !rdiv_def. transitivity (/ a * a * (/ b * b)); [ | ring ]. now rewrite !rinv_l, rmul_1_l. Qed. Theorem rdiv4 a b c d : ~ b == 0 -> ~ d == 0 -> (a / b) * (c / d) == (a * c) / (b * d). Proof. intros H H0. assert (~ b * d == 0) by now apply field_is_integral_domain. apply rmul_reg_l with (b * d); trivial. rewrite rdiv_simpl; trivial. transitivity (b * (a / b) * (d * (c / d))); [ ring | ]. rewrite !rdiv_simpl; trivial. Qed. Theorem rdiv4b a b c d e f : ~ b * e == 0 -> ~ d * f == 0 -> ((a * f) / (b * e)) * ((c * e) / (d * f)) == (a * c) / (b * d). Proof. intros H H0. assert (~ b == 0) by (contradict H; rewrite H; ring). assert (~ e == 0) by (contradict H; rewrite H; ring). assert (~ d == 0) by (contradict H0; rewrite H0; ring). assert (~ f == 0) by (contradict H0; rewrite H0; ring). assert (~ b*d == 0) by now apply field_is_integral_domain. assert (~ e*f == 0) by now apply field_is_integral_domain. rewrite rdiv4; trivial. transitivity ((e * f) * (a * c) / ((e * f) * (b * d))). - apply rdiv_ext; ring. - rewrite <- rdiv4, rdiv_r_r; trivial. Qed. Theorem rdiv7 a b c d : ~ b == 0 -> ~ c == 0 -> ~ d == 0 -> (a / b) / (c / d) == (a * d) / (b * c). Proof. intros. rewrite (rdiv_def (a / b)). rewrite rdiv6; trivial. apply rdiv4; trivial. Qed. Theorem rdiv7b a b c d e f : ~ b * f == 0 -> ~ c * e == 0 -> ~ d * f == 0 -> ((a * e) / (b * f)) / ((c * e) / (d * f)) == (a * d) / (b * c). Proof. intros Hbf Hce Hdf. assert (~ c==0) by (contradict Hce; rewrite Hce; ring). assert (~ e==0) by (contradict Hce; rewrite Hce; ring). assert (~ b==0) by (contradict Hbf; rewrite Hbf; ring). assert (~ f==0) by (contradict Hbf; rewrite Hbf; ring). assert (~ b*c==0) by now apply field_is_integral_domain. assert (~ e*f==0) by now apply field_is_integral_domain. rewrite rdiv7; trivial. transitivity ((e * f) * (a * d) / ((e * f) * (b * c))). - apply rdiv_ext; ring. - now rewrite <- rdiv4, rdiv_r_r. Qed. Theorem rinv_nz a : ~ a == 0 -> ~ /a == 0. Proof. intros H H0. apply rI_neq_rO. rewrite <- (rdiv_r_r H), rdiv_def, H0. apply rmul_0_r. Qed. Theorem rdiv8 a b : ~ b == 0 -> a == 0 -> a / b == 0. Proof. intros H H0. now rewrite rdiv_def, H0, rmul_0_l. Qed. Theorem cross_product_eq a b c d : ~ b == 0 -> ~ d == 0 -> a * d == c * b -> a / b == c / d. Proof. intros. transitivity (a / b * (d / d)). - now rewrite rdiv_r_r, rmul_1_r. - now rewrite rdiv4, H1, (rmul_comm b d), <- rdiv4, rdiv_r_r. Qed. (* Results about [pow_pos] and [pow_N] *) Instance pow_ext : Proper (req ==> eq ==> req) (pow_pos rmul). Proof. intros x y H p p' <-. induction p as [p IH| p IH|];simpl; trivial; now rewrite !IH, ?H. Qed. Instance pow_N_ext : Proper (req ==> eq ==> req) (pow_N rI rmul). Proof. intros x y H n n' <-. destruct n; simpl; trivial. now apply pow_ext. Qed. Lemma pow_pos_0 p : pow_pos rmul 0 p == 0. Proof. induction p;simpl;trivial; now rewrite !IHp. Qed. Lemma pow_pos_1 p : pow_pos rmul 1 p == 1. Proof. induction p;simpl;trivial; ring [IHp]. Qed. Lemma pow_pos_cst c p : pow_pos rmul [c] p == [pow_pos cmul c p]. Proof. induction p;simpl;trivial; now rewrite !CRmorph.(morph_mul), !IHp. Qed. Lemma pow_pos_mul_l x y p : pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p. Proof. induction p;simpl;trivial; ring [IHp]. Qed. Lemma pow_pos_add_r x p1 p2 : pow_pos rmul x (p1+p2) == pow_pos rmul x p1 * pow_pos rmul x p2. Proof. exact (Ring_theory.pow_pos_add Rsth rmul_ext rmul_assoc x p1 p2). Qed. Lemma pow_pos_mul_r x p1 p2 : pow_pos rmul x (p1*p2) == pow_pos rmul (pow_pos rmul x p1) p2. Proof. induction p1;simpl;intros; rewrite ?pow_pos_mul_l, ?pow_pos_add_r; simpl; trivial; ring [IHp1]. Qed. Lemma pow_pos_nz x p : ~x==0 -> ~pow_pos rmul x p == 0. Proof. intros Hx. induction p;simpl;trivial; repeat (apply field_is_integral_domain; trivial). Qed. Lemma pow_pos_div a b p : ~ b == 0 -> pow_pos rmul (a / b) p == pow_pos rmul a p / pow_pos rmul b p. Proof. intros. induction p; simpl; trivial. - rewrite IHp. assert (nz := pow_pos_nz p H). rewrite !rdiv4; trivial. apply field_is_integral_domain; trivial. - rewrite IHp. assert (nz := pow_pos_nz p H). rewrite !rdiv4; trivial. Qed. (* === is a morphism *) Instance PEadd_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEadd C). Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed. Instance PEsub_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEsub C). Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed. Instance PEmul_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEmul C). Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed. Instance PEopp_ext : Proper (NPEequiv ==> NPEequiv) (@PEopp C). Proof. intros ? ? E l. simpl. now rewrite E. Qed. Instance PEpow_ext : Proper (NPEequiv ==> eq ==> NPEequiv) (@PEpow C). Proof. intros ? ? E ? ? <- l. simpl. rewrite !rpow_pow. apply pow_N_ext; trivial. Qed. Lemma PE_1_l (e : PExpr C) : (1 * e === e)%poly. Proof. intros l. simpl. rewrite phi_1. apply rmul_1_l. Qed. Lemma PE_1_r (e : PExpr C) : (e * 1 === e)%poly. Proof. intros l. simpl. rewrite phi_1. apply rmul_1_r. Qed. Lemma PEpow_0_r (e : PExpr C) : (e ^ 0 === 1)%poly. Proof. intros l. simpl. now rewrite !rpow_pow. Qed. Lemma PEpow_1_r (e : PExpr C) : (e ^ 1 === e)%poly. Proof. intros l. simpl. now rewrite !rpow_pow. Qed. Lemma PEpow_1_l n : (1 ^ n === 1)%poly. Proof. intros l. simpl. rewrite rpow_pow. destruct n; simpl. - now rewrite phi_1. - now rewrite phi_1, pow_pos_1. Qed. Lemma PEpow_add_r (e : PExpr C) n n' : (e ^ (n+n') === e ^ n * e ^ n')%poly. Proof. intros l. simpl. rewrite !rpow_pow. destruct n; simpl. - rewrite rmul_1_l. trivial. - destruct n'; simpl. + rewrite rmul_1_r. trivial. + apply pow_pos_add_r. Qed. Lemma PEpow_mul_l (e e' : PExpr C) n : ((e * e') ^ n === e ^ n * e' ^ n)%poly. Proof. intros l. simpl. rewrite !rpow_pow. destruct n; simpl; trivial. - symmetry; apply rmul_1_l. - apply pow_pos_mul_l. Qed. Lemma PEpow_mul_r (e : PExpr C) n n' : (e ^ (n * n') === (e ^ n) ^ n')%poly. Proof. intros l. simpl. rewrite !rpow_pow. destruct n, n'; simpl; trivial. - now rewrite pow_pos_1. - apply pow_pos_mul_r. Qed. Lemma PEpow_nz l e n : ~ e @ l == 0 -> ~ (e^n) @ l == 0. Proof. intros. simpl. rewrite rpow_pow. destruct n; simpl. - apply rI_neq_rO. - now apply pow_pos_nz. Qed. (*************************************************************************** Some equality test ***************************************************************************) Local Notation "a &&& b" := (if a then b else false) (at level 40, left associativity). (* equality test *) Fixpoint PExpr_eq (e e' : PExpr C) {struct e} : bool := match e, e' with | PEc c, PEc c' => ceqb c c' | PEX _ p, PEX _ p' => Pos.eqb p p' | e1 + e2, e1' + e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' | e1 - e2, e1' - e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' | e1 * e2, e1' * e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' | - e, - e' => PExpr_eq e e' | e ^ n, e' ^ n' => N.eqb n n' &&& PExpr_eq e e' | _, _ => false end%poly. Lemma if_true (a b : bool) : a &&& b = true -> a = true /\ b = true. Proof. destruct a, b; split; trivial. Qed. Theorem PExpr_eq_semi_ok e e' : PExpr_eq e e' = true -> (e === e')%poly. Proof. revert e'; induction e; destruct e'; simpl; try discriminate. - intros H l. now apply (morph_eq CRmorph). - case Pos.eqb_spec; intros; now subst. - intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. - intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. - intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. - intros H. now rewrite IHe. - intros H. destruct (if_true _ _ H). apply N.eqb_eq in H0. now rewrite IHe, H0. Qed. Lemma PExpr_eq_spec e e' : BoolSpec (e === e')%poly True (PExpr_eq e e'). Proof. assert (H := PExpr_eq_semi_ok e e'). destruct PExpr_eq; constructor; intros; trivial. now apply H. Qed. (** Smart constructors for polynomial expression, with reduction of constants *) Definition NPEadd e1 e2 := match e1, e2 with | PEc c1, PEc c2 => PEc (c1 + c2) | PEc c, _ => if (c =? 0)%coef then e2 else e1 + e2 | _, PEc c => if (c =? 0)%coef then e1 else e1 + e2 (* Peut t'on factoriser ici ??? *) | _, _ => (e1 + e2) end%poly. Infix "++" := NPEadd (at level 60, right associativity). Theorem NPEadd_ok e1 e2 : (e1 ++ e2 === e1 + e2)%poly. Proof. intros l. destruct e1, e2; simpl; try reflexivity; try (case ceqb_spec); try intro H; try rewrite H; simpl; try apply eq_refl; try (ring [phi_0]). apply (morph_add CRmorph). Qed. Definition NPEsub e1 e2 := match e1, e2 with | PEc c1, PEc c2 => PEc (c1 - c2) | PEc c, _ => if (c =? 0)%coef then - e2 else e1 - e2 | _, PEc c => if (c =? 0)%coef then e1 else e1 - e2 (* Peut-on factoriser ici *) | _, _ => e1 - e2 end%poly. Infix "--" := NPEsub (at level 50, left associativity). Theorem NPEsub_ok e1 e2: (e1 -- e2 === e1 - e2)%poly. Proof. intros l. destruct e1, e2; simpl; try reflexivity; try case ceqb_spec; try intro H; try rewrite H; simpl; try rewrite phi_0; try reflexivity; try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r). apply (morph_sub CRmorph). Qed. Definition NPEopp e1 := match e1 with PEc c1 => PEc (- c1) | _ => - e1 end%poly. Theorem NPEopp_ok e : (NPEopp e === -e)%poly. Proof. intros l. destruct e; simpl; trivial. apply (morph_opp CRmorph). Qed. Definition NPEpow x n := match n with | N0 => 1 | Npos p => if (p =? 1)%positive then x else match x with | PEc c => if (c =? 1)%coef then 1 else if (c =? 0)%coef then 0 else PEc (pow_pos cmul c p) | _ => x ^ n end end%poly. Infix "^^" := NPEpow (at level 35, right associativity). Theorem NPEpow_ok e n : (e ^^ n === e ^ n)%poly. Proof. intros l. unfold NPEpow; destruct n. - simpl; now rewrite rpow_pow. - case Pos.eqb_spec; [intro; subst | intros _]. + simpl. now rewrite rpow_pow. + destruct e;simpl;trivial. repeat case ceqb_spec; intros; rewrite ?rpow_pow, ?H; simpl. * now rewrite phi_1, pow_pos_1. * now rewrite phi_0, pow_pos_0. * now rewrite pow_pos_cst. Qed. Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := match x, y with | PEc c1, PEc c2 => PEc (c1 * c2) | PEc c, _ => if (c =? 1)%coef then y else if (c =? 0)%coef then 0 else x * y | _, PEc c => if (c =? 1)%coef then x else if (c =? 0)%coef then 0 else x * y | e1 ^ n1, e2 ^ n2 => if (n1 =? n2)%N then (NPEmul e1 e2)^^n1 else x * y | _, _ => x * y end%poly. Infix "**" := NPEmul (at level 40, left associativity). Theorem NPEmul_ok e1 e2 : (e1 ** e2 === e1 * e2)%poly. Proof. intros l. revert e2; induction e1;destruct e2; simpl;try reflexivity; repeat (case ceqb_spec; intro H; try rewrite H; clear H); simpl; try reflexivity; try ring [phi_0 phi_1]. apply (morph_mul CRmorph). case N.eqb_spec; [intros <- | reflexivity]. rewrite NPEpow_ok. simpl. rewrite !rpow_pow. rewrite IHe1. destruct n; simpl; [ ring | apply pow_pos_mul_l ]. Qed. (* simplification *) Fixpoint PEsimp (e : PExpr C) : PExpr C := match e with | e1 + e2 => (PEsimp e1) ++ (PEsimp e2) | e1 * e2 => (PEsimp e1) ** (PEsimp e2) | e1 - e2 => (PEsimp e1) -- (PEsimp e2) | - e1 => NPEopp (PEsimp e1) | e1 ^ n1 => (PEsimp e1) ^^ n1 | _ => e end%poly. Theorem PEsimp_ok e : (PEsimp e === e)%poly. Proof. induction e; simpl. - reflexivity. - reflexivity. - intro l; trivial. - intro l; trivial. - rewrite NPEadd_ok. now f_equiv. - rewrite NPEsub_ok. now f_equiv. - rewrite NPEmul_ok. now f_equiv. - rewrite NPEopp_ok. now f_equiv. - rewrite NPEpow_ok. now f_equiv. Qed. (**************************************************************************** Datastructure ***************************************************************************) (* The input: syntax of a field expression *) Inductive FExpr : Type := | FEO : FExpr | FEI : FExpr | FEc: C -> FExpr | FEX: positive -> FExpr | FEadd: FExpr -> FExpr -> FExpr | FEsub: FExpr -> FExpr -> FExpr | FEmul: FExpr -> FExpr -> FExpr | FEopp: FExpr -> FExpr | FEinv: FExpr -> FExpr | FEdiv: FExpr -> FExpr -> FExpr | FEpow: FExpr -> N -> FExpr . Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := match pe with | FEO => rO | FEI => rI | FEc c => phi c | FEX x => BinList.nth 0 x l | FEadd x y => FEeval l x + FEeval l y | FEsub x y => FEeval l x - FEeval l y | FEmul x y => FEeval l x * FEeval l y | FEopp x => - FEeval l x | FEinv x => / FEeval l x | FEdiv x y => FEeval l x / FEeval l y | FEpow x n => rpow (FEeval l x) (Cp_phi n) end. Strategy expand [FEeval]. (* The result of the normalisation *) Record linear : Type := mk_linear { num : PExpr C; denum : PExpr C; condition : list (PExpr C) }. (*************************************************************************** Semantics and properties of side condition ***************************************************************************) Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop := match le with | nil => True | e1 :: nil => ~ req (e1 @ l) rO | e1 :: l1 => ~ req (e1 @ l) rO /\ PCond l l1 end. Theorem PCond_cons l a l1 : PCond l (a :: l1) <-> ~ a @ l == 0 /\ PCond l l1. Proof. destruct l1. - simpl. split; [split|destruct 1]; trivial. - reflexivity. Qed. Theorem PCond_cons_inv_l l a l1 : PCond l (a::l1) -> ~ a @ l == 0. Proof. rewrite PCond_cons. now destruct 1. Qed. Theorem PCond_cons_inv_r l a l1 : PCond l (a :: l1) -> PCond l l1. Proof. rewrite PCond_cons. now destruct 1. Qed. Theorem PCond_app l l1 l2 : PCond l (l1 ++ l2) <-> PCond l l1 /\ PCond l l2. Proof. induction l1. - simpl. split; [split|destruct 1]; trivial. - simpl app. rewrite !PCond_cons, IHl1. symmetry; apply and_assoc. Qed. (* An unsatisfiable condition: issued when a division by zero is detected *) Definition absurd_PCond := cons 0%poly nil. Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond. Proof. unfold absurd_PCond; simpl. red; intros. apply H. apply phi_0. Qed. (*************************************************************************** Normalisation ***************************************************************************) Definition default_isIn e1 p1 e2 p2 := if PExpr_eq e1 e2 then match Z.pos_sub p1 p2 with | Zpos p => Some (Npos p, 1%poly) | Z0 => Some (N0, 1%poly) | Zneg p => Some (N0, e2 ^^ Npos p) end else None. Fixpoint isIn e1 p1 e2 p2 {struct e2}: option (N * PExpr C) := match e2 with | e3 * e4 => match isIn e1 p1 e3 p2 with | Some (N0, e5) => Some (N0, e5 ** (e4 ^^ Npos p2)) | Some (Npos p, e5) => match isIn e1 p e4 p2 with | Some (n, e6) => Some (n, e5 ** e6) | None => Some (Npos p, e5 ** (e4 ^^ Npos p2)) end | None => match isIn e1 p1 e4 p2 with | Some (n, e5) => Some (n, (e3 ^^ Npos p2) ** e5) | None => None end end | e3 ^ N0 => None | e3 ^ Npos p3 => isIn e1 p1 e3 (Pos.mul p3 p2) | _ => default_isIn e1 p1 e2 p2 end%poly. Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end. Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end. Lemma Z_pos_sub_gt p q : (p > q)%positive -> Z.pos_sub p q = Zpos (p - q). Proof. intros; now apply Z.pos_sub_gt, Pos.gt_lt. Qed. Ltac simpl_pos_sub := rewrite ?Z_pos_sub_gt in * by assumption. Lemma default_isIn_ok e1 e2 p1 p2 : match default_isIn e1 p1 e2 p2 with | Some(n, e3) => let n' := ZtoN (Zpos p1 - NtoZ n) in (e2 ^ N.pos p2 === e1 ^ n' * e3)%poly /\ (Zpos p1 > NtoZ n)%Z | _ => True end. Proof. unfold default_isIn. case PExpr_eq_spec; trivial. intros EQ. rewrite Z.pos_sub_spec. case Pos.compare_spec;intros H; split; try reflexivity. - simpl. now rewrite PE_1_r, H, EQ. - rewrite NPEpow_ok, EQ, <- PEpow_add_r. f_equiv. simpl. f_equiv. now rewrite Pos.add_comm, Pos.sub_add. - simpl. rewrite PE_1_r, EQ. f_equiv. rewrite Z.pos_sub_gt by now apply Pos.sub_decr. simpl. f_equiv. rewrite Pos.sub_sub_distr, Pos.add_comm; trivial. rewrite Pos.add_sub; trivial. apply Pos.sub_decr; trivial. - simpl. now apply Z.lt_gt, Pos.sub_decr. Qed. Ltac npe_simpl := rewrite ?NPEmul_ok, ?NPEpow_ok, ?PEpow_mul_l. Ltac npe_ring := intro l; simpl; ring. Theorem isIn_ok e1 p1 e2 p2 : match isIn e1 p1 e2 p2 with | Some(n, e3) => let n' := ZtoN (Zpos p1 - NtoZ n) in (e2 ^ N.pos p2 === e1 ^ n' * e3)%poly /\ (Zpos p1 > NtoZ n)%Z | _ => True end. Proof. Opaque NPEpow. revert p1 p2. induction e2; intros p1 p2; try refine (default_isIn_ok e1 _ p1 p2); simpl isIn. - specialize (IHe2_1 p1 p2). destruct isIn as [([|p],e)|]. + split; [|reflexivity]. clear IHe2_2. destruct IHe2_1 as (IH,_). npe_simpl. rewrite IH. npe_ring. + specialize (IHe2_2 p p2). destruct isIn as [([|p'],e')|]. * destruct IHe2_1 as (IH1,GT1). destruct IHe2_2 as (IH2,GT2). split; [|simpl; apply Zgt_trans with (Z.pos p); trivial]. npe_simpl. rewrite IH1, IH2. simpl. simpl_pos_sub. simpl. replace (N.pos p1) with (N.pos p + N.pos (p1 - p))%N. rewrite PEpow_add_r; npe_ring. { simpl. f_equal. rewrite Pos.add_comm, Pos.sub_add. trivial. now apply Pos.gt_lt. } * destruct IHe2_1 as (IH1,GT1). destruct IHe2_2 as (IH2,GT2). assert (Z.pos p1 > Z.pos p')%Z by (now apply Zgt_trans with (Zpos p)). split; [|simpl; trivial]. npe_simpl. rewrite IH1, IH2. simpl. simpl_pos_sub. simpl. replace (N.pos (p1 - p')) with (N.pos (p1 - p) + N.pos (p - p'))%N. rewrite PEpow_add_r; npe_ring. { simpl. f_equal. rewrite Pos.add_sub_assoc, Pos.sub_add; trivial. now apply Pos.gt_lt. now apply Pos.gt_lt. } * destruct IHe2_1 as (IH,GT). split; trivial. npe_simpl. rewrite IH. npe_ring. + specialize (IHe2_2 p1 p2). destruct isIn as [(n,e)|]; trivial. destruct IHe2_2 as (IH,GT). split; trivial. set (d := ZtoN (Z.pos p1 - NtoZ n)) in *; clearbody d. npe_simpl. rewrite IH. npe_ring. - destruct n; trivial. specialize (IHe2 p1 (p * p2)%positive). destruct isIn as [(n,e)|]; trivial. destruct IHe2 as (IH,GT). split; trivial. set (d := ZtoN (Z.pos p1 - NtoZ n)) in *; clearbody d. now rewrite <- PEpow_mul_r. Qed. Record rsplit : Type := mk_rsplit { rsplit_left : PExpr C; rsplit_common : PExpr C; rsplit_right : PExpr C}. (* Stupid name clash *) Notation left := rsplit_left. Notation right := rsplit_right. Notation common := rsplit_common. Fixpoint split_aux e1 p e2 {struct e1}: rsplit := match e1 with | e3 * e4 => let r1 := split_aux e3 p e2 in let r2 := split_aux e4 p (right r1) in mk_rsplit (left r1 ** left r2) (common r1 ** common r2) (right r2) | e3 ^ N0 => mk_rsplit 1 1 e2 | e3 ^ Npos p3 => split_aux e3 (Pos.mul p3 p) e2 | _ => match isIn e1 p e2 1 with | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3 | Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3 | None => mk_rsplit (e1 ^^ Npos p) 1 e2 end end%poly. Lemma split_aux_ok1 e1 p e2 : (let res := match isIn e1 p e2 1 with | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3 | Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3 | None => mk_rsplit (e1 ^^ Npos p) 1 e2 end in e1 ^ Npos p === left res * common res /\ e2 === right res * common res)%poly. Proof. Opaque NPEpow NPEmul. intros. unfold res;clear res; generalize (isIn_ok e1 p e2 xH). destruct (isIn e1 p e2 1) as [([|p'],e')|]; simpl. - intros (H1,H2); split; npe_simpl. + now rewrite PE_1_l. + rewrite PEpow_1_r in H1. rewrite H1. npe_ring. - intros (H1,H2); split; npe_simpl. + rewrite <- PEpow_add_r. f_equiv. simpl. f_equal. rewrite Pos.add_comm, Pos.sub_add; trivial. now apply Z.gt_lt in H2. + rewrite PEpow_1_r in H1. rewrite H1. simpl_pos_sub. simpl. npe_ring. - intros _; split; npe_simpl; now rewrite PE_1_r. Qed. Theorem split_aux_ok: forall e1 p e2, (e1 ^ Npos p === left (split_aux e1 p e2) * common (split_aux e1 p e2) /\ e2 === right (split_aux e1 p e2) * common (split_aux e1 p e2))%poly. Proof. induction e1;intros k e2; try refine (split_aux_ok1 _ k e2);simpl. destruct (IHe1_1 k e2) as (H1,H2). destruct (IHe1_2 k (right (split_aux e1_1 k e2))) as (H3,H4). clear IHe1_1 IHe1_2. - npe_simpl; split. * rewrite H1, H3. npe_ring. * rewrite H2 at 1. rewrite H4 at 1. npe_ring. - destruct n; simpl. + rewrite PEpow_0_r, PEpow_1_l, !PE_1_r. now split. + rewrite <- PEpow_mul_r. simpl. apply IHe1. Qed. Definition split e1 e2 := split_aux e1 xH e2. Theorem split_ok_l e1 e2 : (e1 === left (split e1 e2) * common (split e1 e2))%poly. Proof. destruct (split_aux_ok e1 xH e2) as (H,_). now rewrite <- H, PEpow_1_r. Qed. Theorem split_ok_r e1 e2 : (e2 === right (split e1 e2) * common (split e1 e2))%poly. Proof. destruct (split_aux_ok e1 xH e2) as (_,H). trivial. Qed. Lemma split_nz_l l e1 e2 : ~ e1 @ l == 0 -> ~ left (split e1 e2) @ l == 0. Proof. intros H. contradict H. rewrite (split_ok_l e1 e2); simpl. now rewrite H, rmul_0_l. Qed. Lemma split_nz_r l e1 e2 : ~ e2 @ l == 0 -> ~ right (split e1 e2) @ l == 0. Proof. intros H. contradict H. rewrite (split_ok_r e1 e2); simpl. now rewrite H, rmul_0_l. Qed. Fixpoint Fnorm (e : FExpr) : linear := match e with | FEO => mk_linear 0 1 nil | FEI => mk_linear 1 1 nil | FEc c => mk_linear (PEc c) 1 nil | FEX x => mk_linear (PEX C x) 1 nil | FEadd e1 e2 => let x := Fnorm e1 in let y := Fnorm e2 in let s := split (denum x) (denum y) in mk_linear ((num x ** right s) ++ (num y ** left s)) (left s ** (right s ** common s)) (condition x ++ condition y)%list | FEsub e1 e2 => let x := Fnorm e1 in let y := Fnorm e2 in let s := split (denum x) (denum y) in mk_linear ((num x ** right s) -- (num y ** left s)) (left s ** (right s ** common s)) (condition x ++ condition y)%list | FEmul e1 e2 => let x := Fnorm e1 in let y := Fnorm e2 in let s1 := split (num x) (denum y) in let s2 := split (num y) (denum x) in mk_linear (left s1 ** left s2) (right s2 ** right s1) (condition x ++ condition y)%list | FEopp e1 => let x := Fnorm e1 in mk_linear (NPEopp (num x)) (denum x) (condition x) | FEinv e1 => let x := Fnorm e1 in mk_linear (denum x) (num x) (num x :: condition x) | FEdiv e1 e2 => let x := Fnorm e1 in let y := Fnorm e2 in let s1 := split (num x) (num y) in let s2 := split (denum x) (denum y) in mk_linear (left s1 ** right s2) (left s2 ** right s1) (num y :: condition x ++ condition y)%list | FEpow e1 n => let x := Fnorm e1 in mk_linear ((num x)^^n) ((denum x)^^n) (condition x) end. (* Example *) (* Eval compute in (Fnorm (FEdiv (FEc cI) (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))). *) Theorem Pcond_Fnorm l e : PCond l (condition (Fnorm e)) -> ~ (denum (Fnorm e))@l == 0. Proof. induction e; simpl condition; rewrite ?PCond_cons, ?PCond_app; simpl denum; intros (Hc1,Hc2) || intros Hc; rewrite ?NPEmul_ok. - simpl. rewrite phi_1; exact rI_neq_rO. - simpl. rewrite phi_1; exact rI_neq_rO. - simpl; intros. rewrite phi_1; exact rI_neq_rO. - simpl; intros. rewrite phi_1; exact rI_neq_rO. - rewrite <- split_ok_r. simpl. apply field_is_integral_domain. + apply split_nz_l, IHe1, Hc1. + apply IHe2, Hc2. - rewrite <- split_ok_r. simpl. apply field_is_integral_domain. + apply split_nz_l, IHe1, Hc1. + apply IHe2, Hc2. - simpl. apply field_is_integral_domain. + apply split_nz_r, IHe1, Hc1. + apply split_nz_r, IHe2, Hc2. - now apply IHe. - trivial. - destruct Hc2 as (Hc2,_). simpl. apply field_is_integral_domain. + apply split_nz_l, IHe1, Hc2. + apply split_nz_r, Hc1. - rewrite NPEpow_ok. apply PEpow_nz, IHe, Hc. Qed. (*************************************************************************** Main theorem ***************************************************************************) Ltac uneval := repeat match goal with | |- context [ ?x @ ?l * ?y @ ?l ] => change (x@l * y@l) with ((x*y)@l) | |- context [ ?x @ ?l + ?y @ ?l ] => change (x@l + y@l) with ((x+y)@l) end. Theorem Fnorm_FEeval_PEeval l fe: PCond l (condition (Fnorm fe)) -> FEeval l fe == (num (Fnorm fe)) @ l / (denum (Fnorm fe)) @ l. Proof. induction fe; simpl condition; rewrite ?PCond_cons, ?PCond_app; simpl; intros (Hc1,Hc2) || intros Hc; try (specialize (IHfe1 Hc1);apply Pcond_Fnorm in Hc1); try (specialize (IHfe2 Hc2);apply Pcond_Fnorm in Hc2); try set (F1 := Fnorm fe1) in *; try set (F2 := Fnorm fe2) in *. - now rewrite phi_1, phi_0, rdiv_def. - now rewrite phi_1; apply rdiv1. - rewrite phi_1; apply rdiv1. - rewrite phi_1; apply rdiv1. - rewrite NPEadd_ok, !NPEmul_ok. simpl. rewrite <- rdiv2b; uneval; rewrite <- ?split_ok_l, <- ?split_ok_r; trivial. now f_equiv. - rewrite NPEsub_ok, !NPEmul_ok. simpl. rewrite <- rdiv3b; uneval; rewrite <- ?split_ok_l, <- ?split_ok_r; trivial. now f_equiv. - rewrite !NPEmul_ok. simpl. rewrite IHfe1, IHfe2. rewrite (split_ok_l (num F1) (denum F2) l), (split_ok_r (num F1) (denum F2) l), (split_ok_l (num F2) (denum F1) l), (split_ok_r (num F2) (denum F1) l) in *. apply rdiv4b; trivial. - rewrite NPEopp_ok; simpl; rewrite (IHfe Hc); apply rdiv5. - rewrite (IHfe Hc2); apply rdiv6; trivial; apply Pcond_Fnorm; trivial. - destruct Hc2 as (Hc2,Hc3). rewrite !NPEmul_ok. simpl. assert (U1 := split_ok_l (num F1) (num F2) l). assert (U2 := split_ok_r (num F1) (num F2) l). assert (U3 := split_ok_l (denum F1) (denum F2) l). assert (U4 := split_ok_r (denum F1) (denum F2) l). rewrite (IHfe1 Hc2), (IHfe2 Hc3), U1, U2, U3, U4. simpl in U2, U3, U4. apply rdiv7b; rewrite <- ?U2, <- ?U3, <- ?U4; try apply Pcond_Fnorm; trivial. - rewrite !NPEpow_ok. simpl. rewrite !rpow_pow, (IHfe Hc). destruct n; simpl. + apply rdiv1. + apply pow_pos_div. apply Pcond_Fnorm; trivial. Qed. Theorem Fnorm_crossproduct l fe1 fe2 : let nfe1 := Fnorm fe1 in let nfe2 := Fnorm fe2 in (num nfe1 * denum nfe2) @ l == (num nfe2 * denum nfe1) @ l -> PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. Proof. simpl. rewrite PCond_app. intros Hcrossprod (Hc1,Hc2). rewrite !Fnorm_FEeval_PEeval; trivial. apply cross_product_eq; trivial; apply Pcond_Fnorm; trivial. Qed. (* Correctness lemmas of reflexive tactics *) Notation Ninterp_PElist := (interp_PElist rO rI radd rmul rsub ropp req phi Cp_phi rpow). Notation Nmk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv). Theorem Fnorm_ok: forall n l lpe fe, Ninterp_PElist l lpe -> Peq ceqb (Nnorm n (Nmk_monpol_list lpe) (num (Fnorm fe))) (Pc cO) = true -> PCond l (condition (Fnorm fe)) -> FEeval l fe == 0. Proof. intros n l lpe fe Hlpe H H1. rewrite (Fnorm_FEeval_PEeval l fe H1). apply rdiv8. apply Pcond_Fnorm; trivial. transitivity (0@l); trivial. rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_th n l lpe); trivial. change (0 @ l) with (Pphi 0 radd rmul phi l (Pc cO)). apply (Peq_ok Rsth Reqe CRmorph); trivial. Qed. Notation ring_rw_correct := (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec). Notation ring_rw_pow_correct := (ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec). Notation ring_correct := (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th). (* simplify a field expression into a fraction *) (* TODO: simplify when den is constant... *) Definition display_linear l num den := NPphi_dev l num / NPphi_dev l den. Definition display_pow_linear l num den := NPphi_pow l num / NPphi_pow l den. Theorem Field_rw_correct n lpe l : Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall fe nfe, Fnorm fe = nfe -> PCond l (condition nfe) -> FEeval l fe == display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). Proof. intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. rewrite (Fnorm_FEeval_PEeval _ _ H). unfold display_linear; apply rdiv_ext; eapply ring_rw_correct; eauto. Qed. Theorem Field_rw_pow_correct n lpe l : Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall fe nfe, Fnorm fe = nfe -> PCond l (condition nfe) -> FEeval l fe == display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). Proof. intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. rewrite (Fnorm_FEeval_PEeval _ _ H). unfold display_pow_linear; apply rdiv_ext; eapply ring_rw_pow_correct;eauto. Qed. Theorem Field_correct n l lpe fe1 fe2 : Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> Peq ceqb (Nnorm n lmp (num nfe1 * denum nfe2)) (Nnorm n lmp (num nfe2 * denum nfe1)) = true -> PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. Proof. intros Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp. apply Fnorm_crossproduct; trivial. eapply ring_correct; eauto. Qed. (* simplify a field equation : generate the crossproduct and simplify polynomials *) (** This allows rewriting modulo the simplification of PEeval on PMul *) Declare Equivalent Keys PEeval rmul. Theorem Field_simplify_eq_correct : forall n l lpe fe1 fe2, Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> forall den, split (denum nfe1) (denum nfe2) = den -> NPphi_dev l (Nnorm n lmp (num nfe1 * right den)) == NPphi_dev l (Nnorm n lmp (num nfe2 * left den)) -> PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. Proof. intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond. apply Fnorm_crossproduct; rewrite ?eq1, ?eq2; trivial. simpl. rewrite (split_ok_l (denum nfe1) (denum nfe2) l), eq3. rewrite (split_ok_r (denum nfe1) (denum nfe2) l), eq3. simpl. rewrite !rmul_assoc. apply rmul_ext; trivial. rewrite (ring_rw_correct n lpe l Hlpe Logic.eq_refl (num nfe1 * right den) Logic.eq_refl), (ring_rw_correct n lpe l Hlpe Logic.eq_refl (num nfe2 * left den) Logic.eq_refl). rewrite Hlmp. apply Hcrossprod. Qed. Theorem Field_simplify_eq_pow_correct : forall n l lpe fe1 fe2, Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> forall den, split (denum nfe1) (denum nfe2) = den -> NPphi_pow l (Nnorm n lmp (num nfe1 * right den)) == NPphi_pow l (Nnorm n lmp (num nfe2 * left den)) -> PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. Proof. intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond. apply Fnorm_crossproduct; rewrite ?eq1, ?eq2; trivial. simpl. rewrite (split_ok_l (denum nfe1) (denum nfe2) l), eq3. rewrite (split_ok_r (denum nfe1) (denum nfe2) l), eq3. simpl. rewrite !rmul_assoc. apply rmul_ext; trivial. rewrite (ring_rw_pow_correct n lpe l Hlpe Logic.eq_refl (num nfe1 * right den) Logic.eq_refl), (ring_rw_pow_correct n lpe l Hlpe Logic.eq_refl (num nfe2 * left den) Logic.eq_refl). rewrite Hlmp. apply Hcrossprod. Qed. Theorem Field_simplify_aux_ok l fe1 fe2 den : FEeval l fe1 == FEeval l fe2 -> split (denum (Fnorm fe1)) (denum (Fnorm fe2)) = den -> PCond l (condition (Fnorm fe1) ++ condition (Fnorm fe2)) -> (num (Fnorm fe1) * right den) @ l == (num (Fnorm fe2) * left den) @ l. Proof. rewrite PCond_app; intros Hfe Hden (Hc1,Hc2); simpl. assert (Hc1' := Pcond_Fnorm _ _ Hc1). assert (Hc2' := Pcond_Fnorm _ _ Hc2). set (N1 := num (Fnorm fe1)) in *. set (N2 := num (Fnorm fe2)) in *. set (D1 := denum (Fnorm fe1)) in *. set (D2 := denum (Fnorm fe2)) in *. assert (~ (common den) @ l == 0). { intro H. apply Hc1'. rewrite (split_ok_l D1 D2 l). rewrite Hden. simpl. ring [H]. } apply (@rmul_reg_l ((common den) @ l)); trivial. rewrite !(rmul_comm ((common den) @ l)), <- !rmul_assoc. change (N1@l * (right den * common den) @ l == N2@l * (left den * common den) @ l). rewrite <- Hden, <- split_ok_l, <- split_ok_r. apply (@rmul_reg_l (/ D2@l)). { apply rinv_nz; trivial. } rewrite (rmul_comm (/ D2 @ l)), <- !rmul_assoc. rewrite <- rdiv_def, rdiv_r_r, rmul_1_r by trivial. apply (@rmul_reg_l (/ (D1@l))). { apply rinv_nz; trivial. } rewrite !(rmul_comm (/ D1@l)), <- !rmul_assoc. rewrite <- !rdiv_def, rdiv_r_r, rmul_1_r by trivial. rewrite (rmul_comm (/ D2@l)), <- rdiv_def. unfold N1,N2,D1,D2; rewrite <- !Fnorm_FEeval_PEeval; trivial. Qed. Theorem Field_simplify_eq_pow_in_correct : forall n l lpe fe1 fe2, Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> forall den, split (denum nfe1) (denum nfe2) = den -> forall np1, Nnorm n lmp (num nfe1 * right den) = np1 -> forall np2, Nnorm n lmp (num nfe2 * left den) = np2 -> FEeval l fe1 == FEeval l fe2 -> PCond l (condition nfe1 ++ condition nfe2) -> NPphi_pow l np1 == NPphi_pow l np2. Proof. intros. subst nfe1 nfe2 lmp np1 np2. rewrite !(Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec). repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. apply Field_simplify_aux_ok; trivial. Qed. Theorem Field_simplify_eq_in_correct : forall n l lpe fe1 fe2, Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> forall den, split (denum nfe1) (denum nfe2) = den -> forall np1, Nnorm n lmp (num nfe1 * right den) = np1 -> forall np2, Nnorm n lmp (num nfe2 * left den) = np2 -> FEeval l fe1 == FEeval l fe2 -> PCond l (condition nfe1 ++ condition nfe2) -> NPphi_dev l np1 == NPphi_dev l np2. Proof. intros. subst nfe1 nfe2 lmp np1 np2. rewrite !(Pphi_dev_ok Rsth Reqe ARth CRmorph get_sign_spec). repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). apply Field_simplify_aux_ok; trivial. Qed. Section Fcons_impl. Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C). Hypothesis PCond_fcons_inv : forall l a l1, PCond l (Fcons a l1) -> ~ a @ l == 0 /\ PCond l l1. Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) := match l with | nil => m | cons a l1 => Fcons a (Fapp l1 m) end. Lemma fcons_ok : forall l l1, (forall lock, lock = PCond l -> lock (Fapp l1 nil)) -> PCond l l1. Proof. intros l l1 h1; assert (H := h1 (PCond l) (refl_equal _));clear h1. induction l1; simpl; intros. trivial. elim PCond_fcons_inv with (1 := H); intros. destruct l1; trivial. split; trivial. apply IHl1; trivial. Qed. End Fcons_impl. Section Fcons_simpl. (* Some general simpifications of the condition: eliminate duplicates, split multiplications *) Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := match l with nil => cons e nil | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1) end. Theorem PFcons_fcons_inv: forall l a l1, PCond l (Fcons a l1) -> ~ a @ l == 0 /\ PCond l l1. Proof. induction l1 as [|e l1]; simpl Fcons. - simpl; now split. - case PExpr_eq_spec; intros H; rewrite !PCond_cons; intros (H1,H2); repeat split; trivial. + now rewrite H. + now apply IHl1. + now apply IHl1. Qed. (* equality of normal forms rather than syntactic equality *) Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := match l with nil => cons e nil | cons a l1 => if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l else cons a (Fcons0 e l1) end. Theorem PFcons0_fcons_inv: forall l a l1, PCond l (Fcons0 a l1) -> ~ a @ l == 0 /\ PCond l l1. Proof. induction l1 as [|e l1]; simpl Fcons0. - simpl; now split. - generalize (ring_correct O l nil a e). lazy zeta; simpl Peq. case Peq; intros H; rewrite !PCond_cons; intros (H1,H2); repeat split; trivial. + now rewrite H. + now apply IHl1. + now apply IHl1. Qed. (* split factorized denominators *) Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := match e with PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l) | PEpow e1 _ => Fcons00 e1 l | _ => Fcons0 e l end. Theorem PFcons00_fcons_inv: forall l a l1, PCond l (Fcons00 a l1) -> ~ a @ l == 0 /\ PCond l l1. Proof. intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail). - intros p H p0 H0 l1 H1. simpl in H1. destruct (H _ H1) as (H2,H3). destruct (H0 _ H3) as (H4,H5). split; trivial. simpl. apply field_is_integral_domain; trivial. - intros. destruct (H _ H0). split; trivial. apply PEpow_nz; trivial. Qed. Definition Pcond_simpl_gen := fcons_ok _ PFcons00_fcons_inv. (* Specific case when the equality test of coefs is complete w.r.t. the field equality: non-zero coefs can be eliminated, and opposite can be simplified (if -1 <> 0) *) Hypothesis ceqb_complete : forall c1 c2, [c1] == [c2] -> ceqb c1 c2 = true. Lemma ceqb_spec' c1 c2 : Bool.reflect ([c1] == [c2]) (ceqb c1 c2). Proof. assert (H := morph_eq CRmorph c1 c2). assert (H' := @ceqb_complete c1 c2). destruct (ceqb c1 c2); constructor. - now apply H. - intro E. specialize (H' E). discriminate. Qed. Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := match e with | PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l) | PEpow e _ => Fcons1 e l | PEopp e => if (-(1) =? 0)%coef then absurd_PCond else Fcons1 e l | PEc c => if (c =? 0)%coef then absurd_PCond else l | _ => Fcons0 e l end. Theorem PFcons1_fcons_inv: forall l a l1, PCond l (Fcons1 a l1) -> ~ a @ l == 0 /\ PCond l l1. Proof. intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail). - simpl; intros c l1. case ceqb_spec'; intros H H0. + elim (@absurd_PCond_bottom l H0). + split; trivial. rewrite <- phi_0; trivial. - intros p H p0 H0 l1 H1. simpl in H1. destruct (H _ H1) as (H2,H3). destruct (H0 _ H3) as (H4,H5). split; trivial. simpl. apply field_is_integral_domain; trivial. - simpl; intros p H l1. case ceqb_spec'; intros H0 H1. + elim (@absurd_PCond_bottom l H1). + destruct (H _ H1). split; trivial. apply ropp_neq_0; trivial. rewrite (morph_opp CRmorph), phi_0, phi_1 in H0. trivial. - intros. destruct (H _ H0);split;trivial. apply PEpow_nz; trivial. Qed. Definition Fcons2 e l := Fcons1 (PEsimp e) l. Theorem PFcons2_fcons_inv: forall l a l1, PCond l (Fcons2 a l1) -> ~ a @ l == 0 /\ PCond l l1. Proof. unfold Fcons2; intros l a l1 H; split; case (PFcons1_fcons_inv l (PEsimp a) l1); trivial. intros H1 H2 H3; case H1. transitivity (a@l); trivial. apply PEsimp_ok. Qed. Definition Pcond_simpl_complete := fcons_ok _ PFcons2_fcons_inv. End Fcons_simpl. End AlmostField. Section FieldAndSemiField. Record field_theory : Prop := mk_field { F_R : ring_theory rO rI radd rmul rsub ropp req; F_1_neq_0 : ~ 1 == 0; Fdiv_def : forall p q, p / q == p * / q; Finv_l : forall p, ~ p == 0 -> / p * p == 1 }. Definition F2AF f := mk_afield (Rth_ARth Rsth Reqe f.(F_R)) f.(F_1_neq_0) f.(Fdiv_def) f.(Finv_l). Record semi_field_theory : Prop := mk_sfield { SF_SR : semi_ring_theory rO rI radd rmul req; SF_1_neq_0 : ~ 1 == 0; SFdiv_def : forall p q, p / q == p * / q; SFinv_l : forall p, ~ p == 0 -> / p * p == 1 }. End FieldAndSemiField. End MakeFieldPol. Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth (sf:semi_field_theory rO rI radd rmul rdiv rinv req) := mk_afield _ _ (SRth_ARth Rsth sf.(SF_SR)) sf.(SF_1_neq_0) sf.(SFdiv_def) sf.(SFinv_l). Section Complete. Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable (rdiv : R -> R -> R) (rinv : R -> R). Variable req : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x / y " := (rdiv x y). Notation "/ x" := (rinv x). Notation "x == y" := (req x y) (at level 70, no associativity). Variable Rsth : Setoid_Theory R req. Add Setoid R req Rsth as R_setoid3. Variable Reqe : ring_eq_ext radd rmul ropp req. Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed. Section AlmostField. Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req. Let ARth := AFth.(AF_AR). Let rI_neq_rO := AFth.(AF_1_neq_0). Let rdiv_def := AFth.(AFdiv_def). Let rinv_l := AFth.(AFinv_l). Hypothesis S_inj : forall x y, 1+x==1+y -> x==y. Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. Lemma add_inj_r p x y : gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y. Proof. elim p using Pos.peano_ind; simpl; intros. apply S_inj; trivial. apply H. apply S_inj. rewrite !(ARadd_assoc ARth). rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth); trivial. Qed. Lemma gen_phiPOS_inj x y : gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y -> x = y. Proof. rewrite <- !(same_gen Rsth Reqe ARth). case (Pos.compare_spec x y). intros. trivial. intros. elim gen_phiPOS_not_0 with (y - x)%positive. apply add_inj_r with x. symmetry. rewrite (ARadd_0_r Rsth ARth). rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth). now rewrite Pos.add_comm, Pos.sub_add. intros. elim gen_phiPOS_not_0 with (x - y)%positive. apply add_inj_r with y. rewrite (ARadd_0_r Rsth ARth). rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth). now rewrite Pos.add_comm, Pos.sub_add. Qed. Lemma gen_phiN_inj x y : gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> x = y. Proof. destruct x; destruct y; simpl; intros; trivial. elim gen_phiPOS_not_0 with p. symmetry . rewrite (same_gen Rsth Reqe ARth); trivial. elim gen_phiPOS_not_0 with p. rewrite (same_gen Rsth Reqe ARth); trivial. rewrite gen_phiPOS_inj with (1 := H); trivial. Qed. Lemma gen_phiN_complete x y : gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> N.eqb x y = true. Proof. intros. now apply N.eqb_eq, gen_phiN_inj. Qed. End AlmostField. Section Field. Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req. Let Rth := Fth.(F_R). Let rI_neq_rO := Fth.(F_1_neq_0). Let rdiv_def := Fth.(Fdiv_def). Let rinv_l := Fth.(Finv_l). Let AFth := F2AF Rsth Reqe Fth. Let ARth := Rth_ARth Rsth Reqe Rth. Lemma ring_S_inj x y : 1+x==1+y -> x==y. Proof. intros. rewrite <- (ARadd_0_l ARth x), <- (ARadd_0_l ARth y). rewrite <- (Ropp_def Rth 1), (ARadd_comm ARth 1). rewrite <- !(ARadd_assoc ARth). now apply (Radd_ext Reqe). Qed. Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. Let gen_phiPOS_inject := gen_phiPOS_inj AFth ring_S_inj gen_phiPOS_not_0. Lemma gen_phiPOS_discr_sgn x y : ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y. Proof. red; intros. apply gen_phiPOS_not_0 with (y + x)%positive. rewrite (ARgen_phiPOS_add Rsth Reqe ARth). transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y). apply (Radd_ext Reqe); trivial. reflexivity. rewrite (same_gen Rsth Reqe ARth). rewrite (same_gen Rsth Reqe ARth). trivial. apply (Ropp_def Rth). Qed. Lemma gen_phiZ_inj x y : gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> x = y. Proof. destruct x; destruct y; simpl; intros. trivial. elim gen_phiPOS_not_0 with p. rewrite (same_gen Rsth Reqe ARth). symmetry ; trivial. elim gen_phiPOS_not_0 with p. rewrite (same_gen Rsth Reqe ARth). rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). rewrite <- H. apply (ARopp_zero Rsth Reqe ARth). elim gen_phiPOS_not_0 with p. rewrite (same_gen Rsth Reqe ARth). trivial. rewrite gen_phiPOS_inject with (1 := H); trivial. elim gen_phiPOS_discr_sgn with (1 := H). elim gen_phiPOS_not_0 with p. rewrite (same_gen Rsth Reqe ARth). rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). rewrite H. apply (ARopp_zero Rsth Reqe ARth). elim gen_phiPOS_discr_sgn with p0 p. symmetry ; trivial. replace p0 with p; trivial. apply gen_phiPOS_inject. rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)). rewrite H; trivial. reflexivity. Qed. Lemma gen_phiZ_complete x y : gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> Zeq_bool x y = true. Proof. intros. replace y with x. unfold Zeq_bool. rewrite Z.compare_refl; trivial. apply gen_phiZ_inj; trivial. Qed. End Field. End Complete. Arguments FEO [C]. Arguments FEI [C]. coq-8.6/plugins/setoid_ring/newring_plugin.mlpack0000644000175000017500000000002213022274260021660 0ustar mdenesmdenesNewring G_newring coq-8.6/plugins/setoid_ring/Field_tac.v0000644000175000017500000004616413022274260017522 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* match t with | rO => fun _ => constr:(@FEO C) | rI => fun _ => constr:(@FEI C) | (radd ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(@FEadd C e1 e2) | (rmul ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(@FEmul C e1 e2) | (rsub ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(@FEsub C e1 e2) | (ropp ?t1) => fun _ => let e1 := mkP t1 in constr:(@FEopp C e1) | (rdiv ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(@FEdiv C e1 e2) | (rinv ?t1) => fun _ => let e1 := mkP t1 in constr:(@FEinv C e1) | (rpow ?t1 ?n) => match CstPow n with | InitialRing.NotConstant => fun _ => let p := Find_at t fv in constr:(@FEX C p) | ?c => fun _ => let e1 := mkP t1 in constr:(@FEpow C e1 c) end | _ => fun _ => let p := Find_at t fv in constr:(@FEX C p) end | ?c => fun _ => constr:(@FEc C c) end in f () in mkP t. (* We do not assume that Cst recognizes the rO and rI terms as constants, as *) (* the tactic could be used to discriminate occurrences of an opaque *) (* constant phi, with (phi 0) not convertible to 0 for instance *) Ltac FFV Cst CstPow rO rI add mul sub opp div inv pow t fv := let rec TFV t fv := match Cst t with | InitialRing.NotConstant => match t with | rO => fv | rI => fv | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (opp ?t1) => TFV t1 fv | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (inv ?t1) => TFV t1 fv | (pow ?t1 ?n) => match CstPow n with | InitialRing.NotConstant => AddFvTail t fv | _ => TFV t1 fv end | _ => AddFvTail t fv end | _ => fv end in TFV t fv. (* packaging the field structure *) (* TODO: inline PackField into field_lookup *) Ltac PackField F req Cst_tac Pow_tac L1 L2 L3 L4 cond_ok pre post := let FLD := match type of L1 with | context [req (@FEeval ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] => (fun proj => proj Cst_tac Pow_tac pre post req rO rI radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok) | _ => fail 1 "field anomaly: bad correctness lemma (parse)" end in F FLD. Ltac get_FldPre FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => pre). Ltac get_FldPost FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => post). Ltac get_L1 FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => L1). Ltac get_SimplifyEqLemma FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => L2). Ltac get_SimplifyLemma FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => L3). Ltac get_L4 FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => L4). Ltac get_CondLemma FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => cond_ok). Ltac get_FldEq FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => req). Ltac get_FldCarrier FLD := let req := get_FldEq FLD in relation_carrier req. Ltac get_RingFV FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => FV Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow). Ltac get_FFV FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => FFV Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rdiv rinv rpow). Ltac get_RingMeta FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => mkPolexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow). Ltac get_Meta FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => mkFieldexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rdiv rinv rpow). Ltac get_Hyp_tac FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => let mkPol := mkPolexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow in fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH). Ltac get_FEeval FLD := let L1 := get_L1 FLD in match type of L1 with | context [(@FEeval ?R ?r0 ?r1 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] => constr:(@FEeval R r0 r1 add mul sub opp div inv C phi Cpow powphi pow) | _ => fail 1 "field anomaly: bad correctness lemma (get_FEeval)" end. (* simplifying the non-zero condition... *) Ltac fold_field_cond req := let rec fold_concl t := match t with ?x /\ ?y => let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy) | req ?x ?y -> False => constr:(~ req x y) | _ => t end in let ft := fold_concl Get_goal in change ft. Ltac simpl_PCond FLD := let req := get_FldEq FLD in let lemma := get_CondLemma FLD in try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock); protect_fv "field_cond"; fold_field_cond req; try exact I. Ltac simpl_PCond_BEURK FLD := let req := get_FldEq FLD in let lemma := get_CondLemma FLD in (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock); protect_fv "field_cond"; fold_field_cond req. (* Rewriting (field_simplify) *) Ltac Field_norm_gen f n FLD lH rl := let mkFV := get_RingFV FLD in let mkFFV := get_FFV FLD in let mkFE := get_Meta FLD in let fv0 := FV_hypo_tac mkFV ltac:(get_FldEq FLD) lH in let lemma_tac fv kont := let lemma := get_SimplifyLemma FLD in (* reify equations of the context *) let lpe := get_Hyp_tac FLD fv lH in let vlpe := fresh "hyps" in pose (vlpe := lpe); let prh := proofHyp_tac lH in (* compute the normal form of the reified hyps *) let vlmp := fresh "hyps'" in let vlmp_eq := fresh "hyps_eq" in let mk_monpol := get_MonPol lemma in compute_assertion vlmp_eq vlmp (mk_monpol vlpe); (* partially instantiate the lemma *) let lem := fresh "f_rw_lemma" in (assert (lem := lemma n vlpe fv prh vlmp vlmp_eq) || fail "type error when building the rewriting lemma"); (* continuation will call main_tac for all reified terms *) kont lem; (* at the end, cleanup *) (clear lem vlmp_eq vlmp vlpe||idtac"Field_norm_gen:cleanup failed") in (* each instance of the lemma is simplified then passed to f *) let main_tac H := protect_fv "field" in H; f H in (* generate and use equations for each expression *) ReflexiveRewriteTactic mkFFV mkFE lemma_tac main_tac fv0 rl; try simpl_PCond FLD. Ltac Field_simplify_gen f FLD lH rl := get_FldPre FLD (); Field_norm_gen f ring_subst_niter FLD lH rl; get_FldPost FLD (). Ltac Field_simplify := Field_simplify_gen ltac:(fun H => rewrite H). Tactic Notation (at level 0) "field_simplify" constr_list(rl) := let G := Get_goal in field_lookup (PackField Field_simplify) [] rl G. Tactic Notation (at level 0) "field_simplify" "[" constr_list(lH) "]" constr_list(rl) := let G := Get_goal in field_lookup (PackField Field_simplify) [lH] rl G. Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= let G := Get_goal in let t := type of H in let g := fresh "goal" in set (g:= G); revert H; field_lookup (PackField Field_simplify) [] rl t; intro H; unfold g;clear g. Tactic Notation "field_simplify" "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):= let G := Get_goal in let t := type of H in let g := fresh "goal" in set (g:= G); revert H; field_lookup (PackField Field_simplify) [lH] rl t; intro H; unfold g;clear g. (* Ltac Field_simplify_in hyp:= Field_simplify_gen ltac:(fun H => rewrite H in hyp). Tactic Notation (at level 0) "field_simplify" constr_list(rl) "in" hyp(h) := let t := type of h in field_lookup (Field_simplify_in h) [] rl t. Tactic Notation (at level 0) "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) := let t := type of h in field_lookup (Field_simplify_in h) [lH] rl t. *) (** Generic tactic for solving equations *) Ltac Field_Scheme Simpl_tac n lemma FLD lH := let req := get_FldEq FLD in let mkFV := get_RingFV FLD in let mkFFV := get_FFV FLD in let mkFE := get_Meta FLD in let Main_eq t1 t2 := let fv := FV_hypo_tac mkFV req lH in let fv := mkFFV t1 fv in let fv := mkFFV t2 fv in let lpe := get_Hyp_tac FLD fv lH in let prh := proofHyp_tac lH in let vlpe := fresh "list_hyp" in let fe1 := mkFE t1 fv in let fe2 := mkFE t2 fv in pose (vlpe := lpe); let nlemma := fresh "field_lemma" in (assert (nlemma := lemma n fv vlpe fe1 fe2 prh) || fail "field anomaly:failed to build lemma"); ProveLemmaHyps nlemma ltac:(fun ilemma => apply ilemma || fail "field anomaly: failed in applying lemma"; [ Simpl_tac | simpl_PCond FLD]); clear nlemma; subst vlpe in OnEquation req Main_eq. (* solve completely a field equation, leaving non-zero conditions to be proved (field) *) Ltac FIELD FLD lH rl := let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in let lemma := get_L1 FLD in get_FldPre FLD (); Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; try exact I; get_FldPost FLD(). Tactic Notation (at level 0) "field" := let G := Get_goal in field_lookup (PackField FIELD) [] G. Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" := let G := Get_goal in field_lookup (PackField FIELD) [lH] G. (* transforms a field equation to an equivalent (simplified) ring equation, and leaves non-zero conditions to be proved (field_simplify_eq) *) Ltac FIELD_SIMPL FLD lH rl := let Simpl := (protect_fv "field") in let lemma := get_SimplifyEqLemma FLD in get_FldPre FLD (); Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; get_FldPost FLD (). Tactic Notation (at level 0) "field_simplify_eq" := let G := Get_goal in field_lookup (PackField FIELD_SIMPL) [] G. Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" := let G := Get_goal in field_lookup (PackField FIELD_SIMPL) [lH] G. (* Same as FIELD_SIMPL but in hypothesis *) Ltac Field_simplify_eq n FLD lH := let req := get_FldEq FLD in let mkFV := get_RingFV FLD in let mkFFV := get_FFV FLD in let mkFE := get_Meta FLD in let lemma := get_L4 FLD in let hyp := fresh "hyp" in intro hyp; OnEquationHyp req hyp ltac:(fun t1 t2 => let fv := FV_hypo_tac mkFV req lH in let fv := mkFFV t1 fv in let fv := mkFFV t2 fv in let lpe := get_Hyp_tac FLD fv lH in let prh := proofHyp_tac lH in let fe1 := mkFE t1 fv in let fe2 := mkFE t2 fv in let vlpe := fresh "vlpe" in ProveLemmaHyps (lemma n fv lpe fe1 fe2 prh) ltac:(fun ilemma => match type of ilemma with | req _ _ -> _ -> ?EQ => let tmp := fresh "tmp" in assert (tmp : EQ); [ apply ilemma; [ exact hyp | simpl_PCond_BEURK FLD] | protect_fv "field" in tmp; revert tmp ]; clear hyp end)). Ltac FIELD_SIMPL_EQ FLD lH rl := get_FldPre FLD (); Field_simplify_eq Ring_tac.ring_subst_niter FLD lH; get_FldPost FLD (). Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) := let t := type of H in generalize H; field_lookup (PackField FIELD_SIMPL_EQ) [] t; [ try exact I | clear H;intro H]. Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" "in" hyp(H) := let t := type of H in generalize H; field_lookup (PackField FIELD_SIMPL_EQ) [lH] t; [ try exact I |clear H;intro H]. (* More generic tactics to build variants of field *) (* This tactic reifies c and pass to F: - the FLD structure gathering all info in the field DB - the atom list - the expression (FExpr) *) Ltac gen_with_field F c := let MetaExpr FLD _ rl := let R := get_FldCarrier FLD in let mkFFV := get_FFV FLD in let mkFE := get_Meta FLD in let csr := match rl with | List.cons ?r _ => r | _ => fail 1 "anomaly: ill-formed list" end in let fv := mkFFV csr (@List.nil R) in let expr := mkFE csr fv in F FLD fv expr in field_lookup (PackField MetaExpr) [] (c=c). (* pushes the equation expr = ope(expr) in the goal, and discharge it with field *) Ltac prove_field_eqn ope FLD fv expr := let res := ope expr in let expr' := fresh "input_expr" in pose (expr' := expr); let res' := fresh "result" in pose (res' := res); let lemma := get_L1 FLD in let lemma := constr:(lemma O fv List.nil expr' res' I List.nil (eq_refl _)) in let ty := type of lemma in let lhs := match ty with forall _, ?lhs=_ -> _ => lhs end in let rhs := match ty with forall _, _=_ -> forall _, ?rhs=_ -> _ => rhs end in let lhs' := fresh "lhs" in let lhs_eq := fresh "lhs_eq" in let rhs' := fresh "rhs" in let rhs_eq := fresh "rhs_eq" in compute_assertion lhs_eq lhs' lhs; compute_assertion rhs_eq rhs' rhs; let H := fresh "fld_eqn" in refine (_ (lemma lhs' lhs_eq rhs' rhs_eq _ _)); (* main goal *) [intro H;protect_fv "field" in H; revert H (* ring-nf(lhs') = ring-nf(rhs') *) | vm_compute; reflexivity || fail "field cannot prove this equality" (* denominator condition *) | simpl_PCond FLD]; clear lhs_eq rhs_eq; subst lhs' rhs'. Ltac prove_with_field ope c := gen_with_field ltac:(prove_field_eqn ope) c. (* Prove an equation x=ope(x) and rewrite with it *) Ltac prove_rw ope x := prove_with_field ope x; [ let H := fresh "Heq_maple" in intro H; rewrite H; clear H |..]. (* Apply ope (FExpr->FExpr) on an expression *) Ltac reduce_field_expr ope kont FLD fv expr := let evfun := get_FEeval FLD in let res := ope expr in let c := (eval simpl_field_expr in (evfun fv res)) in kont c. (* Hack to let a Ltac return a term in the context of a primitive tactic *) Ltac return_term x := generalize (eq_refl x). Ltac get_term := match goal with | |- ?x = _ -> _ => x end. (* Turn an operation on field expressions (FExpr) into a reduction on terms (in the field carrier). Because of field_lookup, the tactic cannot return a term directly, so it is returned via the conclusion of the goal (return_term). *) Ltac reduce_field_ope ope c := gen_with_field ltac:(reduce_field_expr ope return_term) c. (* Adding a new field *) Ltac ring_of_field f := match type of f with | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f) | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f) | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f) end. Ltac coerce_to_almost_field set ext f := match type of f with | almost_field_theory _ _ _ _ _ _ _ _ _ => f | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f) | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f) end. Ltac field_elements set ext fspec pspec sspec dspec rk := let afth := coerce_to_almost_field set ext fspec in let rspec := ring_of_field fspec in ring_elements set ext rspec pspec sspec dspec rk ltac:(fun arth ext_r morph p_spec s_spec d_spec f => f afth ext_r morph p_spec s_spec d_spec). Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := let get_lemma := match pspec with None => fun x y => x | _ => fun x y => y end in let simpl_eq_lemma := get_lemma Field_simplify_eq_correct Field_simplify_eq_pow_correct in let simpl_eq_in_lemma := get_lemma Field_simplify_eq_in_correct Field_simplify_eq_pow_in_correct in let rw_lemma := get_lemma Field_rw_correct Field_rw_pow_correct in field_elements set ext fspec pspec sspec dspec rk ltac:(fun afth ext_r morph p_spec s_spec d_spec => match morph with | _ => let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in match p_spec with | mkhypo ?pp_spec => let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in match s_spec with | mkhypo ?ss_spec => match d_spec with | mkhypo ?dd_spec => let field_ok := constr:(field_ok2 _ dd_spec) in let mk_lemma lemma := constr:(lemma _ _ _ _ _ _ _ _ _ _ set ext_r inv_m afth _ _ _ _ _ _ _ _ _ morph _ _ _ pp_spec _ ss_spec _ dd_spec) in let field_simpl_eq_ok := mk_lemma simpl_eq_lemma in let field_simpl_ok := mk_lemma rw_lemma in let field_simpl_eq_in := mk_lemma simpl_eq_in_lemma in let cond1_ok := constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in let cond2_ok := constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_spec) in (fun f => f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in cond1_ok cond2_ok) | _ => fail 4 "field: bad coefficient division specification" end | _ => fail 3 "field: bad sign specification" end | _ => fail 2 "field: bad power specification" end | _ => fail 1 "field internal error : field_lemmas, please report" end). coq-8.6/plugins/setoid_ring/Ring.v0000644000175000017500000000265613022274260016545 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* b) (eq(A:=bool)). split; simpl. destruct x; reflexivity. destruct x; destruct y; reflexivity. destruct x; destruct y; destruct z; reflexivity. reflexivity. destruct x; destruct y; reflexivity. destruct x; destruct y; reflexivity. destruct x; destruct y; destruct z; reflexivity. reflexivity. destruct x; reflexivity. Qed. Definition bool_eq (b1 b2:bool) := if b1 then b2 else negb b2. Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2. destruct b1; destruct b2; auto. Qed. Ltac bool_cst t := let t := eval hnf in t in match t with true => constr:(true) | false => constr:(false) | _ => constr:(NotConstant) end. Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]). coq-8.6/plugins/setoid_ring/newring.ml0000644000175000017500000011157113022274260017457 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mk_clos subs c | Prot -> mk_atom c | Rec -> if Int.equal i (-1) then mk_clos subs c else tag_rec c let global_head_of_constr c = let f, args = decompose_app c in try global_of_constr f with Not_found -> anomaly (str "global_head_of_constr") let global_of_constr_nofail c = try global_of_constr c with Not_found -> VarRef (Id.of_string "dummy") let rec mk_clos_but f_map subs t = match f_map (global_of_constr_nofail t) with | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t | None -> (match kind_of_term t with App(f,args) -> mk_clos_app_but f_map subs f args 0 | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t | _ -> mk_atom t) and mk_clos_app_but f_map subs f args n = if n >= Array.length args then mk_atom(mkApp(f, args)) else let fargs, args' = Array.chop n args in let f' = mkApp(f,fargs) in match f_map (global_of_constr_nofail f') with | Some map -> let f i t = tag_arg (mk_clos_but f_map subs) map subs i t in mk_red (FApp (f (-1) f', Array.mapi f args')) | None -> mk_atom (mkApp (f, args)) let interp_map l t = try Some(List.assoc_f eq_gr t l) with Not_found -> None let protect_maps = ref String.Map.empty let add_map s m = protect_maps := String.Map.add s m !protect_maps let lookup_map map = try String.Map.find map !protect_maps with Not_found -> errorlabstrm"lookup_map"(str"map "++qs map++str"not found") let protect_red map env sigma c = kl (create_clos_infos all env) (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);; let protect_tac map = Tactics.reduct_option (protect_red map,DEFAULTcast) None let protect_tac_in map id = Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp)) (****************************************************************************) let closed_term t l = let open Quote_plugin in let l = List.map Universes.constr_of_global l in let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in if Quote.closed_under cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt()) (* TACTIC EXTEND echo | [ "echo" constr(t) ] -> [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ] END;;*) (* let closed_term_ast l = TacFun([Some(Id.of_string"t")], TacAtom(Loc.ghost,TacExtend(Loc.ghost,"closed_term", [Genarg.in_gen Constrarg.wit_constr (mkVar(Id.of_string"t")); Genarg.in_gen (Genarg.wit_list Constrarg.wit_ref) l]))) *) let closed_term_ast l = let tacname = { mltac_plugin = "newring_plugin"; mltac_tactic = "closed_term"; } in let tacname = { mltac_name = tacname; mltac_index = 0; } in let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in TacFun([Some(Id.of_string"t")], TacML(Loc.ghost,tacname, [TacGeneric (Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None)); TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l)])) (* let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" *) (****************************************************************************) let ic c = let env = Global.env() in let sigma = Evd.from_env env in Constrintern.interp_open_constr env sigma c let ic_unsafe c = (*FIXME remove *) let env = Global.env() in let sigma = Evd.from_env env in fst (Constrintern.interp_constr env sigma c) let decl_constant na ctx c = let vars = Universes.universes_of_constr c in let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in mkConst(declare_constant (Id.of_string na) (DefinitionEntry (definition_entry ~opaque:true ~univs:(Univ.ContextSet.to_context ctx) c), IsProof Lemma)) (* Calling a global tactic *) let ltac_call tac (args:glob_tactic_arg list) = TacArg(Loc.ghost,TacCall(Loc.ghost, ArgArg(Loc.ghost, Lazy.force tac),args)) (* Calling a locally bound tactic *) let ltac_lcall tac args = TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, Id.of_string tac),args)) let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) = let fold arg (i, vars, lfun) = let id = Id.of_string ("x" ^ string_of_int i) in let x = Reference (ArgVar (Loc.ghost, id)) in (succ i, x :: vars, Id.Map.add id arg lfun) in let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in let lfun = Id.Map.add (Id.of_string "F") f lfun in let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args) let dummy_goal env sigma = let (gl,_,sigma) = Goal.V82.mk_goal sigma (named_context_val env) mkProp Evd.Store.empty in {Evd.it = gl; Evd.sigma = sigma} let constr_of v = match Value.to_constr v with | Some c -> c | None -> failwith "Ring.exec_tactic: anomaly" let tactic_res = ref [||] let get_res = let open Tacexpr in let name = { mltac_plugin = "newring_plugin"; mltac_tactic = "get_res"; } in let entry = { mltac_name = name; mltac_index = 0 } in let tac args ist = let n = Tacinterp.Value.cast (Genarg.topwit Stdarg.wit_int) (List.hd args) in let init i = Id.Map.find (Id.of_string ("x" ^ string_of_int i)) ist.lfun in tactic_res := Array.init n init; Proofview.tclUNIT () in Tacenv.register_ml_tactic name [| tac |]; entry let exec_tactic env evd n f args = let fold arg (i, vars, lfun) = let id = Id.of_string ("x" ^ string_of_int i) in let x = Reference (ArgVar (Loc.ghost, id)) in (succ i, x :: vars, Id.Map.add id (Value.of_constr arg) lfun) in let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in (** Build the getter *) let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in (** Evaluate the whole result *) let gl = dummy_goal env evd in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in Array.map (fun x -> nf (constr_of x)) !tactic_res, snd (Evd.universe_context evd) let stdlib_modules = [["Coq";"Setoids";"Setoid"]; ["Coq";"Lists";"List"]; ["Coq";"Init";"Datatypes"]; ["Coq";"Init";"Logic"]; ] let coq_constant c = lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c) let coq_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c) let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" let coq_None = coq_reference "None" let coq_Some = coq_reference "Some" let coq_eq = coq_constant "eq" let coq_cons = coq_reference "cons" let coq_nil = coq_reference "nil" let lapp f args = mkApp(Lazy.force f,args) let plapp evd f args = let fc = Evarutil.e_new_global evd (Lazy.force f) in mkApp(fc,args) let dest_rel0 t = match kind_of_term t with | App(f,args) when Array.length args >= 2 -> let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in if closed0 rel then (rel,args.(Array.length args - 2),args.(Array.length args - 1)) else error "ring: cannot find relation (not closed)" | _ -> error "ring: cannot find relation" let rec dest_rel t = match kind_of_term t with | Prod(_,_,c) -> dest_rel c | _ -> dest_rel0 t (****************************************************************************) (* Library linking *) let plugin_dir = "setoid_ring" let cdir = ["Coq";plugin_dir] let plugin_modules = List.map (fun d -> cdir@d) [["Ring_theory"];["Ring_polynom"]; ["Ring_tac"];["InitialRing"]; ["Field_tac"]; ["Field_theory"] ] let my_constant c = lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c) let my_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c) let new_ring_path = DirPath.make (List.map Id.of_string ["Ring_tac";plugin_dir;"Coq"]) let znew_ring_path = DirPath.make (List.map Id.of_string ["InitialRing";plugin_dir;"Coq"]) let zltac s = lazy(make_kn (MPfile znew_ring_path) DirPath.empty (Label.make s)) let mk_cst l s = lazy (Coqlib.gen_reference "newring" l s);; let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;; (* Ring theory *) (* almost_ring defs *) let coq_almost_ring_theory = my_constant "almost_ring_theory" (* setoid and morphism utilities *) let coq_eq_setoid = my_reference "Eqsth" let coq_eq_morph = my_reference "Eq_ext" let coq_eq_smorph = my_reference "Eq_s_ext" (* ring -> almost_ring utilities *) let coq_ring_theory = my_constant "ring_theory" let coq_mk_reqe = my_constant "mk_reqe" (* semi_ring -> almost_ring utilities *) let coq_semi_ring_theory = my_constant "semi_ring_theory" let coq_mk_seqe = my_constant "mk_seqe" let coq_abstract = my_constant"Abstract" let coq_comp = my_constant"Computational" let coq_morph = my_constant"Morphism" (* power function *) let ltac_inv_morph_nothing = zltac"inv_morph_nothing" (* hypothesis *) let coq_mkhypo = my_reference "mkhypo" let coq_hypo = my_reference "hypo" (* Equality: do not evaluate but make recursive call on both sides *) let map_with_eq arg_map c = let (req,_,_) = dest_rel c in interp_map ((global_head_of_constr req,(function -1->Prot|_->Rec)):: List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) let map_without_eq arg_map _ = interp_map (List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) let _ = add_map "ring" (map_with_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); pol_cst "Pphi_pow", (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)]) (****************************************************************************) (* Ring database *) module Cmap = Map.Make(Constr) let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table" let from_name = Summary.ref Spmap.empty ~name:"ring-tac-name-table" let ring_for_carrier r = Cmap.find r !from_carrier let find_ring_structure env sigma l = match l with | t::cl' -> let ty = Retyping.get_type_of env sigma t in let check c = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then errorlabstrm "ring" (str"arguments of ring_simplify do not have all the same type") in List.iter check cl'; (try ring_for_carrier ty with Not_found -> errorlabstrm "ring" (str"cannot find a declared ring structure over"++ spc()++str"\""++pr_constr ty++str"\"")) | [] -> assert false let add_entry (sp,_kn) e = from_carrier := Cmap.add e.ring_carrier e !from_carrier; from_name := Spmap.add sp e !from_name let subst_th (subst,th) = let c' = subst_mps subst th.ring_carrier in let eq' = subst_mps subst th.ring_req in let set' = subst_mps subst th.ring_setoid in let ext' = subst_mps subst th.ring_ext in let morph' = subst_mps subst th.ring_morph in let th' = subst_mps subst th.ring_th in let thm1' = subst_mps subst th.ring_lemma1 in let thm2' = subst_mps subst th.ring_lemma2 in let tac'= Tacsubst.subst_tactic subst th.ring_cst_tac in let pow_tac'= Tacsubst.subst_tactic subst th.ring_pow_tac in let pretac'= Tacsubst.subst_tactic subst th.ring_pre_tac in let posttac'= Tacsubst.subst_tactic subst th.ring_post_tac in if c' == th.ring_carrier && eq' == th.ring_req && eq_constr set' th.ring_setoid && ext' == th.ring_ext && morph' == th.ring_morph && th' == th.ring_th && thm1' == th.ring_lemma1 && thm2' == th.ring_lemma2 && tac' == th.ring_cst_tac && pow_tac' == th.ring_pow_tac && pretac' == th.ring_pre_tac && posttac' == th.ring_post_tac then th else { ring_carrier = c'; ring_req = eq'; ring_setoid = set'; ring_ext = ext'; ring_morph = morph'; ring_th = th'; ring_cst_tac = tac'; ring_pow_tac = pow_tac'; ring_lemma1 = thm1'; ring_lemma2 = thm2'; ring_pre_tac = pretac'; ring_post_tac = posttac' } let theory_to_obj : ring_info -> obj = let cache_th (name,th) = add_entry name th in declare_object {(default_object "tactic-new-ring-theory") with open_function = (fun i o -> if Int.equal i 1 then cache_th o); cache_function = cache_th; subst_function = subst_th; classify_function = (fun x -> Substitute x)} let setoid_of_relation env evd a r = try let evm = !evd in let evm, refl = Rewrite.get_reflexive_proof env evm a r in let evm, sym = Rewrite.get_symmetric_proof env evm a r in let evm, trans = Rewrite.get_transitive_proof env evm a r in evd := evm; lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |] with Not_found -> error "cannot find setoid relation" let op_morph r add mul opp req m1 m2 m3 = lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |] let op_smorph r add mul req m1 m2 = lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |] (* let default_ring_equality (r,add,mul,opp,req) = *) (* let is_setoid = function *) (* {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *) (* eq_constr_nounivs req rel (\* Qu: use conversion ? *\) *) (* | _ -> false in *) (* match default_relation_for_carrier ~filter:is_setoid r with *) (* Leibniz _ -> *) (* let setoid = lapp coq_eq_setoid [|r|] in *) (* let op_morph = *) (* match opp with *) (* Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] *) (* | None -> lapp coq_eq_smorph [|r;add;mul|] in *) (* (setoid,op_morph) *) (* | Relation rel -> *) (* let setoid = setoid_of_relation rel in *) (* let is_endomorphism = function *) (* { args=args } -> List.for_all *) (* (function (var,Relation rel) -> *) (* var=None && eq_constr_nounivs req rel *) (* | _ -> false) args in *) (* let add_m = *) (* try default_morphism ~filter:is_endomorphism add *) (* with Not_found -> *) (* error "ring addition should be declared as a morphism" in *) (* let mul_m = *) (* try default_morphism ~filter:is_endomorphism mul *) (* with Not_found -> *) (* error "ring multiplication should be declared as a morphism" in *) (* let op_morph = *) (* match opp with *) (* | Some opp -> *) (* (let opp_m = *) (* try default_morphism ~filter:is_endomorphism opp *) (* with Not_found -> *) (* error "ring opposite should be declared as a morphism" in *) (* let op_morph = *) (* op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in *) (* msgnl *) (* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++ *) (* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) (* str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++ *) (* str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ *) (* str"\""); *) (* op_morph) *) (* | None -> *) (* (msgnl *) (* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++ *) (* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) (* str"\""++spc()++str"and \""++ *) (* pr_constr mul_m.morphism_theory++str"\""); *) (* op_smorph r add mul req add_m.lem mul_m.lem) in *) (* (setoid,op_morph) *) let ring_equality env evd (r,add,mul,opp,req) = match kind_of_term req with | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) -> let setoid = plapp evd coq_eq_setoid [|r|] in let op_morph = match opp with Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] | None -> plapp evd coq_eq_smorph [|r;add;mul|] in let setoid = Typing.e_solve_evars env evd setoid in let op_morph = Typing.e_solve_evars env evd op_morph in (setoid,op_morph) | _ -> let setoid = setoid_of_relation (Global.env ()) evd r req in let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in let add_m, add_m_lem = try Rewrite.default_morphism signature add with Not_found -> error "ring addition should be declared as a morphism" in let mul_m, mul_m_lem = try Rewrite.default_morphism signature mul with Not_found -> error "ring multiplication should be declared as a morphism" in let op_morph = match opp with | Some opp -> (let opp_m,opp_m_lem = try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) opp with Not_found -> error "ring opposite should be declared as a morphism" in let op_morph = op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in Flags.if_verbose Feedback.msg_info (str"Using setoid \""++pr_constr req++str"\""++spc()++ str"and morphisms \""++pr_constr add_m_lem ++ str"\","++spc()++ str"\""++pr_constr mul_m_lem++ str"\""++spc()++str"and \""++pr_constr opp_m_lem++ str"\""); op_morph) | None -> (Flags.if_verbose Feedback.msg_info (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++ str"and morphisms \""++pr_constr add_m_lem ++ str"\""++spc()++str"and \""++ pr_constr mul_m_lem++str"\""); op_smorph r add mul req add_m_lem mul_m_lem) in (setoid,op_morph) let build_setoid_params env evd r add mul opp req eqth = match eqth with Some th -> th | None -> ring_equality env evd (r,add,mul,opp,req) let dest_ring env sigma th_spec = let th_typ = Retyping.get_type_of env sigma th_spec in match kind_of_term th_typ with App(f,[|r;zero;one;add;mul;sub;opp;req|]) when eq_constr_nounivs f (Lazy.force coq_almost_ring_theory) -> (None,r,zero,one,add,mul,Some sub,Some opp,req) | App(f,[|r;zero;one;add;mul;req|]) when eq_constr_nounivs f (Lazy.force coq_semi_ring_theory) -> (Some true,r,zero,one,add,mul,None,None,req) | App(f,[|r;zero;one;add;mul;sub;opp;req|]) when eq_constr_nounivs f (Lazy.force coq_ring_theory) -> (Some false,r,zero,one,add,mul,Some sub,Some opp,req) | _ -> error "bad ring structure" let reflect_coeff rkind = (* We build an ill-typed terms on purpose... *) match rkind with Abstract -> Lazy.force coq_abstract | Computational c -> lapp coq_comp [|c|] | Morphism m -> lapp coq_morph [|m|] let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = match cst_tac with Some (CstTac t) -> Tacintern.glob_tactic t | Some (Closed lc) -> closed_term_ast (List.map Smartlocate.global_with_alias lc) | None -> let t = ArgArg(Loc.ghost,Lazy.force ltac_inv_morph_nothing) in TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])) let make_hyp env evd c = let t = Retyping.get_type_of env !evd c in plapp evd coq_mkhypo [|t;c|] let make_hyp_list env evd lH = let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in let l = List.fold_right (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH (plapp evd coq_nil [|carrier|]) in let l' = Typing.e_solve_evars env evd l in Evarutil.nf_evars_universes !evd l' let interp_power env evd pow = let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in match pow with | None -> let t = ArgArg(Loc.ghost, Lazy.force ltac_inv_morph_nothing) in (TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])), plapp evd coq_None [|carrier|]) | Some (tac, spec) -> let tac = match tac with | CstTac t -> Tacintern.glob_tactic t | Closed lc -> closed_term_ast (List.map Smartlocate.global_with_alias lc) in let spec = make_hyp env evd (ic_unsafe spec) in (tac, plapp evd coq_Some [|carrier; spec|]) let interp_sign env evd sign = let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in match sign with | None -> plapp evd coq_None [|carrier|] | Some spec -> let spec = make_hyp env evd (ic_unsafe spec) in plapp evd coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) let interp_div env evd div = let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in match div with | None -> plapp evd coq_None [|carrier|] | Some spec -> let spec = make_hyp env evd (ic_unsafe spec) in plapp evd coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div = check_required_library (cdir@["Ring_base"]); let env = Global.env() in let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in let evd = ref sigma in let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in let (pow_tac, pspec) = interp_power env evd power in let sspec = interp_sign env evd sign in let dspec = interp_div env evd div in let rk = reflect_coeff morphth in let params,ctx = exec_tactic env !evd 5 (zltac "ring_lemmas") [sth;ext;rth;pspec;sspec;dspec;rk] in let lemma1 = params.(3) in let lemma2 = params.(4) in let lemma1 = decl_constant (Id.to_string name^"_ring_lemma1") ctx lemma1 in let lemma2 = decl_constant (Id.to_string name^"_ring_lemma2") ctx lemma2 in let cst_tac = interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in let pretac = match pre with Some t -> Tacintern.glob_tactic t | _ -> TacId [] in let posttac = match post with Some t -> Tacintern.glob_tactic t | _ -> TacId [] in let _ = Lib.add_leaf name (theory_to_obj { ring_carrier = r; ring_req = req; ring_setoid = sth; ring_ext = params.(1); ring_morph = params.(2); ring_th = params.(0); ring_cst_tac = cst_tac; ring_pow_tac = pow_tac; ring_lemma1 = lemma1; ring_lemma2 = lemma2; ring_pre_tac = pretac; ring_post_tac = posttac }) in () let ic_coeff_spec = function | Computational t -> Computational (ic_unsafe t) | Morphism t -> Morphism (ic_unsafe t) | Abstract -> Abstract let set_once s r v = if Option.is_empty !r then r := Some v else error (s^" cannot be set twice") let process_ring_mods l = let kind = ref None in let set = ref None in let cst_tac = ref None in let pre = ref None in let post = ref None in let sign = ref None in let power = ref None in let div = ref None in List.iter(function Ring_kind k -> set_once "ring kind" kind (ic_coeff_spec k) | Const_tac t -> set_once "tactic recognizing constants" cst_tac t | Pre_tac t -> set_once "preprocess tactic" pre t | Post_tac t -> set_once "postprocess tactic" post t | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext) | Pow_spec(t,spec) -> set_once "power" power (t,spec) | Sign_spec t -> set_once "sign" sign t | Div_spec t -> set_once "div" div t) l; let k = match !kind with Some k -> k | None -> Abstract in (k, !set, !cst_tac, !pre, !post, !power, !sign, !div) (*****************************************************************************) (* The tactics consist then only in a lookup in the ring database and call the appropriate ltac. *) let make_args_list rl t = match rl with | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2] | _ -> rl let make_term_list env evd carrier rl = let l = List.fold_right (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl (plapp evd coq_nil [|carrier|]) in Typing.e_solve_evars env evd l let carg = Tacinterp.Value.of_constr let tacarg expr = Tacinterp.Value.of_closure (Tacinterp.default_ist ()) expr let ltac_ring_structure e = let req = carg e.ring_req in let sth = carg e.ring_setoid in let ext = carg e.ring_ext in let morph = carg e.ring_morph in let th = carg e.ring_th in let cst_tac = tacarg e.ring_cst_tac in let pow_tac = tacarg e.ring_pow_tac in let lemma1 = carg e.ring_lemma1 in let lemma2 = carg e.ring_lemma2 in let pretac = tacarg (TacFun([None],e.ring_pre_tac)) in let posttac = tacarg (TacFun([None],e.ring_post_tac)) in [req;sth;ext;morph;th;cst_tac;pow_tac; lemma1;lemma2;pretac;posttac] let ring_lookup (f : Value.t) lH rl t = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try (* find_ring_strucure can raise an exception *) let evdref = ref sigma in let rl = make_args_list rl t in let e = find_ring_structure env sigma rl in let rl = carg (make_term_list env evdref e.ring_carrier rl) in let lH = carg (make_hyp_list env evdref lH) in let ring = ltac_ring_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end } (***********************************************************************) let new_field_path = DirPath.make (List.map Id.of_string ["Field_tac";plugin_dir;"Coq"]) let field_ltac s = lazy(make_kn (MPfile new_field_path) DirPath.empty (Label.make s)) let _ = add_map "field" (map_with_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); (* display_linear: evaluate polynomials and coef operations, protect field operations and make recursive call on the var map *) my_reference "display_linear", (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot); my_reference "display_pow_linear", (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); pol_cst "Pphi_pow", (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot); (* FEeval: evaluate morphism, protect field operations and make recursive call on the var map *) my_reference "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);; let _ = add_map "field_cond" (map_without_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); (* PCond: evaluate morphism and denum list, protect ring operations and make recursive call on the var map *) my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);; (* (function -1|9|11->Eval|10->Rec|_->Prot)]);;*) let _ = Redexpr.declare_reduction "simpl_field_expr" (protect_red "field") let afield_theory = my_reference "almost_field_theory" let field_theory = my_reference "field_theory" let sfield_theory = my_reference "semi_field_theory" let af_ar = my_reference"AF_AR" let f_r = my_reference"F_R" let sf_sr = my_reference"SF_SR" let dest_field env evd th_spec = let th_typ = Retyping.get_type_of env !evd th_spec in match kind_of_term th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) when is_global (Lazy.force afield_theory) f -> let rth = plapp evd af_ar [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) when is_global (Lazy.force field_theory) f -> let rth = plapp evd f_r [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;div;inv;req|]) when is_global (Lazy.force sfield_theory) f -> let rth = plapp evd sf_sr [|r;zero;one;add;mul;div;inv;req;th_spec|] in (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) | _ -> error "bad field structure" let field_from_carrier = Summary.ref Cmap.empty ~name:"field-tac-carrier-table" let field_from_name = Summary.ref Spmap.empty ~name:"field-tac-name-table" let field_for_carrier r = Cmap.find r !field_from_carrier let find_field_structure env sigma l = check_required_library (cdir@["Field_tac"]); match l with | t::cl' -> let ty = Retyping.get_type_of env sigma t in let check c = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then errorlabstrm "field" (str"arguments of field_simplify do not have all the same type") in List.iter check cl'; (try field_for_carrier ty with Not_found -> errorlabstrm "field" (str"cannot find a declared field structure over"++ spc()++str"\""++pr_constr ty++str"\"")) | [] -> assert false let add_field_entry (sp,_kn) e = field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier; field_from_name := Spmap.add sp e !field_from_name let subst_th (subst,th) = let c' = subst_mps subst th.field_carrier in let eq' = subst_mps subst th.field_req in let thm1' = subst_mps subst th.field_ok in let thm2' = subst_mps subst th.field_simpl_eq_ok in let thm3' = subst_mps subst th.field_simpl_ok in let thm4' = subst_mps subst th.field_simpl_eq_in_ok in let thm5' = subst_mps subst th.field_cond in let tac'= Tacsubst.subst_tactic subst th.field_cst_tac in let pow_tac' = Tacsubst.subst_tactic subst th.field_pow_tac in let pretac'= Tacsubst.subst_tactic subst th.field_pre_tac in let posttac'= Tacsubst.subst_tactic subst th.field_post_tac in if c' == th.field_carrier && eq' == th.field_req && thm1' == th.field_ok && thm2' == th.field_simpl_eq_ok && thm3' == th.field_simpl_ok && thm4' == th.field_simpl_eq_in_ok && thm5' == th.field_cond && tac' == th.field_cst_tac && pow_tac' == th.field_pow_tac && pretac' == th.field_pre_tac && posttac' == th.field_post_tac then th else { field_carrier = c'; field_req = eq'; field_cst_tac = tac'; field_pow_tac = pow_tac'; field_ok = thm1'; field_simpl_eq_ok = thm2'; field_simpl_ok = thm3'; field_simpl_eq_in_ok = thm4'; field_cond = thm5'; field_pre_tac = pretac'; field_post_tac = posttac' } let ftheory_to_obj : field_info -> obj = let cache_th (name,th) = add_field_entry name th in declare_object {(default_object "tactic-new-field-theory") with open_function = (fun i o -> if Int.equal i 1 then cache_th o); cache_function = cache_th; subst_function = subst_th; classify_function = (fun x -> Substitute x) } let field_equality evd r inv req = match kind_of_term req with | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) -> mkApp(Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) | _ -> let _setoid = setoid_of_relation (Global.env ()) evd r req in let signature = [Some (r,Some req)],Some(r,Some req) in let inv_m, inv_m_lem = try Rewrite.default_morphism signature inv with Not_found -> error "field inverse should be declared as a morphism" in inv_m_lem let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power sign odiv = check_required_library (cdir@["Field_tac"]); let env = Global.env() in let evd = ref sigma in let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = dest_field env evd fth in let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in let eqth = Some(sth,ext) in let _ = add_theory name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in let (pow_tac, pspec) = interp_power env evd power in let sspec = interp_sign env evd sign in let dspec = interp_div env evd odiv in let inv_m = field_equality evd r inv req in let rk = reflect_coeff morphth in let params,ctx = exec_tactic env !evd 9 (field_ltac"field_lemmas") [sth;ext;inv_m;fth;pspec;sspec;dspec;rk] in let lemma1 = params.(3) in let lemma2 = params.(4) in let lemma3 = params.(5) in let lemma4 = params.(6) in let cond_lemma = match inj with | Some thm -> mkApp(params.(8),[|thm|]) | None -> params.(7) in let lemma1 = decl_constant (Id.to_string name^"_field_lemma1") ctx lemma1 in let lemma2 = decl_constant (Id.to_string name^"_field_lemma2") ctx lemma2 in let lemma3 = decl_constant (Id.to_string name^"_field_lemma3") ctx lemma3 in let lemma4 = decl_constant (Id.to_string name^"_field_lemma4") ctx lemma4 in let cond_lemma = decl_constant (Id.to_string name^"_lemma5") ctx cond_lemma in let cst_tac = interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in let pretac = match pre with Some t -> Tacintern.glob_tactic t | _ -> TacId [] in let posttac = match post with Some t -> Tacintern.glob_tactic t | _ -> TacId [] in let _ = Lib.add_leaf name (ftheory_to_obj { field_carrier = r; field_req = req; field_cst_tac = cst_tac; field_pow_tac = pow_tac; field_ok = lemma1; field_simpl_eq_ok = lemma2; field_simpl_ok = lemma3; field_simpl_eq_in_ok = lemma4; field_cond = cond_lemma; field_pre_tac = pretac; field_post_tac = posttac }) in () let process_field_mods l = let kind = ref None in let set = ref None in let cst_tac = ref None in let pre = ref None in let post = ref None in let inj = ref None in let sign = ref None in let power = ref None in let div = ref None in List.iter(function Ring_mod(Ring_kind k) -> set_once "field kind" kind (ic_coeff_spec k) | Ring_mod(Const_tac t) -> set_once "tactic recognizing constants" cst_tac t | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext) | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec) | Ring_mod(Sign_spec t) -> set_once "sign" sign t | Ring_mod(Div_spec t) -> set_once "div" div t | Inject i -> set_once "infinite property" inj (ic_unsafe i)) l; let k = match !kind with Some k -> k | None -> Abstract in (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) let ltac_field_structure e = let req = carg e.field_req in let cst_tac = tacarg e.field_cst_tac in let pow_tac = tacarg e.field_pow_tac in let field_ok = carg e.field_ok in let field_simpl_ok = carg e.field_simpl_ok in let field_simpl_eq_ok = carg e.field_simpl_eq_ok in let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in let cond_ok = carg e.field_cond in let pretac = tacarg (TacFun([None],e.field_pre_tac)) in let posttac = tacarg (TacFun([None],e.field_post_tac)) in [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok; field_simpl_eq_in_ok;cond_ok;pretac;posttac] let field_lookup (f : Value.t) lH rl t = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try let evdref = ref sigma in let rl = make_args_list rl t in let e = find_field_structure env sigma rl in let rl = carg (make_term_list env evdref e.field_carrier rl) in let lH = carg (make_hyp_list env evdref lH) in let field = ltac_field_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end } coq-8.6/plugins/setoid_ring/Cring.v0000644000175000017500000002142613022274260016704 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* idtac | ?e1::?e2::_ => match goal with |- (?op ?u1 ?u2) => change (op (@Ring_polynom.PEeval _ zero one _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) lvar e1) (@Ring_polynom.PEeval _ zero one _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) lvar e2)) end end. Section cring. Context {R:Type}`{Rr:Cring R}. Lemma cring_eq_ext: ring_eq_ext _+_ _*_ -_ _==_. Proof. intros. apply mk_reqe; solve_proper. Defined. Lemma cring_almost_ring_theory: almost_ring_theory (R:=R) zero one _+_ _*_ _-_ -_ _==_. intros. apply mk_art ;intros. rewrite ring_add_0_l; reflexivity. rewrite ring_add_comm; reflexivity. rewrite ring_add_assoc; reflexivity. rewrite ring_mul_1_l; reflexivity. apply ring_mul_0_l. rewrite cring_mul_comm; reflexivity. rewrite ring_mul_assoc; reflexivity. rewrite ring_distr_l; reflexivity. rewrite ring_opp_mul_l; reflexivity. apply ring_opp_add. rewrite ring_sub_def ; reflexivity. Defined. Lemma cring_morph: ring_morph zero one _+_ _*_ _-_ -_ _==_ 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool Ncring_initial.gen_phiZ. intros. apply mkmorph ; intros; simpl; try reflexivity. rewrite Ncring_initial.gen_phiZ_add; reflexivity. rewrite ring_sub_def. unfold Z.sub. rewrite Ncring_initial.gen_phiZ_add. rewrite Ncring_initial.gen_phiZ_opp; reflexivity. rewrite Ncring_initial.gen_phiZ_mul; reflexivity. rewrite Ncring_initial.gen_phiZ_opp; reflexivity. rewrite (Zeqb_ok x y H). reflexivity. Defined. Lemma cring_power_theory : @Ring_theory.power_theory R one _*_ _==_ N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication). intros; apply Ring_theory.mkpow_th. reflexivity. Defined. Lemma cring_div_theory: div_theory _==_ Z.add Z.mul Ncring_initial.gen_phiZ Z.quotrem. intros. apply InitialRing.Ztriv_div_th. unfold Setoid_Theory. simpl. apply ring_setoid. Defined. End cring. Ltac cring_gen := match goal with |- ?g => let lterm := lterm_goal g in match eval red in (list_reifyl (lterm:=lterm)) with | (?fv, ?lexpr) => (*idtac "variables:";idtac fv; idtac "terms:"; idtac lterm; idtac "reifications:"; idtac lexpr; *) reify_goal fv lexpr lterm; match goal with |- ?g => generalize (@Ring_polynom.ring_correct _ 0 1 _+_ _*_ _-_ -_ _==_ ring_setoid cring_eq_ext cring_almost_ring_theory Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool Ncring_initial.gen_phiZ cring_morph N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) cring_power_theory Z.quotrem cring_div_theory O fv nil); let rc := fresh "rc"in intro rc; apply rc end end end. Ltac cring_compute:= vm_compute; reflexivity. Ltac cring:= intros; cring_gen; cring_compute. Instance Zcri: (Cring (Rr:=Zr)). red. exact Z.mul_comm. Defined. (* Cring_simplify *) Ltac cring_simplify_aux lterm fv lexpr hyp := match lterm with | ?t0::?lterm => match lexpr with | ?e::?le => let t := constr:(@Ring_polynom.norm_subst Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool Z.quotrem O nil e) in let te := constr:(@Ring_polynom.Pphi_dev _ 0 1 _+_ _*_ _-_ -_ Z 0%Z 1%Z Zeq_bool Ncring_initial.gen_phiZ get_signZ fv t) in let eq1 := fresh "ring" in let nft := eval vm_compute in t in let t':= fresh "t" in pose (t' := nft); assert (eq1 : t = t'); [vm_cast_no_check (eq_refl t')| let eq2 := fresh "ring" in assert (eq2:(@Ring_polynom.PEeval _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) fv e) == te); [let eq3 := fresh "ring" in generalize (@ring_rw_correct _ 0 1 _+_ _*_ _-_ -_ _==_ ring_setoid cring_eq_ext cring_almost_ring_theory Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool Ncring_initial.gen_phiZ cring_morph N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) cring_power_theory Z.quotrem cring_div_theory get_signZ get_signZ_th O nil fv I nil (eq_refl nil) ); intro eq3; apply eq3; reflexivity| match hyp with | 1%nat => rewrite eq2 | ?H => try rewrite eq2 in H end]; let P:= fresh "P" in match hyp with | 1%nat => rewrite eq1; pattern (@Ring_polynom.Pphi_dev _ 0 1 _+_ _*_ _-_ -_ Z 0%Z 1%Z Zeq_bool Ncring_initial.gen_phiZ get_signZ fv t'); match goal with |- (?p ?t) => set (P:=p) end; unfold t' in *; clear t' eq1 eq2; unfold Pphi_dev, Pphi_avoid; simpl; repeat (unfold mkmult1, mkmultm1, mkmult_c_pos, mkmult_c, mkadd_mult, mkmult_c_pos, mkmult_pow, mkadd_mult, mkpow;simpl) | ?H => rewrite eq1 in H; pattern (@Ring_polynom.Pphi_dev _ 0 1 _+_ _*_ _-_ -_ Z 0%Z 1%Z Zeq_bool Ncring_initial.gen_phiZ get_signZ fv t') in H; match type of H with | (?p ?t) => set (P:=p) in H end; unfold t' in *; clear t' eq1 eq2; unfold Pphi_dev, Pphi_avoid in H; simpl in H; repeat (unfold mkmult1, mkmultm1, mkmult_c_pos, mkmult_c, mkadd_mult, mkmult_c_pos, mkmult_pow, mkadd_mult, mkpow in H;simpl in H) end; unfold P in *; clear P ]; cring_simplify_aux lterm fv le hyp | nil => idtac end | nil => idtac end. Ltac set_variables fv := match fv with | nil => idtac | ?t::?fv => let v := fresh "X" in set (v:=t) in *; set_variables fv end. Ltac deset n:= match n with | 0%nat => idtac | S ?n1 => match goal with | h:= ?v : ?t |- ?g => unfold h in *; clear h; deset n1 end end. (* a est soit un terme de l'anneau, soit une liste de termes. J'ai pas réussi à un décomposer les Vlists obtenues avec ne_constr_list dans Tactic Notation *) Ltac cring_simplify_gen a hyp := let lterm := match a with | _::_ => a | _ => constr:(a::nil) end in match eval red in (list_reifyl (lterm:=lterm)) with | (?fv, ?lexpr) => idtac lterm; idtac fv; idtac lexpr; let n := eval compute in (length fv) in idtac n; let lt:=fresh "lt" in set (lt:= lterm); let lv:=fresh "fv" in set (lv:= fv); (* les termes de fv sont remplacés par des variables pour pouvoir utiliser simpl ensuite sans risquer des simplifications indésirables *) set_variables fv; let lterm1 := eval unfold lt in lt in let lv1 := eval unfold lv in lv in idtac lterm1; idtac lv1; cring_simplify_aux lterm1 lv1 lexpr hyp; clear lt lv; (* on remet les termes de fv *) deset n end. Tactic Notation "cring_simplify" constr(lterm):= cring_simplify_gen lterm 1%nat. Tactic Notation "cring_simplify" constr(lterm) "in" ident(H):= cring_simplify_gen lterm H. coq-8.6/plugins/setoid_ring/Rings_R.v0000644000175000017500000000162713022274260017206 0ustar mdenesmdenesRequire Export Cring. Require Export Integral_domain. (* Real numbers *) Require Import Reals. Require Import RealField. Lemma Rsth : Setoid_Theory R (@eq R). constructor;red;intros;subst;trivial. Qed. Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)). Instance Rri : (Ring (Ro:=Rops)). constructor; try (try apply Rsth; try (unfold respectful, Proper; unfold equality; unfold eq_notation in *; intros; try rewrite H; try rewrite H0; reflexivity)). exact Rplus_0_l. exact Rplus_comm. symmetry. apply Rplus_assoc. exact Rmult_1_l. exact Rmult_1_r. symmetry. apply Rmult_assoc. exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. exact Rplus_opp_r. Defined. Instance Rcri: (Cring (Rr:=Rri)). red. exact Rmult_comm. Defined. Lemma R_one_zero: 1%R <> 0%R. discrR. Qed. Instance Rdi : (Integral_domain (Rcr:=Rcri)). constructor. exact Rmult_integral. exact R_one_zero. Defined. coq-8.6/plugins/setoid_ring/Rings_Q.v0000644000175000017500000000141313022274260017176 0ustar mdenesmdenesRequire Export Cring. Require Export Integral_domain. (* Rational numbers *) Require Import QArith. Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). Instance Qri : (Ring (Ro:=Qops)). constructor. try apply Q_Setoid. apply Qplus_comp. apply Qmult_comp. apply Qminus_comp. apply Qopp_comp. exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. reflexivity. exact Qplus_opp_r. Defined. Instance Qcri: (Cring (Rr:=Qri)). red. exact Qmult_comm. Defined. Lemma Q_one_zero: not (Qeq 1%Q 0%Q). unfold Qeq. simpl. auto with *. Qed. Instance Qdi : (Integral_domain (Rcr:=Qcri)). constructor. exact Qmult_integral. exact Q_one_zero. Defined. coq-8.6/plugins/setoid_ring/NArithRing.v0000644000175000017500000000140113022274260017636 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t | _ => constr:(NotConstant) end. Add Ring Nr : Nth (decidable Neqb_ok, constants [Ncst]). coq-8.6/plugins/setoid_ring/Ncring_initial.v0000644000175000017500000001407513022274260020575 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 1 | xO p => (1 + 1) * (gen_phiPOS1 p) | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p)) end. Fixpoint gen_phiPOS (p:positive) : R := match p with | xH => 1 | xO xH => (1 + 1) | xO p => (1 + 1) * (gen_phiPOS p) | xI xH => 1 + (1 +1) | xI p => 1 + ((1 + 1) * (gen_phiPOS p)) end. Definition gen_phiZ1 z := match z with | Zpos p => gen_phiPOS1 p | Z0 => 0 | Zneg p => -(gen_phiPOS1 p) end. Definition gen_phiZ z := match z with | Zpos p => gen_phiPOS p | Z0 => 0 | Zneg p => -(gen_phiPOS p) end. Local Notation "[ x ]" := (gen_phiZ x) : ZMORPHISM. Local Open Scope ZMORPHISM. Definition get_signZ z := match z with | Zneg p => Some (Zpos p) | _ => None end. Ltac norm := gen_rewrite. Ltac add_push := Ncring.gen_add_push. Ltac rsimpl := simpl. Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. Proof. induction x;rsimpl. rewrite IHx. destruct x;simpl;norm. rewrite IHx;destruct x;simpl;norm. reflexivity. Qed. Lemma ARgen_phiPOS_Psucc : forall x, gen_phiPOS1 (Pos.succ x) == 1 + (gen_phiPOS1 x). Proof. induction x;rsimpl;norm. rewrite IHx. gen_rewrite. add_push 1. reflexivity. Qed. Lemma ARgen_phiPOS_add : forall x y, gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y). Proof. induction x;destruct y;simpl;norm. rewrite Pos.add_carry_spec. rewrite ARgen_phiPOS_Psucc. rewrite IHx;norm. add_push (gen_phiPOS1 y);add_push 1;reflexivity. rewrite IHx;norm;add_push (gen_phiPOS1 y);reflexivity. rewrite ARgen_phiPOS_Psucc;norm;add_push 1;reflexivity. rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;reflexivity. rewrite IHx;norm;add_push(gen_phiPOS1 y);reflexivity. add_push 1;reflexivity. rewrite ARgen_phiPOS_Psucc;norm;add_push 1;reflexivity. Qed. Lemma ARgen_phiPOS_mult : forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y. Proof. induction x;intros;simpl;norm. rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm. rewrite IHx;reflexivity. Qed. (*morphisms are extensionally equal*) Lemma same_genZ : forall x, [x] == gen_phiZ1 x. Proof. destruct x;rsimpl; try rewrite same_gen; reflexivity. Qed. Lemma gen_Zeqb_ok : forall x y, Zeq_bool x y = true -> [x] == [y]. Proof. intros x y H7. assert (H10 := Zeq_bool_eq x y H7);unfold IDphi in H10. rewrite H10;reflexivity. Qed. Lemma gen_phiZ1_add_pos_neg : forall x y, gen_phiZ1 (Z.pos_sub x y) == gen_phiPOS1 x + -gen_phiPOS1 y. Proof. intros x y. generalize (Z.pos_sub_discr x y). destruct (Z.pos_sub x y) as [|p|p]; intros; subst. - now rewrite ring_opp_def. - rewrite ARgen_phiPOS_add;simpl;norm. add_push (gen_phiPOS1 p). rewrite ring_opp_def;norm. - rewrite ARgen_phiPOS_add;simpl;norm. rewrite ring_opp_def;norm. Qed. Lemma match_compOpp : forall x (B:Type) (be bl bg:B), match CompOpp x with Eq => be | Lt => bl | Gt => bg end = match x with Eq => be | Lt => bg | Gt => bl end. Proof. destruct x;simpl;intros;trivial. Qed. Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y]. Proof. intros x y; repeat rewrite same_genZ; generalize x y;clear x y. induction x;destruct y;simpl;norm. apply ARgen_phiPOS_add. apply gen_phiZ1_add_pos_neg. rewrite gen_phiZ1_add_pos_neg. rewrite ring_add_comm. reflexivity. rewrite ARgen_phiPOS_add. rewrite ring_opp_add. reflexivity. Qed. Lemma gen_phiZ_opp : forall x, [- x] == - [x]. Proof. intros x. repeat rewrite same_genZ. generalize x ;clear x. induction x;simpl;norm. rewrite ring_opp_opp. reflexivity. Qed. Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y]. Proof. intros x y;repeat rewrite same_genZ. destruct x;destruct y;simpl;norm; rewrite ARgen_phiPOS_mult;try (norm;fail). rewrite ring_opp_opp ;reflexivity. Qed. Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y]. Proof. intros;subst;reflexivity. Qed. Declare Equivalent Keys bracket gen_phiZ. (*proof that [.] satisfies morphism specifications*) Global Instance gen_phiZ_morph : (@Ring_morphism (Z:Type) R _ _ _ _ _ _ _ Zops Zr _ _ _ _ _ _ _ _ _ gen_phiZ) . (* beurk!*) apply Build_Ring_morphism; simpl;try reflexivity. apply gen_phiZ_add. intros. rewrite ring_sub_def. replace (x-y)%Z with (x + (-y))%Z. now rewrite gen_phiZ_add, gen_phiZ_opp, ring_sub_def. reflexivity. apply gen_phiZ_mul. apply gen_phiZ_opp. apply gen_phiZ_ext. Defined. End ZMORPHISM. Instance multiplication_phi_ring{R:Type}`{Ring R} : Multiplication := {multiplication x y := (gen_phiZ x) * y}. coq-8.6/plugins/setoid_ring/g_newring.ml40000644000175000017500000001300113022274260020036 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ protect_tac_in map id ] | [ "protect_fv" string(map) ] -> [ protect_tac map ] END TACTIC EXTEND closed_term [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] -> [ closed_term t l ] END open Pptactic open Ppconstr let pr_ring_mod = function | Ring_kind (Computational eq_test) -> str "decidable" ++ pr_arg pr_constr_expr eq_test | Ring_kind Abstract -> str "abstract" | Ring_kind (Morphism morph) -> str "morphism" ++ pr_arg pr_constr_expr morph | Const_tac (CstTac cst_tac) -> str "constants" ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]" | Const_tac (Closed l) -> str "closed" ++ spc () ++ str "[" ++ prlist_with_sep spc pr_reference l ++ str "]" | Pre_tac t -> str "preprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]" | Post_tac t -> str "postprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]" | Setoid(sth,ext) -> str "setoid" ++ pr_arg pr_constr_expr sth ++ pr_arg pr_constr_expr ext | Pow_spec(Closed l,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ prlist_with_sep spc pr_reference l ++ str "]" | Pow_spec(CstTac cst_tac,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]" | Sign_spec t -> str "sign" ++ pr_arg pr_constr_expr t | Div_spec t -> str "div" ++ pr_arg pr_constr_expr t VERNAC ARGUMENT EXTEND ring_mod PRINTED BY pr_ring_mod | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ] | [ "abstract" ] -> [ Ring_kind Abstract ] | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism morph) ] | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ] | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ] | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ] | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ] | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ] | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ] | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] -> [ Pow_spec (Closed l, pow_spec) ] | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] -> [ Pow_spec (CstTac cst_tac, pow_spec) ] | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ] END let pr_ring_mods l = surround (prlist_with_sep pr_comma pr_ring_mod l) VERNAC ARGUMENT EXTEND ring_mods PRINTED BY pr_ring_mods | [ "(" ne_ring_mod_list_sep(mods, ",") ")" ] -> [ mods ] END VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] -> [ let l = match l with None -> [] | Some l -> l in let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in add_theory id (ic t) set k cst (pre,post) power sign div] | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [ Feedback.msg_notice (strbrk "The following ring structures have been declared:"); Spmap.iter (fun fn fi -> Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ str"with carrier "++ pr_constr fi.ring_carrier++spc()++ str"and equivalence relation "++ pr_constr fi.ring_req)) ) !from_name ] END TACTIC EXTEND ring_lookup | [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] -> [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t] END let pr_field_mod = function | Ring_mod m -> pr_ring_mod m | Inject inj -> str "completeness" ++ pr_arg pr_constr_expr inj VERNAC ARGUMENT EXTEND field_mod PRINTED BY pr_field_mod | [ ring_mod(m) ] -> [ Ring_mod m ] | [ "completeness" constr(inj) ] -> [ Inject inj ] END let pr_field_mods l = surround (prlist_with_sep pr_comma pr_field_mod l) VERNAC ARGUMENT EXTEND field_mods PRINTED BY pr_field_mods | [ "(" ne_field_mod_list_sep(mods, ",") ")" ] -> [ mods ] END VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF | [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] -> [ let l = match l with None -> [] | Some l -> l in let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div] | [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [ Feedback.msg_notice (strbrk "The following field structures have been declared:"); Spmap.iter (fun fn fi -> Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ str"with carrier "++ pr_constr fi.field_carrier++spc()++ str"and equivalence relation "++ pr_constr fi.field_req)) ) !field_from_name ] END TACTIC EXTEND field_lookup | [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> [ let (t,l) = List.sep_last lt in field_lookup f lH l t ] END coq-8.6/plugins/setoid_ring/Ring_base.v0000644000175000017500000000146113022274260017530 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr:(t1::t2::nil) | ?t1 = ?t2 => constr:(t1::t2::nil) | (_ ?t1 ?t2) => constr:(t1::t2::nil) end. Lemma Zeqb_ok: forall x y : Z, Zeq_bool x y = true -> x == y. intros x y H. rewrite (Zeq_bool_eq x y H). reflexivity. Qed. Ltac reify_goal lvar lexpr lterm:= (*idtac lvar; idtac lexpr; idtac lterm;*) match lexpr with nil => idtac | ?e1::?e2::_ => match goal with |- (?op ?u1 ?u2) => change (op (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _) lvar e1) (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _) lvar e2)) end end. Lemma comm: forall (R:Type)`{Ring R}(c : Z) (x : R), x * (gen_phiZ c) == (gen_phiZ c) * x. induction c. intros. simpl. gen_rewrite. simpl. intros. rewrite <- same_gen. induction p. simpl. gen_rewrite. rewrite IHp. reflexivity. simpl. gen_rewrite. rewrite IHp. reflexivity. simpl. gen_rewrite. simpl. intros. rewrite <- same_gen. induction p. simpl. generalize IHp. clear IHp. gen_rewrite. intro IHp. rewrite IHp. reflexivity. simpl. generalize IHp. clear IHp. gen_rewrite. intro IHp. rewrite IHp. reflexivity. simpl. gen_rewrite. Qed. Ltac ring_gen := match goal with |- ?g => let lterm := lterm_goal g in match eval red in (list_reifyl (lterm:=lterm)) with | (?fv, ?lexpr) => (*idtac "variables:";idtac fv; idtac "terms:"; idtac lterm; idtac "reifications:"; idtac lexpr; *) reify_goal fv lexpr lterm; match goal with |- ?g => apply (@ring_correct Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) _ (@comm _ _ _ _ _ _ _ _ _ _) Zeq_bool Zeqb_ok N (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _)); [apply mkpow_th; reflexivity |vm_compute; reflexivity] end end end. Ltac non_commutative_ring:= intros; ring_gen. (* simplification *) Ltac ring_simplify_aux lterm fv lexpr hyp := match lterm with | ?t0::?lterm => match lexpr with | ?e::?le => (* e:PExpr Z est la réification de t0:R *) let t := constr:(@Ncring_polynom.norm_subst Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z) Zops Zeq_bool e) in (* t:Pol Z *) let te := constr:(@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ fv t) in let eq1 := fresh "ring" in let nft := eval vm_compute in t in let t':= fresh "t" in pose (t' := nft); assert (eq1 : t = t'); [vm_cast_no_check (eq_refl t')| let eq2 := fresh "ring" in assert (eq2:(@Ncring_polynom.PEeval Z _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) fv e) == te); [apply (@Ncring_polynom.norm_subst_ok Z _ 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z) _ _ 0 1 _+_ _*_ _-_ -_ _==_ _ _ Ncring_initial.gen_phiZ _ (@comm _ 0 1 _+_ _*_ _-_ -_ _==_ _ _) _ Zeqb_ok); apply mkpow_th; reflexivity | match hyp with | 1%nat => rewrite eq2 | ?H => try rewrite eq2 in H end]; let P:= fresh "P" in match hyp with | 1%nat => idtac "ok"; rewrite eq1; pattern (@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ fv t'); match goal with |- (?p ?t) => set (P:=p) end; unfold t' in *; clear t' eq1 eq2; simpl | ?H => rewrite eq1 in H; pattern (@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ fv t') in H; match type of H with | (?p ?t) => set (P:=p) in H end; unfold t' in *; clear t' eq1 eq2; simpl in H end; unfold P in *; clear P ]; ring_simplify_aux lterm fv le hyp | nil => idtac end | nil => idtac end. Ltac set_variables fv := match fv with | nil => idtac | ?t::?fv => let v := fresh "X" in set (v:=t) in *; set_variables fv end. Ltac deset n:= match n with | 0%nat => idtac | S ?n1 => match goal with | h:= ?v : ?t |- ?g => unfold h in *; clear h; deset n1 end end. (* a est soit un terme de l'anneau, soit une liste de termes. J'ai pas réussi à un décomposer les Vlists obtenues avec ne_constr_list dans Tactic Notation *) Ltac ring_simplify_gen a hyp := let lterm := match a with | _::_ => a | _ => constr:(a::nil) end in match eval red in (list_reifyl (lterm:=lterm)) with | (?fv, ?lexpr) => idtac lterm; idtac fv; idtac lexpr; let n := eval compute in (length fv) in idtac n; let lt:=fresh "lt" in set (lt:= lterm); let lv:=fresh "fv" in set (lv:= fv); (* les termes de fv sont remplacés par des variables pour pouvoir utiliser simpl ensuite sans risquer des simplifications indésirables *) set_variables fv; let lterm1 := eval unfold lt in lt in let lv1 := eval unfold lv in lv in idtac lterm1; idtac lv1; ring_simplify_aux lterm1 lv1 lexpr hyp; clear lt lv; (* on remet les termes de fv *) deset n end. Tactic Notation "non_commutative_ring_simplify" constr(lterm):= ring_simplify_gen lterm 1%nat. Tactic Notation "non_commutative_ring_simplify" constr(lterm) "in" ident(H):= ring_simplify_gen lterm H. coq-8.6/plugins/btauto/0000755000175000017500000000000013022274260014436 5ustar mdenesmdenescoq-8.6/plugins/btauto/g_btauto.ml40000644000175000017500000000124113022274260016656 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ Refl_btauto.Btauto.tac ] END coq-8.6/plugins/btauto/btauto_plugin.mlpack0000644000175000017500000000002513022274260020500 0ustar mdenesmdenesRefl_btauto G_btauto coq-8.6/plugins/btauto/Btauto.v0000644000175000017500000000010413022274260016056 0ustar mdenesmdenesRequire Import Algebra Reflect. Declare ML Module "btauto_plugin". coq-8.6/plugins/btauto/Reflect.v0000644000175000017500000003224013022274260016212 0ustar mdenesmdenesRequire Import Bool DecidableClass Algebra Ring PArith ROmega Omega. Section Bool. (* Boolean formulas and their evaluations *) Inductive formula := | formula_var : positive -> formula | formula_btm : formula | formula_top : formula | formula_cnj : formula -> formula -> formula | formula_dsj : formula -> formula -> formula | formula_neg : formula -> formula | formula_xor : formula -> formula -> formula | formula_ifb : formula -> formula -> formula -> formula. Fixpoint formula_eval var f := match f with | formula_var x => list_nth x var false | formula_btm => false | formula_top => true | formula_cnj fl fr => (formula_eval var fl) && (formula_eval var fr) | formula_dsj fl fr => (formula_eval var fl) || (formula_eval var fr) | formula_neg f => negb (formula_eval var f) | formula_xor fl fr => xorb (formula_eval var fl) (formula_eval var fr) | formula_ifb fc fl fr => if formula_eval var fc then formula_eval var fl else formula_eval var fr end. End Bool. (* Translation of formulas into polynomials *) Section Translation. (* This is straightforward. *) Fixpoint poly_of_formula f := match f with | formula_var x => Poly (Cst false) x (Cst true) | formula_btm => Cst false | formula_top => Cst true | formula_cnj fl fr => let pl := poly_of_formula fl in let pr := poly_of_formula fr in poly_mul pl pr | formula_dsj fl fr => let pl := poly_of_formula fl in let pr := poly_of_formula fr in poly_add (poly_add pl pr) (poly_mul pl pr) | formula_neg f => poly_add (Cst true) (poly_of_formula f) | formula_xor fl fr => poly_add (poly_of_formula fl) (poly_of_formula fr) | formula_ifb fc fl fr => let pc := poly_of_formula fc in let pl := poly_of_formula fl in let pr := poly_of_formula fr in poly_add pr (poly_add (poly_mul pc pl) (poly_mul pc pr)) end. Opaque poly_add. (* Compatibility of translation wrt evaluation *) Lemma poly_of_formula_eval_compat : forall var f, eval var (poly_of_formula f) = formula_eval var f. Proof. intros var f; induction f; simpl poly_of_formula; simpl formula_eval; auto. now simpl; match goal with [ |- ?t = ?u ] => destruct u; reflexivity end. rewrite poly_mul_compat, IHf1, IHf2; ring. repeat rewrite poly_add_compat. rewrite poly_mul_compat; try_rewrite. now match goal with [ |- ?t = ?x || ?y ] => destruct x; destruct y; reflexivity end. rewrite poly_add_compat; try_rewrite. now match goal with [ |- ?t = negb ?x ] => destruct x; reflexivity end. rewrite poly_add_compat; congruence. rewrite ?poly_add_compat, ?poly_mul_compat; try_rewrite. match goal with [ |- ?t = if ?b1 then ?b2 else ?b3 ] => destruct b1; destruct b2; destruct b3; reflexivity end. Qed. Hint Extern 5 => change 0 with (min 0 0). Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat. Local Hint Constructors valid. Hint Extern 5 => zify; omega. (* Compatibility with validity *) Lemma poly_of_formula_valid_compat : forall f, exists n, valid n (poly_of_formula f). Proof. intros f; induction f; simpl. + exists (Pos.succ p); constructor; intuition; inversion H. + exists 1%positive; auto. + exists 1%positive; auto. + destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max n1 n2); auto. + destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max (Pos.max n1 n2) (Pos.max n1 n2)); auto. + destruct IHf as [n Hn]; exists (Pos.max 1 n); auto. + destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max n1 n2); auto. + destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; destruct IHf3 as [n3 Hn3]; eexists; eauto. Qed. (* The soundness lemma ; alas not complete! *) Lemma poly_of_formula_sound : forall fl fr var, poly_of_formula fl = poly_of_formula fr -> formula_eval var fl = formula_eval var fr. Proof. intros fl fr var Heq. repeat rewrite <- poly_of_formula_eval_compat. rewrite Heq; reflexivity. Qed. End Translation. Section Completeness. (* Lemma reduce_poly_of_formula_simpl : forall fl fr var, simpl_eval (var_of_list var) (reduce (poly_of_formula fl)) = simpl_eval (var_of_list var) (reduce (poly_of_formula fr)) -> formula_eval var fl = formula_eval var fr. Proof. intros fl fr var Hrw. do 2 rewrite <- poly_of_formula_eval_compat. destruct (poly_of_formula_valid_compat fl) as [nl Hl]. destruct (poly_of_formula_valid_compat fr) as [nr Hr]. rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); [|assumption]. rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); [|assumption]. do 2 rewrite <- eval_simpl_eval_compat; assumption. Qed. *) (* Soundness of the method ; immediate *) Lemma reduce_poly_of_formula_sound : forall fl fr var, reduce (poly_of_formula fl) = reduce (poly_of_formula fr) -> formula_eval var fl = formula_eval var fr. Proof. intros fl fr var Heq. repeat rewrite <- poly_of_formula_eval_compat. destruct (poly_of_formula_valid_compat fl) as [nl Hl]. destruct (poly_of_formula_valid_compat fr) as [nr Hr]. rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); auto. rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); auto. rewrite Heq; reflexivity. Qed. Definition make_last {A} n (x def : A) := Pos.peano_rect (fun _ => list A) (cons x nil) (fun _ F => cons def F) n. (* Replace the nth element of a list *) Fixpoint list_replace l n b := match l with | nil => make_last n b false | cons a l => Pos.peano_rect _ (cons b l) (fun n _ => cons a (list_replace l n b)) n end. (** Extract a non-null witness from a polynomial *) Existing Instance Decidable_null. Fixpoint boolean_witness p := match p with | Cst c => nil | Poly p i q => if decide (null p) then let var := boolean_witness q in list_replace var i true else let var := boolean_witness p in list_replace var i false end. Lemma list_nth_base : forall A (def : A) l, list_nth 1 l def = match l with nil => def | cons x _ => x end. Proof. intros A def l; unfold list_nth. rewrite Pos.peano_rect_base; reflexivity. Qed. Lemma list_nth_succ : forall A n (def : A) l, list_nth (Pos.succ n) l def = match l with nil => def | cons _ l => list_nth n l def end. Proof. intros A def l; unfold list_nth. rewrite Pos.peano_rect_succ; reflexivity. Qed. Lemma list_nth_nil : forall A n (def : A), list_nth n nil def = def. Proof. intros A n def; induction n using Pos.peano_rect. + rewrite list_nth_base; reflexivity. + rewrite list_nth_succ; reflexivity. Qed. Lemma make_last_nth_1 : forall A n i x def, i <> n -> list_nth i (@make_last A n x def) def = def. Proof. intros A n; induction n using Pos.peano_rect; intros i x def Hd; unfold make_last; simpl. + induction i using Pos.peano_case; [elim Hd; reflexivity|]. rewrite list_nth_succ, list_nth_nil; reflexivity. + unfold make_last; rewrite Pos.peano_rect_succ; fold (make_last n x def). induction i using Pos.peano_case. - rewrite list_nth_base; reflexivity. - rewrite list_nth_succ; apply IHn; zify; omega. Qed. Lemma make_last_nth_2 : forall A n x def, list_nth n (@make_last A n x def) def = x. Proof. intros A n; induction n using Pos.peano_rect; intros x def; simpl. + reflexivity. + unfold make_last; rewrite Pos.peano_rect_succ; fold (make_last n x def). rewrite list_nth_succ; auto. Qed. Lemma list_replace_nth_1 : forall var i j x, i <> j -> list_nth i (list_replace var j x) false = list_nth i var false. Proof. intros var; induction var; intros i j x Hd; simpl. + rewrite make_last_nth_1, list_nth_nil; auto. + induction j using Pos.peano_rect. - rewrite Pos.peano_rect_base. induction i using Pos.peano_rect; [now elim Hd; auto|]. rewrite 2list_nth_succ; reflexivity. - rewrite Pos.peano_rect_succ. induction i using Pos.peano_rect. { rewrite 2list_nth_base; reflexivity. } { rewrite 2list_nth_succ; apply IHvar; zify; omega. } Qed. Lemma list_replace_nth_2 : forall var i x, list_nth i (list_replace var i x) false = x. Proof. intros var; induction var; intros i x; simpl. + now apply make_last_nth_2. + induction i using Pos.peano_rect. - rewrite Pos.peano_rect_base, list_nth_base; reflexivity. - rewrite Pos.peano_rect_succ, list_nth_succ; auto. Qed. (* The witness is correct only if the polynomial is linear *) Lemma boolean_witness_nonzero : forall k p, linear k p -> ~ null p -> eval (boolean_witness p) p = true. Proof. intros k p Hl Hp; induction Hl; simpl. destruct c; [reflexivity|elim Hp; now constructor]. case_decide. rewrite eval_null_zero; [|assumption]; rewrite list_replace_nth_2; simpl. match goal with [ |- (if ?b then true else false) = true ] => assert (Hrw : b = true); [|rewrite Hrw; reflexivity] end. erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto]. now intros j Hd; apply list_replace_nth_1; zify; omega. rewrite list_replace_nth_2, xorb_false_r. erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto]. now intros j Hd; apply list_replace_nth_1; zify; omega. Qed. (* This should be better when using the [vm_compute] tactic instead of plain reflexivity. *) Lemma reduce_poly_of_formula_sound_alt : forall var fl fr, reduce (poly_add (poly_of_formula fl) (poly_of_formula fr)) = Cst false -> formula_eval var fl = formula_eval var fr. Proof. intros var fl fr Heq. repeat rewrite <- poly_of_formula_eval_compat. destruct (poly_of_formula_valid_compat fl) as [nl Hl]. destruct (poly_of_formula_valid_compat fr) as [nr Hr]. rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); auto. rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); auto. rewrite <- xorb_false_l; change false with (eval var (Cst false)). rewrite <- poly_add_compat, <- Heq. repeat rewrite poly_add_compat. rewrite (reduce_eval_compat nl); [|assumption]. rewrite (reduce_eval_compat (Pos.max nl nr)); [|apply poly_add_valid_compat; assumption]. rewrite (reduce_eval_compat nr); [|assumption]. rewrite poly_add_compat; ring. Qed. (* The completeness lemma *) (* Lemma reduce_poly_of_formula_complete : forall fl fr, reduce (poly_of_formula fl) <> reduce (poly_of_formula fr) -> {var | formula_eval var fl <> formula_eval var fr}. Proof. intros fl fr H. pose (p := poly_add (reduce (poly_of_formula fl)) (poly_opp (reduce (poly_of_formula fr)))). pose (var := boolean_witness p). exists var. intros Hc; apply (f_equal Z_of_bool) in Hc. assert (Hfl : linear 0 (reduce (poly_of_formula fl))). now destruct (poly_of_formula_valid_compat fl) as [n Hn]; apply (linear_le_compat n); [|now auto]; apply linear_reduce; auto. assert (Hfr : linear 0 (reduce (poly_of_formula fr))). now destruct (poly_of_formula_valid_compat fr) as [n Hn]; apply (linear_le_compat n); [|now auto]; apply linear_reduce; auto. repeat rewrite <- poly_of_formula_eval_compat in Hc. define (decide (null p)) b Hb; destruct b; tac_decide. now elim H; apply (null_sub_implies_eq 0 0); fold p; auto; apply linear_valid_incl; auto. elim (boolean_witness_nonzero 0 p); auto. unfold p; rewrite <- (min_id 0); apply poly_add_linear_compat; try apply poly_opp_linear_compat; now auto. unfold p at 2; rewrite poly_add_compat, poly_opp_compat. destruct (poly_of_formula_valid_compat fl) as [nl Hnl]. destruct (poly_of_formula_valid_compat fr) as [nr Hnr]. repeat erewrite reduce_eval_compat; eauto. fold var; rewrite Hc; ring. Defined. *) End Completeness. (* Reification tactics *) (* For reflexivity purposes, that would better be transparent *) Global Transparent decide poly_add. (* Ltac append_var x l k := match l with | nil => constr: (k, cons x l) | cons x _ => constr: (k, l) | cons ?y ?l => let ans := append_var x l (S k) in match ans with (?k, ?l) => constr: (k, cons y l) end end. Ltac build_formula t l := match t with | true => constr: (formula_top, l) | false => constr: (formula_btm, l) | ?fl && ?fr => match build_formula fl l with (?tl, ?l) => match build_formula fr l with (?tr, ?l) => constr: (formula_cnj tl tr, l) end end | ?fl || ?fr => match build_formula fl l with (?tl, ?l) => match build_formula fr l with (?tr, ?l) => constr: (formula_dsj tl tr, l) end end | negb ?f => match build_formula f l with (?t, ?l) => constr: (formula_neg t, l) end | _ => let ans := append_var t l 0 in match ans with (?k, ?l) => constr: (formula_var k, l) end end. (* Extract a counterexample from a polynomial and display it *) Ltac counterexample p l := let var := constr: (boolean_witness p) in let var := eval vm_compute in var in let rec print l vl := match l with | nil => idtac | cons ?x ?l => match vl with | nil => idtac x ":=" "false"; print l (@nil bool) | cons ?v ?vl => idtac x ":=" v; print l vl end end in idtac "Counter-example:"; print l var. Ltac btauto_reify := lazymatch goal with | [ |- @eq bool ?t ?u ] => lazymatch build_formula t (@nil bool) with | (?fl, ?l) => lazymatch build_formula u l with | (?fr, ?l) => change (formula_eval l fl = formula_eval l fr) end end | _ => fail "Cannot recognize a boolean equality" end. (* The long-awaited tactic *) Ltac btauto := lazymatch goal with | [ |- @eq bool ?t ?u ] => lazymatch build_formula t (@nil bool) with | (?fl, ?l) => lazymatch build_formula u l with | (?fr, ?l) => change (formula_eval l fl = formula_eval l fr); apply reduce_poly_of_formula_sound_alt; vm_compute; (reflexivity || fail "Not a tautology") end end | _ => fail "Cannot recognize a boolean equality" end. *) coq-8.6/plugins/btauto/Algebra.v0000644000175000017500000004557413022274260016201 0ustar mdenesmdenesRequire Import Bool PArith DecidableClass Omega ROmega. Ltac bool := repeat match goal with | [ H : ?P && ?Q = true |- _ ] => apply andb_true_iff in H; destruct H | |- ?P && ?Q = true => apply <- andb_true_iff; split end. Arguments decide P /H. Hint Extern 5 => progress bool. Ltac define t x H := set (x := t) in *; assert (H : t = x) by reflexivity; clearbody x. Lemma Decidable_sound : forall P (H : Decidable P), decide P = true -> P. Proof. intros P H Hp; apply -> Decidable_spec; assumption. Qed. Lemma Decidable_complete : forall P (H : Decidable P), P -> decide P = true. Proof. intros P H Hp; apply <- Decidable_spec; assumption. Qed. Lemma Decidable_sound_alt : forall P (H : Decidable P), ~ P -> decide P = false. Proof. intros P [wit spec] Hd; destruct wit; simpl; tauto. Qed. Lemma Decidable_complete_alt : forall P (H : Decidable P), decide P = false -> ~ P. Proof. intros P [wit spec] Hd Hc; simpl in *; intuition congruence. Qed. Ltac try_rewrite := repeat match goal with | [ H : ?P |- _ ] => rewrite H end. (* We opacify here decide for proofs, and will make it transparent for reflexive tactics later on. *) Global Opaque decide. Ltac tac_decide := match goal with | [ H : @decide ?P ?D = true |- _ ] => apply (@Decidable_sound P D) in H | [ H : @decide ?P ?D = false |- _ ] => apply (@Decidable_complete_alt P D) in H | [ |- @decide ?P ?D = true ] => apply (@Decidable_complete P D) | [ |- @decide ?P ?D = false ] => apply (@Decidable_sound_alt P D) | [ |- negb ?b = true ] => apply negb_true_iff | [ |- negb ?b = false ] => apply negb_false_iff | [ H : negb ?b = true |- _ ] => apply negb_true_iff in H | [ H : negb ?b = false |- _ ] => apply negb_false_iff in H end. Ltac try_decide := repeat tac_decide. Ltac make_decide P := match goal with | [ |- context [@decide P ?D] ] => let b := fresh "b" in let H := fresh "H" in define (@decide P D) b H; destruct b; try_decide | [ X : context [@decide P ?D] |- _ ] => let b := fresh "b" in let H := fresh "H" in define (@decide P D) b H; destruct b; try_decide end. Ltac case_decide := match goal with | [ |- context [@decide ?P ?D] ] => let b := fresh "b" in let H := fresh "H" in define (@decide P D) b H; destruct b; try_decide | [ X : context [@decide ?P ?D] |- _ ] => let b := fresh "b" in let H := fresh "H" in define (@decide P D) b H; destruct b; try_decide | [ |- context [Pos.compare ?x ?y] ] => destruct (Pos.compare_spec x y); try (exfalso; zify; romega) | [ X : context [Pos.compare ?x ?y] |- _ ] => destruct (Pos.compare_spec x y); try (exfalso; zify; romega) end. Section Definitions. (** * Global, inductive definitions. *) (** A Horner polynomial is either a constant, or a product P × (i + Q), where i is a variable. *) Inductive poly := | Cst : bool -> poly | Poly : poly -> positive -> poly -> poly. (* TODO: We should use [positive] instead of [nat] to encode variables, for efficiency purpose. *) Inductive null : poly -> Prop := | null_intro : null (Cst false). (** Polynomials satisfy a uniqueness condition whenever they are valid. A polynomial [p] satisfies [valid n p] whenever it is well-formed and each of its variable indices is < [n]. *) Inductive valid : positive -> poly -> Prop := | valid_cst : forall k c, valid k (Cst c) | valid_poly : forall k p i q, Pos.lt i k -> ~ null q -> valid i p -> valid (Pos.succ i) q -> valid k (Poly p i q). (** Linear polynomials are valid polynomials in which every variable appears at most once. *) Inductive linear : positive -> poly -> Prop := | linear_cst : forall k c, linear k (Cst c) | linear_poly : forall k p i q, Pos.lt i k -> ~ null q -> linear i p -> linear i q -> linear k (Poly p i q). End Definitions. Section Computational. Program Instance Decidable_PosEq : forall (p q : positive), Decidable (p = q) := { Decidable_witness := Pos.eqb p q }. Next Obligation. apply Pos.eqb_eq. Qed. Program Instance Decidable_PosLt : forall p q, Decidable (Pos.lt p q) := { Decidable_witness := Pos.ltb p q }. Next Obligation. apply Pos.ltb_lt. Qed. Program Instance Decidable_PosLe : forall p q, Decidable (Pos.le p q) := { Decidable_witness := Pos.leb p q }. Next Obligation. apply Pos.leb_le. Qed. (** * The core reflexive part. *) Hint Constructors valid. Fixpoint beq_poly pl pr := match pl with | Cst cl => match pr with | Cst cr => decide (cl = cr) | Poly _ _ _ => false end | Poly pl il ql => match pr with | Cst _ => false | Poly pr ir qr => decide (il = ir) && beq_poly pl pr && beq_poly ql qr end end. (* We could do that with [decide equality] but dependency in proofs is heavy *) Program Instance Decidable_eq_poly : forall (p q : poly), Decidable (eq p q) := { Decidable_witness := beq_poly p q }. Next Obligation. split. revert q; induction p; intros [] ?; simpl in *; bool; try_decide; f_equal; first [intuition congruence|auto]. revert q; induction p; intros [] Heq; simpl in *; bool; try_decide; intuition; try injection Heq; first[congruence|intuition]. Qed. Program Instance Decidable_null : forall p, Decidable (null p) := { Decidable_witness := match p with Cst false => true | _ => false end }. Next Obligation. split. destruct p as [[]|]; first [discriminate|constructor]. inversion 1; trivial. Qed. Definition list_nth {A} p (l : list A) def := Pos.peano_rect (fun _ => list A -> A) (fun l => match l with nil => def | cons t l => t end) (fun _ F l => match l with nil => def | cons t l => F l end) p l. Fixpoint eval var (p : poly) := match p with | Cst c => c | Poly p i q => let vi := list_nth i var false in xorb (eval var p) (andb vi (eval var q)) end. Fixpoint valid_dec k p := match p with | Cst c => true | Poly p i q => negb (decide (null q)) && decide (i < k)%positive && valid_dec i p && valid_dec (Pos.succ i) q end. Program Instance Decidable_valid : forall n p, Decidable (valid n p) := { Decidable_witness := valid_dec n p }. Next Obligation. split. revert n; induction p; unfold valid_dec in *; intuition; bool; try_decide; auto. intros H; induction H; unfold valid_dec in *; bool; try_decide; auto. Qed. (** Basic algebra *) (* Addition of polynomials *) Fixpoint poly_add pl {struct pl} := match pl with | Cst cl => fix F pr := match pr with | Cst cr => Cst (xorb cl cr) | Poly pr ir qr => Poly (F pr) ir qr end | Poly pl il ql => fix F pr {struct pr} := match pr with | Cst cr => Poly (poly_add pl pr) il ql | Poly pr ir qr => match Pos.compare il ir with | Eq => let qs := poly_add ql qr in (* Ensure validity *) if decide (null qs) then poly_add pl pr else Poly (poly_add pl pr) il qs | Gt => Poly (poly_add pl (Poly pr ir qr)) il ql | Lt => Poly (F pr) ir qr end end end. (* Multiply a polynomial by a constant *) Fixpoint poly_mul_cst v p := match p with | Cst c => Cst (andb c v) | Poly p i q => let r := poly_mul_cst v q in (* Ensure validity *) if decide (null r) then poly_mul_cst v p else Poly (poly_mul_cst v p) i r end. (* Multiply a polynomial by a monomial *) Fixpoint poly_mul_mon k p := match p with | Cst c => if decide (null p) then p else Poly (Cst false) k p | Poly p i q => if decide (i <= k)%positive then Poly (Cst false) k (Poly p i q) else Poly (poly_mul_mon k p) i (poly_mul_mon k q) end. (* Multiplication of polynomials *) Fixpoint poly_mul pl {struct pl} := match pl with | Cst cl => poly_mul_cst cl | Poly pl il ql => fun pr => (* Multiply by a factor *) let qs := poly_mul ql pr in (* Ensure validity *) if decide (null qs) then poly_mul pl pr else poly_add (poly_mul pl pr) (poly_mul_mon il qs) end. (** Quotienting a polynomial by the relation X_i^2 ~ X_i *) (* Remove the multiple occurrences of monomials x_k *) Fixpoint reduce_aux k p := match p with | Cst c => Cst c | Poly p i q => if decide (i = k) then poly_add (reduce_aux k p) (reduce_aux k q) else let qs := reduce_aux i q in (* Ensure validity *) if decide (null qs) then (reduce_aux k p) else Poly (reduce_aux k p) i qs end. (* Rewrite any x_k ^ {n + 1} to x_k *) Fixpoint reduce p := match p with | Cst c => Cst c | Poly p i q => let qs := reduce_aux i q in (* Ensure validity *) if decide (null qs) then reduce p else Poly (reduce p) i qs end. End Computational. Section Validity. (* Decision procedure of validity *) Hint Constructors valid linear. Lemma valid_le_compat : forall k l p, valid k p -> (k <= l)%positive -> valid l p. Proof. intros k l p H Hl; induction H; constructor; eauto. now eapply Pos.lt_le_trans; eassumption. Qed. Lemma linear_le_compat : forall k l p, linear k p -> (k <= l)%positive -> linear l p. Proof. intros k l p H; revert l; induction H; constructor; eauto; zify; romega. Qed. Lemma linear_valid_incl : forall k p, linear k p -> valid k p. Proof. intros k p H; induction H; constructor; auto. eapply valid_le_compat; eauto; zify; romega. Qed. End Validity. Section Evaluation. (* Useful simple properties *) Lemma eval_null_zero : forall p var, null p -> eval var p = false. Proof. intros p var []; reflexivity. Qed. Lemma eval_extensional_eq_compat : forall p var1 var2, (forall x, list_nth x var1 false = list_nth x var2 false) -> eval var1 p = eval var2 p. Proof. intros p var1 var2 H; induction p; simpl; try_rewrite; auto. Qed. Lemma eval_suffix_compat : forall k p var1 var2, (forall i, (i < k)%positive -> list_nth i var1 false = list_nth i var2 false) -> valid k p -> eval var1 p = eval var2 p. Proof. intros k p var1 var2 Hvar Hv; revert var1 var2 Hvar. induction Hv; intros var1 var2 Hvar; simpl; [now auto|]. rewrite Hvar; [|now auto]; erewrite (IHHv1 var1 var2). + erewrite (IHHv2 var1 var2); [ring|]. intros; apply Hvar; zify; omega. + intros; apply Hvar; zify; omega. Qed. End Evaluation. Section Algebra. (* Compatibility with evaluation *) Lemma poly_add_compat : forall pl pr var, eval var (poly_add pl pr) = xorb (eval var pl) (eval var pr). Proof. intros pl; induction pl; intros pr var; simpl. + induction pr; simpl; auto; solve [try_rewrite; ring]. + induction pr; simpl; auto; try solve [try_rewrite; simpl; ring]. destruct (Pos.compare_spec p p0); repeat case_decide; simpl; first [try_rewrite; ring|idtac]. try_rewrite; ring_simplify; repeat rewrite xorb_assoc. match goal with [ |- context [xorb (andb ?b1 ?b2) (andb ?b1 ?b3)] ] => replace (xorb (andb b1 b2) (andb b1 b3)) with (andb b1 (xorb b2 b3)) by ring end. rewrite <- IHpl2. match goal with [ H : null ?p |- _ ] => rewrite (eval_null_zero _ _ H) end; ring. simpl; rewrite IHpl1; simpl; ring. Qed. Lemma poly_mul_cst_compat : forall v p var, eval var (poly_mul_cst v p) = andb v (eval var p). Proof. intros v p; induction p; intros var; simpl; [ring|]. case_decide; simpl; try_rewrite; [ring_simplify|ring]. replace (v && list_nth p2 var false && eval var p3) with (list_nth p2 var false && (v && eval var p3)) by ring. rewrite <- IHp2; inversion H; simpl; ring. Qed. Lemma poly_mul_mon_compat : forall i p var, eval var (poly_mul_mon i p) = (list_nth i var false && eval var p). Proof. intros i p var; induction p; simpl; case_decide; simpl; try_rewrite; try ring. inversion H; ring. match goal with [ |- ?u = ?t ] => set (x := t); destruct x; reflexivity end. match goal with [ |- ?u = ?t ] => set (x := t); destruct x; reflexivity end. Qed. Lemma poly_mul_compat : forall pl pr var, eval var (poly_mul pl pr) = andb (eval var pl) (eval var pr). Proof. intros pl; induction pl; intros pr var; simpl. apply poly_mul_cst_compat. case_decide; simpl. rewrite IHpl1; ring_simplify. replace (eval var pr && list_nth p var false && eval var pl2) with (list_nth p var false && (eval var pl2 && eval var pr)) by ring. now rewrite <- IHpl2; inversion H; simpl; ring. rewrite poly_add_compat, poly_mul_mon_compat, IHpl1, IHpl2; ring. Qed. Hint Extern 5 => match goal with | [ |- (Pos.max ?x ?y <= ?z)%positive ] => apply Pos.max_case_strong; intros; zify; romega | [ |- (?z <= Pos.max ?x ?y)%positive ] => apply Pos.max_case_strong; intros; zify; romega | [ |- (Pos.max ?x ?y < ?z)%positive ] => apply Pos.max_case_strong; intros; zify; romega | [ |- (?z < Pos.max ?x ?y)%positive ] => apply Pos.max_case_strong; intros; zify; romega | _ => zify; omega end. Hint Resolve Pos.le_max_r Pos.le_max_l. Hint Constructors valid linear. (* Compatibility of validity w.r.t algebraic operations *) Lemma poly_add_valid_compat : forall kl kr pl pr, valid kl pl -> valid kr pr -> valid (Pos.max kl kr) (poly_add pl pr). Proof. intros kl kr pl pr Hl Hr; revert kr pr Hr; induction Hl; intros kr pr Hr; simpl. { eapply valid_le_compat; [clear k|apply Pos.le_max_r]. now induction Hr; auto. } { assert (Hle : (Pos.max (Pos.succ i) kr <= Pos.max k kr)%positive) by auto. apply (valid_le_compat (Pos.max (Pos.succ i) kr)); [|assumption]. clear - IHHl1 IHHl2 Hl2 Hr H0; induction Hr. constructor; auto. now rewrite <- (Pos.max_id i); intuition. destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition). + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; zify; romega. + apply (valid_le_compat (Pos.max (Pos.succ i0) (Pos.succ i0))); [now auto|]; rewrite Pos.max_id; zify; romega. + apply (valid_le_compat (Pos.max (Pos.succ i) i0)); intuition. + apply (valid_le_compat (Pos.max i (Pos.succ i0))); intuition. } Qed. Lemma poly_mul_cst_valid_compat : forall k v p, valid k p -> valid k (poly_mul_cst v p). Proof. intros k v p H; induction H; simpl; [now auto|]. case_decide; [|now auto]. eapply (valid_le_compat i); [now auto|zify; romega]. Qed. Lemma poly_mul_mon_null_compat : forall i p, null (poly_mul_mon i p) -> null p. Proof. intros i p; induction p; simpl; case_decide; simpl; inversion 1; intuition. Qed. Lemma poly_mul_mon_valid_compat : forall k i p, valid k p -> valid (Pos.max (Pos.succ i) k) (poly_mul_mon i p). Proof. intros k i p H; induction H; simpl poly_mul_mon; case_decide; intuition. + apply (valid_le_compat (Pos.succ i)); auto; constructor; intuition. - match goal with [ H : null ?p |- _ ] => solve[inversion H] end. + apply (valid_le_compat k); auto; constructor; intuition. - assert (X := poly_mul_mon_null_compat); intuition eauto. - cutrewrite <- (Pos.max (Pos.succ i) i0 = i0); intuition. - cutrewrite <- (Pos.max (Pos.succ i) (Pos.succ i0) = Pos.succ i0); intuition. Qed. Lemma poly_mul_valid_compat : forall kl kr pl pr, valid kl pl -> valid kr pr -> valid (Pos.max kl kr) (poly_mul pl pr). Proof. intros kl kr pl pr Hl Hr; revert kr pr Hr. induction Hl; intros kr pr Hr; simpl. + apply poly_mul_cst_valid_compat; auto. apply (valid_le_compat kr); now auto. + apply (valid_le_compat (Pos.max (Pos.max i kr) (Pos.max (Pos.succ i) (Pos.max (Pos.succ i) kr)))). - case_decide. { apply (valid_le_compat (Pos.max i kr)); auto. } { apply poly_add_valid_compat; auto. now apply poly_mul_mon_valid_compat; intuition. } - repeat apply Pos.max_case_strong; zify; omega. Qed. (* Compatibility of linearity wrt to linear operations *) Lemma poly_add_linear_compat : forall kl kr pl pr, linear kl pl -> linear kr pr -> linear (Pos.max kl kr) (poly_add pl pr). Proof. intros kl kr pl pr Hl; revert kr pr; induction Hl; intros kr pr Hr; simpl. + apply (linear_le_compat kr); [|apply Pos.max_case_strong; zify; omega]. now induction Hr; constructor; auto. + apply (linear_le_compat (Pos.max kr (Pos.succ i))); [|now auto]. induction Hr; simpl. - constructor; auto. replace i with (Pos.max i i) by (apply Pos.max_id); intuition. - destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition). { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. } { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. } { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. } { apply (linear_le_compat (Pos.max i0 (Pos.succ i))); intuition. } { apply (linear_le_compat (Pos.max i (Pos.succ i0))); intuition. } Qed. End Algebra. Section Reduce. (* A stronger version of the next lemma *) Lemma reduce_aux_eval_compat : forall k p var, valid (Pos.succ k) p -> (list_nth k var false && eval var (reduce_aux k p) = list_nth k var false && eval var p). Proof. intros k p var; revert k; induction p; intros k Hv; simpl; auto. inversion Hv; case_decide; subst. + rewrite poly_add_compat; ring_simplify. specialize (IHp1 k); specialize (IHp2 k). destruct (list_nth k var false); ring_simplify; [|now auto]. rewrite <- (andb_true_l (eval var p1)), <- (andb_true_l (eval var p3)). rewrite <- IHp2; auto; rewrite <- IHp1; [ring|]. apply (valid_le_compat k); [now auto|zify; omega]. + remember (list_nth k var false) as b; destruct b; ring_simplify; [|now auto]. case_decide; simpl. - rewrite <- (IHp2 p2); [inversion H|now auto]; simpl. replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring); rewrite <- (IHp1 k). { rewrite <- Heqb; ring. } { apply (valid_le_compat p2); [auto|zify; omega]. } - rewrite (IHp2 p2); [|now auto]. replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring). rewrite <- (IHp1 k); [rewrite <- Heqb; ring|]. apply (valid_le_compat p2); [auto|zify; omega]. Qed. (* Reduction preserves evaluation by boolean assignations *) Lemma reduce_eval_compat : forall k p var, valid k p -> eval var (reduce p) = eval var p. Proof. intros k p var H; induction H; simpl; auto. case_decide; try_rewrite; simpl. + rewrite <- reduce_aux_eval_compat; auto; inversion H3; simpl; ring. + repeat rewrite reduce_aux_eval_compat; try_rewrite; now auto. Qed. Lemma reduce_aux_le_compat : forall k l p, valid k p -> (k <= l)%positive -> reduce_aux l p = reduce_aux k p. Proof. intros k l p; revert k l; induction p; intros k l H Hle; simpl; auto. inversion H; subst; repeat case_decide; subst; try (exfalso; zify; omega). + apply IHp1; [|now auto]; eapply valid_le_compat; [eauto|zify; omega]. + f_equal; apply IHp1; auto. now eapply valid_le_compat; [eauto|zify; omega]. Qed. (* Reduce projects valid polynomials into linear ones *) Lemma linear_reduce_aux : forall i p, valid (Pos.succ i) p -> linear i (reduce_aux i p). Proof. intros i p; revert i; induction p; intros i Hp; simpl. + constructor. + inversion Hp; subst; case_decide; subst. - rewrite <- (Pos.max_id i) at 1; apply poly_add_linear_compat. { apply IHp1; eapply valid_le_compat; [eassumption|zify; omega]. } { intuition. } - case_decide. { apply IHp1; eapply valid_le_compat; [eauto|zify; omega]. } { constructor; try (zify; omega); auto. erewrite (reduce_aux_le_compat p2); [|assumption|zify; omega]. apply IHp1; eapply valid_le_compat; [eauto|]; zify; omega. } Qed. Lemma linear_reduce : forall k p, valid k p -> linear k (reduce p). Proof. intros k p H; induction H; simpl. + now constructor. + case_decide. - eapply linear_le_compat; [eauto|zify; omega]. - constructor; auto. apply linear_reduce_aux; auto. Qed. End Reduce. coq-8.6/plugins/btauto/refl_btauto.ml0000644000175000017500000002016513022274260017302 0ustar mdenesmdenesopen Proofview.Notations let contrib_name = "btauto" let init_constant dir s = let find_constant contrib dir s = Universes.constr_of_global (Coqlib.find_reference contrib dir s) in find_constant contrib_name dir s let get_constant dir s = lazy (Coqlib.gen_constant contrib_name dir s) let get_inductive dir s = let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in Lazy.from_fun (fun () -> Globnames.destIndRef (glob_ref ())) let decomp_term (c : Term.constr) = Term.kind_of_term (Term.strip_outer_cast c) let lapp c v = Term.mkApp (Lazy.force c, v) let (===) = Term.eq_constr module CoqList = struct let path = ["Init"; "Datatypes"] let typ = get_constant path "list" let _nil = get_constant path "nil" let _cons = get_constant path "cons" let cons ty h t = lapp _cons [|ty; h ; t|] let nil ty = lapp _nil [|ty|] let rec of_list ty = function | [] -> nil ty | t::q -> cons ty t (of_list ty q) let type_of_list ty = lapp typ [|ty|] end module CoqPositive = struct let path = ["Numbers"; "BinNums"] let typ = get_constant path "positive" let _xH = get_constant path "xH" let _xO = get_constant path "xO" let _xI = get_constant path "xI" (* A coq nat from an int *) let rec of_int n = if n <= 1 then Lazy.force _xH else let ans = of_int (n / 2) in if n mod 2 = 0 then lapp _xO [|ans|] else lapp _xI [|ans|] end module Env = struct module ConstrHashed = struct type t = Term.constr let equal = Term.eq_constr let hash = Term.hash_constr end module ConstrHashtbl = Hashtbl.Make (ConstrHashed) type t = (int ConstrHashtbl.t * int ref) let add (tbl, off) (t : Term.constr) = try ConstrHashtbl.find tbl t with | Not_found -> let i = !off in let () = ConstrHashtbl.add tbl t i in let () = incr off in i let empty () = (ConstrHashtbl.create 16, ref 1) let to_list (env, _) = (* we need to get an ordered list *) let fold constr key accu = (key, constr) :: accu in let l = ConstrHashtbl.fold fold env [] in let sorted_l = List.sort (fun p1 p2 -> Int.compare (fst p1) (fst p2)) l in List.map snd sorted_l end module Bool = struct let typ = get_constant ["Init"; "Datatypes"] "bool" let ind = get_inductive ["Init"; "Datatypes"] "bool" let trueb = get_constant ["Init"; "Datatypes"] "true" let falseb = get_constant ["Init"; "Datatypes"] "false" let andb = get_constant ["Init"; "Datatypes"] "andb" let orb = get_constant ["Init"; "Datatypes"] "orb" let xorb = get_constant ["Init"; "Datatypes"] "xorb" let negb = get_constant ["Init"; "Datatypes"] "negb" type t = | Var of int | Const of bool | Andb of t * t | Orb of t * t | Xorb of t * t | Negb of t | Ifb of t * t * t let quote (env : Env.t) (c : Term.constr) : t = let trueb = Lazy.force trueb in let falseb = Lazy.force falseb in let andb = Lazy.force andb in let orb = Lazy.force orb in let xorb = Lazy.force xorb in let negb = Lazy.force negb in let rec aux c = match decomp_term c with | Term.App (head, args) -> if head === andb && Array.length args = 2 then Andb (aux args.(0), aux args.(1)) else if head === orb && Array.length args = 2 then Orb (aux args.(0), aux args.(1)) else if head === xorb && Array.length args = 2 then Xorb (aux args.(0), aux args.(1)) else if head === negb && Array.length args = 1 then Negb (aux args.(0)) else Var (Env.add env c) | Term.Case (info, r, arg, pats) -> let is_bool = let i = info.Term.ci_ind in Names.eq_ind i (Lazy.force ind) in if is_bool then Ifb ((aux arg), (aux pats.(0)), (aux pats.(1))) else Var (Env.add env c) | _ -> if c === falseb then Const false else if c === trueb then Const true else Var (Env.add env c) in aux c end module Btauto = struct open Pp let eq = get_constant ["Init"; "Logic"] "eq" let f_var = get_constant ["btauto"; "Reflect"] "formula_var" let f_btm = get_constant ["btauto"; "Reflect"] "formula_btm" let f_top = get_constant ["btauto"; "Reflect"] "formula_top" let f_cnj = get_constant ["btauto"; "Reflect"] "formula_cnj" let f_dsj = get_constant ["btauto"; "Reflect"] "formula_dsj" let f_neg = get_constant ["btauto"; "Reflect"] "formula_neg" let f_xor = get_constant ["btauto"; "Reflect"] "formula_xor" let f_ifb = get_constant ["btauto"; "Reflect"] "formula_ifb" let eval = get_constant ["btauto"; "Reflect"] "formula_eval" let witness = get_constant ["btauto"; "Reflect"] "boolean_witness" let soundness = get_constant ["btauto"; "Reflect"] "reduce_poly_of_formula_sound_alt" let rec convert = function | Bool.Var n -> lapp f_var [|CoqPositive.of_int n|] | Bool.Const true -> Lazy.force f_top | Bool.Const false -> Lazy.force f_btm | Bool.Andb (b1, b2) -> lapp f_cnj [|convert b1; convert b2|] | Bool.Orb (b1, b2) -> lapp f_dsj [|convert b1; convert b2|] | Bool.Negb b -> lapp f_neg [|convert b|] | Bool.Xorb (b1, b2) -> lapp f_xor [|convert b1; convert b2|] | Bool.Ifb (b1, b2, b3) -> lapp f_ifb [|convert b1; convert b2; convert b3|] let convert_env env : Term.constr = CoqList.of_list (Lazy.force Bool.typ) env let reify env t = lapp eval [|convert_env env; convert t|] let print_counterexample p env gl = let var = lapp witness [|p|] in (* Compute an assignment that dissatisfies the goal *) let _, var = Tacmach.pf_reduction_of_red_expr gl (Genredexpr.CbvVm None) var in let rec to_list l = match decomp_term l with | Term.App (c, _) when c === (Lazy.force CoqList._nil) -> [] | Term.App (c, [|_; h; t|]) when c === (Lazy.force CoqList._cons) -> if h === (Lazy.force Bool.trueb) then (true :: to_list t) else if h === (Lazy.force Bool.falseb) then (false :: to_list t) else invalid_arg "to_list" | _ -> invalid_arg "to_list" in let concat sep = function | [] -> mt () | h :: t -> let rec aux = function | [] -> mt () | x :: t -> (sep ++ x ++ aux t) in h ++ aux t in let msg = try let var = to_list var in let assign = List.combine env var in let map_msg (key, v) = let b = if v then str "true" else str "false" in let term = Printer.pr_constr key in term ++ spc () ++ str ":=" ++ spc () ++ b in let assign = List.map map_msg assign in let l = str "[" ++ (concat (str ";" ++ spc ()) assign) ++ str "]" in str "Not a tautology:" ++ spc () ++ l with e when CErrors.noncritical e -> (str "Not a tautology") in Tacticals.tclFAIL 0 msg gl let try_unification env = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let eq = Lazy.force eq in let t = decomp_term concl in match t with | Term.App (c, [|typ; p; _|]) when c === eq -> (* should be an equality [@eq poly ?p (Cst false)] *) let tac = Tacticals.New.tclORELSE0 Tactics.reflexivity (Proofview.V82.tactic (print_counterexample p env)) in tac | _ -> let msg = str "Btauto: Internal error" in Tacticals.New.tclFAIL 0 msg end } let tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let eq = Lazy.force eq in let bool = Lazy.force Bool.typ in let t = decomp_term concl in match t with | Term.App (c, [|typ; tl; tr|]) when typ === bool && c === eq -> let env = Env.empty () in let fl = Bool.quote env tl in let fr = Bool.quote env tr in let env = Env.to_list env in let fl = reify env fl in let fr = reify env fr in let changed_gl = Term.mkApp (c, [|typ; fl; fr|]) in Tacticals.New.tclTHENLIST [ Tactics.change_concl changed_gl; Tactics.apply (Lazy.force soundness); Tactics.normalise_vm_in_concl; try_unification env ] | _ -> let msg = str "Cannot recognize a boolean equality" in Tacticals.New.tclFAIL 0 msg end } end coq-8.6/plugins/btauto/vo.itarget0000644000175000017500000000004013022274260016435 0ustar mdenesmdenesAlgebra.vo Reflect.vo Btauto.vo coq-8.6/plugins/micromega/0000755000175000017500000000000013022274260015103 5ustar mdenesmdenescoq-8.6/plugins/micromega/csdpcert.ml0000644000175000017500000001525313022274260017252 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Const (C2Ml.q_to_num z) | PEX v -> Var ("x"^(string_of_int (C2Ml.index v))) | PEmul(p1,p2) -> let p1 = expr_to_term p1 in let p2 = expr_to_term p2 in let res = Mul(p1,p2) in res | PEadd(p1,p2) -> Add(expr_to_term p1, expr_to_term p2) | PEsub(p1,p2) -> Sub(expr_to_term p1, expr_to_term p2) | PEpow(p,n) -> Pow(expr_to_term p , C2Ml.n n) | PEopp p -> Opp (expr_to_term p) end open M open Mutils let canonical_sum_to_string = function s -> failwith "not implemented" let print_canonical_sum m = Format.print_string (canonical_sum_to_string m) let print_list_term o l = output_string o "print_list_term\n"; List.iter (fun (e,k) -> Printf.fprintf o "q: %s %s ;" (string_of_poly (poly_of_term (expr_to_term e))) (match k with Mc.Equal -> "= " | Mc.Strict -> "> " | Mc.NonStrict -> ">= " | _ -> failwith "not_implemented")) (List.map (fun (e, o) -> Mc.denorm e , o) l) ; output_string o "\n" let partition_expr l = let rec f i = function | [] -> ([],[],[]) | (e,k)::l -> let (eq,ge,neq) = f (i+1) l in match k with | Mc.Equal -> ((e,i)::eq,ge,neq) | Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq) | Mc.Strict -> (* e > 0 == e >= 0 /\ e <> 0 *) (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq) | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq) (* Not quite sure -- Coq interface has changed *) in f 0 l let rec sets_of_list l = match l with | [] -> [[]] | e::l -> let s = sets_of_list l in s@(List.map (fun s0 -> e::s0) s) (* The exploration is probably not complete - for simple cases, it works... *) let real_nonlinear_prover d l = let l = List.map (fun (e,op) -> (Mc.denorm e,op)) l in try let (eq,ge,neq) = partition_expr l in let rec elim_const = function [] -> [] | (x,y)::l -> let p = poly_of_term (expr_to_term x) in if poly_isconst p then elim_const l else (p,y)::(elim_const l) in let eq = elim_const eq in let peq = List.map fst eq in let pge = List.map (fun (e,psatz) -> poly_of_term (expr_to_term e),psatz) ge in let monoids = List.map (fun m -> (List.fold_right (fun (p,kd) y -> let p = poly_of_term (expr_to_term p) in match kd with | Axiom_lt i -> poly_mul p y | Axiom_eq i -> poly_mul (poly_pow p 2) y | _ -> failwith "monoids") m (poly_const (Int 1)) , List.map snd m)) (sets_of_list neq) in let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> list_try_find (fun m -> let (ci,cc) = real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in (ci,cc,snd m)) monoids) 0 in let proofs_ideal = List.map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i)) cert_ideal (List.map snd eq) in let proofs_cone = List.map term_of_sos cert_cone in let proof_ne = let (neq , lt) = List.partition (function Axiom_eq _ -> true | _ -> false ) monoid in let sq = match (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq) with | [] -> Rational_lt (Int 1) | l -> Monoid l in List.fold_right (fun x y -> Product(x,y)) lt sq in let proof = list_fold_right_elements (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in S (Some proof) with | Sos_lib.TooDeep -> S None | any -> F (Printexc.to_string any) (* This is somewhat buggy, over Z, strict inequality vanish... *) let pure_sos l = let l = List.map (fun (e,o) -> Mc.denorm e, o) l in (* If there is no strict inequality, I should nonetheless be able to try something - over Z > is equivalent to -1 >= *) try let l = List.combine l (interval 0 (List.length l -1)) in let (lt,i) = try (List.find (fun (x,_) -> Pervasives.(=) (snd x) Mc.Strict) l) with Not_found -> List.hd l in let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *) let pos = Product (Rational_lt n, List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square (term_of_poly p)), rst)) polys (Rational_lt (Int 0))) in let proof = Sum(Axiom_lt i, pos) in (* let s,proof' = scale_certificate proof in let cert = snd (cert_of_pos proof') in *) S (Some proof) with (* | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *) | any -> (* May be that could be refined *) S None let run_prover prover pb = match prover with | "real_nonlinear_prover", Some d -> real_nonlinear_prover d pb | "pure_sos", None -> pure_sos pb | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) let output_csdp_certificate o = function | S None -> output_string o "S None" | S (Some p) -> Printf.fprintf o "S (Some %a)" output_psatz p | F s -> Printf.fprintf o "F %s" s let main () = try let (prover,poly) = (input_value stdin : provername * micromega_polys) in let cert = run_prover prover poly in (* Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ; close_out chan ; *) output_value stdout (cert:csdp_certificate); flush stdout ; Marshal.to_channel chan (cert:csdp_certificate) [] ; flush chan ; exit 0 with any -> (Printf.fprintf chan "error %s" (Printexc.to_string any) ; exit 1) ;; let _ = main () in () (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/micromega/mutils.ml0000644000175000017500000002574013022274260016762 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* () | e::l -> f o e ; output_string o ";" ; pp_list f o l let finally f rst = try let res = f () in rst () ; res with reraise -> (try rst () with any -> raise reraise ); raise reraise let map_option f x = match x with | None -> None | Some v -> Some (f v) let from_option = function | None -> failwith "from_option" | Some v -> v let rec try_any l x = match l with | [] -> None | (f,s)::l -> match f x with | None -> try_any l x | x -> x let iteri f l = let rec xiter i l = match l with | [] -> () | e::l -> f i e ; xiter (i+1) l in xiter 0 l let all_sym_pairs f l = let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in let rec xpairs acc l = match l with | [] -> acc | e::l -> xpairs (pair_with acc e l) l in xpairs [] l let all_pairs f l = let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in let rec xpairs acc l = match l with | [] -> acc | e::lx -> xpairs (pair_with acc e l) lx in xpairs [] l let rec map3 f l1 l2 l3 = match l1 , l2 ,l3 with | [] , [] , [] -> [] | e1::l1 , e2::l2 , e3::l3 -> (f e1 e2 e3)::(map3 f l1 l2 l3) | _ -> invalid_arg "map3" let rec is_sublist f l1 l2 = match l1 ,l2 with | [] ,_ -> true | e::l1', [] -> false | e::l1' , e'::l2' -> if f e e' then is_sublist f l1' l2' else is_sublist f l1 l2' let list_try_find f = let rec try_find_f = function | [] -> failwith "try_find" | h::t -> try f h with Failure _ -> try_find_f t in try_find_f let list_fold_right_elements f l = let rec aux = function | [] -> invalid_arg "list_fold_right_elements" | [x] -> x | x::l -> f x (aux l) in aux l let interval n m = let rec interval_n (l,m) = if n > m then l else interval_n (m::l,pred m) in interval_n ([],m) let extract pred l = List.fold_left (fun (fd,sys) e -> match fd with | None -> begin match pred e with | None -> fd, e::sys | Some v -> Some(v,e) , sys end | _ -> (fd, e::sys) ) (None,[]) l open Num open Big_int let ppcm x y = let g = gcd_big_int x y in let x' = div_big_int x g in let y' = div_big_int y g in mult_big_int g (mult_big_int x' y') let denominator = function | Int _ | Big_int _ -> unit_big_int | Ratio r -> Ratio.denominator_ratio r let numerator = function | Ratio r -> Ratio.numerator_ratio r | Int i -> Big_int.big_int_of_int i | Big_int i -> i let rec ppcm_list c l = match l with | [] -> c | e::l -> ppcm_list (ppcm c (denominator e)) l let rec rec_gcd_list c l = match l with | [] -> c | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l let gcd_list l = let res = rec_gcd_list zero_big_int l in if Int.equal (compare_big_int res zero_big_int) 0 then unit_big_int else res let rats_to_ints l = let c = ppcm_list unit_big_int l in List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) (denominator x))) l (* Nasty reordering of lists - useful to trim certificate down *) let mapi f l = let rec xmapi i l = match l with | [] -> [] | e::l -> (f e i)::(xmapi (i+1) l) in xmapi 0 l let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l) (* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l)) let assoc_pos_assoc l = let rec xpos i l = match l with | [] -> [] | (x,l) ::rst -> let (l',j) = assoc_pos i l in (x,l')::(xpos j rst) in xpos 0 l let filter_pos f l = (* Could sort ... take care of duplicates... *) let rec xfilter l = match l with | [] -> [] | (x,e)::l -> if List.exists (fun ee -> List.mem ee f) (List.map snd e) then (x,e)::(xfilter l) else xfilter l in xfilter l let select_pos lpos l = let rec xselect i lpos l = match lpos with | [] -> [] | j::rpos -> match l with | [] -> failwith "select_pos" | e::l -> if Int.equal i j then e:: (xselect (i+1) rpos l) else xselect (i+1) lpos l in xselect 0 lpos l (** * MODULE: Coq to Caml data-structure mappings *) module CoqToCaml = struct open Micromega let rec nat = function | O -> 0 | S n -> (nat n) + 1 let rec positive p = match p with | XH -> 1 | XI p -> 1+ 2*(positive p) | XO p -> 2*(positive p) let n nt = match nt with | N0 -> 0 | Npos p -> positive p let rec index i = (* Swap left-right ? *) match i with | XH -> 1 | XI i -> 1+(2*(index i)) | XO i -> 2*(index i) let z x = match x with | Z0 -> 0 | Zpos p -> (positive p) | Zneg p -> - (positive p) open Big_int let rec positive_big_int p = match p with | XH -> unit_big_int | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p)) | XO p -> (mult_int_big_int 2 (positive_big_int p)) let z_big_int x = match x with | Z0 -> zero_big_int | Zpos p -> (positive_big_int p) | Zneg p -> minus_big_int (positive_big_int p) let num x = Num.Big_int (z_big_int x) let q_to_num {qnum = x ; qden = y} = Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) end (** * MODULE: Caml to Coq data-structure mappings *) module CamlToCoq = struct open Micromega let rec nat = function | 0 -> O | n -> S (nat (n-1)) let rec positive n = if Int.equal n 1 then XH else if Int.equal (n land 1) 1 then XI (positive (n lsr 1)) else XO (positive (n lsr 1)) let n nt = if nt < 0 then assert false else if Int.equal nt 0 then N0 else Npos (positive nt) let rec index n = if Int.equal n 1 then XH else if Int.equal (n land 1) 1 then XI (index (n lsr 1)) else XO (index (n lsr 1)) let z x = match compare x 0 with | 0 -> Z0 | 1 -> Zpos (positive x) | _ -> (* this should be -1 *) Zneg (positive (-x)) open Big_int let positive_big_int n = let two = big_int_of_int 2 in let rec _pos n = if eq_big_int n unit_big_int then XH else let (q,m) = quomod_big_int n two in if eq_big_int unit_big_int m then XI (_pos q) else XO (_pos q) in _pos n let bigint x = match sign_big_int x with | 0 -> Z0 | 1 -> Zpos (positive_big_int x) | _ -> Zneg (positive_big_int (minus_big_int x)) let q n = {Micromega.qnum = bigint (numerator n) ; Micromega.qden = positive_big_int (denominator n)} end (** * MODULE: Comparisons on lists: by evaluating the elements in a single list, * between two lists given an ordering, and using a hash computation *) module Cmp = struct let rec compare_lexical l = match l with | [] -> 0 (* Equal *) | f::l -> let cmp = f () in if Int.equal cmp 0 then compare_lexical l else cmp let rec compare_list cmp l1 l2 = match l1 , l2 with | [] , [] -> 0 | [] , _ -> -1 | _ , [] -> 1 | e1::l1 , e2::l2 -> let c = cmp e1 e2 in if Int.equal c 0 then compare_list cmp l1 l2 else c (** * hash_list takes a hash function and a list, and computes an integer which * is the hash value of the list. *) let hash_list hash l = let rec _hash_list l h = match l with | [] -> h lxor (Hashtbl.hash []) | e::l -> _hash_list l ((hash e) lxor h) in _hash_list l 0 end (** * MODULE: Labels for atoms in propositional formulas. * Tags are used to identify unused atoms in CNFs, and propagate them back to * the original formula. The translation back to Coq then ignores these * superfluous items, which speeds the translation up a bit. *) module type Tag = sig type t val from : int -> t val next : t -> t val pp : out_channel -> t -> unit val compare : t -> t -> int end module Tag : Tag = struct type t = int let from i = i let next i = i + 1 let pp o i = output_string o (string_of_int i) let compare : int -> int -> int = Int.compare end (** * MODULE: Ordered sets of tags. *) module TagSet = Set.Make(Tag) (** As for Unix.close_process, our Unix.waipid will ignore all EINTR *) let rec waitpid_non_intr pid = try snd (Unix.waitpid [] pid) with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid (** * Forking routine, plumbing the appropriate pipes where needed. *) let command exe_path args vl = (* creating pipes for stdin, stdout, stderr *) let (stdin_read,stdin_write) = Unix.pipe () and (stdout_read,stdout_write) = Unix.pipe () and (stderr_read,stderr_write) = Unix.pipe () in (* Create the process *) let pid = Unix.create_process exe_path args stdin_read stdout_write stderr_write in (* Write the data on the stdin of the created process *) let outch = Unix.out_channel_of_descr stdin_write in output_value outch vl ; flush outch ; (* Wait for its completion *) let status = waitpid_non_intr pid in finally (* Recover the result *) (fun () -> match status with | Unix.WEXITED 0 -> let inch = Unix.in_channel_of_descr stdout_read in begin try Marshal.from_channel inch with any -> failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string any)) end | Unix.WEXITED i -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) | Unix.WSTOPPED i -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) (* Cleanup *) (fun () -> List.iter (fun x -> try Unix.close x with any -> ()) [stdin_read; stdin_write; stdout_read; stdout_write; stderr_read; stderr_write]) (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/micromega/Refl.v0000644000175000017500000000673413022274260016174 0ustar mdenesmdenes(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ' '/\': basic properties *) Fixpoint make_impl (A : Type) (eval : A -> Prop) (l : list A) (goal : Prop) {struct l} : Prop := match l with | nil => goal | cons e l => (eval e) -> (make_impl eval l goal) end. Theorem make_impl_true : forall (A : Type) (eval : A -> Prop) (l : list A), make_impl eval l True. Proof. induction l as [| a l IH]; simpl. trivial. intro; apply IH. Qed. Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop := match l with | nil => True | cons e nil => (eval e) | cons e l2 => ((eval e) /\ (make_conj eval l2)) end. Theorem make_conj_cons : forall (A : Type) (eval : A -> Prop) (a : A) (l : list A), make_conj eval (a :: l) <-> eval a /\ make_conj eval l. Proof. intros; destruct l; simpl; tauto. Qed. Lemma make_conj_impl : forall (A : Type) (eval : A -> Prop) (l : list A) (g : Prop), (make_conj eval l -> g) <-> make_impl eval l g. Proof. induction l. simpl. tauto. simpl. intros. destruct l. simpl. tauto. generalize (IHl g). tauto. Qed. Lemma make_conj_in : forall (A : Type) (eval : A -> Prop) (l : list A), make_conj eval l -> (forall p, In p l -> eval p). Proof. induction l. simpl. tauto. simpl. intros. destruct l. simpl in H0. destruct H0. subst; auto. tauto. destruct H. destruct H0. subst;auto. apply IHl; auto. Qed. Lemma make_conj_app : forall A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2. Proof. induction l1. simpl. tauto. intros. change ((a::l1) ++ l2) with (a :: (l1 ++ l2)). rewrite make_conj_cons. rewrite IHl1. rewrite make_conj_cons. tauto. Qed. Lemma not_make_conj_cons : forall (A:Type) (t:A) a eval (no_middle_eval : (eval t) \/ ~ (eval t)), ~ make_conj eval (t ::a) -> ~ (eval t) \/ (~ make_conj eval a). Proof. intros. simpl in H. destruct a. tauto. tauto. Qed. Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval (no_middle_eval : forall d, eval d \/ ~ eval d) , ~ make_conj eval (t ++ a) -> (~ make_conj eval t) \/ (~ make_conj eval a). Proof. induction t. simpl. tauto. intros. simpl ((a::t)++a0)in H. destruct (@not_make_conj_cons _ _ _ _ (no_middle_eval a) H). left ; red ; intros. apply H0. rewrite make_conj_cons in H1. tauto. destruct (IHt _ _ no_middle_eval H0). left ; red ; intros. apply H1. rewrite make_conj_cons in H2. tauto. right ; auto. Qed. coq-8.6/plugins/micromega/VarMap.v0000644000175000017500000000470613022274260016467 0ustar mdenesmdenes(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t | Node : t -> A -> t -> t . Fixpoint find (vm : t) (p:positive) {struct vm} : A := match vm with | Empty => default | Leaf i => i | Node l e r => match p with | xH => e | xO p => find l p | xI p => find r p end end. Fixpoint singleton (x:positive) (v : A) : t := match x with | xH => Leaf v | xO p => Node (singleton p v) default Empty | xI p => Node Empty default (singleton p v) end. Fixpoint vm_add (x: positive) (v : A) (m : t) {struct m} : t := match m with | Empty => singleton x v | Leaf vl => match x with | xH => Leaf v | xO p => Node (singleton p v) vl Empty | xI p => Node Empty vl (singleton p v) end | Node l o r => match x with | xH => Node l v r | xI p => Node l o (vm_add p v r) | xO p => Node (vm_add p v l) o r end end. End MakeVarMap. coq-8.6/plugins/micromega/MExtraction.v0000644000175000017500000000442313022274260017532 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "( * )" [ "(,)" ]. Extract Inductive list => list [ "[]" "(::)" ]. Extract Inductive bool => bool [ true false ]. Extract Inductive sumbool => bool [ true false ]. Extract Inductive option => option [ Some None ]. Extract Inductive sumor => option [ Some None ]. (** Then, in a ternary alternative { }+{ }+{ }, - leftmost choice (Inleft Left) is (Some true), - middle choice (Inleft Right) is (Some false), - rightmost choice (Inright) is (None) *) (** To preserve its laziness, andb is normally expanded. Let's rather use the ocaml && *) Extract Inlined Constant andb => "(&&)". Require Import Reals. Extract Constant R => "int". Extract Constant R0 => "0". Extract Constant R1 => "1". Extract Constant Rplus => "( + )". Extract Constant Rmult => "( * )". Extract Constant Ropp => "fun x -> - x". Extract Constant Rinv => "fun x -> 1 / x". Extraction "micromega.ml" List.map simpl_cone (*map_cone indexes*) denorm Qpower vm_add n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/micromega/ZCoeff.v0000644000175000017500000001240513022274260016450 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R -> R. Variable ropp : R -> R. Variables req rle rlt : R -> R -> Prop. Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (rplus x y). Notation "x * y " := (rtimes x y). Notation "x - y " := (rminus x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Notation "x ~= y" := (~ req x y). Notation "x <= y" := (rle x y). Notation "x < y" := (rlt x y). Lemma req_refl : forall x, req x x. Proof. destruct sor.(SORsetoid) as (Equivalence_Reflexive,_,_). apply Equivalence_Reflexive. Qed. Lemma req_sym : forall x y, req x y -> req y x. Proof. destruct sor.(SORsetoid) as (_,Equivalence_Symmetric,_). apply Equivalence_Symmetric. Qed. Lemma req_trans : forall x y z, req x y -> req y z -> req x z. Proof. destruct sor.(SORsetoid) as (_,_,Equivalence_Transitive). apply Equivalence_Transitive. Qed. Add Relation R req reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) as sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. exact sor.(SORplus_wd). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. exact sor.(SORtimes_wd). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. exact sor.(SORopp_wd). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. exact sor.(SORle_wd). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. exact sor.(SORlt_wd). Qed. Add Morphism rminus with signature req ==> req ==> req as rminus_morph. Proof. exact (rminus_morph sor). Qed. Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp. Declare Equivalent Keys gen_order_phi_Z gen_phiZ. Notation phi_pos := (gen_phiPOS 1 rplus rtimes). Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes). Notation "[ x ]" := (gen_order_phi_Z x). Lemma ring_ops_wd : ring_eq_ext rplus rtimes ropp req. Proof. constructor. exact rplus_morph. exact rtimes_morph. exact ropp_morph. Qed. Lemma Zring_morph : ring_morph 0 1 rplus rtimes rminus ropp req 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool gen_order_phi_Z. Proof. exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)). Qed. Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x. Proof. induction x as [x IH | x IH |]; simpl; try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor); try apply (Rlt_0_1 sor); assumption. Qed. Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Pos.succ x) == 1 + phi_pos1 x. Proof. exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))). Qed. Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y. Proof. intros x y H. pattern y; apply Pos.lt_ind with x. rewrite phi_pos1_succ; apply (Rlt_succ_r sor). clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor). assumption. Qed. Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y]. Proof. intros x y H. do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt)); destruct x; destruct y; simpl in *; try discriminate. apply phi_pos1_pos. now apply clt_pos_morph. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. apply (Rlt_trans sor) with 0. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. apply phi_pos1_pos. apply -> (Ropp_lt_mono sor); apply clt_pos_morph. red. now rewrite Pos.compare_antisym. Qed. Lemma Zcleb_morph : forall x y : Z, Z.leb x y = true -> [x] <= [y]. Proof. unfold Z.leb; intros x y H. case_eq (x ?= y)%Z; intro H1; rewrite H1 in H. le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1. le_less. now apply clt_morph. discriminate. Qed. Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y]. Proof. intros x y H. unfold Zeq_bool in H. case_eq (Z.compare x y); intro H1; rewrite H1 in *; (discriminate || clear H). apply (Rlt_neq sor). now apply clt_morph. fold (x > y)%Z in H1. rewrite Z.gt_lt_iff in H1. apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph. Qed. End InitialMorphism. coq-8.6/plugins/micromega/Lra.v0000644000175000017500000000402113022274260016005 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (sos_R rchecker) || (psatz_R d rchecker) | _ => fail "Unsupported domain" end in tac. Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/micromega/QMicromega.v0000644000175000017500000001476613022274260017334 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* x) (fun x => x) (pow_N 1 Qmult). Proof. constructor. constructor ; intros ; try reflexivity. apply Qeq_bool_eq; auto. constructor. reflexivity. intros x y. apply Qeq_bool_neq ; auto. apply Qle_bool_imp_le. Qed. (*Definition Zeval_expr := eval_pexpr 0 Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => Z.of_N x) (Z.pow).*) Require Import EnvRing. Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := match e with | PEc c => c | PEX _ j => env j | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) | PEopp pe1 => - (Qeval_expr env pe1) | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z.of_N n) end. Lemma Qeval_expr_simpl : forall env e, Qeval_expr env e = match e with | PEc c => c | PEX _ j => env j | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) | PEopp pe1 => - (Qeval_expr env pe1) | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z.of_N n) end. Proof. destruct e ; reflexivity. Qed. Definition Qeval_expr' := eval_pexpr Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult). Lemma QNpower : forall r n, r ^ Z.of_N n = pow_N 1 Qmult r n. Proof. destruct n ; reflexivity. Qed. Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e. Proof. induction e ; simpl ; subst ; try congruence. reflexivity. rewrite IHe. apply QNpower. Qed. Definition Qeval_op2 (o : Op2) : Q -> Q -> Prop := match o with | OpEq => Qeq | OpNEq => fun x y => ~ x == y | OpLe => Qle | OpGe => fun x y => Qle y x | OpLt => Qlt | OpGt => fun x y => Qlt y x end. Definition Qeval_formula (e:PolEnv Q) (ff : Formula Q) := let (lhs,o,rhs) := ff in Qeval_op2 o (Qeval_expr e lhs) (Qeval_expr e rhs). Definition Qeval_formula' := eval_formula Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult). Lemma Qeval_formula_compat : forall env f, Qeval_formula env f <-> Qeval_formula' env f. Proof. intros. unfold Qeval_formula. destruct f. repeat rewrite Qeval_expr_compat. unfold Qeval_formula'. unfold Qeval_expr'. split ; destruct Fop ; simpl; auto. Qed. Definition Qeval_nformula := eval_nformula 0 Qplus Qmult Qeq Qle Qlt (fun x => x) . Definition Qeval_op1 (o : Op1) : Q -> Prop := match o with | Equal => fun x : Q => x == 0 | NonEqual => fun x : Q => ~ x == 0 | Strict => fun x : Q => 0 < x | NonStrict => fun x : Q => 0 <= x end. Lemma Qeval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). Proof. exact (fun env d =>eval_nformula_dec Qsor (fun x => x) env d). Qed. Definition QWitness := Psatz Q. Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qeq_bool Qle_bool. Require Import List. Lemma QWeakChecker_sound : forall (l : list (NFormula Q)) (cm : QWitness), QWeakChecker l cm = true -> forall env, make_impl (Qeval_nformula env) l False. Proof. intros l cm H. intro. unfold Qeval_nformula. apply (checker_nf_sound Qsor QSORaddon l cm). unfold QWeakChecker in H. exact H. Qed. Require Import Coq.micromega.Tauto. Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool. Definition qdeduce := nformula_plus_nformula 0 Qplus Qeq_bool. Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := @tauto_checker (Formula Q) (NFormula Q) qunsat qdeduce Qnormalise Qnegate QWitness QWeakChecker f w. Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f (Qeval_formula env) f. Proof. intros f w. unfold QTautoChecker. apply (tauto_checker_sound Qeval_formula Qeval_nformula). apply Qeval_nformula_dec. intros until env. unfold eval_nformula. unfold RingMicromega.eval_nformula. destruct t. apply (check_inconsistent_sound Qsor QSORaddon) ; auto. unfold qdeduce. apply (nformula_plus_nformula_correct Qsor QSORaddon). intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor QSORaddon). intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor QSORaddon). intros t w0. apply QWeakChecker_sound. Qed. (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/micromega/ZMicromega.v0000644000175000017500000007453513022274260017345 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* destruct (andb_prop _ _ id); clear id | [ id : (_ || _)%bool = true |- _ ] => destruct (orb_prop _ _ id); clear id end. Ltac inv H := inversion H ; try subst ; clear H. Require Import EnvRing. Open Scope Z_scope. Lemma Zsor : SOR 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt. Proof. constructor ; intros ; subst ; try (intuition (auto with zarith)). apply Zsth. apply Zth. destruct (Z.lt_trichotomy n m) ; intuition. apply Z.mul_pos_pos ; auto. Qed. Lemma ZSORaddon : SORaddon 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le (* ring elements *) 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (* coefficients *) Zeq_bool Z.leb (fun x => x) (fun x => x) (pow_N 1 Z.mul). Proof. constructor. constructor ; intros ; try reflexivity. apply Zeq_bool_eq ; auto. constructor. reflexivity. intros x y. apply Zeq_bool_neq ; auto. apply Zle_bool_imp_le. Qed. Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z := match e with | PEc c => c | PEX _ x => env x | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2 | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2 | PEpow e1 n => Z.pow (Zeval_expr env e1) (Z.of_N n) | PEsub e1 e2 => (Zeval_expr env e1) - (Zeval_expr env e2) | PEopp e => Z.opp (Zeval_expr env e) end. Definition eval_expr := eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => x) (pow_N 1 Z.mul). Lemma ZNpower : forall r n, r ^ Z.of_N n = pow_N 1 Z.mul r n. Proof. destruct n. reflexivity. simpl. unfold Z.pow_pos. replace (pow_pos Z.mul r p) with (1 * (pow_pos Z.mul r p)) by ring. generalize 1. induction p; simpl ; intros ; repeat rewrite IHp ; ring. Qed. Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = eval_expr env e. Proof. induction e ; simpl ; try congruence. reflexivity. rewrite ZNpower. congruence. Qed. Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop := match o with | OpEq => @eq Z | OpNEq => fun x y => ~ x = y | OpLe => Z.le | OpGe => Z.ge | OpLt => Z.lt | OpGt => Z.gt end. Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):= let (lhs, op, rhs) := f in (Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env rhs). Definition Zeval_formula' := eval_formula Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt (fun x => x) (fun x => x) (pow_N 1 Z.mul). Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f. Proof. destruct f ; simpl. rewrite Zeval_expr_compat. rewrite Zeval_expr_compat. unfold eval_expr. generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env Flhs). generalize ((eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env Frhs)). destruct Fop ; simpl; intros ; intuition (auto with zarith). Qed. Definition eval_nformula := eval_nformula 0 Z.add Z.mul (@eq Z) Z.le Z.lt (fun x => x) . Definition Zeval_op1 (o : Op1) : Z -> Prop := match o with | Equal => fun x : Z => x = 0 | NonEqual => fun x : Z => x <> 0 | Strict => fun x : Z => 0 < x | NonStrict => fun x : Z => 0 <= x end. Lemma Zeval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). Proof. intros. apply (eval_nformula_dec Zsor). Qed. Definition ZWitness := Psatz Z. Definition ZWeakChecker := check_normalised_formulas 0 1 Z.add Z.mul Zeq_bool Z.leb. Lemma ZWeakChecker_sound : forall (l : list (NFormula Z)) (cm : ZWitness), ZWeakChecker l cm = true -> forall env, make_impl (eval_nformula env) l False. Proof. intros l cm H. intro. unfold eval_nformula. apply (checker_nf_sound Zsor ZSORaddon l cm). unfold ZWeakChecker in H. exact H. Qed. Definition psub := psub Z0 Z.add Z.sub Z.opp Zeq_bool. Declare Equivalent Keys psub RingMicromega.psub. Definition padd := padd Z0 Z.add Zeq_bool. Declare Equivalent Keys padd RingMicromega.padd. Definition norm := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. Declare Equivalent Keys norm RingMicromega.norm. Definition eval_pol := eval_pol Z.add Z.mul (fun x => x). Declare Equivalent Keys eval_pol RingMicromega.eval_pol. Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) = eval_pol env lhs - eval_pol env rhs. Proof. intros. apply (eval_pol_sub Zsor ZSORaddon). Qed. Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) = eval_pol env lhs + eval_pol env rhs. Proof. intros. apply (eval_pol_add Zsor ZSORaddon). Qed. Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (norm e) . Proof. intros. apply (eval_pol_norm Zsor ZSORaddon). Qed. Definition xnormalise (t:Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in let lhs := norm lhs in let rhs := norm rhs in match o with | OpEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil | OpNEq => (psub lhs rhs,Equal) :: nil | OpGt => (psub rhs lhs,NonStrict) :: nil | OpLt => (psub lhs rhs,NonStrict) :: nil | OpGe => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil | OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil end. Require Import Coq.micromega.Tauto BinNums. Definition normalise (t:Formula Z) : cnf (NFormula Z) := List.map (fun x => x::nil) (xnormalise t). Lemma normalise_correct : forall env t, eval_cnf eval_nformula env (normalise t) <-> Zeval_formula env t. Proof. unfold normalise, xnormalise; cbn -[padd]; intros env t. rewrite Zeval_formula_compat. unfold eval_cnf, eval_clause. destruct t as [lhs o rhs]; case_eq o; cbn -[padd]; repeat rewrite eval_pol_sub; repeat rewrite eval_pol_add; repeat rewrite <- eval_pol_norm ; simpl in *; unfold eval_expr; generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env lhs); generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst; intuition (auto with zarith). Qed. Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in let lhs := norm lhs in let rhs := norm rhs in match o with | OpEq => (psub lhs rhs,Equal) :: nil | OpNEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil | OpGt => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil | OpLt => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil | OpGe => (psub lhs rhs,NonStrict) :: nil | OpLe => (psub rhs lhs,NonStrict) :: nil end. Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) := List.map (fun x => x::nil) (xnegate t). Lemma negate_correct : forall env t, eval_cnf eval_nformula env (negate t) <-> ~ Zeval_formula env t. Proof. Proof. Opaque padd. intros env t. rewrite Zeval_formula_compat. unfold negate, xnegate ; simpl. unfold eval_cnf,eval_clause. destruct t as [lhs o rhs]; case_eq o; simpl; repeat rewrite eval_pol_sub; repeat rewrite eval_pol_add; repeat rewrite <- eval_pol_norm ; simpl in *; unfold eval_expr; generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env lhs); generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst; intuition (auto with zarith). Transparent padd. Qed. Definition Zunsat := check_inconsistent 0 Zeq_bool Z.leb. Definition Zdeduce := nformula_plus_nformula 0 Z.add Zeq_bool. Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool := @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce normalise negate ZWitness ZWeakChecker f w. (* To get a complete checker, the proof format has to be enriched *) Require Import Zdiv. Open Scope Z_scope. Definition ceiling (a b:Z) : Z := let (q,r) := Z.div_eucl a b in match r with | Z0 => q | _ => q + 1 end. Require Import Znumtheory. Lemma Zdivide_ceiling : forall a b, (b | a) -> ceiling a b = Z.div a b. Proof. unfold ceiling. intros. apply Zdivide_mod in H. case_eq (Z.div_eucl a b). intros. change z with (fst (z,z0)). rewrite <- H0. change (fst (Z.div_eucl a b)) with (Z.div a b). change z0 with (snd (z,z0)). rewrite <- H0. change (snd (Z.div_eucl a b)) with (Z.modulo a b). rewrite H. reflexivity. Qed. Lemma narrow_interval_lower_bound a b x : a > 0 -> a * x >= b -> x >= ceiling b a. Proof. rewrite !Z.ge_le_iff. unfold ceiling. intros Ha H. generalize (Z_div_mod b a Ha). destruct (Z.div_eucl b a) as (q,r). intros (->,(H1,H2)). destruct r as [|r|r]. - rewrite Z.add_0_r in H. apply Z.mul_le_mono_pos_l in H; auto with zarith. - assert (0 < Z.pos r) by easy. rewrite Z.add_1_r, Z.le_succ_l. apply Z.mul_lt_mono_pos_l with a; auto with zarith. - now elim H1. Qed. (** NB: narrow_interval_upper_bound is Zdiv.Zdiv_le_lower_bound *) Require Import QArith. Inductive ZArithProof := | DoneProof | RatProof : ZWitness -> ZArithProof -> ZArithProof | CutProof : ZWitness -> ZArithProof -> ZArithProof | EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof (*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof*). (* n/d <= x -> d*x - n >= 0 *) (* In order to compute the 'cut', we need to express a polynomial P as a * Q + b. - b is the constant - a is the gcd of the other coefficient. *) Require Import Znumtheory. Definition isZ0 (x:Z) := match x with | Z0 => true | _ => false end. Lemma isZ0_0 : forall x, isZ0 x = true <-> x = 0. Proof. destruct x ; simpl ; intuition congruence. Qed. Lemma isZ0_n0 : forall x, isZ0 x = false <-> x <> 0. Proof. destruct x ; simpl ; intuition congruence. Qed. Definition ZgcdM (x y : Z) := Z.max (Z.gcd x y) 1. Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) := match p with | Pc c => (0,c) | Pinj _ p => Zgcd_pol p | PX p _ q => let (g1,c1) := Zgcd_pol p in let (g2,c2) := Zgcd_pol q in (ZgcdM (ZgcdM g1 c1) g2 , c2) end. (*Eval compute in (Zgcd_pol ((PX (Pc (-2)) 1 (Pc 4)))).*) Fixpoint Zdiv_pol (p:PolC Z) (x:Z) : PolC Z := match p with | Pc c => Pc (Z.div c x) | Pinj j p => Pinj j (Zdiv_pol p x) | PX p j q => PX (Zdiv_pol p x) j (Zdiv_pol q x) end. Inductive Zdivide_pol (x:Z): PolC Z -> Prop := | Zdiv_Pc : forall c, (x | c) -> Zdivide_pol x (Pc c) | Zdiv_Pinj : forall p, Zdivide_pol x p -> forall j, Zdivide_pol x (Pinj j p) | Zdiv_PX : forall p q, Zdivide_pol x p -> Zdivide_pol x q -> forall j, Zdivide_pol x (PX p j q). Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p -> forall env, eval_pol env p = a * eval_pol env (Zdiv_pol p a). Proof. intros until 2. induction H0. (* Pc *) simpl. intros. apply Zdivide_Zdiv_eq ; auto. (* Pinj *) simpl. intros. apply IHZdivide_pol. (* PX *) simpl. intros. rewrite IHZdivide_pol1. rewrite IHZdivide_pol2. ring. Qed. Lemma Zgcd_pol_ge : forall p, fst (Zgcd_pol p) >= 0. Proof. induction p. simpl. auto with zarith. simpl. auto. simpl. case_eq (Zgcd_pol p1). case_eq (Zgcd_pol p3). intros. simpl. unfold ZgcdM. generalize (Z.gcd_nonneg z1 z2). generalize (Zmax_spec (Z.gcd z1 z2) 1). generalize (Z.gcd_nonneg (Z.max (Z.gcd z1 z2) 1) z). generalize (Zmax_spec (Z.gcd (Z.max (Z.gcd z1 z2) 1) z) 1). auto with zarith. Qed. Lemma Zdivide_pol_Zdivide : forall p x y, Zdivide_pol x p -> (y | x) -> Zdivide_pol y p. Proof. intros. induction H. constructor. apply Z.divide_trans with (1:= H0) ; assumption. constructor. auto. constructor ; auto. Qed. Lemma Zdivide_pol_one : forall p, Zdivide_pol 1 p. Proof. induction p ; constructor ; auto. exists c. ring. Qed. Lemma Zgcd_minus : forall a b c, (a | c - b ) -> (Z.gcd a b | c). Proof. intros a b c (q,Hq). destruct (Zgcd_is_gcd a b) as [(a',Ha) (b',Hb) _]. set (g:=Z.gcd a b) in *; clearbody g. exists (q * a' + b'). symmetry in Hq. rewrite <- Z.add_move_r in Hq. rewrite <- Hq, Hb, Ha. ring. Qed. Lemma Zdivide_pol_sub : forall p a b, 0 < Z.gcd a b -> Zdivide_pol a (PsubC Z.sub p b) -> Zdivide_pol (Z.gcd a b) p. Proof. induction p. simpl. intros. inversion H0. constructor. apply Zgcd_minus ; auto. intros. constructor. simpl in H0. inversion H0 ; subst; clear H0. apply IHp ; auto. simpl. intros. inv H0. constructor. apply Zdivide_pol_Zdivide with (1:= H3). destruct (Zgcd_is_gcd a b) ; assumption. apply IHp2 ; assumption. Qed. Lemma Zdivide_pol_sub_0 : forall p a, Zdivide_pol a (PsubC Z.sub p 0) -> Zdivide_pol a p. Proof. induction p. simpl. intros. inversion H. constructor. replace (c - 0) with c in H1 ; auto with zarith. intros. constructor. simpl in H. inversion H ; subst; clear H. apply IHp ; auto. simpl. intros. inv H. constructor. auto. apply IHp2 ; assumption. Qed. Lemma Zgcd_pol_div : forall p g c, Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Z.sub p c). Proof. induction p ; simpl. (* Pc *) intros. inv H. constructor. exists 0. now ring. (* Pinj *) intros. constructor. apply IHp ; auto. (* PX *) intros g c. case_eq (Zgcd_pol p1) ; case_eq (Zgcd_pol p3) ; intros. inv H1. unfold ZgcdM at 1. destruct (Zmax_spec (Z.gcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1]; destruct HH1 as [HH1 HH1'] ; rewrite HH1'. constructor. apply Zdivide_pol_Zdivide with (x:= ZgcdM z1 z2). unfold ZgcdM. destruct (Zmax_spec (Z.gcd z1 z2) 1) as [HH2 | HH2]. destruct HH2. rewrite H2. apply Zdivide_pol_sub ; auto. auto with zarith. destruct HH2. rewrite H2. apply Zdivide_pol_one. unfold ZgcdM in HH1. unfold ZgcdM. destruct (Zmax_spec (Z.gcd z1 z2) 1) as [HH2 | HH2]. destruct HH2. rewrite H2 in *. destruct (Zgcd_is_gcd (Z.gcd z1 z2) z); auto. destruct HH2. rewrite H2. destruct (Zgcd_is_gcd 1 z); auto. apply Zdivide_pol_Zdivide with (x:= z). apply (IHp2 _ _ H); auto. destruct (Zgcd_is_gcd (ZgcdM z1 z2) z); auto. constructor. apply Zdivide_pol_one. apply Zdivide_pol_one. Qed. Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Z.sub p c) g)) + c. Proof. intros. rewrite <- Zdiv_pol_correct ; auto. rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). unfold eval_pol. ring. (**) apply Zgcd_pol_div ; auto. Qed. Definition makeCuttingPlane (p : PolC Z) : PolC Z * Z := let (g,c) := Zgcd_pol p in if Z.gtb g Z0 then (Zdiv_pol (PsubC Z.sub p c) g , Z.opp (ceiling (Z.opp c) g)) else (p,Z0). Definition genCuttingPlane (f : NFormula Z) : option (PolC Z * Z * Op1) := let (e,op) := f in match op with | Equal => let (g,c) := Zgcd_pol e in if andb (Z.gtb g Z0) (andb (negb (Zeq_bool c Z0)) (negb (Zeq_bool (Z.gcd g c) g))) then None (* inconsistent *) else (* Could be optimised Zgcd_pol is recomputed *) let (p,c) := makeCuttingPlane e in Some (p,c,Equal) | NonEqual => Some (e,Z0,op) | Strict => let (p,c) := makeCuttingPlane (PsubC Z.sub e 1) in Some (p,c,NonStrict) | NonStrict => let (p,c) := makeCuttingPlane e in Some (p,c,NonStrict) end. Definition nformula_of_cutting_plane (t : PolC Z * Z * Op1) : NFormula Z := let (e_z, o) := t in let (e,z) := e_z in (padd e (Pc z) , o). Definition is_pol_Z0 (p : PolC Z) : bool := match p with | Pc Z0 => true | _ => false end. Lemma is_pol_Z0_eval_pol : forall p, is_pol_Z0 p = true -> forall env, eval_pol env p = 0. Proof. unfold is_pol_Z0. destruct p ; try discriminate. destruct z ; try discriminate. reflexivity. Qed. Definition eval_Psatz : list (NFormula Z) -> ZWitness -> option (NFormula Z) := eval_Psatz 0 1 Z.add Z.mul Zeq_bool Z.leb. Definition valid_cut_sign (op:Op1) := match op with | Equal => true | NonStrict => true | _ => false end. Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := match pf with | DoneProof => false | RatProof w pf => match eval_Psatz l w with | None => false | Some f => if Zunsat f then true else ZChecker (f::l) pf end | CutProof w pf => match eval_Psatz l w with | None => false | Some f => match genCuttingPlane f with | None => true | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf end end | EnumProof w1 w2 pf => match eval_Psatz l w1 , eval_Psatz l w2 with | Some f1 , Some f2 => match genCuttingPlane f1 , genCuttingPlane f2 with |Some (e1,z1,op1) , Some (e2,z2,op2) => if (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd e1 e2)) then (fix label (pfs:list ZArithProof) := fun lb ub => match pfs with | nil => if Z.gtb lb ub then true else false | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Z.add lb 1%Z) ub) end) pf (Z.opp z1) z2 else false | _ , _ => true end | _ , _ => false end end. Fixpoint bdepth (pf : ZArithProof) : nat := match pf with | DoneProof => O | RatProof _ p => S (bdepth p) | CutProof _ p => S (bdepth p) | EnumProof _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x) O l) end. Require Import Wf_nat. Lemma in_bdepth : forall l a b y, In y l -> ltof ZArithProof bdepth y (EnumProof a b l). Proof. induction l. (* nil *) simpl. tauto. (* cons *) simpl. intros. destruct H. subst. unfold ltof. simpl. generalize ( (fold_right (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat l)). intros. generalize (bdepth y) ; intros. generalize (Max.max_l n0 n) (Max.max_r n0 n). auto with zarith. generalize (IHl a0 b y H). unfold ltof. simpl. generalize ( (fold_right (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat l)). intros. generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n). auto with zarith. Qed. Lemma eval_Psatz_sound : forall env w l f', make_conj (eval_nformula env) l -> eval_Psatz l w = Some f' -> eval_nformula env f'. Proof. intros. apply (eval_Psatz_Sound Zsor ZSORaddon) with (l:=l) (e:= w) ; auto. apply make_conj_in ; auto. Qed. Lemma makeCuttingPlane_ns_sound : forall env e e' c, eval_nformula env (e, NonStrict) -> makeCuttingPlane e = (e',c) -> eval_nformula env (nformula_of_cutting_plane (e', c, NonStrict)). Proof. unfold nformula_of_cutting_plane. unfold eval_nformula. unfold RingMicromega.eval_nformula. unfold eval_op1. intros. rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). simpl. (**) unfold makeCuttingPlane in H0. revert H0. case_eq (Zgcd_pol e) ; intros g c0. generalize (Zgt_cases g 0) ; destruct (Z.gtb g 0). intros. inv H2. change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in *. apply Zgcd_pol_correct_lt with (env:=env) in H1. generalize (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Z.sub e c0) g)) H0). auto with zarith. auto with zarith. (* g <= 0 *) intros. inv H2. auto with zarith. Qed. Lemma cutting_plane_sound : forall env f p, eval_nformula env f -> genCuttingPlane f = Some p -> eval_nformula env (nformula_of_cutting_plane p). Proof. unfold genCuttingPlane. destruct f as [e op]. destruct op. (* Equal *) destruct p as [[e' z] op]. case_eq (Zgcd_pol e) ; intros g c. case_eq (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd g c) g))) ; [discriminate|]. case_eq (makeCuttingPlane e). intros. inv H3. unfold makeCuttingPlane in H. rewrite H1 in H. revert H. change (eval_pol env e = 0) in H2. case_eq (Z.gtb g 0). intros. rewrite <- Zgt_is_gt_bool in H. rewrite Zgcd_pol_correct_lt with (1:= H1) in H2; auto with zarith. unfold nformula_of_cutting_plane. change (eval_pol env (padd e' (Pc z)) = 0). inv H3. rewrite eval_pol_add. set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub e c) g)) in *; clearbody x. simpl. rewrite andb_false_iff in H0. destruct H0. rewrite Zgt_is_gt_bool in H ; congruence. rewrite andb_false_iff in H0. destruct H0. rewrite negb_false_iff in H0. apply Zeq_bool_eq in H0. subst. simpl. rewrite Z.add_0_r, Z.mul_eq_0 in H2. intuition auto with zarith. rewrite negb_false_iff in H0. apply Zeq_bool_eq in H0. assert (HH := Zgcd_is_gcd g c). rewrite H0 in HH. inv HH. apply Zdivide_opp_r in H4. rewrite Zdivide_ceiling ; auto. apply Z.sub_move_0_r. apply Z.div_unique_exact ; auto with zarith. intros. unfold nformula_of_cutting_plane. inv H3. change (eval_pol env (padd e' (Pc 0)) = 0). rewrite eval_pol_add. simpl. auto with zarith. (* NonEqual *) intros. inv H0. unfold eval_nformula in *. unfold RingMicromega.eval_nformula in *. unfold nformula_of_cutting_plane. unfold eval_op1 in *. rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). simpl. auto with zarith. (* Strict *) destruct p as [[e' z] op]. case_eq (makeCuttingPlane (PsubC Z.sub e 1)). intros. inv H1. apply makeCuttingPlane_ns_sound with (env:=env) (2:= H). simpl in *. rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). auto with zarith. (* NonStrict *) destruct p as [[e' z] op]. case_eq (makeCuttingPlane e). intros. inv H1. apply makeCuttingPlane_ns_sound with (env:=env) (2:= H). assumption. Qed. Lemma genCuttingPlaneNone : forall env f, genCuttingPlane f = None -> eval_nformula env f -> False. Proof. unfold genCuttingPlane. destruct f. destruct o. case_eq (Zgcd_pol p) ; intros g c. case_eq (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd g c) g))). intros. flatten_bool. rewrite negb_true_iff in H5. apply Zeq_bool_neq in H5. rewrite <- Zgt_is_gt_bool in H3. rewrite negb_true_iff in H. apply Zeq_bool_neq in H. change (eval_pol env p = 0) in H2. rewrite Zgcd_pol_correct_lt with (1:= H0) in H2; auto with zarith. set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub p c) g)) in *; clearbody x. contradict H5. apply Zis_gcd_gcd; auto with zarith. constructor; auto with zarith. exists (-x). rewrite Z.mul_opp_l, Z.mul_comm; auto with zarith. (**) destruct (makeCuttingPlane p); discriminate. discriminate. destruct (makeCuttingPlane (PsubC Z.sub p 1)) ; discriminate. destruct (makeCuttingPlane p) ; discriminate. Qed. Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False. Proof. induction w using (well_founded_ind (well_founded_ltof _ bdepth)). destruct w as [ | w pf | w pf | w1 w2 pf]. (* DoneProof *) simpl. discriminate. (* RatProof *) simpl. intro l. case_eq (eval_Psatz l w) ; [| discriminate]. intros f Hf. case_eq (Zunsat f). intros. apply (checker_nf_sound Zsor ZSORaddon l w). unfold check_normalised_formulas. unfold eval_Psatz in Hf. rewrite Hf. unfold Zunsat in H0. assumption. intros. assert (make_impl (eval_nformula env) (f::l) False). apply H with (2:= H1). unfold ltof. simpl. auto with arith. destruct f. rewrite <- make_conj_impl in H2. rewrite make_conj_cons in H2. rewrite <- make_conj_impl. intro. apply H2. split ; auto. apply eval_Psatz_sound with (2:= Hf) ; assumption. (* CutProof *) simpl. intro l. case_eq (eval_Psatz l w) ; [ | discriminate]. intros f' Hlc. case_eq (genCuttingPlane f'). intros. assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False). eapply (H pf) ; auto. unfold ltof. simpl. auto with arith. rewrite <- make_conj_impl in H2. rewrite make_conj_cons in H2. rewrite <- make_conj_impl. intro. apply H2. split ; auto. apply eval_Psatz_sound with (env:=env) in Hlc. apply cutting_plane_sound with (1:= Hlc) (2:= H0). auto. (* genCuttingPlane = None *) intros. rewrite <- make_conj_impl. intros. apply eval_Psatz_sound with (2:= Hlc) in H2. apply genCuttingPlaneNone with (2:= H2) ; auto. (* EnumProof *) intro. simpl. case_eq (eval_Psatz l w1) ; [ | discriminate]. case_eq (eval_Psatz l w2) ; [ | discriminate]. intros f1 Hf1 f2 Hf2. case_eq (genCuttingPlane f2). destruct p as [ [p1 z1] op1]. case_eq (genCuttingPlane f1). destruct p as [ [p2 z2] op2]. case_eq (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd p1 p2)). intros Hcond. flatten_bool. rename H1 into HZ0. rename H2 into Hop1. rename H3 into Hop2. intros HCutL HCutR Hfix env. (* get the bounds of the enum *) rewrite <- make_conj_impl. intro. assert (-z1 <= eval_pol env p1 <= z2). split. apply eval_Psatz_sound with (env:=env) in Hf2 ; auto. apply cutting_plane_sound with (1:= Hf2) in HCutR. unfold nformula_of_cutting_plane in HCutR. unfold eval_nformula in HCutR. unfold RingMicromega.eval_nformula in HCutR. change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutR. unfold eval_op1 in HCutR. destruct op1 ; simpl in Hop1 ; try discriminate; rewrite eval_pol_add in HCutR; simpl in HCutR; auto with zarith. (**) apply is_pol_Z0_eval_pol with (env := env) in HZ0. rewrite eval_pol_add in HZ0. replace (eval_pol env p1) with (- eval_pol env p2) by omega. apply eval_Psatz_sound with (env:=env) in Hf1 ; auto. apply cutting_plane_sound with (1:= Hf1) in HCutL. unfold nformula_of_cutting_plane in HCutL. unfold eval_nformula in HCutL. unfold RingMicromega.eval_nformula in HCutL. change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutL. unfold eval_op1 in HCutL. rewrite eval_pol_add in HCutL. simpl in HCutL. destruct op2 ; simpl in Hop2 ; try discriminate ; omega. revert Hfix. match goal with | |- context[?F pf (-z1) z2 = true] => set (FF := F) end. intros. assert (HH :forall x, -z1 <= x <= z2 -> exists pr, (In pr pf /\ ZChecker ((PsubC Z.sub p1 x,Equal) :: l) pr = true)%Z). clear HZ0 Hop1 Hop2 HCutL HCutR H0 H1. revert Hfix. generalize (-z1). clear z1. intro z1. revert z1 z2. induction pf;simpl ;intros. generalize (Zgt_cases z1 z2). destruct (Z.gtb z1 z2). intros. apply False_ind ; omega. discriminate. flatten_bool. assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega. destruct HH. subst. exists a ; auto. assert (z1 + 1 <= x <= z2)%Z by omega. elim IHpf with (2:=H2) (3:= H4). destruct H4. intros. exists x0 ; split;tauto. intros until 1. apply H ; auto. unfold ltof in *. simpl in *. zify. omega. (*/asser *) destruct (HH _ H1) as [pr [Hin Hcheker]]. assert (make_impl (eval_nformula env) ((PsubC Z.sub p1 (eval_pol env p1),Equal) :: l) False). apply (H pr);auto. apply in_bdepth ; auto. rewrite <- make_conj_impl in H2. apply H2. rewrite make_conj_cons. split ;auto. unfold eval_nformula. unfold RingMicromega.eval_nformula. simpl. rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). unfold eval_pol. ring. discriminate. (* No cutting plane *) intros. rewrite <- make_conj_impl. intros. apply eval_Psatz_sound with (2:= Hf1) in H3. apply genCuttingPlaneNone with (2:= H3) ; auto. (* No Cutting plane (bis) *) intros. rewrite <- make_conj_impl. intros. apply eval_Psatz_sound with (2:= Hf2) in H2. apply genCuttingPlaneNone with (2:= H2) ; auto. Qed. Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ZArithProof): bool := @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce normalise negate ZArithProof ZChecker f w. Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (Zeval_formula env) f. Proof. intros f w. unfold ZTautoChecker. apply (tauto_checker_sound Zeval_formula eval_nformula). apply Zeval_nformula_dec. intros until env. unfold eval_nformula. unfold RingMicromega.eval_nformula. destruct t. apply (check_inconsistent_sound Zsor ZSORaddon) ; auto. unfold Zdeduce. apply (nformula_plus_nformula_correct Zsor ZSORaddon). intros env t. rewrite normalise_correct ; auto. intros env t. rewrite negate_correct ; auto. intros t w0. apply ZChecker_sound. Qed. Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := match pt with | DoneProof => acc | RatProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt | CutProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt | EnumProof c1 c2 l => let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in List.fold_left (xhyps_of_pt (S base)) l acc end. Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt. (*Lemma hyps_of_pt_correct : forall pt l, *) Open Scope Z_scope. (** To ease bindings from ml code **) (*Definition varmap := Quote.varmap.*) Definition make_impl := Refl.make_impl. Definition make_conj := Refl.make_conj. Require VarMap. (*Definition varmap_type := VarMap.t Z. *) Definition env := PolEnv Z. Definition node := @VarMap.Node Z. Definition empty := @VarMap.Empty Z. Definition leaf := @VarMap.Leaf Z. Definition coneMember := ZWitness. Definition eval := eval_formula. Definition prod_pos_nat := prod positive nat. Notation n_of_Z := Z.to_N (only parsing). (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/micromega/Tauto.v0000644000175000017500000003355213022274260016376 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* BFormula A | A : A -> BFormula A | Cj : BFormula A -> BFormula A -> BFormula A | D : BFormula A-> BFormula A -> BFormula A | N : BFormula A -> BFormula A | I : BFormula A-> BFormula A-> BFormula A. Fixpoint eval_f (A:Type) (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop := match f with | TT _ => True | FF _ => False | A a => ev a | X _ p => p | Cj e1 e2 => (eval_f ev e1) /\ (eval_f ev e2) | D e1 e2 => (eval_f ev e1) \/ (eval_f ev e2) | N e => ~ (eval_f ev e) | I f1 f2 => (eval_f ev f1) -> (eval_f ev f2) end. Lemma eval_f_morph : forall A (ev ev' : A -> Prop) (f : BFormula A), (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f). Proof. induction f ; simpl ; try tauto. intros. assert (H' := H a). auto. Qed. Fixpoint map_bformula (T U : Type) (fct : T -> U) (f : BFormula T) : BFormula U := match f with | TT _ => TT _ | FF _ => FF _ | X _ p => X _ p | A a => A (fct a) | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2) | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2) | N f => N (map_bformula fct f) | I f1 f2 => I (map_bformula fct f1) (map_bformula fct f2) end. Lemma eval_f_map : forall T U (fct: T-> U) env f , eval_f env (map_bformula fct f) = eval_f (fun x => env (fct x)) f. Proof. induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto. rewrite <- IHf. auto. Qed. Lemma map_simpl : forall A B f l, @map A B f l = match l with | nil => nil | a :: l=> (f a) :: (@map A B f l) end. Proof. destruct l ; reflexivity. Qed. Section S. Variable Env : Type. Variable Term : Type. Variable eval : Env -> Term -> Prop. Variable Term' : Type. Variable eval' : Env -> Term' -> Prop. Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). Variable unsat : Term' -> bool. Variable unsat_prop : forall t, unsat t = true -> forall env, eval' env t -> False. Variable deduce : Term' -> Term' -> option Term'. Variable deduce_prop : forall env t t' u, eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u. Definition clause := list Term'. Definition cnf := list clause. Variable normalise : Term -> cnf. Variable negate : Term -> cnf. Definition tt : cnf := @nil clause. Definition ff : cnf := cons (@nil Term') nil. Fixpoint add_term (t: Term') (cl : clause) : option clause := match cl with | nil => match deduce t t with | None => Some (t ::nil) | Some u => if unsat u then None else Some (t::nil) end | t'::cl => match deduce t t' with | None => match add_term t cl with | None => None | Some cl' => Some (t' :: cl') end | Some u => if unsat u then None else match add_term t cl with | None => None | Some cl' => Some (t' :: cl') end end end. Fixpoint or_clause (cl1 cl2 : clause) : option clause := match cl1 with | nil => Some cl2 | t::cl => match add_term t cl2 with | None => None | Some cl' => or_clause cl cl' end end. (* Definition or_clause_cnf (t:clause) (f:cnf) : cnf := List.map (fun x => (t++x)) f. *) Definition or_clause_cnf (t:clause) (f:cnf) : cnf := List.fold_right (fun e acc => match or_clause t e with | None => acc | Some cl => cl :: acc end) nil f. Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := match f with | nil => tt | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') end. Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := f1 ++ f2. Fixpoint xcnf (pol : bool) (f : BFormula Term) {struct f}: cnf := match f with | TT _ => if pol then tt else ff | FF _ => if pol then ff else tt | X _ p => if pol then ff else ff (* This is not complete - cannot negate any proposition *) | A x => if pol then normalise x else negate x | N e => xcnf (negb pol) e | Cj e1 e2 => (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) end. Definition eval_clause (env : Env) (cl : clause) := ~ make_conj (eval' env) cl. Definition eval_cnf (env : Env) (f:cnf) := make_conj (eval_clause env) f. Lemma eval_cnf_app : forall env x y, eval_cnf env (x++y) -> eval_cnf env x /\ eval_cnf env y. Proof. unfold eval_cnf. intros. rewrite make_conj_app in H ; auto. Qed. Definition eval_opt_clause (env : Env) (cl: option clause) := match cl with | None => True | Some cl => eval_clause env cl end. Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl). Proof. induction cl. (* BC *) simpl. case_eq (deduce t t) ; auto. intros until 0. case_eq (unsat t0) ; auto. unfold eval_clause. rewrite make_conj_cons. intros. intro. apply unsat_prop with (1:= H) (env := env). apply deduce_prop with (3:= H0) ; tauto. (* IC *) simpl. case_eq (deduce t a). intro u. case_eq (unsat u). simpl. intros. unfold eval_clause. intro. apply unsat_prop with (1:= H) (env:= env). repeat rewrite make_conj_cons in H2. apply deduce_prop with (3:= H0); tauto. intro. case_eq (add_term t cl) ; intros. simpl in H2. rewrite H0 in IHcl. simpl in IHcl. unfold eval_clause in *. intros. repeat rewrite make_conj_cons in *. tauto. rewrite H0 in IHcl ; simpl in *. unfold eval_clause in *. intros. repeat rewrite make_conj_cons in *. tauto. case_eq (add_term t cl) ; intros. simpl in H1. unfold eval_clause in *. repeat rewrite make_conj_cons in *. rewrite H in IHcl. simpl in IHcl. tauto. simpl in *. rewrite H in IHcl. simpl in IHcl. unfold eval_clause in *. repeat rewrite make_conj_cons in *. tauto. Qed. Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'. Proof. induction cl. simpl. tauto. intros until 0. simpl. assert (HH := add_term_correct env a cl'). case_eq (add_term a cl'). simpl in *. intros. apply IHcl in H0. rewrite H in HH. simpl in HH. unfold eval_clause in *. destruct H0. repeat rewrite make_conj_cons in *. tauto. apply HH in H0. apply not_make_conj_cons in H0 ; auto. repeat rewrite make_conj_cons in *. tauto. simpl. intros. rewrite H in HH. simpl in HH. unfold eval_clause in *. assert (HH' := HH Coq.Init.Logic.I). apply not_make_conj_cons in HH'; auto. repeat rewrite make_conj_cons in *. tauto. Qed. Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) -> (eval_clause env t) \/ (eval_cnf env f). Proof. unfold eval_cnf. unfold or_clause_cnf. intros until t. set (F := (fun (e : clause) (acc : list clause) => match or_clause t e with | Some cl => cl :: acc | None => acc end)). induction f. auto. (**) simpl. intros. destruct f. simpl in H. simpl in IHf. unfold F in H. revert H. intros. apply or_clause_correct. destruct (or_clause t a) ; simpl in * ; auto. unfold F in H at 1. revert H. assert (HH := or_clause_correct t a env). destruct (or_clause t a); simpl in HH ; rewrite make_conj_cons in * ; intuition. rewrite make_conj_cons in *. tauto. Qed. Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf env f -> eval_cnf env (a::f). Proof. intros. unfold eval_cnf in *. rewrite make_conj_cons ; eauto. Qed. Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') -> (eval_cnf env f) \/ (eval_cnf env f'). Proof. induction f. unfold eval_cnf. simpl. tauto. (**) intros. simpl in H. destruct (eval_cnf_app _ _ _ H). clear H. destruct (IHf _ H0). destruct (or_clause_cnf_correct _ _ _ H1). left. apply eval_cnf_cons ; auto. right ; auto. right ; auto. Qed. Variable normalise_correct : forall env t, eval_cnf env (normalise t) -> eval env t. Variable negate_correct : forall env t, eval_cnf env (negate t) -> ~ eval env t. Lemma xcnf_correct : forall f pol env, eval_cnf env (xcnf pol f) -> eval_f (eval env) (if pol then f else N f). Proof. induction f. (* TT *) unfold eval_cnf. simpl. destruct pol ; simpl ; auto. (* FF *) unfold eval_cnf. destruct pol; simpl ; auto. unfold eval_clause ; simpl. tauto. (* P *) simpl. destruct pol ; intros ;simpl. unfold eval_cnf in H. (* Here I have to drop the proposition *) simpl in H. unfold eval_clause in H ; simpl in H. tauto. (* Here, I could store P in the clause *) unfold eval_cnf in H;simpl in H. unfold eval_clause in H ; simpl in H. tauto. (* A *) simpl. destruct pol ; simpl. intros. apply normalise_correct ; auto. (* A 2 *) intros. apply negate_correct ; auto. auto. (* Cj *) destruct pol ; simpl. (* pol = true *) intros. unfold and_cnf in H. destruct (eval_cnf_app _ _ _ H). clear H. split. apply (IHf1 _ _ H0). apply (IHf2 _ _ H1). (* pol = false *) intros. destruct (or_cnf_correct _ _ _ H). generalize (IHf1 false env H0). simpl. tauto. generalize (IHf2 false env H0). simpl. tauto. (* D *) simpl. destruct pol. (* pol = true *) intros. destruct (or_cnf_correct _ _ _ H). generalize (IHf1 _ env H0). simpl. tauto. generalize (IHf2 _ env H0). simpl. tauto. (* pol = true *) unfold and_cnf. intros. destruct (eval_cnf_app _ _ _ H). clear H. simpl. generalize (IHf1 _ _ H0). generalize (IHf2 _ _ H1). simpl. tauto. (**) simpl. destruct pol ; simpl. intros. apply (IHf false) ; auto. intros. generalize (IHf _ _ H). tauto. (* I *) simpl; intros. destruct pol. simpl. intro. destruct (or_cnf_correct _ _ _ H). generalize (IHf1 _ _ H1). simpl in *. tauto. generalize (IHf2 _ _ H1). auto. (* pol = false *) unfold and_cnf in H. simpl in H. destruct (eval_cnf_app _ _ _ H). generalize (IHf1 _ _ H0). generalize (IHf2 _ _ H1). simpl. tauto. Qed. Variable Witness : Type. Variable checker : list Term' -> Witness -> bool. Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval' env) t False. Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool := match f with | nil => true | e::f => match l with | nil => false | c::l => match checker e c with | true => cnf_checker f l | _ => false end end end. Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf env t. Proof. unfold eval_cnf. induction t. (* bc *) simpl. auto. (* ic *) simpl. destruct w. intros ; discriminate. case_eq (checker a w) ; intros ; try discriminate. generalize (@checker_sound _ _ H env). generalize (IHt _ H0 env) ; intros. destruct t. red ; intro. rewrite <- make_conj_impl in H2. tauto. rewrite <- make_conj_impl in H2. tauto. Qed. Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool := cnf_checker (xcnf true f) w. Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (eval env) t. Proof. unfold tauto_checker. intros. change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)). apply (xcnf_correct t true). eapply cnf_checker_sound ; eauto. Qed. End S. (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/micromega/micromega.mli0000644000175000017500000002672713022274260017567 0ustar mdenesmdenesval negb : bool -> bool type nat = | O | S of nat val app : 'a1 list -> 'a1 list -> 'a1 list type comparison = | Eq | Lt | Gt val compOpp : comparison -> comparison val add : nat -> nat -> nat type positive = | XI of positive | XO of positive | XH type n = | N0 | Npos of positive type z = | Z0 | Zpos of positive | Zneg of positive module Pos : sig type mask = | IsNul | IsPos of positive | IsNeg end module Coq_Pos : sig val succ : positive -> positive val add : positive -> positive -> positive val add_carry : positive -> positive -> positive val pred_double : positive -> positive type mask = Pos.mask = | IsNul | IsPos of positive | IsNeg val succ_double_mask : mask -> mask val double_mask : mask -> mask val double_pred_mask : positive -> mask val sub_mask : positive -> positive -> mask val sub_mask_carry : positive -> positive -> mask val sub : positive -> positive -> positive val mul : positive -> positive -> positive val size_nat : positive -> nat val compare_cont : comparison -> positive -> positive -> comparison val compare : positive -> positive -> comparison val gcdn : nat -> positive -> positive -> positive val gcd : positive -> positive -> positive val of_succ_nat : nat -> positive end module N : sig val of_nat : nat -> n end val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 val nth : nat -> 'a1 list -> 'a1 -> 'a1 val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 module Z : sig val double : z -> z val succ_double : z -> z val pred_double : z -> z val pos_sub : positive -> positive -> z val add : z -> z -> z val opp : z -> z val sub : z -> z -> z val mul : z -> z -> z val compare : z -> z -> comparison val leb : z -> z -> bool val ltb : z -> z -> bool val gtb : z -> z -> bool val max : z -> z -> z val abs : z -> z val to_N : z -> n val pos_div_eucl : positive -> z -> z * z val div_eucl : z -> z -> z * z val div : z -> z -> z val gcd : z -> z -> z end val zeq_bool : z -> z -> bool type 'c pol = | Pc of 'c | Pinj of positive * 'c pol | PX of 'c pol * positive * 'c pol val p0 : 'a1 -> 'a1 pol val p1 : 'a1 -> 'a1 pol val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool val mkPinj : positive -> 'a1 pol -> 'a1 pol val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol val mkPX : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol val mkX : 'a1 -> 'a1 -> 'a1 pol val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val paddI : ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val psubI : ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val paddX : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val psubX : 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val psub : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulI : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val pmul : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val psquare : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol type 'c pExpr = | PEc of 'c | PEX of positive | PEadd of 'c pExpr * 'c pExpr | PEsub of 'c pExpr * 'c pExpr | PEmul of 'c pExpr * 'c pExpr | PEopp of 'c pExpr | PEpow of 'c pExpr * n val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol val ppow_pos : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol val ppow_N : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol val norm_aux : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol type 'a bFormula = | TT | FF | X | A of 'a | Cj of 'a bFormula * 'a bFormula | D of 'a bFormula * 'a bFormula | N of 'a bFormula | I of 'a bFormula * 'a bFormula val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula type 'x clause = 'x list type 'x cnf = 'x clause list val tt : 'a1 cnf val ff : 'a1 cnf val add_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 clause option val or_clause : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> 'a1 clause option val or_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 cnf val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 cnf val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf val xcnf : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool val tauto_checker : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool type 'c polC = 'c pol type op1 = | Equal | NonEqual | Strict | NonStrict type 'c nFormula = 'c polC * op1 val opMult : op1 -> op1 -> op1 option val opAdd : op1 -> op1 -> op1 option type 'c psatz = | PsatzIn of nat | PsatzSquare of 'c polC | PsatzMulC of 'c polC * 'c psatz | PsatzMulE of 'c psatz * 'c psatz | PsatzAdd of 'c psatz * 'c psatz | PsatzC of 'c | PsatzZ val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option val nformula_times_nformula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option val nformula_plus_nformula : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option val eval_Psatz : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool val check_normalised_formulas : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool type op2 = | OpEq | OpNEq | OpLe | OpGe | OpLt | OpGt type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } val norm : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol val psub0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val xnormalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list val cnf_normalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula cnf val xnegate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list val cnf_negate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr val denorm : 'a1 pol -> 'a1 pExpr val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula val simpl_cone : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz type q = { qnum : z; qden : positive } val qnum : q -> z val qden : q -> positive val qeq_bool : q -> q -> bool val qle_bool : q -> q -> bool val qplus : q -> q -> q val qmult : q -> q -> q val qopp : q -> q val qminus : q -> q -> q val qinv : q -> q val qpower_positive : q -> positive -> q val qpower : q -> z -> q type 'a t = | Empty | Leaf of 'a | Node of 'a t * 'a * 'a t val find : 'a1 -> 'a1 t -> positive -> 'a1 val singleton : 'a1 -> positive -> 'a1 -> 'a1 t val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t type zWitness = z psatz val zWeakChecker : z nFormula list -> z psatz -> bool val psub1 : z pol -> z pol -> z pol val padd1 : z pol -> z pol -> z pol val norm0 : z pExpr -> z pol val xnormalise0 : z formula -> z nFormula list val normalise : z formula -> z nFormula cnf val xnegate0 : z formula -> z nFormula list val negate : z formula -> z nFormula cnf val zunsat : z nFormula -> bool val zdeduce : z nFormula -> z nFormula -> z nFormula option val ceiling : z -> z -> z type zArithProof = | DoneProof | RatProof of zWitness * zArithProof | CutProof of zWitness * zArithProof | EnumProof of zWitness * zWitness * zArithProof list val zgcdM : z -> z -> z val zgcd_pol : z polC -> z * z val zdiv_pol : z polC -> z -> z polC val makeCuttingPlane : z polC -> z polC * z val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula val is_pol_Z0 : z polC -> bool val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option val valid_cut_sign : op1 -> bool val zChecker : z nFormula list -> zArithProof -> bool val zTautoChecker : z formula bFormula -> zArithProof list -> bool type qWitness = q psatz val qWeakChecker : q nFormula list -> q psatz -> bool val qnormalise : q formula -> q nFormula cnf val qnegate : q formula -> q nFormula cnf val qunsat : q nFormula -> bool val qdeduce : q nFormula -> q nFormula -> q nFormula option val qTautoChecker : q formula bFormula -> qWitness list -> bool type rcst = | C0 | C1 | CQ of q | CZ of z | CPlus of rcst * rcst | CMinus of rcst * rcst | CMult of rcst * rcst | CInv of rcst | COpp of rcst val q_of_Rcst : rcst -> q type rWitness = q psatz val rWeakChecker : q nFormula list -> q psatz -> bool val rnormalise : q formula -> q nFormula cnf val rnegate : q formula -> q nFormula cnf val runsat : q nFormula -> bool val rdeduce : q nFormula -> q nFormula -> q nFormula option val rTautoChecker : rcst formula bFormula -> rWitness list -> bool coq-8.6/plugins/micromega/Lia.v0000644000175000017500000000325313022274260016002 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ) = add_num let (<->) = minus_num let (<*>) = mult_num module Monomial : sig type t val const : t val is_const : t -> bool val var : var -> t val is_var : t -> bool val find : var -> t -> int val mult : var -> t -> t val prod : t -> t -> t val exp : t -> int -> t val div : t -> t -> t * int val compare : t -> t -> int val pp : out_channel -> t -> unit val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a val sqrt : t -> t option end = struct (* A monomial is represented by a multiset of variables *) module Map = Map.Make(Int) open Map type t = int Map.t let pp o m = Map.iter (fun k v -> if v = 1 then Printf.fprintf o "x%i." k else Printf.fprintf o "x%i^%i." k v) m (* The monomial that corresponds to a constant *) let const = Map.empty let sum_degree m = Map.fold (fun _ n s -> s + n) m 0 (* Total ordering of monomials *) let compare: t -> t -> int = fun m1 m2 -> let s1 = sum_degree m1 and s2 = sum_degree m2 in if Int.equal s1 s2 then Map.compare Int.compare m1 m2 else Int.compare s1 s2 let is_const m = (m = Map.empty) (* The monomial 'x' *) let var x = Map.add x 1 Map.empty let is_var m = try not (Map.fold (fun _ i fk -> if fk = true (* first key *) then if i = 1 then false else raise Not_found else raise Not_found) m true) with Not_found -> false let sqrt m = if is_const m then None else try Some (Map.fold (fun v i acc -> let i' = i / 2 in if i mod 2 = 0 then add v i' m else raise Not_found) m const) with Not_found -> None (* Get the degre of a variable in a monomial *) let find x m = try find x m with Not_found -> 0 (* Multiply a monomial by a variable *) let mult x m = add x ( (find x m) + 1) m (* Product of monomials *) let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 let exp m n = let rec exp acc n = if n = 0 then acc else exp (prod acc m) (n - 1) in exp const n (* [div m1 m2 = mr,n] such that mr * (m2)^n = m1 *) let div m1 m2 = let n = fold (fun x i n -> let i' = find x m1 in let nx = i' / i in min n nx) m2 max_int in let mr = fold (fun x i' m -> let i = find x m2 in let ir = i' - i * n in if ir = 0 then m else add x ir m) m1 empty in (mr,n) let fold = fold end module Poly : (* A polynomial is a map of monomials *) (* This is probably a naive implementation (expected to be fast enough - Coq is probably the bottleneck) *The new ring contribution is using a sparse Horner representation. *) sig type t val get : Monomial.t -> t -> num val variable : var -> t val add : Monomial.t -> num -> t -> t val constant : num -> t val mult : Monomial.t -> num -> t -> t val product : t -> t -> t val addition : t -> t -> t val uminus : t -> t val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a val pp : out_channel -> t -> unit val compare : t -> t -> int val is_null : t -> bool val is_linear : t -> bool end = struct (*normalisation bug : 0*x ... *) module P = Map.Make(Monomial) open P type t = num P.t let pp o p = P.iter (fun k v -> if Monomial.compare Monomial.const k = 0 then Printf.fprintf o "%s " (string_of_num v) else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p (* Get the coefficient of monomial mn *) let get : Monomial.t -> t -> num = fun mn p -> try find mn p with Not_found -> (Int 0) (* The polynomial 1.x *) let variable : var -> t = fun x -> add (Monomial.var x) (Int 1) empty (*The constant polynomial *) let constant : num -> t = fun c -> add (Monomial.const) c empty (* The addition of a monomial *) let add : Monomial.t -> num -> t -> t = fun mn v p -> if sign_num v = 0 then p else let vl = (get mn p) <+> v in if sign_num vl = 0 then remove mn p else add mn vl p (** Design choice: empty is not a polynomial I do not remember why .... **) (* The product by a monomial *) let mult : Monomial.t -> num -> t -> t = fun mn v p -> if sign_num v = 0 then constant (Int 0) else fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty let addition : t -> t -> t = fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 let product : t -> t -> t = fun p1 p2 -> fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty let uminus : t -> t = fun p -> map (fun v -> minus_num v) p let fold = P.fold let is_null p = fold (fun mn vl b -> b && sign_num vl = 0) p true let compare = compare compare_num let is_linear p = P.fold (fun m _ acc -> acc && (Monomial.is_const m || Monomial.is_var m)) p true (* let is_linear p = let res = is_linear p in Printf.printf "is_linear %a = %b\n" pp p res ; res *) end module Vect = struct (** [t] is the type of vectors. A vector [(x1,v1) ; ... ; (xn,vn)] is such that: - variables indexes are ordered (x1 true | [] , _ -> false | _::_ , [] -> false | (i1,n1)::v1 , (i2,n2)::v2 -> (Int.equal i1 i2) && n1 =/ n2 && equal v1 v2 let hash v = let rec hash i = function | [] -> i | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in Hashtbl.hash (hash 0 v ) let null = [] let pp_vect o vect = List.iter (fun (v,n) -> Printf.printf "%sx%i + " (string_of_num n) v) vect let from_list (l: num list) = let rec xfrom_list i l = match l with | [] -> [] | e::l -> if e <>/ Int 0 then (i,e)::(xfrom_list (i+1) l) else xfrom_list (i+1) l in xfrom_list 0 l let zero_num = Int 0 let unit_num = Int 1 let to_list m = let rec xto_list i l = match l with | [] -> [] | (x,v)::l' -> if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in xto_list 0 m let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst let rec update i f t = match t with | [] -> cons i (f zero_num) [] | (k,v)::l -> match Int.compare i k with | 0 -> cons k (f v) l | -1 -> cons i (f zero_num) t | 1 -> (k,v) ::(update i f l) | _ -> failwith "compare_num" let rec set i n t = match t with | [] -> cons i n [] | (k,v)::l -> match Int.compare i k with | 0 -> cons k n l | -1 -> cons i n t | 1 -> (k,v) :: (set i n l) | _ -> failwith "compare_num" let gcd m = let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Utils.numerator e)) Big_int.zero_big_int m in if Big_int.compare_big_int res Big_int.zero_big_int = 0 then Big_int.unit_big_int else res let mul z t = match z with | Int 0 -> [] | Int 1 -> t | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t let rec add v1 v2 = match v1 , v2 with | (x1,n1)::v1' , (x2,n2)::v2' -> if x1 = x2 then let n' = n1 +/ n2 in if n' =/ Int 0 then add v1' v2' else let res = add v1' v2' in (x1,n') ::res else if x1 < x2 then let res = add v1' v2 in (x1, n1)::res else let res = add v1 v2' in (x2, n2)::res | [] , [] -> [] | [] , _ -> v2 | _ , [] -> v1 let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical [ (fun () -> Int.compare (fst x) (fst y)); (fun () -> compare_num (snd x) (snd y))]) (** [tail v vect] returns - [None] if [v] is not a variable of the vector [vect] - [Some(vl,rst)] where [vl] is the value of [v] in vector [vect] and [rst] is the remaining of the vector We exploit that vectors are ordered lists *) let rec tail (v:var) (vect:t) = match vect with | [] -> None | (v',vl)::vect' -> match Int.compare v' v with | 0 -> Some (vl,vect) (* Ok, found *) | -1 -> tail v vect' (* Might be in the tail *) | _ -> None (* Hopeless *) let get v vect = match tail v vect with | None -> None | Some(vl,_) -> Some vl let rec fresh v = match v with | [] -> 1 | [v,_] -> v + 1 | _::v -> fresh v end type vector = Vect.t type cstr_compat = {coeffs : vector ; op : op ; cst : num} and op = |Eq | Ge let string_of_op = function Eq -> "=" | Ge -> ">=" let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = Printf.fprintf o "%a %s %s" Vect.pp_vect coeffs (string_of_op op) (string_of_num cst) let opMult o1 o2 = match o1, o2 with | Eq , Eq -> Eq | Eq , Ge | Ge , Eq -> Ge | Ge , Ge -> Ge let opAdd o1 o2 = match o1 , o2 with | Eq , _ | _ , Eq -> Eq | Ge , Ge -> Ge open Big_int type index = int type prf_rule = | Hyp of int | Def of int | Cst of big_int | Zero | Square of (Vect.t * num) | MulC of (Vect.t * num) * prf_rule | Gcd of big_int * prf_rule | MulPrf of prf_rule * prf_rule | AddPrf of prf_rule * prf_rule | CutPrf of prf_rule type proof = | Done | Step of int * prf_rule * proof | Enum of int * prf_rule * Vect.t * prf_rule * proof list let rec output_prf_rule o = function | Hyp i -> Printf.fprintf o "Hyp %i" i | Def i -> Printf.fprintf o "Def %i" i | Cst c -> Printf.fprintf o "Cst %s" (string_of_big_int c) | Zero -> Printf.fprintf o "Zero" | Square _ -> Printf.fprintf o "( )^2" | MulC(p,pr) -> Printf.fprintf o "P * %a" output_prf_rule pr | MulPrf(p1,p2) -> Printf.fprintf o "%a * %a" output_prf_rule p1 output_prf_rule p2 | AddPrf(p1,p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2 | CutPrf(p) -> Printf.fprintf o "[%a]" output_prf_rule p | Gcd(c,p) -> Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c) let rec output_proof o = function | Done -> Printf.fprintf o "." | Step(i,p,pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf | Enum(i,p1,v,p2,pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i output_prf_rule p1 Vect.pp_vect v output_prf_rule p2 (pp_list output_proof) pl let rec pr_rule_max_id = function | Hyp i | Def i -> i | Cst _ | Zero | Square _ -> -1 | MulC(_,p) | CutPrf p | Gcd(_,p) -> pr_rule_max_id p | MulPrf(p1,p2)| AddPrf(p1,p2) -> max (pr_rule_max_id p1) (pr_rule_max_id p2) let rec proof_max_id = function | Done -> -1 | Step(i,pr,prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) | Enum(i,p1,_,p2,l) -> let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l let rec pr_rule_def_cut id = function | MulC(p,prf) -> let (bds,id',prf') = pr_rule_def_cut id prf in (bds, id', MulC(p,prf')) | MulPrf(p1,p2) -> let (bds1,id,p1) = pr_rule_def_cut id p1 in let (bds2,id,p2) = pr_rule_def_cut id p2 in (bds2@bds1,id,MulPrf(p1,p2)) | AddPrf(p1,p2) -> let (bds1,id,p1) = pr_rule_def_cut id p1 in let (bds2,id,p2) = pr_rule_def_cut id p2 in (bds2@bds1,id,AddPrf(p1,p2)) | CutPrf p -> let (bds,id,p) = pr_rule_def_cut id p in ((id,p)::bds,id+1,Def id) | Gcd(c,p) -> let (bds,id,p) = pr_rule_def_cut id p in ((id,p)::bds,id+1,Def id) | Square _|Cst _|Def _|Hyp _|Zero as x -> ([],id,x) (* Do not define top-level cuts *) let pr_rule_def_cut id = function | CutPrf p -> let (bds,ids,p') = pr_rule_def_cut id p in bds,ids, CutPrf p' | p -> pr_rule_def_cut id p let rec implicit_cut p = match p with | CutPrf p -> implicit_cut p | _ -> p let rec normalise_proof id prf = match prf with | Done -> (id,Done) | Step(i,Gcd(c,p),Done) -> normalise_proof id (Step(i,p,Done)) | Step(i,p,prf) -> let bds,id,p' = pr_rule_def_cut id p in let (id,prf) = normalise_proof id prf in let prf = List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) (Step(i,p',prf)) bds in (id,prf) | Enum(i,p1,v,p2,pl) -> (* Why do I have top-level cuts ? *) (* let p1 = implicit_cut p1 in let p2 = implicit_cut p2 in let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in (List.fold_left max 0 ids , Enum(i,p1,v,p2,prfs)) *) let bds1,id,p1' = pr_rule_def_cut id (implicit_cut p1) in let bds2,id,p2' = pr_rule_def_cut id (implicit_cut p2) in let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in (List.fold_left max 0 ids , List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) (Enum(i,p1',v,p2',prfs)) (bds2@bds1)) let normalise_proof id prf = let res = normalise_proof id prf in if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ; res let add_proof x y = match x, y with | Zero , p | p , Zero -> p | _ -> AddPrf(x,y) let mul_proof c p = match sign_big_int c with | 0 -> Zero (* This is likely to be a bug *) | -1 -> MulC(([],Big_int c),p) (* [p] should represent an equality *) | 1 -> if eq_big_int c unit_big_int then p else MulPrf(Cst c,p) | _ -> assert false let mul_proof_ext (p,c) prf = match p with | [] -> mul_proof (numerator c) prf | _ -> MulC((p,c),prf) (* let rec scale_prf_rule = function | Hyp i -> (unit_big_int, Hyp i) | Def i -> (unit_big_int, Def i) | Cst c -> (unit_big_int, Cst i) | Zero -> (unit_big_int, Zero) | Square p -> (unit_big_int,Square p) | Div(c,pr) -> let (bi,pr') = scale_prf_rule pr in (mult_big_int c bi , pr') | MulC(p,pr) -> let bi,pr' = scale_prf_rule pr in (bi,MulC p,pr') | MulPrf(p1,p2) -> let b1,p1 = scale_prf_rule p1 in let b2,p2 = scale_prf_rule p2 in | AddPrf(p1,p2) -> let b1,p1 = scale_prf_rule p1 in let b2,p2 = scale_prf_rule p2 in let g = gcd_big_int *) module LinPoly = struct type t = Vect.t * num module MonT = struct module MonoMap = Map.Make(Monomial) module IntMap = Map.Make(Int) (** A hash table might be preferable but requires a hash function. *) let (index_of_monomial : int MonoMap.t ref) = ref (MonoMap.empty) let (monomial_of_index : Monomial.t IntMap.t ref) = ref (IntMap.empty) let fresh = ref 0 let clear () = index_of_monomial := MonoMap.empty; monomial_of_index := IntMap.empty ; fresh := 0 let register m = try MonoMap.find m !index_of_monomial with Not_found -> begin let res = !fresh in index_of_monomial := MonoMap.add m res !index_of_monomial ; monomial_of_index := IntMap.add res m !monomial_of_index ; incr fresh ; res end let retrieve i = IntMap.find i !monomial_of_index end let normalise (v,c) = (List.sort (fun x y -> Int.compare (fst x) (fst y)) v , c) let output_mon o (x,v) = Printf.fprintf o "%s.%a +" (string_of_num v) Monomial.pp (MonT.retrieve x) let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = Printf.fprintf o "%a %s %s" (pp_list output_mon) coeffs (string_of_op op) (string_of_num cst) let linpol_of_pol p = let (v,c) = Poly.fold (fun mon num (vct,cst) -> if Monomial.is_const mon then (vct,num) else let vr = MonT.register mon in ((vr,num)::vct,cst)) p ([], Int 0) in normalise (v,c) let mult v m (vect,c) = if Monomial.is_const m then (Vect.mul v vect, v <*> c) else if sign_num v <> 0 then let hd = if sign_num c <> 0 then [MonT.register m,v <*> c] else [] in let vect = hd @ (List.map (fun (x,n) -> let x = MonT.retrieve x in let x_m = MonT.register (Monomial.prod m x) in (x_m, v <*> n)) vect ) in normalise (vect , Int 0) else ([],Int 0) let mult v m (vect,c) = let (vect',c') = mult v m (vect,c) in if debug then Printf.printf "mult %s %a (%a,%s) -> (%a,%s)\n" (string_of_num v) Monomial.pp m (pp_list output_mon) vect (string_of_num c) (pp_list output_mon) vect' (string_of_num c') ; (vect',c') let make_lin_pol v mon = if Monomial.is_const mon then [] , v else [MonT.register mon, v],Int 0 let xpivot_eq (c,prf) x v (c',prf') = if debug then Printf.printf "xpivot_eq {%a} %a %s {%a}\n" output_cstr c Monomial.pp (MonT.retrieve x) (string_of_num v) output_cstr c' ; let {coeffs = coeffs ; op = op ; cst = cst} = c' in let m = MonT.retrieve x in let apply_pivot (vqn,q,n) (c',prf') = (* Morally, we have (Vect.get (q*x^n) c'.coeffs) = vmn with n >=0 *) let cc' = abs_num v in let cc_num = Int (- (sign_num v)) <*> vqn in let cc_mon = Monomial.prod q (Monomial.exp m (n-1)) in let (c_coeff,c_cst) = mult cc_num cc_mon (c.coeffs, minus_num c.cst) in let c' = {coeffs = Vect.add (Vect.mul cc' c'.coeffs) c_coeff ; op = op ; cst = (minus_num c_cst) <+> (cc' <*> c'.cst)} in let prf' = add_proof (mul_proof_ext (make_lin_pol cc_num cc_mon) prf) (mul_proof (numerator cc') prf') in if debug then Printf.printf "apply_pivot -> {%a}\n" output_cstr c' ; (c',prf') in let cmp (q,n) (q',n') = if n < n' then -1 else if n = n' then Monomial.compare q q' else 1 in let find_pivot (c',prf') = let (v,q,n) = List.fold_left (fun (v,q,n) (x,v') -> let x = MonT.retrieve x in let (q',n') = Monomial.div x m in if cmp (q,n) (q',n') = -1 then (v',q',n') else (v,q,n)) (Int 0, Monomial.const,0) c'.coeffs in if n > 0 then Some (v,q,n) else None in let rec pivot (q,n) (c',prf') = match find_pivot (c',prf') with | None -> (c',prf') | Some(v,q',n') -> if cmp (q',n') (q,n) = -1 then pivot (q',n') (apply_pivot (v,q',n') (c',prf')) else (c',prf') in pivot (Monomial.const,max_int) (c',prf') let pivot_eq x (c,prf) = match Vect.get x c.coeffs with | None -> (fun x -> None) | Some v -> fun cp' -> Some (xpivot_eq (c,prf) x v cp') end coq-8.6/plugins/micromega/RMicromega.v0000644000175000017500000003301413022274260017320 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (IZR (Qnum x) * / IZR (' Qden x))%R. Lemma Rinv_elim : forall x y z, y <> 0 -> (z * y = x <-> x * / y = z). Proof. intros. split ; intros. subst. rewrite Rmult_assoc. rewrite Rinv_r; auto. ring. subst. rewrite Rmult_assoc. rewrite (Rmult_comm (/ y)). rewrite Rinv_r ; auto. ring. Qed. Ltac INR_nat_of_P := match goal with | H : context[INR (Pos.to_nat ?X)] |- _ => revert H ; let HH := fresh in assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) | |- context[INR (Pos.to_nat ?X)] => let HH := fresh in assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) end. Ltac add_eq expr val := set (temp := expr) ; generalize (eq_refl temp) ; unfold temp at 1 ; generalize temp ; intro val ; clear temp. Ltac Rinv_elim := match goal with | |- context[?x * / ?y] => let z := fresh "v" in add_eq (x * / y) z ; let H := fresh in intro H ; rewrite <- Rinv_elim in H end. Lemma Rlt_neq : forall r , 0 < r -> r <> 0. Proof. red. intros. subst. apply (Rlt_irrefl 0 H). Qed. Lemma Rinv_1 : forall x, x * / 1 = x. Proof. intro. Rinv_elim. subst ; ring. apply R1_neq_R0. Qed. Lemma Qeq_true : forall x y, Qeq_bool x y = true -> IQR x = IQR y. Proof. unfold IQR. simpl. intros. apply Qeq_bool_eq in H. unfold Qeq in H. assert (IZR (Qnum x * ' Qden y) = IZR (Qnum y * ' Qden x))%Z. rewrite H. reflexivity. repeat rewrite mult_IZR in H0. simpl in H0. revert H0. repeat INR_nat_of_P. intros. apply Rinv_elim in H2 ; [| apply Rlt_neq ; auto]. rewrite <- H2. field. split ; apply Rlt_neq ; auto. Qed. Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y. Proof. intros. apply Qeq_bool_neq in H. intro. apply H. clear H. unfold Qeq,IQR in *. simpl in *. revert H0. repeat Rinv_elim. intros. subst. assert (IZR (Qnum x * ' Qden y)%Z = IZR (Qnum y * ' Qden x)%Z). repeat rewrite mult_IZR. simpl. rewrite <- H0. rewrite <- H. ring. apply eq_IZR ; auto. INR_nat_of_P; intros; apply Rlt_neq ; auto. INR_nat_of_P; intros ; apply Rlt_neq ; auto. Qed. Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y. Proof. intros. apply Qle_bool_imp_le in H. unfold Qle in H. unfold IQR. simpl in *. apply IZR_le in H. repeat rewrite mult_IZR in H. simpl in H. repeat INR_nat_of_P; intros. assert (Hr := Rlt_neq r H). assert (Hr0 := Rlt_neq r0 H0). replace (IZR (Qnum x) * / r) with ((IZR (Qnum x) * r0) * (/r * /r0)). replace (IZR (Qnum y) * / r0) with ((IZR (Qnum y) * r) * (/r * /r0)). apply Rmult_le_compat_r ; auto. apply Rmult_le_pos. unfold Rle. left. apply Rinv_0_lt_compat ; auto. unfold Rle. left. apply Rinv_0_lt_compat ; auto. field ; intuition. field ; intuition. Qed. Lemma IQR_0 : IQR 0 = 0. Proof. compute. apply Rinv_1. Qed. Lemma IQR_1 : IQR 1 = 1. Proof. compute. apply Rinv_1. Qed. Lemma IQR_plus : forall x y, IQR (x + y) = IQR x + IQR y. Proof. intros. unfold IQR. simpl in *. rewrite plus_IZR in *. rewrite mult_IZR in *. simpl. rewrite Pos2Nat.inj_mul. rewrite mult_INR. rewrite mult_IZR. simpl. repeat INR_nat_of_P. intros. field. split ; apply Rlt_neq ; auto. Qed. Lemma IQR_opp : forall x, IQR (- x) = - IQR x. Proof. intros. unfold IQR. simpl. rewrite opp_IZR. ring. Qed. Lemma IQR_minus : forall x y, IQR (x - y) = IQR x - IQR y. Proof. intros. unfold Qminus. rewrite IQR_plus. rewrite IQR_opp. ring. Qed. Lemma IQR_mult : forall x y, IQR (x * y) = IQR x * IQR y. Proof. unfold IQR ; intros. simpl. repeat rewrite mult_IZR. rewrite Pos2Nat.inj_mul. rewrite mult_INR. repeat INR_nat_of_P. intros. field ; split ; apply Rlt_neq ; auto. Qed. Lemma IQR_inv_lt : forall x, (0 < x)%Q -> IQR (/ x) = / IQR x. Proof. unfold IQR ; simpl. intros. unfold Qlt in H. revert H. simpl. intros. unfold Qinv. destruct x. destruct Qnum ; simpl in *. exfalso. auto with zarith. clear H. repeat INR_nat_of_P. intros. assert (HH := Rlt_neq _ H). assert (HH0 := Rlt_neq _ H0). rewrite Rinv_mult_distr ; auto. rewrite Rinv_involutive ; auto. ring. apply Rinv_0_lt_compat in H0. apply Rlt_neq ; auto. simpl in H. exfalso. rewrite Pos.mul_comm in H. compute in H. discriminate. Qed. Lemma Qinv_opp : forall x, (- (/ x) = / ( -x))%Q. Proof. destruct x ; destruct Qnum ; reflexivity. Qed. Lemma Qopp_involutive_strong : forall x, (- - x = x)%Q. Proof. intros. destruct x. unfold Qopp. simpl. rewrite Z.opp_involutive. reflexivity. Qed. Lemma Ropp_0 : forall r , - r = 0 -> r = 0. Proof. intros. rewrite <- (Ropp_involutive r). apply Ropp_eq_0_compat ; auto. Qed. Lemma IQR_x_0 : forall x, IQR x = 0 -> x == 0%Q. Proof. destruct x ; simpl. unfold IQR. simpl. INR_nat_of_P. intros. apply Rmult_integral in H0. destruct H0. apply eq_IZR_R0 in H0. subst. reflexivity. exfalso. apply Rinv_0_lt_compat in H. rewrite <- H0 in H. apply Rlt_irrefl in H. auto. Qed. Lemma IQR_inv_gt : forall x, (0 > x)%Q -> IQR (/ x) = / IQR x. Proof. intros. rewrite <- (Qopp_involutive_strong x). rewrite <- Qinv_opp. rewrite IQR_opp. rewrite IQR_inv_lt. repeat rewrite IQR_opp. rewrite Ropp_inv_permute. auto. intro. apply Ropp_0 in H0. apply IQR_x_0 in H0. rewrite H0 in H. compute in H. discriminate. unfold Qlt in *. destruct x ; simpl in *. auto with zarith. Qed. Lemma IQR_inv : forall x, ~ x == 0 -> IQR (/ x) = / IQR x. Proof. intros. assert ( 0 > x \/ 0 < x)%Q. destruct x ; unfold Qlt, Qeq in * ; simpl in *. rewrite Z.mul_1_r in *. destruct Qnum ; simpl in * ; intuition auto. right. reflexivity. left ; reflexivity. destruct H0. apply IQR_inv_gt ; auto. apply IQR_inv_lt ; auto. Qed. Lemma IQR_inv_ext : forall x, IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x). Proof. intros. case_eq (Qeq_bool x 0). intros. apply Qeq_bool_eq in H. destruct x ; simpl. unfold Qeq in H. simpl in H. replace Qnum with 0%Z. compute. rewrite Rinv_1. reflexivity. rewrite <- H. ring. intros. apply IQR_inv. intro. rewrite <- Qeq_bool_iff in H0. congruence. Qed. Notation to_nat := N.to_nat. Lemma QSORaddon : @SORaddon R R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle (* ring elements *) Q 0%Q 1%Q Qplus Qmult Qminus Qopp (* coefficients *) Qeq_bool Qle_bool IQR nat to_nat pow. Proof. constructor. constructor ; intros ; try reflexivity. apply IQR_0. apply IQR_1. apply IQR_plus. apply IQR_minus. apply IQR_mult. apply IQR_opp. apply Qeq_true ; auto. apply R_power_theory. apply Qeq_false. apply Qle_true. Qed. (* Syntactic ring coefficients. For computing, we use Q. *) Inductive Rcst := | C0 | C1 | CQ (r : Q) | CZ (r : Z) | CPlus (r1 r2 : Rcst) | CMinus (r1 r2 : Rcst) | CMult (r1 r2 : Rcst) | CInv (r : Rcst) | COpp (r : Rcst). Fixpoint Q_of_Rcst (r : Rcst) : Q := match r with | C0 => 0 # 1 | C1 => 1 # 1 | CZ z => z # 1 | CQ q => q | CPlus r1 r2 => Qplus (Q_of_Rcst r1) (Q_of_Rcst r2) | CMinus r1 r2 => Qminus (Q_of_Rcst r1) (Q_of_Rcst r2) | CMult r1 r2 => Qmult (Q_of_Rcst r1) (Q_of_Rcst r2) | CInv r => Qinv (Q_of_Rcst r) | COpp r => Qopp (Q_of_Rcst r) end. Fixpoint R_of_Rcst (r : Rcst) : R := match r with | C0 => R0 | C1 => R1 | CZ z => IZR z | CQ q => IQR q | CPlus r1 r2 => (R_of_Rcst r1) + (R_of_Rcst r2) | CMinus r1 r2 => (R_of_Rcst r1) - (R_of_Rcst r2) | CMult r1 r2 => (R_of_Rcst r1) * (R_of_Rcst r2) | CInv r => if Qeq_bool (Q_of_Rcst r) (0 # 1) then R0 else Rinv (R_of_Rcst r) | COpp r => - (R_of_Rcst r) end. Lemma Q_of_RcstR : forall c, IQR (Q_of_Rcst c) = R_of_Rcst c. Proof. induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2). apply IQR_0. apply IQR_1. reflexivity. unfold IQR. simpl. rewrite Rinv_1. reflexivity. apply IQR_plus. apply IQR_minus. apply IQR_mult. rewrite <- IHc. apply IQR_inv_ext. rewrite <- IHc. apply IQR_opp. Qed. Require Import EnvRing. Definition INZ (n:N) : R := match n with | N0 => IZR 0%Z | Npos p => IZR (Zpos p) end. Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp R_of_Rcst N.to_nat pow. Definition Reval_op2 (o:Op2) : R -> R -> Prop := match o with | OpEq => @eq R | OpNEq => fun x y => ~ x = y | OpLe => Rle | OpGe => Rge | OpLt => Rlt | OpGt => Rgt end. Definition Reval_formula (e: PolEnv R) (ff : Formula Rcst) := let (lhs,o,rhs) := ff in Reval_op2 o (Reval_expr e lhs) (Reval_expr e rhs). Definition Reval_formula' := eval_sformula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt N.to_nat pow R_of_Rcst. Definition QReval_formula := eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IQR N.to_nat pow . Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f. Proof. intros. unfold Reval_formula. destruct f. unfold Reval_formula'. unfold Reval_expr. split ; destruct Fop ; simpl ; auto. apply Rge_le. apply Rle_ge. Qed. Definition Qeval_nformula := eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt IQR. Lemma Reval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). Proof. exact (fun env d =>eval_nformula_dec Rsor IQR env d). Qed. Definition RWitness := Psatz Q. Definition RWeakChecker := check_normalised_formulas 0%Q 1%Q Qplus Qmult Qeq_bool Qle_bool. Require Import List. Lemma RWeakChecker_sound : forall (l : list (NFormula Q)) (cm : RWitness), RWeakChecker l cm = true -> forall env, make_impl (Qeval_nformula env) l False. Proof. intros l cm H. intro. unfold Qeval_nformula. apply (checker_nf_sound Rsor QSORaddon l cm). unfold RWeakChecker in H. exact H. Qed. Require Import Coq.micromega.Tauto. Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. Definition runsat := check_inconsistent 0%Q Qeq_bool Qle_bool. Definition rdeduce := nformula_plus_nformula 0%Q Qplus Qeq_bool. Definition RTautoChecker (f : BFormula (Formula Rcst)) (w: list RWitness) : bool := @tauto_checker (Formula Q) (NFormula Q) runsat rdeduce Rnormalise Rnegate RWitness RWeakChecker (map_bformula (map_Formula Q_of_Rcst) f) w. Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f (Reval_formula env) f. Proof. intros f w. unfold RTautoChecker. intros TC env. apply (tauto_checker_sound QReval_formula Qeval_nformula) with (env := env) in TC. rewrite eval_f_map in TC. rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto. intro. unfold QReval_formula. rewrite <- eval_formulaSC with (phiS := R_of_Rcst). rewrite Reval_formula_compat. tauto. intro. rewrite Q_of_RcstR. reflexivity. apply Reval_nformula_dec. destruct t. apply (check_inconsistent_sound Rsor QSORaddon) ; auto. unfold rdeduce. apply (nformula_plus_nformula_correct Rsor QSORaddon). now apply (cnf_normalise_correct Rsor QSORaddon). intros. now apply (cnf_negate_correct Rsor QSORaddon). intros t w0. apply RWeakChecker_sound. Qed. (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/micromega/sos.ml0000644000175000017500000022222613022274260016247 0ustar mdenesmdenes(* ========================================================================= *) (* - This code originates from John Harrison's HOL LIGHT 2.30 *) (* (see file LICENSE.sos for license, copyright and disclaimer) *) (* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL *) (* independent bits *) (* - Frédéric Besson (fbesson@irisa.fr) is using it to feed micromega *) (* ========================================================================= *) (* ========================================================================= *) (* Nonlinear universal reals procedure using SOS decomposition. *) (* ========================================================================= *) open Num;; open Sos_types;; open Sos_lib;; (* prioritize_real();; *) let debugging = ref false;; exception Sanity;; exception Unsolvable;; (* ------------------------------------------------------------------------- *) (* Turn a rational into a decimal string with d sig digits. *) (* ------------------------------------------------------------------------- *) let decimalize = let rec normalize y = if abs_num y =/ Int 1 then normalize (y // Int 10) + 1 else 0 in fun d x -> if x =/ Int 0 then "0.0" else let y = abs_num x in let e = normalize y in let z = pow10(-e) */ y +/ Int 1 in let k = round_num(pow10 d */ z) in (if x a | h::t -> itern (k + 1) t f (f h k a);; let rec iter (m,n) f a = if n < m then a else iter (m+1,n) f (f m a);; (* ------------------------------------------------------------------------- *) (* The main types. *) (* ------------------------------------------------------------------------- *) type vector = int*(int,num)func;; type matrix = (int*int)*(int*int,num)func;; type monomial = (vname,int)func;; type poly = (monomial,num)func;; (* ------------------------------------------------------------------------- *) (* Assignment avoiding zeros. *) (* ------------------------------------------------------------------------- *) let (|-->) x y a = if y =/ Int 0 then a else (x |-> y) a;; (* ------------------------------------------------------------------------- *) (* This can be generic. *) (* ------------------------------------------------------------------------- *) let element (d,v) i = tryapplyd v i (Int 0);; let mapa f (d,v) = d,foldl (fun a i c -> (i |--> f(c)) a) undefined v;; let is_zero (d,v) = match v with Empty -> true | _ -> false;; (* ------------------------------------------------------------------------- *) (* Vectors. Conventionally indexed 1..n. *) (* ------------------------------------------------------------------------- *) let vector_0 n = (n,undefined:vector);; let dim (v:vector) = fst v;; let vector_const c n = if c =/ Int 0 then vector_0 n else (n,itlist (fun k -> k |-> c) (1--n) undefined :vector);; let vector_1 = vector_const (Int 1);; let vector_cmul c (v:vector) = let n = dim v in if c =/ Int 0 then vector_0 n else n,mapf (fun x -> c */ x) (snd v) let vector_neg (v:vector) = (fst v,mapf minus_num (snd v) :vector);; let vector_add (v1:vector) (v2:vector) = let m = dim v1 and n = dim v2 in if m <> n then failwith "vector_add: incompatible dimensions" else (n,combine (+/) (fun x -> x =/ Int 0) (snd v1) (snd v2) :vector);; let vector_sub v1 v2 = vector_add v1 (vector_neg v2);; let vector_dot (v1:vector) (v2:vector) = let m = dim v1 and n = dim v2 in if m <> n then failwith "vector_add: incompatible dimensions" else foldl (fun a i x -> x +/ a) (Int 0) (combine ( */ ) (fun x -> x =/ Int 0) (snd v1) (snd v2));; let vector_of_list l = let n = List.length l in (n,itlist2 (|->) (1--n) l undefined :vector);; (* ------------------------------------------------------------------------- *) (* Matrices; again rows and columns indexed from 1. *) (* ------------------------------------------------------------------------- *) let matrix_0 (m,n) = ((m,n),undefined:matrix);; let dimensions (m:matrix) = fst m;; let matrix_const c (m,n as mn) = if m <> n then failwith "matrix_const: needs to be square" else if c =/ Int 0 then matrix_0 mn else (mn,itlist (fun k -> (k,k) |-> c) (1--n) undefined :matrix);; let matrix_1 = matrix_const (Int 1);; let matrix_cmul c (m:matrix) = let (i,j) = dimensions m in if c =/ Int 0 then matrix_0 (i,j) else (i,j),mapf (fun x -> c */ x) (snd m);; let matrix_neg (m:matrix) = (dimensions m,mapf minus_num (snd m) :matrix);; let matrix_add (m1:matrix) (m2:matrix) = let d1 = dimensions m1 and d2 = dimensions m2 in if d1 <> d2 then failwith "matrix_add: incompatible dimensions" else (d1,combine (+/) (fun x -> x =/ Int 0) (snd m1) (snd m2) :matrix);; let matrix_sub m1 m2 = matrix_add m1 (matrix_neg m2);; let row k (m:matrix) = let i,j = dimensions m in (j, foldl (fun a (i,j) c -> if i = k then (j |-> c) a else a) undefined (snd m) : vector);; let column k (m:matrix) = let i,j = dimensions m in (i, foldl (fun a (i,j) c -> if j = k then (i |-> c) a else a) undefined (snd m) : vector);; let transp (m:matrix) = let i,j = dimensions m in ((j,i),foldl (fun a (i,j) c -> ((j,i) |-> c) a) undefined (snd m) :matrix);; let diagonal (v:vector) = let n = dim v in ((n,n),foldl (fun a i c -> ((i,i) |-> c) a) undefined (snd v) : matrix);; let matrix_of_list l = let m = List.length l in if m = 0 then matrix_0 (0,0) else let n = List.length (List.hd l) in (m,n),itern 1 l (fun v i -> itern 1 v (fun c j -> (i,j) |-> c)) undefined;; (* ------------------------------------------------------------------------- *) (* Monomials. *) (* ------------------------------------------------------------------------- *) let monomial_eval assig (m:monomial) = foldl (fun a x k -> a */ power_num (apply assig x) (Int k)) (Int 1) m;; let monomial_1 = (undefined:monomial);; let monomial_var x = (x |=> 1 :monomial);; let (monomial_mul:monomial->monomial->monomial) = combine (+) (fun x -> false);; let monomial_pow (m:monomial) k = if k = 0 then monomial_1 else mapf (fun x -> k * x) m;; let monomial_divides (m1:monomial) (m2:monomial) = foldl (fun a x k -> tryapplyd m2 x 0 >= k && a) true m1;; let monomial_div (m1:monomial) (m2:monomial) = let m = combine (+) (fun x -> x = 0) m1 (mapf (fun x -> -x) m2) in if foldl (fun a x k -> k >= 0 && a) true m then m else failwith "monomial_div: non-divisible";; let monomial_degree x (m:monomial) = tryapplyd m x 0;; let monomial_lcm (m1:monomial) (m2:monomial) = (itlist (fun x -> x |-> max (monomial_degree x m1) (monomial_degree x m2)) (union (dom m1) (dom m2)) undefined :monomial);; let monomial_multidegree (m:monomial) = foldl (fun a x k -> k + a) 0 m;; let monomial_variables m = dom m;; (* ------------------------------------------------------------------------- *) (* Polynomials. *) (* ------------------------------------------------------------------------- *) let eval assig (p:poly) = foldl (fun a m c -> a +/ c */ monomial_eval assig m) (Int 0) p;; let poly_0 = (undefined:poly);; let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 && a) true p;; let poly_var x = ((monomial_var x) |=> Int 1 :poly);; let poly_const c = if c =/ Int 0 then poly_0 else (monomial_1 |=> c);; let poly_cmul c (p:poly) = if c =/ Int 0 then poly_0 else mapf (fun x -> c */ x) p;; let poly_neg (p:poly) = (mapf minus_num p :poly);; let poly_add (p1:poly) (p2:poly) = (combine (+/) (fun x -> x =/ Int 0) p1 p2 :poly);; let poly_sub p1 p2 = poly_add p1 (poly_neg p2);; let poly_cmmul (c,m) (p:poly) = if c =/ Int 0 then poly_0 else if m = monomial_1 then mapf (fun d -> c */ d) p else foldl (fun a m' d -> (monomial_mul m m' |-> c */ d) a) poly_0 p;; let poly_mul (p1:poly) (p2:poly) = foldl (fun a m c -> poly_add (poly_cmmul (c,m) p2) a) poly_0 p1;; let poly_div (p1:poly) (p2:poly) = if not(poly_isconst p2) then failwith "poly_div: non-constant" else let c = eval undefined p2 in if c =/ Int 0 then failwith "poly_div: division by zero" else poly_cmul (Int 1 // c) p1;; let poly_square p = poly_mul p p;; let rec poly_pow p k = if k = 0 then poly_const (Int 1) else if k = 1 then p else let q = poly_square(poly_pow p (k / 2)) in if k mod 2 = 1 then poly_mul p q else q;; let poly_exp p1 p2 = if not(poly_isconst p2) then failwith "poly_exp: not a constant" else poly_pow p1 (Num.int_of_num (eval undefined p2));; let degree x (p:poly) = foldl (fun a m c -> max (monomial_degree x m) a) 0 p;; let multidegree (p:poly) = foldl (fun a m c -> max (monomial_multidegree m) a) 0 p;; let poly_variables (p:poly) = foldr (fun m c -> union (monomial_variables m)) p [];; (* ------------------------------------------------------------------------- *) (* Order monomials for human presentation. *) (* ------------------------------------------------------------------------- *) let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or x1 = x2 && k1 > k2;; let humanorder_monomial = let rec ord l1 l2 = match (l1,l2) with _,[] -> true | [],_ -> false | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or h1 = h2 && ord t1 t2 in fun m1 m2 -> m1 = m2 or ord (sort humanorder_varpow (graph m1)) (sort humanorder_varpow (graph m2));; (* ------------------------------------------------------------------------- *) (* Conversions to strings. *) (* ------------------------------------------------------------------------- *) let string_of_vector min_size max_size (v:vector) = let n_raw = dim v in if n_raw = 0 then "[]" else let n = max min_size (min n_raw max_size) in let xs = List.map ((o) string_of_num (element v)) (1--n) in "[" ^ end_itlist (fun s t -> s ^ ", " ^ t) xs ^ (if n_raw > max_size then ", ...]" else "]");; let string_of_matrix max_size (m:matrix) = let i_raw,j_raw = dimensions m in let i = min max_size i_raw and j = min max_size j_raw in let rstr = List.map (fun k -> string_of_vector j j (row k m)) (1--i) in "["^end_itlist(fun s t -> s^";\n "^t) rstr ^ (if j > max_size then "\n ...]" else "]");; let string_of_vname (v:vname): string = (v: string);; let rec string_of_term t = match t with Opp t1 -> "(- " ^ string_of_term t1 ^ ")" | Add (t1, t2) -> "(" ^ (string_of_term t1) ^ " + " ^ (string_of_term t2) ^ ")" | Sub (t1, t2) -> "(" ^ (string_of_term t1) ^ " - " ^ (string_of_term t2) ^ ")" | Mul (t1, t2) -> "(" ^ (string_of_term t1) ^ " * " ^ (string_of_term t2) ^ ")" | Inv t1 -> "(/ " ^ string_of_term t1 ^ ")" | Div (t1, t2) -> "(" ^ (string_of_term t1) ^ " / " ^ (string_of_term t2) ^ ")" | Pow (t1, n1) -> "(" ^ (string_of_term t1) ^ " ^ " ^ (string_of_int n1) ^ ")" | Zero -> "0" | Var v -> "x" ^ (string_of_vname v) | Const x -> string_of_num x;; let string_of_varpow x k = if k = 1 then string_of_vname x else string_of_vname x^"^"^string_of_int k;; let string_of_monomial m = if m = monomial_1 then "1" else let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a) (sort humanorder_varpow (graph m)) [] in end_itlist (fun s t -> s^"*"^t) vps;; let string_of_cmonomial (c,m) = if m = monomial_1 then string_of_num c else if c =/ Int 1 then string_of_monomial m else string_of_num c ^ "*" ^ string_of_monomial m;; let string_of_poly (p:poly) = if p = poly_0 then "<<0>>" else let cms = sort (fun (m1,_) (m2,_) -> humanorder_monomial m1 m2) (graph p) in let s = List.fold_left (fun a (m,c) -> if c >";; (* ------------------------------------------------------------------------- *) (* Printers. *) (* ------------------------------------------------------------------------- *) let print_vector v = Format.print_string(string_of_vector 0 20 v);; let print_matrix m = Format.print_string(string_of_matrix 20 m);; let print_monomial m = Format.print_string(string_of_monomial m);; let print_poly m = Format.print_string(string_of_poly m);; (* #install_printer print_vector;; #install_printer print_matrix;; #install_printer print_monomial;; #install_printer print_poly;; *) (* ------------------------------------------------------------------------- *) (* Conversion from term. *) (* ------------------------------------------------------------------------- *) let rec poly_of_term t = match t with Zero -> poly_0 | Const n -> poly_const n | Var x -> poly_var x | Opp t1 -> poly_neg (poly_of_term t1) | Inv t1 -> let p = poly_of_term t1 in if poly_isconst p then poly_const(Int 1 // eval undefined p) else failwith "poly_of_term: inverse of non-constant polyomial" | Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r) | Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r) | Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r) | Div (l, r) -> let p = poly_of_term l and q = poly_of_term r in if poly_isconst q then poly_cmul (Int 1 // eval undefined q) p else failwith "poly_of_term: division by non-constant polynomial" | Pow (t, n) -> poly_pow (poly_of_term t) n;; (* ------------------------------------------------------------------------- *) (* String of vector (just a list of space-separated numbers). *) (* ------------------------------------------------------------------------- *) let sdpa_of_vector (v:vector) = let n = dim v in let strs = List.map (o (decimalize 20) (element v)) (1--n) in end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; (* ------------------------------------------------------------------------- *) (* String for block diagonal matrix numbered k. *) (* ------------------------------------------------------------------------- *) let sdpa_of_blockdiagonal k m = let pfx = string_of_int k ^" " in let ents = foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in let entss = sort (increasing fst) ents in itlist (fun ((b,i,j),c) a -> pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; (* ------------------------------------------------------------------------- *) (* String for a matrix numbered k, in SDPA sparse format. *) (* ------------------------------------------------------------------------- *) let sdpa_of_matrix k (m:matrix) = let pfx = string_of_int k ^ " 1 " in let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) (snd m) [] in let mss = sort (increasing fst) ms in itlist (fun ((i,j),c) a -> pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; (* ------------------------------------------------------------------------- *) (* String in SDPA sparse format for standard SDP problem: *) (* *) (* X = v_1 * [M_1] + ... + v_m * [M_m] - [M_0] must be PSD *) (* Minimize obj_1 * v_1 + ... obj_m * v_m *) (* ------------------------------------------------------------------------- *) let sdpa_of_problem comment obj mats = let m = List.length mats - 1 and n,_ = dimensions (List.hd mats) in "\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ "1\n" ^ string_of_int n ^ "\n" ^ sdpa_of_vector obj ^ itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) (1--List.length mats) mats "";; (* ------------------------------------------------------------------------- *) (* More parser basics. *) (* ------------------------------------------------------------------------- *) let word s = end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t)) (List.map a (explode s));; let token s = many (some isspace) ++ word s ++ many (some isspace) >> (fun ((_,t),_) -> t);; let decimal = let numeral = some isnum in let decimalint = atleast 1 numeral >> ((o) Num.num_of_string implode) in let decimalfrac = atleast 1 numeral >> (fun s -> Num.num_of_string(implode s) // pow10 (List.length s)) in let decimalsig = decimalint ++ possibly (a "." ++ decimalfrac >> snd) >> (function (h,[x]) -> h +/ x | (h,_) -> h) in let signed prs = a "-" ++ prs >> ((o) minus_num snd) || a "+" ++ prs >> snd || prs in let exponent = (a "e" || a "E") ++ signed decimalint >> snd in signed decimalsig ++ possibly exponent >> (function (h,[x]) -> h */ power_num (Int 10) x | (h,_) -> h);; let mkparser p s = let x,rst = p(explode s) in if rst = [] then x else failwith "mkparser: unparsed input";; let parse_decimal = mkparser decimal;; (* ------------------------------------------------------------------------- *) (* Parse back a vector. *) (* ------------------------------------------------------------------------- *) let parse_sdpaoutput,parse_csdpoutput = let vector = token "{" ++ listof decimal (token ",") "decimal" ++ token "}" >> (fun ((_,v),_) -> vector_of_list v) in let rec skipupto dscr prs inp = (dscr ++ prs >> snd || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in let ignore inp = (),[] in let sdpaoutput = skipupto (word "xVec" ++ token "=") (vector ++ ignore >> fst) in let csdpoutput = (decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++ (a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in mkparser sdpaoutput,mkparser csdpoutput;; (* ------------------------------------------------------------------------- *) (* Also parse the SDPA output to test success (CSDP yields a return code). *) (* ------------------------------------------------------------------------- *) let sdpa_run_succeeded = let rec skipupto dscr prs inp = (dscr ++ prs >> snd || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in let prs = skipupto (word "phase.value" ++ token "=") (possibly (a "p") ++ possibly (a "d") ++ (word "OPT" || word "FEAS")) in fun s -> try ignore (prs (explode s)); true with Noparse -> false;; (* ------------------------------------------------------------------------- *) (* The default parameters. Unfortunately this goes to a fixed file. *) (* ------------------------------------------------------------------------- *) let sdpa_default_parameters = "100 unsigned int maxIteration;\ \n1.0E-7 double 0.0 < epsilonStar;\ \n1.0E2 double 0.0 < lambdaStar;\ \n2.0 double 1.0 < omegaStar;\ \n-1.0E5 double lowerBound;\ \n1.0E5 double upperBound;\ \n0.1 double 0.0 <= betaStar < 1.0;\ \n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\ \n0.9 double 0.0 < gammaStar < 1.0;\ \n1.0E-7 double 0.0 < epsilonDash;\ \n";; (* ------------------------------------------------------------------------- *) (* These were suggested by Makoto Yamashita for problems where we are *) (* right at the edge of the semidefinite cone, as sometimes happens. *) (* ------------------------------------------------------------------------- *) let sdpa_alt_parameters = "1000 unsigned int maxIteration;\ \n1.0E-7 double 0.0 < epsilonStar;\ \n1.0E4 double 0.0 < lambdaStar;\ \n2.0 double 1.0 < omegaStar;\ \n-1.0E5 double lowerBound;\ \n1.0E5 double upperBound;\ \n0.1 double 0.0 <= betaStar < 1.0;\ \n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\ \n0.9 double 0.0 < gammaStar < 1.0;\ \n1.0E-7 double 0.0 < epsilonDash;\ \n";; let sdpa_params = sdpa_alt_parameters;; (* ------------------------------------------------------------------------- *) (* CSDP parameters; so far I'm sticking with the defaults. *) (* ------------------------------------------------------------------------- *) let csdp_default_parameters = "axtol=1.0e-8\ \natytol=1.0e-8\ \nobjtol=1.0e-8\ \npinftol=1.0e8\ \ndinftol=1.0e8\ \nmaxiter=100\ \nminstepfrac=0.9\ \nmaxstepfrac=0.97\ \nminstepp=1.0e-8\ \nminstepd=1.0e-8\ \nusexzgap=1\ \ntweakgap=0\ \naffine=0\ \nprintlevel=1\ \n";; let csdp_params = csdp_default_parameters;; (* ------------------------------------------------------------------------- *) (* Now call CSDP on a problem and parse back the output. *) (* ------------------------------------------------------------------------- *) let run_csdp dbg obj mats = let input_file = Filename.temp_file "sos" ".dat-s" in let output_file = String.sub input_file 0 (String.length input_file - 6) ^ ".out" and params_file = Filename.concat (!temp_path) "param.csdp" in file_of_string input_file (sdpa_of_problem "" obj mats); file_of_string params_file csdp_params; let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^ " " ^ output_file ^ (if dbg then "" else "> /dev/null")) in let op = string_of_file output_file in let res = parse_csdpoutput op in ((if dbg then () else (Sys.remove input_file; Sys.remove output_file)); rv,res);; let csdp obj mats = let rv,res = run_csdp (!debugging) obj mats in (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible" else if rv = 3 then () (* Format.print_string "csdp warning: Reduced accuracy"; Format.print_newline() *) else if rv <> 0 then failwith("csdp: error "^string_of_int rv) else ()); res;; (* ------------------------------------------------------------------------- *) (* Try some apparently sensible scaling first. Note that this is purely to *) (* get a cleaner translation to floating-point, and doesn't affect any of *) (* the results, in principle. In practice it seems a lot better when there *) (* are extreme numbers in the original problem. *) (* ------------------------------------------------------------------------- *) let scale_then = let common_denominator amat acc = foldl (fun a m c -> lcm_num (denominator c) a) acc amat and maximal_element amat acc = foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in fun solver obj mats -> let cd1 = itlist common_denominator mats (Int 1) and cd2 = common_denominator (snd obj) (Int 1) in let mats' = List.map (mapf (fun x -> cd1 */ x)) mats and obj' = vector_cmul cd2 obj in let max1 = itlist maximal_element mats' (Int 0) and max2 = maximal_element (snd obj') (Int 0) in let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0)) and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in let mats'' = List.map (mapf (fun x -> x */ scal1)) mats' and obj'' = vector_cmul scal2 obj' in solver obj'' mats'';; (* ------------------------------------------------------------------------- *) (* Round a vector to "nice" rationals. *) (* ------------------------------------------------------------------------- *) let nice_rational n x = round_num (n */ x) // n;; let nice_vector n = mapa (nice_rational n);; (* ------------------------------------------------------------------------- *) (* Reduce linear program to SDP (diagonal matrices) and test with CSDP. This *) (* one tests A [-1;x1;..;xn] >= 0 (i.e. left column is negated constants). *) (* ------------------------------------------------------------------------- *) let linear_program_basic a = let m,n = dimensions a in let mats = List.map (fun j -> diagonal (column j a)) (1--n) and obj = vector_const (Int 1) m in let rv,res = run_csdp false obj mats in if rv = 1 or rv = 2 then false else if rv = 0 then true else failwith "linear_program: An error occurred in the SDP solver";; (* ------------------------------------------------------------------------- *) (* Alternative interface testing A x >= b for matrix A, vector b. *) (* ------------------------------------------------------------------------- *) let linear_program a b = let m,n = dimensions a in if dim b <> m then failwith "linear_program: incompatible dimensions" else let mats = diagonal b :: List.map (fun j -> diagonal (column j a)) (1--n) and obj = vector_const (Int 1) m in let rv,res = run_csdp false obj mats in if rv = 1 or rv = 2 then false else if rv = 0 then true else failwith "linear_program: An error occurred in the SDP solver";; (* ------------------------------------------------------------------------- *) (* Test whether a point is in the convex hull of others. Rather than use *) (* computational geometry, express as linear inequalities and call CSDP. *) (* This is a bit lazy of me, but it's easy and not such a bottleneck so far. *) (* ------------------------------------------------------------------------- *) let in_convex_hull pts pt = let pts1 = (1::pt) :: List.map (fun x -> 1::x) pts in let pts2 = List.map (fun p -> List.map (fun x -> -x) p @ p) pts1 in let n = List.length pts + 1 and v = 2 * (List.length pt + 1) in let m = v + n - 1 in let mat = (m,n), itern 1 pts2 (fun pts j -> itern 1 pts (fun x i -> (i,j) |-> Int x)) (iter (1,n) (fun i -> (v + i,i+1) |-> Int 1) undefined) in linear_program_basic mat;; (* ------------------------------------------------------------------------- *) (* Filter down a set of points to a minimal set with the same convex hull. *) (* ------------------------------------------------------------------------- *) let minimal_convex_hull = let augment1 = function | [] -> assert false | (m::ms) -> if in_convex_hull ms m then ms else ms@[m] in let augment m ms = funpow 3 augment1 (m::ms) in fun mons -> let mons' = itlist augment (List.tl mons) [List.hd mons] in funpow (List.length mons') augment1 mons';; (* ------------------------------------------------------------------------- *) (* Stuff for "equations" (generic A->num functions). *) (* ------------------------------------------------------------------------- *) let equation_cmul c eq = if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq;; let equation_add eq1 eq2 = combine (+/) (fun x -> x =/ Int 0) eq1 eq2;; let equation_eval assig eq = let value v = apply assig v in foldl (fun a v c -> a +/ value(v) */ c) (Int 0) eq;; (* ------------------------------------------------------------------------- *) (* Eliminate among linear equations: return unconstrained variables and *) (* assignments for the others in terms of them. We give one pseudo-variable *) (* "one" that's used for a constant term. *) (* ------------------------------------------------------------------------- *) let failstore = ref [];; let eliminate_equations = let rec extract_first p l = match l with [] -> failwith "extract_first" | h::t -> if p(h) then h,t else let k,s = extract_first p t in k,h::s in let rec eliminate vars dun eqs = match vars with [] -> if forall is_undefined eqs then dun else (failstore := [vars,dun,eqs]; raise Unsolvable) | v::vs -> try let eq,oeqs = extract_first (fun e -> defined e v) eqs in let a = apply eq v in let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in let elim e = let b = tryapplyd e v (Int 0) in if b =/ Int 0 then e else equation_add e (equation_cmul (minus_num b // a) eq) in eliminate vs ((v |-> eq') (mapf elim dun)) (List.map elim oeqs) with Failure _ -> eliminate vs dun eqs in fun one vars eqs -> let assig = eliminate vars undefined eqs in let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in setify vs,assig;; (* ------------------------------------------------------------------------- *) (* Eliminate all variables, in an essentially arbitrary order. *) (* ------------------------------------------------------------------------- *) let eliminate_all_equations one = let choose_variable eq = let (v,_) = choose eq in if v = one then let eq' = undefine v eq in if is_undefined eq' then failwith "choose_variable" else let (w,_) = choose eq' in w else v in let rec eliminate dun eqs = match eqs with [] -> dun | eq::oeqs -> if is_undefined eq then eliminate dun oeqs else let v = choose_variable eq in let a = apply eq v in let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in let elim e = let b = tryapplyd e v (Int 0) in if b =/ Int 0 then e else equation_add e (equation_cmul (minus_num b // a) eq) in eliminate ((v |-> eq') (mapf elim dun)) (List.map elim oeqs) in fun eqs -> let assig = eliminate undefined eqs in let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in setify vs,assig;; (* ------------------------------------------------------------------------- *) (* Solve equations by assigning arbitrary numbers. *) (* ------------------------------------------------------------------------- *) let solve_equations one eqs = let vars,assigs = eliminate_all_equations one eqs in let vfn = itlist (fun v -> (v |-> Int 0)) vars (one |=> Int(-1)) in let ass = combine (+/) (fun c -> false) (mapf (equation_eval vfn) assigs) vfn in if forall (fun e -> equation_eval ass e =/ Int 0) eqs then undefine one ass else raise Sanity;; (* ------------------------------------------------------------------------- *) (* Hence produce the "relevant" monomials: those whose squares lie in the *) (* Newton polytope of the monomials in the input. (This is enough according *) (* to Reznik: "Extremal PSD forms with few terms", Duke Math. Journal, *) (* vol 45, pp. 363--374, 1978. *) (* *) (* These are ordered in sort of decreasing degree. In particular the *) (* constant monomial is last; this gives an order in diagonalization of the *) (* quadratic form that will tend to display constants. *) (* ------------------------------------------------------------------------- *) let newton_polytope pol = let vars = poly_variables pol in let mons = List.map (fun m -> List.map (fun x -> monomial_degree x m) vars) (dom pol) and ds = List.map (fun x -> (degree x pol + 1) / 2) vars in let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]] and mons' = minimal_convex_hull mons in let all' = List.filter (fun m -> in_convex_hull mons' (List.map (fun x -> 2 * x) m)) all in List.map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a) vars m monomial_1) (List.rev all');; (* ------------------------------------------------------------------------- *) (* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form. *) (* ------------------------------------------------------------------------- *) let diag m = let nn = dimensions m in let n = fst nn in if snd nn <> n then failwith "diagonalize: non-square matrix" else let rec diagonalize i m = if is_zero m then [] else let a11 = element m (i,i) in if a11 a1k // a11) v in let m' = (n,n), iter (i+1,n) (fun j -> iter (i+1,n) (fun k -> ((j,k) |--> (element m (j,k) -/ element v j */ element v' k)))) undefined in (a11,v')::diagonalize (i + 1) m' in diagonalize 1 m;; (* ------------------------------------------------------------------------- *) (* Adjust a diagonalization to collect rationals at the start. *) (* ------------------------------------------------------------------------- *) let deration d = if d = [] then Int 0,d else let adj(c,l) = let a = foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) // foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in (c // (a */ a)),mapa (fun x -> a */ x) l in let d' = List.map adj d in let a = itlist ((o) lcm_num ( (o) denominator fst)) d' (Int 1) // itlist ((o) gcd_num ( (o) numerator fst)) d' (Int 0) in (Int 1 // a),List.map (fun (c,l) -> (a */ c,l)) d';; (* ------------------------------------------------------------------------- *) (* Enumeration of monomials with given multidegree bound. *) (* ------------------------------------------------------------------------- *) let rec enumerate_monomials d vars = if d < 0 then [] else if d = 0 then [undefined] else if vars = [] then [monomial_1] else let alts = List.map (fun k -> let oths = enumerate_monomials (d - k) (List.tl vars) in List.map (fun ks -> if k = 0 then ks else (List.hd vars |-> k) ks) oths) (0--d) in end_itlist (@) alts;; (* ------------------------------------------------------------------------- *) (* Enumerate products of distinct input polys with degree <= d. *) (* We ignore any constant input polynomials. *) (* Give the output polynomial and a record of how it was derived. *) (* ------------------------------------------------------------------------- *) let rec enumerate_products d pols = if d = 0 then [poly_const num_1,Rational_lt num_1] else if d < 0 then [] else match pols with [] -> [poly_const num_1,Rational_lt num_1] | (p,b)::ps -> let e = multidegree p in if e = 0 then enumerate_products d ps else enumerate_products d ps @ List.map (fun (q,c) -> poly_mul p q,Product(b,c)) (enumerate_products (d - e) ps);; (* ------------------------------------------------------------------------- *) (* Multiply equation-parametrized poly by regular poly and add accumulator. *) (* ------------------------------------------------------------------------- *) let epoly_pmul p q acc = foldl (fun a m1 c -> foldl (fun b m2 e -> let m = monomial_mul m1 m2 in let es = tryapplyd b m undefined in (m |-> equation_add (equation_cmul c e) es) b) a q) acc p;; (* ------------------------------------------------------------------------- *) (* Usual operations on equation-parametrized poly. *) (* ------------------------------------------------------------------------- *) let epoly_cmul c l = if c =/ Int 0 then undefined else mapf (equation_cmul c) l;; let epoly_neg = epoly_cmul (Int(-1));; let epoly_add = combine equation_add is_undefined;; let epoly_sub p q = epoly_add p (epoly_neg q);; (* ------------------------------------------------------------------------- *) (* Convert regular polynomial. Note that we treat (0,0,0) as -1. *) (* ------------------------------------------------------------------------- *) let epoly_of_poly p = foldl (fun a m c -> (m |-> ((0,0,0) |=> minus_num c)) a) undefined p;; (* ------------------------------------------------------------------------- *) (* String for block diagonal matrix numbered k. *) (* ------------------------------------------------------------------------- *) let sdpa_of_blockdiagonal k m = let pfx = string_of_int k ^" " in let ents = foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in let entss = sort (increasing fst) ents in itlist (fun ((b,i,j),c) a -> pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; (* ------------------------------------------------------------------------- *) (* SDPA for problem using block diagonal (i.e. multiple SDPs) *) (* ------------------------------------------------------------------------- *) let sdpa_of_blockproblem comment nblocks blocksizes obj mats = let m = List.length mats - 1 in "\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ string_of_int nblocks ^ "\n" ^ (end_itlist (fun s t -> s^" "^t) (List.map string_of_int blocksizes)) ^ "\n" ^ sdpa_of_vector obj ^ itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a) (1--List.length mats) mats "";; (* ------------------------------------------------------------------------- *) (* Hence run CSDP on a problem in block diagonal form. *) (* ------------------------------------------------------------------------- *) let run_csdp dbg nblocks blocksizes obj mats = let input_file = Filename.temp_file "sos" ".dat-s" in let output_file = String.sub input_file 0 (String.length input_file - 6) ^ ".out" and params_file = Filename.concat (!temp_path) "param.csdp" in file_of_string input_file (sdpa_of_blockproblem "" nblocks blocksizes obj mats); file_of_string params_file csdp_params; let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^ " " ^ output_file ^ (if dbg then "" else "> /dev/null")) in let op = string_of_file output_file in let res = parse_csdpoutput op in ((if dbg then () else (Sys.remove input_file; Sys.remove output_file)); rv,res);; let csdp nblocks blocksizes obj mats = let rv,res = run_csdp (!debugging) nblocks blocksizes obj mats in (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible" else if rv = 3 then () (*Format.print_string "csdp warning: Reduced accuracy"; Format.print_newline() *) else if rv <> 0 then failwith("csdp: error "^string_of_int rv) else ()); res;; (* ------------------------------------------------------------------------- *) (* 3D versions of matrix operations to consider blocks separately. *) (* ------------------------------------------------------------------------- *) let bmatrix_add = combine (+/) (fun x -> x =/ Int 0);; let bmatrix_cmul c bm = if c =/ Int 0 then undefined else mapf (fun x -> c */ x) bm;; let bmatrix_neg = bmatrix_cmul (Int(-1));; let bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);; (* ------------------------------------------------------------------------- *) (* Smash a block matrix into components. *) (* ------------------------------------------------------------------------- *) let blocks blocksizes bm = List.map (fun (bs,b0) -> let m = foldl (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a) undefined bm in (((bs,bs),m):matrix)) (zip blocksizes (1--List.length blocksizes));; (* ------------------------------------------------------------------------- *) (* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *) (* ------------------------------------------------------------------------- *) let real_positivnullstellensatz_general linf d eqs leqs pol = let vars = itlist ((o) union poly_variables) (pol::eqs @ List.map fst leqs) [] in let monoid = if linf then (poly_const num_1,Rational_lt num_1):: (List.filter (fun (p,c) -> multidegree p <= d) leqs) else enumerate_products d leqs in let nblocks = List.length monoid in let mk_idmultiplier k p = let e = d - multidegree p in let mons = enumerate_monomials e vars in let nons = zip mons (1--List.length mons) in mons, itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in let mk_sqmultiplier k (p,c) = let e = (d - multidegree p) / 2 in let mons = enumerate_monomials e vars in let nons = zip mons (1--List.length mons) in mons, itlist (fun (m1,n1) -> itlist (fun (m2,n2) a -> let m = monomial_mul m1 m2 in if n1 > n2 then a else let c = if n1 = n2 then Int 1 else Int 2 in let e = tryapplyd a m undefined in (m |-> equation_add ((k,n1,n2) |=> c) e) a) nons) nons undefined in let sqmonlist,sqs = unzip(List.map2 mk_sqmultiplier (1--List.length monoid) monoid) and idmonlist,ids = unzip(List.map2 mk_idmultiplier (1--List.length eqs) eqs) in let blocksizes = List.map List.length sqmonlist in let bigsum = itlist2 (fun p q a -> epoly_pmul p q a) eqs ids (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs (epoly_of_poly(poly_neg pol))) in let eqns = foldl (fun a m e -> e::a) [] bigsum in let pvs,assig = eliminate_all_equations (0,0,0) eqns in let qvars = (0,0,0)::pvs in let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in let mk_matrix v = foldl (fun m (b,i,j) ass -> if b < 0 then m else let c = tryapplyd ass v (Int 0) in if c =/ Int 0 then m else ((b,j,i) |-> c) (((b,i,j) |-> c) m)) undefined allassig in let diagents = foldl (fun a (b,i,j) e -> if b > 0 && i = j then equation_add e a else a) undefined allassig in let mats = List.map mk_matrix qvars and obj = List.length pvs, itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0))) undefined in let raw_vec = if pvs = [] then vector_0 0 else scale_then (csdp nblocks blocksizes) obj mats in let find_rounding d = (if !debugging then (Format.print_string("Trying rounding with limit "^string_of_num d); Format.print_newline()) else ()); let vec = nice_vector d raw_vec in let blockmat = iter (1,dim vec) (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a) (bmatrix_neg (el 0 mats)) in let allmats = blocks blocksizes blockmat in vec,List.map diag allmats in let vec,ratdias = if pvs = [] then find_rounding num_1 else tryfind find_rounding (List.map Num.num_of_int (1--31) @ List.map pow2 (5--66)) in let newassigs = itlist (fun k -> el (k - 1) pvs |-> element vec k) (1--dim vec) ((0,0,0) |=> Int(-1)) in let finalassigs = foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs allassig in let poly_of_epoly p = foldl (fun a v e -> (v |--> equation_eval finalassigs e) a) undefined p in let mk_sos mons = let mk_sq (c,m) = c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a) (1--List.length mons) undefined in List.map mk_sq in let sqs = List.map2 mk_sos sqmonlist ratdias and cfs = List.map poly_of_epoly ids in let msq = List.filter (fun (a,b) -> b <> []) (List.map2 (fun a b -> a,b) monoid sqs) in let eval_sq sqs = itlist (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in let sanity = itlist (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs (poly_neg pol)) in if not(is_undefined sanity) then raise Sanity else cfs,List.map (fun (a,b) -> snd a,b) msq;; (* ------------------------------------------------------------------------- *) (* Iterative deepening. *) (* ------------------------------------------------------------------------- *) let rec deepen f n = try print_string "Searching with depth limit "; print_int n; print_newline(); f n with Failure _ -> deepen f (n + 1);; (* ------------------------------------------------------------------------- *) (* The ordering so we can create canonical HOL polynomials. *) (* ------------------------------------------------------------------------- *) let dest_monomial mon = sort (increasing fst) (graph mon);; let monomial_order = let rec lexorder l1 l2 = match (l1,l2) with [],[] -> true | vps,[] -> false | [],vps -> true | ((x1,n1)::vs1),((x2,n2)::vs2) -> if x1 < x2 then true else if x2 < x1 then false else if n1 < n2 then false else if n2 < n1 then true else lexorder vs1 vs2 in fun m1 m2 -> if m2 = monomial_1 then true else if m1 = monomial_1 then false else let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in let deg1 = itlist ((o) (+) snd) mon1 0 and deg2 = itlist ((o) (+) snd) mon2 0 in if deg1 < deg2 then false else if deg1 > deg2 then true else lexorder mon1 mon2;; let dest_poly p = List.map (fun (m,c) -> c,dest_monomial m) (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p));; (* ------------------------------------------------------------------------- *) (* Map back polynomials and their composites to HOL. *) (* ------------------------------------------------------------------------- *) let term_of_varpow = fun x k -> if k = 1 then Var x else Pow (Var x, k);; let term_of_monomial = fun m -> if m = monomial_1 then Const num_1 else let m' = dest_monomial m in let vps = itlist (fun (x,k) a -> term_of_varpow x k :: a) m' [] in end_itlist (fun s t -> Mul (s,t)) vps;; let term_of_cmonomial = fun (m,c) -> if m = monomial_1 then Const c else if c =/ num_1 then term_of_monomial m else Mul (Const c,term_of_monomial m);; let term_of_poly = fun p -> if p = poly_0 then Zero else let cms = List.map term_of_cmonomial (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in end_itlist (fun t1 t2 -> Add (t1,t2)) cms;; let term_of_sqterm (c,p) = Product(Rational_lt c,Square(term_of_poly p));; let term_of_sos (pr,sqs) = if sqs = [] then pr else Product(pr,end_itlist (fun a b -> Sum(a,b)) (List.map term_of_sqterm sqs));; (* ------------------------------------------------------------------------- *) (* Interface to HOL. *) (* ------------------------------------------------------------------------- *) (* let REAL_NONLINEAR_PROVER translator (eqs,les,lts) = let eq0 = map (poly_of_term o lhand o concl) eqs and le0 = map (poly_of_term o lhand o concl) les and lt0 = map (poly_of_term o lhand o concl) lts in let eqp0 = map (fun (t,i) -> t,Axiom_eq i) (zip eq0 (0--(length eq0 - 1))) and lep0 = map (fun (t,i) -> t,Axiom_le i) (zip le0 (0--(length le0 - 1))) and ltp0 = map (fun (t,i) -> t,Axiom_lt i) (zip lt0 (0--(length lt0 - 1))) in let keq,eq = partition (fun (p,_) -> multidegree p = 0) eqp0 and klep,lep = partition (fun (p,_) -> multidegree p = 0) lep0 and kltp,ltp = partition (fun (p,_) -> multidegree p = 0) ltp0 in let trivial_axiom (p,ax) = match ax with Axiom_eq n when eval undefined p <>/ num_0 -> el n eqs | Axiom_le n when eval undefined p el n les | Axiom_lt n when eval undefined p <=/ num_0 -> el n lts | _ -> failwith "not a trivial axiom" in try let th = tryfind trivial_axiom (keq @ klep @ kltp) in CONV_RULE (LAND_CONV REAL_POLY_CONV THENC REAL_RAT_RED_CONV) th with Failure _ -> let pol = itlist poly_mul (map fst ltp) (poly_const num_1) in let leq = lep @ ltp in let tryall d = let e = multidegree pol in let k = if e = 0 then 0 else d / e in let eq' = map fst eq in tryfind (fun i -> d,i,real_positivnullstellensatz_general false d eq' leq (poly_neg(poly_pow pol i))) (0--k) in let d,i,(cert_ideal,cert_cone) = deepen tryall 0 in let proofs_ideal = map2 (fun q (p,ax) -> Eqmul(term_of_poly q,ax)) cert_ideal eq and proofs_cone = map term_of_sos cert_cone and proof_ne = if ltp = [] then Rational_lt num_1 else let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in let proof = end_itlist (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in print_string("Translating proof certificate to HOL"); print_newline(); translator (eqs,les,lts) proof;; *) (* ------------------------------------------------------------------------- *) (* A wrapper that tries to substitute away variables first. *) (* ------------------------------------------------------------------------- *) (* let REAL_NONLINEAR_SUBST_PROVER = let zero = `&0:real` and mul_tm = `( * ):real->real->real` and shuffle1 = CONV_RULE(REWR_CONV(REAL_ARITH `a + x = (y:real) <=> x = y - a`)) and shuffle2 = CONV_RULE(REWR_CONV(REAL_ARITH `x + a = (y:real) <=> x = y - a`)) in let rec substitutable_monomial fvs tm = match tm with Var(_,Tyapp("real",[])) when not (mem tm fvs) -> Int 1,tm | Comb(Comb(Const("real_mul",_),c),(Var(_,_) as t)) when is_ratconst c && not (mem t fvs) -> rat_of_term c,t | Comb(Comb(Const("real_add",_),s),t) -> (try substitutable_monomial (union (frees t) fvs) s with Failure _ -> substitutable_monomial (union (frees s) fvs) t) | _ -> failwith "substitutable_monomial" and isolate_variable v th = match lhs(concl th) with x when x = v -> th | Comb(Comb(Const("real_add",_),(Var(_,Tyapp("real",[])) as x)),t) when x = v -> shuffle2 th | Comb(Comb(Const("real_add",_),s),t) -> isolate_variable v(shuffle1 th) in let make_substitution th = let (c,v) = substitutable_monomial [] (lhs(concl th)) in let th1 = AP_TERM (mk_comb(mul_tm,term_of_rat(Int 1 // c))) th in let th2 = CONV_RULE(BINOP_CONV REAL_POLY_MUL_CONV) th1 in CONV_RULE (RAND_CONV REAL_POLY_CONV) (isolate_variable v th2) in fun translator -> let rec substfirst(eqs,les,lts) = try let eth = tryfind make_substitution eqs in let modify = CONV_RULE(LAND_CONV(SUBS_CONV[eth] THENC REAL_POLY_CONV)) in substfirst(filter (fun t -> lhand(concl t) <> zero) (map modify eqs), map modify les,map modify lts) with Failure _ -> REAL_NONLINEAR_PROVER translator (eqs,les,lts) in substfirst;; *) (* ------------------------------------------------------------------------- *) (* Overall function. *) (* ------------------------------------------------------------------------- *) (* let REAL_SOS = let init = GEN_REWRITE_CONV ONCE_DEPTH_CONV [DECIMAL] and pure = GEN_REAL_ARITH REAL_NONLINEAR_SUBST_PROVER in fun tm -> let th = init tm in EQ_MP (SYM th) (pure(rand(concl th)));; *) (* ------------------------------------------------------------------------- *) (* Add hacks for division. *) (* ------------------------------------------------------------------------- *) (* let REAL_SOSFIELD = let inv_tm = `inv:real->real` in let prenex_conv = TOP_DEPTH_CONV BETA_CONV THENC PURE_REWRITE_CONV[FORALL_SIMP; EXISTS_SIMP; real_div; REAL_INV_INV; REAL_INV_MUL; GSYM REAL_POW_INV] THENC NNFC_CONV THENC DEPTH_BINOP_CONV `(/\)` CONDS_CELIM_CONV THENC PRENEX_CONV and setup_conv = NNF_CONV THENC WEAK_CNF_CONV THENC CONJ_CANON_CONV and core_rule t = try REAL_ARITH t with Failure _ -> try REAL_RING t with Failure _ -> REAL_SOS t and is_inv = let is_div = is_binop `(/):real->real->real` in fun tm -> (is_div tm or (is_comb tm && rator tm = inv_tm)) && not(is_ratconst(rand tm)) in let BASIC_REAL_FIELD tm = let is_freeinv t = is_inv t && free_in t tm in let itms = setify(map rand (find_terms is_freeinv tm)) in let hyps = map (fun t -> SPEC t REAL_MUL_RINV) itms in let tm' = itlist (fun th t -> mk_imp(concl th,t)) hyps tm in let itms' = map (curry mk_comb inv_tm) itms in let gvs = map (genvar o type_of) itms' in let tm'' = subst (zip gvs itms') tm' in let th1 = setup_conv tm'' in let cjs = conjuncts(rand(concl th1)) in let ths = map core_rule cjs in let th2 = EQ_MP (SYM th1) (end_itlist CONJ ths) in rev_itlist (C MP) hyps (INST (zip itms' gvs) th2) in fun tm -> let th0 = prenex_conv tm in let tm0 = rand(concl th0) in let avs,bod = strip_forall tm0 in let th1 = setup_conv bod in let ths = map BASIC_REAL_FIELD (conjuncts(rand(concl th1))) in EQ_MP (SYM th0) (GENL avs (EQ_MP (SYM th1) (end_itlist CONJ ths)));; *) (* ------------------------------------------------------------------------- *) (* Integer version. *) (* ------------------------------------------------------------------------- *) (* let INT_SOS = let atom_CONV = let pth = prove (`(~(x <= y) <=> y + &1 <= x:int) /\ (~(x < y) <=> y <= x) /\ (~(x = y) <=> x + &1 <= y \/ y + &1 <= x) /\ (x < y <=> x + &1 <= y)`, REWRITE_TAC[INT_NOT_LE; INT_NOT_LT; INT_NOT_EQ; INT_LT_DISCRETE]) in GEN_REWRITE_CONV I [pth] and bub_CONV = GEN_REWRITE_CONV TOP_SWEEP_CONV [int_eq; int_le; int_lt; int_ge; int_gt; int_of_num_th; int_neg_th; int_add_th; int_mul_th; int_sub_th; int_pow_th; int_abs_th; int_max_th; int_min_th] in let base_CONV = TRY_CONV atom_CONV THENC bub_CONV in let NNF_NORM_CONV = GEN_NNF_CONV false (base_CONV,fun t -> base_CONV t,base_CONV(mk_neg t)) in let init_CONV = GEN_REWRITE_CONV DEPTH_CONV [FORALL_SIMP; EXISTS_SIMP] THENC GEN_REWRITE_CONV DEPTH_CONV [INT_GT; INT_GE] THENC CONDS_ELIM_CONV THENC NNF_NORM_CONV in let p_tm = `p:bool` and not_tm = `(~)` in let pth = TAUT(mk_eq(mk_neg(mk_neg p_tm),p_tm)) in fun tm -> let th0 = INST [tm,p_tm] pth and th1 = NNF_NORM_CONV(mk_neg tm) in let th2 = REAL_SOS(mk_neg(rand(concl th1))) in EQ_MP th0 (EQ_MP (AP_TERM not_tm (SYM th1)) th2);; *) (* ------------------------------------------------------------------------- *) (* Natural number version. *) (* ------------------------------------------------------------------------- *) (* let SOS_RULE tm = let avs = frees tm in let tm' = list_mk_forall(avs,tm) in let th1 = NUM_TO_INT_CONV tm' in let th2 = INT_SOS (rand(concl th1)) in SPECL avs (EQ_MP (SYM th1) th2);; *) (* ------------------------------------------------------------------------- *) (* Now pure SOS stuff. *) (* ------------------------------------------------------------------------- *) (*prioritize_real();;*) (* ------------------------------------------------------------------------- *) (* Some combinatorial helper functions. *) (* ------------------------------------------------------------------------- *) let rec allpermutations l = if l = [] then [[]] else itlist (fun h acc -> List.map (fun t -> h::t) (allpermutations (subtract l [h])) @ acc) l [];; let allvarorders l = List.map (fun vlis x -> index x vlis) (allpermutations l);; let changevariables_monomial zoln (m:monomial) = foldl (fun a x k -> (List.assoc x zoln |-> k) a) monomial_1 m;; let changevariables zoln pol = foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a) poly_0 pol;; (* ------------------------------------------------------------------------- *) (* Return to original non-block matrices. *) (* ------------------------------------------------------------------------- *) let sdpa_of_vector (v:vector) = let n = dim v in let strs = List.map (o (decimalize 20) (element v)) (1--n) in end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; let sdpa_of_blockdiagonal k m = let pfx = string_of_int k ^" " in let ents = foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in let entss = sort (increasing fst) ents in itlist (fun ((b,i,j),c) a -> pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; let sdpa_of_matrix k (m:matrix) = let pfx = string_of_int k ^ " 1 " in let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) (snd m) [] in let mss = sort (increasing fst) ms in itlist (fun ((i,j),c) a -> pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; let sdpa_of_problem comment obj mats = let m = List.length mats - 1 and n,_ = dimensions (List.hd mats) in "\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ "1\n" ^ string_of_int n ^ "\n" ^ sdpa_of_vector obj ^ itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) (1--List.length mats) mats "";; let run_csdp dbg obj mats = let input_file = Filename.temp_file "sos" ".dat-s" in let output_file = String.sub input_file 0 (String.length input_file - 6) ^ ".out" and params_file = Filename.concat (!temp_path) "param.csdp" in file_of_string input_file (sdpa_of_problem "" obj mats); file_of_string params_file csdp_params; let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^ " " ^ output_file ^ (if dbg then "" else "> /dev/null")) in let op = string_of_file output_file in let res = parse_csdpoutput op in ((if dbg then () else (Sys.remove input_file; Sys.remove output_file)); rv,res);; let csdp obj mats = let rv,res = run_csdp (!debugging) obj mats in (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible" else if rv = 3 then () (* (Format.print_string "csdp warning: Reduced accuracy"; Format.print_newline()) *) else if rv <> 0 then failwith("csdp: error "^string_of_int rv) else ()); res;; (* ------------------------------------------------------------------------- *) (* Sum-of-squares function with some lowbrow symmetry reductions. *) (* ------------------------------------------------------------------------- *) let sumofsquares_general_symmetry tool pol = let vars = poly_variables pol and lpps = newton_polytope pol in let n = List.length lpps in let sym_eqs = let invariants = List.filter (fun vars' -> is_undefined(poly_sub pol (changevariables (zip vars vars') pol))) (allpermutations vars) in let lpns = zip lpps (1--List.length lpps) in let lppcs = List.filter (fun (m,(n1,n2)) -> n1 <= n2) (allpairs (fun (m1,n1) (m2,n2) -> (m1,m2),(n1,n2)) lpns lpns) in let clppcs = end_itlist (@) (List.map (fun ((m1,m2),(n1,n2)) -> List.map (fun vars' -> (changevariables_monomial (zip vars vars') m1, changevariables_monomial (zip vars vars') m2),(n1,n2)) invariants) lppcs) in let clppcs_dom = setify(List.map fst clppcs) in let clppcs_cls = List.map (fun d -> List.filter (fun (e,_) -> e = d) clppcs) clppcs_dom in let eqvcls = List.map (o setify (List.map snd)) clppcs_cls in let mk_eq cls acc = match cls with [] -> raise Sanity | [h] -> acc | h::t -> List.map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in itlist mk_eq eqvcls [] in let eqs = foldl (fun a x y -> y::a) [] (itern 1 lpps (fun m1 n1 -> itern 1 lpps (fun m2 n2 f -> let m = monomial_mul m1 m2 in if n1 > n2 then f else let c = if n1 = n2 then Int 1 else Int 2 in (m |-> ((n1,n2) |-> c) (tryapplyd f m undefined)) f)) (foldl (fun a m c -> (m |-> ((0,0)|=>c)) a) undefined pol)) @ sym_eqs in let pvs,assig = eliminate_all_equations (0,0) eqs in let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in let qvars = (0,0)::pvs in let diagents = end_itlist equation_add (List.map (fun i -> apply allassig (i,i)) (1--n)) in let mk_matrix v = ((n,n), foldl (fun m (i,j) ass -> let c = tryapplyd ass v (Int 0) in if c =/ Int 0 then m else ((j,i) |-> c) (((i,j) |-> c) m)) undefined allassig :matrix) in let mats = List.map mk_matrix qvars and obj = List.length pvs, itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0))) undefined in let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in let find_rounding d = (if !debugging then (Format.print_string("Trying rounding with limit "^string_of_num d); Format.print_newline()) else ()); let vec = nice_vector d raw_vec in let mat = iter (1,dim vec) (fun i a -> matrix_add (matrix_cmul (element vec i) (el i mats)) a) (matrix_neg (el 0 mats)) in deration(diag mat) in let rat,dia = if pvs = [] then let mat = matrix_neg (el 0 mats) in deration(diag mat) else tryfind find_rounding (List.map Num.num_of_int (1--31) @ List.map pow2 (5--66)) in let poly_of_lin(d,v) = d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in let lins = List.map poly_of_lin dia in let sqs = List.map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in let sos = poly_cmul rat (end_itlist poly_add sqs) in if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;; let sumofsquares = sumofsquares_general_symmetry csdp;; (* ------------------------------------------------------------------------- *) (* Pure HOL SOS conversion. *) (* ------------------------------------------------------------------------- *) (* let SOS_CONV = let mk_square = let pow_tm = `(pow)` and two_tm = `2` in fun tm -> mk_comb(mk_comb(pow_tm,tm),two_tm) and mk_prod = mk_binop `( * )` and mk_sum = mk_binop `(+)` in fun tm -> let k,sos = sumofsquares(poly_of_term tm) in let mk_sqtm(c,p) = mk_prod (term_of_rat(k */ c)) (mk_square(term_of_poly p)) in let tm' = end_itlist mk_sum (map mk_sqtm sos) in let th = REAL_POLY_CONV tm and th' = REAL_POLY_CONV tm' in TRANS th (SYM th');; *) (* ------------------------------------------------------------------------- *) (* Attempt to prove &0 <= x by direct SOS decomposition. *) (* ------------------------------------------------------------------------- *) (* let PURE_SOS_TAC = let tac = MATCH_ACCEPT_TAC(REWRITE_RULE[GSYM REAL_POW_2] REAL_LE_SQUARE) ORELSE MATCH_ACCEPT_TAC REAL_LE_SQUARE ORELSE (MATCH_MP_TAC REAL_LE_ADD THEN CONJ_TAC) ORELSE (MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC) ORELSE CONV_TAC(RAND_CONV REAL_RAT_REDUCE_CONV THENC REAL_RAT_LE_CONV) in REPEAT GEN_TAC THEN REWRITE_TAC[real_ge] THEN GEN_REWRITE_TAC I [GSYM REAL_SUB_LE] THEN CONV_TAC(RAND_CONV SOS_CONV) THEN REPEAT tac THEN NO_TAC;; let PURE_SOS tm = prove(tm,PURE_SOS_TAC);; *) (* ------------------------------------------------------------------------- *) (* Examples. *) (* ------------------------------------------------------------------------- *) (***** time REAL_SOS `a1 >= &0 /\ a2 >= &0 /\ (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + &2) /\ (a1 * b1 + a2 * b2 = &0) ==> a1 * a2 - b1 * b2 >= &0`;; time REAL_SOS `&3 * x + &7 * a < &4 /\ &3 < &2 * x ==> a < &0`;; time REAL_SOS `b pow 2 < &4 * a * c ==> ~(a * x pow 2 + b * x + c = &0)`;; time REAL_SOS `(a * x pow 2 + b * x + c = &0) ==> b pow 2 >= &4 * a * c`;; time REAL_SOS `&0 <= x /\ x <= &1 /\ &0 <= y /\ y <= &1 ==> x pow 2 + y pow 2 < &1 \/ (x - &1) pow 2 + y pow 2 < &1 \/ x pow 2 + (y - &1) pow 2 < &1 \/ (x - &1) pow 2 + (y - &1) pow 2 < &1`;; time REAL_SOS `&0 <= b /\ &0 <= c /\ &0 <= x /\ &0 <= y /\ (x pow 2 = c) /\ (y pow 2 = a pow 2 * c + b) ==> a * c <= y * x`;; time REAL_SOS `&0 <= x /\ &0 <= y /\ &0 <= z /\ x + y + z <= &3 ==> x * y + x * z + y * z >= &3 * x * y * z`;; time REAL_SOS `(x pow 2 + y pow 2 + z pow 2 = &1) ==> (x + y + z) pow 2 <= &3`;; time REAL_SOS `(w pow 2 + x pow 2 + y pow 2 + z pow 2 = &1) ==> (w + x + y + z) pow 2 <= &4`;; time REAL_SOS `x >= &1 /\ y >= &1 ==> x * y >= x + y - &1`;; time REAL_SOS `x > &1 /\ y > &1 ==> x * y > x + y - &1`;; time REAL_SOS `abs(x) <= &1 ==> abs(&64 * x pow 7 - &112 * x pow 5 + &56 * x pow 3 - &7 * x) <= &1`;; time REAL_SOS `abs(x - z) <= e /\ abs(y - z) <= e /\ &0 <= u /\ &0 <= v /\ (u + v = &1) ==> abs((u * x + v * y) - z) <= e`;; (* ------------------------------------------------------------------------- *) (* One component of denominator in dodecahedral example. *) (* ------------------------------------------------------------------------- *) time REAL_SOS `&2 <= x /\ x <= &125841 / &50000 /\ &2 <= y /\ y <= &125841 / &50000 /\ &2 <= z /\ z <= &125841 / &50000 ==> &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= &0`;; (* ------------------------------------------------------------------------- *) (* Over a larger but simpler interval. *) (* ------------------------------------------------------------------------- *) time REAL_SOS `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4 ==> &0 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;; (* ------------------------------------------------------------------------- *) (* We can do 12. I think 12 is a sharp bound; see PP's certificate. *) (* ------------------------------------------------------------------------- *) time REAL_SOS `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4 ==> &12 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;; (* ------------------------------------------------------------------------- *) (* Gloptipoly example. *) (* ------------------------------------------------------------------------- *) (*** This works but normalization takes minutes time REAL_SOS `(x - y - &2 * x pow 4 = &0) /\ &0 <= x /\ x <= &2 /\ &0 <= y /\ y <= &3 ==> y pow 2 - &7 * y - &12 * x + &17 >= &0`;; ***) (* ------------------------------------------------------------------------- *) (* Inequality from sci.math (see "Leon-Sotelo, por favor"). *) (* ------------------------------------------------------------------------- *) time REAL_SOS `&0 <= x /\ &0 <= y /\ (x * y = &1) ==> x + y <= x pow 2 + y pow 2`;; time REAL_SOS `&0 <= x /\ &0 <= y /\ (x * y = &1) ==> x * y * (x + y) <= x pow 2 + y pow 2`;; time REAL_SOS `&0 <= x /\ &0 <= y ==> x * y * (x + y) pow 2 <= (x pow 2 + y pow 2) pow 2`;; (* ------------------------------------------------------------------------- *) (* Some examples over integers and natural numbers. *) (* ------------------------------------------------------------------------- *) time SOS_RULE `!m n. 2 * m + n = (n + m) + m`;; time SOS_RULE `!n. ~(n = 0) ==> (0 MOD n = 0)`;; time SOS_RULE `!m n. m < n ==> (m DIV n = 0)`;; time SOS_RULE `!n:num. n <= n * n`;; time SOS_RULE `!m n. n * (m DIV n) <= m`;; time SOS_RULE `!n. ~(n = 0) ==> (0 DIV n = 0)`;; time SOS_RULE `!m n p. ~(p = 0) /\ m <= n ==> m DIV p <= n DIV p`;; time SOS_RULE `!a b n. ~(a = 0) ==> (n <= b DIV a <=> a * n <= b)`;; (* ------------------------------------------------------------------------- *) (* This is particularly gratifying --- cf hideous manual proof in arith.ml *) (* ------------------------------------------------------------------------- *) (*** This doesn't now seem to work as well as it did; what changed? time SOS_RULE `!a b c d. ~(b = 0) /\ b * c < (a + 1) * d ==> c DIV d <= a DIV b`;; ***) (* ------------------------------------------------------------------------- *) (* Key lemma for injectivity of Cantor-type pairing functions. *) (* ------------------------------------------------------------------------- *) time SOS_RULE `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) ==> (x1 + y1 = x2 + y2)`;; time SOS_RULE `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) /\ (x1 + y1 = x2 + y2) ==> (x1 = x2) /\ (y1 = y2)`;; time SOS_RULE `!x1 y1 x2 y2. (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 = ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) ==> (x1 + y1 = x2 + y2)`;; time SOS_RULE `!x1 y1 x2 y2. (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 = ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) /\ (x1 + y1 = x2 + y2) ==> (x1 = x2) /\ (y1 = y2)`;; (* ------------------------------------------------------------------------- *) (* Reciprocal multiplication (actually just ARITH_RULE does these). *) (* ------------------------------------------------------------------------- *) time SOS_RULE `x <= 127 ==> ((86 * x) DIV 256 = x DIV 3)`;; time SOS_RULE `x < 2 EXP 16 ==> ((104858 * x) DIV (2 EXP 20) = x DIV 10)`;; (* ------------------------------------------------------------------------- *) (* This is more impressive since it's really nonlinear. See REMAINDER_DECODE *) (* ------------------------------------------------------------------------- *) time SOS_RULE `0 < m /\ m < n ==> ((m * ((n * x) DIV m + 1)) DIV n = x)`;; (* ------------------------------------------------------------------------- *) (* Some conversion examples. *) (* ------------------------------------------------------------------------- *) time SOS_CONV `&2 * x pow 4 + &2 * x pow 3 * y - x pow 2 * y pow 2 + &5 * y pow 4`;; time SOS_CONV `x pow 4 - (&2 * y * z + &1) * x pow 2 + (y pow 2 * z pow 2 + &2 * y * z + &2)`;; time SOS_CONV `&4 * x pow 4 + &4 * x pow 3 * y - &7 * x pow 2 * y pow 2 - &2 * x * y pow 3 + &10 * y pow 4`;; time SOS_CONV `&4 * x pow 4 * y pow 6 + x pow 2 - x * y pow 2 + y pow 2`;; time SOS_CONV `&4096 * (x pow 4 + x pow 2 + z pow 6 - &3 * x pow 2 * z pow 2) + &729`;; time SOS_CONV `&120 * x pow 2 - &63 * x pow 4 + &10 * x pow 6 + &30 * x * y - &120 * y pow 2 + &120 * y pow 4 + &31`;; time SOS_CONV `&9 * x pow 2 * y pow 4 + &9 * x pow 2 * z pow 4 + &36 * x pow 2 * y pow 3 + &36 * x pow 2 * y pow 2 - &48 * x * y * z pow 2 + &4 * y pow 4 + &4 * z pow 4 - &16 * y pow 3 + &16 * y pow 2`;; time SOS_CONV `(x pow 2 + y pow 2 + z pow 2) * (x pow 4 * y pow 2 + x pow 2 * y pow 4 + z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2)`;; time SOS_CONV `x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3`;; (*** I think this will work, but normalization is slow time SOS_CONV `&100 * (x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z) + &212`;; ***) time SOS_CONV `&100 * ((&2 * x - &2) pow 2 + (x pow 3 - &8 * x - &2) pow 2) - &588`;; time SOS_CONV `x pow 2 * (&120 - &63 * x pow 2 + &10 * x pow 4) + &30 * x * y + &30 * y pow 2 * (&4 * y pow 2 - &4) + &31`;; (* ------------------------------------------------------------------------- *) (* Example of basic rule. *) (* ------------------------------------------------------------------------- *) time PURE_SOS `!x. x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3 >= &1 / &7`;; time PURE_SOS `&0 <= &98 * x pow 12 + -- &980 * x pow 10 + &3038 * x pow 8 + -- &2968 * x pow 6 + &1022 * x pow 4 + -- &84 * x pow 2 + &2`;; time PURE_SOS `!x. &0 <= &2 * x pow 14 + -- &84 * x pow 12 + &1022 * x pow 10 + -- &2968 * x pow 8 + &3038 * x pow 6 + -- &980 * x pow 4 + &98 * x pow 2`;; (* ------------------------------------------------------------------------- *) (* From Zeng et al, JSC vol 37 (2004), p83-99. *) (* All of them work nicely with pure SOS_CONV, except (maybe) the one noted. *) (* ------------------------------------------------------------------------- *) PURE_SOS `x pow 6 + y pow 6 + z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2 >= &0`;; PURE_SOS `x pow 4 + y pow 4 + z pow 4 + &1 - &4*x*y*z >= &0`;; PURE_SOS `x pow 4 + &2*x pow 2*z + x pow 2 - &2*x*y*z + &2*y pow 2*z pow 2 + &2*y*z pow 2 + &2*z pow 2 - &2*x + &2* y*z + &1 >= &0`;; (**** This is harder. Interestingly, this fails the pure SOS test, it seems. Yet only on rounding(!?) Poor Newton polytope optimization or something? But REAL_SOS does finally converge on the second run at level 12! REAL_SOS `x pow 4*y pow 4 - &2*x pow 5*y pow 3*z pow 2 + x pow 6*y pow 2*z pow 4 + &2*x pow 2*y pow 3*z - &4* x pow 3*y pow 2*z pow 3 + &2*x pow 4*y*z pow 5 + z pow 2*y pow 2 - &2*z pow 4*y*x + z pow 6*x pow 2 >= &0`;; ****) PURE_SOS `x pow 4 + &4*x pow 2*y pow 2 + &2*x*y*z pow 2 + &2*x*y*w pow 2 + y pow 4 + z pow 4 + w pow 4 + &2*z pow 2*w pow 2 + &2*x pow 2*w + &2*y pow 2*w + &2*x*y + &3*w pow 2 + &2*z pow 2 + &1 >= &0`;; PURE_SOS `w pow 6 + &2*z pow 2*w pow 3 + x pow 4 + y pow 4 + z pow 4 + &2*x pow 2*w + &2*x pow 2*z + &3*x pow 2 + w pow 2 + &2*z*w + z pow 2 + &2*z + &2*w + &1 >= &0`;; *****) coq-8.6/plugins/micromega/mfourier.ml0000644000175000017500000006755113022274260017303 0ustar mdenesmdenesopen Num module Utils = Mutils open Polynomial open Vect let map_option = Utils.map_option let from_option = Utils.from_option let debug = false type ('a,'b) lr = Inl of 'a | Inr of 'b let compare_float (p : float) q = Pervasives.compare p q (** Implementation of intervals *) module Itv = struct (** The type of intervals is *) type interval = num option * num option (** None models the absence of bound i.e. infinity *) (** As a result, - None , None -> \]-oo,+oo\[ - None , Some v -> \]-oo,v\] - Some v, None -> \[v,+oo\[ - Some v, Some v' -> \[v,v'\] Intervals needs to be explicitly normalised. *) type who = Left | Right (** if then interval [itv] is empty, [norm_itv itv] returns [None] otherwise, it returns [Some itv] *) let norm_itv itv = match itv with | Some a , Some b -> if a <=/ b then Some itv else None | _ -> Some itv (** [opp_itv itv] computes the opposite interval *) let opp_itv itv = let (l,r) = itv in (map_option minus_num r, map_option minus_num l) (** [inter i1 i2 = None] if the intersection of intervals is empty [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) let inter i1 i2 = let (l1,r1) = i1 and (l2,r2) = i2 in let inter f o1 o2 = match o1 , o2 with | None , None -> None | Some _ , None -> o1 | None , Some _ -> o2 | Some n1 , Some n2 -> Some (f n1 n2) in norm_itv (inter max_num l1 l2 , inter min_num r1 r2) let range = function | None,_ | _,None -> None | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1)) let smaller_itv i1 i2 = match range i1 , range i2 with | None , _ -> false | _ , None -> true | Some i , Some j -> i <=/ j (** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *) let in_bound bnd v = let (l,r) = bnd in match l , r with | None , None -> true | None , Some a -> v <=/ a | Some a , None -> a <=/ v | Some a , Some b -> a <=/ v && v <=/ b end open Itv type vector = Vect.t (** 'cstr' is the type of constraints. {coeffs = v ; bound = (l,r) } models the constraints l <= v <= r **) module ISet = Set.Make(Int) module PSet = ISet module System = Hashtbl.Make(Vect) type proof = | Hyp of int | Elim of var * proof * proof | And of proof * proof let max_nb_cstr = ref max_int type system = { sys : cstr_info ref System.t ; vars : ISet.t } and cstr_info = { bound : interval ; prf : proof ; pos : int ; neg : int ; } (** A system of constraints has the form [\{sys = s ; vars = v\}]. [s] is a hashtable mapping a normalised vector to a [cstr_info] record where - [bound] is an interval - [prf_idx] is the set of hypothesis indexes (i.e. constraints in the initial system) used to obtain the current constraint. In the initial system, each constraint is given an unique singleton proof_idx. When a new constraint c is computed by a function f(c1,...,cn), its proof_idx is ISet.fold union (List.map (fun x -> x.proof_idx) [c1;...;cn] - [pos] is the number of positive values of the vector - [neg] is the number of negative values of the vector ( [neg] + [pos] is therefore the length of the vector) [v] is an upper-bound of the set of variables which appear in [s]. *) (** To be thrown when a system has no solution *) exception SystemContradiction of proof let hyps prf = let rec hyps prf acc = match prf with | Hyp i -> ISet.add i acc | Elim(_,prf1,prf2) | And(prf1,prf2) -> hyps prf1 (hyps prf2 acc) in hyps prf ISet.empty (** Pretty printing *) let rec pp_proof o prf = match prf with | Hyp i -> Printf.fprintf o "H%i" i | Elim(v, prf1,prf2) -> Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2 | And(prf1,prf2) -> Printf.fprintf o "A(%a,%a)" pp_proof prf1 pp_proof prf2 let pp_bound o = function | None -> output_string o "oo" | Some a -> output_string o (string_of_num a) let pp_itv o (l,r) = Printf.fprintf o "(%a,%a)" pp_bound l pp_bound r let pp_iset o s = output_string o "{" ; ISet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); output_string o "}" let pp_pset o s = output_string o "{" ; PSet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); output_string o "}" let pp_info o i = pp_itv o i.bound let pp_cstr o (vect,bnd) = let (l,r) = bnd in (match l with | None -> () | Some n -> Printf.fprintf o "%s <= " (string_of_num n)) ; pp_vect o vect ; (match r with | None -> output_string o"\n" | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n)) let pp_system o sys= System.iter (fun vect ibnd -> pp_cstr o (vect,(!ibnd).bound)) sys let pp_split_cstr o (vl,v,c,_) = Printf.fprintf o "(val x = %s ,%a,%s)" (string_of_num vl) pp_vect v (string_of_num c) (** [merge_cstr_info] takes: - the intersection of bounds and - the union of proofs - [pos] and [neg] fields should be identical *) let merge_cstr_info i1 i2 = let { pos = p1 ; neg = n1 ; bound = i1 ; prf = prf1 } = i1 and { pos = p2 ; neg = n2 ; bound = i2 ; prf = prf2 } = i2 in assert (Int.equal p1 p2 && Int.equal n1 n2) ; match inter i1 i2 with | None -> None (* Could directly raise a system contradiction exception *) | Some bnd -> Some { pos = p1 ; neg = n1 ; bound = bnd ; prf = And(prf1,prf2) } (** [xadd_cstr vect cstr_info] loads an constraint into the system. The constraint is neither redundant nor contradictory. @raise SystemContradiction if [cstr_info] returns [None] *) let xadd_cstr vect cstr_info sys = try let info = System.find sys vect in match merge_cstr_info cstr_info !info with | None -> raise (SystemContradiction (And(cstr_info.prf, (!info).prf))) | Some info' -> info := info' with | Not_found -> System.replace sys vect (ref cstr_info) exception TimeOut let xadd_cstr vect cstr_info sys = if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ; if System.length sys < !max_nb_cstr then xadd_cstr vect cstr_info sys else raise TimeOut type cstr_ext = | Contradiction (** The constraint is contradictory. Typically, a [SystemContradiction] exception will be raised. *) | Redundant (** The constrain is redundant. Typically, the constraint will be dropped *) | Cstr of vector * cstr_info (** Taken alone, the constraint is neither contradictory nor redundant. Typically, it will be added to the constraint system. *) (** [normalise_cstr] : vector -> cstr_info -> cstr_ext *) let normalise_cstr vect cinfo = match norm_itv cinfo.bound with | None -> Contradiction | Some (l,r) -> match vect with | [] -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction | (_,n)::_ -> Cstr( (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect), let divn x = x // n in if Int.equal (sign_num n) 1 then{cinfo with bound = (map_option divn l , map_option divn r) } else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (map_option divn r , map_option divn l)}) (** For compatibility, there is an external representation of constraints *) let eval_op = function | Eq -> (=/) | Ge -> (>=/) let count v = let rec count n p v = match v with | [] -> (n,p) | (_,vl)::v -> let sg = sign_num vl in assert (sg <> 0) ; if Int.equal sg 1 then count n (p+1) v else count (n+1) p v in count 0 0 v let norm_cstr {coeffs = v ; op = o ; cst = c} idx = let (n,p) = count v in normalise_cstr v {pos = p ; neg = n ; bound = (match o with | Eq -> Some c , Some c | Ge -> Some c , None) ; prf = Hyp idx } (** [load_system l] takes a list of constraints of type [cstr_compat] @return a system of constraints @raise SystemContradiction if a contradiction is found *) let load_system l = let sys = System.create 1000 in let li = Mutils.mapi (fun e i -> (e,i)) l in let vars = List.fold_left (fun vrs (cstr,i) -> match norm_cstr cstr i with | Contradiction -> raise (SystemContradiction (Hyp i)) | Redundant -> vrs | Cstr(vect,info) -> xadd_cstr vect info sys ; List.fold_left (fun s (v,_) -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in {sys = sys ;vars = vars} let system_list sys = let { sys = s ; vars = v } = sys in System.fold (fun k bi l -> (k, !bi)::l) s [] (** [add (v1,c1) (v2,c2) ] precondition: (c1 <>/ Int 0 && c2 <>/ Int 0) @return a pair [(v,ln)] such that [v] is the sum of vector [v1] divided by [c1] and vector [v2] divided by [c2] Note that the resulting vector is not normalised. *) let add (v1,c1) (v2,c2) = assert (c1 <>/ Int 0 && c2 <>/ Int 0) ; let rec xadd v1 v2 = match v1 , v2 with | (x1,n1)::v1' , (x2,n2)::v2' -> if Int.equal x1 x2 then let n' = (n1 // c1) +/ (n2 // c2) in if n' =/ Int 0 then xadd v1' v2' else let res = xadd v1' v2' in (x1,n') ::res else if x1 < x2 then let res = xadd v1' v2 in (x1, n1 // c1)::res else let res = xadd v1 v2' in (x2, n2 // c2)::res | [] , [] -> [] | [] , _ -> List.map (fun (x,vl) -> (x,vl // c2)) v2 | _ , [] -> List.map (fun (x,vl) -> (x,vl // c1)) v1 in let res = xadd v1 v2 in (res, count res) let add (v1,c1) (v2,c2) = let res = add (v1,c1) (v2,c2) in (* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*) res type tlr = (num * vector * cstr_info) list type tm = (vector * cstr_info ) list (** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *) (** [split x vect info (l,m,r)] @param v is the variable to eliminate @param l contains constraints such that (e + a*x) // a >= c / a @param r contains constraints such that (e + a*x) // - a >= c / -a @param m contains constraints which do not mention [x] *) let split x (vect: vector) info (l,m,r) = match get x vect with | None -> (* The constraint does not mention [x], store it in m *) (l,(vect,info)::m,r) | Some vl -> (* otherwise *) let cons_bound lst bd = match bd with | None -> lst | Some bnd -> (vl,vect,{info with bound = Some bnd,None})::lst in let lb,rb = info.bound in if Int.equal (sign_num vl) 1 then (cons_bound l lb,m,cons_bound r rb) else (* sign_num vl = -1 *) (cons_bound l rb,m,cons_bound r lb) (** [project vr sys] projects system [sys] over the set of variables [ISet.remove vr sys.vars ]. This is a one step Fourier elimination. *) let project vr sys = let (l,m,r) = System.fold (fun vect rf l_m_r -> split vr vect !rf l_m_r) sys.sys ([],[],[]) in let new_sys = System.create (System.length sys.sys) in (* Constraints in [m] belong to the projection - for those [vr] is already projected out *) List.iter (fun (vect,info) -> System.replace new_sys vect (ref info) ) m ; let elim (v1,vect1,info1) (v2,vect2,info2) = let {neg = n1 ; pos = p1 ; bound = bound1 ; prf = prf1} = info1 and {neg = n2 ; pos = p2 ; bound = bound2 ; prf = prf2} = info2 in let bnd1 = from_option (fst bound1) and bnd2 = from_option (fst bound2) in let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in let vres,(n,p) = add (vect1,v1) (vect2,minus_num v2) in (vres,{neg = n ; pos = p ; bound = (Some bound, None); prf = Elim(vr,info1.prf,info2.prf)}) in List.iter(fun l_elem -> List.iter (fun r_elem -> let (vect,info) = elim l_elem r_elem in match normalise_cstr vect info with | Redundant -> () | Contradiction -> raise (SystemContradiction info.prf) | Cstr(vect,info) -> xadd_cstr vect info new_sys) r ) l; {sys = new_sys ; vars = ISet.remove vr sys.vars} (** [project_using_eq] performs elimination by pivoting using an equation. This is the counter_part of the [elim] sub-function of [!project]. @param vr is the variable to be used as pivot @param c is the coefficient of variable [vr] in vector [vect] @param len is the length of the equation @param bound is the bound of the equation @param prf is the proof of the equation *) let project_using_eq vr c vect bound prf (vect',info') = match get vr vect' with | Some c2 -> let c1 = if c2 >=/ Int 0 then minus_num c else c in let c2 = abs_num c2 in let (vres,(n,p)) = add (vect,c1) (vect', c2) in let cst = bound // c1 in let bndres = let f x = cst +/ x // c2 in let (l,r) = info'.bound in (map_option f l , map_option f r) in (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)}) | None -> (vect',info') let elim_var_using_eq vr vect cst prf sys = let c = from_option (get vr vect) in let elim_var = project_using_eq vr c vect cst prf in let new_sys = System.create (System.length sys.sys) in System.iter(fun vect iref -> let (vect',info') = elim_var (vect,!iref) in match normalise_cstr vect' info' with | Redundant -> () | Contradiction -> raise (SystemContradiction info'.prf) | Cstr(vect,info') -> xadd_cstr vect info' new_sys) sys.sys ; {sys = new_sys ; vars = ISet.remove vr sys.vars} (** [size sys] computes the number of entries in the system of constraints *) let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0 module IMap = Map.Make(Int) let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (string_of_num elt)) map () (** [eval_vect map vect] evaluates vector [vect] using the values of [map]. If [map] binds all the variables of [vect], we get [eval_vect map [(x1,v1);...;(xn,vn)] = (IMap.find x1 map * v1) + ... + (IMap.find xn map) * vn , []] The function returns as second argument, a sub-vector consisting in the variables that are not in [map]. *) let eval_vect map vect = let rec xeval_vect vect sum rst = match vect with | [] -> (sum,rst) | (v,vl)::vect -> try let val_v = IMap.find v map in xeval_vect vect (sum +/ (val_v */ vl)) rst with Not_found -> xeval_vect vect sum ((v,vl)::rst) in xeval_vect vect (Int 0) [] (** [restrict_bound n sum itv] returns the interval of [x] given that (fst itv) <= x * n + sum <= (snd itv) *) let restrict_bound n sum (itv:interval) = let f x = (x -/ sum) // n in let l,r = itv in match sign_num n with | 0 -> if in_bound itv sum then (None,None) (* redundant *) else failwith "SystemContradiction" | 1 -> map_option f l , map_option f r | _ -> map_option f r , map_option f l (** [bound_of_variable map v sys] computes the interval of [v] in [sys] given a mapping [map] binding all the other variables *) let bound_of_variable map v sys = System.fold (fun vect iref bnd -> let sum,rst = eval_vect map vect in let vl = match get v rst with | None -> Int 0 | Some v -> v in match inter bnd (restrict_bound vl sum (!iref).bound) with | None -> failwith "bound_of_variable: impossible" | Some itv -> itv) sys (None,None) (** [pick_small_value bnd] picks a value being closed to zero within the interval *) let pick_small_value bnd = match bnd with | None , None -> Int 0 | None , Some i -> if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i | Some i,None -> if i <=/ (Int 0) then Int 0 else ceiling_num i | Some i,Some j -> if i <=/ Int 0 && Int 0 <=/ j then Int 0 else if ceiling_num i <=/ floor_num j then ceiling_num i (* why not *) else i (** [solution s1 sys_l = Some(sn,\[(vn-1,sn-1);...; (v1,s1)\]\@sys_l)] then [sn] is a system which contains only [black_v] -- if it existed in [s1] and [sn+1] is obtained by projecting [vn] out of [sn] @raise SystemContradiction if system [s] has no solution *) let solve_sys black_v choose_eq choose_variable sys sys_l = let rec solve_sys sys sys_l = if debug then Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys); let eqs = choose_eq sys in try let (v,vect,cst,ln) = fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in if debug then (Printf.printf "\nE %a = %s variable %i\n" pp_vect vect (string_of_num cst) v ; flush stdout); let sys' = elim_var_using_eq v vect cst ln sys in solve_sys sys' ((v,sys)::sys_l) with Not_found -> let vars = choose_variable sys in try let (v,est) = (List.find (fun (v,_) -> v <> black_v) vars) in if debug then (Printf.printf "\nV : %i estimate %f\n" v est ; flush stdout) ; let sys' = project v sys in solve_sys sys' ((v,sys)::sys_l) with Not_found -> (* we are done *) Inl (sys,sys_l) in solve_sys sys sys_l let solve black_v choose_eq choose_variable cstrs = try let sys = load_system cstrs in if debug then Printf.printf "solve :\n %a" pp_system sys.sys ; solve_sys black_v choose_eq choose_variable sys [] with SystemContradiction prf -> Inr prf (** The purpose of module [EstimateElimVar] is to try to estimate the cost of eliminating a variable. The output is an ordered list of (variable,cost). *) module EstimateElimVar = struct type sys_list = (vector * cstr_info) list let abstract_partition (v:int) (l: sys_list) = let rec xpart (l:sys_list) (ltl:sys_list) (n:int list) (z:int) (p:int list) = match l with | [] -> (ltl, n,z,p) | (l1,info) ::rl -> match l1 with | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p | (vr,vl)::rl1 -> if Int.equal v vr then let cons_bound lst bd = match bd with | None -> lst | Some bnd -> info.neg+info.pos::lst in let lb,rb = info.bound in if Int.equal (sign_num vl) 1 then xpart rl ((rl1,info)::ltl) (cons_bound n lb) z (cons_bound p rb) else xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb) else (* the variable is greater *) xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p in let (sys',n,z,p) = xpart l [] [] 0 [] in let ln = float_of_int (List.length n) in let sn = float_of_int (List.fold_left (+) 0 n) in let lp = float_of_int (List.length p) in let sp = float_of_int (List.fold_left (+) 0 p) in (sys', float_of_int z +. lp *. sn +. ln *. sp -. lp*.ln) let choose_variable sys = let {sys = s ; vars = v} = sys in let sl = system_list sys in let evals = fst (ISet.fold (fun v (eval,s) -> let ts,vl = abstract_partition v s in ((v,vl)::eval, ts)) v ([],sl)) in List.sort (fun x y -> compare_float (snd x) (snd y) ) evals end open EstimateElimVar (** The module [EstimateElimEq] is similar to [EstimateElimVar] but it orders equations. *) module EstimateElimEq = struct let itv_point bnd = match bnd with |(Some a, Some b) -> a =/ b | _ -> false let eq_bound bnd c = match bnd with |(Some a, Some b) -> a =/ b && c =/ b | _ -> false let rec unroll_until v l = match l with | [] -> (false,[]) | (i,_)::rl -> if Int.equal i v then (true,rl) else if i < v then unroll_until v rl else (false,l) let rec choose_simple_equation eqs = match eqs with | [] -> None | (vect,a,prf,ln)::eqs -> match vect with | [i,_] -> Some (i,vect,a,prf,ln) | _ -> choose_simple_equation eqs let choose_primal_equation eqs sys_l = (* Counts the number of equations referring to variable [v] -- It looks like nb_cst is dead... *) let is_primal_equation_var v = List.fold_left (fun nb_eq (vect,info) -> if fst (unroll_until v vect) then if itv_point info.bound then nb_eq + 1 else nb_eq else nb_eq) 0 sys_l in let rec find_var vect = match vect with | [] -> None | (i,_)::vect -> let nb_eq = is_primal_equation_var i in if Int.equal nb_eq 2 then Some i else find_var vect in let rec find_eq_var eqs = match eqs with | [] -> None | (vect,a,prf,ln)::l -> match find_var vect with | None -> find_eq_var l | Some r -> Some (r,vect,a,prf,ln) in match choose_simple_equation eqs with | None -> find_eq_var eqs | Some res -> Some res let choose_equality_var sys = let sys_l = system_list sys in let equalities = List.fold_left (fun l (vect,info) -> match info.bound with | Some a , Some b -> if a =/ b then (* This an equation *) (vect,a,info.prf,info.neg+info.pos)::l else l | _ -> l ) [] sys_l in let rec estimate_cost v ct sysl acc tlsys = match sysl with | [] -> (acc,tlsys) | (l,info)::rsys -> let ln = info.pos + info.neg in let (b,l) = unroll_until v l in match b with | true -> if itv_point info.bound then estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) (* this is free *) else estimate_cost v ct rsys (acc+ln+ct) ((l,info)::tlsys) (* should be more ? *) | false -> estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) in match choose_primal_equation equalities sys_l with | None -> let cost_eq eq const prf ln acc_costs = let rec cost_eq eqr sysl costs = match eqr with | [] -> costs | (v,_) ::eqr -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in cost_eq eqr tlsys (((v,eq,const,prf),cst)::costs) in cost_eq eq sys_l acc_costs in let all_costs = List.fold_left (fun all_costs (vect,const,prf,ln) -> cost_eq vect const prf ln all_costs) [] equalities in (* pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *) List.sort (fun x y -> Int.compare (snd x) (snd y) ) all_costs | Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0] end open EstimateElimEq module Fourier = struct let optimise vect l = (* We add a dummy (fresh) variable for vector *) let fresh = List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 l in let cstr = { coeffs = Vect.set fresh (Int (-1)) vect ; op = Eq ; cst = (Int 0)} in match solve fresh choose_equality_var choose_variable (cstr::l) with | Inr prf -> None (* This is an unsatisfiability proof *) | Inl (s,_) -> try Some (bound_of_variable IMap.empty fresh s.sys) with x when CErrors.noncritical x -> Printf.printf "optimise Exception : %s" (Printexc.to_string x); None let find_point cstrs = match solve max_int choose_equality_var choose_variable cstrs with | Inr prf -> Inr prf | Inl (_,l) -> let rec rebuild_solution l map = match l with | [] -> map | (v,e)::l -> let itv = bound_of_variable map v e.sys in let map = IMap.add v (pick_small_value itv) map in rebuild_solution l map in let map = rebuild_solution l IMap.empty in let vect = List.rev (IMap.fold (fun v i vect -> (v,i)::vect) map []) in (* Printf.printf "SOLUTION %a" pp_vect vect ; *) let res = Inl vect in res end module Proof = struct (** A proof term in the sense of a ZMicromega.RatProof is a positive combination of the hypotheses which leads to a contradiction. The proofs constructed by Fourier elimination are more like execution traces: - certain facts are recorded but are useless - certain inferences are implicit. The following code implements proof reconstruction. *) let add x y = fst (add x y) let forall_pairs f l1 l2 = List.fold_left (fun acc e1 -> List.fold_left (fun acc e2 -> match f e1 e2 with | None -> acc | Some v -> v::acc) acc l2) [] l1 let add_op x y = match x , y with | Eq , Eq -> Eq | _ -> Ge let pivot v (p1,c1) (p2,c2) = let {coeffs = v1 ; op = op1 ; cst = n1} = c1 and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in match Vect.get v v1 , Vect.get v v2 with | None , _ | _ , None -> None | Some a , Some b -> if Int.equal ((sign_num a) * (sign_num b)) (-1) then Some (add (p1,abs_num a) (p2,abs_num b) , {coeffs = add (v1,abs_num a) (v2,abs_num b) ; op = add_op op1 op2 ; cst = n1 // (abs_num a) +/ n2 // (abs_num b) }) else if op1 == Eq then Some (add (p1,minus_num (a // b)) (p2,Int 1), {coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ; op = add_op op1 op2; cst = n1 // (minus_num (a// b)) +/ n2 // (Int 1)}) else if op2 == Eq then Some (add (p2,minus_num (b // a)) (p1,Int 1), {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ; op = add_op op1 op2; cst = n2 // (minus_num (b// a)) +/ n1 // (Int 1)}) else None (* op2 could be Eq ... this might happen *) let normalise_proofs l = List.fold_left (fun acc (prf,cstr) -> match acc with | Inr _ -> acc (* I already found a contradiction *) | Inl acc -> match norm_cstr cstr 0 with | Redundant -> Inl acc | Contradiction -> Inr (prf,cstr) | Cstr(v,info) -> Inl ((prf,cstr,v,info)::acc)) (Inl []) l type oproof = (vector * cstr_compat * num) option let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) = let (l,r) = info.bound in let keep p ob bd = match ob , bd with | None , None -> None | None , Some b -> Some(prf,cstr,b) | Some _ , None -> ob | Some(prfl,cstrl,bl) , Some b -> if p bl b then Some(prf,cstr, b) else ob in let oleft = keep (<=/) oleft l in let oright = keep (>=/) oright r in (* Now, there might be a contradiction *) match oleft , oright with | None , _ | _ , None -> Inl (oleft,oright) | Some(prfl,cstrl,l) , Some(prfr,cstrr,r) -> if l <=/ r then Inl (oleft,oright) else (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*) match cstrr.coeffs with | [] -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *) | (v,_)::_ -> match pivot v (prfl,cstrl) (prfr,cstrr) with | None -> failwith "merge_proof : pivot is not possible" | Some x -> Inr x let mk_proof hyps prf = (* I am keeping list - I might have a proof for the left bound and a proof for the right bound. If I perform aggressive elimination of redundancies, I expect the list to be of length at most 2. For each proof list, all the vectors should be of the form a.v for different constants a. *) let rec mk_proof prf = match prf with | Hyp i -> [ ([i, Int 1] , List.nth hyps i) ] | Elim(v,prf1,prf2) -> let prfsl = mk_proof prf1 and prfsr = mk_proof prf2 in (* I take only the pairs for which the elimination is meaningful *) forall_pairs (pivot v) prfsl prfsr | And(prf1,prf2) -> let prfsl1 = mk_proof prf1 and prfsl2 = mk_proof prf2 in (* detect trivial redundancies and contradictions *) match normalise_proofs (prfsl1@prfsl2) with | Inr x -> [x] (* This is a contradiction - this should be the end of the proof *) | Inl l -> (* All the vectors are the same *) let prfs = List.fold_left (fun acc e -> match acc with | Inr _ -> acc (* I have a contradiction *) | Inl (oleft,oright) -> merge_proof oleft e oright) (Inl(None,None)) l in match prfs with | Inr x -> [x] | Inl (oleft,oright) -> match oleft , oright with | None , None -> [] | None , Some(prf,cstr,_) | Some(prf,cstr,_) , None -> [prf,cstr] | Some(prf1,cstr1,_) , Some(prf2,cstr2,_) -> [prf1,cstr1;prf2,cstr2] in mk_proof prf end coq-8.6/plugins/micromega/OrderedRing.v0000644000175000017500000003344713022274260017511 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R -> R) (ropp : R -> R). Variable req rle rlt : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (rplus x y). Notation "x * y " := (rtimes x y). Notation "x - y " := (rminus x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Notation "x ~= y" := (~ req x y). Notation "x <= y" := (rle x y). Notation "x < y" := (rlt x y). Record SOR : Type := mk_SOR_theory { SORsetoid : Setoid_Theory R req; SORplus_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; SORtimes_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2; SORopp_wd : forall x1 x2, x1 == x2 -> -x1 == -x2; SORle_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 <= y1 <-> x2 <= y2); SORlt_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 < y1 <-> x2 < y2); SORrt : ring_theory rO rI rplus rtimes rminus ropp req; SORle_refl : forall n : R, n <= n; SORle_antisymm : forall n m : R, n <= m -> m <= n -> n == m; SORle_trans : forall n m p : R, n <= m -> m <= p -> n <= p; SORlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m; SORlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n; SORplus_le_mono_l : forall n m p : R, n <= m -> p + n <= p + m; SORtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m; SORneq_0_1 : 0 ~= 1 }. (* We cannot use Relation_Definitions.order.ord_antisym and Relations_1.Antisymmetric because they refer to Leibniz equality *) End DEFINITIONS. Section STRICT_ORDERED_RING. Variable R : Type. Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R). Variable req rle rlt : R -> R -> Prop. Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (rplus x y). Notation "x * y " := (rtimes x y). Notation "x - y " := (rminus x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Notation "x ~= y" := (~ req x y). Notation "x <= y" := (rle x y). Notation "x < y" := (rlt x y). Add Relation R req reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) as sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. exact sor.(SORplus_wd). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. exact sor.(SORtimes_wd). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. exact sor.(SORopp_wd). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. exact sor.(SORle_wd). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. exact sor.(SORlt_wd). Qed. Add Ring SOR : sor.(SORrt). Add Morphism rminus with signature req ==> req ==> req as rminus_morph. Proof. intros x1 x2 H1 y1 y2 H2. rewrite (sor.(SORrt).(Rsub_def) x1 y1). rewrite (sor.(SORrt).(Rsub_def) x2 y2). rewrite H1; now rewrite H2. Qed. Theorem Rneq_symm : forall n m : R, n ~= m -> m ~= n. Proof. intros n m H1 H2; rewrite H2 in H1; now apply H1. Qed. (* Propeties of plus, minus and opp *) Theorem Rplus_0_l : forall n : R, 0 + n == n. Proof. intro; ring. Qed. Theorem Rplus_0_r : forall n : R, n + 0 == n. Proof. intro; ring. Qed. Theorem Rtimes_0_r : forall n : R, n * 0 == 0. Proof. intro; ring. Qed. Theorem Rplus_comm : forall n m : R, n + m == m + n. Proof. intros; ring. Qed. Theorem Rtimes_0_l : forall n : R, 0 * n == 0. Proof. intro; ring. Qed. Theorem Rtimes_comm : forall n m : R, n * m == m * n. Proof. intros; ring. Qed. Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m. Proof. intros n m. split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H. now rewrite Rplus_0_l. rewrite H; ring. Qed. Theorem Rplus_cancel_l : forall n m p : R, p + n == p + m <-> n == m. Proof. intros n m p; split; intro H. setoid_replace n with (- p + (p + n)) by ring. setoid_replace m with (- p + (p + m)) by ring. now rewrite H. now rewrite H. Qed. (* Relations *) Theorem Rle_refl : forall n : R, n <= n. Proof sor.(SORle_refl). Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m. Proof sor.(SORle_antisymm). Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p. Proof sor.(SORle_trans). Theorem Rlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n. Proof sor.(SORlt_trichotomy). Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m. Proof sor.(SORlt_le_neq). Theorem Rneq_0_1 : 0 ~= 1. Proof sor.(SORneq_0_1). Theorem Req_em : forall n m : R, n == m \/ n ~= m. Proof. intros n m. destruct (Rlt_trichotomy n m) as [H | [H | H]]; try rewrite Rlt_le_neq in H. right; now destruct H. now left. right; apply Rneq_symm; now destruct H. Qed. Theorem Req_dne : forall n m : R, ~ ~ n == m <-> n == m. Proof. intros n m; destruct (Req_em n m) as [H | H]. split; auto. split. intro H1; false_hyp H H1. auto. Qed. Theorem Rle_lt_eq : forall n m : R, n <= m <-> n < m \/ n == m. Proof. intros n m; rewrite Rlt_le_neq. split; [intro H | intros [[H1 H2] | H]]. destruct (Req_em n m) as [H1 | H1]. now right. left; now split. assumption. rewrite H; apply Rle_refl. Qed. Ltac le_less := rewrite Rle_lt_eq; left; try assumption. Ltac le_equal := rewrite Rle_lt_eq; right; try reflexivity; try assumption. Ltac le_elim H := rewrite Rle_lt_eq in H; destruct H as [H | H]. Theorem Rlt_trans : forall n m p : R, n < m -> m < p -> n < p. Proof. intros n m p; repeat rewrite Rlt_le_neq; intros [H1 H2] [H3 H4]; split. now apply Rle_trans with m. intro H. rewrite H in H1. pose proof (Rle_antisymm H3 H1). now apply H4. Qed. Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p. Proof. intros n m p H1 H2; le_elim H1. now apply Rlt_trans with (m := m). now rewrite H1. Qed. Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p. Proof. intros n m p H1 H2; le_elim H2. now apply Rlt_trans with (m := m). now rewrite <- H2. Qed. Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n. Proof. intros n m; destruct (Rlt_trichotomy n m) as [H | [H | H]]. left; now le_less. left; now le_equal. now right. Qed. Theorem Rlt_neq : forall n m : R, n < m -> n ~= m. Proof. intros n m; rewrite Rlt_le_neq; now intros [_ H]. Qed. Theorem Rle_ngt : forall n m : R, n <= m <-> ~ m < n. Proof. intros n m; split. intros H H1; assert (H2 : n < n) by now apply Rle_lt_trans with m. now apply (Rlt_neq H2). intro H. destruct (Rle_gt_cases n m) as [H1 | H1]. assumption. false_hyp H1 H. Qed. Theorem Rlt_nge : forall n m : R, n < m <-> ~ m <= n. Proof. intros n m; split. intros H H1; assert (H2 : n < n) by now apply Rlt_le_trans with m. now apply (Rlt_neq H2). intro H. destruct (Rle_gt_cases m n) as [H1 | H1]. false_hyp H1 H. assumption. Qed. (* Plus, minus and order *) Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m. Proof. intros n m p; split. apply sor.(SORplus_le_mono_l). intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H. setoid_replace (- p + (p + n)) with n in H by ring. setoid_replace (- p + (p + m)) with m in H by ring. assumption. Qed. Theorem Rplus_le_mono_r : forall n m p : R, n <= m <-> n + p <= m + p. Proof. intros n m p; rewrite (Rplus_comm n p); rewrite (Rplus_comm m p). apply Rplus_le_mono_l. Qed. Theorem Rplus_lt_mono_l : forall n m p : R, n < m <-> p + n < p + m. Proof. intros n m p; do 2 rewrite Rlt_le_neq. rewrite Rplus_cancel_l. now rewrite <- Rplus_le_mono_l. Qed. Theorem Rplus_lt_mono_r : forall n m p : R, n < m <-> n + p < m + p. Proof. intros n m p. rewrite (Rplus_comm n p); rewrite (Rplus_comm m p); apply Rplus_lt_mono_l. Qed. Theorem Rplus_lt_mono : forall n m p q : R, n < m -> p < q -> n + p < m + q. Proof. intros n m p q H1 H2. apply Rlt_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_lt_mono_l]. Qed. Theorem Rplus_le_mono : forall n m p q : R, n <= m -> p <= q -> n + p <= m + q. Proof. intros n m p q H1 H2. apply Rle_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_le_mono_l]. Qed. Theorem Rplus_lt_le_mono : forall n m p q : R, n < m -> p <= q -> n + p < m + q. Proof. intros n m p q H1 H2. apply Rlt_le_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_le_mono_l]. Qed. Theorem Rplus_le_lt_mono : forall n m p q : R, n <= m -> p < q -> n + p < m + q. Proof. intros n m p q H1 H2. apply Rle_lt_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_lt_mono_l]. Qed. Theorem Rplus_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n + m. Proof. intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_mono. Qed. Theorem Rplus_pos_nonneg : forall n m : R, 0 < n -> 0 <= m -> 0 < n + m. Proof. intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_le_mono. Qed. Theorem Rplus_nonneg_pos : forall n m : R, 0 <= n -> 0 < m -> 0 < n + m. Proof. intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_lt_mono. Qed. Theorem Rplus_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n + m. Proof. intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_mono. Qed. Theorem Rle_le_minus : forall n m : R, n <= m <-> 0 <= m - n. Proof. intros n m. rewrite (@Rplus_le_mono_r n m (- n)). setoid_replace (n + - n) with 0 by ring. now setoid_replace (m + - n) with (m - n) by ring. Qed. Theorem Rlt_lt_minus : forall n m : R, n < m <-> 0 < m - n. Proof. intros n m. rewrite (@Rplus_lt_mono_r n m (- n)). setoid_replace (n + - n) with 0 by ring. now setoid_replace (m + - n) with (m - n) by ring. Qed. Theorem Ropp_lt_mono : forall n m : R, n < m <-> - m < - n. Proof. intros n m. split; intro H. apply -> (@Rplus_lt_mono_l n m (- n - m)) in H. setoid_replace (- n - m + n) with (- m) in H by ring. now setoid_replace (- n - m + m) with (- n) in H by ring. apply -> (@Rplus_lt_mono_l (- m) (- n) (n + m)) in H. setoid_replace (n + m + - m) with n in H by ring. now setoid_replace (n + m + - n) with m in H by ring. Qed. Theorem Ropp_pos_neg : forall n : R, 0 < - n <-> n < 0. Proof. intro n; rewrite (Ropp_lt_mono n 0). now setoid_replace (- 0) with 0 by ring. Qed. (* Times and order *) Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m. Proof sor.(SORtimes_pos_pos). Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m. Proof. intros n m H1 H2. le_elim H1. le_elim H2. le_less; now apply Rtimes_pos_pos. rewrite <- H2; rewrite Rtimes_0_r; le_equal. rewrite <- H1; rewrite Rtimes_0_l; le_equal. Qed. Theorem Rtimes_pos_neg : forall n m : R, 0 < n -> m < 0 -> n * m < 0. Proof. intros n m H1 H2. apply -> Ropp_pos_neg. setoid_replace (- (n * m)) with (n * (- m)) by ring. apply Rtimes_pos_pos. assumption. now apply <- Ropp_pos_neg. Qed. Theorem Rtimes_neg_neg : forall n m : R, n < 0 -> m < 0 -> 0 < n * m. Proof. intros n m H1 H2. setoid_replace (n * m) with ((- n) * (- m)) by ring. apply Rtimes_pos_pos; now apply <- Ropp_pos_neg. Qed. Theorem Rtimes_square_nonneg : forall n : R, 0 <= n * n. Proof. intro n; destruct (Rlt_trichotomy 0 n) as [H | [H | H]]. le_less; now apply Rtimes_pos_pos. rewrite <- H, Rtimes_0_l; le_equal. le_less; now apply Rtimes_neg_neg. Qed. Theorem Rtimes_neq_0 : forall n m : R, n ~= 0 /\ m ~= 0 -> n * m ~= 0. Proof. intros n m [H1 H2]. destruct (Rlt_trichotomy n 0) as [H3 | [H3 | H3]]; destruct (Rlt_trichotomy m 0) as [H4 | [H4 | H4]]; try (false_hyp H3 H1); try (false_hyp H4 H2). apply Rneq_symm. apply Rlt_neq. now apply Rtimes_neg_neg. apply Rlt_neq. rewrite Rtimes_comm. now apply Rtimes_pos_neg. apply Rlt_neq. now apply Rtimes_pos_neg. apply Rneq_symm. apply Rlt_neq. now apply Rtimes_pos_pos. Qed. (* The following theorems are used to build a morphism from Z to R and prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *) (* Surprisingly, multilication is needed to prove the following theorem *) Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n. Proof. intro n; setoid_replace n with (- - n) by ring. rewrite Ropp_pos_neg. now setoid_replace (- - n) with n by ring. Qed. Theorem Rlt_0_1 : 0 < 1. Proof. apply <- Rlt_le_neq. split. setoid_replace 1 with (1 * 1) by ring. apply Rtimes_square_nonneg. apply Rneq_0_1. Qed. Theorem Rlt_succ_r : forall n : R, n < 1 + n. Proof. intro n. rewrite <- (Rplus_0_l n); setoid_replace (1 + (0 + n)) with (1 + n) by ring. apply -> Rplus_lt_mono_r. apply Rlt_0_1. Qed. Theorem Rlt_lt_succ : forall n m : R, n < m -> n < 1 + m. Proof. intros n m H; apply Rlt_trans with m. assumption. apply Rlt_succ_r. Qed. (*Theorem Rtimes_lt_mono_pos_l : forall n m p : R, 0 < p -> n < m -> p * n < p * m. Proof. intros n m p H1 H2. apply <- Rlt_lt_minus. setoid_replace (p * m - p * n) with (p * (m - n)) by ring. apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus. Qed.*) End STRICT_ORDERED_RING. coq-8.6/plugins/micromega/sos.mli0000644000175000017500000000221113022274260016406 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool val poly_neg : poly -> poly val poly_mul : poly -> poly -> poly val poly_pow : poly -> int -> poly val poly_const : Num.num -> poly val poly_of_term : term -> poly val term_of_poly : poly -> term val term_of_sos : positivstellensatz * (Num.num * poly) list -> positivstellensatz val string_of_poly : poly -> string val real_positivnullstellensatz_general : bool -> int -> poly list -> (poly * positivstellensatz) list -> poly -> poly list * (positivstellensatz * (Num.num * poly) list) list val sumofsquares : poly -> Num.num * ( Num.num * poly) list coq-8.6/plugins/micromega/Env.v0000644000175000017500000000603313022274260016024 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* D. Definition jump (j:positive) (e:Env) := fun x => e (x+j). Definition nth (n:positive) (e:Env) := e n. Definition hd (e:Env) := nth 1 e. Definition tail (e:Env) := jump 1 e. Lemma jump_add i j l x : jump (i + j) l x = jump i (jump j l) x. Proof. unfold jump. f_equal. apply Pos.add_assoc. Qed. Lemma jump_simpl p l x : jump p l x = match p with | xH => tail l x | xO p => jump p (jump p l) x | xI p => jump p (jump p (tail l)) x end. Proof. destruct p; unfold tail; rewrite <- ?jump_add; f_equal; now rewrite Pos.add_diag. Qed. Lemma jump_tl j l x : tail (jump j l) x = jump j (tail l) x. Proof. unfold tail. rewrite <- !jump_add. f_equal. apply Pos.add_comm. Qed. Lemma jump_succ j l x : jump (Pos.succ j) l x = jump 1 (jump j l) x. Proof. rewrite <- jump_add. f_equal. symmetry. apply Pos.add_1_l. Qed. Lemma jump_pred_double i l x : jump (Pos.pred_double i) (tail l) x = jump i (jump i l) x. Proof. unfold tail. rewrite <- !jump_add. f_equal. now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag. Qed. Lemma nth_spec p l : nth p l = match p with | xH => hd l | xO p => nth p (jump p l) | xI p => nth p (jump p (tail l)) end. Proof. unfold hd, nth, tail, jump. destruct p; f_equal; now rewrite Pos.add_diag. Qed. Lemma nth_jump p l : nth p (tail l) = hd (jump p l). Proof. unfold hd, nth, tail, jump. f_equal. apply Pos.add_comm. Qed. Lemma nth_pred_double p l : nth (Pos.pred_double p) (tail l) = nth p (jump p l). Proof. unfold nth, tail, jump. f_equal. now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag. Qed. End S. Ltac jump_simpl := repeat match goal with | |- context [jump xH] => rewrite (jump_simpl xH) | |- context [jump (xO ?p)] => rewrite (jump_simpl (xO p)) | |- context [jump (xI ?p)] => rewrite (jump_simpl (xI p)) end. coq-8.6/plugins/micromega/Lqa.v0000644000175000017500000000372313022274260016014 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ((sos_Q rchecker) || (psatz_Q d rchecker)) | _ => fail "Unsupported domain" end in tac. Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/micromega/sos_lib.ml0000644000175000017500000005344613022274260017103 0ustar mdenesmdenes(* ========================================================================= *) (* - This code originates from John Harrison's HOL LIGHT 2.30 *) (* (see file LICENSE.sos for license, copyright and disclaimer) *) (* This code is the HOL LIGHT library code used by sos.ml *) (* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL *) (* independent bits *) (* - Frédéric Besson (fbesson@irisa.fr) is using it to feed micromega *) (* ========================================================================= *) open Num let debugging = ref false;; (* ------------------------------------------------------------------------- *) (* Comparisons that are reflexive on NaN and also short-circuiting. *) (* ------------------------------------------------------------------------- *) let cmp = Pervasives.compare (** FIXME *) let (=?) = fun x y -> cmp x y = 0;; let ( cmp x y < 0;; let (<=?) = fun x y -> cmp x y <= 0;; let (>?) = fun x y -> cmp x y > 0;; let (>=?) = fun x y -> cmp x y >= 0;; (* ------------------------------------------------------------------------- *) (* Combinators. *) (* ------------------------------------------------------------------------- *) let (o) = fun f g x -> f(g x);; (* ------------------------------------------------------------------------- *) (* Some useful functions on "num" type. *) (* ------------------------------------------------------------------------- *) let num_0 = Int 0 and num_1 = Int 1 and num_2 = Int 2 and num_10 = Int 10;; let pow2 n = power_num num_2 (Int n);; let pow10 n = power_num num_10 (Int n);; let numdom r = let r' = Ratio.normalize_ratio (ratio_of_num r) in num_of_big_int(Ratio.numerator_ratio r'), num_of_big_int(Ratio.denominator_ratio r');; let numerator = (o) fst numdom and denominator = (o) snd numdom;; let gcd_num n1 n2 = num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));; let lcm_num x y = if x =/ num_0 && y =/ num_0 then num_0 else abs_num((x */ y) // gcd_num x y);; (* ------------------------------------------------------------------------- *) (* List basics. *) (* ------------------------------------------------------------------------- *) let rec el n l = if n = 0 then List.hd l else el (n - 1) (List.tl l);; (* ------------------------------------------------------------------------- *) (* Various versions of list iteration. *) (* ------------------------------------------------------------------------- *) let rec itlist f l b = match l with [] -> b | (h::t) -> f h (itlist f t b);; let rec end_itlist f l = match l with [] -> failwith "end_itlist" | [x] -> x | (h::t) -> f h (end_itlist f t);; let rec itlist2 f l1 l2 b = match (l1,l2) with ([],[]) -> b | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b) | _ -> failwith "itlist2";; (* ------------------------------------------------------------------------- *) (* All pairs arising from applying a function over two lists. *) (* ------------------------------------------------------------------------- *) let rec allpairs f l1 l2 = match l1 with h1::t1 -> itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) | [] -> [];; (* ------------------------------------------------------------------------- *) (* String operations (surely there is a better way...) *) (* ------------------------------------------------------------------------- *) let implode l = itlist (^) l "";; let explode s = let rec exap n l = if n < 0 then l else exap (n - 1) ((String.sub s n 1)::l) in exap (String.length s - 1) [];; (* ------------------------------------------------------------------------- *) (* Attempting function or predicate applications. *) (* ------------------------------------------------------------------------- *) let can f x = try (f x; true) with Failure _ -> false;; (* ------------------------------------------------------------------------- *) (* Repetition of a function. *) (* ------------------------------------------------------------------------- *) let rec funpow n f x = if n < 1 then x else funpow (n-1) f (f x);; (* ------------------------------------------------------------------------- *) (* Replication and sequences. *) (* ------------------------------------------------------------------------- *) let rec replicate x n = if n < 1 then [] else x::(replicate x (n - 1));; let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);; (* ------------------------------------------------------------------------- *) (* Various useful list operations. *) (* ------------------------------------------------------------------------- *) let rec forall p l = match l with [] -> true | h::t -> p(h) && forall p t;; let rec tryfind f l = match l with [] -> failwith "tryfind" | (h::t) -> try f h with Failure _ -> tryfind f t;; let index x = let rec ind n l = match l with [] -> failwith "index" | (h::t) -> if x =? h then n else ind (n + 1) t in ind 0;; (* ------------------------------------------------------------------------- *) (* "Set" operations on lists. *) (* ------------------------------------------------------------------------- *) let rec mem x lis = match lis with [] -> false | (h::t) -> x =? h || mem x t;; let insert x l = if mem x l then l else x::l;; let union l1 l2 = itlist insert l1 l2;; let subtract l1 l2 = List.filter (fun x -> not (mem x l2)) l1;; (* ------------------------------------------------------------------------- *) (* Merging and bottom-up mergesort. *) (* ------------------------------------------------------------------------- *) let rec merge ord l1 l2 = match l1 with [] -> l2 | h1::t1 -> match l2 with [] -> l1 | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2) else h2::(merge ord l1 t2);; (* ------------------------------------------------------------------------- *) (* Common measure predicates to use with "sort". *) (* ------------------------------------------------------------------------- *) let increasing f x y = f x ? f y;; (* ------------------------------------------------------------------------- *) (* Zipping, unzipping etc. *) (* ------------------------------------------------------------------------- *) let rec zip l1 l2 = match (l1,l2) with ([],[]) -> [] | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2) | _ -> failwith "zip";; let rec unzip = function [] -> [],[] | ((a,b)::rest) -> let alist,blist = unzip rest in (a::alist,b::blist);; (* ------------------------------------------------------------------------- *) (* Iterating functions over lists. *) (* ------------------------------------------------------------------------- *) let rec do_list f l = match l with [] -> () | (h::t) -> (f h; do_list f t);; (* ------------------------------------------------------------------------- *) (* Sorting. *) (* ------------------------------------------------------------------------- *) let rec sort cmp lis = match lis with [] -> [] | piv::rest -> let r,l = List.partition (cmp piv) rest in (sort cmp l) @ (piv::(sort cmp r));; (* ------------------------------------------------------------------------- *) (* Removing adjacent (NB!) equal elements from list. *) (* ------------------------------------------------------------------------- *) let rec uniq l = match l with x::(y::_ as t) -> let t' = uniq t in if x =? y then t' else if t'==t then l else x::t' | _ -> l;; (* ------------------------------------------------------------------------- *) (* Convert list into set by eliminating duplicates. *) (* ------------------------------------------------------------------------- *) let setify s = uniq (sort (<=?) s);; (* ------------------------------------------------------------------------- *) (* Polymorphic finite partial functions via Patricia trees. *) (* *) (* The point of this strange representation is that it is canonical (equal *) (* functions have the same encoding) yet reasonably efficient on average. *) (* *) (* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). *) (* ------------------------------------------------------------------------- *) type ('a,'b)func = Empty | Leaf of int * ('a*'b)list | Branch of int * int * ('a,'b)func * ('a,'b)func;; (* ------------------------------------------------------------------------- *) (* Undefined function. *) (* ------------------------------------------------------------------------- *) let undefined = Empty;; (* ------------------------------------------------------------------------- *) (* In case of equality comparison worries, better use this. *) (* ------------------------------------------------------------------------- *) let is_undefined f = match f with Empty -> true | _ -> false;; (* ------------------------------------------------------------------------- *) (* Operation analagous to "map" for lists. *) (* ------------------------------------------------------------------------- *) let mapf = let rec map_list f l = match l with [] -> [] | (x,y)::t -> (x,f(y))::(map_list f t) in let rec mapf f t = match t with Empty -> Empty | Leaf(h,l) -> Leaf(h,map_list f l) | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in mapf;; (* ------------------------------------------------------------------------- *) (* Operations analogous to "fold" for lists. *) (* ------------------------------------------------------------------------- *) let foldl = let rec foldl_list f a l = match l with [] -> a | (x,y)::t -> foldl_list f (f a x y) t in let rec foldl f a t = match t with Empty -> a | Leaf(h,l) -> foldl_list f a l | Branch(p,b,l,r) -> foldl f (foldl f a l) r in foldl;; let foldr = let rec foldr_list f l a = match l with [] -> a | (x,y)::t -> f x y (foldr_list f t a) in let rec foldr f t a = match t with Empty -> a | Leaf(h,l) -> foldr_list f l a | Branch(p,b,l,r) -> foldr f l (foldr f r a) in foldr;; (* ------------------------------------------------------------------------- *) (* Redefinition and combination. *) (* ------------------------------------------------------------------------- *) let (|->),combine = let ldb x y = let z = x lxor y in z land (-z) in let newbranch p1 t1 p2 t2 = let b = ldb p1 p2 in let p = p1 land (b - 1) in if p1 land b = 0 then Branch(p,b,t1,t2) else Branch(p,b,t2,t1) in let rec define_list (x,y as xy) l = match l with (a,b as ab)::t -> if x =? a then xy::t else if x [xy] and combine_list op z l1 l2 = match (l1,l2) with [],_ -> l2 | _,[] -> l1 | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) -> if x1 ) x y = let k = Hashtbl.hash x in let rec upd t = match t with Empty -> Leaf (k,[x,y]) | Leaf(h,l) -> if h = k then Leaf(h,define_list (x,y) l) else newbranch h t k (Leaf(k,[x,y])) | Branch(p,b,l,r) -> if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y])) else if k land b = 0 then Branch(p,b,upd l,r) else Branch(p,b,l,upd r) in upd in let rec combine op z t1 t2 = match (t1,t2) with Empty,_ -> t2 | _,Empty -> t1 | Leaf(h1,l1),Leaf(h2,l2) -> if h1 = h2 then let l = combine_list op z l1 l2 in if l = [] then Empty else Leaf(h1,l) else newbranch h1 t1 h2 t2 | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) | (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) -> if k land (b - 1) = p then if k land b = 0 then let l' = combine op z lf l in if is_undefined l' then r else Branch(p,b,l',r) else let r' = combine op z lf r in if is_undefined r' then l else Branch(p,b,l,r') else newbranch k lf p br | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) -> if b1 < b2 then if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2 else if p2 land b1 = 0 then let l = combine op z l1 t2 in if is_undefined l then r1 else Branch(p1,b1,l,r1) else let r = combine op z r1 t2 in if is_undefined r then l1 else Branch(p1,b1,l1,r) else if b2 < b1 then if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2 else if p1 land b2 = 0 then let l = combine op z t1 l2 in if is_undefined l then r2 else Branch(p2,b2,l,r2) else let r = combine op z t1 r2 in if is_undefined r then l2 else Branch(p2,b2,l2,r) else if p1 = p2 then let l = combine op z l1 l2 and r = combine op z r1 r2 in if is_undefined l then r else if is_undefined r then l else Branch(p1,b1,l,r) else newbranch p1 t1 p2 t2 in (|->),combine;; (* ------------------------------------------------------------------------- *) (* Special case of point function. *) (* ------------------------------------------------------------------------- *) let (|=>) = fun x y -> (x |-> y) undefined;; (* ------------------------------------------------------------------------- *) (* Grab an arbitrary element. *) (* ------------------------------------------------------------------------- *) let rec choose t = match t with Empty -> failwith "choose: completely undefined function" | Leaf(h,l) -> List.hd l | Branch(b,p,t1,t2) -> choose t1;; (* ------------------------------------------------------------------------- *) (* Application. *) (* ------------------------------------------------------------------------- *) let applyd = let rec apply_listd l d x = match l with (a,b)::t -> if x =? a then b else if x >? a then apply_listd t d x else d x | [] -> d x in fun f d x -> let k = Hashtbl.hash x in let rec look t = match t with Leaf(h,l) when h = k -> apply_listd l d x | Branch(p,b,l,r) -> look (if k land b = 0 then l else r) | _ -> d x in look f;; let apply f = applyd f (fun x -> failwith "apply");; let tryapplyd f a d = applyd f (fun x -> d) a;; let defined f x = try apply f x; true with Failure _ -> false;; (* ------------------------------------------------------------------------- *) (* Undefinition. *) (* ------------------------------------------------------------------------- *) let undefine = let rec undefine_list x l = match l with (a,b as ab)::t -> if x =? a then t else if x [] in fun x -> let k = Hashtbl.hash x in let rec und t = match t with Leaf(h,l) when h = k -> let l' = undefine_list x l in if l' == l then t else if l' = [] then Empty else Leaf(h,l') | Branch(p,b,l,r) when k land (b - 1) = p -> if k land b = 0 then let l' = und l in if l' == l then t else if is_undefined l' then r else Branch(p,b,l',r) else let r' = und r in if r' == r then t else if is_undefined r' then l else Branch(p,b,l,r') | _ -> t in und;; (* ------------------------------------------------------------------------- *) (* Mapping to sorted-list representation of the graph, domain and range. *) (* ------------------------------------------------------------------------- *) let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);; let dom f = setify(foldl (fun a x y -> x::a) [] f);; let ran f = setify(foldl (fun a x y -> y::a) [] f);; (* ------------------------------------------------------------------------- *) (* More parser basics. *) (* ------------------------------------------------------------------------- *) exception Noparse;; let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = let charcode s = Char.code(String.get s 0) in let spaces = " \t\n\r" and separators = ",;" and brackets = "()[]{}" and symbs = "\\!@#$%^&*-+|\\<=>/?~.:" and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ" and nums = "0123456789" in let allchars = spaces^separators^brackets^symbs^alphas^nums in let csetsize = itlist ((o) max charcode) (explode allchars) 256 in let ctable = Array.make csetsize 0 in do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces); do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators); do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets); do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs); do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas); do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums); let isspace c = Array.get ctable (charcode c) = 1 and issep c = Array.get ctable (charcode c) = 2 and isbra c = Array.get ctable (charcode c) = 4 and issymb c = Array.get ctable (charcode c) = 8 and isalpha c = Array.get ctable (charcode c) = 16 and isnum c = Array.get ctable (charcode c) = 32 and isalnum c = Array.get ctable (charcode c) >= 16 in isspace,issep,isbra,issymb,isalpha,isnum,isalnum;; let (||) parser1 parser2 input = try parser1 input with Noparse -> parser2 input;; let (++) parser1 parser2 input = let result1,rest1 = parser1 input in let result2,rest2 = parser2 rest1 in (result1,result2),rest2;; let rec many prs input = try let result,next = prs input in let results,rest = many prs next in (result::results),rest with Noparse -> [],input;; let (>>) prs treatment input = let result,rest = prs input in treatment(result),rest;; let fix err prs input = try prs input with Noparse -> failwith (err ^ " expected");; let listof prs sep err = prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);; let possibly prs input = try let x,rest = prs input in [x],rest with Noparse -> [],input;; let some p = function [] -> raise Noparse | (h::t) -> if p h then (h,t) else raise Noparse;; let a tok = some (fun item -> item = tok);; let rec atleast n prs i = (if n <= 0 then many prs else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;; let finished input = if input = [] then 0,input else failwith "Unparsed input";; (* ------------------------------------------------------------------------- *) let temp_path = ref Filename.temp_dir_name;; (* ------------------------------------------------------------------------- *) (* Convenient conversion between files and (lists of) strings. *) (* ------------------------------------------------------------------------- *) let strings_of_file filename = let fd = try Pervasives.open_in filename with Sys_error _ -> failwith("strings_of_file: can't open "^filename) in let rec suck_lines acc = try let l = Pervasives.input_line fd in suck_lines (l::acc) with End_of_file -> List.rev acc in let data = suck_lines [] in (Pervasives.close_in fd; data);; let string_of_file filename = end_itlist (fun s t -> s^"\n"^t) (strings_of_file filename);; let file_of_string filename s = let fd = Pervasives.open_out filename in output_string fd s; close_out fd;; (* ------------------------------------------------------------------------- *) (* Iterative deepening. *) (* ------------------------------------------------------------------------- *) let rec deepen f n = try (*print_string "Searching with depth limit "; print_int n; print_newline();*) f n with Failure _ -> deepen f (n + 1);; exception TooDeep let deepen_until limit f n = match compare limit 0 with | 0 -> raise TooDeep | -1 -> deepen f n | _ -> let rec d_until f n = try(* if !debugging then (print_string "Searching with depth limit "; print_int n; print_newline()) ;*) f n with Failure x -> (*if !debugging then (Printf.printf "solver error : %s\n" x) ; *) if n = limit then raise TooDeep else d_until f (n + 1) in d_until f n coq-8.6/plugins/micromega/sos_types.ml0000644000175000017500000000535413022274260017474 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* output_string o "0" | Const n -> output_string o (string_of_num n) | Var n -> Printf.fprintf o "v%s" n | Inv t -> Printf.fprintf o "1/(%a)" output_term t | Opp t -> Printf.fprintf o "- (%a)" output_term t | Add(t1,t2) -> Printf.fprintf o "(%a)+(%a)" output_term t1 output_term t2 | Sub(t1,t2) -> Printf.fprintf o "(%a)-(%a)" output_term t1 output_term t2 | Mul(t1,t2) -> Printf.fprintf o "(%a)*(%a)" output_term t1 output_term t2 | Div(t1,t2) -> Printf.fprintf o "(%a)/(%a)" output_term t1 output_term t2 | Pow(t1,i) -> Printf.fprintf o "(%a)^(%i)" output_term t1 i (* ------------------------------------------------------------------------- *) (* Data structure for Positivstellensatz refutations. *) (* ------------------------------------------------------------------------- *) type positivstellensatz = Axiom_eq of int | Axiom_le of int | Axiom_lt of int | Rational_eq of num | Rational_le of num | Rational_lt of num | Square of term | Monoid of int list | Eqmul of term * positivstellensatz | Sum of positivstellensatz * positivstellensatz | Product of positivstellensatz * positivstellensatz;; let rec output_psatz o = function | Axiom_eq i -> Printf.fprintf o "Aeq(%i)" i | Axiom_le i -> Printf.fprintf o "Ale(%i)" i | Axiom_lt i -> Printf.fprintf o "Alt(%i)" i | Rational_eq n -> Printf.fprintf o "eq(%s)" (string_of_num n) | Rational_le n -> Printf.fprintf o "le(%s)" (string_of_num n) | Rational_lt n -> Printf.fprintf o "lt(%s)" (string_of_num n) | Square t -> Printf.fprintf o "(%a)^2" output_term t | Monoid l -> Printf.fprintf o "monoid" | Eqmul (t,ps) -> Printf.fprintf o "%a * %a" output_term t output_psatz ps | Sum (t1,t2) -> Printf.fprintf o "%a + %a" output_psatz t1 output_psatz t2 | Product (t1,t2) -> Printf.fprintf o "%a * %a" output_psatz t1 output_psatz t2 coq-8.6/plugins/micromega/persistent_cache.ml0000644000175000017500000001374513022274260020772 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string -> 'a t (** [create i f] creates an empty persistent table with initial size i associated with file [f] *) val open_in : string -> 'a t (** [open_in f] rebuilds a table from the records stored in file [f]. As marshaling is not type-safe, it migth segault. *) val find : 'a t -> key -> 'a (** find has the specification of Hashtable.find *) val add : 'a t -> key -> 'a -> unit (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl]. (and writes the binding to the file associated with [tbl].) If [key] is already bound, raises KeyAlreadyBound *) val close : 'a t -> unit (** [close tbl] is closing the table. Once closed, a table cannot be used. i.e, find,add will raise UnboundTable *) val memo : string -> (key -> 'a) -> (key -> 'a) (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. Note that the cache will only be loaded when the function is used for the first time *) end open Hashtbl module PHashtable(Key:HashedType) : PHashtable with type key = Key.t = struct open Unix type key = Key.t module Table = Hashtbl.Make(Key) exception InvalidTableFormat exception UnboundTable type mode = Closed | Open type 'a t = { outch : out_channel ; mutable status : mode ; htbl : 'a Table.t } let create i f = let flags = [O_WRONLY; O_TRUNC;O_CREAT] in { outch = out_channel_of_descr (openfile f flags 0o666); status = Open ; htbl = Table.create i } let finally f rst = try let res = f () in rst () ; res with reraise -> (try rst () with any -> raise reraise ); raise reraise let read_key_elem inch = try Some (Marshal.from_channel inch) with | End_of_file -> None | e when CErrors.noncritical e -> raise InvalidTableFormat (** We used to only lock/unlock regions. Is-it more robust/portable to lock/unlock a fixed region e.g. [0;1]? In case of locking failure, the cache is not used. **) type lock_kind = Read | Write let lock kd fd = let pos = lseek fd 0 SEEK_CUR in let success = try ignore (lseek fd 0 SEEK_SET); let lk = match kd with | Read -> F_RLOCK | Write -> F_LOCK in lockf fd lk 1; true with Unix.Unix_error(_,_,_) -> false in ignore (lseek fd pos SEEK_SET) ; success let unlock fd = let pos = lseek fd 0 SEEK_CUR in try ignore (lseek fd 0 SEEK_SET) ; lockf fd F_ULOCK 1 with Unix.Unix_error(_,_,_) -> () (* Here, this is really bad news -- there is a pending lock which could cause a deadlock. Should it be an anomaly or produce a warning ? *); ignore (lseek fd pos SEEK_SET) (* We make the assumption that an acquired lock can always be released *) let do_under_lock kd fd f = if lock kd fd then finally f (fun () -> unlock fd) else f () let open_in f = let flags = [O_RDONLY ; O_CREAT] in let finch = openfile f flags 0o666 in let inch = in_channel_of_descr finch in let htbl = Table.create 100 in let rec xload () = match read_key_elem inch with | None -> () | Some (key,elem) -> Table.add htbl key elem ; xload () in try (* Locking of the (whole) file while reading *) do_under_lock Read finch xload ; close_in_noerr inch ; { outch = out_channel_of_descr (openfile f [O_WRONLY;O_APPEND;O_CREAT] 0o666) ; status = Open ; htbl = htbl } with InvalidTableFormat -> (* The file is corrupted *) begin close_in_noerr inch ; let flags = [O_WRONLY; O_TRUNC;O_CREAT] in let out = (openfile f flags 0o666) in let outch = out_channel_of_descr out in do_under_lock Write out (fun () -> Table.iter (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; flush outch) ; { outch = outch ; status = Open ; htbl = htbl } end let close t = let {outch = outch ; status = status ; htbl = tbl} = t in match t.status with | Closed -> () (* don't do it twice *) | Open -> close_out outch ; Table.clear tbl ; t.status <- Closed let add t k e = let {outch = outch ; status = status ; htbl = tbl} = t in if status == Closed then raise UnboundTable else let fd = descr_of_out_channel outch in begin Table.add tbl k e ; do_under_lock Write fd (fun _ -> Marshal.to_channel outch (k,e) [Marshal.No_sharing] ; flush outch ) end let find t k = let {outch = outch ; status = status ; htbl = tbl} = t in if status == Closed then raise UnboundTable else let res = Table.find tbl k in res let memo cache f = let tbl = lazy (try Some (open_in cache) with _ -> None) in fun x -> match Lazy.force tbl with | None -> f x | Some tbl -> try find tbl x with Not_found -> let res = f x in add tbl x res ; res end (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/micromega/Psatz.v0000644000175000017500000000401213022274260016370 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (sos_Z Lia.zchecker) || (psatz_Z d Lia.zchecker) | R => (sos_R Lra.rchecker) || (psatz_R d Lra.rchecker) | Q => (sos_Q Lqa.rchecker) || (psatz_Q d Lqa.rchecker) | _ => fail "Unsupported domain" end in tac. Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). Ltac psatzl dom := let tac := lazymatch dom with | Z => Lia.lia | Q => Lqa.lra | R => Lra.lra | _ => fail "Unsupported domain" end in tac. Ltac lra := first [ psatzl R | psatzl Q ]. Ltac nra := first [ Lra.nra | Lqa.nra ]. (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/micromega/RingMicromega.v0000644000175000017500000007545613022274260020036 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R -> R. Variable ropp : R -> R. Variables req rle rlt : R -> R -> Prop. Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (rplus x y). Notation "x * y " := (rtimes x y). Notation "x - y " := (rminus x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Notation "x ~= y" := (~ req x y). Notation "x <= y" := (rle x y). Notation "x < y" := (rlt x y). (* Assume we have a type of coefficients C and a morphism from C to R *) Variable C : Type. Variables cO cI : C. Variables cplus ctimes cminus: C -> C -> C. Variable copp : C -> C. Variables ceqb cleb : C -> C -> bool. Variable phi : C -> R. (* Power coefficients *) Variable E : Type. (* the type of exponents *) Variable pow_phi : N -> E. Variable rpow : R -> E -> R. Notation "[ x ]" := (phi x). Notation "x [=] y" := (ceqb x y). Notation "x [<=] y" := (cleb x y). (* Let's collect all hypotheses in addition to the ordered ring axioms into one structure *) Record SORaddon := mk_SOR_addon { SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi; SORpower : power_theory rI rtimes req pow_phi rpow; SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y]; SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y] }. Variable addon : SORaddon. Add Relation R req reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) as micomega_sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. exact sor.(SORplus_wd). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. exact sor.(SORtimes_wd). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. exact sor.(SORopp_wd). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. exact sor.(SORle_wd). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. exact sor.(SORlt_wd). Qed. Add Morphism rminus with signature req ==> req ==> req as rminus_morph. Proof. exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *) Qed. Definition cneqb (x y : C) := negb (ceqb x y). Definition cltb (x y : C) := (cleb x y) && (cneqb x y). Notation "x [~=] y" := (cneqb x y). Notation "x [<] y" := (cltb x y). Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H]. Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y]. Proof. exact addon.(SORcleb_morph). Qed. Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y]. Proof. intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1. destruct (ceqb x y); now try discriminate. Qed. Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y]. Proof. intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2]. apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split. Qed. (* Begin Micromega *) Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *) Definition PolEnv := Env R. (* For interpreting PolC *) Definition eval_pol : PolEnv -> PolC -> R := Pphi rplus rtimes phi. Inductive Op1 : Set := (* relations with 0 *) | Equal (* == 0 *) | NonEqual (* ~= 0 *) | Strict (* > 0 *) | NonStrict (* >= 0 *). Definition NFormula := (PolC * Op1)%type. (* normalized formula *) Definition eval_op1 (o : Op1) : R -> Prop := match o with | Equal => fun x => x == 0 | NonEqual => fun x : R => x ~= 0 | Strict => fun x : R => 0 < x | NonStrict => fun x : R => 0 <= x end. Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop := let (p, op) := f in eval_op1 op (eval_pol env p). (** Rule of "signs" for addition and multiplication. An arbitrary result is coded buy None. *) Definition OpMult (o o' : Op1) : option Op1 := match o with | Equal => Some Equal | NonStrict => match o' with | Equal => Some Equal | NonEqual => None | Strict => Some NonStrict | NonStrict => Some NonStrict end | Strict => match o' with | NonEqual => None | _ => Some o' end | NonEqual => match o' with | Equal => Some Equal | NonEqual => Some NonEqual | _ => None end end. Definition OpAdd (o o': Op1) : option Op1 := match o with | Equal => Some o' | NonStrict => match o' with | Strict => Some Strict | NonEqual => None | _ => Some NonStrict end | Strict => match o' with | NonEqual => None | _ => Some Strict end | NonEqual => match o' with | Equal => Some NonEqual | _ => None end end. Lemma OpMult_sound : forall (o o' om: Op1) (x y : R), eval_op1 o x -> eval_op1 o' y -> OpMult o o' = Some om -> eval_op1 om (x * y). Proof. unfold eval_op1; destruct o; simpl; intros o' om x y H1 H2 H3. (* x == 0 *) inversion H3. rewrite H1. now rewrite (Rtimes_0_l sor). (* x ~= 0 *) destruct o' ; inversion H3. (* y == 0 *) rewrite H2. now rewrite (Rtimes_0_r sor). (* y ~= 0 *) apply (Rtimes_neq_0 sor) ; auto. (* 0 < x *) destruct o' ; inversion H3. (* y == 0 *) rewrite H2; now rewrite (Rtimes_0_r sor). (* 0 < y *) now apply (Rtimes_pos_pos sor). (* 0 <= y *) apply (Rtimes_nonneg_nonneg sor); [le_less | assumption]. (* 0 <= x *) destruct o' ; inversion H3. (* y == 0 *) rewrite H2; now rewrite (Rtimes_0_r sor). (* 0 < y *) apply (Rtimes_nonneg_nonneg sor); [assumption | le_less ]. (* 0 <= y *) now apply (Rtimes_nonneg_nonneg sor). Qed. Lemma OpAdd_sound : forall (o o' oa : Op1) (e e' : R), eval_op1 o e -> eval_op1 o' e' -> OpAdd o o' = Some oa -> eval_op1 oa (e + e'). Proof. unfold eval_op1; destruct o; simpl; intros o' oa e e' H1 H2 Hoa. (* e == 0 *) inversion Hoa. rewrite <- H0. destruct o' ; rewrite H1 ; now rewrite (Rplus_0_l sor). (* e ~= 0 *) destruct o'. (* e' == 0 *) inversion Hoa. rewrite H2. now rewrite (Rplus_0_r sor). (* e' ~= 0 *) discriminate. (* 0 < e' *) discriminate. (* 0 <= e' *) discriminate. (* 0 < e *) destruct o'. (* e' == 0 *) inversion Hoa. rewrite H2. now rewrite (Rplus_0_r sor). (* e' ~= 0 *) discriminate. (* 0 < e' *) inversion Hoa. now apply (Rplus_pos_pos sor). (* 0 <= e' *) inversion Hoa. now apply (Rplus_pos_nonneg sor). (* 0 <= e *) destruct o'. (* e' == 0 *) inversion Hoa. now rewrite H2, (Rplus_0_r sor). (* e' ~= 0 *) discriminate. (* 0 < e' *) inversion Hoa. now apply (Rplus_nonneg_pos sor). (* 0 <= e' *) inversion Hoa. now apply (Rplus_nonneg_nonneg sor). Qed. Inductive Psatz : Type := | PsatzIn : nat -> Psatz | PsatzSquare : PolC -> Psatz | PsatzMulC : PolC -> Psatz -> Psatz | PsatzMulE : Psatz -> Psatz -> Psatz | PsatzAdd : Psatz -> Psatz -> Psatz | PsatzC : C -> Psatz | PsatzZ : Psatz. (** Given a list [l] of NFormula and an extended polynomial expression [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a logic consequence of the conjunction of the formulae in l. Moreover, the polynomial expression is obtained by replacing the (PsatzIn n) by the nth polynomial expression in [l] and the sign is computed by the "rule of sign" *) (* Might be defined elsewhere *) Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B := match o with | None => None | Some x => f x end. Arguments map_option [A B] f o. Definition map_option2 (A B C : Type) (f : A -> B -> option C) (o: option A) (o': option B) : option C := match o , o' with | None , _ => None | _ , None => None | Some x , Some x' => f x x' end. Arguments map_option2 [A B C] f o o'. Definition Rops_wd := mk_reqe (*rplus rtimes ropp req*) sor.(SORplus_wd) sor.(SORtimes_wd) sor.(SORopp_wd). Definition pexpr_times_nformula (e: PolC) (f : NFormula) : option NFormula := let (ef,o) := f in match o with | Equal => Some (Pmul cO cI cplus ctimes ceqb e ef , Equal) | _ => None end. Definition nformula_times_nformula (f1 f2 : NFormula) : option NFormula := let (e1,o1) := f1 in let (e2,o2) := f2 in map_option (fun x => (Some (Pmul cO cI cplus ctimes ceqb e1 e2,x))) (OpMult o1 o2). Definition nformula_plus_nformula (f1 f2 : NFormula) : option NFormula := let (e1,o1) := f1 in let (e2,o2) := f2 in map_option (fun x => (Some (Padd cO cplus ceqb e1 e2,x))) (OpAdd o1 o2). Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula := match e with | PsatzIn n => Some (nth n l (Pc cO, Equal)) | PsatzSquare e => Some (Psquare cO cI cplus ctimes ceqb e , NonStrict) | PsatzMulC re e => map_option (pexpr_times_nformula re) (eval_Psatz l e) | PsatzMulE f1 f2 => map_option2 nformula_times_nformula (eval_Psatz l f1) (eval_Psatz l f2) | PsatzAdd f1 f2 => map_option2 nformula_plus_nformula (eval_Psatz l f1) (eval_Psatz l f2) | PsatzC c => if cltb cO c then Some (Pc c, Strict) else None (* This could be 0, or <> 0 -- but these cases are useless *) | PsatzZ => Some (Pc cO, Equal) (* Just to make life easier *) end. Lemma pexpr_times_nformula_correct : forall (env: PolEnv) (e: PolC) (f f' : NFormula), eval_nformula env f -> pexpr_times_nformula e f = Some f' -> eval_nformula env f'. Proof. unfold pexpr_times_nformula. destruct f. intros. destruct o ; inversion H0 ; try discriminate. simpl in *. unfold eval_pol in *. rewrite (Pmul_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). rewrite H. apply (Rtimes_0_r sor). Qed. Lemma nformula_times_nformula_correct : forall (env:PolEnv) (f1 f2 f : NFormula), eval_nformula env f1 -> eval_nformula env f2 -> nformula_times_nformula f1 f2 = Some f -> eval_nformula env f. Proof. unfold nformula_times_nformula. destruct f1 ; destruct f2. case_eq (OpMult o o0) ; simpl ; try discriminate. intros. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; rewrite (Pmul_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); apply OpMult_sound with (3:= H);assumption. Qed. Lemma nformula_plus_nformula_correct : forall (env:PolEnv) (f1 f2 f : NFormula), eval_nformula env f1 -> eval_nformula env f2 -> nformula_plus_nformula f1 f2 = Some f -> eval_nformula env f. Proof. unfold nformula_plus_nformula. destruct f1 ; destruct f2. case_eq (OpAdd o o0) ; simpl ; try discriminate. intros. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; rewrite (Padd_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); apply OpAdd_sound with (3:= H);assumption. Qed. Lemma eval_Psatz_Sound : forall (l : list NFormula) (env : PolEnv), (forall (f : NFormula), In f l -> eval_nformula env f) -> forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f -> eval_nformula env f. Proof. induction e. (* PsatzIn *) simpl ; intros. destruct (nth_in_or_default n l (Pc cO, Equal)) as [Hin|Heq]. (* index is in bounds *) apply H. congruence. (* index is out-of-bounds *) inversion H0. rewrite Heq. simpl. now apply addon.(SORrm).(morph0). (* PsatzSquare *) simpl. intros. inversion H0. simpl. unfold eval_pol. rewrite (Psquare_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); now apply (Rtimes_square_nonneg sor). (* PsatzMulC *) simpl. intro. case_eq (eval_Psatz l e) ; simpl ; intros. apply IHe in H0. apply pexpr_times_nformula_correct with (1:=H0) (2:= H1). discriminate. (* PsatzMulC *) simpl ; intro. case_eq (eval_Psatz l e1) ; simpl ; try discriminate. case_eq (eval_Psatz l e2) ; simpl ; try discriminate. intros. apply IHe1 in H1. apply IHe2 in H0. apply (nformula_times_nformula_correct env n0 n) ; assumption. (* PsatzAdd *) simpl ; intro. case_eq (eval_Psatz l e1) ; simpl ; try discriminate. case_eq (eval_Psatz l e2) ; simpl ; try discriminate. intros. apply IHe1 in H1. apply IHe2 in H0. apply (nformula_plus_nformula_correct env n0 n) ; assumption. (* PsatzC *) simpl. intro. case_eq (cO [<] c). intros. inversion H1. simpl. rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. discriminate. (* PsatzZ *) simpl. intros. inversion H0. simpl. apply addon.(SORrm).(morph0). Qed. Fixpoint ge_bool (n m : nat) : bool := match n with | O => match m with | O => true | S _ => false end | S n => match m with | O => true | S m => ge_bool n m end end. Lemma ge_bool_cases : forall n m, (if ge_bool n m then n >= m else n < m)%nat. Proof. induction n; destruct m ; simpl; auto with arith. specialize (IHn m). destruct (ge_bool); auto with arith. Qed. Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz) : list nat := match prf with | PsatzC _ | PsatzZ | PsatzSquare _ => acc | PsatzMulC _ prf => xhyps_of_psatz base acc prf | PsatzAdd e1 e2 | PsatzMulE e1 e2 => xhyps_of_psatz base (xhyps_of_psatz base acc e2) e1 | PsatzIn n => if ge_bool n base then (n::acc) else acc end. Fixpoint nhyps_of_psatz (prf : Psatz) : list nat := match prf with | PsatzC _ | PsatzZ | PsatzSquare _ => nil | PsatzMulC _ prf => nhyps_of_psatz prf | PsatzAdd e1 e2 | PsatzMulE e1 e2 => nhyps_of_psatz e1 ++ nhyps_of_psatz e2 | PsatzIn n => n :: nil end. Fixpoint extract_hyps (l: list NFormula) (ln : list nat) : list NFormula := match ln with | nil => nil | n::ln => nth n l (Pc cO, Equal) :: extract_hyps l ln end. Lemma extract_hyps_app : forall l ln1 ln2, extract_hyps l (ln1 ++ ln2) = (extract_hyps l ln1) ++ (extract_hyps l ln2). Proof. induction ln1. reflexivity. simpl. intros. rewrite IHln1. reflexivity. Qed. Ltac inv H := inversion H ; try subst ; clear H. Lemma nhyps_of_psatz_correct : forall (env : PolEnv) (e:Psatz) (l : list NFormula) (f: NFormula), eval_Psatz l e = Some f -> ((forall f', In f' (extract_hyps l (nhyps_of_psatz e)) -> eval_nformula env f') -> eval_nformula env f). Proof. induction e ; intros. (*PsatzIn*) simpl in *. apply H0. intuition congruence. (* PsatzSquare *) simpl in *. inv H. simpl. unfold eval_pol. rewrite (Psquare_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); now apply (Rtimes_square_nonneg sor). (* PsatzMulC *) simpl in *. case_eq (eval_Psatz l e). intros. rewrite H1 in H. simpl in H. apply pexpr_times_nformula_correct with (2:= H). apply IHe with (1:= H1); auto. intros. rewrite H1 in H. simpl in H ; discriminate. (* PsatzMulE *) simpl in *. revert H. case_eq (eval_Psatz l e1). case_eq (eval_Psatz l e2) ; simpl ; intros. apply nformula_times_nformula_correct with (3:= H2). apply IHe1 with (1:= H1) ; auto. intros. apply H0. rewrite extract_hyps_app. apply in_or_app. tauto. apply IHe2 with (1:= H) ; auto. intros. apply H0. rewrite extract_hyps_app. apply in_or_app. tauto. discriminate. simpl. discriminate. (* PsatzAdd *) simpl in *. revert H. case_eq (eval_Psatz l e1). case_eq (eval_Psatz l e2) ; simpl ; intros. apply nformula_plus_nformula_correct with (3:= H2). apply IHe1 with (1:= H1) ; auto. intros. apply H0. rewrite extract_hyps_app. apply in_or_app. tauto. apply IHe2 with (1:= H) ; auto. intros. apply H0. rewrite extract_hyps_app. apply in_or_app. tauto. discriminate. simpl. discriminate. (* PsatzC *) simpl in H. case_eq (cO [<] c). intros. rewrite H1 in H. inv H. unfold eval_nformula. simpl. rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. intros. rewrite H1 in H. discriminate. (* PsatzZ *) simpl in *. inv H. unfold eval_nformula. simpl. apply addon.(SORrm).(morph0). Qed. (* roughly speaking, normalise_pexpr_correct is a proof of forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *) (*****) Definition paddC := PaddC cplus. Definition psubC := PsubC cminus. Definition PsubC_ok : forall c P env, eval_pol env (psubC P c) == eval_pol env P - [c] := let Rops_wd := mk_reqe (*rplus rtimes ropp req*) sor.(SORplus_wd) sor.(SORtimes_wd) sor.(SORopp_wd) in PsubC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm). Definition PaddC_ok : forall c P env, eval_pol env (paddC P c) == eval_pol env P + [c] := let Rops_wd := mk_reqe (*rplus rtimes ropp req*) sor.(SORplus_wd) sor.(SORtimes_wd) sor.(SORopp_wd) in PaddC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm). (* Check that a formula f is inconsistent by normalizing and comparing the resulting constant with 0 *) Definition check_inconsistent (f : NFormula) : bool := let (e, op) := f in match e with | Pc c => match op with | Equal => cneqb c cO | NonStrict => c [<] cO | Strict => c [<=] cO | NonEqual => c [=] cO end | _ => false (* not a constant *) end. Lemma check_inconsistent_sound : forall (p : PolC) (op : Op1), check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pol env p). Proof. intros p op H1 env. unfold check_inconsistent in H1. destruct op; simpl ; (*****) destruct p ; simpl; try discriminate H1; try rewrite <- addon.(SORrm).(morph0); trivial. now apply cneqb_sound. apply addon.(SORrm).(morph_eq) in H1. congruence. apply cleb_sound in H1. now apply -> (Rle_ngt sor). apply cltb_sound in H1. now apply -> (Rlt_nge sor). Qed. Definition check_normalised_formulas : list NFormula -> Psatz -> bool := fun l cm => match eval_Psatz l cm with | None => false | Some f => check_inconsistent f end. Lemma checker_nf_sound : forall (l : list NFormula) (cm : Psatz), check_normalised_formulas l cm = true -> forall env : PolEnv, make_impl (eval_nformula env) l False. Proof. intros l cm H env. unfold check_normalised_formulas in H. revert H. case_eq (eval_Psatz l cm) ; [|discriminate]. intros nf. intros. rewrite <- make_conj_impl. intro. assert (H1' := make_conj_in _ _ H1). assert (Hnf := @eval_Psatz_Sound _ _ H1' _ _ H). destruct nf. apply (@check_inconsistent_sound _ _ H0 env Hnf). Qed. (** Normalisation of formulae **) Inductive Op2 : Set := (* binary relations *) | OpEq | OpNEq | OpLe | OpGe | OpLt | OpGt. Definition eval_op2 (o : Op2) : R -> R -> Prop := match o with | OpEq => req | OpNEq => fun x y : R => x ~= y | OpLe => rle | OpGe => fun x y : R => y <= x | OpLt => fun x y : R => x < y | OpGt => fun x y : R => y < x end. Definition eval_pexpr : PolEnv -> PExpr C -> R := PEeval rplus rtimes rminus ropp phi pow_phi rpow. Record Formula (T:Type) : Type := { Flhs : PExpr T; Fop : Op2; Frhs : PExpr T }. Definition eval_formula (env : PolEnv) (f : Formula C) : Prop := let (lhs, op, rhs) := f in (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs). (* We normalize Formulas by moving terms to one side *) Definition norm := norm_aux cO cI cplus ctimes cminus copp ceqb. Definition psub := Psub cO cplus cminus copp ceqb. Definition padd := Padd cO cplus ceqb. Definition normalise (f : Formula C) : NFormula := let (lhs, op, rhs) := f in let lhs := norm lhs in let rhs := norm rhs in match op with | OpEq => (psub lhs rhs, Equal) | OpNEq => (psub lhs rhs, NonEqual) | OpLe => (psub rhs lhs, NonStrict) | OpGe => (psub lhs rhs, NonStrict) | OpGt => (psub lhs rhs, Strict) | OpLt => (psub rhs lhs, Strict) end. Definition negate (f : Formula C) : NFormula := let (lhs, op, rhs) := f in let lhs := norm lhs in let rhs := norm rhs in match op with | OpEq => (psub rhs lhs, NonEqual) | OpNEq => (psub rhs lhs, Equal) | OpLe => (psub lhs rhs, Strict) (* e <= e' == ~ e > e' *) | OpGe => (psub rhs lhs, Strict) | OpGt => (psub rhs lhs, NonStrict) | OpLt => (psub lhs rhs, NonStrict) end. Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) == eval_pol env lhs - eval_pol env rhs. Proof. intros. apply (Psub_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). Qed. Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) == eval_pol env lhs + eval_pol env rhs. Proof. intros. apply (Padd_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). Qed. Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env (norm lhs). Proof. intros. apply (norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm) addon.(SORpower) ). Qed. Theorem normalise_sound : forall (env : PolEnv) (f : Formula C), eval_formula env f -> eval_nformula env (normalise f). Proof. intros env f H; destruct f as [lhs op rhs]; simpl in *. destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. now apply <- (Rminus_eq_0 sor). intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H. now apply -> (Rle_le_minus sor). now apply -> (Rle_le_minus sor). now apply -> (Rlt_lt_minus sor). now apply -> (Rlt_lt_minus sor). Qed. Theorem negate_correct : forall (env : PolEnv) (f : Formula C), eval_formula env f <-> ~ (eval_nformula env (negate f)). Proof. intros env f; destruct f as [lhs op rhs]; simpl. destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. symmetry. rewrite (Rminus_eq_0 sor). split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)]. rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor). rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). Qed. (** Another normalisation - this is used for cnf conversion **) Definition xnormalise (t:Formula C) : list (NFormula) := let (lhs,o,rhs) := t in let lhs := norm lhs in let rhs := norm rhs in match o with | OpEq => (psub lhs rhs, Strict)::(psub rhs lhs , Strict)::nil | OpNEq => (psub lhs rhs,Equal) :: nil | OpGt => (psub rhs lhs,NonStrict) :: nil | OpLt => (psub lhs rhs,NonStrict) :: nil | OpGe => (psub rhs lhs , Strict) :: nil | OpLe => (psub lhs rhs ,Strict) :: nil end. Require Import Coq.micromega.Tauto. Definition cnf_normalise (t:Formula C) : cnf (NFormula) := List.map (fun x => x::nil) (xnormalise t). Add Ring SORRing : sor.(SORrt). Lemma cnf_normalise_correct : forall env t, eval_cnf eval_nformula env (cnf_normalise t) -> eval_formula env t. Proof. unfold cnf_normalise, xnormalise ; simpl ; intros env t. unfold eval_cnf, eval_clause. destruct t as [lhs o rhs]; case_eq o ; simpl; repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros. (**) apply sor.(SORle_antisymm). rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. now rewrite <- (Rminus_eq_0 sor). rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. Qed. Definition xnegate (t:Formula C) : list (NFormula) := let (lhs,o,rhs) := t in let lhs := norm lhs in let rhs := norm rhs in match o with | OpEq => (psub lhs rhs,Equal) :: nil | OpNEq => (psub lhs rhs ,Strict)::(psub rhs lhs,Strict)::nil | OpGt => (psub lhs rhs,Strict) :: nil | OpLt => (psub rhs lhs,Strict) :: nil | OpGe => (psub lhs rhs,NonStrict) :: nil | OpLe => (psub rhs lhs,NonStrict) :: nil end. Definition cnf_negate (t:Formula C) : cnf (NFormula) := List.map (fun x => x::nil) (xnegate t). Lemma cnf_negate_correct : forall env t, eval_cnf eval_nformula env (cnf_negate t) -> ~ eval_formula env t. Proof. unfold cnf_negate, xnegate ; simpl ; intros env t. unfold eval_cnf, eval_clause. destruct t as [lhs o rhs]; case_eq o ; simpl; repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; intuition. (**) apply H0. rewrite H1 ; ring. (**) apply H1. apply sor.(SORle_antisymm). rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. (**) apply H0. now rewrite (Rle_le_minus sor) in H1. apply H0. now rewrite (Rle_le_minus sor) in H1. apply H0. now rewrite (Rlt_lt_minus sor) in H1. apply H0. now rewrite (Rlt_lt_minus sor) in H1. Qed. Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). Proof. intros. destruct d ; simpl. generalize (eval_pol env p); intros. destruct o ; simpl. apply (Req_em sor r 0). destruct (Req_em sor r 0) ; tauto. rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto. rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto. Qed. (** Reverse transformation *) Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C := match p with | Pc c => PEc c | Pinj j p => xdenorm (Pos.add j jmp ) p | PX p j q => PEadd (PEmul (xdenorm jmp p) (PEpow (PEX _ jmp) (Npos j))) (xdenorm (Pos.succ jmp) q) end. Lemma xdenorm_correct : forall p i env, eval_pol (jump i env) p == eval_pexpr env (xdenorm (Pos.succ i) p). Proof. unfold eval_pol. induction p. simpl. reflexivity. (* Pinj *) simpl. intros. rewrite Pos.add_succ_r. rewrite <- IHp. symmetry. rewrite Pos.add_comm. rewrite Pjump_add. reflexivity. (* PX *) simpl. intros. rewrite <- IHp1, <- IHp2. unfold Env.tail , Env.hd. rewrite <- Pjump_add. rewrite Pos.add_1_r. unfold Env.nth. unfold jump at 2. rewrite <- Pos.add_1_l. rewrite addon.(SORpower).(rpow_pow_N). unfold pow_N. ring. Qed. Definition denorm := xdenorm xH. Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p). Proof. unfold denorm. induction p. reflexivity. simpl. rewrite Pos.add_1_r. apply xdenorm_correct. simpl. intros. rewrite IHp1. unfold Env.tail. rewrite xdenorm_correct. change (Pos.succ xH) with 2%positive. rewrite addon.(SORpower).(rpow_pow_N). simpl. reflexivity. Qed. (** Sometimes it is convenient to make a distinction between "syntactic" coefficients and "real" coefficients that are used to actually compute *) Variable S : Type. Variable C_of_S : S -> C. Variable phiS : S -> R. Variable phi_C_of_S : forall c, phiS c = phi (C_of_S c). Fixpoint map_PExpr (e : PExpr S) : PExpr C := match e with | PEc c => PEc (C_of_S c) | PEX _ p => PEX _ p | PEadd e1 e2 => PEadd (map_PExpr e1) (map_PExpr e2) | PEsub e1 e2 => PEsub (map_PExpr e1) (map_PExpr e2) | PEmul e1 e2 => PEmul (map_PExpr e1) (map_PExpr e2) | PEopp e => PEopp (map_PExpr e) | PEpow e n => PEpow (map_PExpr e) n end. Definition map_Formula (f : Formula S) : Formula C := let (l,o,r) := f in Build_Formula (map_PExpr l) o (map_PExpr r). Definition eval_sexpr : PolEnv -> PExpr S -> R := PEeval rplus rtimes rminus ropp phiS pow_phi rpow. Definition eval_sformula (env : PolEnv) (f : Formula S) : Prop := let (lhs, op, rhs) := f in (eval_op2 op) (eval_sexpr env lhs) (eval_sexpr env rhs). Lemma eval_pexprSC : forall env s, eval_sexpr env s = eval_pexpr env (map_PExpr s). Proof. unfold eval_pexpr, eval_sexpr. induction s ; simpl ; try (rewrite IHs1 ; rewrite IHs2) ; try reflexivity. apply phi_C_of_S. rewrite IHs. reflexivity. rewrite IHs. reflexivity. Qed. (** equality migth be (too) strong *) Lemma eval_formulaSC : forall env f, eval_sformula env f = eval_formula env (map_Formula f). Proof. destruct f. simpl. repeat rewrite eval_pexprSC. reflexivity. Qed. (** Some syntactic simplifications of expressions *) Definition simpl_cone (e:Psatz) : Psatz := match e with | PsatzSquare t => match t with | Pc c => if ceqb cO c then PsatzZ else PsatzC (ctimes c c) | _ => PsatzSquare t end | PsatzMulE t1 t2 => match t1 , t2 with | PsatzZ , x => PsatzZ | x , 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 | PsatzMulE (PsatzC p2) x , PsatzC p1 => PsatzMulE (PsatzC (ctimes p1 p2)) x | PsatzMulE x (PsatzC p2) , PsatzC p1 => PsatzMulE (PsatzC (ctimes p1 p2)) x | PsatzC x , PsatzAdd y z => PsatzAdd (PsatzMulE (PsatzC x) y) (PsatzMulE (PsatzC x) z) | PsatzC c , _ => if ceqb cI c then t2 else PsatzMulE t1 t2 | _ , PsatzC c => if ceqb cI c then t1 else PsatzMulE t1 t2 | _ , _ => e end | PsatzAdd t1 t2 => match t1 , t2 with | PsatzZ , x => x | x , PsatzZ => x | x , y => PsatzAdd x y end | _ => e end. End Micromega. (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/micromega/LICENSE.sos0000644000175000017500000000305713022274260016720 0ustar mdenesmdenes HOL Light copyright notice, licence and disclaimer (c) University of Cambridge 1998 (c) Copyright, John Harrison 1998-2006 HOL Light version 2.20, hereinafter referred to as "the software", is a computer theorem proving system written by John Harrison. Much of the software was developed at the University of Cambridge Computer Laboratory, New Museums Site, Pembroke Street, Cambridge, CB2 3QG, England. The software is copyright, University of Cambridge 1998 and John Harrison 1998-2006. Permission to use, copy, modify, and distribute the software and its documentation for any purpose and without fee is hereby granted. In the case of further distribution of the software the present text, including copyright notice, licence and disclaimer of warranty, must be included in full and unmodified form in any release. Distribution of derivative software obtained by modifying the software, or incorporating it into other software, is permitted, provided the inclusion of the software is acknowledged and that any changes made to the software are clearly documented. John Harrison and the University of Cambridge disclaim all warranties with regard to the software, including all implied warranties of merchantability and fitness. In no event shall John Harrison or the University of Cambridge be liable for any special, indirect, incidental or consequential damages or any damages whatsoever, including, but not limited to, those arising from computer failure or malfunction, work stoppage, loss of profit or loss of contracts. coq-8.6/plugins/micromega/EnvRing.v0000644000175000017500000007450713022274260016657 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R->R) (ropp : R->R). Variable req : R -> R -> Prop. (* Ring properties *) Variable Rsth : Equivalence req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. (* Coefficients *) Variable C: Type. Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). Variable ceqb : C->C->bool. Variable phi : C -> R. Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. (* Power coefficients *) Variable Cpow : Type. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. (* R notations *) Notation "0" := rO. Notation "1" := rI. Infix "+" := radd. Infix "*" := rmul. Infix "-" := rsub. Notation "- x" := (ropp x). Infix "==" := req. Infix "^" := (pow_pos rmul). (* C notations *) Infix "+!" := cadd. Infix "*!" := cmul. Infix "-! " := csub. Notation "-! x" := (copp x). Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). (* Useful tactics *) Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac rsimpl := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. Ltac add_permut_rec t := match t with | ?x + ?y => add_permut_rec y || add_permut_rec x | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity] end. Ltac add_permut := repeat (reflexivity || match goal with |- ?t == _ => add_permut_rec t end). Ltac mul_permut_rec t := match t with | ?x * ?y => mul_permut_rec y || mul_permut_rec x | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity] end. Ltac mul_permut := repeat (reflexivity || match goal with |- ?t == _ => mul_permut_rec t end). (* Definition of multivariable polynomials with coefficients in C : Type [Pol] represents [X1 ... Xn]. The representation is Horner's where a [n] variable polynomial (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients are polynomials with [n-1] variables (C[X2..Xn]). There are several optimisations to make the repr compacter: - [Pc c] is the constant polynomial of value c == c*X1^0*..*Xn^0 - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. variable indices are shifted of j in Q. == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} - [PX P i Q] is an optimised Horner form of P*X^i + Q with P not the null polynomial == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} In addition: - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden since they can be represented by the simpler form (PX P (i+j) Q) - (Pinj i (Pinj j P)) is (Pinj (i+j) P) - (Pinj i (Pc c)) is (Pc c) *) Inductive Pol : Type := | Pc : C -> Pol | Pinj : positive -> Pol -> Pol | PX : Pol -> positive -> Pol -> Pol. Definition P0 := Pc cO. Definition P1 := Pc cI. Fixpoint Peq (P P' : Pol) {struct P'} : bool := match P, P' with | Pc c, Pc c' => c ?=! c' | Pinj j Q, Pinj j' Q' => match j ?= j' with | Eq => Peq Q Q' | _ => false end | PX P i Q, PX P' i' Q' => match i ?= i' with | Eq => if Peq P P' then Peq Q Q' else false | _ => false end | _, _ => false end. Infix "?==" := Peq. Definition mkPinj j P := match P with | Pc _ => P | Pinj j' Q => Pinj (j + j') Q | _ => Pinj j P end. Definition mkPinj_pred j P:= match j with | xH => P | xO j => Pinj (Pos.pred_double j) P | xI j => Pinj (xO j) P end. Definition mkPX P i Q := match P with | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q | Pinj _ _ => PX P i Q | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q end. Definition mkXi i := PX P1 i P0. Definition mkX := mkXi 1. (** Opposite of addition *) Fixpoint Popp (P:Pol) : Pol := match P with | Pc c => Pc (-! c) | Pinj j Q => Pinj j (Popp Q) | PX P i Q => PX (Popp P) i (Popp Q) end. Notation "-- P" := (Popp P). (** Addition et subtraction *) Fixpoint PaddC (P:Pol) (c:C) : Pol := match P with | Pc c1 => Pc (c1 +! c) | Pinj j Q => Pinj j (PaddC Q c) | PX P i Q => PX P i (PaddC Q c) end. Fixpoint PsubC (P:Pol) (c:C) : Pol := match P with | Pc c1 => Pc (c1 -! c) | Pinj j Q => Pinj j (PsubC Q c) | PX P i Q => PX P i (PsubC Q c) end. Section PopI. Variable Pop : Pol -> Pol -> Pol. Variable Q : Pol. Fixpoint PaddI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PaddC Q c) | Pinj j' Q' => match Z.pos_sub j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PaddI k Q') end | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) | xO j => PX P i (PaddI (Pos.pred_double j) Q') | xI j => PX P i (PaddI (xO j) Q') end end. Fixpoint PsubI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PaddC (--Q) c) | Pinj j' Q' => match Z.pos_sub j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PsubI k Q') end | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) | xO j => PX P i (PsubI (Pos.pred_double j) Q') | xI j => PX P i (PsubI (xO j) Q') end end. Variable P' : Pol. Fixpoint PaddX (i':positive) (P:Pol) : Pol := match P with | Pc c => PX P' i' P | Pinj j Q' => match j with | xH => PX P' i' Q' | xO j => PX P' i' (Pinj (Pos.pred_double j) Q') | xI j => PX P' i' (Pinj (xO j) Q') end | PX P i Q' => match Z.pos_sub i i' with | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' | Z0 => mkPX (Pop P P') i Q' | Zneg k => mkPX (PaddX k P) i Q' end end. Fixpoint PsubX (i':positive) (P:Pol) : Pol := match P with | Pc c => PX (--P') i' P | Pinj j Q' => match j with | xH => PX (--P') i' Q' | xO j => PX (--P') i' (Pinj (Pos.pred_double j) Q') | xI j => PX (--P') i' (Pinj (xO j) Q') end | PX P i Q' => match Z.pos_sub i i' with | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' | Z0 => mkPX (Pop P P') i Q' | Zneg k => mkPX (PsubX k P) i Q' end end. End PopI. Fixpoint Padd (P P': Pol) {struct P'} : Pol := match P' with | Pc c' => PaddC P c' | Pinj j' Q' => PaddI Padd Q' j' P | PX P' i' Q' => match P with | Pc c => PX P' i' (PaddC Q' c) | Pinj j Q => match j with | xH => PX P' i' (Padd Q Q') | xO j => PX P' i' (Padd (Pinj (Pos.pred_double j) Q) Q') | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') end | PX P i Q => match Z.pos_sub i i' with | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') | Z0 => mkPX (Padd P P') i (Padd Q Q') | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') end end end. Infix "++" := Padd. Fixpoint Psub (P P': Pol) {struct P'} : Pol := match P' with | Pc c' => PsubC P c' | Pinj j' Q' => PsubI Psub Q' j' P | PX P' i' Q' => match P with | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) | Pinj j Q => match j with | xH => PX (--P') i' (Psub Q Q') | xO j => PX (--P') i' (Psub (Pinj (Pos.pred_double j) Q) Q') | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') end | PX P i Q => match Z.pos_sub i i' with | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') | Z0 => mkPX (Psub P P') i (Psub Q Q') | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') end end end. Infix "--" := Psub. (** Multiplication *) Fixpoint PmulC_aux (P:Pol) (c:C) : Pol := match P with | Pc c' => Pc (c' *! c) | Pinj j Q => mkPinj j (PmulC_aux Q c) | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c) end. Definition PmulC P c := if c ?=! cO then P0 else if c ?=! cI then P else PmulC_aux P c. Section PmulI. Variable Pmul : Pol -> Pol -> Pol. Variable Q : Pol. Fixpoint PmulI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PmulC Q c) | Pinj j' Q' => match Z.pos_sub j' j with | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) | Z0 => mkPinj j (Pmul Q' Q) | Zneg k => mkPinj j' (PmulI k Q') end | PX P' i' Q' => match j with | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) | xO j' => mkPX (PmulI j P') i' (PmulI (Pos.pred_double j') Q') | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') end end. End PmulI. Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := match P'' with | Pc c => PmulC P c | Pinj j' Q' => PmulI Pmul Q' j' P | PX P' i' Q' => match P with | Pc c => PmulC P'' c | Pinj j Q => let QQ' := match j with | xH => Pmul Q Q' | xO j => Pmul (Pinj (Pos.pred_double j) Q) Q' | xI j => Pmul (Pinj (xO j) Q) Q' end in mkPX (Pmul P P') i' QQ' | PX P i Q=> let QQ' := Pmul Q Q' in let PQ' := PmulI Pmul Q' xH P in let QP' := Pmul (mkPinj xH Q) P' in let PP' := Pmul P P' in (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' end end. Infix "**" := Pmul. Fixpoint Psquare (P:Pol) : Pol := match P with | Pc c => Pc (c *! c) | Pinj j Q => Pinj j (Psquare Q) | PX P i Q => let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in let Q2 := Psquare Q in let P2 := Psquare P in mkPX (mkPX P2 i P0 ++ twoPQ) i Q2 end. (** Monomial **) (** A monomial is X1^k1...Xi^ki. Its representation is a simplified version of the polynomial representation: - [mon0] correspond to the polynom [P1]. - [(zmon j M)] corresponds to [(Pinj j ...)], i.e. skip j variable indices. - [(vmon i M)] is X^i*M with X the current variable, its corresponds to (PX P1 i ...)] *) Inductive Mon: Set := | mon0: Mon | zmon: positive -> Mon -> Mon | vmon: positive -> Mon -> Mon. Definition mkZmon j M := match M with mon0 => mon0 | _ => zmon j M end. Definition zmon_pred j M := match j with xH => M | _ => mkZmon (Pos.pred j) M end. Definition mkVmon i M := match M with | mon0 => vmon i mon0 | zmon j m => vmon i (zmon_pred j m) | vmon i' m => vmon (i+i') m end. Fixpoint MFactor (P: Pol) (M: Mon) : Pol * Pol := match P, M with _, mon0 => (Pc cO, P) | Pc _, _ => (P, Pc cO) | Pinj j1 P1, zmon j2 M1 => match (j1 ?= j2) with Eq => let (R,S) := MFactor P1 M1 in (mkPinj j1 R, mkPinj j1 S) | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in (mkPinj j1 R, mkPinj j1 S) | Gt => (P, Pc cO) end | Pinj _ _, vmon _ _ => (P, Pc cO) | PX P1 i Q1, zmon j M1 => let M2 := zmon_pred j M1 in let (R1, S1) := MFactor P1 M in let (R2, S2) := MFactor Q1 M2 in (mkPX R1 i R2, mkPX S1 i S2) | PX P1 i Q1, vmon j M1 => match (i ?= j) with Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in (mkPX R1 i Q1, S1) | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in (mkPX R1 i Q1, S1) | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) end end. Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol := let (Q1,R1) := MFactor P1 M1 in match R1 with (Pc c) => if c ?=! cO then None else Some (Padd Q1 (Pmul P2 R1)) | _ => Some (Padd Q1 (Pmul P2 R1)) end. Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) : Pol := match POneSubst P1 M1 P2 with Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end | _ => P1 end. Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol := match POneSubst P1 M1 P2 with Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end | _ => None end. Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : Pol := match LM1 with cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n | _ => P1 end. Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : option Pol := match LM1 with cons (M1,P2) LM2 => match PNSubst P1 M1 P2 n with Some P3 => Some (PSubstL1 P3 LM2 n) | None => PSubstL P1 LM2 n end | _ => None end. Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) : Pol := match PSubstL P1 LM1 n with Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end | _ => P1 end. (** Evaluation of a polynomial towards R *) Fixpoint Pphi(l:Env R) (P:Pol) : R := match P with | Pc c => [c] | Pinj j Q => Pphi (jump j l) Q | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q end. Reserved Notation "P @ l " (at level 10, no associativity). Notation "P @ l " := (Pphi l P). (** Evaluation of a monomial towards R *) Fixpoint Mphi(l:Env R) (M: Mon) : R := match M with | mon0 => rI | zmon j M1 => Mphi (jump j l) M1 | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i end. Notation "M @@ l" := (Mphi l M) (at level 10, no associativity). (** Proofs *) Ltac destr_pos_sub := match goal with |- context [Z.pos_sub ?x ?y] => generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y) end. Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l. Proof. revert P';induction P;destruct P';simpl; intros H l; try easy. - now apply (morph_eq CRmorph). - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. now rewrite IHP. - specialize (IHP1 P'1); specialize (IHP2 P'2). destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. destruct (P2 ?== P'1); [|easy]. rewrite H in *. now rewrite IHP1, IHP2. Qed. Lemma Peq_spec P P' : BoolSpec (forall l, P@l == P'@l) True (P ?== P'). Proof. generalize (Peq_ok P P'). destruct (P ?== P'); auto. Qed. Lemma Pphi0 l : P0@l == 0. Proof. simpl;apply (morph0 CRmorph). Qed. Lemma Pphi1 l : P1@l == 1. Proof. simpl;apply (morph1 CRmorph). Qed. Lemma env_morph p e1 e2 : (forall x, e1 x = e2 x) -> p @ e1 = p @ e2. Proof. revert e1 e2. induction p ; simpl. - reflexivity. - intros e1 e2 EQ. apply IHp. intros. apply EQ. - intros e1 e2 EQ. f_equal; [f_equal|]. + now apply IHp1. + f_equal. apply EQ. + apply IHp2. intros; apply EQ. Qed. Lemma Pjump_add P i j l : P @ (jump (i + j) l) = P @ (jump j (jump i l)). Proof. apply env_morph. intros. rewrite <- jump_add. f_equal. apply Pos.add_comm. Qed. Lemma Pjump_xO_tail P p l : P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l). Proof. apply env_morph. intros. now jump_simpl. Qed. Lemma Pjump_pred_double P p l : P @ (jump (Pos.pred_double p) (tail l)) = P @ (jump (xO p) l). Proof. apply env_morph. intros. rewrite jump_pred_double. now jump_simpl. Qed. Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l). Proof. destruct P;simpl;rsimpl. now rewrite Pjump_add. Qed. Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. Proof. rewrite Pos.add_comm. apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). Qed. Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). Proof. generalize (morph_eq CRmorph c c'). destruct (c ?=! c'); auto. Qed. Lemma mkPX_ok l P i Q : (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l). Proof. unfold mkPX. destruct P. - case ceqb_spec; intros H; simpl; try reflexivity. rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl. - reflexivity. - case Peq_spec; intros H; simpl; try reflexivity. rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl. Qed. Hint Rewrite Pphi0 Pphi1 mkPinj_ok mkPX_ok (morph0 CRmorph) (morph1 CRmorph) (morph0 CRmorph) (morph_add CRmorph) (morph_mul CRmorph) (morph_sub CRmorph) (morph_opp CRmorph) : Esimpl. (* Quicker than autorewrite with Esimpl :-) *) Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl. Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c]. Proof. revert l;induction P;simpl;intros;Esimpl;trivial. rewrite IHP2;rsimpl. Qed. Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c]. Proof. revert l;induction P;simpl;intros. - Esimpl. - rewrite IHP;rsimpl. - rewrite IHP2;rsimpl. Qed. Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c]. Proof. revert l;induction P;simpl;intros;Esimpl;trivial. rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut. Qed. Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c]. Proof. unfold PmulC. case ceqb_spec; intros H. - rewrite H; Esimpl. - case ceqb_spec; intros H'. + rewrite H'; Esimpl. + apply PmulC_aux_ok. Qed. Lemma Popp_ok P l : (--P)@l == - P@l. Proof. revert l;induction P;simpl;intros. - Esimpl. - apply IHP. - rewrite IHP1, IHP2;rsimpl. Qed. Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl. Lemma PaddX_ok P' P k l : (forall P l, (P++P')@l == P@l + P'@l) -> (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k. Proof. intros IHP'. revert k l. induction P;simpl;intros. - add_permut. - destruct p; simpl; rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut. - destr_pos_sub; intros ->;Esimpl. + rewrite IHP';rsimpl. add_permut. + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + rewrite IHP1, pow_pos_add;rsimpl. add_permut. Qed. Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l. Proof. revert P l; induction P';simpl;intros;Esimpl. - revert p l; induction P;simpl;intros. + Esimpl; add_permut. + destr_pos_sub; intros ->;Esimpl. * now rewrite IHP'. * rewrite IHP';Esimpl. now rewrite Pjump_add. * rewrite IHP. now rewrite Pjump_add. + destruct p0;simpl. * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl. * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl. * rewrite IHP'. rsimpl. - destruct P;simpl. + Esimpl. add_permut. + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. * rewrite Pjump_xO_tail. rsimpl. add_permut. * rewrite Pjump_pred_double. rsimpl. add_permut. * rsimpl. unfold tail. add_permut. + destr_pos_sub; intros ->; Esimpl. * rewrite IHP'1, IHP'2;rsimpl. add_permut. * rewrite IHP'1, IHP'2;simpl;Esimpl. rewrite pow_pos_add;rsimpl. add_permut. * rewrite PaddX_ok by trivial; rsimpl. rewrite IHP'2, pow_pos_add; rsimpl. add_permut. Qed. Lemma PsubX_ok P' P k l : (forall P l, (P--P')@l == P@l - P'@l) -> (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k. Proof. intros IHP'. revert k l. induction P;simpl;intros. - rewrite Popp_ok;rsimpl; add_permut. - destruct p; simpl; rewrite Popp_ok;rsimpl; rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut. - destr_pos_sub; intros ->; Esimpl. + rewrite IHP';rsimpl. add_permut. + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + rewrite IHP1, pow_pos_add;rsimpl. add_permut. Qed. Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l. Proof. revert P l; induction P';simpl;intros;Esimpl. - revert p l; induction P;simpl;intros. + Esimpl; add_permut. + destr_pos_sub; intros ->;Esimpl. * rewrite IHP';rsimpl. * rewrite IHP';Esimpl. now rewrite Pjump_add. * rewrite IHP. now rewrite Pjump_add. + destruct p0;simpl. * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl. * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl. * rewrite IHP'. rsimpl. - destruct P;simpl. + Esimpl; add_permut. + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. * rewrite Pjump_xO_tail. rsimpl. add_permut. * rewrite Pjump_pred_double. rsimpl. add_permut. * rsimpl. unfold tail. add_permut. + destr_pos_sub; intros ->; Esimpl. * rewrite IHP'1, IHP'2;rsimpl. add_permut. * rewrite IHP'1, IHP'2;simpl;Esimpl. rewrite pow_pos_add;rsimpl. add_permut. * rewrite PsubX_ok by trivial;rsimpl. rewrite IHP'2, pow_pos_add;rsimpl. add_permut. Qed. Lemma PmulI_ok P' : (forall P l, (Pmul P P') @ l == P @ l * P' @ l) -> forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). Proof. intros IHP'. induction P;simpl;intros. - Esimpl; mul_permut. - destr_pos_sub; intros ->;Esimpl. + now rewrite IHP'. + now rewrite IHP', Pjump_add. + now rewrite IHP, Pjump_add. - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl. + rewrite Pjump_xO_tail. f_equiv. mul_permut. + rewrite Pjump_pred_double. f_equiv. mul_permut. + rewrite IHP'. f_equiv. mul_permut. Qed. Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l. Proof. revert P l;induction P';simpl;intros. - apply PmulC_ok. - apply PmulI_ok;trivial. - destruct P. + rewrite (ARmul_comm ARth). Esimpl. + Esimpl. rewrite IHP'1;Esimpl. f_equiv. destruct p0;rewrite IHP'2;Esimpl. * now rewrite Pjump_xO_tail. * rewrite Pjump_pred_double; Esimpl. + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok, !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl. unfold tail. add_permut; f_equiv; mul_permut. Qed. Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l. Proof. revert l;induction P;simpl;intros;Esimpl. - apply IHP. - rewrite Padd_ok, Pmul_ok;Esimpl. rewrite IHP1, IHP2. mul_push ((hd l)^p). now mul_push (P2@l). Qed. Lemma Mphi_morph M e1 e2 : (forall x, e1 x = e2 x) -> M @@ e1 = M @@ e2. Proof. revert e1 e2; induction M; simpl; intros e1 e2 EQ; trivial. - apply IHM. intros; apply EQ. - f_equal. * apply IHM. intros; apply EQ. * f_equal. apply EQ. Qed. Lemma Mjump_xO_tail M p l : M @@ (jump (xO p) (tail l)) = M @@ (jump (xI p) l). Proof. apply Mphi_morph. intros. now jump_simpl. Qed. Lemma Mjump_pred_double M p l : M @@ (jump (Pos.pred_double p) (tail l)) = M @@ (jump (xO p) l). Proof. apply Mphi_morph. intros. rewrite jump_pred_double. now jump_simpl. Qed. Lemma Mjump_add M i j l : M @@ (jump (i + j) l) = M @@ (jump j (jump i l)). Proof. apply Mphi_morph. intros. now rewrite <- jump_add, Pos.add_comm. Qed. Lemma mkZmon_ok M j l : (mkZmon j M) @@ l == (zmon j M) @@ l. Proof. destruct M; simpl; rsimpl. Qed. Lemma zmon_pred_ok M j l : (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l. Proof. destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl. - now rewrite Mjump_xO_tail. - rewrite Mjump_pred_double; rsimpl. Qed. Lemma mkVmon_ok M i l : (mkVmon i M)@@l == M@@l * (hd l)^i. Proof. destruct M;simpl;intros;rsimpl. - rewrite zmon_pred_ok;simpl;rsimpl. - rewrite pow_pos_add;rsimpl. Qed. Ltac destr_mfactor R S := match goal with | H : context [MFactor ?P _] |- context [MFactor ?P ?M] => specialize (H M); destruct MFactor as (R,S) end. Lemma Mphi_ok P M l : let (Q,R) := MFactor P M in P@l == Q@l + M@@l * R@l. Proof. revert M l; induction P; destruct M; intros l; simpl; auto; Esimpl. - case Pos.compare_spec; intros He; simpl. * destr_mfactor R1 S1. now rewrite IHP, He, !mkPinj_ok. * destr_mfactor R1 S1. rewrite IHP; simpl. now rewrite !mkPinj_ok, <- Mjump_add, Pos.add_comm, Pos.sub_add. * Esimpl. - destr_mfactor R1 S1. destr_mfactor R2 S2. rewrite IHP1, IHP2, !mkPX_ok, zmon_pred_ok; simpl; rsimpl. add_permut. - case Pos.compare_spec; intros He; simpl; destr_mfactor R1 S1; rewrite ?He, IHP1, mkPX_ok, ?mkZmon_ok; simpl; rsimpl; unfold tail; add_permut; mul_permut. * rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl. * rewrite mkPX_ok. simpl. Esimpl. mul_permut. rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl. Qed. Lemma POneSubst_ok P1 M1 P2 P3 l : POneSubst P1 M1 P2 = Some P3 -> M1@@l == P2@l -> P1@l == P3@l. Proof. unfold POneSubst. assert (H := Mphi_ok P1). destr_mfactor R1 S1. rewrite H; clear H. intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1). - rewrite EQ', Padd_ok, Pmul_ok; rsimpl. - revert EQ. destruct S1; try now injection 1. case ceqb_spec; now inversion 2. Qed. Lemma PNSubst1_ok n P1 M1 P2 l : M1@@l == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. Proof. revert P1. induction n; simpl; intros P1; generalize (POneSubst_ok P1 M1 P2); destruct POneSubst; intros; rewrite <- ?IHn; auto; reflexivity. Qed. Lemma PNSubst_ok n P1 M1 P2 l P3 : PNSubst P1 M1 P2 n = Some P3 -> M1@@l == P2@l -> P1@l == P3@l. Proof. unfold PNSubst. assert (H := POneSubst_ok P1 M1 P2); destruct POneSubst; try discriminate. destruct n; inversion_clear 1. intros. rewrite <- PNSubst1_ok; auto. Qed. Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) : Prop := match LM1 with | cons (M1,P2) LM2 => (M1@@l == P2@l) /\ MPcond LM2 l | _ => True end. Lemma PSubstL1_ok n LM1 P1 l : MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. Proof. revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. - reflexivity. - rewrite <- IH by intuition. now apply PNSubst1_ok. Qed. Lemma PSubstL_ok n LM1 P1 P2 l : PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. Proof. revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros. - discriminate. - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. * injection H as <-. rewrite <- PSubstL1_ok; intuition. * now apply IH. Qed. Lemma PNSubstL_ok m n LM1 P1 l : MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. Proof. revert LM1 P1. induction m; simpl; intros; assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL; auto; try reflexivity. rewrite <- IHm; auto. Qed. (** Definition of polynomial expressions *) Inductive PExpr : Type := | PEc : C -> PExpr | PEX : positive -> PExpr | PEadd : PExpr -> PExpr -> PExpr | PEsub : PExpr -> PExpr -> PExpr | PEmul : PExpr -> PExpr -> PExpr | PEopp : PExpr -> PExpr | PEpow : PExpr -> N -> PExpr. (** evaluation of polynomial expressions towards R *) Definition mk_X j := mkPinj_pred j mkX. (** evaluation of polynomial expressions towards R *) Fixpoint PEeval (l:Env R) (pe:PExpr) : R := match pe with | PEc c => phi c | PEX j => nth j l | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) | PEopp pe1 => - (PEeval l pe1) | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) end. (** Correctness proofs *) Lemma mkX_ok p l : nth p l == (mk_X p) @ l. Proof. destruct p;simpl;intros;Esimpl;trivial. rewrite nth_spec ; auto. unfold hd. now rewrite <- nth_pred_double, nth_jump. Qed. Hint Rewrite Padd_ok Psub_ok : Esimpl. Section POWER. Variable subst_l : Pol -> Pol. Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol := match p with | xH => subst_l (res ** P) | xO p => Ppow_pos (Ppow_pos res P p) P p | xI p => subst_l ((Ppow_pos (Ppow_pos res P p) P p) ** P) end. Definition Ppow_N P n := match n with | N0 => P1 | Npos p => Ppow_pos P1 P p end. Lemma Ppow_pos_ok l : (forall P, subst_l P@l == P@l) -> forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. Proof. intros subst_l_ok res P p. revert res. induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; mul_permut. Qed. Lemma Ppow_N_ok l : (forall P, subst_l P@l == P@l) -> forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. Proof. destruct n;simpl. - reflexivity. - rewrite Ppow_pos_ok by trivial. Esimpl. Qed. End POWER. (** Normalization and rewriting *) Section NORM_SUBST_REC. Variable n : nat. Variable lmp:list (Mon*Pol). Let subst_l P := PNSubstL P lmp n n. Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). Let Ppow_subst := Ppow_N subst_l. Fixpoint norm_aux (pe:PExpr) : Pol := match pe with | PEc c => Pc c | PEX j => mk_X j | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1) | PEadd pe1 (PEopp pe2) => Psub (norm_aux pe1) (norm_aux pe2) | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) | PEopp pe1 => Popp (norm_aux pe1) | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n end. Definition norm_subst pe := subst_l (norm_aux pe). (** Internally, [norm_aux] is expanded in a large number of cases. To speed-up proofs, we use an alternative definition. *) Definition get_PEopp pe := match pe with | PEopp pe' => Some pe' | _ => None end. Lemma norm_aux_PEadd pe1 pe2 : norm_aux (PEadd pe1 pe2) = match get_PEopp pe1, get_PEopp pe2 with | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1') | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2') | None, None => (norm_aux pe1) ++ (norm_aux pe2) end. Proof. simpl (norm_aux (PEadd _ _)). destruct pe1; [ | | | | | reflexivity | ]; destruct pe2; simpl get_PEopp; reflexivity. Qed. Lemma norm_aux_PEopp pe : match get_PEopp pe with | Some pe' => norm_aux pe = -- (norm_aux pe') | None => True end. Proof. now destruct pe. Qed. Lemma norm_aux_spec l pe : PEeval l pe == (norm_aux pe)@l. Proof. intros. induction pe. - reflexivity. - apply mkX_ok. - simpl PEeval. rewrite IHpe1, IHpe2. assert (H1 := norm_aux_PEopp pe1). assert (H2 := norm_aux_PEopp pe2). rewrite norm_aux_PEadd. do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut. - simpl. rewrite IHpe1, IHpe2. Esimpl. - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - simpl. rewrite IHpe. Esimpl. - simpl. rewrite Ppow_N_ok by reflexivity. rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl. induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. End NORM_SUBST_REC. End MakeRingPol. coq-8.6/plugins/micromega/g_micromega.ml40000644000175000017500000000576613022274260020010 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ Tactics.red_in_concl ] END TACTIC EXTEND PsatzZ | [ "psatz_Z" int_or_var(i) tactic(t) ] -> [ (Coq_micromega.psatz_Z i (Tacinterp.tactic_of_value ist t)) ] | [ "psatz_Z" tactic(t)] -> [ (Coq_micromega.psatz_Z (-1)) (Tacinterp.tactic_of_value ist t) ] END TACTIC EXTEND Lia [ "xlia" tactic(t) ] -> [ (Coq_micromega.xlia (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND Nia [ "xnlia" tactic(t) ] -> [ (Coq_micromega.xnlia (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND NRA [ "xnra" tactic(t) ] -> [ (Coq_micromega.nra (Tacinterp.tactic_of_value ist t))] END TACTIC EXTEND NQA [ "xnqa" tactic(t) ] -> [ (Coq_micromega.nqa (Tacinterp.tactic_of_value ist t))] END TACTIC EXTEND Sos_Z | [ "sos_Z" tactic(t) ] -> [ (Coq_micromega.sos_Z (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND Sos_Q | [ "sos_Q" tactic(t) ] -> [ (Coq_micromega.sos_Q (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND Sos_R | [ "sos_R" tactic(t) ] -> [ (Coq_micromega.sos_R (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND LRA_Q [ "lra_Q" tactic(t) ] -> [ (Coq_micromega.lra_Q (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND LRA_R [ "lra_R" tactic(t) ] -> [ (Coq_micromega.lra_R (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND PsatzR | [ "psatz_R" int_or_var(i) tactic(t) ] -> [ (Coq_micromega.psatz_R i (Tacinterp.tactic_of_value ist t)) ] | [ "psatz_R" tactic(t) ] -> [ (Coq_micromega.psatz_R (-1) (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND PsatzQ | [ "psatz_Q" int_or_var(i) tactic(t) ] -> [ (Coq_micromega.psatz_Q i (Tacinterp.tactic_of_value ist t)) ] | [ "psatz_Q" tactic(t) ] -> [ (Coq_micromega.psatz_Q (-1) (Tacinterp.tactic_of_value ist t)) ] END coq-8.6/plugins/micromega/coq_micromega.ml0000644000175000017500000023341313022274260020250 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Some !vref); optwrite = (fun x -> vref := (match x with None -> max_depth | Some v -> v)) } in let lia_enum_opt = { optsync = true; optdepr = false; optname = "Lia Enum"; optkey = ["Lia";"Enum"]; optread = (fun () -> !lia_enum); optwrite = (fun x -> lia_enum := x) } in let _ = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in let _ = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in let _ = declare_bool_option lia_enum_opt in () (** * Initialize a tag type to the Tag module declaration (see Mutils). *) type tag = Tag.t (** * An atom is of the form: * pExpr1 \{<,>,=,<>,<=,>=\} pExpr2 * where pExpr1, pExpr2 are polynomial expressions (see Micromega). pExprs are * parametrized by 'cst, which is used as the type of constants. *) type 'cst atom = 'cst Micromega.formula (** * Micromega's encoding of formulas. * By order of appearance: boolean constants, variables, atoms, conjunctions, * disjunctions, negation, implication. *) type 'cst formula = | TT | FF | X of Term.constr | A of 'cst atom * tag * Term.constr | C of 'cst formula * 'cst formula | D of 'cst formula * 'cst formula | N of 'cst formula | I of 'cst formula * Names.Id.t option * 'cst formula (** * Formula pretty-printer. *) let rec pp_formula o f = match f with | TT -> output_string o "tt" | FF -> output_string o "ff" | X c -> output_string o "X " | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2 | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" pp_formula f1 (match n with | Some id -> Names.Id.to_string id | None -> "") pp_formula f2 | N(f) -> Printf.fprintf o "N(%a)" pp_formula f let rec map_atoms fct f = match f with | TT -> TT | FF -> FF | X x -> X x | A (at,tg,cstr) -> A(fct at,tg,cstr) | C (f1,f2) -> C(map_atoms fct f1, map_atoms fct f2) | D (f1,f2) -> D(map_atoms fct f1, map_atoms fct f2) | N f -> N(map_atoms fct f) | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2) let rec map_prop fct f = match f with | TT -> TT | FF -> FF | X x -> X (fct x) | A (at,tg,cstr) -> A(at,tg,cstr) | C (f1,f2) -> C(map_prop fct f1, map_prop fct f2) | D (f1,f2) -> D(map_prop fct f1, map_prop fct f2) | N f -> N(map_prop fct f) | I(f1,o,f2) -> I(map_prop fct f1, o , map_prop fct f2) (** * Collect the identifiers of a (string of) implications. Implication labels * are inherited from Coq/CoC's higher order dependent type constructor (Pi). *) let rec ids_of_formula f = match f with | I(f1,Some id,f2) -> id::(ids_of_formula f2) | _ -> [] (** * A clause is a list of (tagged) nFormulas. * nFormulas are normalized formulas, i.e., of the form: * cPol \{=,<>,>,>=\} 0 * with cPol compact polynomials (see the Pol inductive type in EnvRing.v). *) type 'cst clause = ('cst Micromega.nFormula * tag) list (** * A CNF is a list of clauses. *) type 'cst cnf = ('cst clause) list (** * True and False are empty cnfs and clauses. *) let tt : 'cst cnf = [] let ff : 'cst cnf = [ [] ] (** * A refinement of cnf with tags left out. This is an intermediary form * between the cnf tagged list representation ('cst cnf) used to solve psatz, * and the freeform formulas ('cst formula) that is retrieved from Coq. *) module Mc = Micromega type 'cst mc_cnf = ('cst Mc.nFormula) list list (** * From a freeform formula, build a cnf. * The parametric functions negate and normalize are theory-dependent, and * originate in micromega.ml (extracted, e.g. for rnegate, from RMicromega.v * and RingMicromega.v). *) type 'a tagged_option = T of tag list | S of 'a let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) (unsat : 'cst Mc.nFormula -> bool) (deduce : 'cst Mc.nFormula -> 'cst Mc.nFormula -> 'cst Mc.nFormula option) (f:'cst formula) = let negate a t = List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in let normalise a t = List.map (fun cl -> List.map (fun x -> (x,t)) cl) (normalise a) in let and_cnf x y = x @ y in let rec add_term t0 = function | [] -> (match deduce (fst t0) (fst t0) with | Some u -> if unsat u then T [snd t0] else S (t0::[]) | None -> S (t0::[])) | t'::cl0 -> (match deduce (fst t0) (fst t') with | Some u -> if unsat u then T [snd t0 ; snd t'] else (match add_term t0 cl0 with | S cl' -> S (t'::cl') | T l -> T l) | None -> (match add_term t0 cl0 with | S cl' -> S (t'::cl') | T l -> T l)) in let rec or_clause cl1 cl2 = match cl1 with | [] -> S cl2 | t0::cl -> (match add_term t0 cl2 with | S cl' -> or_clause cl cl' | T l -> T l) in let or_clause_cnf t f = List.fold_right (fun e (acc,tg) -> match or_clause t e with | S cl -> (cl :: acc,tg) | T l -> (acc,tg@l)) f ([],[]) in let rec or_cnf f f' = match f with | [] -> tt,[] | e :: rst -> let (rst_f',t) = or_cnf rst f' in let (e_f', t') = or_clause_cnf e f' in (rst_f' @ e_f', t @ t') in let rec xcnf (polarity : bool) f = match f with | TT -> if polarity then (tt,[]) else (ff,[]) | FF -> if polarity then (ff,[]) else (tt,[]) | X p -> if polarity then (ff,[]) else (ff,[]) | A(x,t,_) -> ((if polarity then normalise x t else negate x t),[]) | N(e) -> xcnf (not polarity) e | C(e1,e2) -> let e1,t1 = xcnf polarity e1 in let e2,t2 = xcnf polarity e2 in if polarity then and_cnf e1 e2, t1 @ t2 else let f',t' = or_cnf e1 e2 in (f', t1 @ t2 @ t') | D(e1,e2) -> let e1,t1 = xcnf polarity e1 in let e2,t2 = xcnf polarity e2 in if polarity then let f',t' = or_cnf e1 e2 in (f', t1 @ t2 @ t') else and_cnf e1 e2, t1 @ t2 | I(e1,_,e2) -> let e1 , t1 = (xcnf (not polarity) e1) in let e2 , t2 = (xcnf polarity e2) in if polarity then let f',t' = or_cnf e1 e2 in (f', t1 @ t2 @ t') else and_cnf e1 e2, t1 @ t2 in xcnf true f (** * MODULE: Ordered set of integers. *) module ISet = Set.Make(Int) module IMap = Map.Make(Int) (** * Given a set of integers s=\{i0,...,iN\} and a list m, return the list of * elements of m that are at position i0,...,iN. *) let selecti s m = let rec xselecti i m = match m with | [] -> [] | e::m -> if ISet.mem i s then e::(xselecti (i+1) m) else xselecti (i+1) m in xselecti 0 m (** * MODULE: Mapping of the Coq data-strustures into Caml and Caml extracted * code. This includes initializing Caml variables based on Coq terms, parsing * various Coq expressions into Caml, and dumping Caml expressions into Coq. * * Opened here and in csdpcert.ml. *) module M = struct open Coqlib open Term (** * Location of the Coq libraries. *) let logic_dir = ["Coq";"Logic";"Decidable"] let mic_modules = [ ["Coq";"Lists";"List"]; ["ZMicromega"]; ["Tauto"]; ["RingMicromega"]; ["EnvRing"]; ["Coq"; "micromega"; "ZMicromega"]; ["Coq"; "micromega"; "RMicromega"]; ["Coq" ; "micromega" ; "Tauto"]; ["Coq" ; "micromega" ; "RingMicromega"]; ["Coq" ; "micromega" ; "EnvRing"]; ["Coq";"QArith"; "QArith_base"]; ["Coq";"Reals" ; "Rdefinitions"]; ["Coq";"Reals" ; "Rpow_def"]; ["LRing_normalise"]] let coq_modules = init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules @ mic_modules let bin_module = [["Coq";"Numbers";"BinNums"]] let r_modules = [["Coq";"Reals" ; "Rdefinitions"]; ["Coq";"Reals" ; "Rpow_def"] ; ["Coq";"Reals" ; "Raxioms"] ; ] let z_modules = [["Coq";"ZArith";"BinInt"]] (** * Initialization : a large amount of Caml symbols are derived from * ZMicromega.v *) let init_constant = gen_constant_in_modules "ZMicromega" init_modules let constant = gen_constant_in_modules "ZMicromega" coq_modules let bin_constant = gen_constant_in_modules "ZMicromega" bin_module let r_constant = gen_constant_in_modules "ZMicromega" r_modules let z_constant = gen_constant_in_modules "ZMicromega" z_modules let m_constant = gen_constant_in_modules "ZMicromega" mic_modules let coq_and = lazy (init_constant "and") let coq_or = lazy (init_constant "or") let coq_not = lazy (init_constant "not") let coq_not_gl_ref = (Nametab.locate ( Libnames.qualid_of_string "Coq.Init.Logic.not")) let coq_iff = lazy (init_constant "iff") let coq_True = lazy (init_constant "True") let coq_False = lazy (init_constant "False") let coq_cons = lazy (constant "cons") let coq_nil = lazy (constant "nil") let coq_list = lazy (constant "list") let coq_O = lazy (init_constant "O") let coq_S = lazy (init_constant "S") let coq_nat = lazy (init_constant "nat") let coq_N0 = lazy (bin_constant "N0") let coq_Npos = lazy (bin_constant "Npos") let coq_pair = lazy (init_constant "pair") let coq_None = lazy (init_constant "None") let coq_option = lazy (init_constant "option") let coq_positive = lazy (bin_constant "positive") let coq_xH = lazy (bin_constant "xH") let coq_xO = lazy (bin_constant "xO") let coq_xI = lazy (bin_constant "xI") let coq_Z = lazy (bin_constant "Z") let coq_ZERO = lazy (bin_constant "Z0") let coq_POS = lazy (bin_constant "Zpos") let coq_NEG = lazy (bin_constant "Zneg") let coq_Q = lazy (constant "Q") let coq_R = lazy (constant "R") let coq_Build_Witness = lazy (constant "Build_Witness") let coq_Qmake = lazy (constant "Qmake") let coq_Rcst = lazy (constant "Rcst") let coq_C0 = lazy (m_constant "C0") let coq_C1 = lazy (m_constant "C1") let coq_CQ = lazy (m_constant "CQ") let coq_CZ = lazy (m_constant "CZ") let coq_CPlus = lazy (m_constant "CPlus") let coq_CMinus = lazy (m_constant "CMinus") let coq_CMult = lazy (m_constant "CMult") let coq_CInv = lazy (m_constant "CInv") let coq_COpp = lazy (m_constant "COpp") let coq_R0 = lazy (constant "R0") let coq_R1 = lazy (constant "R1") let coq_proofTerm = lazy (constant "ZArithProof") let coq_doneProof = lazy (constant "DoneProof") let coq_ratProof = lazy (constant "RatProof") let coq_cutProof = lazy (constant "CutProof") let coq_enumProof = lazy (constant "EnumProof") let coq_Zgt = lazy (z_constant "Z.gt") let coq_Zge = lazy (z_constant "Z.ge") let coq_Zle = lazy (z_constant "Z.le") let coq_Zlt = lazy (z_constant "Z.lt") let coq_Eq = lazy (init_constant "eq") let coq_Zplus = lazy (z_constant "Z.add") let coq_Zminus = lazy (z_constant "Z.sub") let coq_Zopp = lazy (z_constant "Z.opp") let coq_Zmult = lazy (z_constant "Z.mul") let coq_Zpower = lazy (z_constant "Z.pow") let coq_Qgt = lazy (constant "Qgt") let coq_Qge = lazy (constant "Qge") let coq_Qle = lazy (constant "Qle") let coq_Qlt = lazy (constant "Qlt") let coq_Qeq = lazy (constant "Qeq") let coq_Qplus = lazy (constant "Qplus") let coq_Qminus = lazy (constant "Qminus") let coq_Qopp = lazy (constant "Qopp") let coq_Qmult = lazy (constant "Qmult") let coq_Qpower = lazy (constant "Qpower") let coq_Rgt = lazy (r_constant "Rgt") let coq_Rge = lazy (r_constant "Rge") let coq_Rle = lazy (r_constant "Rle") let coq_Rlt = lazy (r_constant "Rlt") let coq_Rplus = lazy (r_constant "Rplus") let coq_Rminus = lazy (r_constant "Rminus") let coq_Ropp = lazy (r_constant "Ropp") let coq_Rmult = lazy (r_constant "Rmult") let coq_Rdiv = lazy (r_constant "Rdiv") let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") let coq_IZR = lazy (r_constant "IZR") let coq_IQR = lazy (constant "IQR") let coq_PEX = lazy (constant "PEX" ) let coq_PEc = lazy (constant"PEc") let coq_PEadd = lazy (constant "PEadd") let coq_PEopp = lazy (constant "PEopp") let coq_PEmul = lazy (constant "PEmul") let coq_PEsub = lazy (constant "PEsub") let coq_PEpow = lazy (constant "PEpow") let coq_PX = lazy (constant "PX" ) let coq_Pc = lazy (constant"Pc") let coq_Pinj = lazy (constant "Pinj") let coq_OpEq = lazy (constant "OpEq") let coq_OpNEq = lazy (constant "OpNEq") let coq_OpLe = lazy (constant "OpLe") let coq_OpLt = lazy (constant "OpLt") let coq_OpGe = lazy (constant "OpGe") let coq_OpGt = lazy (constant "OpGt") let coq_PsatzIn = lazy (constant "PsatzIn") let coq_PsatzSquare = lazy (constant "PsatzSquare") let coq_PsatzMulE = lazy (constant "PsatzMulE") let coq_PsatzMultC = lazy (constant "PsatzMulC") let coq_PsatzAdd = lazy (constant "PsatzAdd") let coq_PsatzC = lazy (constant "PsatzC") let coq_PsatzZ = lazy (constant "PsatzZ") let coq_coneMember = lazy (constant "coneMember") let coq_make_impl = lazy (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl") let coq_make_conj = lazy (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj") let coq_TT = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") let coq_FF = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF") let coq_And = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj") let coq_Or = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D") let coq_Neg = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N") let coq_Atom = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A") let coq_X = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X") let coq_Impl = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I") let coq_Formula = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula") (** * Initialization : a few Caml symbols are derived from other libraries; * QMicromega, ZArithRing, RingMicromega. *) let coq_QWitness = lazy (gen_constant_in_modules "QMicromega" [["Coq"; "micromega"; "QMicromega"]] "QWitness") let coq_ZWitness = lazy (gen_constant_in_modules "QMicromega" [["Coq"; "micromega"; "ZMicromega"]] "ZWitness") let coq_N_of_Z = lazy (gen_constant_in_modules "ZArithRing" [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z") let coq_Build = lazy (gen_constant_in_modules "RingMicromega" [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Build_Formula") let coq_Cstr = lazy (gen_constant_in_modules "RingMicromega" [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula") (** * Parsing and dumping : transformation functions between Caml and Coq * data-structures. * * dump_* functions go from Micromega to Coq terms * parse_* functions go from Coq to Micromega terms * pp_* functions pretty-print Coq terms. *) (* Error datastructures *) type parse_error = | Ukn | BadStr of string | BadNum of int | BadTerm of Term.constr | Msg of string | Goal of (Term.constr list ) * Term.constr * parse_error let string_of_error = function | Ukn -> "ukn" | BadStr s -> s | BadNum i -> string_of_int i | BadTerm _ -> "BadTerm" | Msg s -> s | Goal _ -> "Goal" exception ParseError (* A simple but useful getter function *) let get_left_construct term = match Term.kind_of_term term with | Term.Construct((_,i),_) -> (i,[| |]) | Term.App(l,rst) -> (match Term.kind_of_term l with | Term.Construct((_,i),_) -> (i,rst) | _ -> raise ParseError ) | _ -> raise ParseError (* Access the Micromega module *) (* parse/dump/print from numbers up to expressions and formulas *) let rec parse_nat term = let (i,c) = get_left_construct term in match i with | 1 -> Mc.O | 2 -> Mc.S (parse_nat (c.(0))) | i -> raise ParseError let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n) let rec dump_nat x = match x with | Mc.O -> Lazy.force coq_O | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |]) let rec parse_positive term = let (i,c) = get_left_construct term in match i with | 1 -> Mc.XI (parse_positive c.(0)) | 2 -> Mc.XO (parse_positive c.(0)) | 3 -> Mc.XH | i -> raise ParseError let rec dump_positive x = match x with | Mc.XH -> Lazy.force coq_xH | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_positive p |]) | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_positive p |]) let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) let dump_n x = match x with | Mc.N0 -> Lazy.force coq_N0 | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) let rec dump_index x = match x with | Mc.XH -> Lazy.force coq_xH | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_index p |]) | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_index p |]) let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x) let pp_n o x = output_string o (string_of_int (CoqToCaml.n x)) let dump_pair t1 t2 dump_t1 dump_t2 (x,y) = Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|]) let parse_z term = let (i,c) = get_left_construct term in match i with | 1 -> Mc.Z0 | 2 -> Mc.Zpos (parse_positive c.(0)) | 3 -> Mc.Zneg (parse_positive c.(0)) | i -> raise ParseError let dump_z x = match x with | Mc.Z0 ->Lazy.force coq_ZERO | Mc.Zpos p -> Term.mkApp(Lazy.force coq_POS,[| dump_positive p|]) | Mc.Zneg p -> Term.mkApp(Lazy.force coq_NEG,[| dump_positive p|]) let pp_z o x = Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x)) let dump_num bd1 = Term.mkApp(Lazy.force coq_Qmake, [|dump_z (CamlToCoq.bigint (numerator bd1)) ; dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |]) let dump_q q = Term.mkApp(Lazy.force coq_Qmake, [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) let parse_q term = match Term.kind_of_term term with | Term.App(c, args) -> if Constr.equal c (Lazy.force coq_Qmake) then {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) } else raise ParseError | _ -> raise ParseError let rec pp_Rcst o cst = match cst with | Mc.C0 -> output_string o "C0" | Mc.C1 -> output_string o "C1" | Mc.CQ q -> output_string o "CQ _" | Mc.CZ z -> pp_z o z | Mc.CPlus(x,y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y | Mc.CMinus(x,y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y | Mc.CMult(x,y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y | Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t let rec dump_Rcst cst = match cst with | Mc.C0 -> Lazy.force coq_C0 | Mc.C1 -> Lazy.force coq_C1 | Mc.CQ q -> Term.mkApp(Lazy.force coq_CQ, [| dump_q q |]) | Mc.CZ z -> Term.mkApp(Lazy.force coq_CZ, [| dump_z z |]) | Mc.CPlus(x,y) -> Term.mkApp(Lazy.force coq_CPlus, [| dump_Rcst x ; dump_Rcst y |]) | Mc.CMinus(x,y) -> Term.mkApp(Lazy.force coq_CMinus, [| dump_Rcst x ; dump_Rcst y |]) | Mc.CMult(x,y) -> Term.mkApp(Lazy.force coq_CMult, [| dump_Rcst x ; dump_Rcst y |]) | Mc.CInv t -> Term.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) | Mc.COpp t -> Term.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) let rec parse_Rcst term = let (i,c) = get_left_construct term in match i with | 1 -> Mc.C0 | 2 -> Mc.C1 | 3 -> Mc.CQ (parse_q c.(0)) | 4 -> Mc.CPlus(parse_Rcst c.(0), parse_Rcst c.(1)) | 5 -> Mc.CMinus(parse_Rcst c.(0), parse_Rcst c.(1)) | 6 -> Mc.CMult(parse_Rcst c.(0), parse_Rcst c.(1)) | 7 -> Mc.CInv(parse_Rcst c.(0)) | 8 -> Mc.COpp(parse_Rcst c.(0)) | _ -> raise ParseError let rec parse_list parse_elt term = let (i,c) = get_left_construct term in match i with | 1 -> [] | 2 -> parse_elt c.(1) :: parse_list parse_elt c.(2) | i -> raise ParseError let rec dump_list typ dump_elt l = match l with | [] -> Term.mkApp(Lazy.force coq_nil,[| typ |]) | e :: l -> Term.mkApp(Lazy.force coq_cons, [| typ; dump_elt e;dump_list typ dump_elt l|]) let pp_list op cl elt o l = let rec _pp o l = match l with | [] -> () | [e] -> Printf.fprintf o "%a" elt e | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in Printf.fprintf o "%s%a%s" op _pp l cl let pp_var = pp_positive let dump_var = dump_positive let pp_expr pp_z o e = let rec pp_expr o e = match e with | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n | Mc.PEc z -> pp_z o z | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2 | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2 | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2 | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n n in pp_expr o e let dump_expr typ dump_z e = let rec dump_expr e = match e with | Mc.PEX n -> mkApp(Lazy.force coq_PEX,[| typ; dump_var n |]) | Mc.PEc z -> mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |]) | Mc.PEadd(e1,e2) -> mkApp(Lazy.force coq_PEadd, [| typ; dump_expr e1;dump_expr e2|]) | Mc.PEsub(e1,e2) -> mkApp(Lazy.force coq_PEsub, [| typ; dump_expr e1;dump_expr e2|]) | Mc.PEopp e -> mkApp(Lazy.force coq_PEopp, [| typ; dump_expr e|]) | Mc.PEmul(e1,e2) -> mkApp(Lazy.force coq_PEmul, [| typ; dump_expr e1;dump_expr e2|]) | Mc.PEpow(e,n) -> mkApp(Lazy.force coq_PEpow, [| typ; dump_expr e; dump_n n|]) in dump_expr e let dump_pol typ dump_c e = let rec dump_pol e = match e with | Mc.Pc n -> mkApp(Lazy.force coq_Pc, [|typ ; dump_c n|]) | Mc.Pinj(p,pol) -> mkApp(Lazy.force coq_Pinj , [| typ ; dump_positive p ; dump_pol pol|]) | Mc.PX(pol1,p,pol2) -> mkApp(Lazy.force coq_PX, [| typ ; dump_pol pol1 ; dump_positive p ; dump_pol pol2|]) in dump_pol e let pp_pol pp_c o e = let rec pp_pol o e = match e with | Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n | Mc.Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in pp_pol o e let pp_cnf pp_c o f = let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) l in List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f let dump_psatz typ dump_z e = let z = Lazy.force typ in let rec dump_cone e = match e with | Mc.PsatzIn n -> mkApp(Lazy.force coq_PsatzIn,[| z; dump_nat n |]) | Mc.PsatzMulC(e,c) -> mkApp(Lazy.force coq_PsatzMultC, [| z; dump_pol z dump_z e ; dump_cone c |]) | Mc.PsatzSquare e -> mkApp(Lazy.force coq_PsatzSquare, [| z;dump_pol z dump_z e|]) | Mc.PsatzAdd(e1,e2) -> mkApp(Lazy.force coq_PsatzAdd, [| z; dump_cone e1; dump_cone e2|]) | Mc.PsatzMulE(e1,e2) -> mkApp(Lazy.force coq_PsatzMulE, [| z; dump_cone e1; dump_cone e2|]) | Mc.PsatzC p -> mkApp(Lazy.force coq_PsatzC,[| z; dump_z p|]) | Mc.PsatzZ -> mkApp( Lazy.force coq_PsatzZ,[| z|]) in dump_cone e let pp_psatz pp_z o e = let rec pp_cone o e = match e with | Mc.PsatzIn n -> Printf.fprintf o "(In %a)%%nat" pp_nat n | Mc.PsatzMulC(e,c) -> Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c | Mc.PsatzSquare e -> Printf.fprintf o "(%a^2)" (pp_pol pp_z) e | Mc.PsatzAdd(e1,e2) -> Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2 | Mc.PsatzMulE(e1,e2) -> Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2 | Mc.PsatzC p -> Printf.fprintf o "(%a)%%positive" pp_z p | Mc.PsatzZ -> Printf.fprintf o "0" in pp_cone o e let dump_op = function | Mc.OpEq-> Lazy.force coq_OpEq | Mc.OpNEq-> Lazy.force coq_OpNEq | Mc.OpLe -> Lazy.force coq_OpLe | Mc.OpGe -> Lazy.force coq_OpGe | Mc.OpGt-> Lazy.force coq_OpGt | Mc.OpLt-> Lazy.force coq_OpLt let pp_op o e= match e with | Mc.OpEq-> Printf.fprintf o "=" | Mc.OpNEq-> Printf.fprintf o "<>" | Mc.OpLe -> Printf.fprintf o "=<" | Mc.OpGe -> Printf.fprintf o ">=" | Mc.OpGt-> Printf.fprintf o ">" | Mc.OpLt-> Printf.fprintf o "<" let pp_cstr pp_z o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } = Printf.fprintf o"(%a %a %a)" (pp_expr pp_z) l pp_op op (pp_expr pp_z) r let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} = Term.mkApp(Lazy.force coq_Build, [| typ; dump_expr typ dump_constant e1 ; dump_op o ; dump_expr typ dump_constant e2|]) let assoc_const x l = try snd (List.find (fun (x',y) -> Constr.equal x (Lazy.force x')) l) with Not_found -> raise ParseError let zop_table = [ coq_Zgt, Mc.OpGt ; coq_Zge, Mc.OpGe ; coq_Zlt, Mc.OpLt ; coq_Zle, Mc.OpLe ] let rop_table = [ coq_Rgt, Mc.OpGt ; coq_Rge, Mc.OpGe ; coq_Rlt, Mc.OpLt ; coq_Rle, Mc.OpLe ] let qop_table = [ coq_Qlt, Mc.OpLt ; coq_Qle, Mc.OpLe ; coq_Qeq, Mc.OpEq ] let has_typ gl t1 typ = let ty = Retyping.get_type_of (Tacmach.pf_env gl) (Tacmach.project gl) t1 in Constr.equal ty typ let is_convertible gl t1 t2 = Reductionops.is_conv (Tacmach.pf_env gl) (Tacmach.project gl) t1 t2 let parse_zop gl (op,args) = match kind_of_term op with | Const (x,_) -> (assoc_const op zop_table, args.(0) , args.(1)) | Ind((n,0),_) -> if Constr.equal op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError | _ -> failwith "parse_zop" let parse_rop gl (op,args) = match kind_of_term op with | Const (x,_) -> (assoc_const op rop_table, args.(0) , args.(1)) | Ind((n,0),_) -> if Constr.equal op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError | _ -> failwith "parse_zop" let parse_qop gl (op,args) = (assoc_const op qop_table, args.(0) , args.(1)) let is_constant t = (* This is an approx *) match kind_of_term t with | Construct(i,_) -> true | _ -> false type 'a op = | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) | Opp | Power | Ukn of string let assoc_ops x l = try snd (List.find (fun (x',y) -> Constr.equal x (Lazy.force x')) l) with Not_found -> Ukn "Oups" (** * MODULE: Env is for environment. *) module Env = struct type t = constr list let compute_rank_add env v = let rec _add env n v = match env with | [] -> ([v],n) | e::l -> if eq_constr e v then (env,n) else let (env,n) = _add l ( n+1) v in (e::env,n) in let (env, n) = _add env 1 v in (env, CamlToCoq.positive n) let get_rank env v = let rec _get_rank env n = match env with | [] -> raise (Invalid_argument "get_rank") | e::l -> if eq_constr e v then n else _get_rank l (n+1) in _get_rank env 1 let empty = [] let elements env = env end (* MODULE END: Env *) (** * This is the big generic function for expression parsers. *) let parse_expr parse_constant parse_exp ops_spec env term = if debug then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term); (* let constant_or_variable env term = try ( Mc.PEc (parse_constant term) , env) with ParseError -> let (env,n) = Env.compute_rank_add env term in (Mc.PEX n , env) in *) let parse_variable env term = let (env,n) = Env.compute_rank_add env term in (Mc.PEX n , env) in let rec parse_expr env term = let combine env op (t1,t2) = let (expr1,env) = parse_expr env t1 in let (expr2,env) = parse_expr env t2 in (op expr1 expr2,env) in try (Mc.PEc (parse_constant term) , env) with ParseError -> match kind_of_term term with | App(t,args) -> ( match kind_of_term t with | Const c -> ( match assoc_ops t ops_spec with | Binop f -> combine env f (args.(0),args.(1)) | Opp -> let (expr,env) = parse_expr env args.(0) in (Mc.PEopp expr, env) | Power -> begin try let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in (power , env) with e when CErrors.noncritical e -> (* if the exponent is a variable *) let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) end | Ukn s -> if debug then (Printf.printf "unknown op: %s\n" s; flush stdout;); let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) ) | _ -> parse_variable env term ) | _ -> parse_variable env term in parse_expr env term let zop_spec = [ coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ; coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ; coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ; coq_Zopp , Opp ; coq_Zpower , Power] let qop_spec = [ coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ; coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ; coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ; coq_Qopp , Opp ; coq_Qpower , Power] let rop_spec = [ coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ; coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ; coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ; coq_Ropp , Opp ; coq_Rpower , Power] let zconstant = parse_z let qconstant = parse_q let rconst_assoc = [ coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ; coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; coq_Rmult , (fun x y -> Mc.CMult(x,y)) ; (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) ] let rec rconstant term = match Term.kind_of_term term with | Const x -> if Constr.equal term (Lazy.force coq_R0) then Mc.C0 else if Constr.equal term (Lazy.force coq_R1) then Mc.C1 else raise ParseError | App(op,args) -> begin try (* the evaluation order is important in the following *) let f = assoc_const op rconst_assoc in let a = rconstant args.(0) in let b = rconstant args.(1) in f a b with ParseError -> match op with | op when Constr.equal op (Lazy.force coq_Rinv) -> let arg = rconstant args.(0) in if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH} then raise ParseError (* This is a division by zero -- no semantics *) else Mc.CInv(arg) | op when Constr.equal op (Lazy.force coq_IQR) -> Mc.CQ (parse_q args.(0)) | op when Constr.equal op (Lazy.force coq_IZR) -> Mc.CZ (parse_z args.(0)) | _ -> raise ParseError end | _ -> raise ParseError let rconstant term = if debug then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.prterm term ++ fnl ()); let res = rconstant term in if debug then (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; res let parse_zexpr = parse_expr zconstant (fun expr x -> let exp = (parse_z x) in match exp with | Mc.Zneg _ -> Mc.PEc Mc.Z0 | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) zop_spec let parse_qexpr = parse_expr qconstant (fun expr x -> let exp = parse_z x in match exp with | Mc.Zneg _ -> begin match expr with | Mc.PEc q -> Mc.PEc (Mc.qpower q exp) | _ -> print_string "parse_qexpr parse error" ; flush stdout ; raise ParseError end | _ -> let exp = Mc.Z.to_N exp in Mc.PEpow(expr,exp)) qop_spec let parse_rexpr = parse_expr rconstant (fun expr x -> let exp = Mc.N.of_nat (parse_nat x) in Mc.PEpow(expr,exp)) rop_spec let parse_arith parse_op parse_expr env cstr gl = if debug then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.prterm cstr ++ fnl ()); match kind_of_term cstr with | App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in let (e1,env) = parse_expr env lhs in let (e2,env) = parse_expr env rhs in ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) | _ -> failwith "error : parse_arith(2)" let parse_zarith = parse_arith parse_zop parse_zexpr let parse_qarith = parse_arith parse_qop parse_qexpr let parse_rarith = parse_arith parse_rop parse_rexpr (* generic parsing of arithmetic expressions *) let rec f2f = function | TT -> Mc.TT | FF -> Mc.FF | X _ -> Mc.X | A (x,_,_) -> Mc.A x | C (a,b) -> Mc.Cj(f2f a,f2f b) | D (a,b) -> Mc.D(f2f a,f2f b) | N (a) -> Mc.N(f2f a) | I(a,_,b) -> Mc.I(f2f a,f2f b) let mkC f1 f2 = C(f1,f2) let mkD f1 f2 = D(f1,f2) let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1)) let mkI f1 f2 = I(f1,None,f2) let mkformula_binary g term f1 f2 = match f1 , f2 with | X _ , X _ -> X(term) | _ -> g f1 f2 (** * This is the big generic function for formula parsers. *) let parse_formula gl parse_atom env tg term = let parse_atom env tg t = try let (at,env) = parse_atom env t gl in (A(at,tg,t), env,Tag.next tg) with e when CErrors.noncritical e -> (X(t),env,tg) in let is_prop term = let sort = Retyping.get_sort_of (Tacmach.pf_env gl) (Tacmach.project gl) term in Term.is_prop_sort sort in let rec xparse_formula env tg term = match kind_of_term term with | App(l,rst) -> (match rst with | [|a;b|] when eq_constr l (Lazy.force coq_and) -> let f,env,tg = xparse_formula env tg a in let g,env, tg = xparse_formula env tg b in mkformula_binary mkC term f g,env,tg | [|a;b|] when eq_constr l (Lazy.force coq_or) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkD term f g,env,tg | [|a|] when eq_constr l (Lazy.force coq_not) -> let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) | [|a;b|] when eq_constr l (Lazy.force coq_iff) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkIff term f g,env,tg | _ -> parse_atom env tg term) | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b)-> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkI term f g,env,tg | _ when eq_constr term (Lazy.force coq_True) -> (TT,env,tg) | _ when eq_constr term (Lazy.force coq_False) -> (FF,env,tg) | _ when is_prop term -> X(term),env,tg | _ -> raise ParseError in xparse_formula env tg ((*Reductionops.whd_zeta*) term) let dump_formula typ dump_atom f = let rec xdump f = match f with | TT -> mkApp(Lazy.force coq_TT,[|typ|]) | FF -> mkApp(Lazy.force coq_FF,[|typ|]) | C(x,y) -> mkApp(Lazy.force coq_And,[|typ ; xdump x ; xdump y|]) | D(x,y) -> mkApp(Lazy.force coq_Or,[|typ ; xdump x ; xdump y|]) | I(x,_,y) -> mkApp(Lazy.force coq_Impl,[|typ ; xdump x ; xdump y|]) | N(x) -> mkApp(Lazy.force coq_Neg,[|typ ; xdump x|]) | A(x,_,_) -> mkApp(Lazy.force coq_Atom,[|typ ; dump_atom x|]) | X(t) -> mkApp(Lazy.force coq_X,[|typ ; t|]) in xdump f let prop_env_of_formula form = let rec doit env = function | TT | FF | A(_,_,_) -> env | X t -> fst (Env.compute_rank_add env t) | C(f1,f2) | D(f1,f2) | I(f1,_,f2) -> doit (doit env f1) f2 | N f -> doit env f in doit [] form let var_env_of_formula form = let rec vars_of_expr = function | Mc.PEX n -> ISet.singleton (CoqToCaml.positive n) | Mc.PEc z -> ISet.empty | Mc.PEadd(e1,e2) | Mc.PEmul(e1,e2) | Mc.PEsub(e1,e2) -> ISet.union (vars_of_expr e1) (vars_of_expr e2) | Mc.PEopp e | Mc.PEpow(e,_)-> vars_of_expr e in let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} = ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in let rec doit = function | TT | FF | X _ -> ISet.empty | A (a,t,c) -> vars_of_atom a | C(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2) | N f -> doit f in doit form type 'cst dump_expr = (* 'cst is the type of the syntactic constants *) { interp_typ : constr; dump_cst : 'cst -> constr; dump_add : constr; dump_sub : constr; dump_opp : constr; dump_mul : constr; dump_pow : constr; dump_pow_arg : Mc.n -> constr; dump_op : (Mc.op2 * Term.constr) list } let dump_zexpr = lazy { interp_typ = Lazy.force coq_Z; dump_cst = dump_z; dump_add = Lazy.force coq_Zplus; dump_sub = Lazy.force coq_Zminus; dump_opp = Lazy.force coq_Zopp; dump_mul = Lazy.force coq_Zmult; dump_pow = Lazy.force coq_Zpower; dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) zop_table } let dump_qexpr = lazy { interp_typ = Lazy.force coq_Q; dump_cst = dump_q; dump_add = Lazy.force coq_Qplus; dump_sub = Lazy.force coq_Qminus; dump_opp = Lazy.force coq_Qopp; dump_mul = Lazy.force coq_Qmult; dump_pow = Lazy.force coq_Qpower; dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table } let dump_positive_as_R p = let mult = Lazy.force coq_Rmult in let add = Lazy.force coq_Rplus in let one = Lazy.force coq_R1 in let mk_add x y = mkApp(add,[|x;y|]) in let mk_mult x y = mkApp(mult,[|x;y|]) in let two = mk_add one one in let rec dump_positive p = match p with | Mc.XH -> one | Mc.XO p -> mk_mult two (dump_positive p) | Mc.XI p -> mk_add one (mk_mult two (dump_positive p)) in dump_positive p let dump_n_as_R n = let z = CoqToCaml.n n in if z = 0 then Lazy.force coq_R0 else dump_positive_as_R (CamlToCoq.positive z) let rec dump_Rcst_as_R cst = match cst with | Mc.C0 -> Lazy.force coq_R0 | Mc.C1 -> Lazy.force coq_R1 | Mc.CQ q -> Term.mkApp(Lazy.force coq_IQR, [| dump_q q |]) | Mc.CZ z -> Term.mkApp(Lazy.force coq_IZR, [| dump_z z |]) | Mc.CPlus(x,y) -> Term.mkApp(Lazy.force coq_Rplus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) | Mc.CMinus(x,y) -> Term.mkApp(Lazy.force coq_Rminus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) | Mc.CMult(x,y) -> Term.mkApp(Lazy.force coq_Rmult, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) | Mc.CInv t -> Term.mkApp(Lazy.force coq_Rinv, [| dump_Rcst_as_R t |]) | Mc.COpp t -> Term.mkApp(Lazy.force coq_Ropp, [| dump_Rcst_as_R t |]) let dump_rexpr = lazy { interp_typ = Lazy.force coq_R; dump_cst = dump_Rcst_as_R; dump_add = Lazy.force coq_Rplus; dump_sub = Lazy.force coq_Rminus; dump_opp = Lazy.force coq_Ropp; dump_mul = Lazy.force coq_Rmult; dump_pow = Lazy.force coq_Rpower; dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n))); dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table } (** [make_goal_of_formula depxr vars props form] where - vars is an environment for the arithmetic variables occuring in form - props is an environment for the propositions occuring in form @return a goal where all the variables and propositions of the formula are quantified *) let rec make_goal_of_formula dexpr form = let vars_idx = List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) let props = prop_env_of_formula form in let vars_n = List.map (fun (_,i) -> (Names.id_of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in let props_n = List.mapi (fun i _ -> (Names.id_of_string (Printf.sprintf "__p%i" (i+1))) , Term.mkProp) props in let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in let dump_expr i e = let rec dump_expr = function | Mc.PEX n -> mkRel (i+(List.assoc (CoqToCaml.positive n) vars_idx)) | Mc.PEc z -> dexpr.dump_cst z | Mc.PEadd(e1,e2) -> mkApp(dexpr.dump_add, [| dump_expr e1;dump_expr e2|]) | Mc.PEsub(e1,e2) -> mkApp(dexpr.dump_sub, [| dump_expr e1;dump_expr e2|]) | Mc.PEopp e -> mkApp(dexpr.dump_opp, [| dump_expr e|]) | Mc.PEmul(e1,e2) -> mkApp(dexpr.dump_mul, [| dump_expr e1;dump_expr e2|]) | Mc.PEpow(e,n) -> mkApp(dexpr.dump_pow, [| dump_expr e; dexpr.dump_pow_arg n|]) in dump_expr e in let mkop op e1 e2 = try Term.mkApp(List.assoc op dexpr.dump_op, [| e1; e2|]) with Not_found -> Term.mkApp(Lazy.force coq_Eq,[|dexpr.interp_typ ; e1 ;e2|]) in let dump_cstr i { Mc.flhs ; Mc.fop ; Mc.frhs } = mkop fop (dump_expr i flhs) (dump_expr i frhs) in let rec xdump pi xi f = match f with | TT -> Lazy.force coq_True | FF -> Lazy.force coq_False | C(x,y) -> mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) | D(x,y) -> mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) | I(x,_,y) -> mkArrow (xdump pi xi x) (xdump (pi+1) (xi+1) y) | N(x) -> mkArrow (xdump pi xi x) (Lazy.force coq_False) | A(x,_,_) -> dump_cstr xi x | X(t) -> let idx = Env.get_rank props t in mkRel (pi+idx) in let nb_vars = List.length vars_n in let nb_props = List.length props_n in (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) let subst_prop p = let idx = Env.get_rank props p in mkVar (Names.id_of_string (Printf.sprintf "__p%i" idx)) in let form' = map_prop subst_prop form in (Term.prodn nb_props (List.map (fun (x,y) -> Names.Name x,y) props_n) (Term.prodn nb_vars (List.map (fun (x,y) -> Names.Name x,y) vars_n) (xdump (List.length vars_n) 0 form)), List.rev props_n, List.rev var_name_pos,form') (** * Given a conclusion and a list of affectations, rebuild a term prefixed by * the appropriate letins. * TODO: reverse the list of bindings! *) let set l concl = let rec xset acc = function | [] -> acc | (e::l) -> let (name,expr,typ) = e in xset (Term.mkNamedLetIn (Names.Id.of_string name) expr typ acc) l in xset concl l end (** * MODULE END: M *) open M let rec sig_of_cone = function | Mc.PsatzIn n -> [CoqToCaml.nat n] | Mc.PsatzMulE(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) | Mc.PsatzMulC(w1,w2) -> (sig_of_cone w2) | Mc.PsatzAdd(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) | _ -> [] let same_proof sg cl1 cl2 = let rec xsame_proof sg = match sg with | [] -> true | n::sg -> (try Int.equal (List.nth cl1 n) (List.nth cl2 n) with Invalid_argument _ -> false) && (xsame_proof sg ) in xsame_proof sg let tags_of_clause tgs wit clause = let rec xtags tgs = function | Mc.PsatzIn n -> Names.Id.Set.union tgs (snd (List.nth clause (CoqToCaml.nat n) )) | Mc.PsatzMulC(e,w) -> xtags tgs w | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(w1,w2) -> xtags (xtags tgs w1) w2 | _ -> tgs in xtags tgs wit (*let tags_of_cnf wits cnf = List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) Names.Id.Set.empty wits cnf *) let find_witness prover polys1 = try_any prover polys1 let rec witness prover l1 l2 = match l2 with | [] -> Some [] | e :: l2 -> match find_witness prover (e::l1) with | None -> None | Some w -> (match witness prover l1 l2 with | None -> None | Some l -> Some (w::l) ) let rec apply_ids t ids = match ids with | [] -> t | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids let coq_Node = lazy (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") let coq_Leaf = lazy (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") let coq_Empty = lazy (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") let coq_VarMap = lazy (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t") let rec dump_varmap typ m = match m with | Mc.Empty -> Term.mkApp(Lazy.force coq_Empty,[| typ |]) | Mc.Leaf v -> Term.mkApp(Lazy.force coq_Leaf,[| typ; v|]) | Mc.Node(l,o,r) -> Term.mkApp (Lazy.force coq_Node, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) let vm_of_list env = match env with | [] -> Mc.Empty | (d,_)::_ -> List.fold_left (fun vm (c,i) -> Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env let rec pp_varmap o vm = match vm with | Mc.Empty -> output_string o "[]" | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z z | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l pp_z z pp_varmap r let rec dump_proof_term = function | Micromega.DoneProof -> Lazy.force coq_doneProof | Micromega.RatProof(cone,rst) -> Term.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|]) | Micromega.CutProof(cone,prf) -> Term.mkApp(Lazy.force coq_cutProof, [| dump_psatz coq_Z dump_z cone ; dump_proof_term prf|]) | Micromega.EnumProof(c1,c2,prfs) -> Term.mkApp (Lazy.force coq_enumProof, [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) let rec size_of_psatz = function | Micromega.PsatzIn _ -> 1 | Micromega.PsatzSquare _ -> 1 | Micromega.PsatzMulC(_,p) -> 1 + (size_of_psatz p) | Micromega.PsatzMulE(p1,p2) | Micromega.PsatzAdd(p1,p2) -> size_of_psatz p1 + size_of_psatz p2 | Micromega.PsatzC _ -> 1 | Micromega.PsatzZ -> 1 let rec size_of_pf = function | Micromega.DoneProof -> 1 | Micromega.RatProof(p,a) -> (size_of_pf a) + (size_of_psatz p) | Micromega.CutProof(p,a) -> (size_of_pf a) + (size_of_psatz p) | Micromega.EnumProof(p1,p2,l) -> (size_of_psatz p1) + (size_of_psatz p2) + (List.fold_left (fun acc p -> size_of_pf p + acc) 0 l) let dump_proof_term t = if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t) ; dump_proof_term t let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden let rec pp_proof_term o = function | Micromega.DoneProof -> Printf.fprintf o "D" | Micromega.RatProof(cone,rst) -> Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst | Micromega.EnumProof(c1,c2,rst) -> Printf.fprintf o "EP[%a,%a,%a]" (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 (pp_list "[" "]" pp_proof_term) rst let rec parse_hyps gl parse_arith env tg hyps = match hyps with | [] -> ([],env,tg) | (i,t)::l -> let (lhyps,env,tg) = parse_hyps gl parse_arith env tg l in try let (c,env,tg) = parse_formula gl parse_arith env tg t in ((i,c)::lhyps, env,tg) with e when CErrors.noncritical e -> (lhyps,env,tg) (*(if debug then Printf.printf "parse_arith : %s\n" x);*) (*exception ParseError*) let parse_goal gl parse_arith env hyps term = (* try*) let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in (lhyps,f,env) (* with Failure x -> raise ParseError*) (** * The datastructures that aggregate theory-dependent proof values. *) type ('synt_c, 'prf) domain_spec = { typ : Term.constr; (* is the type of the interpretation domain - Z, Q, R*) coeff : Term.constr ; (* is the type of the syntactic coeffs - Z , Q , Rcst *) dump_coeff : 'synt_c -> Term.constr ; proof_typ : Term.constr ; dump_proof : 'prf -> Term.constr } let zz_domain_spec = lazy { typ = Lazy.force coq_Z; coeff = Lazy.force coq_Z; dump_coeff = dump_z ; proof_typ = Lazy.force coq_proofTerm ; dump_proof = dump_proof_term } let qq_domain_spec = lazy { typ = Lazy.force coq_Q; coeff = Lazy.force coq_Q; dump_coeff = dump_q ; proof_typ = Lazy.force coq_QWitness ; dump_proof = dump_psatz coq_Q dump_q } let rcst_domain_spec = lazy { typ = Lazy.force coq_R; coeff = Lazy.force coq_Rcst; dump_coeff = dump_Rcst; proof_typ = Lazy.force coq_QWitness ; dump_proof = dump_psatz coq_Q dump_q } open Proofview.Notations (** Naive topological sort of constr according to the subterm-ordering *) (* An element is minimal x is minimal w.r.t y if x <= y or (x and y are incomparable) *) let is_min le x y = if le x y then true else if le y x then false else true let is_minimal le l c = List.for_all (is_min le c) l let find_rem p l = let rec xfind_rem acc l = match l with | [] -> (None, acc) | x :: l -> if p x then (Some x, acc @ l) else xfind_rem (x::acc) l in xfind_rem [] l let find_minimal le l = find_rem (is_minimal le l) l let rec mk_topo_order le l = match find_minimal le l with | (None , _) -> [] | (Some v,l') -> v :: (mk_topo_order le l') let topo_sort_constr l = mk_topo_order Termops.dependent l (** * Instanciate the current Coq goal with a Micromega formula, a varmap, and a * witness. *) let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) = (* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in let vm = dump_varmap (spec.typ) (vm_of_list env) in (* todo : directly generate the proof term - or generalize before conversion? *) Proofview.Goal.nf_enter { enter = begin fun gl -> let gl = Tacmach.New.of_old (fun x -> x) gl in Tacticals.New.tclTHENLIST [ Tactics.change_concl (set [ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |])); ("__varmap", vm, Term.mkApp(Lazy.force coq_VarMap, [|spec.typ|])); ("__wit", cert, cert_typ) ] (Tacmach.pf_concl gl)) ] end } (** * The datastructures that aggregate prover attributes. *) type ('option,'a,'prf) prover = { name : string ; (* name of the prover *) get_option : unit ->'option ; (* find the options of the prover *) prover : 'option * 'a list -> 'prf option ; (* the prover itself *) hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *) compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *) pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *) pp_f : out_channel -> 'a -> unit (* pretty printing of the formulas (polynomials)*) } (** * Given a list of provers and a disjunction of atoms, find a proof of any of * the atoms. Returns an (optional) pair of a proof and a prover * datastructure. *) let find_witness provers polys1 = let provers = List.map (fun p -> (fun l -> match p.prover (p.get_option (),l) with | None -> None | Some prf -> Some(prf,p)) , p.name) provers in try_any provers (List.map fst polys1) (** * Given a list of provers and a CNF, find a proof for each of the clauses. * Return the proofs as a list. *) let witness_list prover l = let rec xwitness_list l = match l with | [] -> Some [] | e :: l -> match find_witness prover e with | None -> None | Some w -> (match xwitness_list l with | None -> None | Some l -> Some (w :: l) ) in xwitness_list l let witness_list_tags = witness_list (* *Deprecated* let is_singleton = function [] -> true | [e] -> true | _ -> false *) let pp_ml_list pp_elt o l = output_string o "[" ; List.iter (fun x -> Printf.fprintf o "%a ;" pp_elt x) l ; output_string o "]" (** * Prune the proof object, according to the 'diff' between two cnf formulas. *) let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = let new_cl = Mutils.mapi (fun (f,_) i -> (f,i)) new_cl in let remap i = let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in List.assoc formula new_cl in (* if debug then begin Printf.printf "\ncompact_proof : %a %a %a" (pp_ml_list prover.pp_f) (List.map fst old_cl) prover.pp_prf prf (pp_ml_list prover.pp_f) (List.map fst new_cl) ; flush stdout end ; *) let res = try prover.compact prf remap with x when CErrors.noncritical x -> if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; (* This should not happen -- this is the recovery plan... *) match prover.prover (prover.get_option () ,List.map fst new_cl) with | None -> failwith "proof compaction error" | Some p -> p in if debug then begin Printf.printf " -> %a\n" prover.pp_prf res ; flush stdout end ; res in let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = let hyps_idx = prover.hyps prf in let hyps = selecti hyps_idx old_cl in is_sublist Pervasives.(=) hyps new_cl in let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) List.map (fun x -> let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res in compact_proof o p x) cnf_ff' (** * "Hide out" tagged atoms of a formula by transforming them into generic * variables. See the Tag module in mutils.ml for more. *) let abstract_formula hyps f = let rec xabs f = match f with | X c -> X c | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term) | C(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (Term.mkApp(Lazy.force coq_and, [|a1;a2|])) | f1 , f2 -> C(f1,f2) ) | D(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (Term.mkApp(Lazy.force coq_or, [|a1;a2|])) | f1 , f2 -> D(f1,f2) ) | N(f) -> (match xabs f with | X a -> X (Term.mkApp(Lazy.force coq_not, [|a|])) | f -> N f) | I(f1,hyp,f2) -> (match xabs f1 , hyp, xabs f2 with | X a1 , Some _ , af2 -> af2 | X a1 , None , X a2 -> X (Term.mkArrow a1 a2) | af1 , _ , af2 -> I(af1,hyp,af2) ) | FF -> FF | TT -> TT in xabs f (* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2 *) let rec abstract_wrt_formula f1 f2 = match f1 , f2 with | X c , _ -> X c | A _ , A _ -> f2 | C(a,b) , C(a',b') -> C(abstract_wrt_formula a a', abstract_wrt_formula b b') | D(a,b) , D(a',b') -> D(abstract_wrt_formula a a', abstract_wrt_formula b b') | I(a,_,b) , I(a',x,b') -> I(abstract_wrt_formula a a',x, abstract_wrt_formula b b') | FF , FF -> FF | TT , TT -> TT | N x , N y -> N(abstract_wrt_formula x y) | _ -> failwith "abstract_wrt_formula" (** * This exception is raised by really_call_csdpcert if Coq's configure didn't * find a CSDP executable. *) exception CsdpNotFound (** * This is the core of Micromega: apply the prover, analyze the result and * prune unused fomulas, and finally modify the proof state. *) let formula_hyps_concl hyps concl = List.fold_right (fun (id,f) (cc,ids) -> match f with X _ -> (cc,ids) | _ -> (I(f,Some id,cc), id::ids)) hyps (concl,[]) let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 gl = (* Express the goal as one big implication *) let (ff,ids) = formula_hyps_concl polys1 polys2 in (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *) let cnf_ff,cnf_ff_tags = cnf negate normalise unsat deduce ff in if debug then begin Feedback.msg_notice (Pp.str "Formula....\n") ; let formula_typ = (Term.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in let ff = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff in Feedback.msg_notice (Printer.prterm ff); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff end; match witness_list_tags prover cnf_ff with | None -> None | Some res -> (*Printf.printf "\nList %i" (List.length `res); *) let hyps = List.fold_left (fun s (cl,(prf,p)) -> let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty cnf_ff_tags) (List.combine cnf_ff res) in if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; let ff' = abstract_formula hyps ff in let cnf_ff',_ = cnf negate normalise unsat deduce ff' in if debug then begin Feedback.msg_notice (Pp.str "\nAFormula\n") ; let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in let ff' = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff' in Feedback.msg_notice (Printer.prterm ff'); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' end; (* Even if it does not work, this does not mean it is not provable -- the prover is REALLY incomplete *) (* if debug then begin (* recompute the proofs *) match witness_list_tags prover cnf_ff' with | None -> failwith "abstraction is wrong" | Some res -> () end ; *) let res' = compact_proofs cnf_ff res cnf_ff' in let (ff',res',ids) = (ff',res', ids_of_formula ff') in let res' = dump_list (spec.proof_typ) spec.dump_proof res' in Some (ids,ff',res') (** * Parse the proof environment, and call micromega_tauto *) let micromega_gen parse_arith (negate:'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) unsat deduce spec dumpexpr prover tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let gl = Tacmach.New.of_old (fun x -> x) gl in let concl = Tacmach.pf_concl gl in let hyps = Tacmach.pf_hyps_types gl in try let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in let env = Env.elements env in let spec = Lazy.force spec in let dumpexpr = Lazy.force dumpexpr in match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl with | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Some (ids,ff',res') -> let (arith_goal,props,vars,ff_arith) = make_goal_of_formula dumpexpr ff' in let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in let goal_name = Tactics.fresh_id [] (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; micromega_order_change spec res' (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in let goal_props = List.rev (prop_env_of_formula ff') in let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in let arith_args = goal_props @ goal_vars in let kill_arith = Tacticals.New.tclTHEN (Tactics.keep []) ((*Tactics.tclABSTRACT None*) (Tacticals.New.tclTHEN tac_arith tac)) in Tacticals.New.tclTHENS (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) [ kill_arith; (Tacticals.New.tclTHENLIST [(Tactics.generalize (List.map Term.mkVar ids)); Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args)) ] ) ] with | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") | CsdpNotFound -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str (" Skipping what remains of this tactic: the complexity of the goal requires " ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) end } let micromega_gen parse_arith (negate:'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) unsat deduce spec prover = (micromega_gen parse_arith negate normalise unsat deduce spec prover) let micromega_order_changer cert env ff = (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) let coeff = Lazy.force coq_Rcst in let dump_coeff = dump_Rcst in let typ = Lazy.force coq_R in let cert_typ = (Term.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in let vm = dump_varmap (typ) (vm_of_list env) in Proofview.Goal.nf_enter { enter = begin fun gl -> let gl = Tacmach.New.of_old (fun x -> x) gl in Tacticals.New.tclTHENLIST [ (Tactics.change_concl (set [ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |])); ("__varmap", vm, Term.mkApp (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); ("__wit", cert, cert_typ) ] (Tacmach.pf_concl gl))); (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) ] end } let micromega_genr prover tac = let parse_arith = parse_rarith in let negate = Mc.rnegate in let normalise = Mc.rnormalise in let unsat = Mc.runsat in let deduce = Mc.rdeduce in let spec = lazy { typ = Lazy.force coq_R; coeff = Lazy.force coq_Rcst; dump_coeff = dump_q; proof_typ = Lazy.force coq_QWitness ; dump_proof = dump_psatz coq_Q dump_q } in Proofview.Goal.nf_enter { enter = begin fun gl -> let gl = Tacmach.New.of_old (fun x -> x) gl in let concl = Tacmach.pf_concl gl in let hyps = Tacmach.pf_hyps_types gl in try let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in let env = Env.elements env in let spec = Lazy.force spec in let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl with | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Some (ids,ff',res') -> let (ff,ids) = formula_hyps_concl (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in let ff' = abstract_wrt_formula ff' ff in let (arith_goal,props,vars,ff_arith) = make_goal_of_formula (Lazy.force dump_rexpr) ff' in let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in let goal_name = Tactics.fresh_id [] (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; micromega_order_changer res' env' ff_arith ] in let goal_props = List.rev (prop_env_of_formula ff') in let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in let arith_args = goal_props @ goal_vars in let kill_arith = Tacticals.New.tclTHEN (Tactics.keep []) ((*Tactics.tclABSTRACT None*) (Tacticals.New.tclTHEN tac_arith tac)) in Tacticals.New.tclTHENS (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) [ kill_arith; (Tacticals.New.tclTHENLIST [(Tactics.generalize (List.map Term.mkVar ids)); Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args)) ] ) ] with | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") | CsdpNotFound -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str (" Skipping what remains of this tactic: the complexity of the goal requires " ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) end } let micromega_genr prover = (micromega_genr prover) let lift_ratproof prover l = match prover l with | None -> None | Some c -> Some (Mc.RatProof( c,Mc.DoneProof)) type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list type csdp_certificate = S of Sos_types.positivstellensatz option | F of string type provername = string * int option (** * The caching mechanism. *) open Persistent_cache module Cache = PHashtable(struct type t = (provername * micromega_polys) let equal = Pervasives.(=) let hash = Hashtbl.hash end) let csdp_cache = ".csdp.cache" (** * Build the command to call csdpcert, and launch it. This in turn will call * the sos driver to the csdp executable. * Throw CsdpNotFound if Coq isn't aware of any csdp executable. *) let require_csdp = if System.is_in_system_path "csdp" then lazy () else lazy (raise CsdpNotFound) let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option = fun provername poly -> Lazy.force require_csdp; let cmdname = List.fold_left Filename.concat (Envars.coqlib ()) ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in match ((command cmdname [|cmdname|] (provername,poly)) : csdp_certificate) with | F str -> failwith str | S res -> res (** * Check the cache before calling the prover. *) let xcall_csdpcert = Cache.memo csdp_cache (fun (prover,pb) -> really_call_csdpcert prover pb) (** * Prover callback functions. *) let call_csdpcert prover pb = xcall_csdpcert (prover,pb) let rec z_to_q_pol e = match e with | Mc.Pc z -> Mc.Pc {Mc.qnum = z ; Mc.qden = Mc.XH} | Mc.Pinj(p,pol) -> Mc.Pinj(p,z_to_q_pol pol) | Mc.PX(pol1,p,pol2) -> Mc.PX(z_to_q_pol pol1, p, z_to_q_pol pol2) let call_csdpcert_q provername poly = match call_csdpcert provername poly with | None -> None | Some cert -> let cert = Certificate.q_cert_of_pos cert in if Mc.qWeakChecker poly cert then Some cert else ((print_string "buggy certificate") ;None) let call_csdpcert_z provername poly = let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in match call_csdpcert provername l with | None -> None | Some cert -> let cert = Certificate.z_cert_of_pos cert in if Mc.zWeakChecker poly cert then Some cert else ((print_string "buggy certificate" ; flush stdout) ;None) let xhyps_of_cone base acc prf = let rec xtract e acc = match e with | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in if n >= base then ISet.add (n-base) acc else acc | Mc.PsatzMulC(_,c) -> xtract c acc | Mc.PsatzAdd(e1,e2) | Mc.PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in xtract prf acc let hyps_of_cone prf = xhyps_of_cone 0 ISet.empty prf let compact_cone prf f = let np n = CamlToCoq.nat (f (CoqToCaml.nat n)) in let rec xinterp prf = match prf with | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> prf | Mc.PsatzIn n -> Mc.PsatzIn (np n) | Mc.PsatzMulC(e,c) -> Mc.PsatzMulC(e,xinterp c) | Mc.PsatzAdd(e1,e2) -> Mc.PsatzAdd(xinterp e1,xinterp e2) | Mc.PsatzMulE(e1,e2) -> Mc.PsatzMulE(xinterp e1,xinterp e2) in xinterp prf let hyps_of_pt pt = let rec xhyps base pt acc = match pt with | Mc.DoneProof -> acc | Mc.RatProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) | Mc.EnumProof(c1,c2,l) -> let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in List.fold_left (fun s x -> xhyps (base + 1) x s) s l in xhyps 0 pt ISet.empty let hyps_of_pt pt = let res = hyps_of_pt pt in if debug then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res); res let compact_pt pt f = let translate ofset x = if x < ofset then x else (f (x-ofset) + ofset) in let rec compact_pt ofset pt = match pt with | Mc.DoneProof -> Mc.DoneProof | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) | Mc.CutProof(c,pt) -> Mc.CutProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) | Mc.EnumProof(c1,c2,l) -> Mc.EnumProof(compact_cone c1 (translate (ofset)), compact_cone c2 (translate (ofset)), Mc.map (fun x -> compact_pt (ofset+1) x) l) in compact_pt 0 pt (** * Definition of provers. * Instantiates the type ('a,'prf) prover defined above. *) let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) module CacheZ = PHashtable(struct type prover_option = bool * int type t = prover_option * ((Mc.z Mc.pol * Mc.op1) list) let equal = (=) let hash = Hashtbl.hash end) module CacheQ = PHashtable(struct type t = int * ((Mc.q Mc.pol * Mc.op1) list) let equal = (=) let hash = Hashtbl.hash end) let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) let memo_nlia = CacheZ.memo ".nia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s) let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s) let linear_prover_Q = { name = "linear prover"; get_option = get_lra_option ; prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ; hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; pp_f = fun o x -> pp_pol pp_q o (fst x) } let linear_prover_R = { name = "linear prover"; get_option = get_lra_option ; prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ; hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; pp_f = fun o x -> pp_pol pp_q o (fst x) } let nlinear_prover_R = { name = "nra"; get_option = get_lra_option; prover = memo_nra ; hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; pp_f = fun o x -> pp_pol pp_q o (fst x) } let non_linear_prover_Q str o = { name = "real nonlinear prover"; get_option = (fun () -> (str,o)); prover = (fun (o,l) -> call_csdpcert_q o l); hyps = hyps_of_cone; compact = compact_cone ; pp_prf = pp_psatz pp_q ; pp_f = fun o x -> pp_pol pp_q o (fst x) } let non_linear_prover_R str o = { name = "real nonlinear prover"; get_option = (fun () -> (str,o)); prover = (fun (o,l) -> call_csdpcert_q o l); hyps = hyps_of_cone; compact = compact_cone; pp_prf = pp_psatz pp_q; pp_f = fun o x -> pp_pol pp_q o (fst x) } let non_linear_prover_Z str o = { name = "real nonlinear prover"; get_option = (fun () -> (str,o)); prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; pp_f = fun o x -> pp_pol pp_z o (fst x) } let linear_Z = { name = "lia"; get_option = get_lia_option; prover = memo_zlinear_prover ; hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; pp_f = fun o x -> pp_pol pp_z o (fst x) } let nlinear_Z = { name = "nlia"; get_option = get_lia_option; prover = memo_nlia ; hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; pp_f = fun o x -> pp_pol pp_z o (fst x) } let tauto_lia ff = let prover = linear_Z in let cnf_ff,_ = cnf Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce ff in match witness_list_tags [prover] cnf_ff with | None -> None | Some l -> Some (List.map fst l) (** * Functions instantiating micromega_gen with the appropriate theories and * solvers *) let lra_Q = micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr [ linear_prover_Q ] let psatz_Q i = micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] let lra_R = micromega_genr [ linear_prover_R ] let psatz_R i = micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] let psatz_Z i = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] let sos_Z = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr [ non_linear_prover_Z "pure_sos" None ] let sos_Q = micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr [ non_linear_prover_Q "pure_sos" None ] let sos_R = micromega_genr [ non_linear_prover_R "pure_sos" None ] let xlia = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr [ linear_Z ] let xnlia = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr [ nlinear_Z ] let nra = micromega_genr [ nlinear_prover_R ] let nqa = micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr [ nlinear_prover_R ] (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/micromega/micromega_plugin.mlpack0000644000175000017500000000014613022274260021616 0ustar mdenesmdenesSos_types Mutils Micromega Polynomial Mfourier Certificate Persistent_cache Coq_micromega G_micromega coq-8.6/plugins/micromega/vo.itarget0000644000175000017500000000023713022274260017112 0ustar mdenesmdenesEnvRing.vo Env.vo OrderedRing.vo Psatz.vo QMicromega.vo Refl.vo RingMicromega.vo RMicromega.vo Tauto.vo VarMap.vo ZCoeff.vo ZMicromega.vo Lia.vo Lqa.vo Lra.vo coq-8.6/plugins/micromega/micromega.ml0000644000175000017500000014154613022274260017413 0ustar mdenesmdenes(** val negb : bool -> bool **) let negb = function | true -> false | false -> true type nat = | O | S of nat (** val app : 'a1 list -> 'a1 list -> 'a1 list **) let rec app l m = match l with | [] -> m | a::l1 -> a::(app l1 m) type comparison = | Eq | Lt | Gt (** val compOpp : comparison -> comparison **) let compOpp = function | Eq -> Eq | Lt -> Gt | Gt -> Lt module Coq__1 = struct (** val add : nat -> nat -> nat **) let rec add n0 m = match n0 with | O -> m | S p -> S (add p m) end let add = Coq__1.add type positive = | XI of positive | XO of positive | XH type n = | N0 | Npos of positive type z = | Z0 | Zpos of positive | Zneg of positive module Pos = struct type mask = | IsNul | IsPos of positive | IsNeg end module Coq_Pos = struct (** val succ : positive -> positive **) let rec succ = function | XI p -> XO (succ p) | XO p -> XI p | XH -> XO XH (** val add : positive -> positive -> positive **) let rec add x y = match x with | XI p -> (match y with | XI q0 -> XO (add_carry p q0) | XO q0 -> XI (add p q0) | XH -> XO (succ p)) | XO p -> (match y with | XI q0 -> XI (add p q0) | XO q0 -> XO (add p q0) | XH -> XI p) | XH -> (match y with | XI q0 -> XO (succ q0) | XO q0 -> XI q0 | XH -> XO XH) (** val add_carry : positive -> positive -> positive **) and add_carry x y = match x with | XI p -> (match y with | XI q0 -> XI (add_carry p q0) | XO q0 -> XO (add_carry p q0) | XH -> XI (succ p)) | XO p -> (match y with | XI q0 -> XO (add_carry p q0) | XO q0 -> XI (add p q0) | XH -> XO (succ p)) | XH -> (match y with | XI q0 -> XI (succ q0) | XO q0 -> XO (succ q0) | XH -> XI XH) (** val pred_double : positive -> positive **) let rec pred_double = function | XI p -> XI (XO p) | XO p -> XI (pred_double p) | XH -> XH type mask = Pos.mask = | IsNul | IsPos of positive | IsNeg (** val succ_double_mask : mask -> mask **) let succ_double_mask = function | IsNul -> IsPos XH | IsPos p -> IsPos (XI p) | IsNeg -> IsNeg (** val double_mask : mask -> mask **) let double_mask = function | IsPos p -> IsPos (XO p) | x0 -> x0 (** val double_pred_mask : positive -> mask **) let double_pred_mask = function | XI p -> IsPos (XO (XO p)) | XO p -> IsPos (XO (pred_double p)) | XH -> IsNul (** val sub_mask : positive -> positive -> mask **) let rec sub_mask x y = match x with | XI p -> (match y with | XI q0 -> double_mask (sub_mask p q0) | XO q0 -> succ_double_mask (sub_mask p q0) | XH -> IsPos (XO p)) | XO p -> (match y with | XI q0 -> succ_double_mask (sub_mask_carry p q0) | XO q0 -> double_mask (sub_mask p q0) | XH -> IsPos (pred_double p)) | XH -> (match y with | XH -> IsNul | _ -> IsNeg) (** val sub_mask_carry : positive -> positive -> mask **) and sub_mask_carry x y = match x with | XI p -> (match y with | XI q0 -> succ_double_mask (sub_mask_carry p q0) | XO q0 -> double_mask (sub_mask p q0) | XH -> IsPos (pred_double p)) | XO p -> (match y with | XI q0 -> double_mask (sub_mask_carry p q0) | XO q0 -> succ_double_mask (sub_mask_carry p q0) | XH -> double_pred_mask p) | XH -> IsNeg (** val sub : positive -> positive -> positive **) let sub x y = match sub_mask x y with | IsPos z0 -> z0 | _ -> XH (** val mul : positive -> positive -> positive **) let rec mul x y = match x with | XI p -> add y (XO (mul p y)) | XO p -> XO (mul p y) | XH -> y (** val size_nat : positive -> nat **) let rec size_nat = function | XI p2 -> S (size_nat p2) | XO p2 -> S (size_nat p2) | XH -> S O (** val compare_cont : comparison -> positive -> positive -> comparison **) let rec compare_cont r x y = match x with | XI p -> (match y with | XI q0 -> compare_cont r p q0 | XO q0 -> compare_cont Gt p q0 | XH -> Gt) | XO p -> (match y with | XI q0 -> compare_cont Lt p q0 | XO q0 -> compare_cont r p q0 | XH -> Gt) | XH -> (match y with | XH -> r | _ -> Lt) (** val compare : positive -> positive -> comparison **) let compare = compare_cont Eq (** val gcdn : nat -> positive -> positive -> positive **) let rec gcdn n0 a b = match n0 with | O -> XH | S n1 -> (match a with | XI a' -> (match b with | XI b' -> (match compare a' b' with | Eq -> a | Lt -> gcdn n1 (sub b' a') a | Gt -> gcdn n1 (sub a' b') b) | XO b0 -> gcdn n1 a b0 | XH -> XH) | XO a0 -> (match b with | XI _ -> gcdn n1 a0 b | XO b0 -> XO (gcdn n1 a0 b0) | XH -> XH) | XH -> XH) (** val gcd : positive -> positive -> positive **) let gcd a b = gcdn (Coq__1.add (size_nat a) (size_nat b)) a b (** val of_succ_nat : nat -> positive **) let rec of_succ_nat = function | O -> XH | S x -> succ (of_succ_nat x) end module N = struct (** val of_nat : nat -> n **) let of_nat = function | O -> N0 | S n' -> Npos (Coq_Pos.of_succ_nat n') end (** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) let rec pow_pos rmul x = function | XI i0 -> let p = pow_pos rmul x i0 in rmul x (rmul p p) | XO i0 -> let p = pow_pos rmul x i0 in rmul p p | XH -> x (** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) let rec nth n0 l default = match n0 with | O -> (match l with | [] -> default | x::_ -> x) | S m -> (match l with | [] -> default | _::t0 -> nth m t0 default) (** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) let rec map f = function | [] -> [] | a::t0 -> (f a)::(map f t0) (** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) let rec fold_right f a0 = function | [] -> a0 | b::t0 -> f b (fold_right f a0 t0) module Z = struct (** val double : z -> z **) let double = function | Z0 -> Z0 | Zpos p -> Zpos (XO p) | Zneg p -> Zneg (XO p) (** val succ_double : z -> z **) let succ_double = function | Z0 -> Zpos XH | Zpos p -> Zpos (XI p) | Zneg p -> Zneg (Coq_Pos.pred_double p) (** val pred_double : z -> z **) let pred_double = function | Z0 -> Zneg XH | Zpos p -> Zpos (Coq_Pos.pred_double p) | Zneg p -> Zneg (XI p) (** val pos_sub : positive -> positive -> z **) let rec pos_sub x y = match x with | XI p -> (match y with | XI q0 -> double (pos_sub p q0) | XO q0 -> succ_double (pos_sub p q0) | XH -> Zpos (XO p)) | XO p -> (match y with | XI q0 -> pred_double (pos_sub p q0) | XO q0 -> double (pos_sub p q0) | XH -> Zpos (Coq_Pos.pred_double p)) | XH -> (match y with | XI q0 -> Zneg (XO q0) | XO q0 -> Zneg (Coq_Pos.pred_double q0) | XH -> Z0) (** val add : z -> z -> z **) let add x y = match x with | Z0 -> y | Zpos x' -> (match y with | Z0 -> x | Zpos y' -> Zpos (Coq_Pos.add x' y') | Zneg y' -> pos_sub x' y') | Zneg x' -> (match y with | Z0 -> x | Zpos y' -> pos_sub y' x' | Zneg y' -> Zneg (Coq_Pos.add x' y')) (** val opp : z -> z **) let opp = function | Z0 -> Z0 | Zpos x0 -> Zneg x0 | Zneg x0 -> Zpos x0 (** val sub : z -> z -> z **) let sub m n0 = add m (opp n0) (** val mul : z -> z -> z **) let mul x y = match x with | Z0 -> Z0 | Zpos x' -> (match y with | Z0 -> Z0 | Zpos y' -> Zpos (Coq_Pos.mul x' y') | Zneg y' -> Zneg (Coq_Pos.mul x' y')) | Zneg x' -> (match y with | Z0 -> Z0 | Zpos y' -> Zneg (Coq_Pos.mul x' y') | Zneg y' -> Zpos (Coq_Pos.mul x' y')) (** val compare : z -> z -> comparison **) let compare x y = match x with | Z0 -> (match y with | Z0 -> Eq | Zpos _ -> Lt | Zneg _ -> Gt) | Zpos x' -> (match y with | Zpos y' -> Coq_Pos.compare x' y' | _ -> Gt) | Zneg x' -> (match y with | Zneg y' -> compOpp (Coq_Pos.compare x' y') | _ -> Lt) (** val leb : z -> z -> bool **) let leb x y = match compare x y with | Gt -> false | _ -> true (** val ltb : z -> z -> bool **) let ltb x y = match compare x y with | Lt -> true | _ -> false (** val gtb : z -> z -> bool **) let gtb x y = match compare x y with | Gt -> true | _ -> false (** val max : z -> z -> z **) let max n0 m = match compare n0 m with | Lt -> m | _ -> n0 (** val abs : z -> z **) let abs = function | Zneg p -> Zpos p | x -> x (** val to_N : z -> n **) let to_N = function | Zpos p -> Npos p | _ -> N0 (** val pos_div_eucl : positive -> z -> z * z **) let rec pos_div_eucl a b = match a with | XI a' -> let q0,r = pos_div_eucl a' b in let r' = add (mul (Zpos (XO XH)) r) (Zpos XH) in if ltb r' b then (mul (Zpos (XO XH)) q0),r' else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) | XO a' -> let q0,r = pos_div_eucl a' b in let r' = mul (Zpos (XO XH)) r in if ltb r' b then (mul (Zpos (XO XH)) q0),r' else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) | XH -> if leb (Zpos (XO XH)) b then Z0,(Zpos XH) else (Zpos XH),Z0 (** val div_eucl : z -> z -> z * z **) let div_eucl a b = match a with | Z0 -> Z0,Z0 | Zpos a' -> (match b with | Z0 -> Z0,Z0 | Zpos _ -> pos_div_eucl a' b | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in (match r with | Z0 -> (opp q0),Z0 | _ -> (opp (add q0 (Zpos XH))),(add b r))) | Zneg a' -> (match b with | Z0 -> Z0,Z0 | Zpos _ -> let q0,r = pos_div_eucl a' b in (match r with | Z0 -> (opp q0),Z0 | _ -> (opp (add q0 (Zpos XH))),(sub b r)) | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in q0,(opp r)) (** val div : z -> z -> z **) let div a b = let q0,_ = div_eucl a b in q0 (** val gcd : z -> z -> z **) let gcd a b = match a with | Z0 -> abs b | Zpos a0 -> (match b with | Z0 -> abs a | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) | Zneg a0 -> (match b with | Z0 -> abs a | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) end (** val zeq_bool : z -> z -> bool **) let zeq_bool x y = match Z.compare x y with | Eq -> true | _ -> false type 'c pol = | Pc of 'c | Pinj of positive * 'c pol | PX of 'c pol * positive * 'c pol (** val p0 : 'a1 -> 'a1 pol **) let p0 cO = Pc cO (** val p1 : 'a1 -> 'a1 pol **) let p1 cI = Pc cI (** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **) let rec peq ceqb p p' = match p with | Pc c -> (match p' with | Pc c' -> ceqb c c' | _ -> false) | Pinj (j, q0) -> (match p' with | Pinj (j', q') -> (match Coq_Pos.compare j j' with | Eq -> peq ceqb q0 q' | _ -> false) | _ -> false) | PX (p2, i, q0) -> (match p' with | PX (p'0, i', q') -> (match Coq_Pos.compare i i' with | Eq -> if peq ceqb p2 p'0 then peq ceqb q0 q' else false | _ -> false) | _ -> false) (** val mkPinj : positive -> 'a1 pol -> 'a1 pol **) let mkPinj j p = match p with | Pc _ -> p | Pinj (j', q0) -> Pinj ((Coq_Pos.add j j'), q0) | PX (_, _, _) -> Pinj (j, p) (** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) let mkPinj_pred j p = match j with | XI j0 -> Pinj ((XO j0), p) | XO j0 -> Pinj ((Coq_Pos.pred_double j0), p) | XH -> p (** val mkPX : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let mkPX cO ceqb p i q0 = match p with | Pc c -> if ceqb c cO then mkPinj XH q0 else PX (p, i, q0) | Pinj (_, _) -> PX (p, i, q0) | PX (p', i', q') -> if peq ceqb q' (p0 cO) then PX (p', (Coq_Pos.add i' i), q0) else PX (p, i, q0) (** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **) let mkXi cO cI i = PX ((p1 cI), i, (p0 cO)) (** val mkX : 'a1 -> 'a1 -> 'a1 pol **) let mkX cO cI = mkXi cO cI XH (** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) let rec popp copp = function | Pc c -> Pc (copp c) | Pinj (j, q0) -> Pinj (j, (popp copp q0)) | PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0)) (** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) let rec paddC cadd p c = match p with | Pc c1 -> Pc (cadd c1 c) | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c)) | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c)) (** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) let rec psubC csub p c = match p with | Pc c1 -> Pc (csub c1 c) | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c)) | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c)) (** val paddI : ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec paddI cadd pop q0 j = function | Pc c -> mkPinj j (paddC cadd q0 c) | Pinj (j', q') -> (match Z.pos_sub j' j with | Z0 -> mkPinj j (pop q' q0) | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0) | Zneg k -> mkPinj j' (paddI cadd pop q0 k q')) | PX (p2, i, q') -> (match j with | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q')) | XO j0 -> PX (p2, i, (paddI cadd pop q0 (Coq_Pos.pred_double j0) q')) | XH -> PX (p2, i, (pop q' q0))) (** val psubI : ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec psubI cadd copp pop q0 j = function | Pc c -> mkPinj j (paddC cadd (popp copp q0) c) | Pinj (j', q') -> (match Z.pos_sub j' j with | Z0 -> mkPinj j (pop q' q0) | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0) | Zneg k -> mkPinj j' (psubI cadd copp pop q0 k q')) | PX (p2, i, q') -> (match j with | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q')) | XO j0 -> PX (p2, i, (psubI cadd copp pop q0 (Coq_Pos.pred_double j0) q')) | XH -> PX (p2, i, (pop q' q0))) (** val paddX : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec paddX cO ceqb pop p' i' p = match p with | Pc _ -> PX (p', i', p) | Pinj (j, q') -> (match j with | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) | XO j0 -> PX (p', i', (Pinj ((Coq_Pos.pred_double j0), q'))) | XH -> PX (p', i', q')) | PX (p2, i, q') -> (match Z.pos_sub i i' with | Z0 -> mkPX cO ceqb (pop p2 p') i q' | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q') (** val psubX : 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec psubX cO copp ceqb pop p' i' p = match p with | Pc _ -> PX ((popp copp p'), i', p) | Pinj (j, q') -> (match j with | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q'))) | XO j0 -> PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q'))) | XH -> PX ((popp copp p'), i', q')) | PX (p2, i, q') -> (match Z.pos_sub i i' with | Z0 -> mkPX cO ceqb (pop p2 p') i q' | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q') (** val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let rec padd cO cadd ceqb p = function | Pc c' -> paddC cadd p c' | Pinj (j', q') -> paddI cadd (padd cO cadd ceqb) q' j' p | PX (p'0, i', q') -> (match p with | Pc c -> PX (p'0, i', (paddC cadd q' c)) | Pinj (j, q0) -> (match j with | XI j0 -> PX (p'0, i', (padd cO cadd ceqb (Pinj ((XO j0), q0)) q')) | XO j0 -> PX (p'0, i', (padd cO cadd ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q')) | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q'))) | PX (p2, i, q0) -> (match Z.pos_sub i i' with | Z0 -> mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i (padd cO cadd ceqb q0 q') | Zpos k -> mkPX cO ceqb (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i' (padd cO cadd ceqb q0 q') | Zneg k -> mkPX cO ceqb (paddX cO ceqb (padd cO cadd ceqb) p'0 k p2) i (padd cO cadd ceqb q0 q'))) (** val psub : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let rec psub cO cadd csub copp ceqb p = function | Pc c' -> psubC csub p c' | Pinj (j', q') -> psubI cadd copp (psub cO cadd csub copp ceqb) q' j' p | PX (p'0, i', q') -> (match p with | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c)) | Pinj (j, q0) -> (match j with | XI j0 -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q')) | XO j0 -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q')) | XH -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q'))) | PX (p2, i, q0) -> (match Z.pos_sub i i' with | Z0 -> mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i (psub cO cadd csub copp ceqb q0 q') | Zpos k -> mkPX cO ceqb (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) i' (psub cO cadd csub copp ceqb q0 q') | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb (psub cO cadd csub copp ceqb) p'0 k p2) i (psub cO cadd csub copp ceqb q0 q'))) (** val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol **) let rec pmulC_aux cO cmul ceqb p c = match p with | Pc c' -> Pc (cmul c' c) | Pinj (j, q0) -> mkPinj j (pmulC_aux cO cmul ceqb q0 c) | PX (p2, i, q0) -> mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i (pmulC_aux cO cmul ceqb q0 c) (** val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol **) let pmulC cO cI cmul ceqb p c = if ceqb c cO then p0 cO else if ceqb c cI then p else pmulC_aux cO cmul ceqb p c (** val pmulI : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec pmulI cO cI cmul ceqb pmul0 q0 j = function | Pc c -> mkPinj j (pmulC cO cI cmul ceqb q0 c) | Pinj (j', q') -> (match Z.pos_sub j' j with | Z0 -> mkPinj j (pmul0 q' q0) | Zpos k -> mkPinj j (pmul0 (Pinj (k, q')) q0) | Zneg k -> mkPinj j' (pmulI cO cI cmul ceqb pmul0 q0 k q')) | PX (p', i', q') -> (match j with | XI j' -> mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q') | XO j' -> mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' (pmulI cO cI cmul ceqb pmul0 q0 (Coq_Pos.pred_double j') q') | XH -> mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' (pmul0 q' q0)) (** val pmul : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with | Pc c -> pmulC cO cI cmul ceqb p c | Pinj (j', q') -> pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p | PX (p', i', q') -> (match p with | Pc c -> pmulC cO cI cmul ceqb p'' c | Pinj (j, q0) -> let qQ' = match j with | XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q' | XO j0 -> pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q' | XH -> pmul cO cI cadd cmul ceqb q0 q' in mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' qQ' | PX (p2, i, q0) -> let qQ' = pmul cO cI cadd cmul ceqb q0 q' in let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 in let qP' = pmul cO cI cadd cmul ceqb (mkPinj XH q0) p' in let pP' = pmul cO cI cadd cmul ceqb p2 p' in padd cO cadd ceqb (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') i' (p0 cO)) (mkPX cO ceqb pQ' i qQ')) (** val psquare : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol **) let rec psquare cO cI cadd cmul ceqb = function | Pc c -> Pc (cmul c c) | Pinj (j, q0) -> Pinj (j, (psquare cO cI cadd cmul ceqb q0)) | PX (p2, i, q0) -> let twoPQ = pmul cO cI cadd cmul ceqb p2 (mkPinj XH (pmulC cO cI cmul ceqb q0 (cadd cI cI))) in let q2 = psquare cO cI cadd cmul ceqb q0 in let p3 = psquare cO cI cadd cmul ceqb p2 in mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb p3 i (p0 cO)) twoPQ) i q2 type 'c pExpr = | PEc of 'c | PEX of positive | PEadd of 'c pExpr * 'c pExpr | PEsub of 'c pExpr * 'c pExpr | PEmul of 'c pExpr * 'c pExpr | PEopp of 'c pExpr | PEpow of 'c pExpr * n (** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **) let mk_X cO cI j = mkPinj_pred j (mkX cO cI) (** val ppow_pos : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol **) let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function | XI p3 -> subst_l (pmul cO cI cadd cmul ceqb (ppow_pos cO cI cadd cmul ceqb subst_l (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p) | XO p3 -> ppow_pos cO cI cadd cmul ceqb subst_l (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3 | XH -> subst_l (pmul cO cI cadd cmul ceqb res p) (** val ppow_N : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **) let ppow_N cO cI cadd cmul ceqb subst_l p = function | N0 -> p1 cI | Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2 (** val norm_aux : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) let rec norm_aux cO cI cadd cmul csub copp ceqb = function | PEc c -> Pc c | PEX j -> mk_X cO cI j | PEadd (pe1, pe2) -> (match pe1 with | PEopp pe3 -> psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe2) (norm_aux cO cI cadd cmul csub copp ceqb pe3) | _ -> (match pe2 with | PEopp pe3 -> psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) (norm_aux cO cI cadd cmul csub copp ceqb pe3) | _ -> padd cO cadd ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) (norm_aux cO cI cadd cmul csub copp ceqb pe2))) | PEsub (pe1, pe2) -> psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) (norm_aux cO cI cadd cmul csub copp ceqb pe2) | PEmul (pe1, pe2) -> pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) (norm_aux cO cI cadd cmul csub copp ceqb pe2) | PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1) | PEpow (pe1, n0) -> ppow_N cO cI cadd cmul ceqb (fun p -> p) (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 type 'a bFormula = | TT | FF | X | A of 'a | Cj of 'a bFormula * 'a bFormula | D of 'a bFormula * 'a bFormula | N of 'a bFormula | I of 'a bFormula * 'a bFormula (** val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula **) let rec map_bformula fct = function | TT -> TT | FF -> FF | X -> X | A a -> A (fct a) | Cj (f1, f2) -> Cj ((map_bformula fct f1), (map_bformula fct f2)) | D (f1, f2) -> D ((map_bformula fct f1), (map_bformula fct f2)) | N f0 -> N (map_bformula fct f0) | I (f1, f2) -> I ((map_bformula fct f1), (map_bformula fct f2)) type 'x clause = 'x list type 'x cnf = 'x clause list (** val tt : 'a1 cnf **) let tt = [] (** val ff : 'a1 cnf **) let ff = []::[] (** val add_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 clause option **) let rec add_term unsat deduce t0 = function | [] -> (match deduce t0 t0 with | Some u -> if unsat u then None else Some (t0::[]) | None -> Some (t0::[])) | t'::cl0 -> (match deduce t0 t' with | Some u -> if unsat u then None else (match add_term unsat deduce t0 cl0 with | Some cl' -> Some (t'::cl') | None -> None) | None -> (match add_term unsat deduce t0 cl0 with | Some cl' -> Some (t'::cl') | None -> None)) (** val or_clause : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> 'a1 clause option **) let rec or_clause unsat deduce cl1 cl2 = match cl1 with | [] -> Some cl2 | t0::cl -> (match add_term unsat deduce t0 cl2 with | Some cl' -> or_clause unsat deduce cl cl' | None -> None) (** val or_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 cnf **) let or_clause_cnf unsat deduce t0 f = fold_right (fun e acc -> match or_clause unsat deduce t0 e with | Some cl -> cl::acc | None -> acc) [] f (** val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) let rec or_cnf unsat deduce f f' = match f with | [] -> tt | e::rst -> app (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') (** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) let and_cnf f1 f2 = app f1 f2 (** val xcnf : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) let rec xcnf unsat deduce normalise0 negate0 pol0 = function | TT -> if pol0 then tt else ff | FF -> if pol0 then ff else tt | X -> ff | A x -> if pol0 then normalise0 x else negate0 x | Cj (e1, e2) -> if pol0 then and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) else or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) | D (e1, e2) -> if pol0 then or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) else and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) | N e -> xcnf unsat deduce normalise0 negate0 (negb pol0) e | I (e1, e2) -> if pol0 then or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) else and_cnf (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) (** val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **) let rec cnf_checker checker f l = match f with | [] -> true | e::f0 -> (match l with | [] -> false | c::l0 -> if checker e c then cnf_checker checker f0 l0 else false) (** val tauto_checker : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool **) let tauto_checker unsat deduce normalise0 negate0 checker f w = cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w (** val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) let cneqb ceqb x y = negb (ceqb x y) (** val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) let cltb ceqb cleb x y = (&&) (cleb x y) (cneqb ceqb x y) type 'c polC = 'c pol type op1 = | Equal | NonEqual | Strict | NonStrict type 'c nFormula = 'c polC * op1 (** val opMult : op1 -> op1 -> op1 option **) let opMult o o' = match o with | Equal -> Some Equal | NonEqual -> (match o' with | Equal -> Some Equal | NonEqual -> Some NonEqual | _ -> None) | Strict -> (match o' with | NonEqual -> None | _ -> Some o') | NonStrict -> (match o' with | Equal -> Some Equal | NonEqual -> None | _ -> Some NonStrict) (** val opAdd : op1 -> op1 -> op1 option **) let opAdd o o' = match o with | Equal -> Some o' | NonEqual -> (match o' with | Equal -> Some NonEqual | _ -> None) | Strict -> (match o' with | NonEqual -> None | _ -> Some Strict) | NonStrict -> (match o' with | Equal -> Some NonStrict | NonEqual -> None | x -> Some x) type 'c psatz = | PsatzIn of nat | PsatzSquare of 'c polC | PsatzMulC of 'c polC * 'c psatz | PsatzMulE of 'c psatz * 'c psatz | PsatzAdd of 'c psatz * 'c psatz | PsatzC of 'c | PsatzZ (** val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option **) let map_option f = function | Some x -> f x | None -> None (** val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option **) let map_option2 f o o' = match o with | Some x -> (match o' with | Some x' -> f x x' | None -> None) | None -> None (** val pexpr_times_nformula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **) let pexpr_times_nformula cO cI cplus ctimes ceqb e = function | ef,o -> (match o with | Equal -> Some ((pmul cO cI cplus ctimes ceqb e ef),Equal) | _ -> None) (** val nformula_times_nformula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 = let e1,o1 = f1 in let e2,o2 = f2 in map_option (fun x -> Some ((pmul cO cI cplus ctimes ceqb e1 e2),x)) (opMult o1 o2) (** val nformula_plus_nformula : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) let nformula_plus_nformula cO cplus ceqb f1 f2 = let e1,o1 = f1 in let e2,o2 = f2 in map_option (fun x -> Some ((padd cO cplus ceqb e1 e2),x)) (opAdd o1 o2) (** val eval_Psatz : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option **) let rec eval_Psatz cO cI cplus ctimes ceqb cleb l = function | PsatzIn n0 -> Some (nth n0 l ((Pc cO),Equal)) | PsatzSquare e0 -> Some ((psquare cO cI cplus ctimes ceqb e0),NonStrict) | PsatzMulC (re, e0) -> map_option (pexpr_times_nformula cO cI cplus ctimes ceqb re) (eval_Psatz cO cI cplus ctimes ceqb cleb l e0) | PsatzMulE (f1, f2) -> map_option2 (nformula_times_nformula cO cI cplus ctimes ceqb) (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) | PsatzAdd (f1, f2) -> map_option2 (nformula_plus_nformula cO cplus ceqb) (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) | PsatzC c -> if cltb ceqb cleb cO c then Some ((Pc c),Strict) else None | PsatzZ -> Some ((Pc cO),Equal) (** val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool **) let check_inconsistent cO ceqb cleb = function | e,op -> (match e with | Pc c -> (match op with | Equal -> cneqb ceqb c cO | NonEqual -> ceqb c cO | Strict -> cleb c cO | NonStrict -> cltb ceqb cleb c cO) | _ -> false) (** val check_normalised_formulas : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool **) let check_normalised_formulas cO cI cplus ctimes ceqb cleb l cm = match eval_Psatz cO cI cplus ctimes ceqb cleb l cm with | Some f -> check_inconsistent cO ceqb cleb f | None -> false type op2 = | OpEq | OpNEq | OpLe | OpGe | OpLt | OpGt type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } (** val norm : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) let norm cO cI cplus ctimes cminus copp ceqb = norm_aux cO cI cplus ctimes cminus copp ceqb (** val psub0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let psub0 cO cplus cminus copp ceqb = psub cO cplus cminus copp ceqb (** val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let padd0 cO cplus ceqb = padd cO cplus ceqb (** val xnormalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list **) let xnormalise cO cI cplus ctimes cminus copp ceqb t0 = let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in (match o with | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[]) | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] | OpLe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[] | OpGe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[] | OpLt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict)::[] | OpGt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[]) (** val cnf_normalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula cnf **) let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 = map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t0) (** val xnegate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list **) let xnegate cO cI cplus ctimes cminus copp ceqb t0 = let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in (match o with | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[]) | OpLe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[] | OpGe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict)::[] | OpLt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[] | OpGt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[]) (** val cnf_negate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula cnf **) let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 = map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0) (** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) let rec xdenorm jmp = function | Pc c -> PEc c | Pinj (j, p2) -> xdenorm (Coq_Pos.add j jmp) p2 | PX (p2, j, q0) -> PEadd ((PEmul ((xdenorm jmp p2), (PEpow ((PEX jmp), (Npos j))))), (xdenorm (Coq_Pos.succ jmp) q0)) (** val denorm : 'a1 pol -> 'a1 pExpr **) let denorm p = xdenorm XH p (** val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr **) let rec map_PExpr c_of_S = function | PEc c -> PEc (c_of_S c) | PEX p -> PEX p | PEadd (e1, e2) -> PEadd ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) | PEsub (e1, e2) -> PEsub ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) | PEmul (e1, e2) -> PEmul ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) | PEopp e0 -> PEopp (map_PExpr c_of_S e0) | PEpow (e0, n0) -> PEpow ((map_PExpr c_of_S e0), n0) (** val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula **) let map_Formula c_of_S f = let { flhs = l; fop = o; frhs = r } = f in { flhs = (map_PExpr c_of_S l); fop = o; frhs = (map_PExpr c_of_S r) } (** val simpl_cone : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz **) let simpl_cone cO cI ctimes ceqb e = match e with | PsatzSquare t0 -> (match t0 with | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c) | _ -> PsatzSquare t0) | PsatzMulE (t1, t2) -> (match t1 with | PsatzMulE (x, x0) -> (match x with | PsatzC p2 -> (match t2 with | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x0) | PsatzZ -> PsatzZ | _ -> e) | _ -> (match x0 with | PsatzC p2 -> (match t2 with | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x) | PsatzZ -> PsatzZ | _ -> e) | _ -> (match t2 with | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) | PsatzZ -> PsatzZ | _ -> e))) | PsatzC c -> (match t2 with | PsatzMulE (x, x0) -> (match x with | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x0) | _ -> (match x0 with | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x) | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2))) | PsatzAdd (y, z0) -> PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c), z0))) | PsatzC c0 -> PsatzC (ctimes c c0) | PsatzZ -> PsatzZ | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2)) | PsatzZ -> PsatzZ | _ -> (match t2 with | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) | PsatzZ -> PsatzZ | _ -> e)) | PsatzAdd (t1, t2) -> (match t1 with | PsatzZ -> t2 | _ -> (match t2 with | PsatzZ -> t1 | _ -> PsatzAdd (t1, t2))) | _ -> e type q = { qnum : z; qden : positive } (** val qnum : q -> z **) let qnum x = x.qnum (** val qden : q -> positive **) let qden x = x.qden (** val qeq_bool : q -> q -> bool **) let qeq_bool x y = zeq_bool (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) (** val qle_bool : q -> q -> bool **) let qle_bool x y = Z.leb (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) (** val qplus : q -> q -> q **) let qplus x y = { qnum = (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden))); qden = (Coq_Pos.mul x.qden y.qden) } (** val qmult : q -> q -> q **) let qmult x y = { qnum = (Z.mul x.qnum y.qnum); qden = (Coq_Pos.mul x.qden y.qden) } (** val qopp : q -> q **) let qopp x = { qnum = (Z.opp x.qnum); qden = x.qden } (** val qminus : q -> q -> q **) let qminus x y = qplus x (qopp y) (** val qinv : q -> q **) let qinv x = match x.qnum with | Z0 -> { qnum = Z0; qden = XH } | Zpos p -> { qnum = (Zpos x.qden); qden = p } | Zneg p -> { qnum = (Zneg x.qden); qden = p } (** val qpower_positive : q -> positive -> q **) let qpower_positive = pow_pos qmult (** val qpower : q -> z -> q **) let qpower q0 = function | Z0 -> { qnum = (Zpos XH); qden = XH } | Zpos p -> qpower_positive q0 p | Zneg p -> qinv (qpower_positive q0 p) type 'a t = | Empty | Leaf of 'a | Node of 'a t * 'a * 'a t (** val find : 'a1 -> 'a1 t -> positive -> 'a1 **) let rec find default vm p = match vm with | Empty -> default | Leaf i -> i | Node (l, e, r) -> (match p with | XI p2 -> find default r p2 | XO p2 -> find default l p2 | XH -> e) (** val singleton : 'a1 -> positive -> 'a1 -> 'a1 t **) let rec singleton default x v = match x with | XI p -> Node (Empty, default, (singleton default p v)) | XO p -> Node ((singleton default p v), default, Empty) | XH -> Leaf v (** val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t **) let rec vm_add default x v = function | Empty -> singleton default x v | Leaf vl -> (match x with | XI p -> Node (Empty, vl, (singleton default p v)) | XO p -> Node ((singleton default p v), vl, Empty) | XH -> Leaf v) | Node (l, o, r) -> (match x with | XI p -> Node (l, o, (vm_add default p v r)) | XO p -> Node ((vm_add default p v l), o, r) | XH -> Node (l, v, r)) type zWitness = z psatz (** val zWeakChecker : z nFormula list -> z psatz -> bool **) let zWeakChecker = check_normalised_formulas Z0 (Zpos XH) Z.add Z.mul zeq_bool Z.leb (** val psub1 : z pol -> z pol -> z pol **) let psub1 = psub0 Z0 Z.add Z.sub Z.opp zeq_bool (** val padd1 : z pol -> z pol -> z pol **) let padd1 = padd0 Z0 Z.add zeq_bool (** val norm0 : z pExpr -> z pol **) let norm0 = norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp zeq_bool (** val xnormalise0 : z formula -> z nFormula list **) let xnormalise0 t0 = let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = norm0 lhs in let rhs0 = norm0 rhs in (match o with | OpEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[]) | OpNEq -> ((psub1 lhs0 rhs0),Equal)::[] | OpLe -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[] | OpGe -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] | OpLt -> ((psub1 lhs0 rhs0),NonStrict)::[] | OpGt -> ((psub1 rhs0 lhs0),NonStrict)::[]) (** val normalise : z formula -> z nFormula cnf **) let normalise t0 = map (fun x -> x::[]) (xnormalise0 t0) (** val xnegate0 : z formula -> z nFormula list **) let xnegate0 t0 = let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = norm0 lhs in let rhs0 = norm0 rhs in (match o with | OpEq -> ((psub1 lhs0 rhs0),Equal)::[] | OpNEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[]) | OpLe -> ((psub1 rhs0 lhs0),NonStrict)::[] | OpGe -> ((psub1 lhs0 rhs0),NonStrict)::[] | OpLt -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] | OpGt -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[]) (** val negate : z formula -> z nFormula cnf **) let negate t0 = map (fun x -> x::[]) (xnegate0 t0) (** val zunsat : z nFormula -> bool **) let zunsat = check_inconsistent Z0 zeq_bool Z.leb (** val zdeduce : z nFormula -> z nFormula -> z nFormula option **) let zdeduce = nformula_plus_nformula Z0 Z.add zeq_bool (** val ceiling : z -> z -> z **) let ceiling a b = let q0,r = Z.div_eucl a b in (match r with | Z0 -> q0 | _ -> Z.add q0 (Zpos XH)) type zArithProof = | DoneProof | RatProof of zWitness * zArithProof | CutProof of zWitness * zArithProof | EnumProof of zWitness * zWitness * zArithProof list (** val zgcdM : z -> z -> z **) let zgcdM x y = Z.max (Z.gcd x y) (Zpos XH) (** val zgcd_pol : z polC -> z * z **) let rec zgcd_pol = function | Pc c -> Z0,c | Pinj (_, p2) -> zgcd_pol p2 | PX (p2, _, q0) -> let g1,c1 = zgcd_pol p2 in let g2,c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2),c2 (** val zdiv_pol : z polC -> z -> z polC **) let rec zdiv_pol p x = match p with | Pc c -> Pc (Z.div c x) | Pinj (j, p2) -> Pinj (j, (zdiv_pol p2 x)) | PX (p2, j, q0) -> PX ((zdiv_pol p2 x), j, (zdiv_pol q0 x)) (** val makeCuttingPlane : z polC -> z polC * z **) let makeCuttingPlane p = let g,c = zgcd_pol p in if Z.gtb g Z0 then (zdiv_pol (psubC Z.sub p c) g),(Z.opp (ceiling (Z.opp c) g)) else p,Z0 (** val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option **) let genCuttingPlane = function | e,op -> (match op with | Equal -> let g,c = zgcd_pol e in if (&&) (Z.gtb g Z0) ((&&) (negb (zeq_bool c Z0)) (negb (zeq_bool (Z.gcd g c) g))) then None else Some ((makeCuttingPlane e),Equal) | NonEqual -> Some ((e,Z0),op) | Strict -> Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict) | NonStrict -> Some ((makeCuttingPlane e),NonStrict)) (** val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula **) let nformula_of_cutting_plane = function | e_z,o -> let e,z0 = e_z in (padd1 e (Pc z0)),o (** val is_pol_Z0 : z polC -> bool **) let is_pol_Z0 = function | Pc z0 -> (match z0 with | Z0 -> true | _ -> false) | _ -> false (** val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option **) let eval_Psatz0 = eval_Psatz Z0 (Zpos XH) Z.add Z.mul zeq_bool Z.leb (** val valid_cut_sign : op1 -> bool **) let valid_cut_sign = function | Equal -> true | NonStrict -> true | _ -> false (** val zChecker : z nFormula list -> zArithProof -> bool **) let rec zChecker l = function | DoneProof -> false | RatProof (w, pf0) -> (match eval_Psatz0 l w with | Some f -> if zunsat f then true else zChecker (f::l) pf0 | None -> false) | CutProof (w, pf0) -> (match eval_Psatz0 l w with | Some f -> (match genCuttingPlane f with | Some cp -> zChecker ((nformula_of_cutting_plane cp)::l) pf0 | None -> true) | None -> false) | EnumProof (w1, w2, pf0) -> (match eval_Psatz0 l w1 with | Some f1 -> (match eval_Psatz0 l w2 with | Some f2 -> (match genCuttingPlane f1 with | Some p -> let p2,op3 = p in let e1,z1 = p2 in (match genCuttingPlane f2 with | Some p3 -> let p4,op4 = p3 in let e2,z2 = p4 in if (&&) ((&&) (valid_cut_sign op3) (valid_cut_sign op4)) (is_pol_Z0 (padd1 e1 e2)) then let rec label pfs lb ub = match pfs with | [] -> Z.gtb lb ub | pf1::rsr -> (&&) (zChecker (((psub1 e1 (Pc lb)),Equal)::l) pf1) (label rsr (Z.add lb (Zpos XH)) ub) in label pf0 (Z.opp z1) z2 else false | None -> true) | None -> true) | None -> false) | None -> false) (** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) let zTautoChecker f w = tauto_checker zunsat zdeduce normalise negate zChecker f w type qWitness = q psatz (** val qWeakChecker : q nFormula list -> q psatz -> bool **) let qWeakChecker = check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qeq_bool qle_bool (** val qnormalise : q formula -> q nFormula cnf **) let qnormalise = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qminus qopp qeq_bool (** val qnegate : q formula -> q nFormula cnf **) let qnegate = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qminus qopp qeq_bool (** val qunsat : q nFormula -> bool **) let qunsat = check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool (** val qdeduce : q nFormula -> q nFormula -> q nFormula option **) let qdeduce = nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool (** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) let qTautoChecker f w = tauto_checker qunsat qdeduce qnormalise qnegate qWeakChecker f w type rcst = | C0 | C1 | CQ of q | CZ of z | CPlus of rcst * rcst | CMinus of rcst * rcst | CMult of rcst * rcst | CInv of rcst | COpp of rcst (** val q_of_Rcst : rcst -> q **) let rec q_of_Rcst = function | C0 -> { qnum = Z0; qden = XH } | C1 -> { qnum = (Zpos XH); qden = XH } | CQ q0 -> q0 | CZ z0 -> { qnum = z0; qden = XH } | CPlus (r1, r2) -> qplus (q_of_Rcst r1) (q_of_Rcst r2) | CMinus (r1, r2) -> qminus (q_of_Rcst r1) (q_of_Rcst r2) | CMult (r1, r2) -> qmult (q_of_Rcst r1) (q_of_Rcst r2) | CInv r0 -> qinv (q_of_Rcst r0) | COpp r0 -> qopp (q_of_Rcst r0) type rWitness = q psatz (** val rWeakChecker : q nFormula list -> q psatz -> bool **) let rWeakChecker = check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qeq_bool qle_bool (** val rnormalise : q formula -> q nFormula cnf **) let rnormalise = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qminus qopp qeq_bool (** val rnegate : q formula -> q nFormula cnf **) let rnegate = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qminus qopp qeq_bool (** val runsat : q nFormula -> bool **) let runsat = check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool (** val rdeduce : q nFormula -> q nFormula -> q nFormula option **) let rdeduce = nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool (** val rTautoChecker : rcst formula bFormula -> rWitness list -> bool **) let rTautoChecker f w = tauto_checker runsat rdeduce rnormalise rnegate rWeakChecker (map_bformula (map_Formula q_of_Rcst) f) w coq-8.6/plugins/micromega/certificate.ml0000644000175000017500000011406213022274260017723 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a; number_to_num : 'a -> num; zero : 'a; unit : 'a; mult : 'a -> 'a -> 'a; eqb : 'a -> 'a -> bool } let z_spec = { bigint_to_number = Ml2C.bigint ; number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)); zero = Mc.Z0; unit = Mc.Zpos Mc.XH; mult = Mc.Z.mul; eqb = Mc.zeq_bool } let q_spec = { bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); number_to_num = C2Ml.q_to_num; zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH}; unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH}; mult = Mc.qmult; eqb = Mc.qeq_bool } let r_spec = z_spec let dev_form n_spec p = let rec dev_form p = match p with | Mc.PEc z -> Poly.constant (n_spec.number_to_num z) | Mc.PEX v -> Poly.variable (C2Ml.positive v) | Mc.PEmul(p1,p2) -> let p1 = dev_form p1 in let p2 = dev_form p2 in Poly.product p1 p2 | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2) | Mc.PEopp p -> Poly.uminus (dev_form p) | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2)) | Mc.PEpow(p,n) -> let p = dev_form p in let n = C2Ml.n n in let rec pow n = if Int.equal n 0 then Poly.constant (n_spec.number_to_num n_spec.unit) else Poly.product p (pow (n-1)) in pow n in dev_form p let monomial_to_polynomial mn = Monomial.fold (fun v i acc -> let v = Ml2C.positive v in let mn = if Int.equal i 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in if Pervasives.(=) acc (Mc.PEc (Mc.Zpos Mc.XH)) (** FIXME *) then mn else Mc.PEmul(mn,acc)) mn (Mc.PEc (Mc.Zpos Mc.XH)) let list_to_polynomial vars l = assert (List.for_all (fun x -> ceiling_num x =/ x) l); let var x = monomial_to_polynomial (List.nth vars x) in let rec xtopoly p i = function | [] -> p | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l else let c = Mc.PEc (Ml2C.bigint (numerator c)) in let mn = if Pervasives.(=) c (Mc.PEc (Mc.Zpos Mc.XH)) then var i else Mc.PEmul (c,var i) in let p' = if Pervasives.(=) p (Mc.PEc Mc.Z0) then mn else Mc.PEadd (mn, p) in xtopoly p' (i+1) l in xtopoly (Mc.PEc Mc.Z0) 0 l let rec fixpoint f x = let y' = f x in if Pervasives.(=) y' x then y' else fixpoint f y' let rec_simpl_cone n_spec e = let simpl_cone = Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in let rec rec_simpl_cone = function | Mc.PsatzMulE(t1, t2) -> simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2)) | Mc.PsatzAdd(t1,t2) -> simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2)) | x -> simpl_cone x in rec_simpl_cone e let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c type cone_prod = Const of cone | Ideal of cone *cone | Mult of cone * cone | Other of cone and cone = Mc.zWitness let factorise_linear_cone c = let rec cone_list c l = match c with | Mc.PsatzAdd (x,r) -> cone_list r (x::l) | _ -> c :: l in let factorise c1 c2 = match c1 , c2 with | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> if Pervasives.(=) x x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> if Pervasives.(=) x x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None | _ -> None in let rec rebuild_cone l pending = match l with | [] -> (match pending with | None -> Mc.PsatzZ | Some p -> p ) | e::l -> (match pending with | None -> rebuild_cone l (Some e) | Some p -> (match factorise p e with | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e)) | Some f -> rebuild_cone l (Some f) ) ) in (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None) (* The binding with Fourier might be a bit obsolete -- how does it handle equalities ? *) (* Certificates are elements of the cone such that P = 0 *) (* To begin with, we search for certificates of the form: a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0 where pi >= 0 qi > 0 ai >= 0 bi >= 0 Sum bi + c >= 1 This is a linear problem: each monomial is considered as a variable. Hence, we can use fourier. The variable c is at index 0 *) open Mfourier (* fold_left followed by a rev ! *) let constrain_monomial mn l = let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in if Pervasives.(=) mn Monomial.const then { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; op = Eq ; cst = Big_int zero_big_int } else { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ; op = Eq ; cst = Big_int zero_big_int } let positivity l = let rec xpositivity i l = match l with | [] -> [] | (_,Mc.Equal)::l -> xpositivity (i+1) l | (_,_)::l -> {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; op = Ge ; cst = Int 0 } :: (xpositivity (i+1) l) in xpositivity 0 l let string_of_op = function | Mc.Strict -> "> 0" | Mc.NonStrict -> ">= 0" | Mc.Equal -> "= 0" | Mc.NonEqual -> "<> 0" module MonSet = Set.Make(Monomial) (* If the certificate includes at least one strict inequality, the obtained polynomial can also be 0 *) let build_linear_system l = (* Gather the monomials: HINT add up of the polynomials ==> This does not work anymore *) let l' = List.map fst l in let monomials = List.fold_left (fun acc p -> Poly.fold (fun m _ acc -> MonSet.add m acc) p acc) (MonSet.singleton Monomial.const) l' in (* For each monomial, compute a constraint *) let s0 = MonSet.fold (fun mn res -> (constrain_monomial mn l')::res) monomials [] in (* I need at least something strictly positive *) let strict = { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.map (fun (x,y) -> match y with Mc.Strict -> Big_int unit_big_int | _ -> Big_int zero_big_int) l)); op = Ge ; cst = Big_int unit_big_int } in (* Add the positivity constraint *) {coeffs = Vect.from_list ([Big_int unit_big_int]) ; op = Ge ; cst = Big_int zero_big_int}::(strict::(positivity l)@s0) let big_int_to_z = Ml2C.bigint (* For Q, this is a pity that the certificate has been scaled -- at a lower layer, certificates are using nums... *) let make_certificate n_spec (cert,li) = let bint_to_cst = n_spec.bigint_to_number in match cert with | [] -> failwith "empty_certificate" | e::cert' -> (* let cst = match compare_big_int e zero_big_int with | 0 -> Mc.PsatzZ | 1 -> Mc.PsatzC (bint_to_cst e) | _ -> failwith "positivity error" in *) let rec scalar_product cert l = match cert with | [] -> Mc.PsatzZ | c::cert -> match l with | [] -> failwith "make_certificate(1)" | i::l -> let r = scalar_product cert l in match compare_big_int c zero_big_int with | -1 -> Mc.PsatzAdd ( Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), r) | 0 -> r | _ -> Mc.PsatzAdd ( Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), r) in (factorise_linear_cone (simplify_cone n_spec (scalar_product cert' li))) exception Found of Monomial.t exception Strict module MonMap = Map.Make(Monomial) let primal l = let vr = ref 0 in let vect_of_poly map p = Poly.fold (fun mn vl (map,vect) -> if Pervasives.(=) mn Monomial.const then (map,vect) else let (mn,m) = try (MonMap.find mn map,map) with Not_found -> let res = (!vr, MonMap.add mn !vr map) in incr vr ; res in (m,if Int.equal (sign_num vl) 0 then vect else (mn,vl)::vect)) p (map,[]) in let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in let cmp x y = Int.compare (fst x) (fst y) in snd (List.fold_right (fun (p,op) (map,l) -> let (mp,vect) = vect_of_poly map p in let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in (mp,cstr::l)) l (MonMap.empty,[])) let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = (* List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *) let sys = build_linear_system l in try match Fourier.find_point sys with | Inr _ -> None | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) (* should not use rats_to_ints *) with x when CErrors.noncritical x -> if debug then (Printf.printf "raw certificate %s" (Printexc.to_string x); flush stdout) ; None let raw_certificate l = try let p = primal l in match Fourier.find_point p with | Inr prf -> if debug then Printf.printf "AProof : %a\n" pp_proof prf ; let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; Some (rats_to_ints (Vect.to_list cert)) | Inl _ -> None with Strict -> (* Fourier elimination should handle > *) dual_raw_certificate l let simple_linear_prover l = let (lc,li) = List.split l in match raw_certificate lc with | None -> None (* No certificate *) | Some cert -> Some (cert,li) let linear_prover n_spec l = let build_system n_spec l = let li = List.combine l (interval 0 (List.length l -1)) in let (l1,l') = List.partition (fun (x,_) -> if Pervasives.(=) (snd x) Mc.NonEqual then true else false) li in List.map (fun ((x,y),i) -> match y with Mc.NonEqual -> failwith "cannot happen" | y -> ((dev_form n_spec x, y),i)) l' in let l' = build_system n_spec l in simple_linear_prover (*n_spec*) l' let linear_prover n_spec l = try linear_prover n_spec l with x when CErrors.noncritical x -> (print_string (Printexc.to_string x); None) let compute_max_nb_cstr l d = let len = List.length l in max len (max d (len * d)) let linear_prover_with_cert prfdepth spec l = max_nb_cstr := compute_max_nb_cstr l prfdepth ; match linear_prover spec l with | None -> None | Some cert -> Some (make_certificate spec cert) let nlinear_prover prfdepth (sys: (Mc.q Mc.pExpr * Mc.op1) list) = LinPoly.MonT.clear (); max_nb_cstr := compute_max_nb_cstr sys prfdepth ; (* Assign a proof to the initial hypotheses *) let sys = mapi (fun c i -> (c,Mc.PsatzIn (Ml2C.nat i))) sys in (* Add all the product of hypotheses *) let prod = all_pairs (fun ((c,o),p) ((c',o'),p') -> ((Mc.PEmul(c,c') , Mc.opMult o o') , Mc.PsatzMulE(p,p'))) sys in (* Only filter those have a meaning *) let prod = List.fold_left (fun l ((c,o),p) -> match o with | None -> l | Some o -> ((c,o),p) :: l) [] prod in let sys = sys @ prod in let square = (* Collect the squares and state that they are positive *) let pols = List.map (fun ((p,_),_) -> dev_form q_spec p) sys in let square = List.fold_left (fun acc p -> Poly.fold (fun m _ acc -> match Monomial.sqrt m with | None -> acc | Some s -> MonMap.add s m acc) p acc) MonMap.empty pols in let pol_of_mon m = Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc q_spec.unit) in let norm0 = Mc.norm q_spec.zero q_spec.unit Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool in MonMap.fold (fun s m acc -> ((pol_of_mon m , Mc.NonStrict), Mc.PsatzSquare(norm0 (pol_of_mon s)))::acc) square [] in let sys = sys @ square in (* Call the linear prover without the proofs *) let sys_no_prf = List.map fst sys in match linear_prover q_spec sys_no_prf with | None -> None | Some cert -> let cert = make_certificate q_spec cert in let rec map_psatz = function | Mc.PsatzIn n -> snd (List.nth sys (C2Ml.nat n)) | Mc.PsatzSquare c -> Mc.PsatzSquare c | Mc.PsatzMulC(c,p) -> Mc.PsatzMulC(c, map_psatz p) | Mc.PsatzMulE(p1,p2) -> Mc.PsatzMulE(map_psatz p1,map_psatz p2) | Mc.PsatzAdd(p1,p2) -> Mc.PsatzAdd(map_psatz p1,map_psatz p2) | Mc.PsatzC c -> Mc.PsatzC c | Mc.PsatzZ -> Mc.PsatzZ in Some (map_psatz cert) let make_linear_system l = let l' = List.map fst l in let monomials = List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l' in let monomials = Poly.fold (fun mn _ l -> if Pervasives.(=) mn Monomial.const then l else mn::l) monomials [] in (List.map (fun (c,op) -> {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ; op = op ; cst = minus_num ( (Poly.get Monomial.const c))}) l ,monomials) let pplus x y = Mc.PEadd(x,y) let pmult x y = Mc.PEmul(x,y) let pconst x = Mc.PEc x let popp x = Mc.PEopp x (* keep track of enumerated vectors *) let rec mem p x l = match l with [] -> false | e::l -> if p x e then true else mem p x l let rec remove_assoc p x l = match l with [] -> [] | e::l -> if p x (fst e) then remove_assoc p x l else e::(remove_assoc p x l) let eq x y = Int.equal (Vect.compare x y) 0 let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l (* The prover is (probably) incomplete -- only searching for naive cutting planes *) let develop_constraint z_spec (e,k) = match k with | Mc.NonStrict -> (dev_form z_spec e , Ge) | Mc.Equal -> (dev_form z_spec e , Eq) | _ -> assert false let op_of_op_compat = function | Ge -> Mc.NonStrict | Eq -> Mc.Equal let integer_vector coeffs = let vars , coeffs = List.split coeffs in List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs)) let integer_cstr {coeffs = coeffs ; op = op ; cst = cst } = let vars , coeffs = List.split coeffs in match rats_to_ints (cst::coeffs) with | cst :: coeffs -> { coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ; op = op ; cst = Big_int cst} | _ -> assert false let pexpr_of_cstr_compat var cstr = let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in try let expr = list_to_polynomial var (Vect.to_list coeffs) in let d = Ml2C.bigint (denominator cst) in let n = Ml2C.bigint (numerator cst) in (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op) with Failure _ -> failwith "pexpr_of_cstr_compat" open Sos_types let rec scale_term t = match t with | Zero -> unit_big_int , Zero | Const n -> (denominator n) , Const (Big_int (numerator n)) | Var n -> unit_big_int , Var n | Inv _ -> failwith "scale_term : not implemented" | Opp t -> let s, t = scale_term t in s, Opp t | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in let g = gcd_big_int s1 s2 in let s1' = div_big_int s1 g in let s2' = div_big_int s2 g in let e = mult_big_int g (mult_big_int s1' s2') in if Int.equal (compare_big_int e unit_big_int) 0 then (unit_big_int, Add (y1,y2)) else e, Add (Mul(Const (Big_int s2'), y1), Mul (Const (Big_int s1'), y2)) | Sub _ -> failwith "scale term: not implemented" | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in mult_big_int s1 s2 , Mul (y1, y2) | Pow(t,n) -> let s,t = scale_term t in power_big_int_positive_int s n , Pow(t,n) | _ -> failwith "scale_term : not implemented" let scale_term t = let (s,t') = scale_term t in s,t' let get_index_of_ith_match f i l = let rec get j res l = match l with | [] -> failwith "bad index" | e::l -> if f e then (if Int.equal j i then res else get (j+1) (res+1) l ) else get j (res+1) l in get 0 0 l let rec scale_certificate pos = match pos with | Axiom_eq i -> unit_big_int , Axiom_eq i | Axiom_le i -> unit_big_int , Axiom_le i | Axiom_lt i -> unit_big_int , Axiom_lt i | Monoid l -> unit_big_int , Monoid l | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) | Square t -> let s,t' = scale_term t in mult_big_int s s , Square t' | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in mult_big_int s1 s2 , Eqmul (y1,y2) | Sum (y, z) -> let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in let g = gcd_big_int s1 s2 in let s1' = div_big_int s1 g in let s2' = div_big_int s2 g in mult_big_int g (mult_big_int s1' s2'), Sum (Product(Rational_le (Big_int s2'), y1), Product (Rational_le (Big_int s1'), y2)) | Product (y, z) -> let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in mult_big_int s1 s2 , Product (y1,y2) open Micromega let rec term_to_q_expr = function | Const n -> PEc (Ml2C.q n) | Zero -> PEc ( Ml2C.q (Int 0)) | Var s -> PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2) | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2) | Opp p -> PEopp (term_to_q_expr p) | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n) | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2) | _ -> failwith "term_to_q_expr: not implemented" let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e) let rec product l = match l with | [] -> Mc.PsatzZ | [i] -> Mc.PsatzIn (Ml2C.nat i) | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l) let q_cert_of_pos pos = let rec _cert_of_pos = function Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l | Rational_eq n | Rational_le n | Rational_lt n -> if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else Mc.PsatzC (Ml2C.q n) | Square t -> Mc.PsatzSquare (term_to_q_pol t) | Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_pol t, _cert_of_pos y) | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in simplify_cone q_spec (_cert_of_pos pos) let rec term_to_z_expr = function | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) | Zero -> PEc ( Z0) | Var s -> PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2) | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2) | Opp p -> PEopp (term_to_z_expr p) | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n) | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2) | _ -> failwith "term_to_z_expr: not implemented" let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e) let z_cert_of_pos pos = let s,pos = (scale_certificate pos) in let rec _cert_of_pos = function Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l | Rational_eq n | Rational_le n | Rational_lt n -> if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else Mc.PsatzC (Ml2C.bigint (big_int_of_num n)) | Square t -> Mc.PsatzSquare (term_to_z_pol t) | Eqmul (t, y) -> let is_unit = match t with | Const n -> n =/ Int 1 | _ -> false in if is_unit then _cert_of_pos y else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y) | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in simplify_cone z_spec (_cert_of_pos pos) (** All constraints (initial or derived) have an index and have a justification i.e., proof. Given a constraint, all the coefficients are always integers. *) open Mutils open Mfourier open Num open Big_int open Polynomial module Env = struct type t = int list let id_of_hyp hyp l = let rec xid_of_hyp i l = match l with | [] -> failwith "id_of_hyp" | hyp'::l -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l in xid_of_hyp 0 l end let coq_poly_of_linpol (p,c) = let pol_of_mon m = Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc (Mc.Zpos Mc.XH)) in List.fold_left (fun acc (x,v) -> let mn = LinPoly.MonT.retrieve x in Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p let rec cmpl_prf_rule env = function | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env)) | Cst i -> Mc.PsatzC (Ml2C.bigint i) | Zero -> Mc.PsatzZ | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2) | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2) | MulC(lp,p) -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in Mc.PsatzMulC(lp,cmpl_prf_rule env p) | Square lp -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp)) | _ -> failwith "Cuts should already be compiled" let rec cmpl_proof env = function | Done -> Mc.DoneProof | Step(i,p,prf) -> begin match p with | CutPrf p' -> Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf) | _ -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf) end | Enum(i,p1,_,p2,l) -> Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l) let compile_proof env prf = let id = 1 + proof_max_id prf in let _,prf = normalise_proof id prf in if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf; cmpl_proof env prf type prf_sys = (cstr_compat * prf_rule) list let xlinear_prover sys = match Fourier.find_point sys with | Inr prf -> if debug then Printf.printf "AProof : %a\n" pp_proof prf ; let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; Some (rats_to_ints (Vect.to_list cert)) | Inl _ -> None let output_num o n = output_string o (string_of_num n) let output_bigint o n = output_string o (string_of_big_int n) let proof_of_farkas prf cert = (* Printf.printf "\nproof_of_farkas %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ; *) let rec mk_farkas acc prf cert = match prf, cert with | _ , [] -> acc | [] , _ -> failwith "proof_of_farkas : not enough hyps" | p::prf,c::cert -> mk_farkas (add_proof (mul_proof c p) acc) prf cert in let res = mk_farkas Zero prf cert in (*Printf.printf "==> %a" output_prf_rule res ; *) res let linear_prover sys = let (sysi,prfi) = List.split sys in match xlinear_prover sysi with | None -> None | Some cert -> Some (proof_of_farkas prfi cert) let linear_prover = if debug then fun sys -> Printf.printf ""; flush stdout ; res else linear_prover (** A single constraint can be unsat for the following reasons: - 0 >= c for c a negative constant - 0 = c for c a non-zero constant - e = c when the coeffs of e are all integers and c is rational *) type checksat = | Tauto (* Tautology *) | Unsat of prf_rule (* Unsatisfiable *) | Cut of cstr_compat * prf_rule (* Cutting plane *) | Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *) (** [check_sat] - detects constraints that are not satisfiable; - normalises constraints and generate cuts. *) let check_sat (cstr,prf) = let {coeffs=coeffs ; op=op ; cst=cst} = cstr in match coeffs with | [] -> if eval_op op (Int 0) cst then Tauto else Unsat prf | _ -> let gcdi = (gcd_list (List.map snd coeffs)) in let gcd = Big_int gcdi in if eq_num gcd (Int 1) then Normalise(cstr,prf) else if Int.equal (sign_num (mod_num cst gcd)) 0 then (* We can really normalise *) begin assert (sign_num gcd >=1 ) ; let cstr = { coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; op = op ; cst = cst // gcd } in Normalise(cstr,Gcd(gcdi,prf)) (* Normalise(cstr,CutPrf prf)*) end else match op with | Eq -> Unsat (CutPrf prf) | Ge -> let cstr = { coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; op = op ; cst = ceiling_num (cst // gcd) } in Cut(cstr,CutPrf prf) (** Proof generating pivoting over variable v *) let pivot v (c1,p1) (c2,p2) = let {coeffs = v1 ; op = op1 ; cst = n1} = c1 and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in (* Could factorise gcd... *) let xpivot cv1 cv2 = ( {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ; op = Proof.add_op op1 op2 ; cst = n1 */ cv1 +/ n2 */ cv2 }, AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in match Vect.get v v1 , Vect.get v v2 with | None , _ | _ , None -> None | Some a , Some b -> if Int.equal ((sign_num a) * (sign_num b)) (-1) then let cv1 = abs_num b and cv2 = abs_num a in Some (xpivot cv1 cv2) else if op1 == Eq then let cv1 = minus_num (b */ (Int (sign_num a))) and cv2 = abs_num a in Some (xpivot cv1 cv2) else if op2 == Eq then let cv1 = abs_num b and cv2 = minus_num (a */ (Int (sign_num b))) in Some (xpivot cv1 cv2) else None (* op2 could be Eq ... this might happen *) exception FoundProof of prf_rule let simpl_sys sys = List.fold_left (fun acc (c,p) -> match check_sat (c,p) with | Tauto -> acc | Unsat prf -> raise (FoundProof prf) | Cut(c,p) -> (c,p)::acc | Normalise (c,p) -> (c,p)::acc) [] sys (** [ext_gcd a b] is the extended Euclid algorithm. [ext_gcd a b = (x,y,g)] iff [ax+by=g] Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm *) let rec ext_gcd a b = if Int.equal (sign_big_int b) 0 then (unit_big_int,zero_big_int) else let (q,r) = quomod_big_int a b in let (s,t) = ext_gcd b r in (t, sub_big_int s (mult_big_int q t)) let pp_ext_gcd a b = let a' = big_int_of_int a in let b' = big_int_of_int b in let (x,y) = ext_gcd a' b' in Printf.fprintf stdout "%s * %s + %s * %s = %s\n" (string_of_big_int x) (string_of_big_int a') (string_of_big_int y) (string_of_big_int b') (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b'))) exception Result of (int * (proof * cstr_compat)) let split_equations psys = List.partition (fun (c,p) -> c.op == Eq) let extract_coprime (c1,p1) (c2,p2) = let rec exist2 vect1 vect2 = match vect1 , vect2 with | _ , [] | [], _ -> None | (v1,n1)::vect1' , (v2, n2) :: vect2' -> if Pervasives.(=) v1 v2 then if Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0 then Some (v1,n1,n2) else exist2 vect1' vect2' else if v1 < v2 then exist2 vect1' vect2 else exist2 vect1 vect2' in if c1.op == Eq && c2.op == Eq then exist2 c1.coeffs c2.coeffs else None let extract2 pred l = let rec xextract2 rl l = match l with | [] -> (None,rl) (* Did not find *) | e::l -> match extract (pred e) l with | None,_ -> xextract2 (e::rl) l | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in xextract2 [] l let extract_coprime_equation psys = extract2 extract_coprime psys let apply_and_normalise f psys = List.fold_left (fun acc pc' -> match f pc' with | None -> pc'::acc | Some pc' -> match check_sat pc' with | Tauto -> acc | Unsat prf -> raise (FoundProof prf) | Cut(c,p) -> (c,p)::acc | Normalise (c,p) -> (c,p)::acc ) [] psys let pivot_sys v pc psys = apply_and_normalise (pivot v pc) psys let reduce_coprime psys = let oeq,sys = extract_coprime_equation psys in match oeq with | None -> None (* Nothing to do *) | Some((v,n1,n2),(c1,p1),(c2,p2) ) -> let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in let l1' = Big_int l1 and l2' = Big_int l2 in let cstr = {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs); op = Eq ; cst = (l1' */ c1.cst) +/ (l2' */ c2.cst) } in let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in Some (pivot_sys v (cstr,prf) ((c1,p1)::sys)) (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *) let reduce_unary psys = let is_unary_equation (cstr,prf) = if cstr.op == Eq then try Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs)) with Not_found -> None else None in let (oeq,sys) = extract is_unary_equation psys in match oeq with | None -> None (* Nothing to do *) | Some(v,pc) -> Some(pivot_sys v pc sys) let reduce_non_lin_unary psys = let is_unary_equation (cstr,prf) = if cstr.op == Eq then try let x = fst (List.find (fun (x,n) -> (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in let x' = LinPoly.MonT.retrieve x in if List.for_all (fun (y,_) -> Pervasives.(=) y x || Int.equal (snd (Monomial.div (LinPoly.MonT.retrieve y) x')) 0) cstr.coeffs then Some x else None with Not_found -> None else None in let (oeq,sys) = extract is_unary_equation psys in match oeq with | None -> None (* Nothing to do *) | Some(v,pc) -> Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys) let reduce_var_change psys = let rec rel_prime vect = match vect with | [] -> None | (x,v)::vect -> let v = numerator v in try let (x',v') = List.find (fun (_,v') -> let v' = numerator v' in eq_big_int (gcd_big_int v v') unit_big_int) vect in Some ((x,v),(x',numerator v')) with Not_found -> rel_prime vect in let rel_prime (cstr,prf) = if cstr.op == Eq then rel_prime cstr.coeffs else None in let (oeq,sys) = extract rel_prime psys in match oeq with | None -> None | Some(((x,v),(x',v')),(c,p)) -> let (l1,l2) = ext_gcd v v' in let l1,l2 = Big_int l1 , Big_int l2 in let get v vect = match Vect.get v vect with | None -> Int 0 | Some n -> n in let pivot_eq (c',p') = let {coeffs = coeffs ; op = op ; cst = cst} = c' in let vx = get x coeffs in let vx' = get x' coeffs in let m = minus_num (vx */ l1 +/ vx' */ l2) in Some ({coeffs = Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} , AddPrf(MulC(([], m),p),p')) in Some (apply_and_normalise pivot_eq sys) let reduce_pivot psys = let is_equation (cstr,prf) = if cstr.op == Eq then try Some (fst (List.hd cstr.coeffs)) with Not_found -> None else None in let (oeq,sys) = extract is_equation psys in match oeq with | None -> None (* Nothing to do *) | Some(v,pc) -> if debug then Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst); Some(pivot_sys v pc sys) let iterate_until_stable f x = let rec iter x = match f x with | None -> x | Some x' -> iter x' in iter x let rec app_funs l x = match l with | [] -> None | f::fl -> match f x with | None -> app_funs fl x | Some x' -> Some x' let reduction_equations psys = iterate_until_stable (app_funs [reduce_unary ; reduce_coprime ; reduce_var_change (*; reduce_pivot*)]) psys let reduction_non_lin_equations psys = iterate_until_stable (app_funs [reduce_non_lin_unary (*; reduce_coprime ; reduce_var_change ; reduce_pivot *)]) psys (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) let get_bound sys = let is_small (v,i) = match Itv.range i with | None -> false | Some i -> i <=/ (Int 1) in let select_best (x1,i1) (x2,i2) = if Itv.smaller_itv i1 i2 then (x1,i1) else (x2,i2) in (* For lia, there are no equations => these precautions are not needed *) (* For nlia, there are equations => do not enumerate over equations! *) let all_planes sys = let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in match eq with | [] -> List.rev_map (fun c -> c.coeffs) ineq | _ -> List.fold_left (fun acc c -> if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq then acc else c.coeffs ::acc) [] ineq in let smallest_interval = List.fold_left (fun acc vect -> if is_small acc then acc else match Fourier.optimise vect sys with | None -> acc | Some i -> if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ; select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in let smallest_interval = match smallest_interval with | (x,(Some i, Some j)) -> Some(i,x,j) | x -> None (* This should not be possible *) in match smallest_interval with | Some (lb,e,ub) -> let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in (match (* x <= ub -> x > ub *) xlinear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys), (* lb <= x -> lb > x *) xlinear_prover ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys) with | Some cub , Some clb -> Some(List.tl clb,(lb,e,ub), List.tl cub) | _ -> failwith "Interval without proof" ) | None -> None let check_sys sys = List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys let xlia (can_enum:bool) reduction_equations sys = let rec enum_proof (id:int) (sys:prf_sys) : proof option = if debug then (Printf.printf "enum_proof\n" ; flush stdout) ; assert (check_sys sys) ; let nsys,prf = List.split sys in match get_bound nsys with | None -> None (* Is the systeme really unbounded ? *) | Some(prf1,(lb,e,ub),prf2) -> if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect e (string_of_num lb) (string_of_num ub) ; (match start_enum id e (ceiling_num lb) (floor_num ub) sys with | Some prfl -> Some(Enum(id,proof_of_farkas prf prf1,e, proof_of_farkas prf prf2,prfl)) | None -> None ) and start_enum id e clb cub sys = if clb >/ cub then Some [] else let eq = {coeffs = e ; op = Eq ; cst = clb} in match aux_lia (id+1) ((eq, Def id) :: sys) with | None -> None | Some prf -> match start_enum id e (clb +/ (Int 1)) cub sys with | None -> None | Some l -> Some (prf::l) and aux_lia (id:int) (sys:prf_sys) : proof option = assert (check_sys sys) ; if debug then Printf.printf "xlia: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; try let sys = reduction_equations sys in if debug then Printf.printf "after reduction: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; match linear_prover sys with | Some prf -> Some (Step(id,prf,Done)) | None -> if can_enum then enum_proof id sys else None with FoundProof prf -> (* [reduction_equations] can find a proof *) Some(Step(id,prf,Done)) in (* let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*) let id = List.length sys in let orpf = try let sys = simpl_sys sys in aux_lia id sys with FoundProof pr -> Some(Step(id,pr,Done)) in match orpf with | None -> None | Some prf -> (*Printf.printf "direct proof %a\n" output_proof prf ; *) let env = mapi (fun _ i -> i) sys in let prf = compile_proof env prf in (*try if Mc.zChecker sys' prf then Some prf else raise Certificate.BadCertificate with Failure s -> (Printf.printf "%s" s ; Some prf) *) Some prf let cstr_compat_of_poly (p,o) = let (v,c) = LinPoly.linpol_of_pol p in {coeffs = v ; op = o ; cst = minus_num c } let lia (can_enum:bool) (prfdepth:int) sys = LinPoly.MonT.clear (); max_nb_cstr := compute_max_nb_cstr sys prfdepth ; let sys = List.map (develop_constraint z_spec) sys in let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in let sys = mapi (fun c i -> (c,Hyp i)) sys in xlia can_enum reduction_equations sys let nlia enum prfdepth sys = LinPoly.MonT.clear (); max_nb_cstr := compute_max_nb_cstr sys prfdepth; let sys = List.map (develop_constraint z_spec) sys in let sys = mapi (fun c i -> (c,Hyp i)) sys in let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in let collect_square = List.fold_left (fun acc ((p,_),_) -> Poly.fold (fun m _ acc -> match Monomial.sqrt m with | None -> acc | Some s -> MonMap.add s m acc) p acc) MonMap.empty sys in let sys = MonMap.fold (fun s m acc -> let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in ((m, Ge), (Square s))::acc) collect_square sys in (* List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*) let sys = if is_linear then sys else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') -> ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in assert (check_sys sys) ; xlia enum (if is_linear then reduction_equations else reduction_non_lin_equations) sys (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.6/plugins/romega/0000755000175000017500000000000013022274260014412 5ustar mdenesmdenescoq-8.6/plugins/romega/const_omega.ml0000644000175000017500000003124413022274260017246 0ustar mdenesmdenes(************************************************************************* PROJET RNRT Calife - 2001 Author: Pierre Crégut - France Télécom R&D Licence : LGPL version 2.1 *************************************************************************) let module_refl_name = "ReflOmegaCore" let module_refl_path = ["Coq"; "romega"; module_refl_name] type result = Kvar of string | Kapp of string * Term.constr list | Kimp of Term.constr * Term.constr | Kufo;; let meaningful_submodule = [ "Z"; "N"; "Pos" ] let string_of_global r = let dp = Nametab.dirpath_of_global r in let prefix = match Names.DirPath.repr dp with | [] -> "" | m::_ -> let s = Names.Id.to_string m in if Util.String.List.mem s meaningful_submodule then s^"." else "" in prefix^(Names.Id.to_string (Nametab.basename_of_global r)) let destructurate t = let c, args = Term.decompose_app t in match Term.kind_of_term c, args with | Term.Const (sp,_), args -> Kapp (string_of_global (Globnames.ConstRef sp), args) | Term.Construct (csp,_) , args -> Kapp (string_of_global (Globnames.ConstructRef csp), args) | Term.Ind (isp,_), args -> Kapp (string_of_global (Globnames.IndRef isp), args) | Term.Var id,[] -> Kvar(Names.Id.to_string id) | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) | Term.Prod (Names.Name _,_,_),[] -> CErrors.error "Omega: Not a quantifier-free goal" | _ -> Kufo exception Destruct let dest_const_apply t = let f,args = Term.decompose_app t in let ref = match Term.kind_of_term f with | Term.Const (sp,_) -> Globnames.ConstRef sp | Term.Construct (csp,_) -> Globnames.ConstructRef csp | Term.Ind (isp,_) -> Globnames.IndRef isp | _ -> raise Destruct in Nametab.basename_of_global ref, args let logic_dir = ["Coq";"Logic";"Decidable"] let coq_modules = Coqlib.init_modules @ [logic_dir] @ Coqlib.arith_modules @ Coqlib.zarith_base_modules @ [["Coq"; "Lists"; "List"]] @ [module_refl_path] @ [module_refl_path@["ZOmega"]] let bin_module = [["Coq";"Numbers";"BinNums"]] let z_module = [["Coq";"ZArith";"BinInt"]] let init_constant = Coqlib.gen_constant_in_modules "Omega" Coqlib.init_modules let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules let z_constant = Coqlib.gen_constant_in_modules "Omega" z_module let bin_constant = Coqlib.gen_constant_in_modules "Omega" bin_module (* Logic *) let coq_refl_equal = lazy(init_constant "eq_refl") let coq_and = lazy(init_constant "and") let coq_not = lazy(init_constant "not") let coq_or = lazy(init_constant "or") let coq_True = lazy(init_constant "True") let coq_False = lazy(init_constant "False") let coq_I = lazy(init_constant "I") (* ReflOmegaCore/ZOmega *) let coq_h_step = lazy (constant "h_step") let coq_pair_step = lazy (constant "pair_step") let coq_p_left = lazy (constant "P_LEFT") let coq_p_right = lazy (constant "P_RIGHT") let coq_p_invert = lazy (constant "P_INVERT") let coq_p_step = lazy (constant "P_STEP") let coq_t_int = lazy (constant "Tint") let coq_t_plus = lazy (constant "Tplus") let coq_t_mult = lazy (constant "Tmult") let coq_t_opp = lazy (constant "Topp") let coq_t_minus = lazy (constant "Tminus") let coq_t_var = lazy (constant "Tvar") let coq_proposition = lazy (constant "proposition") let coq_p_eq = lazy (constant "EqTerm") let coq_p_leq = lazy (constant "LeqTerm") let coq_p_geq = lazy (constant "GeqTerm") let coq_p_lt = lazy (constant "LtTerm") let coq_p_gt = lazy (constant "GtTerm") let coq_p_neq = lazy (constant "NeqTerm") let coq_p_true = lazy (constant "TrueTerm") let coq_p_false = lazy (constant "FalseTerm") let coq_p_not = lazy (constant "Tnot") let coq_p_or = lazy (constant "Tor") let coq_p_and = lazy (constant "Tand") let coq_p_imp = lazy (constant "Timp") let coq_p_prop = lazy (constant "Tprop") (* Constructors for shuffle tactic *) let coq_t_fusion = lazy (constant "t_fusion") let coq_f_equal = lazy (constant "F_equal") let coq_f_cancel = lazy (constant "F_cancel") let coq_f_left = lazy (constant "F_left") let coq_f_right = lazy (constant "F_right") (* Constructors for reordering tactics *) let coq_c_do_both = lazy (constant "C_DO_BOTH") let coq_c_do_left = lazy (constant "C_LEFT") let coq_c_do_right = lazy (constant "C_RIGHT") let coq_c_do_seq = lazy (constant "C_SEQ") let coq_c_nop = lazy (constant "C_NOP") let coq_c_opp_plus = lazy (constant "C_OPP_PLUS") let coq_c_opp_opp = lazy (constant "C_OPP_OPP") let coq_c_opp_mult_r = lazy (constant "C_OPP_MULT_R") let coq_c_opp_one = lazy (constant "C_OPP_ONE") let coq_c_reduce = lazy (constant "C_REDUCE") let coq_c_mult_plus_distr = lazy (constant "C_MULT_PLUS_DISTR") let coq_c_opp_left = lazy (constant "C_MULT_OPP_LEFT") let coq_c_mult_assoc_r = lazy (constant "C_MULT_ASSOC_R") let coq_c_plus_assoc_r = lazy (constant "C_PLUS_ASSOC_R") let coq_c_plus_assoc_l = lazy (constant "C_PLUS_ASSOC_L") let coq_c_plus_permute = lazy (constant "C_PLUS_PERMUTE") let coq_c_plus_comm = lazy (constant "C_PLUS_COMM") let coq_c_red0 = lazy (constant "C_RED0") let coq_c_red1 = lazy (constant "C_RED1") let coq_c_red2 = lazy (constant "C_RED2") let coq_c_red3 = lazy (constant "C_RED3") let coq_c_red4 = lazy (constant "C_RED4") let coq_c_red5 = lazy (constant "C_RED5") let coq_c_red6 = lazy (constant "C_RED6") let coq_c_mult_opp_left = lazy (constant "C_MULT_OPP_LEFT") let coq_c_mult_assoc_reduced = lazy (constant "C_MULT_ASSOC_REDUCED") let coq_c_minus = lazy (constant "C_MINUS") let coq_c_mult_comm = lazy (constant "C_MULT_COMM") let coq_s_constant_not_nul = lazy (constant "O_CONSTANT_NOT_NUL") let coq_s_constant_neg = lazy (constant "O_CONSTANT_NEG") let coq_s_div_approx = lazy (constant "O_DIV_APPROX") let coq_s_not_exact_divide = lazy (constant "O_NOT_EXACT_DIVIDE") let coq_s_exact_divide = lazy (constant "O_EXACT_DIVIDE") let coq_s_sum = lazy (constant "O_SUM") let coq_s_state = lazy (constant "O_STATE") let coq_s_contradiction = lazy (constant "O_CONTRADICTION") let coq_s_merge_eq = lazy (constant "O_MERGE_EQ") let coq_s_split_ineq =lazy (constant "O_SPLIT_INEQ") let coq_s_constant_nul =lazy (constant "O_CONSTANT_NUL") let coq_s_negate_contradict =lazy (constant "O_NEGATE_CONTRADICT") let coq_s_negate_contradict_inv =lazy (constant "O_NEGATE_CONTRADICT_INV") (* construction for the [extract_hyp] tactic *) let coq_direction = lazy (constant "direction") let coq_d_left = lazy (constant "D_left") let coq_d_right = lazy (constant "D_right") let coq_d_mono = lazy (constant "D_mono") let coq_e_split = lazy (constant "E_SPLIT") let coq_e_extract = lazy (constant "E_EXTRACT") let coq_e_solve = lazy (constant "E_SOLVE") let coq_interp_sequent = lazy (constant "interp_goal_concl") let coq_do_omega = lazy (constant "do_omega") (* \subsection{Construction d'expressions} *) let do_left t = if Term.eq_constr t (Lazy.force coq_c_nop) then Lazy.force coq_c_nop else Term.mkApp (Lazy.force coq_c_do_left, [|t |] ) let do_right t = if Term.eq_constr t (Lazy.force coq_c_nop) then Lazy.force coq_c_nop else Term.mkApp (Lazy.force coq_c_do_right, [|t |]) let do_both t1 t2 = if Term.eq_constr t1 (Lazy.force coq_c_nop) then do_right t2 else if Term.eq_constr t2 (Lazy.force coq_c_nop) then do_left t1 else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |]) let do_seq t1 t2 = if Term.eq_constr t1 (Lazy.force coq_c_nop) then t2 else if Term.eq_constr t2 (Lazy.force coq_c_nop) then t1 else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |]) let rec do_list = function | [] -> Lazy.force coq_c_nop | [x] -> x | (x::l) -> do_seq x (do_list l) (* Nat *) let coq_S = lazy(init_constant "S") let coq_O = lazy(init_constant "O") let rec mk_nat = function | 0 -> Lazy.force coq_O | n -> Term.mkApp (Lazy.force coq_S, [| mk_nat (n-1) |]) (* Lists *) let mkListConst c = let r = Coqlib.gen_reference "" ["Init";"Datatypes"] c in let inst = if Global.is_polymorphic r then fun u -> Univ.Instance.of_array [|u|] else fun _ -> Univ.Instance.empty in fun u -> Term.mkConstructU (Globnames.destConstructRef r, inst u) let coq_cons univ typ = Term.mkApp (mkListConst "cons" univ, [|typ|]) let coq_nil univ typ = Term.mkApp (mkListConst "nil" univ, [|typ|]) let mk_list univ typ l = let rec loop = function | [] -> coq_nil univ typ | (step :: l) -> Term.mkApp (coq_cons univ typ, [| step; loop l |]) in loop l let mk_plist = let type1lev = Universes.new_univ_level (Global.current_dirpath ()) in fun l -> mk_list type1lev Term.mkProp l let mk_list = mk_list Univ.Level.set let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l type parse_term = | Tplus of Term.constr * Term.constr | Tmult of Term.constr * Term.constr | Tminus of Term.constr * Term.constr | Topp of Term.constr | Tsucc of Term.constr | Tnum of Bigint.bigint | Tother type parse_rel = | Req of Term.constr * Term.constr | Rne of Term.constr * Term.constr | Rlt of Term.constr * Term.constr | Rle of Term.constr * Term.constr | Rgt of Term.constr * Term.constr | Rge of Term.constr * Term.constr | Rtrue | Rfalse | Rnot of Term.constr | Ror of Term.constr * Term.constr | Rand of Term.constr * Term.constr | Rimp of Term.constr * Term.constr | Riff of Term.constr * Term.constr | Rother let parse_logic_rel c = try match destructurate c with | Kapp("True",[]) -> Rtrue | Kapp("False",[]) -> Rfalse | Kapp("not",[t]) -> Rnot t | Kapp("or",[t1;t2]) -> Ror (t1,t2) | Kapp("and",[t1;t2]) -> Rand (t1,t2) | Kimp(t1,t2) -> Rimp (t1,t2) | Kapp("iff",[t1;t2]) -> Riff (t1,t2) | _ -> Rother with e when Logic.catchable_exception e -> Rother module type Int = sig val typ : Term.constr Lazy.t val plus : Term.constr Lazy.t val mult : Term.constr Lazy.t val opp : Term.constr Lazy.t val minus : Term.constr Lazy.t val mk : Bigint.bigint -> Term.constr val parse_term : Term.constr -> parse_term val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel (* check whether t is built only with numbers and + * - *) val is_scalar : Term.constr -> bool end module Z : Int = struct let typ = lazy (bin_constant "Z") let plus = lazy (z_constant "Z.add") let mult = lazy (z_constant "Z.mul") let opp = lazy (z_constant "Z.opp") let minus = lazy (z_constant "Z.sub") let coq_xH = lazy (bin_constant "xH") let coq_xO = lazy (bin_constant "xO") let coq_xI = lazy (bin_constant "xI") let coq_Z0 = lazy (bin_constant "Z0") let coq_Zpos = lazy (bin_constant "Zpos") let coq_Zneg = lazy (bin_constant "Zneg") let recognize t = let rec loop t = let f,l = dest_const_apply t in match Names.Id.to_string f,l with "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t)) | "xO",[t] -> Bigint.mult Bigint.two (loop t) | "xH",[] -> Bigint.one | _ -> failwith "not a number" in let f,l = dest_const_apply t in match Names.Id.to_string f,l with "Zpos",[t] -> loop t | "Zneg",[t] -> Bigint.neg (loop t) | "Z0",[] -> Bigint.zero | _ -> failwith "not a number";; let rec mk_positive n = if n=Bigint.one then Lazy.force coq_xH else let (q,r) = Bigint.euclid n Bigint.two in Term.mkApp ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI), [| mk_positive q |]) let mk_Z n = if n = Bigint.zero then Lazy.force coq_Z0 else if Bigint.is_strictly_pos n then Term.mkApp (Lazy.force coq_Zpos, [| mk_positive n |]) else Term.mkApp (Lazy.force coq_Zneg, [| mk_positive (Bigint.neg n) |]) let mk = mk_Z let parse_term t = try match destructurate t with | Kapp("Z.add",[t1;t2]) -> Tplus (t1,t2) | Kapp("Z.sub",[t1;t2]) -> Tminus (t1,t2) | Kapp("Z.mul",[t1;t2]) -> Tmult (t1,t2) | Kapp("Z.opp",[t]) -> Topp t | Kapp("Z.succ",[t]) -> Tsucc t | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> (try Tnum (recognize t) with e when CErrors.noncritical e -> Tother) | _ -> Tother with e when Logic.catchable_exception e -> Tother let parse_rel gl t = try match destructurate t with | Kapp("eq",[typ;t1;t2]) when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) -> Req (t1,t2) | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2) | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2) | Kapp("Z.ge",[t1;t2]) -> Rge (t1,t2) | Kapp("Z.gt",[t1;t2]) -> Rgt (t1,t2) | _ -> parse_logic_rel t with e when Logic.catchable_exception e -> Rother let is_scalar t = let rec aux t = match destructurate t with | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> aux t1 && aux t2 | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true | _ -> false in try aux t with e when CErrors.noncritical e -> false end coq-8.6/plugins/romega/ReflOmegaCore.v0000644000175000017500000027444613022274260017274 0ustar mdenesmdenes(* -*- coding: utf-8 -*- *) (************************************************************************* PROJET RNRT Calife - 2001 Author: Pierre Crégut - France Télécom R&D Licence du projet : LGPL version 2.1 *************************************************************************) Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable ZArith_base. Delimit Scope Int_scope with I. (* Abstract Integers. *) Module Type Int. Parameter t : Set. Parameter zero : t. Parameter one : t. Parameter plus : t -> t -> t. Parameter opp : t -> t. Parameter minus : t -> t -> t. Parameter mult : t -> t -> t. Notation "0" := zero : Int_scope. Notation "1" := one : Int_scope. Infix "+" := plus : Int_scope. Infix "-" := minus : Int_scope. Infix "*" := mult : Int_scope. Notation "- x" := (opp x) : Int_scope. Open Scope Int_scope. (* First, int is a ring: *) Axiom ring : @ring_theory t 0 1 plus mult minus opp (@eq t). (* int should also be ordered: *) Parameter le : t -> t -> Prop. Parameter lt : t -> t -> Prop. Parameter ge : t -> t -> Prop. Parameter gt : t -> t -> Prop. Notation "x <= y" := (le x y): Int_scope. Notation "x < y" := (lt x y) : Int_scope. Notation "x >= y" := (ge x y) : Int_scope. Notation "x > y" := (gt x y): Int_scope. Axiom le_lt_iff : forall i j, (i<=j) <-> ~(j=j) <-> (j<=i). Axiom gt_lt_iff : forall i j, (i>j) <-> (j j i i<>j. (* Compatibilities *) Axiom lt_0_1 : 0<1. Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l. Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i). Axiom mult_lt_compat_l : forall i j k, 0 < k -> i < j -> k*i t -> comparison. Infix "?=" := compare (at level 70, no associativity) : Int_scope. Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j. Axiom compare_Lt : forall i j, compare i j = Lt <-> i i>j. (* Up to here, these requirements could be fulfilled by any totally ordered ring. Let's now be int-specific: *) Axiom le_lt_int : forall x y, x x<=y+-(1). (* Btw, lt_0_1 could be deduced from this last axiom *) End Int. (* Of course, Z is a model for our abstract int *) Module Z_as_Int <: Int. Open Scope Z_scope. Definition t := Z. Definition zero := 0. Definition one := 1. Definition plus := Z.add. Definition opp := Z.opp. Definition minus := Z.sub. Definition mult := Z.mul. Lemma ring : @ring_theory t zero one plus mult minus opp (@eq t). Proof. constructor. exact Z.add_0_l. exact Z.add_comm. exact Z.add_assoc. exact Z.mul_1_l. exact Z.mul_comm. exact Z.mul_assoc. exact Z.mul_add_distr_r. unfold minus, Z.sub; auto. exact Z.add_opp_diag_r. Qed. Definition le := Z.le. Definition lt := Z.lt. Definition ge := Z.ge. Definition gt := Z.gt. Definition le_lt_iff := Z.le_ngt. Definition ge_le_iff := Z.ge_le_iff. Definition gt_lt_iff := Z.gt_lt_iff. Definition lt_trans := Z.lt_trans. Definition lt_not_eq := Z.lt_neq. Definition lt_0_1 := Z.lt_0_1. Definition plus_le_compat := Z.add_le_mono. Definition mult_lt_compat_l := Zmult_lt_compat_l. Lemma opp_le_compat i j : i<=j -> (-j)<=(-i). Proof. apply -> Z.opp_le_mono. Qed. Definition compare := Z.compare. Definition compare_Eq := Z.compare_eq_iff. Lemma compare_Lt i j : compare i j = Lt <-> i i>j. Proof. reflexivity. Qed. Definition le_lt_int := Z.lt_le_pred. End Z_as_Int. Module IntProperties (I:Int). Import I. Local Notation int := I.t. (* Primo, some consequences of being a ring theory... *) Definition two := 1+1. Notation "2" := two : Int_scope. (* Aliases for properties packed in the ring record. *) Definition plus_assoc := ring.(Radd_assoc). Definition plus_comm := ring.(Radd_comm). Definition plus_0_l := ring.(Radd_0_l). Definition mult_assoc := ring.(Rmul_assoc). Definition mult_comm := ring.(Rmul_comm). Definition mult_1_l := ring.(Rmul_1_l). Definition mult_plus_distr_r := ring.(Rdistr_l). Definition opp_def := ring.(Ropp_def). Definition minus_def := ring.(Rsub_def). Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l mult_plus_distr_r opp_def minus_def. (* More facts about plus *) Lemma plus_0_r : forall x, x+0 = x. Proof. intros; rewrite plus_comm; apply plus_0_l. Qed. Lemma plus_0_r_reverse : forall x, x = x+0. Proof. intros; symmetry; apply plus_0_r. Qed. Lemma plus_assoc_reverse : forall x y z, x+y+z = x+(y+z). Proof. intros; symmetry; apply plus_assoc. Qed. Lemma plus_permute : forall x y z, x+(y+z) = y+(x+z). Proof. intros; do 2 rewrite plus_assoc; f_equal; apply plus_comm. Qed. Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z. Proof. intros. rewrite (plus_0_r_reverse y), (plus_0_r_reverse z), <-(opp_def x). now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. Qed. (* More facts about mult *) Lemma mult_assoc_reverse : forall x y z, x*y*z = x*(y*z). Proof. intros; symmetry; apply mult_assoc. Qed. Lemma mult_plus_distr_l : forall x y z, x*(y+z)=x*y+x*z. Proof. intros. rewrite (mult_comm x (y+z)), (mult_comm x y), (mult_comm x z). apply mult_plus_distr_r. Qed. Lemma mult_0_l : forall x, 0*x = 0. Proof. intros. generalize (mult_plus_distr_r 0 1 x). rewrite plus_0_l, mult_1_l, plus_comm; intros. apply plus_reg_l with x. rewrite <- H. apply plus_0_r_reverse. Qed. (* More facts about opp *) Definition plus_opp_r := opp_def. Lemma plus_opp_l : forall x, -x + x = 0. Proof. intros; now rewrite plus_comm, opp_def. Qed. Lemma mult_opp_comm : forall x y, - x * y = x * - y. Proof. intros. apply plus_reg_l with (x*y). rewrite <- mult_plus_distr_l, <- mult_plus_distr_r. now rewrite opp_def, opp_def, mult_0_l, mult_comm, mult_0_l. Qed. Lemma opp_eq_mult_neg_1 : forall x, -x = x * -(1). Proof. intros; now rewrite mult_comm, mult_opp_comm, mult_1_l. Qed. Lemma opp_involutive : forall x, -(-x) = x. Proof. intros. apply plus_reg_l with (-x). now rewrite opp_def, plus_comm, opp_def. Qed. Lemma opp_plus_distr : forall x y, -(x+y) = -x + -y. Proof. intros. apply plus_reg_l with (x+y). rewrite opp_def. rewrite plus_permute. do 2 rewrite plus_assoc. now rewrite (plus_comm (-x)), opp_def, plus_0_l, opp_def. Qed. Lemma opp_mult_distr_r : forall x y, -(x*y) = x * -y. Proof. intros. rewrite <- mult_opp_comm. apply plus_reg_l with (x*y). now rewrite opp_def, <-mult_plus_distr_r, opp_def, mult_0_l. Qed. Lemma egal_left : forall n m, n=m -> n+-m = 0. Proof. intros; subst; apply opp_def. Qed. Lemma ne_left_2 : forall x y : int, x<>y -> 0<>(x + - y). Proof. intros; contradict H. apply (plus_reg_l (-y)). now rewrite plus_opp_l, plus_comm, H. Qed. (* Special lemmas for factorisation. *) Lemma red_factor0 : forall n, n = n*1. Proof. symmetry; rewrite mult_comm; apply mult_1_l. Qed. Lemma red_factor1 : forall n, n+n = n*2. Proof. intros; unfold two. now rewrite mult_comm, mult_plus_distr_r, mult_1_l. Qed. Lemma red_factor2 : forall n m, n + n*m = n * (1+m). Proof. intros; rewrite mult_plus_distr_l. f_equal; now rewrite mult_comm, mult_1_l. Qed. Lemma red_factor3 : forall n m, n*m + n = n*(1+m). Proof. intros; now rewrite plus_comm, red_factor2. Qed. Lemma red_factor4 : forall n m p, n*m + n*p = n*(m+p). Proof. intros; now rewrite mult_plus_distr_l. Qed. Lemma red_factor5 : forall n m , n * 0 + m = m. Proof. intros; now rewrite mult_comm, mult_0_l, plus_0_l. Qed. Definition red_factor6 := plus_0_r_reverse. (* Specialized distributivities *) Hint Rewrite mult_plus_distr_l mult_plus_distr_r mult_assoc : int. Hint Rewrite <- plus_assoc : int. Lemma OMEGA10 : forall v c1 c2 l1 l2 k1 k2 : int, (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). Proof. intros; autorewrite with int; f_equal; now rewrite plus_permute. Qed. Lemma OMEGA11 : forall v1 c1 l1 l2 k1 : int, (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). Proof. intros; now autorewrite with int. Qed. Lemma OMEGA12 : forall v2 c2 l1 l2 k2 : int, l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). Proof. intros; autorewrite with int; now rewrite plus_permute. Qed. Lemma OMEGA13 : forall v l1 l2 x : int, v * -x + l1 + (v * x + l2) = l1 + l2. Proof. intros; autorewrite with int. rewrite plus_permute; f_equal. rewrite plus_assoc. now rewrite <- mult_plus_distr_l, plus_opp_l, mult_comm, mult_0_l, plus_0_l. Qed. Lemma OMEGA15 : forall v c1 c2 l1 l2 k2 : int, v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). Proof. intros; autorewrite with int; f_equal; now rewrite plus_permute. Qed. Lemma OMEGA16 : forall v c l k : int, (v * c + l) * k = v * (c * k) + l * k. Proof. intros; now autorewrite with int. Qed. Lemma sum1 : forall a b c d : int, 0 = a -> 0 = b -> 0 = a * c + b * d. Proof. intros; elim H; elim H0; simpl; auto. now rewrite mult_0_l, mult_0_l, plus_0_l. Qed. (* Secondo, some results about order (and equality) *) Lemma lt_irrefl : forall n, ~ n m False. Proof. intros; elim (lt_irrefl _ (lt_trans _ _ _ H H0)); auto. Qed. Lemma lt_le_weak : forall n m, n n<=m. Proof. intros; rewrite le_lt_iff; intro H'; eapply lt_antisym; eauto. Qed. Lemma le_refl : forall n, n<=n. Proof. intros; rewrite le_lt_iff; apply lt_irrefl; auto. Qed. Lemma le_antisym : forall n m, n<=m -> m<=n -> n=m. Proof. intros n m; do 2 rewrite le_lt_iff; intros. rewrite <- compare_Lt in H0. rewrite <- gt_lt_iff, <- compare_Gt in H. rewrite <- compare_Eq. destruct compare; intuition. Qed. Lemma lt_eq_lt_dec : forall n m, { n ~(m<=n). Proof. intros. rewrite le_lt_iff. destruct (lt_dec n m); intuition. Qed. Lemma le_dec : forall n m: int, { n<=m } + { ~n<=m }. Proof. intros; destruct (lt_dec m n); [right|left]; rewrite le_lt_iff; intuition. Qed. Lemma le_lt_dec : forall n m, { n<=m } + { m true | _ => false end. Lemma beq_iff : forall i j, beq i j = true <-> i=j. Proof. intros; unfold beq; generalize (compare_Eq i j). destruct compare; intuition discriminate. Qed. Lemma beq_true : forall i j, beq i j = true -> i=j. Proof. intros. rewrite <- beq_iff; auto. Qed. Lemma beq_false : forall i j, beq i j = false -> i<>j. Proof. intros. intro H'. rewrite <- beq_iff in H'; rewrite H' in H; discriminate. Qed. Lemma eq_dec : forall n m:int, { n=m } + { n<>m }. Proof. intros; generalize (beq_iff n m); destruct beq; [left|right]; intuition. Qed. Definition bgt i j := match compare i j with Gt => true | _ => false end. Lemma bgt_iff : forall i j, bgt i j = true <-> i>j. Proof. intros; unfold bgt; generalize (compare_Gt i j). destruct compare; intuition discriminate. Qed. Lemma bgt_true : forall i j, bgt i j = true -> i>j. Proof. intros; now rewrite <- bgt_iff. Qed. Lemma bgt_false : forall i j, bgt i j = false -> i<=j. Proof. intros. rewrite le_lt_iff, <-gt_lt_iff, <-bgt_iff; intro H'; now rewrite H' in H. Qed. Lemma le_is_lt_or_eq : forall n m, n<=m -> { n n<>m -> n m<=p -> n<=p. Proof. intros n m p; do 3 rewrite le_lt_iff; intros A B C. destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto. generalize (lt_trans _ _ _ H C); intuition. Qed. (* order and operations *) Lemma le_0_neg : forall n, 0 <= n <-> -n <= 0. Proof. intros. pattern 0 at 2; rewrite <- (mult_0_l (-(1))). rewrite <- opp_eq_mult_neg_1. split; intros. apply opp_le_compat; auto. rewrite <-(opp_involutive 0), <-(opp_involutive n). apply opp_le_compat; auto. Qed. Lemma le_0_neg' : forall n, n <= 0 <-> 0 <= -n. Proof. intros; rewrite le_0_neg, opp_involutive; intuition. Qed. Lemma plus_le_reg_r : forall n m p, n + p <= m + p -> n <= m. Proof. intros. replace n with ((n+p)+-p). replace m with ((m+p)+-p). apply plus_le_compat; auto. apply le_refl. now rewrite <- plus_assoc, opp_def, plus_0_r. now rewrite <- plus_assoc, opp_def, plus_0_r. Qed. Lemma plus_le_lt_compat : forall n m p q, n<=m -> p n+p p n+p -m < -n. Proof. intros n m; do 2 rewrite lt_le_iff; intros H; contradict H. rewrite <-(opp_involutive m), <-(opp_involutive n). apply opp_le_compat; auto. Qed. Lemma lt_0_neg : forall n, 0 < n <-> -n < 0. Proof. intros. pattern 0 at 2; rewrite <- (mult_0_l (-(1))). rewrite <- opp_eq_mult_neg_1. split; intros. apply opp_lt_compat; auto. rewrite <-(opp_involutive 0), <-(opp_involutive n). apply opp_lt_compat; auto. Qed. Lemma lt_0_neg' : forall n, n < 0 <-> 0 < -n. Proof. intros; rewrite lt_0_neg, opp_involutive; intuition. Qed. Lemma mult_lt_0_compat : forall n m, 0 < n -> 0 < m -> 0 < n*m. Proof. intros. rewrite <- (mult_0_l n), mult_comm. apply mult_lt_compat_l; auto. Qed. Lemma mult_integral : forall n m, n * m = 0 -> n = 0 \/ m = 0. Proof. intros. destruct (lt_eq_lt_dec n 0) as [[Hn|Hn]|Hn]; auto; destruct (lt_eq_lt_dec m 0) as [[Hm|Hm]|Hm]; auto; exfalso. rewrite lt_0_neg' in Hn. rewrite lt_0_neg' in Hm. generalize (mult_lt_0_compat _ _ Hn Hm). rewrite <- opp_mult_distr_r, mult_comm, <- opp_mult_distr_r, opp_involutive. rewrite mult_comm, H. exact (lt_irrefl 0). rewrite lt_0_neg' in Hn. generalize (mult_lt_0_compat _ _ Hn Hm). rewrite mult_comm, <- opp_mult_distr_r, mult_comm. rewrite H. rewrite opp_eq_mult_neg_1, mult_0_l. exact (lt_irrefl 0). rewrite lt_0_neg' in Hm. generalize (mult_lt_0_compat _ _ Hn Hm). rewrite <- opp_mult_distr_r. rewrite H. rewrite opp_eq_mult_neg_1, mult_0_l. exact (lt_irrefl 0). generalize (mult_lt_0_compat _ _ Hn Hm). rewrite H. exact (lt_irrefl 0). Qed. Lemma mult_le_compat : forall i j k l, i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l. Proof. intros. destruct (le_is_lt_or_eq _ _ H1). apply le_trans with (i*l). destruct (le_is_lt_or_eq _ _ H0); [ | subst; apply le_refl]. apply lt_le_weak. apply mult_lt_compat_l; auto. generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. rewrite (mult_comm i), (mult_comm j). destruct (le_is_lt_or_eq _ _ H0); [ | subst; do 2 rewrite mult_0_l; apply le_refl]. destruct (le_is_lt_or_eq _ _ H); [ | subst; apply le_refl]. apply lt_le_weak. apply mult_lt_compat_l; auto. subst i. rewrite mult_0_l. generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. destruct (le_is_lt_or_eq _ _ H); [ | subst; rewrite mult_0_l; apply le_refl]. destruct (le_is_lt_or_eq _ _ H0); [ | subst; rewrite mult_comm, mult_0_l; apply le_refl]. apply lt_le_weak. apply mult_lt_0_compat; auto. Qed. Lemma sum5 : forall a b c d : int, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d. Proof. intros. subst b; rewrite mult_0_l, plus_0_r. contradict H. symmetry in H; destruct (mult_integral _ _ H); congruence. Qed. Lemma one_neq_zero : 1 <> 0. Proof. red; intro. symmetry in H. apply (lt_not_eq 0 1); auto. apply lt_0_1. Qed. Lemma minus_one_neq_zero : -(1) <> 0. Proof. apply lt_not_eq. rewrite <- lt_0_neg. apply lt_0_1. Qed. Lemma le_left : forall n m, n <= m -> 0 <= m + - n. Proof. intros. rewrite <- (opp_def m). apply plus_le_compat. apply le_refl. apply opp_le_compat; auto. Qed. Lemma OMEGA2 : forall x y, 0 <= x -> 0 <= y -> 0 <= x + y. Proof. intros. replace 0 with (0+0). apply plus_le_compat; auto. rewrite plus_0_l; auto. Qed. Lemma OMEGA8 : forall x y, 0 <= x -> 0 <= y -> x = - y -> x = 0. Proof. intros. assert (y=-x). subst x; symmetry; apply opp_involutive. clear H1; subst y. destruct (eq_dec 0 x) as [H'|H']; auto. assert (H'':=le_neq_lt _ _ H H'). generalize (plus_le_lt_compat _ _ _ _ H0 H''). rewrite plus_opp_l, plus_0_l. intros. elim (lt_not_eq _ _ H1); auto. Qed. Lemma sum2 : forall a b c d : int, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d. Proof. intros. subst a; rewrite mult_0_l, plus_0_l. rewrite <- (mult_0_l 0). apply mult_le_compat; auto; apply le_refl. Qed. Lemma sum3 : forall a b c d : int, 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d. Proof. intros. rewrite <- (plus_0_l 0). apply plus_le_compat; auto. rewrite <- (mult_0_l 0). apply mult_le_compat; auto; apply le_refl. rewrite <- (mult_0_l 0). apply mult_le_compat; auto; apply le_refl. Qed. Lemma sum4 : forall k : int, k>0 -> 0 <= k. Proof. intros k; rewrite gt_lt_iff; apply lt_le_weak. Qed. (* Lemmas specific to integers (they use lt_le_int) *) Lemma lt_left : forall n m, n < m -> 0 <= m + -(1) + - n. Proof. intros; apply le_left. now rewrite <- le_lt_int. Qed. Lemma lt_left_inv : forall x y, 0 <= y + -(1) + - x -> x < y. Proof. intros. generalize (plus_le_compat _ _ _ _ H (le_refl x)); clear H. now rewrite plus_0_l, <-plus_assoc, plus_opp_l, plus_0_r, le_lt_int. Qed. Lemma OMEGA4 : forall x y z, x > 0 -> y > x -> z * y + x <> 0. Proof. intros. intro H'. rewrite gt_lt_iff in H,H0. destruct (lt_eq_lt_dec z 0) as [[G|G]|G]. rewrite lt_0_neg' in G. generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0). rewrite H'. pattern y at 2; rewrite <-(mult_1_l y), <-mult_plus_distr_r. intros. rewrite le_lt_int in G. rewrite <- opp_plus_distr in G. assert (0 < y) by (apply lt_trans with x; auto). generalize (mult_le_compat _ _ _ _ G (lt_le_weak _ _ H2) (le_refl 0) (le_refl 0)). rewrite mult_0_l, mult_comm, <- opp_mult_distr_r, mult_comm, <-le_0_neg', le_lt_iff. intuition. subst; rewrite mult_0_l, plus_0_l in H'; subst. apply (lt_not_eq _ _ H); auto. apply (lt_not_eq 0 (z*y+x)); auto. rewrite <- (plus_0_l 0). apply plus_lt_compat; auto. apply mult_lt_0_compat; auto. apply lt_trans with x; auto. Qed. Lemma OMEGA19 : forall x, x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). Proof. intros. do 2 rewrite <- le_lt_int. rewrite <- opp_eq_mult_neg_1. destruct (lt_eq_lt_dec 0 x) as [[H'|H']|H']. auto. congruence. right. rewrite <-(mult_0_l (-(1))), <-(opp_eq_mult_neg_1 0). apply opp_lt_compat; auto. Qed. Lemma mult_le_approx : forall n m p, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. Proof. intros n m p. do 2 rewrite gt_lt_iff. do 2 rewrite le_lt_iff; intros. contradict H1. rewrite lt_0_neg' in H1. rewrite lt_0_neg'. rewrite opp_plus_distr. rewrite mult_comm, opp_mult_distr_r. rewrite le_lt_int. rewrite <- plus_assoc, (plus_comm (-p)), plus_assoc. apply lt_left. rewrite le_lt_int. rewrite le_lt_int in H0. apply le_trans with (n+-(1)); auto. apply plus_le_compat; [ | apply le_refl ]. rewrite le_lt_int in H1. generalize (mult_le_compat _ _ _ _ (lt_le_weak _ _ H) H1 (le_refl 0) (le_refl 0)). rewrite mult_0_l. rewrite mult_plus_distr_l. rewrite <- opp_eq_mult_neg_1. intros. generalize (plus_le_compat _ _ _ _ (le_refl n) H2). now rewrite plus_permute, opp_def, plus_0_r, plus_0_r. Qed. (* Some decidabilities *) Lemma dec_eq : forall i j:int, decidable (i=j). Proof. red; intros; destruct (eq_dec i j); auto. Qed. Lemma dec_ne : forall i j:int, decidable (i<>j). Proof. red; intros; destruct (eq_dec i j); auto. Qed. Lemma dec_le : forall i j:int, decidable (i<=j). Proof. red; intros; destruct (le_dec i j); auto. Qed. Lemma dec_lt : forall i j:int, decidable (i=j). Proof. red; intros; rewrite ge_le_iff; destruct (le_dec j i); auto. Qed. Lemma dec_gt : forall i j:int, decidable (i>j). Proof. red; intros; rewrite gt_lt_iff; destruct (lt_dec j i); auto. Qed. End IntProperties. Module IntOmega (I:Int). Import I. Module IP:=IntProperties(I). Import IP. Local Notation int := I.t. (* \subsubsection{Definition of reified integer expressions} Terms are either: \begin{itemize} \item integers [Tint] \item variables [Tvar] \item operation over integers (addition, product, opposite, subtraction) The last two are translated in additions and products. *) Inductive term : Set := | Tint : int -> term | Tplus : term -> term -> term | Tmult : term -> term -> term | Tminus : term -> term -> term | Topp : term -> term | Tvar : nat -> term. Delimit Scope romega_scope with term. Arguments Tint _%I. Arguments Tplus (_ _)%term. Arguments Tmult (_ _)%term. Arguments Tminus (_ _)%term. Arguments Topp _%term. Infix "+" := Tplus : romega_scope. Infix "*" := Tmult : romega_scope. Infix "-" := Tminus : romega_scope. Notation "- x" := (Topp x) : romega_scope. Notation "[ x ]" := (Tvar x) (at level 0) : romega_scope. (* \subsubsection{Definition of reified goals} *) (* Very restricted definition of handled predicates that should be extended to cover a wider set of operations. Taking care of negations and disequations require solving more than a goal in parallel. This is a major improvement over previous versions. *) Inductive proposition : Set := | EqTerm : term -> term -> proposition (* equality between terms *) | LeqTerm : term -> term -> proposition (* less or equal on terms *) | TrueTerm : proposition (* true *) | FalseTerm : proposition (* false *) | Tnot : proposition -> proposition (* negation *) | GeqTerm : term -> term -> proposition | GtTerm : term -> term -> proposition | LtTerm : term -> term -> proposition | NeqTerm : term -> term -> proposition | Tor : proposition -> proposition -> proposition | Tand : proposition -> proposition -> proposition | Timp : proposition -> proposition -> proposition | Tprop : nat -> proposition. (* Definition of goals as a list of hypothesis *) Notation hyps := (list proposition). (* Definition of lists of subgoals (set of open goals) *) Notation lhyps := (list hyps). (* a single goal packed in a subgoal list *) Notation singleton := (fun a : hyps => a :: nil). (* an absurd goal *) Definition absurd := FalseTerm :: nil. (* \subsubsection{Traces for merging equations} This inductive type describes how the monomial of two equations should be merged when the equations are added. For [F_equal], both equations have the same head variable and coefficient must be added, furthermore if coefficients are opposite, [F_cancel] should be used to collapse the term. [F_left] and [F_right] indicate which monomial should be put first in the result *) Inductive t_fusion : Set := | F_equal : t_fusion | F_cancel : t_fusion | F_left : t_fusion | F_right : t_fusion. (* \subsubsection{Rewriting steps to normalize terms} *) Inductive step : Set := (* apply the rewriting steps to both subterms of an operation *) | C_DO_BOTH : step -> step -> step (* apply the rewriting step to the first branch *) | C_LEFT : step -> step (* apply the rewriting step to the second branch *) | C_RIGHT : step -> step (* apply two steps consecutively to a term *) | C_SEQ : step -> step -> step (* empty step *) | C_NOP : step (* the following operations correspond to actual rewriting *) | C_OPP_PLUS : step | C_OPP_OPP : step | C_OPP_MULT_R : step | C_OPP_ONE : step (* This is a special step that reduces the term (computation) *) | C_REDUCE : step | C_MULT_PLUS_DISTR : step | C_MULT_OPP_LEFT : step | C_MULT_ASSOC_R : step | C_PLUS_ASSOC_R : step | C_PLUS_ASSOC_L : step | C_PLUS_PERMUTE : step | C_PLUS_COMM : step | C_RED0 : step | C_RED1 : step | C_RED2 : step | C_RED3 : step | C_RED4 : step | C_RED5 : step | C_RED6 : step | C_MULT_ASSOC_REDUCED : step | C_MINUS : step | C_MULT_COMM : step. (* \subsubsection{Omega steps} *) (* The following inductive type describes steps as they can be found in the trace coming from the decision procedure Omega. *) Inductive t_omega : Set := (* n = 0 and n!= 0 *) | O_CONSTANT_NOT_NUL : nat -> t_omega | O_CONSTANT_NEG : nat -> t_omega (* division and approximation of an equation *) | O_DIV_APPROX : int -> int -> term -> nat -> t_omega -> nat -> t_omega (* no solution because no exact division *) | O_NOT_EXACT_DIVIDE : int -> int -> term -> nat -> nat -> t_omega (* exact division *) | O_EXACT_DIVIDE : int -> term -> nat -> t_omega -> nat -> t_omega | O_SUM : int -> nat -> int -> nat -> list t_fusion -> t_omega -> t_omega | O_CONTRADICTION : nat -> nat -> nat -> t_omega | O_MERGE_EQ : nat -> nat -> nat -> t_omega -> t_omega | O_SPLIT_INEQ : nat -> nat -> t_omega -> t_omega -> t_omega | O_CONSTANT_NUL : nat -> t_omega | O_NEGATE_CONTRADICT : nat -> nat -> t_omega | O_NEGATE_CONTRADICT_INV : nat -> nat -> nat -> t_omega | O_STATE : int -> step -> nat -> nat -> t_omega -> t_omega. (* \subsubsection{Rules for normalizing the hypothesis} *) (* These rules indicate how to normalize useful propositions of each useful hypothesis before the decomposition of hypothesis. The rules include the inversion phase for negation removal. *) Inductive p_step : Set := | P_LEFT : p_step -> p_step | P_RIGHT : p_step -> p_step | P_INVERT : step -> p_step | P_STEP : step -> p_step | P_NOP : p_step. (* List of normalizations to perform : if the type [p_step] had a constructor that indicated visiting both left and right branches, we would be able to restrict ourselves to the case of only one normalization by hypothesis. And since all hypothesis are useful (otherwise they wouldn't be included), we would be able to replace [h_step] by a simple list. *) Inductive h_step : Set := pair_step : nat -> p_step -> h_step. (* \subsubsection{Rules for decomposing the hypothesis} *) (* This type allows navigation in the logical constructors that form the predicats of the hypothesis in order to decompose them. This allows in particular to extract one hypothesis from a conjunction with possibly the right level of negations. *) Inductive direction : Set := | D_left : direction | D_right : direction | D_mono : direction. (* This type allows extracting useful components from hypothesis, either hypothesis generated by splitting a disjonction, or equations. The last constructor indicates how to solve the obtained system via the use of the trace type of Omega [t_omega] *) Inductive e_step : Set := | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step | E_EXTRACT : nat -> list direction -> e_step -> e_step | E_SOLVE : t_omega -> e_step. (* \subsection{Efficient decidable equality} *) (* For each reified data-type, we define an efficient equality test. It is not the one produced by [Decide Equality]. Then we prove two theorem allowing elimination of such equalities : \begin{verbatim} (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2. (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2. \end{verbatim} *) (* \subsubsection{Reified terms} *) Open Scope romega_scope. Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := match t1, t2 with | Tint st1, Tint st2 => beq st1 st2 | (st11 + st12), (st21 + st22) => eq_term st11 st21 && eq_term st12 st22 | (st11 * st12), (st21 * st22) => eq_term st11 st21 && eq_term st12 st22 | (st11 - st12), (st21 - st22) => eq_term st11 st21 && eq_term st12 st22 | (- st1), (- st2) => eq_term st1 st2 | [st1], [st2] => beq_nat st1 st2 | _, _ => false end. Close Scope romega_scope. Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2. Proof. induction t1; destruct t2; simpl in *; try discriminate; (rewrite andb_true_iff; intros (H1,H2)) || intros H; f_equal; auto using beq_true, beq_nat_true. Qed. Theorem eq_term_refl : forall t0 : term, eq_term t0 t0 = true. Proof. induction t0; simpl in *; try (apply andb_true_iff; split); trivial. - now apply beq_iff. - now apply beq_nat_true_iff. Qed. Ltac trivial_case := unfold not; intros; discriminate. Theorem eq_term_false : forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2. Proof. intros t1 t2 H E. subst t2. now rewrite eq_term_refl in H. Qed. (* \subsubsection{Tactiques pour éliminer ces tests} Si on se contente de faire un [Case (eq_typ t1 t2)] on perd totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2]. Initialement, les développements avaient été réalisés avec les tests rendus par [Decide Equality], c'est à dire un test rendant des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un tel test préserve bien l'information voulue mais calculatoirement de telles fonctions sont trop lentes. *) (* Les tactiques définies si après se comportent exactement comme si on avait utilisé le test précédent et fait une elimination dessus. *) Ltac elim_eq_term t1 t2 := let Aux := fresh "Aux" in pattern (eq_term t1 t2); apply bool_eq_ind; intro Aux; [ generalize (eq_term_true t1 t2 Aux); clear Aux | generalize (eq_term_false t1 t2 Aux); clear Aux ]. Ltac elim_beq t1 t2 := let Aux := fresh "Aux" in pattern (beq t1 t2); apply bool_eq_ind; intro Aux; [ generalize (beq_true t1 t2 Aux); clear Aux | generalize (beq_false t1 t2 Aux); clear Aux ]. Ltac elim_bgt t1 t2 := let Aux := fresh "Aux" in pattern (bgt t1 t2); apply bool_eq_ind; intro Aux; [ generalize (bgt_true t1 t2 Aux); clear Aux | generalize (bgt_false t1 t2 Aux); clear Aux ]. (* \subsection{Interprétations} \subsubsection{Interprétation des termes dans Z} *) Fixpoint interp_term (env : list int) (t : term) {struct t} : int := match t with | Tint x => x | (t1 + t2)%term => interp_term env t1 + interp_term env t2 | (t1 * t2)%term => interp_term env t1 * interp_term env t2 | (t1 - t2)%term => interp_term env t1 - interp_term env t2 | (- t)%term => - interp_term env t | [n]%term => nth n env 0 end. (* \subsubsection{Interprétation des prédicats} *) Fixpoint interp_proposition (envp : list Prop) (env : list int) (p : proposition) {struct p} : Prop := match p with | EqTerm t1 t2 => interp_term env t1 = interp_term env t2 | LeqTerm t1 t2 => interp_term env t1 <= interp_term env t2 | TrueTerm => True | FalseTerm => False | Tnot p' => ~ interp_proposition envp env p' | GeqTerm t1 t2 => interp_term env t1 >= interp_term env t2 | GtTerm t1 t2 => interp_term env t1 > interp_term env t2 | LtTerm t1 t2 => interp_term env t1 < interp_term env t2 | NeqTerm t1 t2 => (interp_term env t1)<>(interp_term env t2) | Tor p1 p2 => interp_proposition envp env p1 \/ interp_proposition envp env p2 | Tand p1 p2 => interp_proposition envp env p1 /\ interp_proposition envp env p2 | Timp p1 p2 => interp_proposition envp env p1 -> interp_proposition envp env p2 | Tprop n => nth n envp True end. (* \subsubsection{Inteprétation des listes d'hypothèses} \paragraph{Sous forme de conjonction} Interprétation sous forme d'une conjonction d'hypothèses plus faciles à manipuler individuellement *) Fixpoint interp_hyps (envp : list Prop) (env : list int) (l : hyps) {struct l} : Prop := match l with | nil => True | p' :: l' => interp_proposition envp env p' /\ interp_hyps envp env l' end. (* \paragraph{sous forme de but} C'est cette interpétation que l'on utilise sur le but (car on utilise [Generalize] et qu'une conjonction est forcément lourde (répétition des types dans les conjonctions intermédiaires) *) Fixpoint interp_goal_concl (c : proposition) (envp : list Prop) (env : list int) (l : hyps) {struct l} : Prop := match l with | nil => interp_proposition envp env c | p' :: l' => interp_proposition envp env p' -> interp_goal_concl c envp env l' end. Notation interp_goal := (interp_goal_concl FalseTerm). (* Les théorèmes qui suivent assurent la correspondance entre les deux interprétations. *) Theorem goal_to_hyps : forall (envp : list Prop) (env : list int) (l : hyps), (interp_hyps envp env l -> False) -> interp_goal envp env l. Proof. simple induction l; [ simpl; auto | simpl; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ]. Qed. Theorem hyps_to_goal : forall (envp : list Prop) (env : list int) (l : hyps), interp_goal envp env l -> interp_hyps envp env l -> False. Proof. simple induction l; simpl; [ auto | intros; apply H; elim H1; auto ]. Qed. (* \subsection{Manipulations sur les hypothèses} *) (* \subsubsection{Définitions de base de stabilité pour la réflexion} *) (* Une opération laisse un terme stable si l'égalité est préservée *) Definition term_stable (f : term -> term) := forall (e : list int) (t : term), interp_term e t = interp_term e (f t). (* Une opération est valide sur une hypothèse, si l'hypothèse implique le résultat de l'opération. \emph{Attention : cela ne concerne que des opérations sur les hypothèses et non sur les buts (contravariance)}. On définit la validité pour une opération prenant une ou deux propositions en argument (cela suffit pour omega). *) Definition valid1 (f : proposition -> proposition) := forall (ep : list Prop) (e : list int) (p1 : proposition), interp_proposition ep e p1 -> interp_proposition ep e (f p1). Definition valid2 (f : proposition -> proposition -> proposition) := forall (ep : list Prop) (e : list int) (p1 p2 : proposition), interp_proposition ep e p1 -> interp_proposition ep e p2 -> interp_proposition ep e (f p1 p2). (* Dans cette notion de validité, la fonction prend directement une liste de propositions et rend une nouvelle liste de proposition. On reste contravariant *) Definition valid_hyps (f : hyps -> hyps) := forall (ep : list Prop) (e : list int) (lp : hyps), interp_hyps ep e lp -> interp_hyps ep e (f lp). (* Enfin ce théorème élimine la contravariance et nous ramène à une opération sur les buts *) Theorem valid_goal : forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps), valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l. Proof. intros; simpl; apply goal_to_hyps; intro H1; apply (hyps_to_goal ep env (a l) H0); apply H; assumption. Qed. (* \subsubsection{Généralisation a des listes de buts (disjonctions)} *) Fixpoint interp_list_hyps (envp : list Prop) (env : list int) (l : lhyps) {struct l} : Prop := match l with | nil => False | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l' end. Fixpoint interp_list_goal (envp : list Prop) (env : list int) (l : lhyps) {struct l} : Prop := match l with | nil => True | h :: l' => interp_goal envp env h /\ interp_list_goal envp env l' end. Theorem list_goal_to_hyps : forall (envp : list Prop) (env : list int) (l : lhyps), (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l. Proof. simple induction l; simpl; [ auto | intros h1 l1 H H1; split; [ apply goal_to_hyps; intro H2; apply H1; auto | apply H; intro H2; apply H1; auto ] ]. Qed. Theorem list_hyps_to_goal : forall (envp : list Prop) (env : list int) (l : lhyps), interp_list_goal envp env l -> interp_list_hyps envp env l -> False. Proof. simple induction l; simpl; [ auto | intros h1 l1 H (H1, H2) H3; elim H3; intro H4; [ apply hyps_to_goal with (1 := H1); assumption | auto ] ]. Qed. Definition valid_list_hyps (f : hyps -> lhyps) := forall (ep : list Prop) (e : list int) (lp : hyps), interp_hyps ep e lp -> interp_list_hyps ep e (f lp). Definition valid_list_goal (f : hyps -> lhyps) := forall (ep : list Prop) (e : list int) (lp : hyps), interp_list_goal ep e (f lp) -> interp_goal ep e lp. Theorem goal_valid : forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f. Proof. unfold valid_list_goal; intros f H ep e lp H1; apply goal_to_hyps; intro H2; apply list_hyps_to_goal with (1 := H1); apply (H ep e lp); assumption. Qed. Theorem append_valid : forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 -> interp_list_hyps ep e (l1 ++ l2). Proof. intros ep e; simple induction l1; [ simpl; intros l2 [H| H]; [ contradiction | trivial ] | simpl; intros h1 t1 HR l2 [[H| H]| H]; [ auto | right; apply (HR l2); left; trivial | right; apply (HR l2); right; trivial ] ]. Qed. (* \subsubsection{Opérateurs valides sur les hypothèses} *) (* Extraire une hypothèse de la liste *) Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. Unset Printing Notations. Theorem nth_valid : forall (ep : list Prop) (e : list int) (i : nat) (l : hyps), interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l). Proof. unfold nth_hyps; simple induction i; [ simple induction l; simpl; [ auto | intros; elim H0; auto ] | intros n H; simple induction l; [ simpl; trivial | intros; simpl; apply H; elim H1; auto ] ]. Qed. (* Appliquer une opération (valide) sur deux hypothèses extraites de la liste et ajouter le résultat à la liste. *) Definition apply_oper_2 (i j : nat) (f : proposition -> proposition -> proposition) (l : hyps) := f (nth_hyps i l) (nth_hyps j l) :: l. Theorem apply_oper_2_valid : forall (i j : nat) (f : proposition -> proposition -> proposition), valid2 f -> valid_hyps (apply_oper_2 i j f). Proof. intros i j f Hf; unfold apply_oper_2, valid_hyps; simpl; intros lp Hlp; split; [ apply Hf; apply nth_valid; assumption | assumption ]. Qed. (* Modifier une hypothèse par application d'une opération valide *) Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) (l : hyps) {struct i} : hyps := match l with | nil => nil (A:=proposition) | p :: l' => match i with | O => f p :: l' | S j => p :: apply_oper_1 j f l' end end. Theorem apply_oper_1_valid : forall (i : nat) (f : proposition -> proposition), valid1 f -> valid_hyps (apply_oper_1 i f). Proof. unfold valid_hyps; intros i f Hf ep e; elim i; [ intro lp; case lp; [ simpl; trivial | simpl; intros p l' (H1, H2); split; [ apply Hf with (1 := H1) | assumption ] ] | intros n Hrec lp; case lp; [ simpl; auto | simpl; intros p l' (H1, H2); split; [ assumption | apply Hrec; assumption ] ] ]. Qed. (* \subsubsection{Manipulations de termes} *) (* Les fonctions suivantes permettent d'appliquer une fonction de réécriture sur un sous terme du terme principal. Avec la composition, cela permet de construire des réécritures complexes proches des tactiques de conversion *) Definition apply_left (f : term -> term) (t : term) := match t with | (x + y)%term => (f x + y)%term | (x * y)%term => (f x * y)%term | (- x)%term => (- f x)%term | x => x end. Definition apply_right (f : term -> term) (t : term) := match t with | (x + y)%term => (x + f y)%term | (x * y)%term => (x * f y)%term | x => x end. Definition apply_both (f g : term -> term) (t : term) := match t with | (x + y)%term => (f x + g y)%term | (x * y)%term => (f x * g y)%term | x => x end. (* Les théorèmes suivants montrent la stabilité (conditionnée) des fonctions. *) Theorem apply_left_stable : forall f : term -> term, term_stable f -> term_stable (apply_left f). Proof. unfold term_stable; intros f H e t; case t; auto; simpl; intros; elim H; trivial. Qed. Theorem apply_right_stable : forall f : term -> term, term_stable f -> term_stable (apply_right f). Proof. unfold term_stable; intros f H e t; case t; auto; simpl; intros t0 t1; elim H; trivial. Qed. Theorem apply_both_stable : forall f g : term -> term, term_stable f -> term_stable g -> term_stable (apply_both f g). Proof. unfold term_stable; intros f g H1 H2 e t; case t; auto; simpl; intros t0 t1; elim H1; elim H2; trivial. Qed. Theorem compose_term_stable : forall f g : term -> term, term_stable f -> term_stable g -> term_stable (fun t : term => f (g t)). Proof. unfold term_stable; intros f g Hf Hg e t; elim Hf; apply Hg. Qed. (* \subsection{Les règles de réécriture} *) (* Chacune des règles de réécriture est accompagnée par sa preuve de stabilité. Toutes ces preuves ont la même forme : il faut analyser suivant la forme du terme (élimination de chaque Case). On a besoin d'une élimination uniquement dans les cas d'utilisation d'égalité décidable. Cette tactique itère la décomposition des Case. Elle est constituée de deux fonctions s'appelant mutuellement : \begin{itemize} \item une fonction d'enrobage qui lance la recherche sur le but, \item une fonction récursive qui décompose ce but. Quand elle a trouvé un Case, elle l'élimine. \end{itemize} Les motifs sur les cas sont très imparfaits et dans certains cas, il semble que cela ne marche pas. On aimerait plutot un motif de la forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on utilise le bon type. Chaque élimination introduit correctement exactement le nombre d'hypothèses nécessaires et conserve dans le cas d'une égalité la connaissance du résultat du test en faisant la réécriture. Pour un test de comparaison, on conserve simplement le résultat. Cette fonction déborde très largement la résolution des réécritures simples et fait une bonne partie des preuves des pas de Omega. *) (* \subsubsection{La tactique pour prouver la stabilité} *) Ltac loop t := match t with (* Global *) | (?X1 = ?X2) => loop X1 || loop X2 | (_ -> ?X1) => loop X1 (* Interpretations *) | (interp_hyps _ _ ?X1) => loop X1 | (interp_list_hyps _ _ ?X1) => loop X1 | (interp_proposition _ _ ?X1) => loop X1 | (interp_term _ ?X1) => loop X1 (* Propositions *) | (EqTerm ?X1 ?X2) => loop X1 || loop X2 | (LeqTerm ?X1 ?X2) => loop X1 || loop X2 (* Termes *) | (?X1 + ?X2)%term => loop X1 || loop X2 | (?X1 - ?X2)%term => loop X1 || loop X2 | (?X1 * ?X2)%term => loop X1 || loop X2 | (- ?X1)%term => loop X1 | (Tint ?X1) => loop X1 (* Eliminations *) | match ?X1 with | EqTerm _ _ => _ | LeqTerm _ _ => _ | TrueTerm => _ | FalseTerm => _ | Tnot _ => _ | GeqTerm _ _ => _ | GtTerm _ _ => _ | LtTerm _ _ => _ | NeqTerm _ _ => _ | Tor _ _ => _ | Tand _ _ => _ | Timp _ _ => _ | Tprop _ => _ end => destruct X1; auto; Simplify | match ?X1 with | Tint _ => _ | (_ + _)%term => _ | (_ * _)%term => _ | (_ - _)%term => _ | (- _)%term => _ | [_]%term => _ end => destruct X1; auto; Simplify | (if beq ?X1 ?X2 then _ else _) => let H := fresh "H" in elim_beq X1 X2; intro H; try (rewrite H in *; clear H); simpl; auto; Simplify | (if bgt ?X1 ?X2 then _ else _) => let H := fresh "H" in elim_bgt X1 X2; intro H; simpl; auto; Simplify | (if eq_term ?X1 ?X2 then _ else _) => let H := fresh "H" in elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H); simpl; auto; Simplify | (if _ && _ then _ else _) => rewrite andb_if; Simplify | (if negb _ then _ else _) => rewrite negb_if; Simplify | _ => fail end with Simplify := match goal with | |- ?X1 => try loop X1 | _ => idtac end. Ltac prove_stable x th := match constr:(x) with | ?X1 => unfold term_stable, X1; intros; Simplify; simpl; apply th end. (* \subsubsection{Les règles elle mêmes} *) Definition Tplus_assoc_l (t : term) := match t with | (n + (m + p))%term => (n + m + p)%term | _ => t end. Theorem Tplus_assoc_l_stable : term_stable Tplus_assoc_l. Proof. prove_stable Tplus_assoc_l (ring.(Radd_assoc)). Qed. Definition Tplus_assoc_r (t : term) := match t with | (n + m + p)%term => (n + (m + p))%term | _ => t end. Theorem Tplus_assoc_r_stable : term_stable Tplus_assoc_r. Proof. prove_stable Tplus_assoc_r plus_assoc_reverse. Qed. Definition Tmult_assoc_r (t : term) := match t with | (n * m * p)%term => (n * (m * p))%term | _ => t end. Theorem Tmult_assoc_r_stable : term_stable Tmult_assoc_r. Proof. prove_stable Tmult_assoc_r mult_assoc_reverse. Qed. Definition Tplus_permute (t : term) := match t with | (n + (m + p))%term => (m + (n + p))%term | _ => t end. Theorem Tplus_permute_stable : term_stable Tplus_permute. Proof. prove_stable Tplus_permute plus_permute. Qed. Definition Tplus_comm (t : term) := match t with | (x + y)%term => (y + x)%term | _ => t end. Theorem Tplus_comm_stable : term_stable Tplus_comm. Proof. prove_stable Tplus_comm plus_comm. Qed. Definition Tmult_comm (t : term) := match t with | (x * y)%term => (y * x)%term | _ => t end. Theorem Tmult_comm_stable : term_stable Tmult_comm. Proof. prove_stable Tmult_comm mult_comm. Qed. Definition T_OMEGA10 (t : term) := match t with | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term => if eq_term v v' then (v * Tint (c1 * k1 + c2 * k2)%I + (l1 * Tint k1 + l2 * Tint k2))%term else t | _ => t end. Theorem T_OMEGA10_stable : term_stable T_OMEGA10. Proof. prove_stable T_OMEGA10 OMEGA10. Qed. Definition T_OMEGA11 (t : term) := match t with | ((v1 * Tint c1 + l1) * Tint k1 + l2)%term => (v1 * Tint (c1 * k1) + (l1 * Tint k1 + l2))%term | _ => t end. Theorem T_OMEGA11_stable : term_stable T_OMEGA11. Proof. prove_stable T_OMEGA11 OMEGA11. Qed. Definition T_OMEGA12 (t : term) := match t with | (l1 + (v2 * Tint c2 + l2) * Tint k2)%term => (v2 * Tint (c2 * k2) + (l1 + l2 * Tint k2))%term | _ => t end. Theorem T_OMEGA12_stable : term_stable T_OMEGA12. Proof. prove_stable T_OMEGA12 OMEGA12. Qed. Definition T_OMEGA13 (t : term) := match t with | (v * Tint x + l1 + (v' * Tint x' + l2))%term => if eq_term v v' && beq x (-x') then (l1+l2)%term else t | _ => t end. Theorem T_OMEGA13_stable : term_stable T_OMEGA13. Proof. unfold term_stable, T_OMEGA13; intros; Simplify; simpl; apply OMEGA13. Qed. Definition T_OMEGA15 (t : term) := match t with | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term => if eq_term v v' then (v * Tint (c1 + c2 * k2)%I + (l1 + l2 * Tint k2))%term else t | _ => t end. Theorem T_OMEGA15_stable : term_stable T_OMEGA15. Proof. prove_stable T_OMEGA15 OMEGA15. Qed. Definition T_OMEGA16 (t : term) := match t with | ((v * Tint c + l) * Tint k)%term => (v * Tint (c * k) + l * Tint k)%term | _ => t end. Theorem T_OMEGA16_stable : term_stable T_OMEGA16. Proof. prove_stable T_OMEGA16 OMEGA16. Qed. Definition Tred_factor5 (t : term) := match t with | (x * Tint c + y)%term => if beq c 0 then y else t | _ => t end. Theorem Tred_factor5_stable : term_stable Tred_factor5. Proof. prove_stable Tred_factor5 red_factor5. Qed. Definition Topp_plus (t : term) := match t with | (- (x + y))%term => (- x + - y)%term | _ => t end. Theorem Topp_plus_stable : term_stable Topp_plus. Proof. prove_stable Topp_plus opp_plus_distr. Qed. Definition Topp_opp (t : term) := match t with | (- - x)%term => x | _ => t end. Theorem Topp_opp_stable : term_stable Topp_opp. Proof. prove_stable Topp_opp opp_involutive. Qed. Definition Topp_mult_r (t : term) := match t with | (- (x * Tint k))%term => (x * Tint (- k))%term | _ => t end. Theorem Topp_mult_r_stable : term_stable Topp_mult_r. Proof. prove_stable Topp_mult_r opp_mult_distr_r. Qed. Definition Topp_one (t : term) := match t with | (- x)%term => (x * Tint (-(1)))%term | _ => t end. Theorem Topp_one_stable : term_stable Topp_one. Proof. prove_stable Topp_one opp_eq_mult_neg_1. Qed. Definition Tmult_plus_distr (t : term) := match t with | ((n + m) * p)%term => (n * p + m * p)%term | _ => t end. Theorem Tmult_plus_distr_stable : term_stable Tmult_plus_distr. Proof. prove_stable Tmult_plus_distr mult_plus_distr_r. Qed. Definition Tmult_opp_left (t : term) := match t with | (- x * Tint y)%term => (x * Tint (- y))%term | _ => t end. Theorem Tmult_opp_left_stable : term_stable Tmult_opp_left. Proof. prove_stable Tmult_opp_left mult_opp_comm. Qed. Definition Tmult_assoc_reduced (t : term) := match t with | (n * Tint m * Tint p)%term => (n * Tint (m * p))%term | _ => t end. Theorem Tmult_assoc_reduced_stable : term_stable Tmult_assoc_reduced. Proof. prove_stable Tmult_assoc_reduced mult_assoc_reverse. Qed. Definition Tred_factor0 (t : term) := (t * Tint 1)%term. Theorem Tred_factor0_stable : term_stable Tred_factor0. Proof. prove_stable Tred_factor0 red_factor0. Qed. Definition Tred_factor1 (t : term) := match t with | (x + y)%term => if eq_term x y then (x * Tint 2)%term else t | _ => t end. Theorem Tred_factor1_stable : term_stable Tred_factor1. Proof. prove_stable Tred_factor1 red_factor1. Qed. Definition Tred_factor2 (t : term) := match t with | (x + y * Tint k)%term => if eq_term x y then (x * Tint (1 + k))%term else t | _ => t end. Theorem Tred_factor2_stable : term_stable Tred_factor2. Proof. prove_stable Tred_factor2 red_factor2. Qed. Definition Tred_factor3 (t : term) := match t with | (x * Tint k + y)%term => if eq_term x y then (x * Tint (1 + k))%term else t | _ => t end. Theorem Tred_factor3_stable : term_stable Tred_factor3. Proof. prove_stable Tred_factor3 red_factor3. Qed. Definition Tred_factor4 (t : term) := match t with | (x * Tint k1 + y * Tint k2)%term => if eq_term x y then (x * Tint (k1 + k2))%term else t | _ => t end. Theorem Tred_factor4_stable : term_stable Tred_factor4. Proof. prove_stable Tred_factor4 red_factor4. Qed. Definition Tred_factor6 (t : term) := (t + Tint 0)%term. Theorem Tred_factor6_stable : term_stable Tred_factor6. Proof. prove_stable Tred_factor6 red_factor6. Qed. Definition Tminus_def (t : term) := match t with | (x - y)%term => (x + - y)%term | _ => t end. Theorem Tminus_def_stable : term_stable Tminus_def. Proof. prove_stable Tminus_def minus_def. Qed. (* \subsection{Fonctions de réécriture complexes} *) (* \subsubsection{Fonction de réduction} *) (* Cette fonction réduit un terme dont la forme normale est un entier. Il suffit pour cela d'échanger le constructeur [Tint] avec les opérateurs réifiés. La réduction est ``gratuite''. *) Fixpoint reduce (t : term) : term := match t with | (x + y)%term => match reduce x with | Tint x' => match reduce y with | Tint y' => Tint (x' + y') | y' => (Tint x' + y')%term end | x' => (x' + reduce y)%term end | (x * y)%term => match reduce x with | Tint x' => match reduce y with | Tint y' => Tint (x' * y') | y' => (Tint x' * y')%term end | x' => (x' * reduce y)%term end | (x - y)%term => match reduce x with | Tint x' => match reduce y with | Tint y' => Tint (x' - y') | y' => (Tint x' - y')%term end | x' => (x' - reduce y)%term end | (- x)%term => match reduce x with | Tint x' => Tint (- x') | x' => (- x')%term end | _ => t end. Theorem reduce_stable : term_stable reduce. Proof. unfold term_stable; intros e t; elim t; auto; try (intros t0 H0 t1 H1; simpl; rewrite H0; rewrite H1; (case (reduce t0); [ intro z0; case (reduce t1); intros; auto | intros; auto | intros; auto | intros; auto | intros; auto | intros; auto ])); intros t0 H0; simpl; rewrite H0; case (reduce t0); intros; auto. Qed. (* \subsubsection{Fusions} \paragraph{Fusion de deux équations} *) (* On donne une somme de deux équations qui sont supposées normalisées. Cette fonction prend une trace de fusion en argument et transforme le terme en une équation normalisée. C'est une version très simplifiée du moteur de réécriture [rewrite]. *) Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := match trace with | nil => reduce t | step :: trace' => match step with | F_equal => apply_right (fusion trace') (T_OMEGA10 t) | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA10 t)) | F_left => apply_right (fusion trace') (T_OMEGA11 t) | F_right => apply_right (fusion trace') (T_OMEGA12 t) end end. Theorem fusion_stable : forall trace : list t_fusion, term_stable (fusion trace). Proof. simple induction trace; simpl; [ exact reduce_stable | intros stp l H; case stp; [ apply compose_term_stable; [ apply apply_right_stable; assumption | exact T_OMEGA10_stable ] | unfold term_stable; intros e t1; rewrite T_OMEGA10_stable; rewrite Tred_factor5_stable; apply H | apply compose_term_stable; [ apply apply_right_stable; assumption | exact T_OMEGA11_stable ] | apply compose_term_stable; [ apply apply_right_stable; assumption | exact T_OMEGA12_stable ] ] ]. Qed. (* \paragraph{Fusion de deux équations dont une sans coefficient} *) Definition fusion_right (trace : list t_fusion) (t : term) : term := match trace with | nil => reduce t (* Il faut mettre un compute *) | step :: trace' => match step with | F_equal => apply_right (fusion trace') (T_OMEGA15 t) | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA15 t)) | F_left => apply_right (fusion trace') (Tplus_assoc_r t) | F_right => apply_right (fusion trace') (T_OMEGA12 t) end end. (* \paragraph{Fusion avec annihilation} *) (* Normalement le résultat est une constante *) Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term := match trace with | O => reduce t | S trace' => fusion_cancel trace' (T_OMEGA13 t) end. Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t). Proof. unfold term_stable, fusion_cancel; intros trace e; elim trace; [ exact (reduce_stable e) | intros n H t; elim H; exact (T_OMEGA13_stable e t) ]. Qed. (* \subsubsection{Opérations affines sur une équation} *) (* \paragraph{Multiplication scalaire et somme d'une constante} *) Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term := match trace with | O => reduce t | S trace' => apply_right (scalar_norm_add trace') (T_OMEGA11 t) end. Theorem scalar_norm_add_stable : forall t : nat, term_stable (scalar_norm_add t). Proof. unfold term_stable, scalar_norm_add; intros trace; elim trace; [ exact reduce_stable | intros n H e t; elim apply_right_stable; [ exact (T_OMEGA11_stable e t) | exact H ] ]. Qed. (* \paragraph{Multiplication scalaire} *) Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term := match trace with | O => reduce t | S trace' => apply_right (scalar_norm trace') (T_OMEGA16 t) end. Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t). Proof. unfold term_stable, scalar_norm; intros trace; elim trace; [ exact reduce_stable | intros n H e t; elim apply_right_stable; [ exact (T_OMEGA16_stable e t) | exact H ] ]. Qed. (* \paragraph{Somme d'une constante} *) Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term := match trace with | O => reduce t | S trace' => apply_right (add_norm trace') (Tplus_assoc_r t) end. Theorem add_norm_stable : forall t : nat, term_stable (add_norm t). Proof. unfold term_stable, add_norm; intros trace; elim trace; [ exact reduce_stable | intros n H e t; elim apply_right_stable; [ exact (Tplus_assoc_r_stable e t) | exact H ] ]. Qed. (* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *) Fixpoint t_rewrite (s : step) : term -> term := match s with | C_DO_BOTH s1 s2 => apply_both (t_rewrite s1) (t_rewrite s2) | C_LEFT s => apply_left (t_rewrite s) | C_RIGHT s => apply_right (t_rewrite s) | C_SEQ s1 s2 => fun t : term => t_rewrite s2 (t_rewrite s1 t) | C_NOP => fun t : term => t | C_OPP_PLUS => Topp_plus | C_OPP_OPP => Topp_opp | C_OPP_MULT_R => Topp_mult_r | C_OPP_ONE => Topp_one | C_REDUCE => reduce | C_MULT_PLUS_DISTR => Tmult_plus_distr | C_MULT_OPP_LEFT => Tmult_opp_left | C_MULT_ASSOC_R => Tmult_assoc_r | C_PLUS_ASSOC_R => Tplus_assoc_r | C_PLUS_ASSOC_L => Tplus_assoc_l | C_PLUS_PERMUTE => Tplus_permute | C_PLUS_COMM => Tplus_comm | C_RED0 => Tred_factor0 | C_RED1 => Tred_factor1 | C_RED2 => Tred_factor2 | C_RED3 => Tred_factor3 | C_RED4 => Tred_factor4 | C_RED5 => Tred_factor5 | C_RED6 => Tred_factor6 | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced | C_MINUS => Tminus_def | C_MULT_COMM => Tmult_comm end. Theorem t_rewrite_stable : forall s : step, term_stable (t_rewrite s). Proof. simple induction s; simpl; [ intros; apply apply_both_stable; auto | intros; apply apply_left_stable; auto | intros; apply apply_right_stable; auto | unfold term_stable; intros; elim H0; apply H | unfold term_stable; auto | exact Topp_plus_stable | exact Topp_opp_stable | exact Topp_mult_r_stable | exact Topp_one_stable | exact reduce_stable | exact Tmult_plus_distr_stable | exact Tmult_opp_left_stable | exact Tmult_assoc_r_stable | exact Tplus_assoc_r_stable | exact Tplus_assoc_l_stable | exact Tplus_permute_stable | exact Tplus_comm_stable | exact Tred_factor0_stable | exact Tred_factor1_stable | exact Tred_factor2_stable | exact Tred_factor3_stable | exact Tred_factor4_stable | exact Tred_factor5_stable | exact Tred_factor6_stable | exact Tmult_assoc_reduced_stable | exact Tminus_def_stable | exact Tmult_comm_stable ]. Qed. (* \subsection{tactiques de résolution d'un but omega normalisé} Trace de la procédure \subsubsection{Tactiques générant une contradiction} \paragraph{[O_CONSTANT_NOT_NUL]} *) Definition constant_not_nul (i : nat) (h : hyps) := match nth_hyps i h with | EqTerm (Tint Nul) (Tint n) => if beq n Nul then h else absurd | _ => h end. Theorem constant_not_nul_valid : forall i : nat, valid_hyps (constant_not_nul i). Proof. unfold valid_hyps, constant_not_nul; intros i ep e lp H. generalize (nth_valid ep e i lp H); Simplify. Qed. (* \paragraph{[O_CONSTANT_NEG]} *) Definition constant_neg (i : nat) (h : hyps) := match nth_hyps i h with | LeqTerm (Tint Nul) (Tint Neg) => if bgt Nul Neg then absurd else h | _ => h end. Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i). Proof. unfold valid_hyps, constant_neg; intros; generalize (nth_valid ep e i lp); Simplify; simpl. rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. Qed. (* \paragraph{[NOT_EXACT_DIVIDE]} *) Definition not_exact_divide (k1 k2 : int) (body : term) (t i : nat) (l : hyps) := match nth_hyps i l with | EqTerm (Tint Nul) b => if beq Nul 0 && eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && bgt k2 0 && bgt k1 k2 then absurd else l | _ => l end. Theorem not_exact_divide_valid : forall (k1 k2 : int) (body : term) (t0 i : nat), valid_hyps (not_exact_divide k1 k2 body t0 i). Proof. unfold valid_hyps, not_exact_divide; intros; generalize (nth_valid ep e i lp); Simplify. rewrite (scalar_norm_add_stable t0 e), <-H1. do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros. absurd (interp_term e body * k1 + k2 = 0); [ now apply OMEGA4 | symmetry; auto ]. Qed. (* \paragraph{[O_CONTRADICTION]} *) Definition contradiction (t i j : nat) (l : hyps) := match nth_hyps i l with | LeqTerm (Tint Nul) b1 => match nth_hyps j l with | LeqTerm (Tint Nul') b2 => match fusion_cancel t (b1 + b2)%term with | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k then absurd else l | _ => l end | _ => l end | _ => l end. Theorem contradiction_valid : forall t i j : nat, valid_hyps (contradiction t i j). Proof. unfold valid_hyps, contradiction; intros t i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; auto; case (nth_hyps j l); auto; intros t3 t4; case t3; auto; simpl; intros z z' H1 H2; generalize (eq_refl (interp_term e (fusion_cancel t (t2 + t4)%term))); pattern (fusion_cancel t (t2 + t4)%term) at 2 3; case (fusion_cancel t (t2 + t4)%term); simpl; auto; intro k; elim (fusion_cancel_stable t); simpl. Simplify; intro H3. generalize (OMEGA2 _ _ H2 H1); rewrite H3. rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. Qed. (* \paragraph{[O_NEGATE_CONTRADICT]} *) Definition negate_contradict (i1 i2 : nat) (h : hyps) := match nth_hyps i1 h with | EqTerm (Tint Nul) b1 => match nth_hyps i2 h with | NeqTerm (Tint Nul') b2 => if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 then absurd else h | _ => h end | NeqTerm (Tint Nul) b1 => match nth_hyps i2 h with | EqTerm (Tint Nul') b2 => if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 then absurd else h | _ => h end | _ => h end. Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := match nth_hyps i1 h with | EqTerm (Tint Nul) b1 => match nth_hyps i2 h with | NeqTerm (Tint Nul') b2 => if beq Nul 0 && beq Nul' 0 && eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) then absurd else h | _ => h end | NeqTerm (Tint Nul) b1 => match nth_hyps i2 h with | EqTerm (Tint Nul') b2 => if beq Nul 0 && beq Nul' 0 && eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) then absurd else h | _ => h end | _ => h end. Theorem negate_contradict_valid : forall i j : nat, valid_hyps (negate_contradict i j). Proof. unfold valid_hyps, negate_contradict; intros i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; auto; intros z; auto; case (nth_hyps j l); auto; intros t3 t4; case t3; auto; intros z'; auto; simpl; intros H1 H2; Simplify. Qed. Theorem negate_contradict_inv_valid : forall t i j : nat, valid_hyps (negate_contradict_inv t i j). Proof. unfold valid_hyps, negate_contradict_inv; intros t i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; auto; intros z; auto; case (nth_hyps j l); auto; intros t3 t4; case t3; auto; intros z'; auto; simpl; intros H1 H2; Simplify; [ rewrite <- scalar_norm_stable in H2; simpl in *; elim (mult_integral (interp_term e t4) (-(1))); intuition; elim minus_one_neq_zero; auto | elim H2; clear H2; rewrite <- scalar_norm_stable; simpl in *; now rewrite <- H1, mult_0_l ]. Qed. (* \subsubsection{Tactiques générant une nouvelle équation} *) (* \paragraph{[O_SUM]} C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant les opérateurs de comparaison des deux arguments) d'où une preuve un peu compliquée. On utilise quelques lemmes qui sont des généralisations des théorèmes utilisés par OMEGA. *) Definition sum (k1 k2 : int) (trace : list t_fusion) (prop1 prop2 : proposition) := match prop1 with | EqTerm (Tint Null) b1 => match prop2 with | EqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 then EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm | LeqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 && bgt k2 0 then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm | _ => TrueTerm end | LeqTerm (Tint Null) b1 => if beq Null 0 && bgt k1 0 then match prop2 with | EqTerm (Tint Null') b2 => if beq Null' 0 then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm | LeqTerm (Tint Null') b2 => if beq Null' 0 && bgt k2 0 then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm | _ => TrueTerm end else TrueTerm | NeqTerm (Tint Null) b1 => match prop2 with | EqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 && (negb (beq k1 0)) then NeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm | _ => TrueTerm end | _ => TrueTerm end. Theorem sum_valid : forall (k1 k2 : int) (t : list t_fusion), valid2 (sum k1 k2 t). Proof. unfold valid2; intros k1 k2 t ep e p1 p2; unfold sum; Simplify; simpl; auto; try elim (fusion_stable t); simpl; intros; [ apply sum1; assumption | apply sum2; try assumption; apply sum4; assumption | rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption | apply sum3; try assumption; apply sum4; assumption | apply sum5; auto ]. Qed. (* \paragraph{[O_EXACT_DIVIDE]} c'est une oper1 valide mais on préfère une substitution a ce point la *) Definition exact_divide (k : int) (body : term) (t : nat) (prop : proposition) := match prop with | EqTerm (Tint Null) b => if beq Null 0 && eq_term (scalar_norm t (body * Tint k)%term) b && negb (beq k 0) then EqTerm (Tint 0) body else TrueTerm | NeqTerm (Tint Null) b => if beq Null 0 && eq_term (scalar_norm t (body * Tint k)%term) b && negb (beq k 0) then NeqTerm (Tint 0) body else TrueTerm | _ => TrueTerm end. Theorem exact_divide_valid : forall (k : int) (t : term) (n : nat), valid1 (exact_divide k t n). Proof. unfold valid1, exact_divide; intros k1 k2 t ep e p1; Simplify; simpl; auto; subst; rewrite <- scalar_norm_stable; simpl; intros; [ destruct (mult_integral _ _ (eq_sym H0)); intuition | contradict H0; rewrite <- H0, mult_0_l; auto ]. Qed. (* \paragraph{[O_DIV_APPROX]} La preuve reprend le schéma de la précédente mais on est sur une opération de type valid1 et non sur une opération terminale. *) Definition divide_and_approx (k1 k2 : int) (body : term) (t : nat) (prop : proposition) := match prop with | LeqTerm (Tint Null) b => if beq Null 0 && eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && bgt k1 0 && bgt k1 k2 then LeqTerm (Tint 0) body else prop | _ => prop end. Theorem divide_and_approx_valid : forall (k1 k2 : int) (body : term) (t : nat), valid1 (divide_and_approx k1 k2 body t). Proof. unfold valid1, divide_and_approx; intros k1 k2 body t ep e p1; Simplify; simpl; auto; subst; elim (scalar_norm_add_stable t e); simpl. intro H2; apply mult_le_approx with (3 := H2); assumption. Qed. (* \paragraph{[MERGE_EQ]} *) Definition merge_eq (t : nat) (prop1 prop2 : proposition) := match prop1 with | LeqTerm (Tint Null) b1 => match prop2 with | LeqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 && eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) then EqTerm (Tint 0) b1 else TrueTerm | _ => TrueTerm end | _ => TrueTerm end. Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n). Proof. unfold valid2, merge_eq; intros n ep e p1 p2; Simplify; simpl; auto; elim (scalar_norm_stable n e); simpl; intros; symmetry ; apply OMEGA8 with (2 := H0); [ assumption | elim opp_eq_mult_neg_1; trivial ]. Qed. (* \paragraph{[O_CONSTANT_NUL]} *) Definition constant_nul (i : nat) (h : hyps) := match nth_hyps i h with | NeqTerm (Tint Null) (Tint Null') => if beq Null Null' then absurd else h | _ => h end. Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i). Proof. unfold valid_hyps, constant_nul; intros; generalize (nth_valid ep e i lp); Simplify; simpl; intro H1; absurd (0 = 0); intuition. Qed. (* \paragraph{[O_STATE]} *) Definition state (m : int) (s : step) (prop1 prop2 : proposition) := match prop1 with | EqTerm (Tint Null) b1 => match prop2 with | EqTerm b2 b3 => if beq Null 0 then EqTerm (Tint 0) (t_rewrite s (b1 + (- b3 + b2) * Tint m)%term) else TrueTerm | _ => TrueTerm end | _ => TrueTerm end. Theorem state_valid : forall (m : int) (s : step), valid2 (state m s). Proof. unfold valid2; intros m s ep e p1 p2; unfold state; Simplify; simpl; auto; elim (t_rewrite_stable s e); simpl; intros H1 H2; elim H1. now rewrite H2, plus_opp_l, plus_0_l, mult_0_l. Qed. (* \subsubsection{Tactiques générant plusieurs but} \paragraph{[O_SPLIT_INEQ]} La seule pour le moment (tant que la normalisation n'est pas réfléchie). *) Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) (l : hyps) := match nth_hyps i l with | NeqTerm (Tint Null) b1 => if beq Null 0 then f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-(1)))%term) :: l) ++ f2 (LeqTerm (Tint 0) (scalar_norm_add t (b1 * Tint (-(1)) + Tint (-(1)))%term) :: l) else l :: nil | _ => l :: nil end. Theorem split_ineq_valid : forall (i t : nat) (f1 f2 : hyps -> lhyps), valid_list_hyps f1 -> valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2). Proof. unfold valid_list_hyps, split_ineq; intros i t f1 f2 H1 H2 ep e lp H; generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); simpl; auto; intros t1 t2; case t1; simpl; auto; intros z; simpl; auto; intro H3. Simplify. apply append_valid; elim (OMEGA19 (interp_term e t2)); [ intro H4; left; apply H1; simpl; elim (add_norm_stable t); simpl; auto | intro H4; right; apply H2; simpl; elim (scalar_norm_add_stable t); simpl; auto | generalize H3; unfold not; intros E1 E2; apply E1; symmetry ; trivial ]. Qed. (* \subsection{La fonction de rejeu de la trace} *) Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := match t with | O_CONSTANT_NOT_NUL n => singleton (constant_not_nul n l) | O_CONSTANT_NEG n => singleton (constant_neg n l) | O_DIV_APPROX k1 k2 body t cont n => execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body t) l) | O_NOT_EXACT_DIVIDE k1 k2 body t i => singleton (not_exact_divide k1 k2 body t i l) | O_EXACT_DIVIDE k body t cont n => execute_omega cont (apply_oper_1 n (exact_divide k body t) l) | O_SUM k1 i1 k2 i2 t cont => execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2 t) l) | O_CONTRADICTION t i j => singleton (contradiction t i j l) | O_MERGE_EQ t i1 i2 cont => execute_omega cont (apply_oper_2 i1 i2 (merge_eq t) l) | O_SPLIT_INEQ t i cont1 cont2 => split_ineq i t (execute_omega cont1) (execute_omega cont2) l | O_CONSTANT_NUL i => singleton (constant_nul i l) | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l) | O_NEGATE_CONTRADICT_INV t i j => singleton (negate_contradict_inv t i j l) | O_STATE m s i1 i2 cont => execute_omega cont (apply_oper_2 i1 i2 (state m s) l) end. Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). Proof. simple induction tr; simpl; [ unfold valid_list_hyps; simpl; intros; left; apply (constant_not_nul_valid n ep e lp H) | unfold valid_list_hyps; simpl; intros; left; apply (constant_neg_valid n ep e lp H) | unfold valid_list_hyps, valid_hyps; intros k1 k2 body n t' Ht' m ep e lp H; apply Ht'; apply (apply_oper_1_valid m (divide_and_approx k1 k2 body n) (divide_and_approx_valid k1 k2 body n) ep e lp H) | unfold valid_list_hyps; simpl; intros; left; apply (not_exact_divide_valid _ _ _ _ _ ep e lp H) | unfold valid_list_hyps, valid_hyps; intros k body n t' Ht' m ep e lp H; apply Ht'; apply (apply_oper_1_valid m (exact_divide k body n) (exact_divide_valid k body n) ep e lp H) | unfold valid_list_hyps, valid_hyps; intros k1 i1 k2 i2 trace t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (sum k1 k2 trace) (sum_valid k1 k2 trace) ep e lp H) | unfold valid_list_hyps; simpl; intros; left; apply (contradiction_valid n n0 n1 ep e lp H) | unfold valid_list_hyps, valid_hyps; intros trace i1 i2 t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (merge_eq trace) (merge_eq_valid trace) ep e lp H) | intros t' i k1 H1 k2 H2; unfold valid_list_hyps; simpl; intros ep e lp H; apply (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) H1 H2 ep e lp H) | unfold valid_list_hyps; simpl; intros i ep e lp H; left; apply (constant_nul_valid i ep e lp H) | unfold valid_list_hyps; simpl; intros i j ep e lp H; left; apply (negate_contradict_valid i j ep e lp H) | unfold valid_list_hyps; simpl; intros n i j ep e lp H; left; apply (negate_contradict_inv_valid n i j ep e lp H) | unfold valid_list_hyps, valid_hyps; intros m s i1 i2 t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H) ]. Qed. (* \subsection{Les opérations globales sur le but} \subsubsection{Normalisation} *) Definition move_right (s : step) (p : proposition) := match p with | EqTerm t1 t2 => EqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) | LeqTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t2 + - t1)%term) | GeqTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) | LtTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t2 + Tint (-(1)) + - t1)%term) | GtTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t1 + Tint (-(1)) + - t2)%term) | NeqTerm t1 t2 => NeqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) | p => p end. Theorem move_right_valid : forall s : step, valid1 (move_right s). Proof. unfold valid1, move_right; intros s ep e p; Simplify; simpl; elim (t_rewrite_stable s e); simpl; [ symmetry ; apply egal_left; assumption | intro; apply le_left; assumption | intro; apply le_left; rewrite <- ge_le_iff; assumption | intro; apply lt_left; rewrite <- gt_lt_iff; assumption | intro; apply lt_left; assumption | intro; apply ne_left_2; assumption ]. Qed. Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s). Theorem do_normalize_valid : forall (i : nat) (s : step), valid_hyps (do_normalize i s). Proof. intros; unfold do_normalize; apply apply_oper_1_valid; apply move_right_valid. Qed. Fixpoint do_normalize_list (l : list step) (i : nat) (h : hyps) {struct l} : hyps := match l with | s :: l' => do_normalize_list l' (S i) (do_normalize i s h) | nil => h end. Theorem do_normalize_list_valid : forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i). Proof. simple induction l; simpl; unfold valid_hyps; [ auto | intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl'; apply (do_normalize_valid i a ep e lp); assumption ]. Qed. Theorem normalize_goal : forall (s : list step) (ep : list Prop) (env : list int) (l : hyps), interp_goal ep env (do_normalize_list s 0 l) -> interp_goal ep env l. Proof. intros; apply valid_goal with (2 := H); apply do_normalize_list_valid. Qed. (* \subsubsection{Exécution de la trace} *) Theorem execute_goal : forall (tr : t_omega) (ep : list Prop) (env : list int) (l : hyps), interp_list_goal ep env (execute_omega tr l) -> interp_goal ep env l. Proof. intros; apply (goal_valid (execute_omega tr) (omega_valid tr) ep env l H). Qed. Theorem append_goal : forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), interp_list_goal ep e l1 /\ interp_list_goal ep e l2 -> interp_list_goal ep e (l1 ++ l2). Proof. intros ep e; simple induction l1; [ simpl; intros l2 (H1, H2); assumption | simpl; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ]. Qed. (* A simple decidability checker : if the proposition belongs to the simple grammar describe below then it is decidable. Proof is by induction and uses well known theorem about arithmetic and propositional calculus *) Fixpoint decidability (p : proposition) : bool := match p with | EqTerm _ _ => true | LeqTerm _ _ => true | GeqTerm _ _ => true | GtTerm _ _ => true | LtTerm _ _ => true | NeqTerm _ _ => true | FalseTerm => true | TrueTerm => true | Tnot t => decidability t | Tand t1 t2 => decidability t1 && decidability t2 | Timp t1 t2 => decidability t1 && decidability t2 | Tor t1 t2 => decidability t1 && decidability t2 | Tprop _ => false end. Theorem decidable_correct : forall (ep : list Prop) (e : list int) (p : proposition), decidability p = true -> decidable (interp_proposition ep e p). Proof. simple induction p; simpl; intros; [ apply dec_eq | apply dec_le | left; auto | right; unfold not; auto | apply dec_not; auto | apply dec_ge | apply dec_gt | apply dec_lt | apply dec_ne | apply dec_or; elim andb_prop with (1 := H1); auto | apply dec_and; elim andb_prop with (1 := H1); auto | apply dec_imp; elim andb_prop with (1 := H1); auto | discriminate H ]. Qed. (* An interpretation function for a complete goal with an explicit conclusion. We use an intermediate fixpoint. *) Fixpoint interp_full_goal (envp : list Prop) (env : list int) (c : proposition) (l : hyps) {struct l} : Prop := match l with | nil => interp_proposition envp env c | p' :: l' => interp_proposition envp env p' -> interp_full_goal envp env c l' end. Definition interp_full (ep : list Prop) (e : list int) (lc : hyps * proposition) : Prop := match lc with | (l, c) => interp_full_goal ep e c l end. (* Relates the interpretation of a complete goal with the interpretation of its hypothesis and conclusion *) Theorem interp_full_false : forall (ep : list Prop) (e : list int) (l : hyps) (c : proposition), (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c). Proof. simple induction l; unfold interp_full; simpl; [ auto | intros a l1 H1 c H2 H3; apply H1; auto ]. Qed. (* Push the conclusion in the list of hypothesis using a double negation If the decidability cannot be "proven", then just forget about the conclusion (equivalent of replacing it with false) *) Definition to_contradict (lc : hyps * proposition) := match lc with | (l, c) => if decidability c then Tnot c :: l else l end. (* The previous operation is valid in the sense that the new list of hypothesis implies the original goal *) Theorem to_contradict_valid : forall (ep : list Prop) (e : list int) (lc : hyps * proposition), interp_goal ep e (to_contradict lc) -> interp_full ep e lc. Proof. intros ep e lc; case lc; intros l c; simpl; pattern (decidability c); apply bool_eq_ind; [ simpl; intros H H1; apply interp_full_false; intros H2; apply not_not; [ apply decidable_correct; assumption | unfold not at 1; intro H3; apply hyps_to_goal with (2 := H2); auto ] | intros H1 H2; apply interp_full_false; intro H3; elim hyps_to_goal with (1 := H2); assumption ]. Qed. (* [map_cons x l] adds [x] at the head of each list in [l] (which is a list of lists *) Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} : list (list A) := match l with | nil => nil | l :: ll => (x :: l) :: map_cons A x ll end. (* This function breaks up a list of hypothesis in a list of simpler list of hypothesis that together implie the original one. The goal of all this is to transform the goal in a list of solvable problems. Note that : - we need a way to drive the analysis as some hypotheis may not require a split. - this procedure must be perfectly mimicked by the ML part otherwise hypothesis will get desynchronised and this will be a mess. *) Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps := match nn with | O => ll :: nil | S n => match ll with | nil => nil :: nil | Tor p1 p2 :: l => destructure_hyps n (p1 :: l) ++ destructure_hyps n (p2 :: l) | Tand p1 p2 :: l => destructure_hyps n (p1 :: p2 :: l) | Timp p1 p2 :: l => if decidability p1 then destructure_hyps n (Tnot p1 :: l) ++ destructure_hyps n (p2 :: l) else map_cons _ (Timp p1 p2) (destructure_hyps n l) | Tnot p :: l => match p with | Tnot p1 => if decidability p1 then destructure_hyps n (p1 :: l) else map_cons _ (Tnot (Tnot p1)) (destructure_hyps n l) | Tor p1 p2 => destructure_hyps n (Tnot p1 :: Tnot p2 :: l) | Tand p1 p2 => if decidability p1 then destructure_hyps n (Tnot p1 :: l) ++ destructure_hyps n (Tnot p2 :: l) else map_cons _ (Tnot p) (destructure_hyps n l) | _ => map_cons _ (Tnot p) (destructure_hyps n l) end | x :: l => map_cons _ x (destructure_hyps n l) end end. Theorem map_cons_val : forall (ep : list Prop) (e : list int) (p : proposition) (l : lhyps), interp_proposition ep e p -> interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l). Proof. simple induction l; simpl; [ auto | intros; elim H1; intro H2; auto ]. Qed. Hint Resolve map_cons_val append_valid decidable_correct. Theorem destructure_hyps_valid : forall n : nat, valid_list_hyps (destructure_hyps n). Proof. simple induction n; [ unfold valid_list_hyps; simpl; auto | unfold valid_list_hyps at 2; intros n1 H ep e lp; case lp; [ simpl; auto | intros p l; case p; try (simpl; intros; apply map_cons_val; simpl; elim H0; auto); [ intro p'; case p'; try (simpl; intros; apply map_cons_val; simpl; elim H0; auto); [ simpl; intros p1 (H1, H2); pattern (decidability p1); apply bool_eq_ind; intro H3; [ apply H; simpl; split; [ apply not_not; auto | assumption ] | auto ] | simpl; intros p1 p2 (H1, H2); apply H; simpl; elim not_or with (1 := H1); auto | simpl; intros p1 p2 (H1, H2); pattern (decidability p1); apply bool_eq_ind; intro H3; [ apply append_valid; elim not_and with (2 := H1); [ intro; left; apply H; simpl; auto | intro; right; apply H; simpl; auto | auto ] | auto ] ] | simpl; intros p1 p2 (H1, H2); apply append_valid; (elim H1; intro H3; simpl; [ left | right ]); apply H; simpl; auto | simpl; intros; apply H; simpl; tauto | simpl; intros p1 p2 (H1, H2); pattern (decidability p1); apply bool_eq_ind; intro H3; [ apply append_valid; elim imp_simp with (2 := H1); [ intro H4; left; simpl; apply H; simpl; auto | intro H4; right; simpl; apply H; simpl; auto | auto ] | auto ] ] ] ]. Qed. Definition prop_stable (f : proposition -> proposition) := forall (ep : list Prop) (e : list int) (p : proposition), interp_proposition ep e p <-> interp_proposition ep e (f p). Definition p_apply_left (f : proposition -> proposition) (p : proposition) := match p with | Timp x y => Timp (f x) y | Tor x y => Tor (f x) y | Tand x y => Tand (f x) y | Tnot x => Tnot (f x) | x => x end. Theorem p_apply_left_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_apply_left f). Proof. unfold prop_stable; intros f H ep e p; split; (case p; simpl; auto; intros p1; elim (H ep e p1); tauto). Qed. Definition p_apply_right (f : proposition -> proposition) (p : proposition) := match p with | Timp x y => Timp x (f y) | Tor x y => Tor x (f y) | Tand x y => Tand x (f y) | Tnot x => Tnot (f x) | x => x end. Theorem p_apply_right_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_apply_right f). Proof. unfold prop_stable; intros f H ep e p; split; (case p; simpl; auto; [ intros p1; elim (H ep e p1); tauto | intros p1 p2; elim (H ep e p2); tauto | intros p1 p2; elim (H ep e p2); tauto | intros p1 p2; elim (H ep e p2); tauto ]). Qed. Definition p_invert (f : proposition -> proposition) (p : proposition) := match p with | EqTerm x y => Tnot (f (NeqTerm x y)) | LeqTerm x y => Tnot (f (GtTerm x y)) | GeqTerm x y => Tnot (f (LtTerm x y)) | GtTerm x y => Tnot (f (LeqTerm x y)) | LtTerm x y => Tnot (f (GeqTerm x y)) | NeqTerm x y => Tnot (f (EqTerm x y)) | x => x end. Theorem p_invert_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_invert f). Proof. unfold prop_stable; intros f H ep e p; split; (case p; simpl; auto; [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl; generalize (dec_eq (interp_term e t1) (interp_term e t2)); unfold decidable; tauto | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl; generalize (dec_gt (interp_term e t1) (interp_term e t2)); unfold decidable; rewrite le_lt_iff, <- gt_lt_iff; tauto | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl; generalize (dec_lt (interp_term e t1) (interp_term e t2)); unfold decidable; rewrite ge_le_iff, le_lt_iff; tauto | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl; generalize (dec_gt (interp_term e t1) (interp_term e t2)); unfold decidable; repeat rewrite le_lt_iff; repeat rewrite gt_lt_iff; tauto | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl; generalize (dec_lt (interp_term e t1) (interp_term e t2)); unfold decidable; repeat rewrite ge_le_iff; repeat rewrite le_lt_iff; tauto | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl; generalize (dec_eq (interp_term e t1) (interp_term e t2)); unfold decidable; tauto ]). Qed. Theorem move_right_stable : forall s : step, prop_stable (move_right s). Proof. unfold move_right, prop_stable; intros s ep e p; split; [ Simplify; simpl; elim (t_rewrite_stable s e); simpl; [ symmetry ; apply egal_left; assumption | intro; apply le_left; assumption | intro; apply le_left; rewrite <- ge_le_iff; assumption | intro; apply lt_left; rewrite <- gt_lt_iff; assumption | intro; apply lt_left; assumption | intro; apply ne_left_2; assumption ] | case p; simpl; intros; auto; generalize H; elim (t_rewrite_stable s); simpl; intro H1; [ rewrite (plus_0_r_reverse (interp_term e t1)); rewrite H1; rewrite plus_permute; rewrite plus_opp_r; rewrite plus_0_r; trivial | apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); rewrite plus_opp_r; assumption | rewrite ge_le_iff; apply (fun a b => plus_le_reg_r a b (- interp_term e t1)); rewrite plus_opp_r; assumption | rewrite gt_lt_iff; apply lt_left_inv; assumption | apply lt_left_inv; assumption | unfold not; intro H2; apply H1; rewrite H2; rewrite plus_opp_r; trivial ] ]. Qed. Fixpoint p_rewrite (s : p_step) : proposition -> proposition := match s with | P_LEFT s => p_apply_left (p_rewrite s) | P_RIGHT s => p_apply_right (p_rewrite s) | P_STEP s => move_right s | P_INVERT s => p_invert (move_right s) | P_NOP => fun p : proposition => p end. Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s). Proof. simple induction s; simpl; [ intros; apply p_apply_left_stable; trivial | intros; apply p_apply_right_stable; trivial | intros; apply p_invert_stable; apply move_right_stable | apply move_right_stable | unfold prop_stable; simpl; intros; split; auto ]. Qed. Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps := match l with | nil => lh | pair_step i s :: r => normalize_hyps r (apply_oper_1 i (p_rewrite s) lh) end. Theorem normalize_hyps_valid : forall l : list h_step, valid_hyps (normalize_hyps l). Proof. simple induction l; unfold valid_hyps; simpl; [ auto | intros n_s r; case n_s; intros n s H ep e lp H1; apply H; apply apply_oper_1_valid; [ unfold valid1; intros ep1 e1 p1 H2; elim (p_rewrite_stable s ep1 e1 p1); auto | assumption ] ]. Qed. Theorem normalize_hyps_goal : forall (s : list h_step) (ep : list Prop) (env : list int) (l : hyps), interp_goal ep env (normalize_hyps s l) -> interp_goal ep env l. Proof. intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. Qed. Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} : proposition := match s with | D_left :: l => match p with | Tand x y => extract_hyp_pos l x | _ => p end | D_right :: l => match p with | Tand x y => extract_hyp_pos l y | _ => p end | D_mono :: l => match p with | Tnot x => extract_hyp_neg l x | _ => p end | _ => p end with extract_hyp_neg (s : list direction) (p : proposition) {struct s} : proposition := match s with | D_left :: l => match p with | Tor x y => extract_hyp_neg l x | Timp x y => if decidability x then extract_hyp_pos l x else Tnot p | _ => Tnot p end | D_right :: l => match p with | Tor x y => extract_hyp_neg l y | Timp x y => extract_hyp_neg l y | _ => Tnot p end | D_mono :: l => match p with | Tnot x => if decidability x then extract_hyp_pos l x else Tnot p | _ => Tnot p end | _ => match p with | Tnot x => if decidability x then x else Tnot p | _ => Tnot p end end. Definition co_valid1 (f : proposition -> proposition) := forall (ep : list Prop) (e : list int) (p1 : proposition), interp_proposition ep e (Tnot p1) -> interp_proposition ep e (f p1). Theorem extract_valid : forall s : list direction, valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s). Proof. unfold valid1, co_valid1; simple induction s; [ split; [ simpl; auto | intros ep e p1; case p1; simpl; auto; intro p; pattern (decidability p); apply bool_eq_ind; [ intro H; generalize (decidable_correct ep e p H); unfold decidable; tauto | simpl; auto ] ] | intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto; case p; auto; simpl; intros; (apply H1; tauto) || (apply H2; tauto) || (pattern (decidability p0); apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e p0 H3); unfold decidable; intro H4; apply H1; tauto | intro; tauto ]) ]. Qed. Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := match s with | E_SPLIT i dl s1 s2 => match extract_hyp_pos dl (nth_hyps i h) with | Tor x y => decompose_solve s1 (x :: h) ++ decompose_solve s2 (y :: h) | Tnot (Tand x y) => if decidability x then decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (Tnot y :: h) else h :: nil | Timp x y => if decidability x then decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h) else h::nil | _ => h :: nil end | E_EXTRACT i dl s1 => decompose_solve s1 (extract_hyp_pos dl (nth_hyps i h) :: h) | E_SOLVE t => execute_omega t h end. Theorem decompose_solve_valid : forall s : e_step, valid_list_goal (decompose_solve s). Proof. intro s; apply goal_valid; unfold valid_list_hyps; elim s; simpl; intros; [ cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp))); [ case (extract_hyp_pos l (nth_hyps n lp)); simpl; auto; [ intro p; case p; simpl; auto; intros p1 p2 H2; pattern (decidability p1); apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; apply append_valid; elim H4; intro H5; [ right; apply H0; simpl; tauto | left; apply H; simpl; tauto ] | simpl; auto ] | intros p1 p2 H2; apply append_valid; simpl; elim H2; [ intros H3; left; apply H; simpl; auto | intros H3; right; apply H0; simpl; auto ] | intros p1 p2 H2; pattern (decidability p1); apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; apply append_valid; elim H4; intro H5; [ right; apply H0; simpl; tauto | left; apply H; simpl; tauto ] | simpl; auto ] ] | elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto ] | intros; apply H; simpl; split; [ elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto | auto ] | apply omega_valid with (1 := H) ]. Qed. (* \subsection{La dernière étape qui élimine tous les séquents inutiles} *) Definition valid_lhyps (f : lhyps -> lhyps) := forall (ep : list Prop) (e : list int) (lp : lhyps), interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp). Fixpoint reduce_lhyps (lp : lhyps) : lhyps := match lp with | (FalseTerm :: nil) :: lp' => reduce_lhyps lp' | x :: lp' => x :: reduce_lhyps lp' | nil => nil (A:=hyps) end. Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps. Proof. unfold valid_lhyps; intros ep e lp; elim lp; [ simpl; auto | intros a l HR; elim a; [ simpl; tauto | intros a1 l1; case l1; case a1; simpl; try tauto ] ]. Qed. Theorem do_reduce_lhyps : forall (envp : list Prop) (env : list int) (l : lhyps), interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l. Proof. intros envp env l H; apply list_goal_to_hyps; intro H1; apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid; assumption. Qed. Definition concl_to_hyp (p : proposition) := if decidability p then Tnot p else TrueTerm. Definition do_concl_to_hyp : forall (envp : list Prop) (env : list int) (c : proposition) (l : hyps), interp_goal envp env (concl_to_hyp c :: l) -> interp_goal_concl c envp env l. Proof. simpl; intros envp env c l; induction l as [| a l Hrecl]; [ simpl; unfold concl_to_hyp; pattern (decidability c); apply bool_eq_ind; [ intro H; generalize (decidable_correct envp env c H); unfold decidable; simpl; tauto | simpl; intros H1 H2; elim H2; trivial ] | simpl; tauto ]. Qed. Definition omega_tactic (t1 : e_step) (t2 : list h_step) (c : proposition) (l : hyps) := reduce_lhyps (decompose_solve t1 (normalize_hyps t2 (concl_to_hyp c :: l))). Theorem do_omega : forall (t1 : e_step) (t2 : list h_step) (envp : list Prop) (env : list int) (c : proposition) (l : hyps), interp_list_goal envp env (omega_tactic t1 t2 c l) -> interp_goal_concl c envp env l. Proof. unfold omega_tactic; intros; apply do_concl_to_hyp; apply (normalize_hyps_goal t2); apply (decompose_solve_valid t1); apply do_reduce_lhyps; assumption. Qed. End IntOmega. (* For now, the above modular construction is instanciated on Z, in order to retrieve the initial ROmega. *) Module ZOmega := IntOmega(Z_as_Int). coq-8.6/plugins/romega/refl_omega.ml0000644000175000017500000013731013022274260017051 0ustar mdenesmdenes(************************************************************************* PROJET RNRT Calife - 2001 Author: Pierre Crégut - France Télécom R&D Licence : LGPL version 2.1 *************************************************************************) open Pp open Util open Const_omega module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint) open OmegaSolver (* \section{Useful functions and flags} *) (* Especially useful debugging functions *) let debug = ref false let show_goal gl = if !debug then (); Tacticals.tclIDTAC gl let pp i = print_int i; print_newline (); flush stdout (* More readable than the prefix notation *) let (>>) = Tacticals.tclTHEN let mkApp = Term.mkApp (* \section{Types} \subsection{How to walk in a term} To represent how to get to a proposition. Only choice points are kept (branch to choose in a disjunction and identifier of the disjunctive connector) *) type direction = Left of int | Right of int (* Step to find a proposition (operators are at most binary). A list is a path *) type occ_step = O_left | O_right | O_mono type occ_path = occ_step list let occ_step_eq s1 s2 = match s1, s2 with | O_left, O_left | O_right, O_right | O_mono, O_mono -> true | _ -> false (* chemin identifiant une proposition sous forme du nom de l'hypothèse et d'une liste de pas à partir de la racine de l'hypothèse *) type occurrence = {o_hyp : Names.Id.t; o_path : occ_path} (* \subsection{reifiable formulas} *) type oformula = (* integer *) | Oint of Bigint.bigint (* recognized binary and unary operations *) | Oplus of oformula * oformula | Omult of oformula * oformula | Ominus of oformula * oformula | Oopp of oformula (* an atom in the environment *) | Oatom of int (* weird expression that cannot be translated *) | Oufo of oformula (* Operators for comparison recognized by Omega *) type comparaison = Eq | Leq | Geq | Gt | Lt | Neq (* Type des prédicats réifiés (fragment de calcul propositionnel. Les * quantifications sont externes au langage) *) type oproposition = Pequa of Term.constr * oequation | Ptrue | Pfalse | Pnot of oproposition | Por of int * oproposition * oproposition | Pand of int * oproposition * oproposition | Pimp of int * oproposition * oproposition | Pprop of Term.constr (* Les équations ou propositions atomiques utiles du calcul *) and oequation = { e_comp: comparaison; (* comparaison *) e_left: oformula; (* formule brute gauche *) e_right: oformula; (* formule brute droite *) e_trace: Term.constr; (* tactique de normalisation *) e_origin: occurrence; (* l'hypothèse dont vient le terme *) e_negated: bool; (* vrai si apparait en position nié après normalisation *) e_depends: direction list; (* liste des points de disjonction dont dépend l'accès à l'équation avec la direction (branche) pour y accéder *) e_omega: afine (* la fonction normalisée *) } (* \subsection{Proof context} This environment codes \begin{itemize} \item the terms and propositions that are given as parameters of the reified proof (and are represented as variables in the reified goals) \item translation functions linking the decision procedure and the Coq proof \end{itemize} *) type environment = { (* La liste des termes non reifies constituant l'environnement global *) mutable terms : Term.constr list; (* La meme chose pour les propositions *) mutable props : Term.constr list; (* Les variables introduites par omega *) mutable om_vars : (oformula * int) list; (* Traduction des indices utilisés ici en les indices finaux utilisés par * la tactique Omega après dénombrement des variables utiles *) real_indices : (int,int) Hashtbl.t; mutable cnt_connectors : int; equations : (int,oequation) Hashtbl.t; constructors : (int, occurrence) Hashtbl.t } (* \subsection{Solution tree} Définition d'une solution trouvée par Omega sous la forme d'un identifiant, d'un ensemble d'équation dont dépend la solution et d'une trace *) (* La liste des dépendances est triée et sans redondance *) type solution = { s_index : int; s_equa_deps : int list; s_trace : action list } (* Arbre de solution résolvant complètement un ensemble de systèmes *) type solution_tree = Leaf of solution (* un noeud interne représente un point de branchement correspondant à l'élimination d'un connecteur générant plusieurs buts (typ. disjonction). Le premier argument est l'identifiant du connecteur *) | Tree of int * solution_tree * solution_tree (* Représentation de l'environnement extrait du but initial sous forme de chemins pour extraire des equations ou d'hypothèses *) type context_content = CCHyp of occurrence | CCEqua of int (* \section{Specific utility functions to handle base types} *) (* Nom arbitraire de l'hypothèse codant la négation du but final *) let id_concl = Names.Id.of_string "__goal__" (* Initialisation de l'environnement de réification de la tactique *) let new_environment () = { terms = []; props = []; om_vars = []; cnt_connectors = 0; real_indices = Hashtbl.create 7; equations = Hashtbl.create 7; constructors = Hashtbl.create 7; } (* Génération d'un nom d'équation *) let new_connector_id env = env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors (* Calcul de la branche complémentaire *) let barre = function Left x -> Right x | Right x -> Left x (* Identifiant associé à une branche *) let indice = function Left x | Right x -> x (* Affichage de l'environnement de réification (termes et propositions) *) let print_env_reification env = let rec loop c i = function [] -> str " ===============================\n\n" | t :: l -> let s = Printf.sprintf "(%c%02d)" c i in spc () ++ str s ++ str " := " ++ Printer.pr_lconstr t ++ fnl () ++ loop c (succ i) l in let prop_info = str "ENVIRONMENT OF PROPOSITIONS :" ++ fnl () ++ loop 'P' 0 env.props in let term_info = str "ENVIRONMENT OF TERMS :" ++ fnl () ++ loop 'V' 0 env.terms in Feedback.msg_debug (prop_info ++ fnl () ++ term_info) (* \subsection{Gestion des environnements de variable pour Omega} *) (* generation d'identifiant d'equation pour Omega *) let new_omega_eq, rst_omega_eq = let cpt = ref 0 in (function () -> incr cpt; !cpt), (function () -> cpt:=0) (* generation d'identifiant de variable pour Omega *) let new_omega_var, rst_omega_var = let cpt = ref 0 in (function () -> incr cpt; !cpt), (function () -> cpt:=0) (* Affichage des variables d'un système *) let display_omega_var i = Printf.sprintf "OV%d" i (* Recherche la variable codant un terme pour Omega et crée la variable dans l'environnement si il n'existe pas. Cas ou la variable dans Omega représente le terme d'un monome (le plus souvent un atome) *) let intern_omega env t = begin try List.assoc_f Pervasives.(=) t env.om_vars (* FIXME *) with Not_found -> let v = new_omega_var () in env.om_vars <- (t,v) :: env.om_vars; v end (* Ajout forcé d'un lien entre un terme et une variable Cas où la variable est créée par Omega et où il faut la lier après coup à un atome réifié introduit de force *) let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars (* Récupère le terme associé à une variable *) let unintern_omega env id = let rec loop = function [] -> failwith "unintern" | ((t,j)::l) -> if Int.equal id j then t else loop l in loop env.om_vars (* \subsection{Gestion des environnements de variable pour la réflexion} Gestion des environnements de traduction entre termes des constructions non réifiés et variables des termes reifies. Attention il s'agit de l'environnement initial contenant tout. Il faudra le réduire après calcul des variables utiles. *) let add_reified_atom t env = try List.index0 Term.eq_constr t env.terms with Not_found -> let i = List.length env.terms in env.terms <- env.terms @ [t]; i let get_reified_atom env = try List.nth env.terms with Invalid_argument _ -> failwith "get_reified_atom" (* \subsection{Gestion de l'environnement de proposition pour Omega} *) (* ajout d'une proposition *) let add_prop env t = try List.index0 Term.eq_constr t env.props with Not_found -> let i = List.length env.props in env.props <- env.props @ [t]; i (* accès a une proposition *) let get_prop v env = try List.nth v env with Invalid_argument _ -> failwith "get_prop" (* \subsection{Gestion du nommage des équations} *) (* Ajout d'une equation dans l'environnement de reification *) let add_equation env e = let id = e.e_omega.id in try let _ = Hashtbl.find env.equations id in () with Not_found -> Hashtbl.add env.equations id e (* accès a une equation *) let get_equation env id = try Hashtbl.find env.equations id with Not_found as e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e (* Affichage des termes réifiés *) let rec oprint ch = function | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n) | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2 | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1 | Oatom n -> Printf.fprintf ch "V%02d" n | Oufo x -> Printf.fprintf ch "?" let rec pprint ch = function Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 }) -> let connector = match comp with Eq -> "=" | Leq -> "<=" | Geq -> ">=" | Gt -> ">" | Lt -> "<" | Neq -> "!=" in Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2 | Ptrue -> Printf.fprintf ch "TT" | Pfalse -> Printf.fprintf ch "FF" | Pnot t -> Printf.fprintf ch "not(%a)" pprint t | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2 | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2 | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2 | Pprop c -> Printf.fprintf ch "Prop" let rec weight env = function | Oint _ -> -1 | Oopp c -> weight env c | Omult(c,_) -> weight env c | Oplus _ -> failwith "weight" | Ominus _ -> failwith "weight minus" | Oufo _ -> -1 | Oatom _ as c -> (intern_omega env c) (* \section{Passage entre oformules et représentation interne de Omega} *) (* \subsection{Oformula vers Omega} *) let omega_of_oformula env kind = let rec loop accu = function | Oplus(Omult(v,Oint n),r) -> loop ({v=intern_omega env v; c=n} :: accu) r | Oint n -> let id = new_omega_eq () in (*i tag_equation name id; i*) {kind = kind; body = List.rev accu; constant = n; id = id} | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in loop [] (* \subsection{Omega vers Oformula} *) let oformula_of_omega env af = let rec loop = function | ({v=v; c=n}::r) -> Oplus(Omult(unintern_omega env v,Oint n),loop r) | [] -> Oint af.constant in loop af.body let app f v = mkApp(Lazy.force f,v) (* \subsection{Oformula vers COQ reel} *) let coq_of_formula env t = let rec loop = function | Oplus (t1,t2) -> app Z.plus [| loop t1; loop t2 |] | Oopp t -> app Z.opp [| loop t |] | Omult(t1,t2) -> app Z.mult [| loop t1; loop t2 |] | Oint v -> Z.mk v | Oufo t -> loop t | Oatom var -> (* attention ne traite pas les nouvelles variables si on ne les * met pas dans env.term *) get_reified_atom env var | Ominus(t1,t2) -> app Z.minus [| loop t1; loop t2 |] in loop t (* \subsection{Oformula vers COQ reifié} *) let reified_of_atom env i = try Hashtbl.find env.real_indices i with Not_found -> Printf.printf "Atome %d non trouvé\n" i; Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; raise Not_found let rec reified_of_formula env = function | Oplus (t1,t2) -> app coq_t_plus [| reified_of_formula env t1; reified_of_formula env t2 |] | Oopp t -> app coq_t_opp [| reified_of_formula env t |] | Omult(t1,t2) -> app coq_t_mult [| reified_of_formula env t1; reified_of_formula env t2 |] | Oint v -> app coq_t_int [| Z.mk v |] | Oufo t -> reified_of_formula env t | Oatom i -> app coq_t_var [| mk_nat (reified_of_atom env i) |] | Ominus(t1,t2) -> app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |] let reified_of_formula env f = try reified_of_formula env f with reraise -> oprint stderr f; raise reraise let rec reified_of_proposition env = function Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> app coq_p_eq [| reified_of_formula env t1; reified_of_formula env t2 |] | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> app coq_p_leq [| reified_of_formula env t1; reified_of_formula env t2 |] | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> app coq_p_geq [| reified_of_formula env t1; reified_of_formula env t2 |] | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> app coq_p_gt [| reified_of_formula env t1; reified_of_formula env t2 |] | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) -> app coq_p_lt [| reified_of_formula env t1; reified_of_formula env t2 |] | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> app coq_p_neq [| reified_of_formula env t1; reified_of_formula env t2 |] | Ptrue -> Lazy.force coq_p_true | Pfalse -> Lazy.force coq_p_false | Pnot t -> app coq_p_not [| reified_of_proposition env t |] | Por (_,t1,t2) -> app coq_p_or [| reified_of_proposition env t1; reified_of_proposition env t2 |] | Pand(_,t1,t2) -> app coq_p_and [| reified_of_proposition env t1; reified_of_proposition env t2 |] | Pimp(_,t1,t2) -> app coq_p_imp [| reified_of_proposition env t1; reified_of_proposition env t2 |] | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |] let reified_of_proposition env f = try reified_of_proposition env f with reraise -> pprint stderr f; raise reraise (* \subsection{Omega vers COQ réifié} *) let reified_of_omega env body constant = let coeff_constant = app coq_t_int [| Z.mk constant |] in let mk_coeff {c=c; v=v} t = let coef = app coq_t_mult [| reified_of_formula env (unintern_omega env v); app coq_t_int [| Z.mk c |] |] in app coq_t_plus [|coef; t |] in List.fold_right mk_coeff body coeff_constant let reified_of_omega env body c = try reified_of_omega env body c with reraise -> display_eq display_omega_var (body,c); raise reraise (* \section{Opérations sur les équations} Ces fonctions préparent les traces utilisées par la tactique réfléchie pour faire des opérations de normalisation sur les équations. *) (* \subsection{Extractions des variables d'une équation} *) (* Extraction des variables d'une équation. *) (* Chaque fonction retourne une liste triée sans redondance *) let (@@) = List.merge_uniq compare let rec vars_of_formula = function | Oint _ -> [] | Oplus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) | Omult (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) | Ominus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) | Oopp e -> vars_of_formula e | Oatom i -> [i] | Oufo _ -> [] let rec vars_of_equations = function | [] -> [] | e::l -> (vars_of_formula e.e_left) @@ (vars_of_formula e.e_right) @@ (vars_of_equations l) let rec vars_of_prop = function | Pequa(_,e) -> vars_of_equations [e] | Pnot p -> vars_of_prop p | Por(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) | Pand(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) | Pimp(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) | Pprop _ | Ptrue | Pfalse -> [] (* \subsection{Multiplication par un scalaire} *) let rec scalar n = function Oplus(t1,t2) -> let tac1,t1' = scalar n t1 and tac2,t2' = scalar n t2 in do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], Oplus(t1',t2') | Oopp t -> do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(Bigint.neg n)) | Omult(t1,Oint x) -> do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x)) | Omult(t1,t2) -> CErrors.error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> do_list [], Omult(t,Oint n) | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i) | (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n)) | Ominus _ -> failwith "scalar minus" (* \subsection{Propagation de l'inversion} *) let rec negate = function Oplus(t1,t2) -> let tac1,t1' = negate t1 and tac2,t2' = negate t2 in do_list [Lazy.force coq_c_opp_plus ; (do_both tac1 tac2)], Oplus(t1',t2') | Oopp t -> do_list [Lazy.force coq_c_opp_opp], t | Omult(t1,Oint x) -> do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x)) | Omult(t1,t2) -> CErrors.error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone)) | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i) | Oufo c -> do_list [], Oufo (Oopp c) | Ominus _ -> failwith "negate minus" let norm l = (List.length l) (* \subsection{Mélange (fusion) de deux équations} *) (* \subsubsection{Version avec coefficients} *) let shuffle_path k1 e1 k2 e2 = let rec loop = function (({c=c1;v=v1}::l1) as l1'), (({c=c2;v=v2}::l2) as l2') -> if Int.equal v1 v2 then if Bigint.equal (k1 * c1 + k2 * c2) zero then ( Lazy.force coq_f_cancel :: loop (l1,l2)) else ( Lazy.force coq_f_equal :: loop (l1,l2) ) else if v1 > v2 then ( Lazy.force coq_f_left :: loop(l1,l2')) else ( Lazy.force coq_f_right :: loop(l1',l2)) | ({c=c1;v=v1}::l1), [] -> Lazy.force coq_f_left :: loop(l1,[]) | [],({c=c2;v=v2}::l2) -> Lazy.force coq_f_right :: loop([],l2) | [],[] -> flush stdout; [] in mk_shuffle_list (loop (e1,e2)) (* \subsubsection{Version sans coefficients} *) let rec shuffle env (t1,t2) = match t1,t2 with Oplus(l1,r1), Oplus(l2,r2) -> if weight env l1 > weight env l2 then let l_action,t' = shuffle env (r1,t2) in do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action], Oplus(l1,t') else let l_action,t' = shuffle env (t1,r2) in do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') | Oplus(l1,r1), t2 -> if weight env l1 > weight env t2 then let (l_action,t') = shuffle env (r1,t2) in do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action],Oplus(l1, t') else do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) | t1,Oplus(l2,r2) -> if weight env l2 > weight env t1 then let (l_action,t') = shuffle env (t1,r2) in do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') else do_list [],Oplus(t1,t2) | Oint t1,Oint t2 -> do_list [Lazy.force coq_c_reduce], Oint(t1+t2) | t1,t2 -> if weight env t1 < weight env t2 then do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) else do_list [],Oplus(t1,t2) (* \subsection{Fusion avec réduction} *) let shrink_pair f1 f2 = begin match f1,f2 with Oatom v,Oatom _ -> Lazy.force coq_c_red1, Omult(Oatom v,Oint two) | Oatom v, Omult(_,c2) -> Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint one)) | Omult (v1,c1),Oatom v -> Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint one)) | Omult (Oatom v,c1),Omult (v2,c2) -> Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2)) | t1,t2 -> oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); flush Pervasives.stdout; CErrors.error "shrink.1" end (* \subsection{Calcul d'une sous formule constante} *) let reduce_factor = function Oatom v -> let r = Omult(Oatom v,Oint one) in [Lazy.force coq_c_red0],r | Omult(Oatom v,Oint n) as f -> [],f | Omult(Oatom v,c) -> let rec compute = function Oint n -> n | Oplus(t1,t2) -> compute t1 + compute t2 | _ -> CErrors.error "condense.1" in [Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c)) | t -> CErrors.error "reduce_factor.1" (* \subsection{Réordonnancement} *) let rec condense env = function Oplus(f1,(Oplus(f2,r) as t)) -> if Int.equal (weight env f1) (weight env f2) then begin let shrink_tac,t = shrink_pair f1 f2 in let assoc_tac = Lazy.force coq_c_plus_assoc_l in let tac_list,t' = condense env (Oplus(t,r)) in assoc_tac :: do_left (do_list [shrink_tac]) :: tac_list, t' end else begin let tac,f = reduce_factor f1 in let tac',t' = condense env t in [do_both (do_list tac) (do_list tac')], Oplus(f,t') end | Oplus(f1,Oint n) -> let tac,f1' = reduce_factor f1 in [do_left (do_list tac)],Oplus(f1',Oint n) | Oplus(f1,f2) -> if Int.equal (weight env f1) (weight env f2) then begin let tac_shrink,t = shrink_pair f1 f2 in let tac,t' = condense env t in tac_shrink :: tac,t' end else begin let tac,f = reduce_factor f1 in let tac',t' = condense env f2 in [do_both (do_list tac) (do_list tac')],Oplus(f,t') end | (Oint _ as t)-> [],t | t -> let tac,t' = reduce_factor t in let final = Oplus(t',Oint zero) in tac @ [Lazy.force coq_c_red6], final (* \subsection{Elimination des zéros} *) let rec clear_zero = function Oplus(Omult(Oatom v,Oint n),r) when Bigint.equal n zero -> let tac',t = clear_zero r in Lazy.force coq_c_red5 :: tac',t | Oplus(f,r) -> let tac,t = clear_zero r in (if List.is_empty tac then [] else [do_right (do_list tac)]),Oplus(f,t) | t -> [],t;; (* \subsection{Transformation des hypothèses} *) let rec reduce env = function Oplus(t1,t2) -> let t1', trace1 = reduce env t1 in let t2', trace2 = reduce env t2 in let trace3,t' = shuffle env (t1',t2') in t', do_list [do_both trace1 trace2; trace3] | Ominus(t1,t2) -> let t,trace = reduce env (Oplus(t1, Oopp t2)) in t, do_list [Lazy.force coq_c_minus; trace] | Omult(t1,t2) as t -> let t1', trace1 = reduce env t1 in let t2', trace2 = reduce env t2 in begin match t1',t2' with | (_, Oint n) -> let tac,t' = scalar n t1' in t', do_list [do_both trace1 trace2; tac] | (Oint n,_) -> let tac,t' = scalar n t2' in t', do_list [do_both trace1 trace2; Lazy.force coq_c_mult_comm; tac] | _ -> Oufo t, Lazy.force coq_c_nop end | Oopp t -> let t',trace = reduce env t in let trace',t'' = negate t' in t'', do_list [do_left trace; trace'] | (Oint _ | Oatom _ | Oufo _) as t -> t, Lazy.force coq_c_nop let normalize_linear_term env t = let t1,trace1 = reduce env t in let trace2,t2 = condense env t1 in let trace3,t3 = clear_zero t2 in do_list [trace1; do_list trace2; do_list trace3], t3 (* Cette fonction reproduit très exactement le comportement de [p_invert] *) let negate_oper = function Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = let mk_step t1 t2 f kind = let t = f t1 t2 in let trace, oterm = normalize_linear_term env t in let equa = omega_of_oformula env kind oterm in { e_comp = oper; e_left = t1; e_right = t2; e_negated = negated; e_depends = depends; e_origin = { o_hyp = origin; o_path = List.rev path }; e_trace = trace; e_omega = equa } in try match (if negated then (negate_oper oper) else oper) with | Eq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) EQUA | Neq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) DISE | Leq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o2,Oopp o1)) INEQ | Geq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) INEQ | Lt -> mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint negone),Oopp o1)) INEQ | Gt -> mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2)) INEQ with e when Logic.catchable_exception e -> raise e (* \section{Compilation des hypothèses} *) let rec oformula_of_constr env t = match Z.parse_term t with | Tplus (t1,t2) -> binop env (fun x y -> Oplus(x,y)) t1 t2 | Tminus (t1,t2) -> binop env (fun x y -> Ominus(x,y)) t1 t2 | Tmult (t1,t2) when Z.is_scalar t1 || Z.is_scalar t2 -> binop env (fun x y -> Omult(x,y)) t1 t2 | Topp t -> Oopp(oformula_of_constr env t) | Tsucc t -> Oplus(oformula_of_constr env t, Oint one) | Tnum n -> Oint n | _ -> Oatom (add_reified_atom t env) and binop env c t1 t2 = let t1' = oformula_of_constr env t1 in let t2' = oformula_of_constr env t2 in c t1' t2' and binprop env (neg2,depends,origin,path) add_to_depends neg1 gl c t1 t2 = let i = new_connector_id env in let depends1 = if add_to_depends then Left i::depends else depends in let depends2 = if add_to_depends then Right i::depends else depends in if add_to_depends then Hashtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path}; let t1' = oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in let t2' = oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in (* On numérote le connecteur dans l'environnement. *) c i t1' t2' and mk_equation env ctxt c connector t1 t2 = let t1' = oformula_of_constr env t1 in let t2' = oformula_of_constr env t2 in (* On ajoute l'equation dans l'environnement. *) let omega = normalize_equation env ctxt (connector,t1',t2') in add_equation env omega; Pequa (c,omega) and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = match Z.parse_rel gl c with | Req (t1,t2) -> mk_equation env ctxt c Eq t1 t2 | Rne (t1,t2) -> mk_equation env ctxt c Neq t1 t2 | Rle (t1,t2) -> mk_equation env ctxt c Leq t1 t2 | Rlt (t1,t2) -> mk_equation env ctxt c Lt t1 t2 | Rge (t1,t2) -> mk_equation env ctxt c Geq t1 t2 | Rgt (t1,t2) -> mk_equation env ctxt c Gt t1 t2 | Rtrue -> Ptrue | Rfalse -> Pfalse | Rnot t -> let t' = oproposition_of_constr env (not negated, depends, origin,(O_mono::path)) gl t in Pnot t' | Ror (t1,t2) -> binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2 | Rand (t1,t2) -> binprop env ctxt negated negated gl (fun i x y -> Pand(i,x,y)) t1 t2 | Rimp (t1,t2) -> binprop env ctxt (not negated) (not negated) gl (fun i x y -> Pimp(i,x,y)) t1 t2 | Riff (t1,t2) -> binprop env ctxt negated negated gl (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) | _ -> Pprop c (* Destructuration des hypothèses et de la conclusion *) let reify_gl env gl = let concl = Tacmach.pf_concl gl in let t_concl = Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in if !debug then begin Printf.printf "REIFED PROBLEM\n\n"; Printf.printf " CONCL: "; pprint stdout t_concl; Printf.printf "\n" end; let rec loop = function (i,t) :: lhyps -> let t' = oproposition_of_constr env (false,[],i,[]) gl t in if !debug then begin Printf.printf " %s: " (Names.Id.to_string i); pprint stdout t'; Printf.printf "\n" end; (i,t') :: loop lhyps | [] -> if !debug then print_env_reification env; [] in let t_lhyps = loop (Tacmach.pf_hyps_types gl) in (id_concl,t_concl) :: t_lhyps let rec destructurate_pos_hyp orig list_equations list_depends = function | Pequa (_,e) -> [e :: list_equations] | Ptrue | Pfalse | Pprop _ -> [list_equations] | Pnot t -> destructurate_neg_hyp orig list_equations list_depends t | Por (i,t1,t2) -> let s1 = destructurate_pos_hyp orig list_equations (i::list_depends) t1 in let s2 = destructurate_pos_hyp orig list_equations (i::list_depends) t2 in s1 @ s2 | Pand(i,t1,t2) -> let list_s1 = destructurate_pos_hyp orig list_equations (list_depends) t1 in let rec loop = function le1 :: ll -> destructurate_pos_hyp orig le1 list_depends t2 @ loop ll | [] -> [] in loop list_s1 | Pimp(i,t1,t2) -> let s1 = destructurate_neg_hyp orig list_equations (i::list_depends) t1 in let s2 = destructurate_pos_hyp orig list_equations (i::list_depends) t2 in s1 @ s2 and destructurate_neg_hyp orig list_equations list_depends = function | Pequa (_,e) -> [e :: list_equations] | Ptrue | Pfalse | Pprop _ -> [list_equations] | Pnot t -> destructurate_pos_hyp orig list_equations list_depends t | Pand (i,t1,t2) -> let s1 = destructurate_neg_hyp orig list_equations (i::list_depends) t1 in let s2 = destructurate_neg_hyp orig list_equations (i::list_depends) t2 in s1 @ s2 | Por(_,t1,t2) -> let list_s1 = destructurate_neg_hyp orig list_equations list_depends t1 in let rec loop = function le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll | [] -> [] in loop list_s1 | Pimp(_,t1,t2) -> let list_s1 = destructurate_pos_hyp orig list_equations list_depends t1 in let rec loop = function le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll | [] -> [] in loop list_s1 let destructurate_hyps syst = let rec loop = function (i,t) :: l -> let l_syst1 = destructurate_pos_hyp i [] [] t in let l_syst2 = loop l in List.cartesian (@) l_syst1 l_syst2 | [] -> [[]] in loop syst (* \subsection{Affichage d'un système d'équation} *) (* Affichage des dépendances de système *) let display_depend = function Left i -> Printf.printf " L%d" i | Right i -> Printf.printf " R%d" i let display_systems syst_list = let display_omega om_e = Printf.printf " E%d : %a %s 0\n" om_e.id (fun _ -> display_eq display_omega_var) (om_e.body, om_e.constant) (operator_of_eq om_e.kind) in let display_equation oformula_eq = pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline (); display_omega oformula_eq.e_omega; Printf.printf " Depends on:"; List.iter display_depend oformula_eq.e_depends; Printf.printf "\n Path: %s" (String.concat "" (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M") oformula_eq.e_origin.o_path)); Printf.printf "\n Origin: %s (negated : %s)\n\n" (Names.Id.to_string oformula_eq.e_origin.o_hyp) (if oformula_eq.e_negated then "yes" else "no") in let display_system syst = Printf.printf "=SYSTEM===================================\n"; List.iter display_equation syst in List.iter display_system syst_list (* Extraction des prédicats utilisées dans une trace. Permet ensuite le calcul des hypothèses *) let rec hyps_used_in_trace = function | act :: l -> begin match act with | HYP e -> [e.id] @@ (hyps_used_in_trace l) | SPLIT_INEQ (_,(_,act1),(_,act2)) -> hyps_used_in_trace act1 @@ hyps_used_in_trace act2 | _ -> hyps_used_in_trace l end | [] -> [] (* Extraction des variables déclarées dans une équation. Permet ensuite de les déclarer dans l'environnement de la procédure réflexive et éviter les créations de variable au vol *) let rec variable_stated_in_trace = function | act :: l -> begin match act with | STATE action -> (*i nlle_equa: afine, def: afine, eq_orig: afine, i*) (*i coef: int, var:int i*) action :: variable_stated_in_trace l | SPLIT_INEQ (_,(_,act1),(_,act2)) -> variable_stated_in_trace act1 @ variable_stated_in_trace act2 | _ -> variable_stated_in_trace l end | [] -> [] ;; let add_stated_equations env tree = (* Il faut trier les variables par ordre d'introduction pour ne pas risquer de définir dans le mauvais ordre *) let stated_equations = let cmpvar x y = Pervasives.(-) x.st_var y.st_var in let rec loop = function | Tree(_,t1,t2) -> List.merge cmpvar (loop t1) (loop t2) | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace) in loop tree in let add_env st = (* On retransforme la définition de v en formule reifiée *) let v_def = oformula_of_omega env st.st_def in (* Notez que si l'ordre de création des variables n'est pas respecté, * ca va planter *) let coq_v = coq_of_formula env v_def in let v = add_reified_atom coq_v env in (* Le terme qu'il va falloir introduire *) let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in (* sa représentation sous forme d'équation mais non réifié car on n'a pas * l'environnement pour le faire correctement *) let term_to_reify = (v_def,Oatom v) in (* enregistre le lien entre la variable omega et la variable Coq *) intern_omega_force env (Oatom v) st.st_var; (v, term_to_generalize,term_to_reify,st.st_def.id) in List.map add_env stated_equations (* Calcule la liste des éclatements à réaliser sur les hypothèses nécessaires pour extraire une liste d'équations donnée *) (* PL: experimentally, the result order of the following function seems _very_ crucial for efficiency. No idea why. Do not remove the List.rev or modify the current semantics of Util.List.union (some elements of first arg, then second arg), unless you know what you're doing. *) let rec get_eclatement env = function i :: r -> let l = try (get_equation env i).e_depends with Not_found -> [] in List.union Pervasives.(=) (List.rev l) (get_eclatement env r) | [] -> [] let select_smaller l = let comp (_,x) (_,y) = Pervasives.(-) (List.length x) (List.length y) in try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller" let filter_compatible_systems required systems = let rec select = function (x::l) -> if List.mem x required then select l else if List.mem (barre x) required then raise Exit else x :: select l | [] -> [] in List.map_filter (function (sol, splits) -> try Some (sol, select splits) with Exit -> None) systems let rec equas_of_solution_tree = function Tree(_,t1,t2) -> (equas_of_solution_tree t1)@@(equas_of_solution_tree t2) | Leaf s -> s.s_equa_deps (* [really_useful_prop] pushes useless props in a new Pprop variable *) (* Things get shorter, but may also get wrong, since a Prop is considered to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance Pfalse is decidable. So should not be used on conclusion (??) *) let really_useful_prop l_equa c = let rec real_of = function Pequa(t,_) -> t | Ptrue -> app coq_True [||] | Pfalse -> app coq_False [||] | Pnot t1 -> app coq_not [|real_of t1|] | Por(_,t1,t2) -> app coq_or [|real_of t1; real_of t2|] | Pand(_,t1,t2) -> app coq_and [|real_of t1; real_of t2|] (* Attention : implications sur le lifting des variables à comprendre ! *) | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2) | Pprop t -> t in let rec loop c = match c with Pequa(_,e) -> if List.mem e.e_omega.id l_equa then Some c else None | Ptrue -> None | Pfalse -> None | Pnot t1 -> begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2 | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2 | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2 | Pprop t -> None and binop f t1 t2 = begin match loop t1, loop t2 with None, None -> None | Some t1',Some t2' -> Some (f(t1',t2')) | Some t1',None -> Some (f(t1',Pprop (real_of t2))) | None,Some t2' -> Some (f(Pprop (real_of t1),t2')) end in match loop c with None -> Pprop (real_of c) | Some t -> t let rec display_solution_tree ch = function Leaf t -> output_string ch (Printf.sprintf "%d[%s]" t.s_index (String.concat " " (List.map string_of_int t.s_equa_deps))) | Tree(i,t1,t2) -> Printf.fprintf ch "S%d(%a,%a)" i display_solution_tree t1 display_solution_tree t2 let rec solve_with_constraints all_solutions path = let rec build_tree sol buf = function [] -> Leaf sol | (Left i :: remainder) -> Tree(i, build_tree sol (Left i :: buf) remainder, solve_with_constraints all_solutions (List.rev(Right i :: buf))) | (Right i :: remainder) -> Tree(i, solve_with_constraints all_solutions (List.rev (Left i :: buf)), build_tree sol (Right i :: buf) remainder) in let weighted = filter_compatible_systems path all_solutions in let (winner_sol,winner_deps) = try select_smaller weighted with reraise -> Printf.printf "%d - %d\n" (List.length weighted) (List.length all_solutions); List.iter display_depend path; raise reraise in build_tree winner_sol (List.rev path) winner_deps let find_path {o_hyp=id;o_path=p} env = let rec loop_path = function ([],l) -> Some l | (x1::l1,x2::l2) when occ_step_eq x1 x2 -> loop_path (l1,l2) | _ -> None in let rec loop_id i = function CCHyp{o_hyp=id';o_path=p'} :: l when Names.Id.equal id id' -> begin match loop_path (p',p) with Some r -> i,r | None -> loop_id (succ i) l end | _ :: l -> loop_id (succ i) l | [] -> failwith "find_path" in loop_id 0 env let mk_direction_list l = let trans = function O_left -> coq_d_left | O_right -> coq_d_right | O_mono -> coq_d_mono in mk_list (Lazy.force coq_direction) (List.map (fun d-> Lazy.force(trans d)) l) (* \section{Rejouer l'historique} *) let get_hyp env_hyp i = try List.index0 Pervasives.(=) (CCEqua i) env_hyp with Not_found -> failwith (Printf.sprintf "get_hyp %d" i) let replay_history env env_hyp = let rec loop env_hyp t = match t with | CONTRADICTION (e1,e2) :: l -> let trace = mk_nat (List.length e1.body) in mkApp (Lazy.force coq_s_contradiction, [| trace ; mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> mkApp (Lazy.force coq_s_div_approx, [| Z.mk k; Z.mk d; reified_of_omega env e2.body e2.constant; mk_nat (List.length e2.body); loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |]) | NOT_EXACT_DIVIDE (e1,k) :: l -> let e2_constant = floor_div e1.constant k in let d = e1.constant - e2_constant * k in let e2_body = map_eq_linear (fun c -> c / k) e1.body in mkApp (Lazy.force coq_s_not_exact_divide, [|Z.mk k; Z.mk d; reified_of_omega env e2_body e2_constant; mk_nat (List.length e2_body); mk_nat (get_hyp env_hyp e1.id)|]) | EXACT_DIVIDE (e1,k) :: l -> let e2_body = map_eq_linear (fun c -> c / k) e1.body in let e2_constant = floor_div e1.constant k in mkApp (Lazy.force coq_s_exact_divide, [|Z.mk k; reified_of_omega env e2_body e2_constant; mk_nat (List.length e2_body); loop env_hyp l; mk_nat (get_hyp env_hyp e1.id)|]) | (MERGE_EQ(e3,e1,e2)) :: l -> let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2 in mkApp (Lazy.force coq_s_merge_eq, [| mk_nat (List.length e1.body); mk_nat n1; mk_nat n2; loop (CCEqua e3:: env_hyp) l |]) | SUM(e3,(k1,e1),(k2,e2)) :: l -> let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2.id in let trace = shuffle_path k1 e1.body k2 e2.body in mkApp (Lazy.force coq_s_sum, [| Z.mk k1; mk_nat n1; Z.mk k2; mk_nat n2; trace; (loop (CCEqua e3 :: env_hyp) l) |]) | CONSTANT_NOT_NUL(e,k) :: l -> mkApp (Lazy.force coq_s_constant_not_nul, [| mk_nat (get_hyp env_hyp e) |]) | CONSTANT_NEG(e,k) :: l -> mkApp (Lazy.force coq_s_constant_neg, [| mk_nat (get_hyp env_hyp e) |]) | STATE {st_new_eq=new_eq; st_def =def; st_orig=orig; st_coef=m; st_var=sigma } :: l -> let n1 = get_hyp env_hyp orig.id and n2 = get_hyp env_hyp def.id in let v = unintern_omega env sigma in let o_def = oformula_of_omega env def in let o_orig = oformula_of_omega env orig in let body = Oplus (o_orig,Omult (Oplus (Oopp v,o_def), Oint m)) in let trace,_ = normalize_linear_term env body in mkApp (Lazy.force coq_s_state, [| Z.mk m; trace; mk_nat n1; mk_nat n2; loop (CCEqua new_eq.id :: env_hyp) l |]) | HYP _ :: l -> loop env_hyp l | CONSTANT_NUL e :: l -> mkApp (Lazy.force coq_s_constant_nul, [| mk_nat (get_hyp env_hyp e) |]) | NEGATE_CONTRADICT(e1,e2,true) :: l -> mkApp (Lazy.force coq_s_negate_contradict, [| mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | NEGATE_CONTRADICT(e1,e2,false) :: l -> mkApp (Lazy.force coq_s_negate_contradict_inv, [| mk_nat (List.length e2.body); mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l -> let i = get_hyp env_hyp e.id in let r1 = loop (CCEqua e1 :: env_hyp) l1 in let r2 = loop (CCEqua e2 :: env_hyp) l2 in mkApp (Lazy.force coq_s_split_ineq, [| mk_nat (List.length e.body); mk_nat i; r1 ; r2 |]) | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> loop env_hyp l | (WEAKEN _ ) :: l -> failwith "not_treated" | [] -> failwith "no contradiction" in loop env_hyp let rec decompose_tree env ctxt = function Tree(i,left,right) -> let org = try Hashtbl.find env.constructors i with Not_found -> failwith (Printf.sprintf "Cannot find constructor %d" i) in let (index,path) = find_path org ctxt in let left_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_left]} in let right_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_right]} in app coq_e_split [| mk_nat index; mk_direction_list path; decompose_tree env (left_hyp::ctxt) left; decompose_tree env (right_hyp::ctxt) right |] | Leaf s -> decompose_tree_hyps s.s_trace env ctxt s.s_equa_deps and decompose_tree_hyps trace env ctxt = function [] -> app coq_e_solve [| replay_history env ctxt trace |] | (i::l) -> let equation = try Hashtbl.find env.equations i with Not_found -> failwith (Printf.sprintf "Cannot find equation %d" i) in let (index,path) = find_path equation.e_origin ctxt in let full_path = if equation.e_negated then path @ [O_mono] else path in let cont = decompose_tree_hyps trace env (CCEqua equation.e_omega.id :: ctxt) l in app coq_e_extract [|mk_nat index; mk_direction_list full_path; cont |] (* \section{La fonction principale} *) (* Cette fonction construit la trace pour la procédure de décision réflexive. A partir des résultats de l'extraction des systèmes, elle lance la résolution par Omega, puis l'extraction d'un ensemble minimal de solutions permettant la résolution globale du système et enfin construit la trace qui permet de faire rejouer cette solution par la tactique réflexive. *) let resolution env full_reified_goal systems_list = let num = ref 0 in let solve_system list_eq = let index = !num in let system = List.map (fun eq -> eq.e_omega) list_eq in let trace = simplify_strong (new_omega_eq,new_omega_var,display_omega_var) system in (* calcule les hypotheses utilisées pour la solution *) let vars = hyps_used_in_trace trace in let splits = get_eclatement env vars in if !debug then begin Printf.printf "SYSTEME %d\n" index; display_action display_omega_var trace; print_string "\n Depend :"; List.iter (fun i -> Printf.printf " %d" i) vars; print_string "\n Split points :"; List.iter display_depend splits; Printf.printf "\n------------------------------------\n" end; incr num; {s_index = index; s_trace = trace; s_equa_deps = vars}, splits in if !debug then Printf.printf "\n====================================\n"; let all_solutions = List.map solve_system systems_list in let solution_tree = solve_with_constraints all_solutions [] in if !debug then begin display_solution_tree stdout solution_tree; print_newline() end; (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *) let useful_equa_id = equas_of_solution_tree solution_tree in (* recupere explicitement ces equations *) let equations = List.map (get_equation env) useful_equa_id in let l_hyps' = List.uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in let l_hyps = id_concl :: List.remove Names.Id.equal id_concl l_hyps' in let useful_hyps = List.map (fun id -> List.assoc_f Names.Id.equal id full_reified_goal) l_hyps in let useful_vars = let really_useful_vars = vars_of_equations equations in let concl_vars = vars_of_prop (List.assoc_f Names.Id.equal id_concl full_reified_goal) in really_useful_vars @@ concl_vars in (* variables a introduire *) let to_introduce = add_stated_equations env solution_tree in let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in let l_generalize_arg = List.map (fun (_,t,_,_) -> t) to_introduce in let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in (* L'environnement de base se construit en deux morceaux : - les variables des équations utiles (et de la conclusion) - les nouvelles variables declarées durant les preuves *) let all_vars_env = useful_vars @ stated_vars in let basic_env = let rec loop i = function var :: l -> let t = get_reified_atom env var in Hashtbl.add env.real_indices var i; t :: loop (succ i) l | [] -> [] in loop 0 all_vars_env in let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in (* On peut maintenant généraliser le but : env est a jour *) let l_reified_stated = List.map (fun (_,_,(l,r),_) -> app coq_p_eq [| reified_of_formula env l; reified_of_formula env r |]) to_introduce in let reified_concl = match useful_hyps with (Pnot p) :: _ -> reified_of_proposition env p | _ -> reified_of_proposition env Pfalse in let l_reified_terms = (List.map (fun p -> reified_of_proposition env (really_useful_prop useful_equa_id p)) (List.tl useful_hyps)) in let env_props_reified = mk_plist env.props in let reified_goal = mk_list (Lazy.force coq_proposition) (l_reified_stated @ l_reified_terms) in let reified = app coq_interp_sequent [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in let normalize_equation e = let rec loop = function [] -> app (if e.e_negated then coq_p_invert else coq_p_step) [| e.e_trace |] | ((O_left | O_mono) :: l) -> app coq_p_left [| loop l |] | (O_right :: l) -> app coq_p_right [| loop l |] in let correct_index = let i = List.index0 Names.Id.equal e.e_origin.o_hyp l_hyps in (* PL: it seems that additionally introduced hyps are in the way during normalization, hence this index shifting... *) if Int.equal i 0 then 0 else Pervasives.(+) i (List.length to_introduce) in app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in let normalization_trace = mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in let initial_context = List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) (List.tl l_hyps) in let context = CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in let decompose_tactic = decompose_tree env context solution_tree in Proofview.V82.of_tactic (Tactics.generalize (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps))) >> Proofview.V82.of_tactic (Tactics.change_concl reified) >> Proofview.V82.of_tactic (Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|])) >> show_goal >> Proofview.V82.of_tactic (Tactics.normalise_vm_in_concl) >> (*i Alternatives to the previous line: - Normalisation without VM: Tactics.normalise_in_concl - Skip the conversion check and rely directly on the QED: Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> i*) Proofview.V82.of_tactic (Tactics.apply (Lazy.force coq_I)) let total_reflexive_omega_tactic gl = Coqlib.check_required_library ["Coq";"romega";"ROmega"]; rst_omega_eq (); rst_omega_var (); try let env = new_environment () in let full_reified_goal = reify_gl env gl in let systems_list = destructurate_hyps full_reified_goal in if !debug then display_systems systems_list; resolution env full_reified_goal systems_list gl with NO_CONTRADICTION -> CErrors.error "ROmega can't solve this system" (*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*) coq-8.6/plugins/romega/README0000644000175000017500000000023013022274260015265 0ustar mdenesmdenesThis work was done for the RNRT Project Calife. As such it is distributed under the LGPL licence. Report bugs to : pierre.cregut@francetelecom.com coq-8.6/plugins/romega/g_romega.ml40000644000175000017500000000312313022274260016607 0ustar mdenesmdenes(************************************************************************* PROJET RNRT Calife - 2001 Author: Pierre Crégut - France Télécom R&D Licence : LGPL version 2.1 *************************************************************************) (*i camlp4deps: "grammar/grammar.cma" i*) DECLARE PLUGIN "romega_plugin" open Names open Refl_omega open Constrarg let eval_tactic name = let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in let kn = KerName.make2 (MPfile dp) (Label.make name) in let tac = Tacenv.interp_ltac kn in Tacinterp.eval_tactic tac let romega_tactic l = let tacs = List.map (function | "nat" -> eval_tactic "zify_nat" | "positive" -> eval_tactic "zify_positive" | "N" -> eval_tactic "zify_N" | "Z" -> eval_tactic "zify_op" | s -> CErrors.error ("No ROmega knowledge base for type "^s)) (Util.List.sort_uniquize String.compare l) in Tacticals.New.tclTHEN (Tacticals.New.tclREPEAT (Proofview.tclPROGRESS (Tacticals.New.tclTHENLIST tacs))) (Tacticals.New.tclTHEN (* because of the contradiction process in (r)omega, we'd better leave as little as possible in the conclusion, for an easier decidability argument. *) (Tactics.intros) (Proofview.V82.tactic total_reflexive_omega_tactic)) TACTIC EXTEND romega | [ "romega" ] -> [ romega_tactic [] ] END TACTIC EXTEND romega' | [ "romega" "with" ne_ident_list(l) ] -> [ romega_tactic (List.map Names.Id.to_string l) ] | [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ] END coq-8.6/plugins/romega/romega_plugin.mlpack0000644000175000017500000000004013022274260020425 0ustar mdenesmdenesConst_omega Refl_omega G_romega coq-8.6/plugins/romega/ROmega.v0000644000175000017500000000065613022274260015762 0ustar mdenesmdenes(************************************************************************* PROJET RNRT Calife - 2001 Author: Pierre Crégut - France Télécom R&D Licence : LGPL version 2.1 *************************************************************************) Require Import ReflOmegaCore. Require Export Setoid. Require Export PreOmega. Require Export ZArith_base. Require Import OmegaPlugin. Declare ML Module "romega_plugin".coq-8.6/plugins/romega/vo.itarget0000644000175000017500000000003313022274260016413 0ustar mdenesmdenesReflOmegaCore.vo ROmega.vo coq-8.6/plugins/romega/const_omega.mli0000644000175000017500000001350113022274260017413 0ustar mdenesmdenes(************************************************************************* PROJET RNRT Calife - 2001 Author: Pierre Crégut - France Télécom R&D Licence : LGPL version 2.1 *************************************************************************) (** Coq objects used in romega *) (* from Logic *) val coq_refl_equal : Term.constr lazy_t val coq_and : Term.constr lazy_t val coq_not : Term.constr lazy_t val coq_or : Term.constr lazy_t val coq_True : Term.constr lazy_t val coq_False : Term.constr lazy_t val coq_I : Term.constr lazy_t (* from ReflOmegaCore/ZOmega *) val coq_h_step : Term.constr lazy_t val coq_pair_step : Term.constr lazy_t val coq_p_left : Term.constr lazy_t val coq_p_right : Term.constr lazy_t val coq_p_invert : Term.constr lazy_t val coq_p_step : Term.constr lazy_t val coq_t_int : Term.constr lazy_t val coq_t_plus : Term.constr lazy_t val coq_t_mult : Term.constr lazy_t val coq_t_opp : Term.constr lazy_t val coq_t_minus : Term.constr lazy_t val coq_t_var : Term.constr lazy_t val coq_proposition : Term.constr lazy_t val coq_p_eq : Term.constr lazy_t val coq_p_leq : Term.constr lazy_t val coq_p_geq : Term.constr lazy_t val coq_p_lt : Term.constr lazy_t val coq_p_gt : Term.constr lazy_t val coq_p_neq : Term.constr lazy_t val coq_p_true : Term.constr lazy_t val coq_p_false : Term.constr lazy_t val coq_p_not : Term.constr lazy_t val coq_p_or : Term.constr lazy_t val coq_p_and : Term.constr lazy_t val coq_p_imp : Term.constr lazy_t val coq_p_prop : Term.constr lazy_t val coq_f_equal : Term.constr lazy_t val coq_f_cancel : Term.constr lazy_t val coq_f_left : Term.constr lazy_t val coq_f_right : Term.constr lazy_t val coq_c_do_both : Term.constr lazy_t val coq_c_do_left : Term.constr lazy_t val coq_c_do_right : Term.constr lazy_t val coq_c_do_seq : Term.constr lazy_t val coq_c_nop : Term.constr lazy_t val coq_c_opp_plus : Term.constr lazy_t val coq_c_opp_opp : Term.constr lazy_t val coq_c_opp_mult_r : Term.constr lazy_t val coq_c_opp_one : Term.constr lazy_t val coq_c_reduce : Term.constr lazy_t val coq_c_mult_plus_distr : Term.constr lazy_t val coq_c_opp_left : Term.constr lazy_t val coq_c_mult_assoc_r : Term.constr lazy_t val coq_c_plus_assoc_r : Term.constr lazy_t val coq_c_plus_assoc_l : Term.constr lazy_t val coq_c_plus_permute : Term.constr lazy_t val coq_c_plus_comm : Term.constr lazy_t val coq_c_red0 : Term.constr lazy_t val coq_c_red1 : Term.constr lazy_t val coq_c_red2 : Term.constr lazy_t val coq_c_red3 : Term.constr lazy_t val coq_c_red4 : Term.constr lazy_t val coq_c_red5 : Term.constr lazy_t val coq_c_red6 : Term.constr lazy_t val coq_c_mult_opp_left : Term.constr lazy_t val coq_c_mult_assoc_reduced : Term.constr lazy_t val coq_c_minus : Term.constr lazy_t val coq_c_mult_comm : Term.constr lazy_t val coq_s_constant_not_nul : Term.constr lazy_t val coq_s_constant_neg : Term.constr lazy_t val coq_s_div_approx : Term.constr lazy_t val coq_s_not_exact_divide : Term.constr lazy_t val coq_s_exact_divide : Term.constr lazy_t val coq_s_sum : Term.constr lazy_t val coq_s_state : Term.constr lazy_t val coq_s_contradiction : Term.constr lazy_t val coq_s_merge_eq : Term.constr lazy_t val coq_s_split_ineq : Term.constr lazy_t val coq_s_constant_nul : Term.constr lazy_t val coq_s_negate_contradict : Term.constr lazy_t val coq_s_negate_contradict_inv : Term.constr lazy_t val coq_direction : Term.constr lazy_t val coq_d_left : Term.constr lazy_t val coq_d_right : Term.constr lazy_t val coq_d_mono : Term.constr lazy_t val coq_e_split : Term.constr lazy_t val coq_e_extract : Term.constr lazy_t val coq_e_solve : Term.constr lazy_t val coq_interp_sequent : Term.constr lazy_t val coq_do_omega : Term.constr lazy_t (** Building expressions *) val do_left : Term.constr -> Term.constr val do_right : Term.constr -> Term.constr val do_both : Term.constr -> Term.constr -> Term.constr val do_seq : Term.constr -> Term.constr -> Term.constr val do_list : Term.constr list -> Term.constr val mk_nat : int -> Term.constr (** Precondition: the type of the list is in Set *) val mk_list : Term.constr -> Term.constr list -> Term.constr val mk_plist : Term.types list -> Term.types val mk_shuffle_list : Term.constr list -> Term.constr (** Analyzing a coq term *) (* The generic result shape of the analysis of a term. One-level depth, except when a number is found *) type parse_term = Tplus of Term.constr * Term.constr | Tmult of Term.constr * Term.constr | Tminus of Term.constr * Term.constr | Topp of Term.constr | Tsucc of Term.constr | Tnum of Bigint.bigint | Tother (* The generic result shape of the analysis of a relation. One-level depth. *) type parse_rel = Req of Term.constr * Term.constr | Rne of Term.constr * Term.constr | Rlt of Term.constr * Term.constr | Rle of Term.constr * Term.constr | Rgt of Term.constr * Term.constr | Rge of Term.constr * Term.constr | Rtrue | Rfalse | Rnot of Term.constr | Ror of Term.constr * Term.constr | Rand of Term.constr * Term.constr | Rimp of Term.constr * Term.constr | Riff of Term.constr * Term.constr | Rother (* A module factorizing what we should now about the number representation *) module type Int = sig (* the coq type of the numbers *) val typ : Term.constr Lazy.t (* the operations on the numbers *) val plus : Term.constr Lazy.t val mult : Term.constr Lazy.t val opp : Term.constr Lazy.t val minus : Term.constr Lazy.t (* building a coq number *) val mk : Bigint.bigint -> Term.constr (* parsing a term (one level, except if a number is found) *) val parse_term : Term.constr -> parse_term (* parsing a relation expression, including = < <= >= > *) val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel (* Is a particular term only made of numbers and + * - ? *) val is_scalar : Term.constr -> bool end (* Currently, we only use Z numbers *) module Z : Int coq-8.6/plugins/nsatz/0000755000175000017500000000000013022274260014277 5ustar mdenesmdenescoq-8.6/plugins/nsatz/polynom.mli0000644000175000017500000000574613022274260016513 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> bool val lt : t -> t -> bool val le : t -> t -> bool val abs : t -> t val plus : t -> t -> t val mult : t -> t -> t val sub : t -> t -> t val opp : t -> t val div : t -> t -> t val modulo : t -> t -> t val puis : t -> int -> t val pgcd : t -> t -> t val hash : t -> int val of_num : Num.num -> t val to_string : t -> string end module type S = sig type coef type variable = int type t = Pint of coef | Prec of variable * t array val of_num : Num.num -> t val x : variable -> t val monome : variable -> int -> t val is_constantP : t -> bool val is_zero : t -> bool val max_var_pol : t -> variable val max_var_pol2 : t -> variable val max_var : t array -> variable val equal : t -> t -> bool val norm : t -> t val deg : variable -> t -> int val deg_total : t -> int val copyP : t -> t val coef : variable -> int -> t -> t val plusP : t -> t -> t val content : t -> coef val div_int : t -> coef -> t val vire_contenu : t -> t val vars : t -> variable list val int_of_Pint : t -> coef val multx : int -> variable -> t -> t val multP : t -> t -> t val deriv : variable -> t -> t val oppP : t -> t val moinsP : t -> t -> t val puisP : t -> int -> t val ( @@ ) : t -> t -> t val ( -- ) : t -> t -> t val ( ^^ ) : t -> int -> t val coefDom : variable -> t -> t val coefConst : variable -> t -> t val remP : variable -> t -> t val coef_int_tete : t -> coef val normc : t -> t val coef_constant : t -> coef val univ : bool ref val string_of_var : int -> string val nsP : int ref val to_string : t -> string val printP : t -> unit val print_tpoly : t array -> unit val print_lpoly : t list -> unit val quo_rem_pol : t -> t -> variable -> t * t val div_pol : t -> t -> variable -> t val divP : t -> t -> t val div_pol_rat : t -> t -> bool val pseudo_div : t -> t -> variable -> t * t * int * t val pgcdP : t -> t -> t val pgcd_pol : t -> t -> variable -> t val content_pol : t -> variable -> t val pgcd_coef_pol : t -> t -> variable -> t val pgcd_pol_rec : t -> t -> variable -> t val gcd_sub_res : t -> t -> variable -> t val gcd_sub_res_rec : t -> t -> t -> t -> int -> variable -> t val lazard_power : t -> t -> int -> variable -> t val hash : t -> int module Hashpol : Hashtbl.S with type key=t end module Make (C:Coef) : S with type coef = C.t coq-8.6/plugins/nsatz/nsatz_plugin.mlpack0000644000175000017500000000004213022274260020201 0ustar mdenesmdenesUtile Polynom Ideal Nsatz G_nsatz coq-8.6/plugins/nsatz/polynom.ml0000644000175000017500000004134513022274260016335 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> bool val lt : t -> t -> bool val le : t -> t -> bool val abs : t -> t val plus : t -> t -> t val mult : t -> t -> t val sub : t -> t -> t val opp : t -> t val div : t -> t -> t val modulo : t -> t -> t val puis : t -> int -> t val pgcd : t -> t -> t val hash : t -> int val of_num : Num.num -> t val to_string : t -> string end module type S = sig type coef type variable = int type t = Pint of coef | Prec of variable * t array val of_num : Num.num -> t val x : variable -> t val monome : variable -> int -> t val is_constantP : t -> bool val is_zero : t -> bool val max_var_pol : t -> variable val max_var_pol2 : t -> variable val max_var : t array -> variable val equal : t -> t -> bool val norm : t -> t val deg : variable -> t -> int val deg_total : t -> int val copyP : t -> t val coef : variable -> int -> t -> t val plusP : t -> t -> t val content : t -> coef val div_int : t -> coef -> t val vire_contenu : t -> t val vars : t -> variable list val int_of_Pint : t -> coef val multx : int -> variable -> t -> t val multP : t -> t -> t val deriv : variable -> t -> t val oppP : t -> t val moinsP : t -> t -> t val puisP : t -> int -> t val ( @@ ) : t -> t -> t val ( -- ) : t -> t -> t val ( ^^ ) : t -> int -> t val coefDom : variable -> t -> t val coefConst : variable -> t -> t val remP : variable -> t -> t val coef_int_tete : t -> coef val normc : t -> t val coef_constant : t -> coef val univ : bool ref val string_of_var : int -> string val nsP : int ref val to_string : t -> string val printP : t -> unit val print_tpoly : t array -> unit val print_lpoly : t list -> unit val quo_rem_pol : t -> t -> variable -> t * t val div_pol : t -> t -> variable -> t val divP : t -> t -> t val div_pol_rat : t -> t -> bool val pseudo_div : t -> t -> variable -> t * t * int * t val pgcdP : t -> t -> t val pgcd_pol : t -> t -> variable -> t val content_pol : t -> variable -> t val pgcd_coef_pol : t -> t -> variable -> t val pgcd_pol_rec : t -> t -> variable -> t val gcd_sub_res : t -> t -> variable -> t val gcd_sub_res_rec : t -> t -> t -> t -> int -> variable -> t val lazard_power : t -> t -> int -> variable -> t val hash : t -> int module Hashpol : Hashtbl.S with type key=t end (*********************************************************************** 2. Type of polynomials, operations. *) module Make (C:Coef) = struct type coef = C.t let coef_of_int i = C.of_num (Num.Int i) let coef0 = coef_of_int 0 let coef1 = coef_of_int 1 type variable = int type t = Pint of coef (* constant polynomial *) | Prec of variable * (t array) (* coefficients, increasing degree *) (* by default, operations work with normalized polynomials: - variables are positive integers - coefficients of a polynomial in x only use variables < x - no zero coefficient at beginning - no Prec(x,a) where a is constant in x *) (* constant polynomials *) let of_num x = Pint (C.of_num x) let cf0 = of_num (Num.Int 0) let cf1 = of_num (Num.Int 1) (* nth variable *) let x n = Prec (n,[|cf0;cf1|]) (* create v^n *) let monome v n = match n with 0->Pint coef1; |_->let tmp = Array.make (n+1) (Pint coef0) in tmp.(n)<-(Pint coef1); Prec (v, tmp) let is_constantP = function Pint _ -> true | Prec _ -> false let int_of_Pint = function Pint x -> x | _ -> failwith "non" let is_zero p = match p with Pint n -> if C.equal n coef0 then true else false |_-> false let max_var_pol p = match p with Pint _ -> 0 |Prec(x,_) -> x (* p not normalized *) let rec max_var_pol2 p = match p with Pint _ -> 0 |Prec(v,c)-> Array.fold_right (fun q m -> max (max_var_pol2 q) m) c v let max_var l = Array.fold_right (fun p m -> max (max_var_pol2 p) m) l 0 (* equality between polynomials *) let rec equal p q = match (p,q) with (Pint a,Pint b) -> C.equal a b |(Prec(x,p1),Prec(y,q1)) -> (Int.equal x y) && Array.for_all2 equal p1 q1 | (_,_) -> false (* normalize polynomial: remove head zeros, coefficients are normalized if constant, returns the coefficient *) let norm p = match p with Pint _ -> p |Prec (x,a)-> let d = (Array.length a -1) in let n = ref d in while !n>0 && (equal a.(!n) (Pint coef0)) do n:=!n-1; done; if !n<0 then Pint coef0 else if Int.equal !n 0 then a.(0) else if Int.equal !n d then p else (let b=Array.make (!n+1) (Pint coef0) in for i=0 to !n do b.(i)<-a.(i);done; Prec(x,b)) (* degree in v, v >= max var of p *) let deg v p = match p with Prec(x,p1) when Int.equal x v -> Array.length p1 -1 |_ -> 0 (* total degree *) let rec deg_total p = match p with Prec (x,p1) -> let d = ref 0 in Array.iteri (fun i q -> d:= (max !d (i+(deg_total q)))) p1; !d |_ -> 0 let rec copyP p = match p with Pint i -> Pint i |Prec(x,q) -> Prec(x,Array.map copyP q) (* coefficient of degree i in v, v >= max var of p *) let coef v i p = match p with Prec (x,p1) when Int.equal x v -> if i<(Array.length p1) then p1.(i) else Pint coef0 |_ -> if Int.equal i 0 then p else Pint coef0 (* addition *) let rec plusP p q = let res = (match (p,q) with (Pint a,Pint b) -> Pint (C.plus a b) |(Pint a, Prec (y,q1)) -> let q2=Array.map copyP q1 in q2.(0)<- plusP p q1.(0); Prec (y,q2) |(Prec (x,p1),Pint b) -> let p2=Array.map copyP p1 in p2.(0)<- plusP p1.(0) q; Prec (x,p2) |(Prec (x,p1),Prec (y,q1)) -> if xy then (let p2=Array.map copyP p1 in p2.(0)<- plusP p1.(0) q; Prec (x,p2)) else (let n=max (deg x p) (deg x q) in let r=Array.make (n+1) (Pint coef0) in for i=0 to n do r.(i)<- plusP (coef x i p) (coef x i q); done; Prec(x,r))) in norm res (* content, positive integer *) let rec content p = match p with Pint a -> C.abs a | Prec (x ,p1) -> Array.fold_left C.pgcd coef0 (Array.map content p1) let rec div_int p a= match p with Pint b -> Pint (C.div b a) | Prec(x,p1) -> Prec(x,Array.map (fun x -> div_int x a) p1) let vire_contenu p = let c = content p in if C.equal c coef0 then p else div_int p c (* sorted list of variables of a polynomial *) let rec vars=function Pint _->[] | Prec (x,l)->(List.flatten ([x]::(List.map vars (Array.to_list l)))) (* multiply p by v^n, v >= max_var p *) let multx n v p = match p with Prec (x,p1) when Int.equal x v -> let p2= Array.make ((Array.length p1)+n) (Pint coef0) in for i=0 to (Array.length p1)-1 do p2.(i+n)<-p1.(i); done; Prec (x,p2) |_ -> if equal p (Pint coef0) then (Pint coef0) else (let p2=Array.make (n+1) (Pint coef0) in p2.(n)<-p; Prec (v,p2)) (* product *) let rec multP p q = match (p,q) with (Pint a,Pint b) -> Pint (C.mult a b) |(Pint a, Prec (y,q1)) -> if C.equal a coef0 then Pint coef0 else let q2 = Array.map (fun z-> multP p z) q1 in Prec (y,q2) |(Prec (x,p1), Pint b) -> if C.equal b coef0 then Pint coef0 else let p2 = Array.map (fun z-> multP z q) p1 in Prec (x,p2) |(Prec (x,p1), Prec(y,q1)) -> if x multP p z) q1 in Prec (y,q2)) else if x>y then (let p2 = Array.map (fun z-> multP z q) p1 in Prec (x,p2)) else Array.fold_left plusP (Pint coef0) (Array.mapi (fun i z-> (multx i x (multP z q))) p1) (* derive p with variable v, v >= max_var p *) let deriv v p = match p with Pint a -> Pint coef0 | Prec(x,p1) when Int.equal x v -> let d = Array.length p1 -1 in if Int.equal d 1 then p1.(1) else (let p2 = Array.make d (Pint coef0) in for i=0 to d-1 do p2.(i)<- multP (Pint (coef_of_int (i+1))) p1.(i+1); done; Prec (x,p2)) | Prec(x,p1)-> Pint coef0 (* opposite *) let rec oppP p = match p with Pint a -> Pint (C.opp a) |Prec(x,p1) -> Prec(x,Array.map oppP p1) let moinsP p q=plusP p (oppP q) let rec puisP p n = match n with 0 -> cf1 |_ -> (multP p (puisP p (n-1))) (* infix notations *) (*let (++) a b = plusP a b *) let (@@) a b = multP a b let (--) a b = moinsP a b let (^^) a b = puisP a b (* leading coefficient in v, v>= max_var p *) let coefDom v p= coef v (deg v p) p let coefConst v p = coef v 0 p (* tail of a polynomial *) let remP v p = moinsP p (multP (coefDom v p) (puisP (x v) (deg v p))) (* first interger coefficient of p *) let rec coef_int_tete p = let v = max_var_pol p in if v>0 then coef_int_tete (coefDom v p) else (match p with | Pint a -> a |_ -> assert false) (* divide by the content and make the head int coef positive *) let normc p = let p = vire_contenu p in let a = coef_int_tete p in if C.le coef0 a then p else oppP p (* constant coef of normalized polynomial *) let rec coef_constant p = match p with Pint a->a |Prec(_,q)->coef_constant q.(0) (*********************************************************************** 3. Printing polynomials. *) (* if univ = false, we use x,y,z,a,b,c,d... as variables, else x1,x2,... *) let univ=ref true let string_of_var x= if !univ then "u"^(string_of_int x) else if x<=3 then String.make 1 (Char.chr(x+(Char.code 'w'))) else String.make 1 (Char.chr(x-4+(Char.code 'a'))) let nsP = ref 0 let rec string_of_Pcut p = if (!nsP)<=0 then "..." else match p with |Pint a-> nsP:=(!nsP)-1; if C.le coef0 a then C.to_string a else "("^(C.to_string a)^")" |Prec (x,t)-> let v=string_of_var x and s=ref "" and sp=ref "" in let st0 = string_of_Pcut t.(0) in if not (String.equal st0 "0") then s:=st0; let fin = ref false in for i=(Array.length t)-1 downto 1 do if (!nsP)<0 then (sp:="..."; if not (!fin) then s:=(!s)^"+"^(!sp); fin:=true) else ( let si=string_of_Pcut t.(i) in sp:=""; if Int.equal i 1 then ( if not (String.equal si "0") then (nsP:=(!nsP)-1; if String.equal si "1" then sp:=v else (if (String.contains si '+') then sp:="("^si^")*"^v else sp:=si^"*"^v))) else ( if not (String.equal si "0") then (nsP:=(!nsP)-1; if String.equal si "1" then sp:=v^"^"^(string_of_int i) else (if (String.contains si '+') then sp:="("^si^")*"^v^"^"^(string_of_int i) else sp:=si^"*"^v^"^"^(string_of_int i)))); if not (String.is_empty !sp) && not (!fin) then (nsP:=(!nsP)-1; if String.is_empty !s then s:=!sp else s:=(!s)^"+"^(!sp))); done; if String.is_empty !s then (nsP:=(!nsP)-1; (s:="0")); !s let to_string p = nsP:=20; string_of_Pcut p let printP p = Format.printf "@[%s@]" (to_string p) let print_tpoly lp = let s = ref "\n{ " in Array.iter (fun p -> s:=(!s)^(to_string p)^"\n") lp; prt0 ((!s)^"}") let print_lpoly lp = print_tpoly (Array.of_list lp) (*********************************************************************** 4. Exact division of polynomials. *) (* return (s,r) s.t. p = s*q+r *) let rec quo_rem_pol p q x = if Int.equal x 0 then (match (p,q) with |(Pint a, Pint b) -> if C.equal (C.modulo a b) coef0 then (Pint (C.div a b), cf0) else failwith "div_pol1" |_ -> assert false) else let m = deg x q in let b = coefDom x q in let q1 = remP x q in (* q = b*x^m+q1 *) let r = ref p in let s = ref cf0 in let continue =ref true in while (!continue) && (not (equal !r cf0)) do let n = deg x !r in if n false (*********************************************************************** 5. Pseudo-division and gcd with subresultants. *) (* pseudo division : q = c*x^m+q1 retruns (r,c,d,s) s.t. c^d*p = s*q + r. *) let pseudo_div p q x = match q with Pint _ -> (cf0, q,1, p) | Prec (v,q1) when not (Int.equal x v) -> (cf0, q,1, p) | Prec (v,q1) -> ( (* pr "pseudo_division: c^d*p = s*q + r";*) let delta = ref 0 in let r = ref p in let c = coefDom x q in let q1 = remP x q in let d' = deg x q in let s = ref cf0 in while (deg x !r)>=(deg x q) do let d = deg x !r in let a = coefDom x !r in let r1=remP x !r in let u = a @@ ((monome x (d-d'))) in r:=(c @@ r1) -- (u @@ q1); s:=plusP (c @@ (!s)) u; delta := (!delta) + 1; done; (* pr ("deg d: "^(string_of_int (!delta))^", deg c: "^(string_of_int (deg_total c))); pr ("deg r:"^(string_of_int (deg_total !r))); *) (!r,c,!delta, !s) ) (* gcd with subresultants *) let rec pgcdP p q = let x = max (max_var_pol p) (max_var_pol q) in pgcd_pol p q x and pgcd_pol p q x = pgcd_pol_rec p q x and content_pol p x = match p with Prec(v,p1) when Int.equal v x -> Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) cf0 p1 | _ -> p and pgcd_coef_pol c p x = match p with Prec(v,p1) when Int.equal x v -> Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) c p1 |_ -> pgcd_pol_rec c p (x-1) and pgcd_pol_rec p q x = match (p,q) with (Pint a,Pint b) -> Pint (C.pgcd (C.abs a) (C.abs b)) |_ -> if equal p cf0 then q else if equal q cf0 then p else if Int.equal (deg x q) 0 then pgcd_coef_pol q p x else if Int.equal (deg x p) 0 then pgcd_coef_pol p q x else ( let a = content_pol p x in let b = content_pol q x in let c = pgcd_pol_rec a b (x-1) in pr (string_of_int x); let p1 = div_pol p c x in let q1 = div_pol q c x in let r = gcd_sub_res p1 q1 x in let cr = content_pol r x in let res = c @@ (div_pol r cr x) in res ) (* Sub-résultants: ai*Ai = Qi*Ai+1 + bi*Ai+2 deg Ai+2 < deg Ai+1 Ai = ci*X^ni + ... di = ni - ni+1 ai = (- ci+1)^(di + 1) b1 = 1 bi = ci*si^di si i>1 s1 = 1 si+1 = ((ci+1)^di*si)/si^di *) and gcd_sub_res p q x = if equal q cf0 then p else let d = deg x p in let d' = deg x q in if d (C.hash a) | Prec (v,p) -> Array.fold_right (fun q h -> h + hash q) p 0 module Hashpol = Hashtbl.Make( struct type poly = t type t = poly let equal = equal let hash = hash end) end coq-8.6/plugins/nsatz/g_nsatz.ml40000644000175000017500000000132713022274260016365 0ustar mdenesmdenesDECLARE PLUGIN "nsatz_plugin" (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ Nsatz.nsatz_compute lt ] END coq-8.6/plugins/nsatz/utile.ml0000644000175000017500000000676113022274260015765 0ustar mdenesmdenes(* Printing *) let pr x = if !Flags.debug then (Format.printf "@[%s@]" x; flush(stdout);)else () let prn x = if !Flags.debug then (Format.printf "@[%s\n@]" x; flush(stdout);) else () let prt0 s = () (* print_string s;flush(stdout)*) let prt s = if !Flags.debug then (print_string (s^"\n");flush(stdout)) else () let info s = Flags.if_verbose prerr_string s (* Lists *) let rec list_mem_eq eq x l = match l with [] -> false |y::l1 -> if (eq x y) then true else (list_mem_eq eq x l1) let set_of_list_eq eq l = let res = ref [] in List.iter (fun x -> if not (list_mem_eq eq x (!res)) then res:=x::(!res)) l; List.rev !res (********************************************************************** Eléments minimaux pour un ordre partiel de division. E est un ensemble, avec une multiplication et une division partielle div (la fonction div peut échouer), constant est un prédicat qui définit un sous-ensemble C de E. *) (* Etant donnée une partie A de E, on calcule une partie B de E disjointe de C telle que: - les éléments de A sont des produits d'éléments de B et d'un de C. - B est minimale pour cette propriété. *) let facteurs_liste div constant lp = let lp = List.filter (fun x -> not (constant x)) lp in let rec factor lmin lp = (* lmin: ne se divisent pas entre eux *) match lp with [] -> lmin |p::lp1 -> (let l1 = ref [] in let p_dans_lmin = ref false in List.iter (fun q -> try (let r = div p q in if not (constant r) then l1:=r::(!l1) else p_dans_lmin:=true) with e when CErrors.noncritical e -> ()) lmin; if !p_dans_lmin then factor lmin lp1 else if (!l1)=[] (* aucun q de lmin ne divise p *) then (let l1=ref lp1 in let lmin1=ref [] in List.iter (fun q -> try (let r = div q p in if not (constant r) then l1:=r::(!l1)) with e when CErrors.noncritical e -> lmin1:=q::(!lmin1)) lmin; factor (List.rev (p::(!lmin1))) !l1) (* au moins un q de lmin divise p non trivialement *) else factor lmin ((!l1)@lp1)) in factor [] lp (* On suppose que tout élément de A est produit d'éléments de B et d'un de C: A et B sont deux tableaux, rend un tableau de couples (élément de C, listes d'indices l) tels que A.(i) = l.(i)_1*Produit(B.(j), j dans l.(i)_2) zero est un prédicat sur E tel que (zero x) => (constant x): si (zero x) est vrai on ne decompose pas x c est un élément quelconque de E. *) let factorise_tableau div zero c f l1 = let res = Array.make (Array.length f) (c,[]) in Array.iteri (fun i p -> let r = ref p in let li = ref [] in if not (zero p) then Array.iteri (fun j q -> try (while true do let rr = div !r q in li:=j::(!li); r:=rr; done) with e when CErrors.noncritical e -> ()) l1; res.(i)<-(!r,!li)) f; (l1,res) (* exemples: let l = [1;2;6;24;720] and div1 = (fun a b -> if a mod b =0 then a/b else failwith "div") and constant = (fun x -> x<2) and zero = (fun x -> x=0) let f = facteurs_liste div1 constant l factorise_tableau div1 zero 0 (Array.of_list l) (Array.of_list f) *) coq-8.6/plugins/nsatz/nsatz.mli0000644000175000017500000000110413022274260016135 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit Proofview.tactic coq-8.6/plugins/nsatz/nsatz.ml0000644000175000017500000004330013022274260015770 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 1 let puis = power_big_int_positive_int (* a et b positifs, résultat positif *) let rec pgcd a b = if equal b coef0 then a else if lt a b then pgcd b a else pgcd b (modulo a b) (* signe du pgcd = signe(a)*signe(b) si non nuls. *) let pgcd2 a b = if equal a coef0 then b else if equal b coef0 then a else let c = pgcd (abs a) (abs b) in if ((lt coef0 a)&&(lt b coef0)) ||((lt coef0 b)&&(lt a coef0)) then opp c else c end (* module Ent = struct type t = Entiers.entiers let of_int = Entiers.ent_of_int let of_num x = Entiers.ent_of_string(Num.string_of_num x) let to_num x = Num.num_of_string (Entiers.string_of_ent x) let equal = Entiers.eq_ent let lt = Entiers.lt_ent let le = Entiers.le_ent let abs = Entiers.abs_ent let plus =Entiers.add_ent let mult = Entiers.mult_ent let sub = Entiers.moins_ent let opp = Entiers.opp_ent let div = Entiers.div_ent let modulo = Entiers.mod_ent let coef0 = Entiers.ent0 let coef1 = Entiers.ent1 let to_string = Entiers.string_of_ent let to_int x = Entiers.int_of_ent x let hash x =Entiers.hash_ent x let signe = Entiers.signe_ent let rec puis p n = match n with 0 -> coef1 |_ -> (mult p (puis p (n-1))) (* a et b positifs, résultat positif *) let rec pgcd a b = if equal b coef0 then a else if lt a b then pgcd b a else pgcd b (modulo a b) (* signe du pgcd = signe(a)*signe(b) si non nuls. *) let pgcd2 a b = if equal a coef0 then b else if equal b coef0 then a else let c = pgcd (abs a) (abs b) in if ((lt coef0 a)&&(lt b coef0)) ||((lt coef0 b)&&(lt a coef0)) then opp c else c end *) (* ------------------------------------------------------------------------- *) (* ------------------------------------------------------------------------- *) type vname = string type term = | Zero | Const of Num.num | Var of vname | Opp of term | Add of term * term | Sub of term * term | Mul of term * term | Pow of term * int let const n = if eq_num n num_0 then Zero else Const n let pow(p,i) = if Int.equal i 1 then p else Pow(p,i) let add = function (Zero,q) -> q | (p,Zero) -> p | (p,q) -> Add(p,q) let mul = function (Zero,_) -> Zero | (_,Zero) -> Zero | (p,Const n) when eq_num n num_1 -> p | (Const n,q) when eq_num n num_1 -> q | (p,q) -> Mul(p,q) let unconstr = mkRel 1 let tpexpr = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc") let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX") let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd") let ttsub = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEsub") let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul") let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp") let ttpow = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEpow") let datatypes = ["Init";"Datatypes"] let binnums = ["Numbers";"BinNums"] let tlist = lazy (gen_constant "CC" datatypes "list") let lnil = lazy (gen_constant "CC" datatypes "nil") let lcons = lazy (gen_constant "CC" datatypes "cons") let tz = lazy (gen_constant "CC" binnums "Z") let z0 = lazy (gen_constant "CC" binnums "Z0") let zpos = lazy (gen_constant "CC" binnums "Zpos") let zneg = lazy(gen_constant "CC" binnums "Zneg") let pxI = lazy(gen_constant "CC" binnums "xI") let pxO = lazy(gen_constant "CC" binnums "xO") let pxH = lazy(gen_constant "CC" binnums "xH") let nN0 = lazy (gen_constant "CC" binnums "N0") let nNpos = lazy(gen_constant "CC" binnums "Npos") let mkt_app name l = mkApp (Lazy.force name, Array.of_list l) let tlp () = mkt_app tlist [mkt_app tpexpr [Lazy.force tz]] let tllp () = mkt_app tlist [tlp()] let rec mkt_pos n = if n =/ num_1 then Lazy.force pxH else if mod_num n num_2 =/ num_0 then mkt_app pxO [mkt_pos (quo_num n num_2)] else mkt_app pxI [mkt_pos (quo_num n num_2)] let mkt_n n = if Num.eq_num n num_0 then Lazy.force nN0 else mkt_app nNpos [mkt_pos n] let mkt_z z = if z =/ num_0 then Lazy.force z0 else if z >/ num_0 then mkt_app zpos [mkt_pos z] else mkt_app zneg [mkt_pos ((Int 0) -/ z)] let rec mkt_term t = match t with | Zero -> mkt_term (Const num_0) | Const r -> let (n,d) = numdom r in mkt_app ttconst [Lazy.force tz; mkt_z n] | Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)] | Opp t1 -> mkt_app ttopp [Lazy.force tz; mkt_term t1] | Add (t1,t2) -> mkt_app ttadd [Lazy.force tz; mkt_term t1; mkt_term t2] | Sub (t1,t2) -> mkt_app ttsub [Lazy.force tz; mkt_term t1; mkt_term t2] | Mul (t1,t2) -> mkt_app ttmul [Lazy.force tz; mkt_term t1; mkt_term t2] | Pow (t1,n) -> if Int.equal n 0 then mkt_app ttconst [Lazy.force tz; mkt_z num_1] else mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)] let rec parse_pos p = match kind_of_term p with | App (a,[|p2|]) -> if eq_constr a (Lazy.force pxO) then num_2 */ (parse_pos p2) else num_1 +/ (num_2 */ (parse_pos p2)) | _ -> num_1 let parse_z z = match kind_of_term z with | App (a,[|p2|]) -> if eq_constr a (Lazy.force zpos) then parse_pos p2 else (num_0 -/ (parse_pos p2)) | _ -> num_0 let parse_n z = match kind_of_term z with | App (a,[|p2|]) -> parse_pos p2 | _ -> num_0 let rec parse_term p = match kind_of_term p with | App (a,[|_;p2|]) -> if eq_constr a (Lazy.force ttvar) then Var (string_of_num (parse_pos p2)) else if eq_constr a (Lazy.force ttconst) then Const (parse_z p2) else if eq_constr a (Lazy.force ttopp) then Opp (parse_term p2) else Zero | App (a,[|_;p2;p3|]) -> if eq_constr a (Lazy.force ttadd) then Add (parse_term p2, parse_term p3) else if eq_constr a (Lazy.force ttsub) then Sub (parse_term p2, parse_term p3) else if eq_constr a (Lazy.force ttmul) then Mul (parse_term p2, parse_term p3) else if eq_constr a (Lazy.force ttpow) then Pow (parse_term p2, int_of_num (parse_n p3)) else Zero | _ -> Zero let rec parse_request lp = match kind_of_term lp with | App (_,[|_|]) -> [] | App (_,[|_;p;lp1|]) -> (parse_term p)::(parse_request lp1) |_-> assert false let nvars = ref 0 let set_nvars_term t = let rec aux t = match t with | Zero -> () | Const r -> () | Var v -> let n = int_of_string v in nvars:= max (!nvars) n | Opp t1 -> aux t1 | Add (t1,t2) -> aux t1; aux t2 | Sub (t1,t2) -> aux t1; aux t2 | Mul (t1,t2) -> aux t1; aux t2 | Pow (t1,n) -> aux t1 in aux t let string_of_term p = let rec aux p = match p with | Zero -> "0" | Const r -> string_of_num r | Var v -> "x"^v | Opp t1 -> "(-"^(aux t1)^")" | Add (t1,t2) -> "("^(aux t1)^"+"^(aux t2)^")" | Sub (t1,t2) -> "("^(aux t1)^"-"^(aux t2)^")" | Mul (t1,t2) -> "("^(aux t1)^"*"^(aux t2)^")" | Pow (t1,n) -> (aux t1)^"^"^(string_of_int n) in aux p (*********************************************************************** Coefficients: recursive polynomials *) module Coef = BigInt (*module Coef = Ent*) module Poly = Polynom.Make(Coef) module PIdeal = Ideal.Make(Poly) open PIdeal (* term to sparse polynomial varaibles <=np are in the coefficients *) let term_pol_sparse np t= let d = !nvars in let rec aux t = (* info ("conversion de: "^(string_of_term t)^"\n");*) let res = match t with | Zero -> zeroP | Const r -> if Num.eq_num r num_0 then zeroP else polconst d (Poly.Pint (Coef.of_num r)) | Var v -> let v = int_of_string v in if v <= np then polconst d (Poly.x v) else gen d v | Opp t1 -> oppP (aux t1) | Add (t1,t2) -> plusP (aux t1) (aux t2) | Sub (t1,t2) -> plusP (aux t1) (oppP (aux t2)) | Mul (t1,t2) -> multP (aux t1) (aux t2) | Pow (t1,n) -> puisP (aux t1) n in (* info ("donne: "^(stringP res)^"\n");*) res in let res= aux t in res (* sparse polynomial to term *) let polrec_to_term p = let rec aux p = match p with |Poly.Pint n -> const (Coef.to_num n) |Poly.Prec (v,coefs) -> let res = ref Zero in Array.iteri (fun i c -> res:=add(!res, mul(aux c, pow (Var (string_of_int v), i)))) coefs; !res in aux p (* approximation of the Horner form used in the tactic ring *) let pol_sparse_to_term n2 p = (* info "pol_sparse_to_term ->\n";*) let p = PIdeal.repr p in let rec aux p = match p with [] -> const (num_of_string "0") | (a,m)::p1 -> let n = (Array.length m)-1 in let (i0,e0) = List.fold_left (fun (r,d) (a,m) -> let i0= ref 0 in for k=1 to n do if m.(k)>0 then i0:=k done; if Int.equal !i0 0 then (r,d) else if !i0 > r then (!i0, m.(!i0)) else if Int.equal !i0 r && m.(!i0) if m.(i0)>=e0 then (m.(i0)<-m.(i0)-e0; p1:=(a,m)::(!p1)) else p2:=(a,m)::(!p2)) p; let vm = if Int.equal e0 1 then Var (string_of_int (i0)) else pow (Var (string_of_int (i0)),e0) in add(mul(vm, aux (List.rev (!p1))), aux (List.rev (!p2)))) in (*info "-> pol_sparse_to_term\n";*) aux p let remove_list_tail l i = let rec aux l i = if List.is_empty l then [] else if i<0 then l else if Int.equal i 0 then List.tl l else match l with |(a::l1) -> a::(aux l1 (i-1)) |_ -> assert false in List.rev (aux (List.rev l) i) (* lq = [cn+m+1 n+m ...cn+m+1 1] lci=[[cn+1 n,...,cn1 1] ... [cn+m n+m-1,...,cn+m 1]] removes intermediate polynomials not useful to compute the last one. *) let remove_zeros zero lci = let n = List.length (List.hd lci) in let m=List.length lci in let u = Array.make m false in let rec utiles k = if k>=m then () else ( u.(k)<-true; let lc = List.nth lci k in for i=0 to List.length lc - 1 do if not (zero (List.nth lc i)) then utiles (i+k+1); done) in utiles 0; let lr = ref [] in for i=0 to m-1 do if u.(i) then lr:=(List.nth lci i)::(!lr) done; let lr=List.rev !lr in let lr = List.map (fun lc -> let lcr=ref lc in for i=0 to m-1 do if not u.(i) then lcr:=remove_list_tail !lcr (m-i+(n-m)) done; !lcr) lr in info ("useless spolynomials: " ^string_of_int (m-List.length lr)^"\n"); info ("useful spolynomials: " ^string_of_int (List.length lr)^"\n"); lr let theoremedeszeros lpol p = let t1 = Unix.gettimeofday() in let m = !nvars in let (lp0,p,cert) = in_ideal m lpol p in let lpc = List.rev !poldepcontent in info ("time: "^Format.sprintf "@[%10.3f@]s\n" (Unix.gettimeofday ()-.t1)); (cert,lp0,p,lpc) open Ideal (* Remove zero polynomials and duplicates from the list of polynomials lp Return (clp, lb) where clp is the reduced list and lb is a list of booleans that has the same size than lp and where true indicates an element that has been removed *) let rec clean_pol lp = let t = Hashpol.create 12 in let find p = try Hashpol.find t p with Not_found -> Hashpol.add t p true; false in let rec aux lp = match lp with | [] -> [], [] | p :: lp1 -> let clp, lb = aux lp1 in if equal p zeroP || find p then clp, true::lb else (p :: clp, false::lb) in aux lp (* Expand the list of polynomials lp putting zeros where the list of booleans lb indicates there is a missing element Warning: the expansion is relative to the end of the list in reversed order lp cannot have less elements than lb *) let expand_pol lb lp = let rec aux lb lp = match lb with | [] -> lp | true :: lb1 -> zeroP :: aux lb1 lp | false :: lb1 -> match lp with [] -> assert false | p :: lp1 -> p :: aux lb1 lp1 in List.rev (aux lb (List.rev lp)) let theoremedeszeros_termes lp = nvars:=0;(* mise a jour par term_pol_sparse *) List.iter set_nvars_term lp; match lp with | Const (Int sugarparam)::Const (Int nparam)::lp -> ((match sugarparam with |0 -> info "computation without sugar\n"; lexico:=false; sugar_flag := false; divide_rem_with_critical_pair := false |1 -> info "computation with sugar\n"; lexico:=false; sugar_flag := true; divide_rem_with_critical_pair := false |2 -> info "ordre lexico computation without sugar\n"; lexico:=true; sugar_flag := false; divide_rem_with_critical_pair := false |3 -> info "ordre lexico computation with sugar\n"; lexico:=true; sugar_flag := true; divide_rem_with_critical_pair := false |4 -> info "computation without sugar, division by pairs\n"; lexico:=false; sugar_flag := false; divide_rem_with_critical_pair := true |5 -> info "computation with sugar, division by pairs\n"; lexico:=false; sugar_flag := true; divide_rem_with_critical_pair := true |6 -> info "ordre lexico computation without sugar, division by pairs\n"; lexico:=true; sugar_flag := false; divide_rem_with_critical_pair := true |7 -> info "ordre lexico computation with sugar, division by pairs\n"; lexico:=true; sugar_flag := true; divide_rem_with_critical_pair := true | _ -> error "nsatz: bad parameter" ); let m= !nvars in let lvar=ref [] in for i=m downto 1 do lvar:=["x"^(string_of_int i)^""]@(!lvar); done; lvar:=["a";"b";"c";"d";"e";"f";"g";"h";"i";"j";"k";"l";"m";"n";"o";"p";"q";"r";"s";"t";"u";"v";"w";"x";"y";"z"] @ (!lvar); (* pour macaulay *) name_var:=!lvar; let lp = List.map (term_pol_sparse nparam) lp in match lp with | [] -> assert false | p::lp1 -> let lpol = List.rev lp1 in (* preprocessing : we remove zero polynomials and duplicate that are not handled by in_ideal lb is kept in order to fix the certificate in the post-processing *) let lpol, lb = clean_pol lpol in let (cert,lp0,p,_lct) = theoremedeszeros lpol p in info "cert ok\n"; let lc = cert.last_comb::List.rev cert.gb_comb in match remove_zeros (fun x -> equal x zeroP) lc with | [] -> assert false | (lq::lci) -> (* post-processing : we apply the correction for the last line *) let lq = expand_pol lb lq in (* lci commence par les nouveaux polynomes *) let m = !nvars in let c = pol_sparse_to_term m (polconst m cert.coef) in let r = Pow(Zero,cert.power) in let lci = List.rev lci in (* post-processing we apply the correction for the other lines *) let lci = List.map (expand_pol lb) lci in let lci = List.map (List.map (pol_sparse_to_term m)) lci in let lq = List.map (pol_sparse_to_term m) lq in info ("number of parameters: "^string_of_int nparam^"\n"); info "term computed\n"; (c,r,lci,lq) ) |_ -> assert false (* version avec hash-consing du certificat: let nsatz lpol = Hashtbl.clear Dansideal.hmon; Hashtbl.clear Dansideal.coefpoldep; Hashtbl.clear Dansideal.sugartbl; Hashtbl.clear Polynomesrec.hcontentP; init_constants (); let lp= parse_request lpol in let (_lp0,_p,c,r,_lci,_lq as rthz) = theoremedeszeros_termes lp in let certif = certificat_vers_polynome_creux rthz in let certif = hash_certif certif in let certif = certif_term certif in let c = mkt_term c in info "constr computed\n"; (c, certif) *) let nsatz lpol = let lp= parse_request lpol in let (c,r,lci,lq) = theoremedeszeros_termes lp in let res = [c::r::lq]@lci in let res = List.map (fun lx -> List.map mkt_term lx) res in let res = List.fold_right (fun lt r -> let ltterm = List.fold_right (fun t r -> mkt_app lcons [mkt_app tpexpr [Lazy.force tz];t;r]) lt (mkt_app lnil [mkt_app tpexpr [Lazy.force tz]]) in mkt_app lcons [tlp ();ltterm;r]) res (mkt_app lnil [tlp ()]) in info "term computed\n"; res let return_term t = let a = mkApp(gen_constant "CC" ["Init";"Logic"] "refl_equal",[|tllp ();t|]) in generalize [a] let nsatz_compute t = let lpol = try nsatz t with Ideal.NotInIdeal -> error "nsatz cannot solve this problem" in return_term lpol coq-8.6/plugins/nsatz/ideal.ml0000644000175000017500000005667613022274260015733 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (* meme degre total *) let res=ref 0 in let i=ref d in while (!res=0) && (!i>=1) do res:= - (Int.compare m.(!i) m'.(!i)); i:=!i-1; done; !res | x -> x) let div_mon m m' = let d = nvar m in let m'' = Array.make (d+1) 0 in for i=0 to d do m''.(i)<- (m.(i)-m'.(i)); done; m'' let div_pol_coef p c = List.map (fun (a,m) -> (P.divP a c,m)) p (* m' divides m *) let div_mon_test m m' = let d = nvar m in let res=ref true in let i=ref 0 in (*il faut que le degre total soit bien mis sinon, i=ref 1*) while (!res) && (!i<=d) do res:= (m.(!i) >= m'.(!i)); i:=succ !i; done; !res let set_deg m = let d = nvar m in m.(0)<-0; for i=1 to d do m.(0)<- m.(i)+m.(0); done; m (* lcm *) let ppcm_mon m m' = let d = nvar m in let m'' = Array.make (d+1) 0 in for i=1 to d do m''.(i)<- (max m.(i) m'.(i)); done; set_deg m'' (********************************************************************** Polynomials list of (coefficient, monomial) decreasing order *) let repr p = p let equal = Util.List.for_all2eq (fun (c1,m1) (c2,m2) -> P.equal c1 c2 && m1=m2) let hash p = let c = List.map fst p in let m = List.map snd p in List.fold_left (fun h p -> h * 17 + P.hash p) (Hashtbl.hash m) c module Hashpol = Hashtbl.Make( struct type t = poly let equal = equal let hash = hash end) (* A pretty printer for polynomials, with Maple-like syntax. *) open Format let getvar lv i = try (List.nth lv i) with Failure _ -> (List.fold_left (fun r x -> r^" "^x) "lv= " lv) ^" i="^(string_of_int i) let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef dimmon string_of_exp lvar p = let rec string_of_mon m coefone = let s=ref [] in for i=1 to (dimmon m) do (match (string_of_exp m i) with "0" -> () | "1" -> s:= (!s) @ [(getvar !lvar (i-1))] | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]); done; (match !s with [] -> if coefone then "1" else "" | l -> if coefone then (String.concat "*" l) else ( "*" ^ (String.concat "*" l))) and string_of_term t start = let a = coefterm t and m = monterm t in match (string_of_coef a) with "0" -> "" | "1" ->(match start with true -> string_of_mon m true |false -> ( "+ "^ (string_of_mon m true))) | "-1" ->( "-" ^" "^(string_of_mon m true)) | c -> if (String.get c 0)='-' then ( "- "^ (String.sub c 1 ((String.length c)-1))^ (string_of_mon m false)) else (match start with true -> ( c^(string_of_mon m false)) |false -> ( "+ "^ c^(string_of_mon m false))) and stringP p start = if (zeroP p) then (if start then ("0") else "") else ((string_of_term (hdP p) start)^ " "^ (stringP (tlP p) false)) in (stringP p true) let print_pol zeroP hdP tlP coefterm monterm string_of_coef dimmon string_of_exp lvar p = let rec print_mon m coefone = let s=ref [] in for i=1 to (dimmon m) do (match (string_of_exp m i) with "0" -> () | "1" -> s:= (!s) @ [(getvar !lvar (i-1))] | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]); done; (match !s with [] -> if coefone then print_string "1" else () | l -> if coefone then print_string (String.concat "*" l) else (print_string "*"; print_string (String.concat "*" l))) and print_term t start = let a = coefterm t and m = monterm t in match (string_of_coef a) with "0" -> () | "1" ->(match start with true -> print_mon m true |false -> (print_string "+ "; print_mon m true)) | "-1" ->(print_string "-";print_space();print_mon m true) | c -> if (String.get c 0)='-' then (print_string "- "; print_string (String.sub c 1 ((String.length c)-1)); print_mon m false) else (match start with true -> (print_string c;print_mon m false) |false -> (print_string "+ "; print_string c;print_mon m false)) and printP p start = if (zeroP p) then (if start then print_string("0") else ()) else (print_term (hdP p) start; if start then open_hovbox 0; print_space(); print_cut(); printP (tlP p) false) in open_hovbox 3; printP p true; print_flush() let name_var= ref [] let stringP p = string_of_pol (fun p -> match p with [] -> true | _ -> false) (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal") (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal") (fun (a,m) -> a) (fun (a,m) -> m) string_of_coef (fun m -> (Array.length m)-1) (fun m i -> (string_of_int (m.(i)))) name_var p let nsP2 = ref max_int let stringPcut p = (*Polynomesrec.nsP1:=20;*) nsP2:=10; let res = if (List.length p)> !nsP2 then (stringP [List.hd p])^" + "^(string_of_int (List.length p))^" terms" else stringP p in (*Polynomesrec.nsP1:= max_int;*) nsP2:= max_int; res let rec lstringP l = match l with [] -> "" |p::l -> (stringP p)^("\n")^(lstringP l) let printP = print_pol (fun p -> match p with [] -> true | _ -> false) (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal") (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal") (fun (a,m) -> a) (fun (a,m) -> m) string_of_coef (fun m -> (Array.length m)-1) (fun m i -> (string_of_int (m.(i)))) name_var let rec lprintP l = match l with [] -> () |p::l -> printP p;print_string "\n"; lprintP l (* Operations *) let zeroP = [] (* returns a constant polynom ial with d variables *) let polconst d c = let m = Array.make (d+1) 0 in let m = set_deg m in [(c,m)] let plusP p q = let rec plusP p q accu = match p, q with | [], [] -> List.rev accu | [], _ -> List.rev_append accu q | _, [] -> List.rev_append accu p | t :: p', t' :: q' -> let c = compare_mon (snd t) (snd t') in if c > 0 then plusP p' q (t :: accu) else if c < 0 then plusP p q' (t' :: accu) else let c = P.plusP (fst t) (fst t') in if P.equal c coef0 then plusP p' q' accu else plusP p' q' ((c, (snd t)) :: accu) in plusP p q [] (* multiplication by (a,monomial) *) let mult_t_pol a m p = let map (b, m') = (P.multP a b, mult_mon m m') in CList.map map p let coef_of_int x = P.of_num (Num.Int x) (* variable i *) let gen d i = let m = Array.make (d+1) 0 in m.(i) <- 1; let m = set_deg m in [((coef_of_int 1),m)] let oppP p = let rec oppP p = match p with [] -> [] |(b,m')::p -> ((P.oppP b),m')::(oppP p) in oppP p (* multiplication by a coefficient *) let emultP a p = let rec emultP p = match p with [] -> [] |(b,m')::p -> ((P.multP a b),m')::(emultP p) in emultP p let multP p q = let rec aux p accu = match p with [] -> accu |(a,m)::p' -> aux p' (plusP (mult_t_pol a m q) accu) in aux p [] let puisP p n= match p with [] -> [] |_ -> if n = 0 then let d = nvar (snd (List.hd p)) in [coef1, Array.make (d+1) 0] else let rec puisP p n = if n = 1 then p else let q = puisP p (n / 2) in let q = multP q q in if n mod 2 = 0 then q else multP p q in puisP p n let rec contentP p = match p with |[] -> coef1 |[a,m] -> a |(a,m)::p1 -> if P.equal a coef1 || P.equal a coefm1 then a else P.pgcdP a (contentP p1) let contentPlist lp = match lp with |[] -> coef1 |p::l1 -> List.fold_left (fun r q -> if P.equal r coef1 || P.equal r coefm1 then r else P.pgcdP r (contentP q)) (contentP p) l1 (*********************************************************************** Division of polynomials *) let pgcdpos a b = P.pgcdP a b let polynom0 = {pol = ref []; num = 0; sugar = 0} let ppol p = !(p.pol) let lm p = snd (List.hd (ppol p)) let nallpol = ref 0 let allpol = ref (Array.make 1000 polynom0) let new_allpol p s = nallpol := !nallpol + 1; if !nallpol >= Array.length !allpol then allpol := Array.append !allpol (Array.make !nallpol polynom0); let p = {pol = ref p; num = !nallpol; sugar = s} in !allpol.(!nallpol)<- p; p (* returns a polynomial of l whose head monomial divides m, else [] *) let rec selectdiv m l = match l with [] -> polynom0 |q::r -> let m'= snd (List.hd (ppol q)) in match (div_mon_test m m') with true -> q |false -> selectdiv m r let div_pol p q a b m = (* info ".";*) plusP (emultP a p) (mult_t_pol b m q) let hmon = Hashtbl.create 1000 let use_hmon = ref false let find_hmon m = if !use_hmon then Hashtbl.find hmon m else raise Not_found let add_hmon m q = if !use_hmon then Hashtbl.add hmon m q else () let div_coef a b = P.divP a b (* remainder r of the division of p by polynomials of l, returns (c,r) where c is the coefficient for pseudo-division : c p = sum_i q_i p_i + r *) let reduce2 p l = let l = if nouveaux_pol_en_tete then List.rev l else l in let rec reduce p = match p with [] -> (coef1,[]) |t::p' -> let (a,m)=t in let q = (try find_hmon m with Not_found -> let q = selectdiv m l in match (ppol q) with t'::q' -> (add_hmon m q; q) |[] -> q) in match (ppol q) with [] -> if reduire_les_queues then let (c,r)=(reduce p') in (c,((P.multP a c,m)::r)) else (coef1,p) |(b,m')::q' -> let c=(pgcdpos a b) in let a'= (div_coef b c) in let b'=(P.oppP (div_coef a c)) in let (e,r)=reduce (div_pol p' q' a' b' (div_mon m m')) in (P.multP a' e,r) in let (c,r) = reduce p in (c,r) (* trace of divisions *) (* list of initial polynomials *) let poldep = ref [] let poldepcontent = ref [] (* coefficients of polynomials when written with initial polynomials *) let coefpoldep = Hashtbl.create 51 (* coef of q in p = sum_i c_i*q_i *) let coefpoldep_find p q = try (Hashtbl.find coefpoldep (p.num,q.num)) with Not_found -> [] let coefpoldep_remove p q = Hashtbl.remove coefpoldep (p.num,q.num) let coefpoldep_set p q c = Hashtbl.add coefpoldep (p.num,q.num) c let initcoefpoldep d lp = poldep:=lp; poldepcontent:= List.map (fun p -> contentP (ppol p)) lp; List.iter (fun p -> coefpoldep_set p p (polconst d (coef_of_int 1))) lp (* keeps trace in coefpoldep divides without pseudodivisions *) let reduce2_trace p l lcp = let l = if nouveaux_pol_en_tete then List.rev l else l in (* rend (lq,r), ou r = p + sum(lq) *) let rec reduce p = match p with [] -> ([],[]) |t::p' -> let (a,m)=t in let q = (try find_hmon m with Not_found -> let q = selectdiv m l in match (ppol q) with t'::q' -> (add_hmon m q; q) |[] -> q) in match (ppol q) with [] -> if reduire_les_queues then let (lq,r)=(reduce p') in (lq,((a,m)::r)) else ([],p) |(b,m')::q' -> let b'=(P.oppP (div_coef a b)) in let m''= div_mon m m' in let p1=plusP p' (mult_t_pol b' m'' q') in let (lq,r)=reduce p1 in ((b',m'',q)::lq, r) in let (lq,r) = reduce p in (*info "reduce2_trace:\n"; iter (fun (a,m,s) -> let x = mult_t_pol a m s in info ((stringP x)^"\n")) lq; info "ok\n";*) (List.map2 (fun c0 q -> let c = List.fold_left (fun x (a,m,s) -> if equal (ppol s) (ppol q) then plusP x (mult_t_pol a m (polconst (nvar m) (coef_of_int 1))) else x) c0 lq in c) lcp !poldep, r) let homogeneous = ref false let pol_courant = ref polynom0 (*********************************************************************** Completion *) let sugar_flag = ref true let compute_sugar p = List.fold_left (fun s (a,m) -> max s m.(0)) 0 p let mk_polynom p = new_allpol p (compute_sugar p) let spol ps qs= let p = ppol ps in let q = ppol qs in let m = snd (List.hd p) in let m'= snd (List.hd q) in let a = fst (List.hd p) in let b = fst (List.hd q) in let p'= List.tl p in let q'= List.tl q in let c = (pgcdpos a b) in let m''=(ppcm_mon m m') in let m1 = div_mon m'' m in let m2 = div_mon m'' m' in let fsp p' q' = plusP (mult_t_pol (div_coef b c) m1 p') (mult_t_pol (P.oppP (div_coef a c)) m2 q') in let sp = fsp p' q' in let sps = new_allpol sp (max (m1.(0) + ps.sugar) (m2.(0) + qs.sugar)) in coefpoldep_set sps ps (fsp (polconst (nvar m) (coef_of_int 1)) []); coefpoldep_set sps qs (fsp [] (polconst (nvar m) (coef_of_int 1))); sps let etrangers p p'= let m = snd (List.hd p) in let m'= snd (List.hd p') in let d = nvar m in let res=ref true in let i=ref 1 in while (!res) && (!i<=d) do res:= (m.(!i) = 0) || (m'.(!i)=0); i:=!i+1; done; !res (* teste if head monomial of p'' divides lcm of lhead monomials of p and p' *) let div_ppcm p p' p'' = let m = snd (List.hd p) in let m'= snd (List.hd p') in let m''= snd (List.hd p'') in let d = nvar m in let res=ref true in let i=ref 1 in while (!res) && (!i<=d) do res:= ((max m.(!i) m'.(!i)) >= m''.(!i)); i:=!i+1; done; !res (* code from extraction of Laurent Théry Coq program *) type 'poly cpRes = Keep of ('poly list) | DontKeep of ('poly list) let list_rec f0 f1 = let rec f2 = function [] -> f0 | a0::l0 -> f1 a0 l0 (f2 l0) in f2 let addRes i = function Keep h'0 -> Keep (i::h'0) | DontKeep h'0 -> DontKeep (i::h'0) let slice i a q = list_rec (match etrangers (ppol i) (ppol a) with true -> DontKeep [] | false -> Keep []) (fun b q1 rec_ren -> match div_ppcm (ppol i) (ppol a) (ppol b) with true -> DontKeep (b::q1) | false -> (match div_ppcm (ppol i) (ppol b) (ppol a) with true -> rec_ren | false -> addRes b rec_ren)) q (* sugar strategy *) let addS x l = l @ [x] (* oblige de mettre en queue sinon le certificat deconne *) let addSsugar x l = if !sugar_flag then let sx = x.sugar in let rec insere l = match l with | [] -> [x] | y::l1 -> if sx <= y.sugar then x::l else y::(insere l1) in insere l else addS x l (* ajoute les spolynomes de i avec la liste de polynomes aP, a la liste q *) let genPcPf i aP q = (let rec genPc aP0 = match aP0 with [] -> (fun r -> r) | a::l1 -> (fun l -> (match slice i a l1 with Keep l2 -> addSsugar (spol i a) (genPc l2 l) | DontKeep l2 -> genPc l2 l)) in genPc aP) q let genOCPf h' = list_rec [] (fun a l rec_ren -> genPcPf a l rec_ren) h' (*********************************************************************** critical pairs/s-polynomials *) let ordcpair ((i1,j1),m1) ((i2,j2),m2) = (* let s1 = (max (!allpol.(i1).sugar + m1.(0) - (snd (hd (ppol !allpol.(i1)))).(0)) (!allpol.(j1).sugar + m1.(0) - (snd (hd (ppol !allpol.(j1)))).(0))) in let s2 = (max (!allpol.(i2).sugar + m2.(0) - (snd (hd (ppol !allpol.(i2)))).(0)) (!allpol.(j2).sugar + m2.(0) - (snd (hd (ppol !allpol.(j2)))).(0))) in match compare s1 s2 with | 1 -> 1 |(-1) -> -1 |0 -> compare_mon m1 m2*) compare_mon m1 m2 let sortcpairs lcp = List.sort ordcpair lcp let mergecpairs l1 l2 = List.merge ordcpair l1 l2 let ord i j = if i r @ (cpair p q)) [] lq) let cpairs lp = let rec aux l = match l with []|[_] -> [] |p::l1 -> mergecpairs (cpairs1 p l1) (aux l1) in aux lp let critere2 ((i,j),m) lp lcp = List.exists (fun h -> h.num <> i && h.num <> j && (div_mon_test m (lm h)) && (let c1 = ord i h.num in not (List.exists (fun (c,_) -> c1 = c) lcp)) && (let c1 = ord j h.num in not (List.exists (fun (c,_) -> c1 = c) lcp))) lp let critere3 ((i,j),m) lp lcp = List.exists (fun h -> h.num <> i && h.num <> j && (div_mon_test m (lm h)) && (h.num < j || not (m = ppcm_mon (lm (!allpol.(i))) (lm h))) && (h.num < i || not (m = ppcm_mon (lm (!allpol.(j))) (lm h)))) lp let add_cpairs p lp lcp = mergecpairs (cpairs1 p lp) lcp let step = ref 0 let infobuch p q = if !step = 0 then (info ("[" ^ (string_of_int (List.length p)) ^ "," ^ (string_of_int (List.length q)) ^ "]")) (* in lp new polynomials are at the end *) let coef_courant = ref coef1 type certificate = { coef : coef; power : int; gb_comb : poly list list; last_comb : poly list } let test_dans_ideal p lp lp0 = let (c,r) = reduce2 (ppol !pol_courant) lp in info ("remainder: "^(stringPcut r)^"\n"); coef_courant:= P.multP !coef_courant c; pol_courant:= mk_polynom r; if r=[] then (info "polynomial reduced to 0\n"; let lcp = List.map (fun q -> []) !poldep in let c = !coef_courant in let (lcq,r) = reduce2_trace (emultP c p) lp lcp in info "r ok\n"; info ("r: "^(stringP r)^"\n"); let res=ref (emultP c p) in List.iter2 (fun cq q -> res:=plusP (!res) (multP cq (ppol q)); ) lcq !poldep; info ("verif sum: "^(stringP (!res))^"\n"); info ("coefficient: "^(stringP (polconst 1 c))^"\n"); let rec aux lp = match lp with |[] -> [] |p::lp -> (List.map (fun q -> coefpoldep_find p q) lp)::(aux lp) in let coefficient_multiplicateur = c in let liste_polynomes_de_depart = List.rev lp0 in let polynome_a_tester = p in let liste_des_coefficients_intermediaires = (let lci = List.rev (aux (List.rev lp)) in let lci = ref lci (* (map rev lci) *) in List.iter (fun x -> lci := List.tl (!lci)) lp0; !lci) in let liste_des_coefficients = List.map (fun cq -> emultP (coef_of_int (-1)) cq) (List.rev lcq) in (liste_polynomes_de_depart, polynome_a_tester, {coef = coefficient_multiplicateur; power = 1; gb_comb = liste_des_coefficients_intermediaires; last_comb = liste_des_coefficients}) ) else ((*info "polynomial not reduced to 0\n"; info ("\nremainder: "^(stringPcut r)^"\n");*) raise NotInIdeal) let divide_rem_with_critical_pair = ref false let list_diff l x = List.filter (fun y -> y <> x) l let deg_hom p = match p with | [] -> -1 | (a,m)::_ -> m.(0) let pbuchf pq p lp0= info "computation of the Groebner basis\n"; step:=0; Hashtbl.clear hmon; let rec pbuchf (lp, lpc) = infobuch lp lpc; (* step:=(!step+1)mod 10;*) match lpc with [] -> (* info ("List of polynomials:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp)); info "--------------------\n";*) test_dans_ideal (ppol p) lp lp0 | ((i,j),m) :: lpc2 -> (* info "choosen pair\n";*) if critere3 ((i,j),m) lp lpc2 then (info "c"; pbuchf (lp, lpc2)) else let a = spol !allpol.(i) !allpol.(j) in if !homogeneous && (ppol a)<>[] && deg_hom (ppol a) > deg_hom (ppol !pol_courant) then (info "h"; pbuchf (lp, lpc2)) else (* let sa = a.sugar in*) let (ca,a0)= reduce2 (ppol a) lp in match a0 with [] -> info "0";pbuchf (lp, lpc2) | _ -> (* info "pair reduced\n";*) a.pol := emultP ca (ppol a); let (lca,a0) = reduce2_trace (ppol a) lp (List.map (fun q -> emultP ca (coefpoldep_find a q)) !poldep) in (* info "paire re-reduced";*) a.pol := a0; (* let a0 = new_allpol a0 sa in*) List.iter2 (fun c q -> coefpoldep_remove a q; coefpoldep_set a q c) lca !poldep; let a0 = a in info ("\nnew polynomial: "^(stringPcut (ppol a0))^"\n"); let ct = coef1 (* contentP a0 *) in (*info ("content: "^(string_of_coef ct)^"\n");*) poldep:=addS a0 lp; poldepcontent:=addS ct (!poldepcontent); try test_dans_ideal (ppol p) (addS a0 lp) lp0 with NotInIdeal -> let newlpc = add_cpairs a0 lp lpc2 in pbuchf (((addS a0 lp), newlpc)) in pbuchf pq let is_homogeneous p = match p with | [] -> true | (a,m)::p1 -> let d = m.(0) in List.for_all (fun (b,m') -> m'.(0)=d) p1 (* returns c lp = [pn;...;p1] p lci = [[a(n+1,n);...;a(n+1,1)]; [a(n+2,n+1);...;a(n+2,1)]; ... [a(n+m,n+m-1);...;a(n+m,1)]] lc = [qn+m; ... q1] such that c*p = sum qi*pi where pn+k = a(n+k,n+k-1)*pn+k-1 + ... + a(n+k,1)* p1 *) let in_ideal d lp p = Hashtbl.clear hmon; Hashtbl.clear coefpoldep; nallpol := 0; allpol := Array.make 1000 polynom0; homogeneous := List.for_all is_homogeneous (p::lp); if !homogeneous then info "homogeneous polynomials\n"; info ("p: "^(stringPcut p)^"\n"); info ("lp:\n"^(List.fold_left (fun r p -> r^(stringPcut p)^"\n") "" lp)); (*info ("p: "^(stringP p)^"\n"); info ("lp:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp));*) let lp = List.map mk_polynom lp in let p = mk_polynom p in initcoefpoldep d lp; coef_courant:=coef1; pol_courant:=p; let (lp1,p1,cert) = try test_dans_ideal (ppol p) lp lp with NotInIdeal -> pbuchf (lp, (cpairs lp)) p lp in info "computed\n"; (List.map ppol lp1, p1, cert) (* *) end coq-8.6/plugins/nsatz/ideal.mli0000644000175000017500000000245213022274260016063 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (coef * int array) list val polconst : int -> coef -> poly val zeroP : poly val gen : int -> int -> poly val equal : poly -> poly -> bool val name_var : string list ref val plusP : poly -> poly -> poly val oppP : poly -> poly val multP : poly -> poly -> poly val puisP : poly -> int -> poly val poldepcontent : coef list ref type certificate = { coef : coef; power : int; gb_comb : poly list list; last_comb : poly list } val in_ideal : deg -> poly list -> poly -> poly list * poly * certificate module Hashpol : Hashtbl.S with type key = poly val sugar_flag : bool ref val divide_rem_with_critical_pair : bool ref end exception NotInIdeal val lexico : bool ref coq-8.6/plugins/nsatz/utile.mli0000644000175000017500000000074313022274260016130 0ustar mdenesmdenes (* Printing *) val pr : string -> unit val prn : string -> unit val prt0 : 'a -> unit val prt : string -> unit val info : string -> unit (* Listes *) val list_mem_eq : ('a -> 'b -> bool) -> 'a -> 'b list -> bool val set_of_list_eq : ('a -> 'a -> bool) -> 'a list -> 'a list val facteurs_liste : ('a -> 'a -> 'a) -> ('a -> bool) -> 'a list -> 'a list val factorise_tableau : ('a -> 'b -> 'a) -> ('a -> bool) -> 'a -> 'a array -> 'b array -> 'b array * ('a * int list) array coq-8.6/plugins/nsatz/Nsatz.v0000644000175000017500000003435713022274260015601 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* x == y. intros x y H; setoid_replace x with ((x - y) + y); simpl; [setoid_rewrite H | idtac]; simpl. cring. cring. Qed. Lemma psos_r1: forall x y, x == y -> x - y == 0. intros x y H; simpl; setoid_rewrite H; simpl; cring. Qed. Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0). intros. intro; apply H. simpl; setoid_replace x with ((x - y) + y). simpl. setoid_rewrite H0. simpl; cring. simpl. simpl; cring. Qed. (* adpatation du code de Benjamin aux setoides *) Require Import ZArith. Require Export Ring_polynom. Require Export InitialRing. Definition PolZ := Pol Z. Definition PEZ := PExpr Z. Definition P0Z : PolZ := P0 (C:=Z) 0%Z. Definition PolZadd : PolZ -> PolZ -> PolZ := @Padd Z 0%Z Z.add Zeq_bool. Definition PolZmul : PolZ -> PolZ -> PolZ := @Pmul Z 0%Z 1%Z Z.add Z.mul Zeq_bool. Definition PolZeq := @Peq Z Zeq_bool. Definition norm := @norm_aux Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool. Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := match la, lp with | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp) | _, _ => P0Z end. Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) := match lla with | List.nil => lp | la::lla => compute_list lla ((mult_l la lp)::lp) end. Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := let (lla, lq) := certif in let lp := List.map norm lpe in PolZeq (norm qe) (mult_l lq (compute_list lla lp)). (* Correction *) Definition PhiR : list R -> PolZ -> R := (Pphi ring0 add mul (InitialRing.gen_phiZ ring0 ring1 add mul opp)). Definition PEevalR : list R -> PEZ -> R := PEeval ring0 ring1 add mul sub opp (gen_phiZ ring0 ring1 add mul opp) N.to_nat pow. Lemma P0Z_correct : forall l, PhiR l P0Z = 0. Proof. trivial. Qed. Lemma Rext: ring_eq_ext add mul opp _==_. Proof. constructor; solve_proper. Qed. Lemma Rset : Setoid_Theory R _==_. apply ring_setoid. Qed. Definition Rtheory:ring_theory ring0 ring1 add mul sub opp _==_. apply mk_rt. apply ring_add_0_l. apply ring_add_comm. apply ring_add_assoc. apply ring_mul_1_l. apply cring_mul_comm. apply ring_mul_assoc. apply ring_distr_l. apply ring_sub_def. apply ring_opp_def. Defined. Lemma PolZadd_correct : forall P' P l, PhiR l (PolZadd P P') == ((PhiR l P) + (PhiR l P')). Proof. unfold PolZadd, PhiR. intros. simpl. refine (Padd_ok Rset Rext (Rth_ARth Rset Rext Rtheory) (gen_phiZ_morph Rset Rext Rtheory) _ _ _). Qed. Lemma PolZmul_correct : forall P P' l, PhiR l (PolZmul P P') == ((PhiR l P) * (PhiR l P')). Proof. unfold PolZmul, PhiR. intros. refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext Rtheory) (gen_phiZ_morph Rset Rext Rtheory) _ _ _). Qed. Lemma R_power_theory : Ring_theory.power_theory ring1 mul _==_ N.to_nat pow. apply Ring_theory.mkpow_th. unfold pow. intros. rewrite Nnat.N2Nat.id. reflexivity. Qed. Lemma norm_correct : forall (l : list R) (pe : PEZ), PEevalR l pe == PhiR l (norm pe). Proof. intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext Rtheory) (gen_phiZ_morph Rset Rext Rtheory) R_power_theory). Qed. Lemma PolZeq_correct : forall P P' l, PolZeq P P' = true -> PhiR l P == PhiR l P'. Proof. intros;apply (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext Rtheory));trivial. Qed. Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := match l with | List.nil => True | a::l => Interp a == 0 /\ Cond0 A Interp l end. Lemma mult_l_correct : forall l la lp, Cond0 PolZ (PhiR l) lp -> PhiR l (mult_l la lp) == 0. Proof. induction la;simpl;intros. cring. destruct lp;trivial. simpl. cring. simpl in H;destruct H. rewrite PolZadd_correct. simpl. rewrite PolZmul_correct. simpl. rewrite H. rewrite IHla. cring. trivial. Qed. Lemma compute_list_correct : forall l lla lp, Cond0 PolZ (PhiR l) lp -> Cond0 PolZ (PhiR l) (compute_list lla lp). Proof. induction lla;simpl;intros;trivial. apply IHlla;simpl;split;trivial. apply mult_l_correct;trivial. Qed. Lemma check_correct : forall l lpe qe certif, check lpe qe certif = true -> Cond0 PEZ (PEevalR l) lpe -> PEevalR l qe == 0. Proof. unfold check;intros l lpe qe (lla, lq) H2 H1. apply PolZeq_correct with (l:=l) in H2. rewrite norm_correct, H2. apply mult_l_correct. apply compute_list_correct. clear H2 lq lla qe;induction lpe;simpl;trivial. simpl in H1;destruct H1. rewrite <- norm_correct;auto. Qed. (* fin *) Definition R2:= 1 + 1. Fixpoint IPR p {struct p}: R := match p with xH => ring1 | xO xH => 1+1 | xO p1 => R2*(IPR p1) | xI xH => 1+(1+1) | xI p1 => 1+(R2*(IPR p1)) end. Definition IZR1 z := match z with Z0 => 0 | Zpos p => IPR p | Zneg p => -(IPR p) end. Fixpoint interpret3 t fv {struct t}: R := match t with | (PEadd t1 t2) => let v1 := interpret3 t1 fv in let v2 := interpret3 t2 fv in (v1 + v2) | (PEmul t1 t2) => let v1 := interpret3 t1 fv in let v2 := interpret3 t2 fv in (v1 * v2) | (PEsub t1 t2) => let v1 := interpret3 t1 fv in let v2 := interpret3 t2 fv in (v1 - v2) | (PEopp t1) => let v1 := interpret3 t1 fv in (-v1) | (PEpow t1 t2) => let v1 := interpret3 t1 fv in pow v1 (N.to_nat t2) | (PEc t1) => (IZR1 t1) | PEO => 0 | PEI => 1 | (PEX _ n) => List.nth (pred (Pos.to_nat n)) fv 0 end. End nsatz1. Ltac equality_to_goal H x y:= (* eliminate trivial hypotheses, but it takes time!: let h := fresh "nH" in (assert (h:equality x y); [solve [cring] | clear H; clear h]) || *) try (generalize (@psos_r1 _ _ _ _ _ _ _ _ _ _ _ x y H); clear H) . Ltac equalities_to_goal := lazymatch goal with | H: (_ ?x ?y) |- _ => equality_to_goal H x y | H: (_ _ ?x ?y) |- _ => equality_to_goal H x y | H: (_ _ _ ?x ?y) |- _ => equality_to_goal H x y | H: (_ _ _ _ ?x ?y) |- _ => equality_to_goal H x y (* extension possible :-) *) | H: (?x == ?y) |- _ => equality_to_goal H x y end. (* lp est incluse dans fv. La met en tete. *) Ltac parametres_en_tete fv lp := match fv with | (@nil _) => lp | (@cons _ ?x ?fv1) => let res := AddFvTail x lp in parametres_en_tete fv1 res end. Ltac append1 a l := match l with | (@nil _) => constr:(cons a l) | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l') end. Ltac rev l := match l with |(@nil _) => l | (cons ?x ?l) => let l' := rev l in append1 x l' end. Ltac nsatz_call_n info nparam p rr lp kont := (* idtac "Trying power: " rr;*) let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in (* idtac "calcul...";*) nsatz_compute ll; (* idtac "done";*) match goal with | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => intros _; let lci := fresh "lci" in set (lci:=lci0); let lq := fresh "lq" in set (lq:=lq0); kont c rr lq lci end. Ltac nsatz_call radicalmax info nparam p lp kont := let rec try_n n := lazymatch n with | 0%N => fail | _ => (let r := eval compute in (N.sub radicalmax (N.pred n)) in nsatz_call_n info nparam p r lp kont) || let n' := eval compute in (N.pred n) in try_n n' end in try_n radicalmax. Ltac lterm_goal g := match g with ?b1 == ?b2 => constr:(b1::b2::nil) | ?b1 == ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l) end. Ltac reify_goal l le lb:= match le with nil => idtac | ?e::?le1 => match lb with ?b::?lb1 => (* idtac "b="; idtac b;*) let x := fresh "B" in set (x:= b) at 1; change x with (interpret3 e l); clear x; reify_goal l le1 lb1 end end. Ltac get_lpol g := match g with (interpret3 ?p _) == _ => constr:(p::nil) | (interpret3 ?p _) == _ -> ?g => let l := get_lpol g in constr:(p::l) end. Ltac nsatz_generic radicalmax info lparam lvar := let nparam := eval compute in (Z.of_nat (List.length lparam)) in match goal with |- ?g => let lb := lterm_goal g in match (match lvar with |(@nil _) => match lparam with |(@nil _) => let r := eval red in (list_reifyl (lterm:=lb)) in r |_ => match eval red in (list_reifyl (lterm:=lb)) with |(?fv, ?le) => let fv := parametres_en_tete fv lparam in (* we reify a second time, with the good order for variables *) let r := eval red in (list_reifyl (lterm:=lb) (lvar:=fv)) in r end end |_ => let fv := parametres_en_tete lvar lparam in let r := eval red in (list_reifyl (lterm:=lb) (lvar:=fv)) in r end) with |(?fv, ?le) => reify_goal fv le lb ; match goal with |- ?g => let lp := get_lpol g in let lpol := eval compute in (List.rev lp) in intros; let SplitPolyList kont := match lpol with | ?p2::?lp2 => kont p2 lp2 | _ => idtac "polynomial not in the ideal" end in SplitPolyList ltac:(fun p lp => let p21 := fresh "p21" in let lp21 := fresh "lp21" in set (p21:=p) ; set (lp21:=lp); (* idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *) nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => let q := fresh "q" in set (q := PEmul c (PEpow p21 r)); let Hg := fresh "Hg" in assert (Hg:check lp21 q (lci,lq) = true); [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate" | let Hg2 := fresh "Hg" in assert (Hg2: (interpret3 q fv) == 0); [ (*simpl*) idtac; generalize (@check_correct _ _ _ _ _ _ _ _ _ _ _ fv lp21 q (lci,lq) Hg); let cc := fresh "H" in (*simpl*) idtac; intro cc; apply cc; clear cc; (*simpl*) idtac; repeat (split;[assumption|idtac]); exact I | (*simpl in Hg2;*) (*simpl*) idtac; apply Rintegral_domain_pow with (interpret3 c fv) (N.to_nat r); (*simpl*) idtac; try apply integral_domain_one_zero; try apply integral_domain_minus_one_zero; try trivial; try exact integral_domain_one_zero; try exact integral_domain_minus_one_zero || (solve [simpl; unfold R2, equality, eq_notation, addition, add_notation, one, one_notation, multiplication, mul_notation, zero, zero_notation; discrR || omega]) || ((*simpl*) idtac) || idtac "could not prove discrimination result" ] ] ) ) end end end . Ltac nsatz_default:= intros; try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); match goal with |- (@equality ?r _ _ _) => repeat equalities_to_goal; nsatz_generic 6%N 1%Z (@nil r) (@nil r) end. Tactic Notation "nsatz" := nsatz_default. Tactic Notation "nsatz" "with" "radicalmax" ":=" constr(radicalmax) "strategy" ":=" constr(info) "parameters" ":=" constr(lparam) "variables" ":=" constr(lvar):= intros; try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); match goal with |- (@equality ?r _ _ _) => repeat equalities_to_goal; nsatz_generic radicalmax info lparam lvar end. (* Real numbers *) Require Import Reals. Require Import RealField. Lemma Rsth : Setoid_Theory R (@eq R). constructor;red;intros;subst;trivial. Qed. Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)). Instance Rri : (Ring (Ro:=Rops)). constructor; try (try apply Rsth; try (unfold respectful, Proper; unfold equality; unfold eq_notation in *; intros; try rewrite H; try rewrite H0; reflexivity)). exact Rplus_0_l. exact Rplus_comm. symmetry. apply Rplus_assoc. exact Rmult_1_l. exact Rmult_1_r. symmetry. apply Rmult_assoc. exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. exact Rplus_opp_r. Defined. Lemma R_one_zero: 1%R <> 0%R. discrR. Qed. Instance Rcri: (Cring (Rr:=Rri)). red. exact Rmult_comm. Defined. Instance Rdi : (Integral_domain (Rcr:=Rcri)). constructor. exact Rmult_integral. exact R_one_zero. Defined. (* Rational numbers *) Require Import QArith. Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). Instance Qri : (Ring (Ro:=Qops)). constructor. try apply Q_Setoid. apply Qplus_comp. apply Qmult_comp. apply Qminus_comp. apply Qopp_comp. exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. reflexivity. exact Qplus_opp_r. Defined. Lemma Q_one_zero: not (Qeq 1%Q 0%Q). unfold Qeq. simpl. auto with *. Qed. Instance Qcri: (Cring (Rr:=Qri)). red. exact Qmult_comm. Defined. Instance Qdi : (Integral_domain (Rcr:=Qcri)). constructor. exact Qmult_integral. exact Q_one_zero. Defined. (* Integers *) Lemma Z_one_zero: 1%Z <> 0%Z. omega. Qed. Instance Zcri: (Cring (Rr:=Zr)). red. exact Z.mul_comm. Defined. Instance Zdi : (Integral_domain (Rcr:=Zcri)). constructor. exact Zmult_integral. exact Z_one_zero. Defined. coq-8.6/plugins/nsatz/vo.itarget0000644000175000017500000000001113022274260016274 0ustar mdenesmdenesNsatz.vo coq-8.6/plugins/xml/0000755000175000017500000000000013022274260013740 5ustar mdenesmdenescoq-8.6/plugins/xml/README0000644000175000017500000000034113022274260014616 0ustar mdenesmdenesThe xml export plugin for Coq has been removed from the sources. A backward compatible plug-in will be provided as a third-party plugin. For more informations, contact Claudio Sacerdoti Coen . coq-8.6/plugins/firstorder/0000755000175000017500000000000013022274260015323 5ustar mdenesmdenescoq-8.6/plugins/firstorder/ground.mli0000644000175000017500000000122613022274260017325 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (Proof_type.goal Tacmach.sigma -> Sequent.t * Proof_type.goal Tacmach.sigma) -> Tacmach.tactic coq-8.6/plugins/firstorder/g_ground.ml40000644000175000017500000001277313022274260017557 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Some !ground_depth); optwrite= (function None->ground_depth:=3 | Some i->ground_depth:=(max i 0))} in declare_int_option gdopt let congruence_depth=ref 100 let _= let gdopt= { optsync=true; optdepr=false; optname="Congruence Depth"; optkey=["Congruence";"Depth"]; optread=(fun ()->Some !congruence_depth); optwrite= (function None->congruence_depth:=0 | Some i->congruence_depth:=(max i 0))} in declare_int_option gdopt let default_intuition_tac = let tac _ _ = Auto.h_auto None [] None in let name = { Tacexpr.mltac_plugin = "ground_plugin"; mltac_tactic = "auto_with"; } in let entry = { Tacexpr.mltac_name = name; mltac_index = 0 } in Tacenv.register_ml_tactic name [| tac |]; Tacexpr.TacML (Loc.ghost, entry, []) let (set_default_solver, default_solver, print_default_solver) = Tactic_option.declare_tactic_option ~default:default_intuition_tac "Firstorder default solver" VERNAC COMMAND EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF | [ "Set" "Firstorder" "Solver" tactic(t) ] -> [ set_default_solver (Locality.make_section_locality (Locality.LocalityFixme.consume ())) (Tacintern.glob_tactic t) ] END VERNAC COMMAND EXTEND Firstorder_Print_Solver CLASSIFIED AS QUERY | [ "Print" "Firstorder" "Solver" ] -> [ Feedback.msg_info (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) ] END let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") let gen_ground_tac flag taco ids bases gl= let backup= !qflag in try qflag:=flag; let solver= match taco with Some tac-> tac | None-> snd (default_solver ()) in let startseq gl= let seq=empty_seq !ground_depth in let seq,gl = extend_with_ref_list ids seq gl in extend_with_auto_hints bases seq gl in let result=ground_tac (Proofview.V82.of_tactic solver) startseq gl in qflag:=backup;result with reraise -> qflag:=backup;raise reraise (* special for compatibility with Intuition let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str let defined_connectives=lazy [[],EvalConstRef (destConst (constant "not")); [],EvalConstRef (destConst (constant "iff"))] let normalize_evaluables= onAllHypsAndConcl (function None->unfold_in_concl (Lazy.force defined_connectives) | Some id-> unfold_in_hyp (Lazy.force defined_connectives) (Tacexpr.InHypType id)) *) open Pp open Genarg open Ppconstr open Printer let pr_firstorder_using_raw _ _ _ = Pptactic.pr_auto_using pr_reference let pr_firstorder_using_glob _ _ _ = Pptactic.pr_auto_using (pr_or_var (fun x -> pr_global (snd x))) let pr_firstorder_using_typed _ _ _ = Pptactic.pr_auto_using pr_global let warn_deprecated_syntax = CWarnings.create ~name:"firstorder-deprecated-syntax" ~category:"deprecated" (fun () -> Pp.strbrk "Deprecated syntax; use \",\" as separator") ARGUMENT EXTEND firstorder_using TYPED AS reference_list PRINTED BY pr_firstorder_using_typed RAW_TYPED AS reference_list RAW_PRINTED BY pr_firstorder_using_raw GLOB_TYPED AS reference_list GLOB_PRINTED BY pr_firstorder_using_glob | [ "using" reference(a) ] -> [ [a] ] | [ "using" reference(a) "," ne_reference_list_sep(l,",") ] -> [ a::l ] | [ "using" reference(a) reference(b) reference_list(l) ] -> [ warn_deprecated_syntax (); a::b::l ] | [ ] -> [ [] ] END TACTIC EXTEND firstorder [ "firstorder" tactic_opt(t) firstorder_using(l) ] -> [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) l []) ] | [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) [] l) ] | [ "firstorder" tactic_opt(t) firstorder_using(l) "with" ne_preident_list(l') ] -> [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) l l') ] END TACTIC EXTEND gintuition [ "gintuition" tactic_opt(t) ] -> [ Proofview.V82.tactic (gen_ground_tac false (Option.map (tactic_of_value ist) t) [] []) ] END open Proofview.Notations open Cc_plugin open Decl_mode_plugin let default_declarative_automation = Proofview.tclUNIT () >>= fun () -> (* delay for [congruence_depth] *) Tacticals.New.tclORELSE (Tacticals.New.tclORELSE (Auto.h_trivial [] None) (Cctac.congruence_tac !congruence_depth [])) (Proofview.V82.tactic (gen_ground_tac true (Some (Tacticals.New.tclTHEN (snd (default_solver ())) (Cctac.congruence_tac !congruence_depth []))) [] [])) let () = Decl_proof_instr.register_automation_tac default_declarative_automation coq-8.6/plugins/firstorder/ground.ml0000644000175000017500000000733213022274260017160 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* () in List.iter f (Classops.coercions ()); red_flags:= CClosure.RedFlags.red_add_transparent CClosure.betaiotazeta (Names.Id.Pred.full,Names.Cpred.complement !predref) let ground_tac solver startseq gl= update_flags (); let rec toptac skipped seq gl= if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then Feedback.msg_debug (Printer.pr_goal gl); tclORELSE (axiom_tac seq.gl seq) begin try let (hd,seq1)=take_formula seq and re_add s=re_add_formula_list skipped s in let continue=toptac [] and backtrack gl=toptac (hd::skipped) seq1 gl in match hd.pat with Right rpat-> begin match rpat with Rand-> and_tac backtrack continue (re_add seq1) | Rforall-> let backtrack1= if !qflag then tclFAIL 0 (Pp.str "reversible in 1st order mode") else backtrack in forall_tac backtrack1 continue (re_add seq1) | Rarrow-> arrow_tac backtrack continue (re_add seq1) | Ror-> or_tac backtrack continue (re_add seq1) | Rfalse->backtrack | Rexists(i,dom,triv)-> let (lfp,seq2)=collect_quantified seq in let backtrack2=toptac (lfp@skipped) seq2 in if !qflag && seq.depth>0 then quantified_tac lfp backtrack2 continue (re_add seq) else backtrack2 (* need special backtracking *) end | Left lpat-> begin match lpat with Lfalse-> left_false_tac hd.id | Land ind-> left_and_tac ind backtrack hd.id continue (re_add seq1) | Lor ind-> left_or_tac ind backtrack hd.id continue (re_add seq1) | Lforall (_,_,_)-> let (lfp,seq2)=collect_quantified seq in let backtrack2=toptac (lfp@skipped) seq2 in if !qflag && seq.depth>0 then quantified_tac lfp backtrack2 continue (re_add seq) else backtrack2 (* need special backtracking *) | Lexists ind -> if !qflag then left_exists_tac ind backtrack hd.id continue (re_add seq1) else backtrack | LA (typ,lap)-> let la_tac= begin match lap with LLatom -> backtrack | LLand (ind,largs) | LLor(ind,largs) | LLfalse (ind,largs)-> (ll_ind_tac ind largs backtrack hd.id continue (re_add seq1)) | LLforall p -> if seq.depth>0 && !qflag then (ll_forall_tac p backtrack hd.id continue (re_add seq1)) else backtrack | LLexists (ind,l) -> if !qflag then ll_ind_tac ind l backtrack hd.id continue (re_add seq1) else backtrack | LLarrow (a,b,c) -> (ll_arrow_tac a b c backtrack hd.id continue (re_add seq1)) end in ll_atom_tac typ la_tac hd.id continue (re_add seq1) end with Heap.EmptyHeap->solver end gl in let seq, gl' = startseq gl in wrap (List.length (pf_hyps gl)) true (toptac []) seq gl' coq-8.6/plugins/firstorder/unify.mli0000644000175000017500000000160713022274260017164 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> (int*constr) list type instance= Real of (int*constr)*int (* nb trous*terme*valeur heuristique *) | Phantom of constr (* domaine de quantification *) val unif_atoms : metavariable -> constr -> constr -> constr -> instance option val more_general : (int*constr) -> (int*constr) -> bool coq-8.6/plugins/firstorder/unify.ml0000644000175000017500000001031113022274260017003 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (n,subst_meta [i,t] tn)) !sigma) in let rec head_reduce t= (* forbids non-sigma-normal meta in head position*) match kind_of_term t with Meta i-> (try head_reduce (Int.List.assoc i !sigma) with Not_found->t) | _->t in Queue.add (t1,t2) bige; try while true do let t1,t2=Queue.take bige in let nt1=head_reduce (whd_betaiotazeta Evd.empty t1) and nt2=head_reduce (whd_betaiotazeta Evd.empty t2) in match (kind_of_term nt1),(kind_of_term nt2) with Meta i,Meta j-> if not (Int.equal i j) then if i let t=subst_meta !sigma nt2 in if Int.Set.is_empty (free_rels t) && not (occur_term (mkMeta i) t) then bind i t else raise (UFAIL(nt1,nt2)) | _,Meta i -> let t=subst_meta !sigma nt1 in if Int.Set.is_empty (free_rels t) && not (occur_term (mkMeta i) t) then bind i t else raise (UFAIL(nt1,nt2)) | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> Queue.add (a,c) bige;Queue.add (pop b,pop d) bige | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> Queue.add (pa,pb) bige; Queue.add (ca,cb) bige; let l=Array.length va in if not (Int.equal l (Array.length vb)) then raise (UFAIL (nt1,nt2)) else for i=0 to l-1 do Queue.add (va.(i),vb.(i)) bige done | App(ha,va),App(hb,vb)-> Queue.add (ha,hb) bige; let l=Array.length va in if not (Int.equal l (Array.length vb)) then raise (UFAIL (nt1,nt2)) else for i=0 to l-1 do Queue.add (va.(i),vb.(i)) bige done | _->if not (eq_constr_nounivs nt1 nt2) then raise (UFAIL (nt1,nt2)) done; assert false (* this place is unreachable but needed for the sake of typing *) with Queue.Empty-> !sigma let value i t= let add x y= if x<0 then y else if y<0 then x else x+y in let rec vaux term= if isMeta term && Int.equal (destMeta term) i then 0 else let f v t=add v (vaux t) in let vr=fold_constr f (-1) term in if vr<0 then -1 else vr+1 in vaux t type instance= Real of (int*constr)*int | Phantom of constr let mk_rel_inst t= let new_rel=ref 1 in let rel_env=ref [] in let rec renum_rec d t= match kind_of_term t with Meta n-> (try mkRel (d+(Int.List.assoc n !rel_env)) with Not_found-> let m= !new_rel in incr new_rel; rel_env:=(n,m) :: !rel_env; mkRel (m+d)) | _ -> map_constr_with_binders succ renum_rec d t in let nt=renum_rec 0 t in (!new_rel - 1,nt) let unif_atoms i dom t1 t2= try let t=Int.List.assoc i (unif t1 t2) in if isMeta t then Some (Phantom dom) else Some (Real(mk_rel_inst t,value i t1)) with UFAIL(_,_) ->None | Not_found ->Some (Phantom dom) let renum_metas_from k n t= (* requires n = max (free_rels t) *) let l=List.init n (fun i->mkMeta (k+i)) in substl l t let more_general (m1,t1) (m2,t2)= let mt1=renum_metas_from 0 m1 t1 and mt2=renum_metas_from m1 m2 t2 in try let sigma=unif mt1 mt2 in let p (n,t)= nfalse coq-8.6/plugins/firstorder/instances.mli0000644000175000017500000000141713022274260020020 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Formula.t list * Sequent.t val give_instances : Formula.t list -> Sequent.t -> (Unify.instance * global_reference) list val quantified_tac : Formula.t list -> seqtac with_backtracking coq-8.6/plugins/firstorder/rules.mli0000644000175000017500000000306113022274260017160 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* tactic) -> Sequent.t -> tactic type lseqtac= global_reference -> seqtac type 'a with_backtracking = tactic -> 'a val wrap : int -> bool -> seqtac val basename_of_global: global_reference -> Id.t val clear_global: global_reference -> tactic val axiom_tac : constr -> Sequent.t -> tactic val ll_atom_tac : constr -> lseqtac with_backtracking val and_tac : seqtac with_backtracking val or_tac : seqtac with_backtracking val arrow_tac : seqtac with_backtracking val left_and_tac : pinductive -> lseqtac with_backtracking val left_or_tac : pinductive -> lseqtac with_backtracking val left_false_tac : global_reference -> tactic val ll_ind_tac : pinductive -> constr list -> lseqtac with_backtracking val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking val forall_tac : seqtac with_backtracking val left_exists_tac : pinductive -> lseqtac with_backtracking val ll_forall_tac : types -> lseqtac with_backtracking val normalize_evaluables : tactic coq-8.6/plugins/firstorder/ground_plugin.mlpack0000644000175000017500000000006613022274260021372 0ustar mdenesmdenesFormula Unify Sequent Rules Instances Ground G_ground coq-8.6/plugins/firstorder/formula.mli0000644000175000017500000000404413022274260017475 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a -> int) -> ('b -> 'b -> int) -> 'a -> 'a -> 'b -> 'b -> int val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) -> 'a -> 'a -> 'b -> 'b -> 'c ->'c -> int type ('a,'b) sum = Left of 'a | Right of 'b type counter = bool -> metavariable val construct_nhyps : pinductive -> Proof_type.goal Tacmach.sigma -> int array val ind_hyps : int -> pinductive -> constr list -> Proof_type.goal Tacmach.sigma -> Context.Rel.t array type atoms = {positive:constr list;negative:constr list} type side = Hyp | Concl | Hint val dummy_id: global_reference val build_atoms : Proof_type.goal Tacmach.sigma -> counter -> side -> constr -> bool * atoms type right_pattern = Rarrow | Rand | Ror | Rfalse | Rforall | Rexists of metavariable*constr*bool type left_arrow_pattern= LLatom | LLfalse of pinductive*constr list | LLand of pinductive*constr list | LLor of pinductive*constr list | LLforall of constr | LLexists of pinductive*constr list | LLarrow of constr*constr*constr type left_pattern= Lfalse | Land of pinductive | Lor of pinductive | Lforall of metavariable*constr*bool | Lexists of pinductive | LA of constr*left_arrow_pattern type t={id: global_reference; constr: constr; pat: (left_pattern,right_pattern) sum; atoms: atoms} (*exception Is_atom of constr*) val build_formula : side -> global_reference -> types -> Proof_type.goal Tacmach.sigma -> counter -> (t,types) sum coq-8.6/plugins/firstorder/sequent.mli0000644000175000017500000000345313022274260017517 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* global_reference -> global_reference list CM.t -> global_reference list CM.t val cm_remove : constr -> global_reference -> global_reference list CM.t -> global_reference list CM.t module HP: Heap.S with type elt=Formula.t type t = {redexes:HP.t; context: global_reference list CM.t; latoms:constr list; gl:types; glatom:constr option; cnt:counter; history:History.t; depth:int} val deepen: t -> t val record: h_item -> t -> t val lookup: h_item -> t -> bool val add_formula : side -> global_reference -> constr -> t -> Proof_type.goal sigma -> t val re_add_formula_list : Formula.t list -> t -> t val find_left : constr -> t -> global_reference val take_formula : t -> Formula.t * t val empty_seq : int -> t val extend_with_ref_list : global_reference list -> t -> Proof_type.goal sigma -> t * Proof_type.goal sigma val extend_with_auto_hints : Hints.hint_db_name list -> t -> Proof_type.goal sigma -> t * Proof_type.goal sigma val print_cmap: global_reference list CM.t -> Pp.std_ppcmds coq-8.6/plugins/firstorder/instances.ml0000644000175000017500000001441513022274260017651 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (OrderedConstr.compare d1 d2) | Real((m1,c1),n1),Real((m2,c2),n2)-> ((-) =? (-) ==? OrderedConstr.compare) m2 m1 n1 n2 c1 c2 | Phantom(_),Real((m,_),_)-> if Int.equal m 0 then -1 else 1 | Real((m,_),_),Phantom(_)-> if Int.equal m 0 then 1 else -1 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 Globnames.RefOrdered.compare id1 id2 module OrderedInstance= struct type t=instance * Globnames.global_reference let compare (inst1,id1) (inst2,id2)= (compare_instance =? compare_gr) inst2 inst1 id2 id1 (* we want a __decreasing__ total order *) end module IS=Set.Make(OrderedInstance) let make_simple_atoms seq= let ratoms= match seq.glatom with Some t->[t] | None->[] in {negative=seq.latoms;positive=ratoms} let do_sequent setref triv id seq i dom atoms= let flag=ref true in let phref=ref triv in let do_atoms a1 a2 = let do_pair t1 t2 = match unif_atoms i dom t1 t2 with None->() | Some (Phantom _) ->phref:=true | Some c ->flag:=false;setref:=IS.add (c,id) !setref in List.iter (fun t->List.iter (do_pair t) a2.negative) a1.positive; List.iter (fun t->List.iter (do_pair t) a2.positive) a1.negative in HP.iter (fun lf->do_atoms atoms lf.atoms) seq.redexes; do_atoms atoms (make_simple_atoms seq); !flag && !phref let match_one_quantified_hyp setref seq lf= match lf.pat with Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))-> if do_sequent setref triv lf.id seq i dom lf.atoms then setref:=IS.add ((Phantom dom),lf.id) !setref | _ -> anomaly (Pp.str "can't happen") let give_instances lf seq= let setref=ref IS.empty in List.iter (match_one_quantified_hyp setref seq) lf; IS.elements !setref (* collector for the engine *) let rec collect_quantified seq= try let hd,seq1=take_formula seq in (match hd.pat with Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> let (q,seq2)=collect_quantified seq1 in ((hd::q),seq2) | _->[],seq) with Heap.EmptyHeap -> [],seq (* open instances processor *) let dummy_bvid=Id.of_string "x" let mk_open_instance id idc gl m t= let env=pf_env gl in let evmap=Refiner.project gl in let var_id= if id==dummy_id then dummy_bvid else let typ=pf_unsafe_type_of gl idc in (* since we know we will get a product, reduction is not too expensive *) let (nam,_,_)=destProd (whd_all env evmap typ) in match nam with Name id -> id | Anonymous -> dummy_bvid in let revt=substl (List.init m (fun i->mkRel (m-i))) t in let rec aux n avoid env evmap decls = if Int.equal n 0 then evmap, decls else let nid=(fresh_id avoid var_id gl) in let evmap = Sigma.Unsafe.of_evar_map evmap in let Sigma ((c, _), evmap, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in let evmap = Sigma.to_evar_map evmap in let decl = LocalAssum (Name nid, c) in aux (n-1) (nid::avoid) (Environ.push_rel decl env) evmap (decl::decls) in let evmap, decls = aux m [] env evmap [] in evmap, decls, revt (* tactics *) let left_instance_tac (inst,id) continue seq= match inst with Phantom dom-> if lookup (id,None) seq then tclFAIL 0 (Pp.str "already done") else tclTHENS (Proofview.V82.of_tactic (cut dom)) [tclTHENLIST [Proofview.V82.of_tactic introf; pf_constr_of_global id (fun idc -> (fun gls-> Proofview.V82.of_tactic (generalize [mkApp(idc, [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])]) gls)); Proofview.V82.of_tactic introf; tclSOLVE [wrap 1 false continue (deepen (record (id,None) seq))]]; tclTRY (Proofview.V82.of_tactic assumption)] | Real((m,t) as c,_)-> if lookup (id,Some c) seq then tclFAIL 0 (Pp.str "already done") else let special_generalize= if m>0 then pf_constr_of_global id (fun idc -> fun gl-> let evmap,rc,ot = mk_open_instance id idc gl m t in let gt= it_mkLambda_or_LetIn (mkApp(idc,[|ot|])) rc in let evmap, _ = try Typing.type_of (pf_env gl) evmap gt with e when CErrors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in tclTHEN (Refiner.tclEVARS evmap) (Proofview.V82.of_tactic (generalize [gt])) gl) else pf_constr_of_global id (fun idc -> Proofview.V82.of_tactic (generalize [mkApp(idc,[|t|])])) in tclTHENLIST [special_generalize; Proofview.V82.of_tactic introf; tclSOLVE [wrap 1 false continue (deepen (record (id,Some c) seq))]] let right_instance_tac inst continue seq= match inst with Phantom dom -> tclTHENS (Proofview.V82.of_tactic (cut dom)) [tclTHENLIST [Proofview.V82.of_tactic introf; (fun gls-> Proofview.V82.of_tactic (split (ImplicitBindings [mkVar (Tacmach.pf_nth_hyp_id gls 1)])) gls); tclSOLVE [wrap 0 true continue (deepen seq)]]; tclTRY (Proofview.V82.of_tactic assumption)] | Real ((0,t),_) -> (tclTHEN (Proofview.V82.of_tactic (split (ImplicitBindings [t]))) (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> tclFAIL 0 (Pp.str "not implemented ... yet") let instance_tac inst= if (snd inst)==dummy_id then right_instance_tac (fst inst) else left_instance_tac inst let quantified_tac lf backtrack continue seq gl= let insts=give_instances lf seq in tclORELSE (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts)) backtrack gl coq-8.6/plugins/firstorder/rules.ml0000644000175000017500000001635613022274260017022 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* tactic) -> Sequent.t -> tactic type lseqtac= global_reference -> seqtac type 'a with_backtracking = tactic -> 'a let wrap n b continue seq gls= Control.check_for_interrupt (); let nc=pf_hyps gls in let env=pf_env gls in let rec aux i nc ctx= if i<=0 then seq else match nc with []->anomaly (Pp.str "Not the expected number of hyps") | nd::q-> let id = get_id nd in if occur_var env id (pf_concl gls) || List.exists (occur_var_in_decl env id) ctx then (aux (i-1) q (nd::ctx)) else add_formula Hyp (VarRef id) (get_type nd) (aux (i-1) q (nd::ctx)) gls in let seq1=aux n nc [] in let seq2=if b then add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in continue seq2 gls let basename_of_global=function VarRef id->id | _->assert false let clear_global=function VarRef id-> Proofview.V82.of_tactic (clear [id]) | _->tclIDTAC (* connection rules *) let axiom_tac t seq= try pf_constr_of_global (find_left t seq) (fun c -> Proofview.V82.of_tactic (exact_no_check c)) with Not_found->tclFAIL 0 (Pp.str "No axiom link") let ll_atom_tac a backtrack id continue seq= tclIFTHENELSE (try tclTHENLIST [pf_constr_of_global (find_left a seq) (fun left -> pf_constr_of_global id (fun id -> Proofview.V82.of_tactic (generalize [mkApp(id, [|left|])]))); clear_global id; Proofview.V82.of_tactic intro] with Not_found->tclFAIL 0 (Pp.str "No link")) (wrap 1 false continue seq) backtrack (* right connectives rules *) let and_tac backtrack continue seq= tclIFTHENELSE (Proofview.V82.of_tactic simplest_split) (wrap 0 true continue seq) backtrack let or_tac backtrack continue seq= tclORELSE (Proofview.V82.of_tactic (any_constructor false (Some (Proofview.V82.tactic (tclCOMPLETE (wrap 0 true continue seq)))))) backtrack let arrow_tac backtrack continue seq= tclIFTHENELSE (Proofview.V82.of_tactic intro) (wrap 1 true continue seq) (tclORELSE (tclTHEN (Proofview.V82.of_tactic introf) (tclCOMPLETE (wrap 1 true continue seq))) backtrack) (* left connectives rules *) let left_and_tac ind backtrack id continue seq gls= let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE (tclTHENLIST [Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim); clear_global id; tclDO n (Proofview.V82.of_tactic intro)]) (wrap n false continue seq) backtrack gls let left_or_tac ind backtrack id continue seq gls= let v=construct_nhyps ind gls in let f n= tclTHENLIST [clear_global id; tclDO n (Proofview.V82.of_tactic intro); wrap n false continue seq] in tclIFTHENSVELSE (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)) (Array.map f v) backtrack gls let left_false_tac id= Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim) (* left arrow connective rules *) (* We use this function for false, and, or, exists *) let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl= let rcs=ind_hyps 0 indu largs gl in let vargs=Array.of_list largs in (* construire le terme H->B, le generaliser etc *) let myterm idc i= let rc=rcs.(i) in let p=List.length rc in let cstr=mkApp ((mkConstructU ((ind,(i+1)),u)),vargs) in let vars=Array.init p (fun j->mkRel (p-j)) in let capply=mkApp ((lift p cstr),vars) in let head=mkApp ((lift p idc),[|capply|]) in it_mkLambda_or_LetIn head rc in let lp=Array.length rcs in let newhyps idc =List.init lp (myterm idc) in tclIFTHENELSE (tclTHENLIST [pf_constr_of_global id (fun idc -> Proofview.V82.of_tactic (generalize (newhyps idc))); clear_global id; tclDO lp (Proofview.V82.of_tactic intro)]) (wrap lp false continue seq) backtrack gl let ll_arrow_tac a b c backtrack id continue seq= let cc=mkProd(Anonymous,a,(lift 1 b)) in let d idc =mkLambda (Anonymous,b, mkApp (idc, [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in tclORELSE (tclTHENS (Proofview.V82.of_tactic (cut c)) [tclTHENLIST [Proofview.V82.of_tactic introf; clear_global id; wrap 1 false continue seq]; tclTHENS (Proofview.V82.of_tactic (cut cc)) [pf_constr_of_global id (fun c -> Proofview.V82.of_tactic (exact_no_check c)); tclTHENLIST [pf_constr_of_global id (fun idc -> Proofview.V82.of_tactic (generalize [d idc])); clear_global id; Proofview.V82.of_tactic introf; Proofview.V82.of_tactic introf; tclCOMPLETE (wrap 2 true continue seq)]]]) backtrack (* quantifier rules (easy side) *) let forall_tac backtrack continue seq= tclORELSE (tclIFTHENELSE (Proofview.V82.of_tactic intro) (wrap 0 true continue seq) (tclORELSE (tclTHEN (Proofview.V82.of_tactic introf) (tclCOMPLETE (wrap 0 true continue seq))) backtrack)) (if !qflag then tclFAIL 0 (Pp.str "reversible in 1st order mode") else backtrack) let left_exists_tac ind backtrack id continue seq gls= let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)) (tclTHENLIST [clear_global id; tclDO n (Proofview.V82.of_tactic intro); (wrap (n-1) false continue seq)]) backtrack gls let ll_forall_tac prod backtrack id continue seq= tclORELSE (tclTHENS (Proofview.V82.of_tactic (cut prod)) [tclTHENLIST [Proofview.V82.of_tactic intro; pf_constr_of_global id (fun idc -> (fun gls-> let id0=pf_nth_hyp_id gls 1 in let term=mkApp(idc,[|mkVar(id0)|]) in tclTHEN (Proofview.V82.of_tactic (generalize [term])) (Proofview.V82.of_tactic (clear [id0])) gls)); clear_global id; Proofview.V82.of_tactic intro; tclCOMPLETE (wrap 1 false continue (deepen seq))]; tclCOMPLETE (wrap 0 true continue (deepen seq))]) backtrack (* rules for instantiation with unification moved to instances.ml *) (* special for compatibility with old Intuition *) let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str let defined_connectives=lazy [AllOccurrences,EvalConstRef (fst (destConst (constant "not"))); AllOccurrences,EvalConstRef (fst (destConst (constant "iff")))] let normalize_evaluables= onAllHypsAndConcl (function None-> Proofview.V82.of_tactic (unfold_in_concl (Lazy.force defined_connectives)) | Some id -> Proofview.V82.of_tactic (unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly))) coq-8.6/plugins/firstorder/formula.ml0000644000175000017500000001707713022274260017336 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* metavariable exception Is_atom of constr let meta_succ m = m+1 let rec nb_prod_after n c= match kind_of_term c with | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else 1+(nb_prod_after 0 b) | _ -> 0 let construct_nhyps ind gls = let nparams = (fst (Global.lookup_inductive (fst ind))).mind_nparams in let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in let hyp = nb_prod_after nparams in Array.map hyp constr_types (* indhyps builds the array of arrays of constructor hyps for (ind largs)*) let ind_hyps nevar ind largs gls= let types= Inductiveops.arities_of_constructors (pf_env gls) ind in let myhyps t = let t1=prod_applist t largs in let t2=snd (decompose_prod_n_assum nevar t1) in fst (decompose_prod_assum t2) in Array.map myhyps types let special_nf gl= let infos=CClosure.create_clos_infos !red_flags (pf_env gl) in (fun t -> CClosure.norm_val infos (CClosure.inject t)) let special_whd gl= let infos=CClosure.create_clos_infos !red_flags (pf_env gl) in (fun t -> CClosure.whd_val infos (CClosure.inject t)) type kind_of_formula= Arrow of constr*constr | False of pinductive*constr list | And of pinductive*constr list*bool | Or of pinductive*constr list*bool | Exists of pinductive*constr list | Forall of constr*constr | Atom of constr let kind_of_formula gl term = let normalize=special_nf gl in let cciterm=special_whd gl term in match match_with_imp_term cciterm with Some (a,b)-> Arrow(a,(pop b)) |_-> match match_with_forall_term cciterm with Some (_,a,b)-> Forall(a,b) |_-> match match_with_nodep_ind cciterm with Some (i,l,n)-> let ind,u=destInd i in let (mib,mip) = Global.lookup_inductive ind in let nconstr=Array.length mip.mind_consnames in if Int.equal nconstr 0 then False((ind,u),l) else let has_realargs=(n>0) in let is_trivial= let is_constant c = Int.equal (nb_prod c) mib.mind_nparams in Array.exists is_constant mip.mind_nf_lc in if Inductiveops.mis_is_recursive (ind,mib,mip) || (has_realargs && not is_trivial) then Atom cciterm else if Int.equal nconstr 1 then And((ind,u),l,is_trivial) else Or((ind,u),l,is_trivial) | _ -> match match_with_sigma_type cciterm with Some (i,l)-> Exists((destInd i),l) |_-> Atom (normalize cciterm) type atoms = {positive:constr list;negative:constr list} type side = Hyp | Concl | Hint let no_atoms = (false,{positive=[];negative=[]}) let dummy_id=VarRef (Id.of_string "_") (* "_" cannot be parsed *) let build_atoms gl metagen side cciterm = let trivial =ref false and positive=ref [] and negative=ref [] in let normalize=special_nf gl in let rec build_rec env polarity cciterm= match kind_of_formula gl cciterm with False(_,_)->if not polarity then trivial:=true | Arrow (a,b)-> build_rec env (not polarity) a; build_rec env polarity b | And(i,l,b) | Or(i,l,b)-> if b then begin let unsigned=normalize (substnl env 0 cciterm) in if polarity then positive:= unsigned :: !positive else negative:= unsigned :: !negative end; let v = ind_hyps 0 i l gl in let g i _ decl = build_rec env polarity (lift i (get_type decl)) in let f l = List.fold_left_i g (1-(List.length l)) () l in if polarity && (* we have a constant constructor *) Array.exists (function []->true|_->false) v then trivial:=true; Array.iter f v | Exists(i,l)-> let var=mkMeta (metagen true) in let v =(ind_hyps 1 i l gl).(0) in let g i _ decl = build_rec (var::env) polarity (lift i (get_type decl)) in List.fold_left_i g (2-(List.length l)) () v | Forall(_,b)-> let var=mkMeta (metagen true) in build_rec (var::env) polarity b | Atom t-> let unsigned=substnl env 0 t in if not (isMeta unsigned) then (* discarding wildcard atoms *) if polarity then positive:= unsigned :: !positive else negative:= unsigned :: !negative in begin match side with Concl -> build_rec [] true cciterm | Hyp -> build_rec [] false cciterm | Hint -> let rels,head=decompose_prod cciterm in let env=List.rev_map (fun _->mkMeta (metagen true)) rels in build_rec env false head;trivial:=false (* special for hints *) end; (!trivial, {positive= !positive; negative= !negative}) type right_pattern = Rarrow | Rand | Ror | Rfalse | Rforall | Rexists of metavariable*constr*bool type left_arrow_pattern= LLatom | LLfalse of pinductive*constr list | LLand of pinductive*constr list | LLor of pinductive*constr list | LLforall of constr | LLexists of pinductive*constr list | LLarrow of constr*constr*constr type left_pattern= Lfalse | Land of pinductive | Lor of pinductive | Lforall of metavariable*constr*bool | Lexists of pinductive | LA of constr*left_arrow_pattern type t={id:global_reference; constr:constr; pat:(left_pattern,right_pattern) sum; atoms:atoms} let build_formula side nam typ gl metagen= let normalize = special_nf gl in try let m=meta_succ(metagen false) in let trivial,atoms= if !qflag then build_atoms gl metagen side typ else no_atoms in let pattern= match side with Concl -> let pat= match kind_of_formula gl typ with False(_,_) -> Rfalse | Atom a -> raise (Is_atom a) | And(_,_,_) -> Rand | Or(_,_,_) -> Ror | Exists (i,l) -> let d = get_type (List.last (ind_hyps 0 i l gl).(0)) in Rexists(m,d,trivial) | Forall (_,a) -> Rforall | Arrow (a,b) -> Rarrow in Right pat | _ -> let pat= match kind_of_formula gl typ with False(i,_) -> Lfalse | Atom a -> raise (Is_atom a) | And(i,_,b) -> if b then let nftyp=normalize typ in raise (Is_atom nftyp) else Land i | Or(i,_,b) -> if b then let nftyp=normalize typ in raise (Is_atom nftyp) else Lor i | Exists (ind,_) -> Lexists ind | Forall (d,_) -> Lforall(m,d,trivial) | Arrow (a,b) -> let nfa=normalize a in LA (nfa, match kind_of_formula gl a with False(i,l)-> LLfalse(i,l) | Atom t-> LLatom | And(i,l,_)-> LLand(i,l) | Or(i,l,_)-> LLor(i,l) | Arrow(a,c)-> LLarrow(a,c,b) | Exists(i,l)->LLexists(i,l) | Forall(_,_)->LLforall a) in Left pat in Left {id=nam; constr=normalize typ; pat=pattern; atoms=atoms} with Is_atom a-> Right a (* already in nf *) coq-8.6/plugins/firstorder/sequent.ml0000644000175000017500000001370713022274260017351 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* if b then incr cnt;!cnt let priority = (* pure heuristics, <=0 for non reversible *) function Right rf-> begin match rf with Rarrow -> 100 | Rand -> 40 | Ror -> -15 | Rfalse -> -50 | Rforall -> 100 | Rexists (_,_,_) -> -29 end | Left lf -> match lf with Lfalse -> 999 | Land _ -> 90 | Lor _ -> 40 | Lforall (_,_,_) -> -30 | Lexists _ -> 60 | LA(_,lap) -> match lap with LLatom -> 0 | LLfalse (_,_) -> 100 | LLand (_,_) -> 80 | LLor (_,_) -> 70 | LLforall _ -> -20 | LLexists (_,_) -> 50 | LLarrow (_,_,_) -> -10 module OrderedFormula= struct type t=Formula.t let compare e1 e2= (priority e1.pat) - (priority e2.pat) end module OrderedConstr= struct type t=constr let compare=constr_ord end type h_item = global_reference * (int*constr) option module Hitem= struct type t = h_item let compare (id1,co1) (id2,co2)= let c = Globnames.RefOrdered.compare id1 id2 in if c = 0 then let cmp (i1, c1) (i2, c2) = let c = Int.compare i1 i2 in if c = 0 then OrderedConstr.compare c1 c2 else c in Option.compare cmp co1 co2 else c end module CM=Map.Make(OrderedConstr) module History=Set.Make(Hitem) let cm_add typ nam cm= try let l=CM.find typ cm in CM.add typ (nam::l) cm with Not_found->CM.add typ [nam] cm let cm_remove typ nam cm= try let l=CM.find typ cm in let l0=List.filter (fun id-> not (Globnames.eq_gr id nam)) l in match l0 with []->CM.remove typ cm | _ ->CM.add typ l0 cm with Not_found ->cm module HP=Heap.Functional(OrderedFormula) type t= {redexes:HP.t; context:(global_reference list) CM.t; latoms:constr list; gl:types; glatom:constr option; cnt:counter; history:History.t; depth:int} let deepen seq={seq with depth=seq.depth-1} let record item seq={seq with history=History.add item seq.history} let lookup item seq= History.mem item seq.history || match item with (_,None)->false | (id,Some ((m,t) as c))-> let p (id2,o)= match o with None -> false | Some ((m2,t2) as c2)-> Globnames.eq_gr id id2 && m2>m && more_general c2 c in History.exists p seq.history let add_formula side nam t seq gl= match build_formula side nam t gl seq.cnt with Left f-> begin match side with Concl -> {seq with redexes=HP.add f seq.redexes; gl=f.constr; glatom=None} | _ -> {seq with redexes=HP.add f seq.redexes; context=cm_add f.constr nam seq.context} end | Right t-> match side with Concl -> {seq with gl=t;glatom=Some t} | _ -> {seq with context=cm_add t nam seq.context; latoms=t::seq.latoms} let re_add_formula_list lf seq= let do_one f cm= if f.id == dummy_id then cm else cm_add f.constr f.id cm in {seq with redexes=List.fold_right HP.add lf seq.redexes; context=List.fold_right do_one lf seq.context} let find_left t seq=List.hd (CM.find t seq.context) (*let rev_left seq= try let lpat=(HP.maximum seq.redexes).pat in left_reversible lpat with Heap.EmptyHeap -> false *) let rec take_formula seq= let hd=HP.maximum seq.redexes and hp=HP.remove seq.redexes in if hd.id == dummy_id then let nseq={seq with redexes=hp} in if seq.gl==hd.constr then hd,nseq else take_formula nseq (* discarding deprecated goal *) else hd,{seq with redexes=hp; context=cm_remove hd.constr hd.id seq.context} let empty_seq depth= {redexes=HP.empty; context=CM.empty; latoms=[]; gl=(mkMeta 1); glatom=None; cnt=newcnt (); history=History.empty; depth=depth} let expand_constructor_hints = List.map_append (function | IndRef ind -> List.init (Inductiveops.nconstructors ind) (fun i -> ConstructRef (ind,i+1)) | gr -> [gr]) let extend_with_ref_list l seq gl = let l = expand_constructor_hints l in let f gr (seq,gl) = let gl, c = pf_eapply Evd.fresh_global gl gr in let typ=(pf_unsafe_type_of gl c) in (add_formula Hyp gr typ seq gl,gl) in List.fold_right f l (seq,gl) open Hints let extend_with_auto_hints l seq gl= let seqref=ref seq in let f p_a_t = match repr_hint p_a_t.code with Res_pf (c,_) | Give_exact (c,_) | Res_pf_THEN_trivial_fail (c,_) -> let (c, _, _) = c in (try let gr = global_of_constr c in let typ=(pf_unsafe_type_of gl c) in seqref:=add_formula Hint gr typ !seqref gl with Not_found->()) | _-> () in let g _ _ l = List.iter f l in let h dbname= let hdb= try searchtable_map dbname with Not_found-> error ("Firstorder: "^dbname^" : No such Hint database") in Hint_db.iter g hdb in List.iter h l; !seqref, gl (*FIXME: forgetting about universes*) let print_cmap map= let print_entry c l s= let xc=Constrextern.extern_constr false (Global.env ()) Evd.empty c in str "| " ++ prlist Printer.pr_global l ++ str " : " ++ Ppconstr.pr_constr_expr xc ++ cut () ++ s in (v 0 (str "-----" ++ cut () ++ CM.fold print_entry map (mt ()) ++ str "-----")) coq-8.6/plugins/funind/0000755000175000017500000000000013022274260014423 5ustar mdenesmdenescoq-8.6/plugins/funind/merge.ml0000644000175000017500000011235413022274260016062 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* false) t1 t2 then true else false let rec compare_constr' t1 t2 = if compare_constr_nosub t1 t2 then true else (compare_constr (compare_constr') t1 t2) let rec substitterm prof t by_t in_u = if (compare_constr' (lift prof t) in_u) then (lift prof by_t) else map_constr_with_binders succ (fun i -> substitterm i t by_t) prof in_u let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl let understand = Pretyping.understand (Global.env()) Evd.empty (** Operations on names and identifiers *) let id_of_name = function Anonymous -> Id.of_string "H" | Name id -> id;; let name_of_string str = Name (Id.of_string str) let string_of_name nme = Id.to_string (id_of_name nme) (** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) let isVarf f x = match x with | GVar (_,x) -> Id.equal x f | _ -> false (** [ident_global_exist id] returns true if identifier [id] is linked in global environment. *) let ident_global_exist id = try let ans = CRef (Libnames.Ident (Loc.ghost,id), None) in let _ = ignore (Constrintern.intern_constr (Global.env()) ans) in true with e when CErrors.noncritical e -> false (** [next_ident_fresh id] returns a fresh identifier (ie not linked in global env) with base [id]. *) let next_ident_fresh (id:Id.t) = let res = ref id in while ident_global_exist !res do res := Nameops.lift_subscript !res done; !res (** {2 Debugging} *) (* comment this line to see debug msgs *) let msg x = () ;; let pr_lconstr c = str "" (* uncomment this to see debugging *) let prconstr c = msg (str" " ++ Printer.pr_lconstr c) let prconstrnl c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") let prlistconstr lc = List.iter prconstr lc let prstr s = msg(str s) let prNamedConstr s c = begin msg(str ""); msg(str(s^" { ") ++ Printer.pr_lconstr c ++ str " } "); msg(str ""); end let prNamedRConstr s c = begin msg(str ""); msg(str(s^" { ") ++ Printer.pr_glob_constr c ++ str " } "); msg(str ""); end let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc let prNamedLConstr s lc = begin prstr "[ "; prstr s; prNamedLConstr_aux lc; prstr " ]\n"; end let prNamedLDecl s lc = begin prstr s; prstr "\n"; List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc; prstr "\n"; end let prNamedRLDecl s lc = begin prstr s; prstr "\n"; prstr "{ "; List.iter (fun x -> match x with | (nm,None,Some tp) -> prNamedRConstr (string_of_name nm) tp | (nm,Some bdy,None) -> prNamedRConstr ("(letin) "^string_of_name nm) bdy | _ -> assert false ) lc; prstr " }\n"; prstr "\n"; end let showind (id:Id.t) = let cstrid = Constrintern.global_reference id in let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in List.iter (fun decl -> print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":"); prconstr (get_type decl); print_string "\n") ib1.mind_arity_ctxt; Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1); Array.iteri (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) ib1.mind_user_lc (** {2 Misc} *) exception Found of int (* Array scanning *) let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int = match Array.findi pred arr with | None -> Array.length arr (* all elt are positive *) | Some i -> i (* Like List.chop but except that [i] is the size of the suffix of [l]. *) let list_chop_end i l = let size_prefix = List.length l -i in if size_prefix < 0 then failwith "list_chop_end" else List.chop size_prefix l let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = let i = ref 0 in List.fold_left (fun acc x -> let res = f !i acc x in i := !i + 1; res) acc arr let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = let i = ref 0 in List.filter (fun x -> let res = f !i x in i := !i + 1; res) l (** Iteration module *) module For = struct let rec map i j (f: int -> 'a) = if i>j then [] else f i :: (map (i+1) j f) let rec foldup i j (f: 'a -> int -> 'a) acc = if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc let rec folddown i j (f: 'a -> int -> 'a) acc = if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc let fold i j = if i Printf.sprintf "Linked %d" i | Unlinked -> Printf.sprintf "Unlinked" | Funres -> Printf.sprintf "Funres" let linkmonad f lnkvar = match lnkvar with | Linked i -> Linked (f i) | Unlinked -> Unlinked | Funres -> Funres let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar (* This map is used to deal with debruijn linked indices. *) module Link = Map.Make (Int) let pr_links l = Printf.printf "links:\n"; Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l; Printf.printf "_____________\n" type 'a merged_arg = | Prm_stable of 'a | Prm_linked of 'a | Prm_arg of 'a | Arg_stable of 'a | Arg_linked of 'a | Arg_funres (** Information about graph merging of two inductives. All rel_decl list are IN REVERSE ORDER (ie well suited for compose) *) type merge_infos = { ident:Id.t; (** new inductive name *) mib1: mutual_inductive_body; oib1: one_inductive_body; mib2: mutual_inductive_body; oib2: one_inductive_body; (** Array of links of the first inductive (should be all stable) *) lnk1: int merged_arg array; (** Array of links of the second inductive (point to the first ind param/args) *) lnk2: int merged_arg array; (** rec params which remain rec param (ie not linked) *) recprms1: Context.Rel.Declaration.t list; recprms2: Context.Rel.Declaration.t list; nrecprms1: int; nrecprms2: int; (** rec parms which became non parm (either linked to something or because after a rec parm that became non parm) *) otherprms1: Context.Rel.Declaration.t list; otherprms2: Context.Rel.Declaration.t list; notherprms1:int; notherprms2:int; (** args which remain args in merge *) args1:Context.Rel.Declaration.t list; args2:Context.Rel.Declaration.t list; nargs1:int; nargs2:int; (** functional result args *) funresprms1: Context.Rel.Declaration.t list; funresprms2: Context.Rel.Declaration.t list; nfunresprms1:int; nfunresprms2:int; } let pr_merginfo x = let i,s= match x with | Prm_linked i -> Some i,"Prm_linked" | Arg_linked i -> Some i,"Arg_linked" | Prm_stable i -> Some i,"Prm_stable" | Prm_arg i -> Some i,"Prm_arg" | Arg_stable i -> Some i,"Arg_stable" | Arg_funres -> None , "Arg_funres" in match i with | Some i -> Printf.sprintf "%s(%d)" s i | None -> Printf.sprintf "%s" s let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false (* ?? prm_linked?? *) let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false let is_stable x = match x with Arg_stable _ | Prm_stable _ | Prm_arg _ -> true | _ -> false let isArg_funres x = match x with Arg_funres -> true | _ -> false let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list = let prms = list_filteri (fun i _ -> isPrm_stable lnk.(i)) l in let args = list_filteri (fun i _ -> isArg_stable lnk.(i)) l in let fres = list_filteri (fun i _ -> isArg_funres lnk.(i)) l in prms@args@fres (** Reverse the link map, keeping only linked vars, elements are list of int as several vars may be linked to the same var. *) let revlinked lnk = For.fold 0 (Array.length lnk - 1) (fun acc k -> match lnk.(k) with | Unlinked | Funres -> acc | Linked i -> let old = try Link.find i acc with Not_found -> [] in Link.add i (k::old) acc) Link.empty let array_switch arr i j = let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list = let larr = Array.of_list l in let _ = Array.iteri (fun j x -> match x with | Prm_linked i -> array_switch larr i j | Arg_linked i -> array_switch larr i j | Prm_stable i -> () | Prm_arg i -> () | Arg_stable i -> () | Arg_funres -> () ) lnk in filter_shift_stable lnk (Array.to_list larr) (** {1 Utilities for merging} *) let ind1name = Id.of_string "__ind1" let ind2name = Id.of_string "__ind2" (** Performs verifications on two graphs before merging: they must not be co-inductive, and for the moment they must not be mutual either. *) let verify_inds mib1 mib2 = if mib1.mind_finite == Decl_kinds.CoFinite then error "First argument is coinductive"; if mib2.mind_finite == Decl_kinds.CoFinite then error "Second argument is coinductive"; if not (Int.equal mib1.mind_ntypes 1) then error "First argument is mutual"; if not (Int.equal mib2.mind_ntypes 1) then error "Second argument is mutual"; () (* (** [build_raw_params prms_decl avoid] returns a list of variables attributed to the list of decl [prms_decl], avoiding names in [avoid]. *) let build_raw_params prms_decl avoid = let dummy_constr = compose_prod (List.map (fun (x,_,z) -> x,z) prms_decl) (mkRel 1) in let _ = prNamedConstr "DUMMY" dummy_constr in let dummy_glob_constr = Detyping.detype false avoid [] dummy_constr in let _ = prNamedRConstr "RAWDUMMY" dummy_glob_constr in let res,_ = glob_decompose_prod dummy_glob_constr in let comblist = List.combine prms_decl res in comblist, res , (avoid @ (Id.Set.elements (ids_of_glob_constr dummy_glob_constr))) *) let ids_of_rawlist avoid rawl = List.fold_left Id.Set.union avoid (List.map ids_of_glob_constr rawl) (** {1 Merging function graphs} *) (** [shift_linked_params mib1 mib2 lnk] Computes which parameters (rec uniform and ordinary ones) of mutual inductives [mib1] and [mib2] remain uniform when linked by [lnk]. All parameters are considered, ie we take parameters of the first inductive body of [mib1] and [mib2]. Explanation: The two inductives have parameters, some of the first are recursively uniform, some of the last are functional result of the functional graph. (I x1 x2 ... xk ... xk' ... xn) (J y1 y2 ... xl ... yl' ... ym) Problem is, if some rec unif params are linked to non rec unif ones, they become non rec (and the following too). And functinal argument have to be shifted at the end *) let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id = let _ = prstr "\nYOUHOU shift\n" in let linked_targets = revlinked lnk2 in let is_param_of_mib1 x = x < mib1.mind_nparams_rec in let is_param_of_mib2 x = x < mib2.mind_nparams_rec in let is_targetted_by_non_recparam_lnk1 i = try let targets = Link.find i linked_targets in List.exists (fun x -> not (is_param_of_mib2 x)) targets with Not_found -> false in let mlnk1 = Array.mapi (fun i lkv -> let isprm = is_param_of_mib1 i in let prmlost = is_targetted_by_non_recparam_lnk1 i in match isprm , prmlost, lnk1.(i) with | true , true , _ -> Prm_arg i (* recparam becoming ordinary *) | true , false , _-> Prm_stable i (* recparam remains recparam*) | false , false , Funres -> Arg_funres | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *) | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *) lnk1 in let mlnk2 = Array.mapi (fun i lkv -> (* Is this correct if some param of ind2 is lost? *) let isprm = is_param_of_mib2 i in match isprm , lnk2.(i) with | true , Linked j when not (is_param_of_mib1 j) -> Prm_arg j (* recparam becoming ordinary *) | true , Linked j -> Prm_linked j (*recparam linked to recparam*) | true , Unlinked -> Prm_stable i (* recparam remains recparam*) | false , Linked j -> Arg_linked j (* Args of lnk2 lost *) | false , Unlinked -> Arg_stable i (* Args of lnk2 remains *) | false , Funres -> Arg_funres | true , Funres -> assert false (* fun res cannot be a rec param *) ) lnk2 in let oib1 = mib1.mind_packets.(0) in let oib2 = mib2.mind_packets.(0) in (* count params remaining params *) let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in let bldprms arity_ctxt mlnk = list_fold_lefti (fun i (acc1,acc2,acc3,acc4) x -> prstr (pr_merginfo mlnk.(i));prstr "\n"; match mlnk.(i) with | Prm_stable _ -> x::acc1 , acc2 , acc3, acc4 | Prm_arg _ -> acc1 , x::acc2 , acc3, acc4 | Arg_stable _ -> acc1 , acc2 , x::acc3, acc4 | Arg_funres -> acc1 , acc2 , acc3, x::acc4 | _ -> acc1 , acc2 , acc3, acc4) ([],[],[],[]) arity_ctxt in (* let arity_ctxt2 = build_raw_params oib2.mind_arity_ctxt (Id.Set.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*) let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in let _ = prstr "\n\n\n" in let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in let _ = prstr "\notherprms1:\n" in let _ = List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); prconstr (get_type decl); prstr "\n") otherprms1 in let _ = prstr "\notherprms2:\n" in let _ = List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); prconstr (get_type decl); prstr "\n") otherprms2 in { ident=id; mib1=mib1; oib1 = oib1; mib2=mib2; oib2 = oib2; lnk1 = mlnk1; lnk2 = mlnk2; nrecprms1 = n_params1; recprms1 = recprms1; otherprms1 = otherprms1; args1 = args1; funresprms1 = funresprms1; notherprms1 = Array.length mlnk1 - n_params1; nfunresprms1 = List.length funresprms1; nargs1 = List.length args1; nrecprms2 = n_params2; recprms2 = recprms2; otherprms2 = otherprms2; args2 = args2; funresprms2 = funresprms2; notherprms2 = Array.length mlnk2 - n_params2; nargs2 = List.length args2; nfunresprms2 = List.length funresprms2; } (** {1 Merging functions} *) exception NoMerge let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in match c1 , c2 with | GApp(_,f1, arr1), GApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> let _ = prstr "\nICI1!\n" in let args = filter_shift_stable lnk (arr1 @ arr2) in GApp (Loc.ghost,GVar (Loc.ghost,shift.ident) , args) | GApp(_,f1, arr1), GApp(_,f2,arr2) -> raise NoMerge | GLetIn(_,nme,bdy,trm) , _ -> let _ = prstr "\nICI2!\n" in let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in GLetIn(Loc.ghost,nme,bdy,newtrm) | _, GLetIn(_,nme,bdy,trm) -> let _ = prstr "\nICI3!\n" in let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in GLetIn(Loc.ghost,nme,bdy,newtrm) | _ -> let _ = prstr "\nICI4!\n" in raise NoMerge let rec merge_app_unsafe c1 c2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in match c1 , c2 with | GApp(_,f1, arr1), GApp(_,f2,arr2) -> let args = filter_shift_stable lnk (arr1 @ arr2) in GApp (Loc.ghost,GVar(Loc.ghost,shift.ident) , args) (* FIXME: what if the function appears in the body of the let? *) | GLetIn(_,nme,bdy,trm) , _ -> let _ = prstr "\nICI2 '!\n" in let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in GLetIn(Loc.ghost,nme,bdy,newtrm) | _, GLetIn(_,nme,bdy,trm) -> let _ = prstr "\nICI3 '!\n" in let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in GLetIn(Loc.ghost,nme,bdy,newtrm) | _ -> let _ = prstr "\nICI4 '!\n" in raise NoMerge (* Heuristic when merging two lists of hypothesis: merge every rec calls of branch 1 with all rec calls of branch 2. *) (* TODO: reecrire cette heuristique (jusqu'a merge_types) *) let rec merge_rec_hyps shift accrec (ltyp:(Name.t * glob_constr option * glob_constr option) list) filter_shift_stable : (Name.t * glob_constr option * glob_constr option) list = let mergeonehyp t reldecl = match reldecl with | (nme,x,Some (GApp(_,i,args) as ind)) -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable) | (nme,Some _,None) -> error "letins with recursive calls not treated yet" | (nme,None,Some _) -> assert false | (nme,None,None) | (nme,Some _,Some _) -> assert false in match ltyp with | [] -> [] | (nme,None,Some (GApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> let rechyps = List.map (mergeonehyp t) accrec in rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable let build_suppl_reccall (accrec:(Name.t * glob_constr) list) concl2 shift = List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec let find_app (nme:Id.t) ltyp = try ignore (List.map (fun x -> match x with | _,None,Some (GApp(_,f,_)) when isVarf nme f -> raise (Found 0) | _ -> ()) ltyp); false with Found _ -> true let prnt_prod_or_letin nm letbdy typ = match letbdy , typ with | Some lbdy , None -> prNamedRConstr ("(letin) " ^ string_of_name nm) lbdy | None , Some tp -> prNamedRConstr (string_of_name nm) tp | _ , _ -> assert false let rec merge_types shift accrec1 (ltyp1:(Name.t * glob_constr option * glob_constr option) list) (concl1:glob_constr) (ltyp2:(Name.t * glob_constr option * glob_constr option) list) concl2 : (Name.t * glob_constr option * glob_constr option) list * glob_constr = let _ = prstr "MERGE_TYPES\n" in let _ = prstr "ltyp 1 : " in let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in let _ = prstr "\nltyp 2 : " in let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp2 in let _ = prstr "\n" in let res = match ltyp1 with | [] -> let isrec1 = not (List.is_empty accrec1) in let isrec2 = find_app ind2name ltyp2 in let rechyps = if isrec1 && isrec2 then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *) merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 filter_shift_stable_right @ merge_rec_hyps shift accrec1 [name_of_string "concl2",None, Some concl2] filter_shift_stable else if isrec1 (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *) then merge_rec_hyps shift accrec1 (ltyp2@[name_of_string "concl2",None,Some concl2]) filter_shift_stable else if isrec2 then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 filter_shift_stable_right else ltyp2 in let _ = prstr"\nrechyps : " in let _ = List.iter(fun (nm,lbdy,tp)-> prnt_prod_or_letin nm lbdy tp) rechyps in let _ = prstr "MERGE CONCL : " in let _ = prNamedRConstr "concl1" concl1 in let _ = prstr " with " in let _ = prNamedRConstr "concl2" concl2 in let _ = prstr "\n" in let concl = merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in let _ = prstr "FIN " in let _ = prNamedRConstr "concl" concl in let _ = prstr "\n" in rechyps , concl | (nme,None, Some t1)as e ::lt1 -> (match t1 with | GApp(_,f,carr) when isVarf ind1name f -> merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 | _ -> let recres, recconcl2 = merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in ((nme,None,Some t1) :: recres) , recconcl2) | (nme,Some bd, None) ::lt1 -> (* FIXME: what if ind1name appears in bd? *) let recres, recconcl2 = merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in ((nme,Some bd,None) :: recres) , recconcl2 | (_,None,None)::_ | (_,Some _,Some _)::_ -> assert false in res (** [build_link_map_aux allargs1 allargs2 shift] returns the mapping of linked args [allargs2] to target args of [allargs1] as specified in [shift]. [allargs1] and [allargs2] are in reverse order. Also returns the list of unlinked vars of [allargs2]. *) let build_link_map_aux (allargs1:Id.t array) (allargs2:Id.t array) (lnk:int merged_arg array) = Array.fold_left_i (fun i acc e -> if Int.equal i (Array.length lnk - 1) then acc (* functional arg, not in allargs *) else match e with | Prm_linked j | Arg_linked j -> Id.Map.add allargs2.(i) allargs1.(j) acc | _ -> acc) Id.Map.empty lnk let build_link_map allargs1 allargs2 lnk = let allargs1 = Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs1) in let allargs2 = Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs2) in build_link_map_aux allargs1 allargs2 lnk (** [merge_one_constructor lnk shift typcstr1 typcstr2] merges the two constructor rawtypes [typcstr1] and [typcstr2]. [typcstr1] and [typcstr2] contain all parameters (including rec. unif. ones) of their inductive. if [typcstr1] and [typcstr2] are of the form: forall recparams1, forall ordparams1, H1a -> H2a... (I1 x1 y1 ... z1) forall recparams2, forall ordparams2, H2b -> H2b... (I2 x2 y2 ... z2) we build: forall recparams1 (recparams2 without linked params), forall ordparams1 (ordparams2 without linked params), H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ... -> (newI x1 ... z1 x2 y2 ...z2 without linked params) where Hix' have been adapted, ie: - linked vars have been changed, - rec calls to I1 and I2 have been replaced by rec calls to newI. More precisely calls to I1 and I2 have been merge by an experimental heuristic (in particular if n o rec calls for I1 or I2 is found, we use the conclusion as a rec call). See [merge_types] above. Precond: vars sets of [typcstr1] and [typcstr2] must be disjoint. TODO: return nothing if equalities (after linking) are contradictory. *) let merge_one_constructor (shift:merge_infos) (typcstr1:glob_constr) (typcstr2:glob_constr) : glob_constr = (* FIXME: les noms des parametres corerspondent en principe au parametres du niveau mib, mais il faudrait s'en assurer *) (* shift.nfunresprmsx last args are functional result *) let nargs1 = shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in let nargs2 = shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in let allargs1,rest1 = glob_decompose_prod_or_letin_n nargs1 typcstr1 in let allargs2,rest2 = glob_decompose_prod_or_letin_n nargs2 typcstr2 in (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *) let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in let rest2 = change_vars linked_map rest2 in let hyps1,concl1 = glob_decompose_prod_or_letin rest1 in let hyps2,concl2' = glob_decompose_prod_or_letin rest2 in let ltyp,concl2 = merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in let _ = prNamedRLDecl "ltyp result:" ltyp in let typ = glob_compose_prod_or_letin concl2 (List.rev ltyp) in let revargs1 = list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in let _ = prNamedRLDecl "ltyp allargs1" allargs1 in let _ = prNamedRLDecl "ltyp revargs1" revargs1 in let revargs2 = list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in let _ = prNamedRLDecl "ltyp allargs2" allargs2 in let _ = prNamedRLDecl "ltyp revargs2" revargs2 in let typwithprms = glob_compose_prod_or_letin typ (List.rev revargs2 @ List.rev revargs1) in typwithprms (** constructor numbering *) let fresh_cstror_suffix , cstror_suffix_init = let cstror_num = ref 0 in (fun () -> let res = string_of_int !cstror_num in cstror_num := !cstror_num + 1; res) , (fun () -> cstror_num := 0) (** [merge_constructor_id id1 id2 shift] returns the identifier of the new constructor from the id of the two merged constructor and the merging info. *) let merge_constructor_id id1 id2 shift:Id.t = let id = Id.to_string shift.ident ^ "_" ^ fresh_cstror_suffix () in next_ident_fresh (Id.of_string id) (** [merge_constructors lnk shift avoid] merges the two list of constructor [(name*type)]. These are translated to glob_constr first, each of them having distinct var names. *) let merge_constructors (shift:merge_infos) (avoid:Id.Set.t) (typcstr1:(Id.t * glob_constr) list) (typcstr2:(Id.t * glob_constr) list) : (Id.t * glob_constr) list = List.flatten (List.map (fun (id1,rawtyp1) -> List.map (fun (id2,rawtyp2) -> let typ = merge_one_constructor shift rawtyp1 rawtyp2 in let newcstror_id = merge_constructor_id id1 id2 shift in let _ = prstr "\n**************\n" in newcstror_id , typ) typcstr2) typcstr1) (** [merge_inductive_body lnk shift avoid oib1 oib2] merges two inductive bodies [oib1] and [oib2], linking with [lnk], params info in [shift], avoiding identifiers in [avoid]. *) let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) (oib2:one_inductive_body) = (* building glob_constr type of constructors *) let mkrawcor nme avoid typ = (* first replace rel 1 by a varname *) let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in Detyping.detype false (Id.Set.elements avoid) (Global.env()) Evd.empty substindtyp in let lcstr1: glob_constr list = Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in (* add to avoid all indentifiers of lcstr1 *) let avoid2 = Id.Set.union avoid (ids_of_rawlist avoid lcstr1) in let lcstr2 = Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in let avoid3 = Id.Set.union avoid (ids_of_rawlist avoid lcstr2) in let params1 = try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) with e when CErrors.noncritical e -> [] in let params2 = try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) with e when CErrors.noncritical e -> [] in let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in cstror_suffix_init(); params1,params2,merge_constructors shift avoid3 lcstr1 lcstr2 (** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual inductive bodies [mib1] and [mib2] linking vars with [lnk]. [shift] information on parameters of the new inductive. For the moment, inductives are supposed to be non mutual. *) let merge_mutual_inductive_body (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) = (* Mutual not treated, we take first ind body of each. *) merge_inductive_body shift Id.Set.empty mib1.mind_packets.(0) mib2.mind_packets.(0) let glob_constr_to_constr_expr x = (* build a constr_expr from a glob_constr *) Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Id.Set.empty) x let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let params = prms2 @ prms1 in let resparams = List.fold_left (fun acc (nme,tp) -> let _ = prstr "param :" in let _ = prNamedRConstr (string_of_name nme) tp in let _ = prstr " ; " in let typ = glob_constr_to_constr_expr tp in LocalRawAssum ([(Loc.ghost,nme)], Constrexpr_ops.default_binder_kind, typ) :: acc) [] params in let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in let arity,_ = List.fold_left (fun (acc,env) decl -> let nm = Context.Rel.Declaration.get_name decl in let c = get_type decl in let typ = Constrextern.extern_constr false env Evd.empty c in let newenv = Environ.push_rel (LocalAssum (nm,c)) env in CProdN (Loc.ghost, [[(Loc.ghost,nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv) (concl,Global.env()) (shift.funresprms2 @ shift.funresprms1 @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in resparams,arity (** [glob_constr_list_to_inductive_expr ident rawlist] returns the induct_expr corresponding to the the list of constructor types [rawlist], named ident. FIXME: params et cstr_expr (arity) *) let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift (rawlist:(Id.t * glob_constr) list) = let lident = (Loc.ghost, shift.ident), None in let bindlist , cstr_expr = (* params , arities *) merge_rec_params_and_arity prms1 prms2 shift mkSet in let lcstor_expr : (bool * (lident * constr_expr)) list = List.map (* zeta_normalize t ? *) (fun (id,t) -> false, ((Loc.ghost,id),glob_constr_to_constr_expr t)) rawlist in lident , bindlist , Some cstr_expr , lcstor_expr let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) = match rdecl with | LocalAssum (nme,t) -> let traw = Detyping.detype false [] (Global.env()) Evd.empty t in GProd (Loc.ghost,nme,Explicit,traw,t2) | LocalDef _ -> assert false (** [merge_inductive ind1 ind2 lnk] merges two graphs, linking variables specified in [lnk]. Graphs are not supposed to be mutual inductives for the moment. *) let merge_inductive (ind1: inductive) (ind2: inductive) (lnk1: linked_var array) (lnk2: linked_var array) id = let env = Global.env() in let mib1,_ = Inductive.lookup_mind_specif env ind1 in let mib2,_ = Inductive.lookup_mind_specif env ind2 in let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *) (* compute params that become ordinary args (because linked to ord. args) *) let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in let _ = prstr "\nrawlist : " in let _ = List.iter (fun (nm,tp) -> prNamedRConstr (Id.to_string nm) tp;prstr "\n") rawlist in let _ = prstr "\nend rawlist\n" in (* FIX: retransformer en constr ici let shift_prm = { shift_prm with recprms1=prms1; recprms1=prms1; } in *) let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in (* Declare inductive *) let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in let mie,pl,impls = Command.interp_mutual_inductive indl [] false (*FIXMEnon-poly *) false (* means not private *) Decl_kinds.Finite (* means: not coinductive *) in (* Declare the mutual inductive block with its associated schemes *) ignore (Command.declare_mutual_inductive_with_eliminations mie pl impls) (* Find infos on identifier id. *) let find_Function_infos_safe (id:Id.t): Indfun_common.function_info = let kn_of_id x = let f_ref = Libnames.Ident (Loc.ghost,x) in locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref) locate_constant f_ref in try find_Function_infos (kn_of_id id) with Not_found -> errorlabstrm "indfun" (Nameops.pr_id id ++ str " has no functional scheme") (** [merge id1 id2 args1 args2 id] builds and declares a new inductive type called [id], representing the merged graphs of both graphs [ind1] and [ind2]. identifiers occurring in both arrays [args1] and [args2] are considered linked (i.e. are the same variable) in the new graph. Warning: For the moment, repetitions of an id in [args1] or [args2] are not supported. *) let merge (id1:Id.t) (id2:Id.t) (args1:Id.t array) (args2:Id.t array) id : unit = let finfo1 = find_Function_infos_safe id1 in let finfo2 = find_Function_infos_safe id2 in (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *) (* We add one arg (functional arg of the graph) *) let lnk1 = Array.make (Array.length args1 + 1) Unlinked in let lnk2' = (* args2 may be linked to args1 members. FIXME: same as above: vars may be linked inside args2?? *) Array.mapi (fun i c -> match Array.findi (fun i x -> Id.equal x c) args1 with | Some j -> Linked j | None -> Unlinked) args2 in (* We add one arg (functional arg of the graph) *) let lnk2 = Array.append lnk2' (Array.make 1 Unlinked) in (* setting functional results *) let _ = lnk1.(Array.length lnk1 - 1) <- Funres in let _ = lnk2.(Array.length lnk2 - 1) <- Funres in merge_inductive finfo1.graph_ind finfo2.graph_ind lnk1 lnk2 id let remove_last_arg c = let (x,y) = decompose_prod c in let xnolast = List.rev (List.tl (List.rev x)) in compose_prod xnolast y let rec remove_n_fst_list n l = if Int.equal n 0 then l else remove_n_fst_list (n-1) (List.tl l) let remove_n_last_list n l = List.rev (remove_n_fst_list n (List.rev l)) let remove_last_n_arg n c = let (x,y) = decompose_prod c in let xnolast = remove_n_last_list n x in compose_prod xnolast y (* [funify_branches relinfo nfuns branch] returns the branch [branch] of the relinfo [relinfo] modified to fit in a functional principle. Things to do: - remove indargs from rel applications - replace *variables only* corresponding to function (recursive) results by the actual function application. *) let funify_branches relinfo nfuns branch = let mut_induct, induct = match relinfo.indref with | None -> assert false | Some (IndRef ((mutual_ind,i) as ind)) -> mutual_ind,ind | _ -> assert false in let is_dom c = match kind_of_term c with | Ind(((u,_),_)) | Construct(((u,_),_),_) -> MutInd.equal u mut_induct | _ -> false in let _dom_i c = assert (is_dom c); match kind_of_term c with | Ind((u,i)) | Construct((u,_),i) -> i | _ -> assert false in let _is_pred c shift = match kind_of_term c with | Rel i -> let reali = i-shift in (reali>=0 && reali false in (* FIXME: *) LocalDef (Anonymous,mkProp,mkProp) let relprinctype_to_funprinctype relprinctype nfuns = let relinfo = compute_elim_sig relprinctype in assert (not relinfo.farg_in_concl); assert (relinfo.indarg_in_concl); (* first remove indarg and indarg_in_concl *) let relinfo_noindarg = { relinfo with indarg_in_concl = false; indarg = None; concl = remove_last_arg (pop relinfo.concl); } in (* the nfuns last induction arguments are functional ones: remove them *) let relinfo_argsok = { relinfo_noindarg with nargs = relinfo_noindarg.nargs - nfuns; (* args is in reverse order, so remove fst *) args = remove_n_fst_list nfuns relinfo_noindarg.args; concl = popn nfuns relinfo_noindarg.concl } in let new_branches = List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in let relinfo_branches = { relinfo_argsok with branches = new_branches } in relinfo_branches (* @article{ bundy93rippling, author = "Alan Bundy and Andrew Stevens and Frank van Harmelen and Andrew Ireland and Alan Smaill", title = "Rippling: A Heuristic for Guiding Inductive Proofs", journal = "Artificial Intelligence", volume = "62", number = "2", pages = "185-253", year = "1993", url = "citeseer.ist.psu.edu/bundy93rippling.html" } *) coq-8.6/plugins/funind/indfun.mli0000644000175000017500000000107713022274260016416 0ustar mdenesmdenesopen Misctypes val warn_cannot_define_graph : ?loc:Loc.t -> Pp.std_ppcmds * Pp.std_ppcmds -> unit val warn_cannot_define_principle : ?loc:Loc.t -> Pp.std_ppcmds * Pp.std_ppcmds -> unit val do_generate_principle : bool -> (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> unit val functional_induction : bool -> Term.constr -> (Term.constr * Term.constr bindings) option -> Tacexpr.or_and_intro_pattern option -> Proof_type.goal Tacmach.sigma -> Proof_type.goal list Evd.sigma val make_graph : Globnames.global_reference -> unit coq-8.6/plugins/funind/functional_principles_proofs.ml0000644000175000017500000015213113022274260022742 0ustar mdenesmdenesopen Printer open CErrors open Util open Term open Vars open Namegen open Names open Pp open Tacmach open Termops open Proof_type open Tacticals open Tactics open Indfun_common open Libnames open Globnames open Context.Rel.Declaration (* let msgnl = Pp.msgnl *) (* let observe strm = if do_observe () then Pp.msg_debug strm else () let do_observe_tac s tac g = try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v with e -> let e = ExplainErr.process_vernac_interp_error e in let goal = begin try (Printer.pr_goal g) with _ -> assert false end in msg_debug (str "observation "++ s++str " raised exception " ++ Errors.print e ++ str " on goal " ++ goal ); raise e;; let observe_tac_stream s tac g = if do_observe () then do_observe_tac s tac g else tac g let observe_tac s tac g = observe_tac_stream (str s) tac g *) let debug_queue = Stack.create () let rec print_debug_queue e = if not (Stack.is_empty debug_queue) then begin let lmsg,goal = Stack.pop debug_queue in let _ = match e with | Some e -> Feedback.msg_debug (hov 0 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) | None -> begin Feedback.msg_debug (str " from " ++ lmsg ++ str " on goal" ++ fnl() ++ goal); end in print_debug_queue None ; end let observe strm = if do_observe () then Feedback.msg_debug strm else () let do_observe_tac s tac g = let goal = Printer.pr_goal g in let lmsg = (str "observation : ") ++ s in Stack.push (lmsg,goal) debug_queue; try let v = tac g in ignore(Stack.pop debug_queue); v with reraise -> let reraise = CErrors.push reraise in if not (Stack.is_empty debug_queue) then print_debug_queue (Some (fst (ExplainErr.process_vernac_interp_error reraise))); iraise reraise let observe_tac_stream s tac g = if do_observe () then do_observe_tac s tac g else tac g let observe_tac s = observe_tac_stream (str s) let list_chop ?(msg="") n l = try List.chop n l with Failure (msg') -> failwith (msg ^ msg') let make_refl_eq constructor type_of_t t = (* let refl_equal_term = Lazy.force refl_equal in *) mkApp(constructor,[|type_of_t;t|]) type pte_info = { proving_tac : (Id.t list -> Tacmach.tactic); is_valid : constr -> bool } type ptes_info = pte_info Id.Map.t type 'a dynamic_info = { nb_rec_hyps : int; rec_hyps : Id.t list ; eq_hyps : Id.t list; info : 'a } type body_info = constr dynamic_info let finish_proof dynamic_infos g = observe_tac "finish" (Proofview.V82.of_tactic assumption) g let refine c = Tacmach.refine c let thin l = Proofview.V82.of_tactic (Tactics.clear l) let eq_constr u v = eq_constr_nounivs u v let is_trivial_eq t = let res = try begin match kind_of_term t with | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> eq_constr t1 t2 | App(f,[|t1;a1;t2;a2|]) when eq_constr f (jmeq ()) -> eq_constr t1 t2 && eq_constr a1 a2 | _ -> false end with e when CErrors.noncritical e -> false in (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res let rec incompatible_constructor_terms t1 t2 = let c1,arg1 = decompose_app t1 and c2,arg2 = decompose_app t2 in (not (eq_constr t1 t2)) && isConstruct c1 && isConstruct c2 && ( not (eq_constr c1 c2) || List.exists2 incompatible_constructor_terms arg1 arg2 ) let is_incompatible_eq t = let res = try match kind_of_term t with | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> incompatible_constructor_terms t1 t2 | App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) -> (eq_constr u1 u2 && incompatible_constructor_terms t1 t2) | _ -> false with e when CErrors.noncritical e -> false in if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t); res let change_hyp_with_using msg hyp_id t tac : tactic = fun g -> let prov_id = pf_get_new_id hyp_id g in tclTHENS ((* observe_tac msg *) Proofview.V82.of_tactic (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac)))) [tclTHENLIST [ (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); (* observe_tac "change_hyp_with_using rename " *) (Proofview.V82.of_tactic (rename_hyp [prov_id,hyp_id])) ]] g exception TOREMOVE let prove_trivial_eq h_id context (constructor,type_of_term,term) = let nb_intros = List.length context in tclTHENLIST [ tclDO nb_intros (Proofview.V82.of_tactic intro); (* introducing context *) (fun g -> let context_hyps = fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) in let context_hyps' = (mkApp(constructor,[|type_of_term;term|])):: (List.map mkVar context_hyps) in let to_refine = applist(mkVar h_id,List.rev context_hyps') in refine to_refine g ) ] let find_rectype env c = let (t, l) = decompose_app (Reduction.whd_betaiotazeta env c) in match kind_of_term t with | Ind ind -> (t, l) | Construct _ -> (t,l) | _ -> raise Not_found let isAppConstruct ?(env=Global.env ()) t = try let t',l = find_rectype (Global.env ()) t in observe (str "isAppConstruct : " ++ Printer.pr_lconstr t ++ str " -> " ++ Printer.pr_lconstr (applist (t',l))); true with Not_found -> false let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) let clos_norm_flags flgs env sigma t = CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = let nochange ?t' msg = begin observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t ); failwith "NoChange"; end in let eq_constr = Evarconv.e_conv env (ref sigma) in if not (noccurn 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) if not (isApp t) then nochange "not an equality"; let f_eq,args = destApp t in let constructor,t1,t2,t1_typ = try if (eq_constr f_eq (Lazy.force eq)) then let t1 = (args.(1),args.(0)) and t2 = (args.(2),args.(0)) and t1_typ = args.(0) in (Lazy.force refl_equal,t1,t2,t1_typ) else if (eq_constr f_eq (jmeq ())) then (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) else nochange "not an equality" with e when CErrors.noncritical e -> nochange "not an equality" in if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; let rec compute_substitution sub t1 t2 = (* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) if isRel t2 then let t2 = destRel t2 in begin try let t1' = Int.Map.find t2 sub in if not (eq_constr t1 t1') then nochange "twice bound variable"; sub with Not_found -> assert (closed0 t1); Int.Map.add t2 t1 sub end else if isAppConstruct t1 && isAppConstruct t2 then begin let c1,args1 = find_rectype env t1 and c2,args2 = find_rectype env t2 in if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; List.fold_left2 compute_substitution sub args1 args2 end else if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_all env t1) t2) "cannot solve (diff)" in let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in let sub = compute_substitution sub (fst t1) (fst t2) in let end_of_type_with_pop = Termops.pop end_of_type in (*the equation will be removed *) let new_end_of_type = (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 Can be safely replaced by the next comment for Ocaml >= 3.08.4 *) let sub = Int.Map.bindings sub in List.fold_left (fun end_of_type (i,t) -> lift 1 (substnl [t] (i-1) end_of_type)) end_of_type_with_pop sub in let old_context_length = List.length context + 1 in let witness_fun = mkLetIn(Anonymous,make_refl_eq constructor t1_typ (fst t1),t, mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) ) in let new_type_of_hyp,ctxt_size,witness_fun = List.fold_left_i (fun i (end_of_type,ctxt_size,witness_fun) decl -> try let witness = Int.Map.find i sub in if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); (Termops.pop end_of_type,ctxt_size,mkLetIn (get_name decl, witness, get_type decl, witness_fun)) with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) 1 (new_end_of_type,0,witness_fun) context in let new_type_of_hyp = Reductionops.nf_betaiota Evd.empty new_type_of_hyp in let new_ctxt,new_end_of_type = decompose_prod_n_assum ctxt_size new_type_of_hyp in let prove_new_hyp : tactic = tclTHEN (tclDO ctxt_size (Proofview.V82.of_tactic intro)) (fun g -> let all_ids = pf_ids_of_hyps g in let new_ids,_ = list_chop ctxt_size all_ids in let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in let evm, _ = pf_apply Typing.type_of g to_refine in tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g ) in let simpl_eq_tac = change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp in (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) (* str "removing an equation " ++ fnl ()++ *) (* str "old_typ_of_hyp :=" ++ *) (* Printer.pr_lconstr_env *) (* env *) (* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) (* ++ fnl () ++ *) (* str "new_typ_of_hyp := "++ *) (* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) (* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) (* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) (* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) (* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) (* ); *) new_ctxt,new_end_of_type,simpl_eq_tac let is_property (ptes_info:ptes_info) t_x full_type_of_hyp = if isApp t_x then let pte,args = destApp t_x in if isVar pte && Array.for_all closed0 args then try let info = Id.Map.find (destVar pte) ptes_info in info.is_valid full_type_of_hyp with Not_found -> false else false else false let isLetIn t = match kind_of_term t with | LetIn _ -> true | _ -> false let h_reduce_with_zeta cl = Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false; }) cl) let rewrite_until_var arg_num eq_ids : tactic = (* tests if the declares recursive argument is neither a Constructor nor an applied Constructor since such a form for the recursive argument will break the Guard when trying to save the Lemma. *) let test_var g = let _,args = destApp (pf_concl g) in not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num)) in let rec do_rewrite eq_ids g = if test_var g then tclIDTAC g else match eq_ids with | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property"); | eq_id::eq_ids -> tclTHEN (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) (do_rewrite eq_ids) g in do_rewrite eq_ids let rec_pte_id = Id.of_string "Hrec" let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let coq_False = Coqlib.build_coq_False () in let coq_True = Coqlib.build_coq_True () in let coq_I = Coqlib.build_coq_I () in let rec scan_type context type_of_hyp : tactic = if isLetIn type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in (* length of context didn't change ? *) let new_context,new_typ_of_hyp = decompose_prod_n_assum (List.length context) reduced_type_of_hyp in tclTHENLIST [ h_reduce_with_zeta (Locusops.onHyp hyp_id); scan_type new_context new_typ_of_hyp ] else if isProd type_of_hyp then begin let (x,t_x,t') = destProd type_of_hyp in let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in if is_property ptes_infos t_x actual_real_type_of_hyp then begin let pte,pte_args = (destApp t_x) in let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar pte) ptes_infos).proving_tac in let popped_t' = Termops.pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in let prove_new_type_of_hyp = let context_length = List.length context in tclTHENLIST [ tclDO context_length (Proofview.V82.of_tactic intro); (fun g -> let context_hyps_ids = fst (list_chop ~msg:"rec hyp : context_hyps" context_length (pf_ids_of_hyps g)) in let rec_pte_id = pf_get_new_id rec_pte_id g in let to_refine = applist(mkVar hyp_id, List.rev_map mkVar (rec_pte_id::context_hyps_ids) ) in (* observe_tac "rec hyp " *) (tclTHENS (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x)) [ (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); (* observe_tac "prove rec hyp" *) (refine to_refine) ]) g ) ] in tclTHENLIST [ (* observe_tac "hyp rec" *) (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp); scan_type context popped_t' ] end else if eq_constr t_x coq_False then begin (* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) (* str " since it has False in its preconds " *) (* ); *) raise TOREMOVE; (* False -> .. useless *) end else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) else if eq_constr t_x coq_True (* Trivial => we remove this precons *) then (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) (* str " removing useless precond True" *) (* ); *) let popped_t' = Termops.pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in let prove_trivial = let nb_intro = List.length context in tclTHENLIST [ tclDO nb_intro (Proofview.V82.of_tactic intro); (fun g -> let context_hyps = fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) in let to_refine = applist (mkVar hyp_id, List.rev (coq_I::List.map mkVar context_hyps) ) in refine to_refine g ) ] in tclTHENLIST[ change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp ((* observe_tac "prove_trivial" *) prove_trivial); scan_type context popped_t' ] else if is_trivial_eq t_x then (* t_x := t = t => we remove this precond *) let popped_t' = Termops.pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in let hd,args = destApp t_x in let get_args hd args = if eq_constr hd (Lazy.force eq) then (Lazy.force refl_equal,args.(0),args.(1)) else (jmeq_refl (),args.(0),args.(1)) in tclTHENLIST [ change_hyp_with_using "prove_trivial_eq" hyp_id real_type_of_hyp ((* observe_tac "prove_trivial_eq" *) (prove_trivial_eq hyp_id context (get_args hd args))); scan_type context popped_t' ] else begin try let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in tclTHEN tac (scan_type new_context new_t') with Failure "NoChange" -> (* Last thing todo : push the rel in the context and continue *) scan_type (LocalAssum (x,t_x) :: context) t' end end else tclIDTAC in try scan_type [] (Typing.unsafe_type_of env sigma (mkVar hyp_id)), [hyp_id] with TOREMOVE -> thin [hyp_id],[] let clean_goal_with_heq ptes_infos continue_tac (dyn_infos:body_info) = fun g -> let env = pf_env g and sigma = project g in let tac,new_hyps = List.fold_left ( fun (hyps_tac,new_hyps) hyp_id -> let hyp_tac,new_hyp = clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma in (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps ) (tclIDTAC,[]) dyn_infos.rec_hyps in let new_infos = { dyn_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps } in tclTHENLIST [ tac ; (* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos) ] g let heq_id = Id.of_string "Heq" let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = fun g -> let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in tclTHENLIST [ (* We first introduce the variables *) tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding dyn_infos.rec_hyps)); (* Then the equation itself *) Proofview.V82.of_tactic (intro_using heq_id); onLastHypId (fun heq_id -> tclTHENLIST [ (* Then the new hypothesis *) tclMAP (fun id -> Proofview.V82.of_tactic (introduction ~check:false id)) dyn_infos.rec_hyps; observe_tac "after_introduction" (fun g' -> (* We get infos on the equations introduced*) let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in (* compute the new value of the body *) let new_term_value = match kind_of_term new_term_value_eq with | App(f,[| _;_;args2 |]) -> args2 | _ -> observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ pr_lconstr_env (pf_env g') Evd.empty new_term_value_eq ); anomaly (Pp.str "cannot compute new term value") in let fun_body = mkLambda(Anonymous, pf_unsafe_type_of g' term, Termops.replace_term term (mkRel 1) dyn_infos.info ) in let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in let new_infos = {dyn_infos with info = new_body; eq_hyps = heq_id::dyn_infos.eq_hyps } in clean_goal_with_heq ptes_infos continue_tac new_infos g' )]) ] g let my_orelse tac1 tac2 g = try tac1 g with e when CErrors.noncritical e -> (* observe (str "using snd tac since : " ++ CErrors.print e); *) tac2 g let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = let args = Array.of_list (List.map mkVar args_id) in let instanciate_one_hyp hid = my_orelse ( (* we instanciate the hyp if possible *) fun g -> let prov_hid = pf_get_new_id hid g in let c = mkApp(mkVar hid,args) in let evm, _ = pf_apply Typing.type_of g c in tclTHENLIST[ Refiner.tclEVARS evm; Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); thin [hid]; Proofview.V82.of_tactic (rename_hyp [prov_hid,hid]) ] g ) ( (* if not then we are in a mutual function block and this hyp is a recursive hyp on an other function. We are not supposed to use it while proving this principle so that we can trash it *) (fun g -> (* observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); *) thin [hid] g ) ) in if List.is_empty args_id then tclTHENLIST [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; do_prove hyps ] else tclTHENLIST [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; tclMAP instanciate_one_hyp hyps; (fun g -> let all_g_hyps_id = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in let remaining_hyps = List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps in do_prove remaining_hyps g ) ] let build_proof (interactive_proof:bool) (fnames:constant list) ptes_infos dyn_infos : tactic = let rec build_proof_aux do_finalize dyn_infos : tactic = fun g -> (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) match kind_of_term dyn_infos.info with | Case(ci,ct,t,cb) -> let do_finalize_t dyn_info' = fun g -> let t = dyn_info'.info in let dyn_infos = {dyn_info' with info = mkCase(ci,ct,t,cb)} in let g_nb_prod = nb_prod (pf_concl g) in let type_of_term = pf_unsafe_type_of g t in let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in tclTHENSEQ [ Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps))); thin dyn_infos.rec_hyps; Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None); (fun g -> observe_tac "toto" ( tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t); (fun g' -> let g'_nb_prod = nb_prod (pf_concl g') in let nb_instanciate_partial = g'_nb_prod - g_nb_prod in observe_tac "treat_new_case" (treat_new_case ptes_infos nb_instanciate_partial (build_proof do_finalize) t dyn_infos) g' ) ]) g ) ] g in build_proof do_finalize_t {dyn_infos with info = t} g | Lambda(n,t,b) -> begin match kind_of_term( pf_concl g) with | Prod _ -> tclTHEN (Proofview.V82.of_tactic intro) (fun g' -> let open Context.Named.Declaration in let id = pf_last_hyp g' |> get_id in let new_term = pf_nf_betaiota g' (mkApp(dyn_infos.info,[|mkVar id|])) in let new_infos = {dyn_infos with info = new_term} in let do_prove new_hyps = build_proof do_finalize {new_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps } in (* observe_tac "Lambda" *) (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' (* build_proof do_finalize new_infos g' *) ) g | _ -> do_finalize dyn_infos g end | Cast(t,_,_) -> build_proof do_finalize {dyn_infos with info = t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> do_finalize dyn_infos g | App(_,_) -> let f,args = decompose_app dyn_infos.info in begin match kind_of_term f with | App _ -> assert false (* we have collected all the app in decompose_app *) | Proj _ -> assert false (*FIXME*) | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> let new_infos = { dyn_infos with info = (f,args) } in build_proof_args do_finalize new_infos g | Const (c,_) when not (List.mem_f Constant.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 do_finalize new_infos g | Const _ -> do_finalize dyn_infos g | Lambda _ -> let new_term = Reductionops.nf_beta Evd.empty dyn_infos.info in build_proof do_finalize {dyn_infos with info = new_term} g | LetIn _ -> let new_infos = { dyn_infos with info = nf_betaiotazeta dyn_infos.info } in tclTHENLIST [tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Locusops.onConcl; build_proof do_finalize new_infos ] g | Cast(b,_,_) -> build_proof do_finalize {dyn_infos with info = b } g | Case _ | Fix _ | CoFix _ -> let new_finalize dyn_infos = let new_infos = { dyn_infos with info = dyn_infos.info,args } in build_proof_args do_finalize new_infos in build_proof new_finalize {dyn_infos with info = f } g end | Fix _ | CoFix _ -> error ( "Anonymous local (co)fixpoints are not handled yet") | Proj _ -> error "Prod" | Prod _ -> error "Prod" | LetIn _ -> let new_infos = { dyn_infos with info = nf_betaiotazeta dyn_infos.info } in tclTHENLIST [tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Locusops.onConcl; build_proof do_finalize new_infos ] g | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !") and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) observe_tac_stream (str "build_proof with " ++ Printer.pr_lconstr dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> let (f_args',args) = dyn_infos.info in let tac : tactic = fun g -> match args with | [] -> do_finalize {dyn_infos with info = f_args'} g | arg::args -> (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) (* fnl () ++ *) (* pr_goal (Tacmach.sig_it g) *) (* ); *) let do_finalize dyn_infos = let new_arg = dyn_infos.info in (* tclTRYD *) (build_proof_args do_finalize {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} ) in build_proof do_finalize {dyn_infos with info = arg } g in (* observe_tac "build_proof_args" *) (tac ) g in let do_finish_proof dyn_infos = (* tclTRYD *) (clean_goal_with_heq ptes_infos finish_proof dyn_infos) in (* observe_tac "build_proof" *) (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) (* Proof of principles from structural functions *) type static_fix_info = { idx : int; name : Id.t; types : types; offset : int; nb_realargs : int; body_with_param : constr; num_in_block : int } let prove_rec_hyp_for_struct fix_info = (fun eq_hyps -> tclTHEN (rewrite_until_var (fix_info.idx) eq_hyps) (fun g -> let _,pte_args = destApp (pf_concl g) in let rec_hyp_proof = mkApp(mkVar fix_info.name,array_get_start pte_args) in refine rec_hyp_proof g )) let prove_rec_hyp fix_info = { proving_tac = prove_rec_hyp_for_struct fix_info ; is_valid = fun _ -> true } let generalize_non_dep hyp g = (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) let hyps = [hyp] in let env = Global.env () in let hyp_typ = pf_unsafe_type_of g (mkVar hyp) in let to_revert,_ = let open Context.Named.Declaration in Environ.fold_named_context_reverse (fun (clear,keep) decl -> let hyp = get_id decl in if Id.List.mem hyp hyps || List.exists (Termops.occur_var_in_decl env hyp) keep || Termops.occur_var env hyp hyp_typ || Termops.is_section_variable hyp (* should be dangerous *) then (clear,decl::keep) else (hyp::clear,keep)) ~init:([],[]) (pf_env g) in (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) tclTHEN ((* observe_tac "h_generalize" *) (Proofview.V82.of_tactic (generalize (List.map mkVar to_revert) ))) ((* observe_tac "thin" *) (thin to_revert)) g let id_of_decl decl = Nameops.out_name (get_name decl) let var_of_decl decl = mkVar (id_of_decl decl) let revert idl = tclTHEN (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) (thin idl) let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num = (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) let f_def = Global.lookup_constant (fst (destConst f)) in let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in let f_body = Option.get (Global.body_of_constant_body f_def) in let params,f_body_with_params = decompose_lam_n nb_params f_body in let (_,num),(_,_,bodies) = destFix f_body_with_params in let fnames_with_params = let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in fnames in (* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *) (* observe (str "body " ++ pr_lconstr bodies.(num)); *) let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in (* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) let (type_ctxt,type_of_f),evd = let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f in decompose_prod_n_assum (nb_params + nb_args) t,evd in let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in (* Pp.msgnl (str "lemma type " ++ Printer.pr_lconstr lemma_type ++ fnl () ++ str "f_body " ++ Printer.pr_lconstr f_body); *) let f_id = Label.to_id (con_label (fst (destConst f))) in let prove_replacement = tclTHENSEQ [ tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro); observe_tac "" (fun g -> let rec_id = pf_nth_hyp_id g 1 in tclTHENSEQ [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id); observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))); (Proofview.V82.of_tactic intros_reflexivity)] g ) ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) Lemmas.start_proof (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) (mk_equation_id f_id) (Decl_kinds.Global, Flags.is_universe_polymorphism (), (Decl_kinds.Proof Decl_kinds.Theorem)) evd lemma_type (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None))); evd let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try let finfos = find_Function_infos (fst (destConst f)) (*FIXME*) in mkConst (Option.get finfos.equation_lemma) with (Not_found | Option.IsNone as e) -> let f_id = Label.to_id (con_label (fst (destConst f))) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious i*) let equation_lemma_id = (mk_equation_id f_id) in evd := generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; let _ = match e with | Option.IsNone -> let finfos = find_Function_infos (fst (destConst f)) in update_Function {finfos with equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant") ) } | _ -> () in (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) let evd',res = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) in evd:=evd'; let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd res in res in let nb_intro_to_do = nb_prod (pf_concl g) in tclTHEN (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) ( fun g' -> let just_introduced = nLastDecls nb_intro_to_do g' in let open Context.Named.Declaration in let just_introduced_id = List.map get_id just_introduced in tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) (revert just_introduced_id) g' ) g let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnames all_funs _nparams : tactic = fun g -> let princ_type = pf_concl g in (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) (* Pp.msgnl (str "all_funs "); *) (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) let princ_info = compute_elim_sig princ_type in let fresh_id = let avoid = ref (pf_ids_of_hyps g) in (fun na -> let new_id = match na with Name id -> fresh_id !avoid (Id.to_string id) | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; (Name new_id) ) in let fresh_decl = map_name fresh_id in let princ_info : elim_scheme = { princ_info with params = List.map fresh_decl princ_info.params; predicates = List.map fresh_decl princ_info.predicates; branches = List.map fresh_decl princ_info.branches; args = List.map fresh_decl princ_info.args } in let get_body const = match Global.body_of_constant const with | Some body -> Tacred.cbv_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) (Evd.empty) body | None -> error ( "Cannot define a principle over an axiom ") in let fbody = get_body fnames.(fun_num) in let f_ctxt,f_body = decompose_lam fbody in let f_ctxt_length = List.length f_ctxt in let diff_params = princ_info.nparams - f_ctxt_length in let full_params,princ_params,fbody_with_full_params = if diff_params > 0 then let princ_params,full_params = list_chop diff_params princ_info.params in (full_params, (* real params *) princ_params, (* the params of the principle which are not params of the function *) substl (* function instanciated with real params *) (List.map var_of_decl full_params) f_body ) else let f_ctxt_other,f_ctxt_params = list_chop (- diff_params) f_ctxt in let f_body = compose_lam f_ctxt_other f_body in (princ_info.params, (* real params *) [],(* all params are full params *) substl (* function instanciated with real params *) (List.map var_of_decl princ_info.params) f_body ) in observe (str "full_params := " ++ prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl))) full_params ); observe (str "princ_params := " ++ prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl))) princ_params ); observe (str "fbody_with_full_params := " ++ pr_lconstr fbody_with_full_params ); let all_funs_with_full_params = Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs in let fix_offset = List.length princ_params in let ptes_to_fix,infos = match kind_of_term fbody_with_full_params with | Fix((idxs,i),(names,typess,bodies)) -> let bodies_with_all_params = Array.map (fun body -> Reductionops.nf_betaiota Evd.empty (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, List.rev_map var_of_decl princ_params)) ) bodies in let info_array = Array.mapi (fun i types -> let types = prod_applist types (List.rev_map var_of_decl princ_params) in { idx = idxs.(i) - fix_offset; name = Nameops.out_name (fresh_id names.(i)); types = types; offset = fix_offset; nb_realargs = List.length (fst (decompose_lam bodies.(i))) - fix_offset; body_with_param = bodies_with_all_params.(i); num_in_block = i } ) typess in let pte_to_fix,rev_info = List.fold_left_i (fun i (acc_map,acc_info) decl -> let pte = get_name decl in let infos = info_array.(i) in let type_args,_ = decompose_prod infos.types in let nargs = List.length type_args in let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in let app_f = mkApp(f,first_args) in let pte_args = (Array.to_list first_args)@[app_f] in let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in let body_with_param,num = let body = get_body fnames.(i) in let body_with_full_params = Reductionops.nf_betaiota Evd.empty ( applist(body,List.rev_map var_of_decl full_params)) in match kind_of_term body_with_full_params with | Fix((_,num),(_,_,bs)) -> Reductionops.nf_betaiota Evd.empty ( (applist (substl (List.rev (Array.to_list all_funs_with_full_params)) bs.(num), List.rev_map var_of_decl princ_params)) ),num | _ -> error "Not a mutual block" in let info = {infos with types = compose_prod type_args app_pte; body_with_param = body_with_param; num_in_block = num } in (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *) (* str " to " ++ Ppconstr.pr_id info.name); *) (Id.Map.add (Nameops.out_name pte) info acc_map,info::acc_info) ) 0 (Id.Map.empty,[]) (List.rev princ_info.predicates) in pte_to_fix,List.rev rev_info | _ -> Id.Map.empty,[] in let mk_fixes : tactic = let pre_info,infos = list_chop fun_num infos in match pre_info,infos with | [],[] -> tclIDTAC | _, this_fix_info::others_infos -> let other_fix_infos = List.map (fun fi -> fi.name,fi.idx + 1 ,fi.types) (pre_info@others_infos) in if List.is_empty other_fix_infos then if this_fix_info.idx + 1 = 0 then tclIDTAC (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) else observe_tac_stream (str "h_fix " ++ int (this_fix_info.idx +1) ) (Proofview.V82.of_tactic (fix (Some this_fix_info.name) (this_fix_info.idx +1))) else Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) other_fix_infos 0) | _ -> anomaly (Pp.str "Not a valid information") in let first_tac : tactic = (* every operations until fix creations *) tclTHENSEQ [ observe_tac "introducing params" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params))); observe_tac "introducing predictes" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates))); observe_tac "introducing branches" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches))); observe_tac "building fixes" mk_fixes; ] in let intros_after_fixes : tactic = fun gl -> let ctxt,pte_app = (decompose_prod_assum (pf_concl gl)) in let pte,pte_args = (decompose_app pte_app) in try let pte = try destVar pte with DestKO -> anomaly (Pp.str "Property is not a variable") in let fix_info = Id.Map.find pte ptes_to_fix in let nb_args = fix_info.nb_realargs in tclTHENSEQ [ (* observe_tac ("introducing args") *) (tclDO nb_args (Proofview.V82.of_tactic intro)); (fun g -> (* replacement of the function by its body *) let args = nLastDecls nb_args g in let fix_body = fix_info.body_with_param in (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) let open Context.Named.Declaration in let args_id = List.map get_id args in let dyn_infos = { nb_rec_hyps = -100; rec_hyps = []; info = Reductionops.nf_betaiota Evd.empty (applist(fix_body,List.rev_map mkVar args_id)); eq_hyps = [] } in tclTHENSEQ [ observe_tac "do_replace" (do_replace evd full_params (fix_info.idx + List.length princ_params) (args_id@(List.map (fun decl -> Nameops.out_name (get_name decl)) princ_params)) (all_funs.(fix_info.num_in_block)) fix_info.num_in_block all_funs ); let do_prove = build_proof interactive_proof (Array.to_list fnames) (Id.Map.map prove_rec_hyp ptes_to_fix) in let prove_tac branches = let dyn_infos = {dyn_infos with rec_hyps = branches; nb_rec_hyps = List.length branches } in observe_tac "cleaning" (clean_goal_with_heq (Id.Map.map prove_rec_hyp ptes_to_fix) do_prove dyn_infos) in (* observe (str "branches := " ++ *) (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) (* ); *) (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac (List.rev_map id_of_decl princ_info.branches) (List.rev args_id)) ] g ); ] gl with Not_found -> let nb_args = min (princ_info.nargs) (List.length ctxt) in tclTHENSEQ [ tclDO nb_args (Proofview.V82.of_tactic intro); (fun g -> (* replacement of the function by its body *) let args = nLastDecls nb_args g in let open Context.Named.Declaration in let args_id = List.map get_id args in let dyn_infos = { nb_rec_hyps = -100; rec_hyps = []; info = Reductionops.nf_betaiota Evd.empty (applist(fbody_with_full_params, (List.rev_map var_of_decl princ_params)@ (List.rev_map mkVar args_id) )); eq_hyps = [] } in let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in tclTHENSEQ [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]); let do_prove = build_proof interactive_proof (Array.to_list fnames) (Id.Map.map prove_rec_hyp ptes_to_fix) in let prove_tac branches = let dyn_infos = {dyn_infos with rec_hyps = branches; nb_rec_hyps = List.length branches } in clean_goal_with_heq (Id.Map.map prove_rec_hyp ptes_to_fix) do_prove dyn_infos in instanciate_hyps_with_args prove_tac (List.rev_map id_of_decl princ_info.branches) (List.rev args_id) ] g ) ] gl in tclTHEN first_tac intros_after_fixes g (* Proof of principles of general functions *) (* let hrec_id = Recdef.hrec_id *) (* and acc_inv_id = Recdef.acc_inv_id *) (* and ltof_ref = Recdef.ltof_ref *) (* and acc_rel = Recdef.acc_rel *) (* and well_founded = Recdef.well_founded *) (* and list_rewrite = Recdef.list_rewrite *) (* and evaluable_of_global_reference = Recdef.evaluable_of_global_reference *) let prove_with_tcc tcc_lemma_constr eqs : tactic = match !tcc_lemma_constr with | None -> anomaly (Pp.str "No tcc proof !!") | Some lemma -> fun gls -> (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) (* let ids = hid::pf_ids_of_hyps gls in *) tclTHENSEQ [ (* generalize [lemma]; *) (* h_intro hid; *) (* Elim.h_decompose_and (mkVar hid); *) tclTRY(list_rewrite true eqs); (* (fun g -> *) (* let ids' = pf_ids_of_hyps g in *) (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) (* rewrite *) (* ) *) Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some [])) ] gls let backtrack_eqs_until_hrec hrec eqs : tactic = fun gls -> let eqs = List.map mkVar eqs in let rewrite = tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) in let _,hrec_concl = decompose_prod (pf_unsafe_type_of gls (mkVar hrec)) in let f_app = Array.last (snd (destApp hrec_concl)) in let f = (fst (destApp f_app)) in let rec backtrack : tactic = fun g -> let f_app = Array.last (snd (destApp (pf_concl g))) in match kind_of_term f_app with | App(f',_) when eq_constr f' f -> tclIDTAC g | _ -> tclTHEN rewrite backtrack g in backtrack gls let rec rewrite_eqs_in_eqs eqs = match eqs with | [] -> tclIDTAC | eq::eqs -> tclTHEN (tclMAP (fun id gl -> observe_tac (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) (tclTRY (Proofview.V82.of_tactic (Equality.general_rewrite_in true Locus.AllOccurrences true (* dep proofs also: *) true id (mkVar eq) false))) gl ) eqs ) (rewrite_eqs_in_eqs eqs) let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = fun gls -> (tclTHENSEQ [ backtrack_eqs_until_hrec hrec eqs; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) (tclTHENS (* We must have exactly ONE subgoal !*) (Proofview.V82.of_tactic (apply (mkVar hrec))) [ tclTHENSEQ [ (Proofview.V82.of_tactic (keep (tcc_hyps@eqs))); (Proofview.V82.of_tactic (apply (Lazy.force acc_inv))); (fun g -> if is_mes then Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) g else tclIDTAC g ); observe_tac "rew_and_finish" (tclTHENLIST [tclTRY(list_rewrite false (List.map (fun v -> (mkVar v,true)) eqs)); observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); (observe_tac "finishing using" ( tclCOMPLETE( Eauto.eauto_with_bases (true,5) [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ) ) ) ] ) ] ]) ]) gls let is_valid_hypothesis predicates_name = let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.empty in let is_pte typ = if isApp typ then let pte,_ = destApp typ in if isVar pte then Id.Set.mem (destVar pte) predicates_name else false else false in let rec is_valid_hypothesis typ = is_pte typ || match kind_of_term typ with | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' | _ -> false in is_valid_hypothesis let prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation gl = let princ_type = pf_concl gl in let princ_info = compute_elim_sig princ_type in let fresh_id = let avoid = ref (pf_ids_of_hyps gl) in fun na -> let new_id = match na with | Name id -> fresh_id !avoid (Id.to_string id) | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; Name new_id in let fresh_decl = map_name fresh_id in let princ_info : elim_scheme = { princ_info with params = List.map fresh_decl princ_info.params; predicates = List.map fresh_decl princ_info.predicates; branches = List.map fresh_decl princ_info.branches; args = List.map fresh_decl princ_info.args } in let wf_tac = if is_mes then (fun b -> Recdef.tclUSER_if_not_mes tclIDTAC b None) else fun _ -> prove_with_tcc tcc_lemma_ref [] in let real_rec_arg_num = rec_arg_num - princ_info.nparams in let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in (* observe ( *) (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) let (post_rec_arg,pre_rec_arg) = Util.List.chop npost_rec_arg princ_info.args in let rec_arg_id = match List.rev post_rec_arg with | (LocalAssum (Name id,_) | LocalDef (Name id,_,_)) :: _ -> id | _ -> assert false in (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) let subst_constrs = List.map (fun decl -> mkVar (Nameops.out_name (get_name decl))) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in let wf_thm_id = Nameops.out_name (fresh_id (Name (Id.of_string "wf_R"))) in let acc_rec_arg_id = Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) in let revert l = tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l)) in let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = ((* observe_tac "prove_rec_arg_acc" *) (tclCOMPLETE (tclTHEN (Proofview.V82.of_tactic (assert_by (Name wf_thm_id) (mkApp (delayed_force well_founded,[|input_type;relation|])) (Proofview.V82.tactic (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)))) ( (* observe_tac *) (* "apply wf_thm" *) Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))) ) ) ) ) g in let args_ids = List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.args in let lemma = match !tcc_lemma_ref with | None -> error "No tcc proof !!" | Some lemma -> lemma in (* let rec list_diff del_list check_list = *) (* match del_list with *) (* [] -> *) (* [] *) (* | f::r -> *) (* if List.mem f check_list then *) (* list_diff r check_list *) (* else *) (* f::(list_diff r check_list) *) (* in *) let tcc_list = ref [] in let start_tac gls = let hyps = pf_ids_of_hyps gls in let hid = next_ident_away_in_goal (Id.of_string "prov") hyps in tclTHENSEQ [ Proofview.V82.of_tactic (generalize [lemma]); Proofview.V82.of_tactic (Simple.intro hid); Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)); (fun g -> let new_hyps = pf_ids_of_hyps g in tcc_list := List.rev (List.subtract Id.equal new_hyps (hid::hyps)); if List.is_empty !tcc_list then begin tcc_list := [hid]; tclIDTAC g end else thin [hid] g ) ] gls in tclTHENSEQ [ observe_tac "start_tac" start_tac; h_intros (List.rev_map (fun decl -> Nameops.out_name (get_name decl)) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); (* observe_tac "" *) Proofview.V82.of_tactic (assert_by (Name acc_rec_arg_id) (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) (Proofview.V82.tactic prove_rec_arg_acc) ); (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) (* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) (* observe_tac "h_fix " *) (Proofview.V82.of_tactic (fix (Some fix_id) (List.length args_ids + 1))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_unsafe_type_of g (mkVar fix_id) )); tclIDTAC g); *) h_intros (List.rev (acc_rec_arg_id::args_ids)); Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); (* observe_tac "finish" *) (fun gl' -> let body = let _,args = destApp (pf_concl gl') in Array.last args in let body_info rec_hyps = { nb_rec_hyps = List.length rec_hyps; rec_hyps = rec_hyps; eq_hyps = []; info = body } in let acc_inv = lazy ( mkApp ( delayed_force acc_inv_id, [|input_type;relation;mkVar rec_arg_id|] ) ) in let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in let predicates_names = List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.predicates in let pte_info = { proving_tac = (fun eqs -> (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *) (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *) (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) (* observe_tac "new_prove_with_tcc" *) (new_prove_with_tcc is_mes acc_inv fix_id (!tcc_list@(List.map (fun decl -> (Nameops.out_name (get_name decl))) (princ_info.args@princ_info.params) )@ ([acc_rec_arg_id])) eqs ) ); is_valid = is_valid_hypothesis predicates_names } in let ptes_info : pte_info Id.Map.t = List.fold_left (fun map pte_id -> Id.Map.add pte_id pte_info map ) Id.Map.empty predicates_names in let make_proof rec_hyps = build_proof false [f_ref] ptes_info (body_info rec_hyps) in (* observe_tac "instanciate_hyps_with_args" *) (instanciate_hyps_with_args make_proof (List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.branches) (List.rev args_ids) ) gl' ) ] gl coq-8.6/plugins/funind/glob_termops.ml0000644000175000017500000005063513022274260017462 0ustar mdenesmdenesopen Pp open Glob_term open CErrors open Util open Names open Decl_kinds open Misctypes (* Some basic functions to rebuild glob_constr In each of them the location is Loc.ghost *) let mkGRef ref = GRef(Loc.ghost,ref,None) let mkGVar id = GVar(Loc.ghost,id) let mkGApp(rt,rtl) = GApp(Loc.ghost,rt,rtl) let mkGLambda(n,t,b) = GLambda(Loc.ghost,n,Explicit,t,b) let mkGProd(n,t,b) = GProd(Loc.ghost,n,Explicit,t,b) let mkGLetIn(n,t,b) = GLetIn(Loc.ghost,n,t,b) let mkGCases(rto,l,brl) = GCases(Loc.ghost,Term.RegularStyle,rto,l,brl) let mkGSort s = GSort(Loc.ghost,s) let mkGHole () = GHole(Loc.ghost,Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) let mkGCast(b,t) = GCast(Loc.ghost,b,CastConv t) (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) let glob_decompose_prod = let rec glob_decompose_prod args = function | GProd(_,n,k,t,b) -> glob_decompose_prod ((n,t)::args) b | rt -> args,rt in glob_decompose_prod [] let glob_decompose_prod_or_letin = let rec glob_decompose_prod args = function | GProd(_,n,k,t,b) -> glob_decompose_prod ((n,None,Some t)::args) b | GLetIn(_,n,t,b) -> glob_decompose_prod ((n,Some t,None)::args) b | rt -> args,rt in glob_decompose_prod [] let glob_compose_prod = List.fold_left (fun b (n,t) -> mkGProd(n,t,b)) let glob_compose_prod_or_letin = List.fold_left ( fun concl decl -> match decl with | (n,None,Some t) -> mkGProd(n,t,concl) | (n,Some bdy,None) -> mkGLetIn(n,bdy,concl) | _ -> assert false) let glob_decompose_prod_n n = let rec glob_decompose_prod i args c = if i<=0 then args,c else match c with | GProd(_,n,_,t,b) -> glob_decompose_prod (i-1) ((n,t)::args) b | rt -> args,rt in glob_decompose_prod n [] let glob_decompose_prod_or_letin_n n = let rec glob_decompose_prod i args c = if i<=0 then args,c else match c with | GProd(_,n,_,t,b) -> glob_decompose_prod (i-1) ((n,None,Some t)::args) b | GLetIn(_,n,t,b) -> glob_decompose_prod (i-1) ((n,Some t,None)::args) b | rt -> args,rt in glob_decompose_prod n [] let glob_decompose_app = let rec decompose_rapp acc rt = (* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) match rt with | GApp(_,rt,rtl) -> decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt | rt -> rt,List.rev acc in decompose_rapp [] (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) let glob_make_eq ?(typ= mkGHole ()) t1 t2 = mkGApp(mkGRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1]) (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) let glob_make_neq t1 t2 = mkGApp(mkGRef (Lazy.force Coqlib.coq_not_ref),[glob_make_eq t1 t2]) (* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *) let glob_make_or t1 t2 = mkGApp (mkGRef(Lazy.force Coqlib.coq_or_ref),[t1;t2]) (* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding to [P1 \/ ( .... \/ Pn)] *) let rec glob_make_or_list = function | [] -> invalid_arg "mk_or" | [e] -> e | e::l -> glob_make_or e (glob_make_or_list l) let remove_name_from_mapping mapping na = match na with | Anonymous -> mapping | Name id -> Id.Map.remove id mapping let change_vars = let rec change_vars mapping rt = match rt with | GRef _ -> rt | GVar(loc,id) -> let new_id = try Id.Map.find id mapping with Not_found -> id in GVar(loc,new_id) | GEvar _ -> rt | GPatVar _ -> rt | GApp(loc,rt',rtl) -> GApp(loc, change_vars mapping rt', List.map (change_vars mapping) rtl ) | GLambda(loc,name,k,t,b) -> GLambda(loc, name, k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) | GProd(loc,name,k,t,b) -> GProd(loc, name, k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) | GLetIn(loc,name,def,b) -> GLetIn(loc, name, change_vars mapping def, change_vars (remove_name_from_mapping mapping name) b ) | GLetTuple(loc,nal,(na,rto),b,e) -> let new_mapping = List.fold_left remove_name_from_mapping mapping nal in GLetTuple(loc, nal, (na, Option.map (change_vars mapping) rto), change_vars mapping b, change_vars new_mapping e ) | GCases(loc,sty,infos,el,brl) -> GCases(loc,sty, infos, List.map (fun (e,x) -> (change_vars mapping e,x)) el, List.map (change_vars_br mapping) brl ) | GIf(loc,b,(na,e_option),lhs,rhs) -> GIf(loc, change_vars mapping b, (na,Option.map (change_vars mapping) e_option), change_vars mapping lhs, change_vars mapping rhs ) | GRec _ -> error "Local (co)fixes are not supported" | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,c) -> GCast(loc,change_vars mapping b, Miscops.map_cast_type (change_vars mapping) c) and change_vars_br mapping ((loc,idl,patl,res) as br) = let new_mapping = List.fold_right Id.Map.remove idl mapping in if Id.Map.is_empty new_mapping then br else (loc,idl,patl,change_vars new_mapping res) in change_vars let rec alpha_pat excluded pat = match pat with | PatVar(loc,Anonymous) -> let new_id = Indfun_common.fresh_id excluded "_x" in PatVar(loc,Name new_id),(new_id::excluded),Id.Map.empty | PatVar(loc,Name id) -> if Id.List.mem id excluded then let new_id = Namegen.next_ident_away id excluded in PatVar(loc,Name new_id),(new_id::excluded), (Id.Map.add id new_id Id.Map.empty) else pat,excluded,Id.Map.empty | PatCstr(loc,constr,patl,na) -> let new_na,new_excluded,map = match na with | Name id when Id.List.mem id excluded -> let new_id = Namegen.next_ident_away id excluded in Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty | _ -> na,excluded,Id.Map.empty in let new_patl,new_excluded,new_map = List.fold_left (fun (patl,excluded,map) pat -> let new_pat,new_excluded,new_map = alpha_pat excluded pat in (new_pat::patl,new_excluded,Id.Map.fold Id.Map.add new_map map) ) ([],new_excluded,map) patl in PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map let alpha_patl excluded patl = let patl,new_excluded,map = List.fold_left (fun (patl,excluded,map) pat -> let new_pat,new_excluded,new_map = alpha_pat excluded pat in new_pat::patl,new_excluded,(Id.Map.fold Id.Map.add new_map map) ) ([],excluded,Id.Map.empty) patl in (List.rev patl,new_excluded,map) let raw_get_pattern_id pat acc = let rec get_pattern_id pat = match pat with | PatVar(loc,Anonymous) -> assert false | PatVar(loc,Name id) -> [id] | PatCstr(loc,constr,patternl,_) -> List.fold_right (fun pat idl -> let idl' = get_pattern_id pat in idl'@idl ) patternl [] in (get_pattern_id pat)@acc let get_pattern_id pat = raw_get_pattern_id pat [] let rec alpha_rt excluded rt = let new_rt = match rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ -> rt | GLambda(loc,Anonymous,k,t,b) -> let new_id = Namegen.next_ident_away (Id.of_string "_x") excluded in let new_excluded = new_id :: excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in GLambda(loc,Name new_id,k,new_t,new_b) | GProd(loc,Anonymous,k,t,b) -> let new_t = alpha_rt excluded t in let new_b = alpha_rt excluded b in GProd(loc,Anonymous,k,new_t,new_b) | GLetIn(loc,Anonymous,t,b) -> let new_t = alpha_rt excluded t in let new_b = alpha_rt excluded b in GLetIn(loc,Anonymous,new_t,new_b) | GLambda(loc,Name id,k,t,b) -> let new_id = Namegen.next_ident_away id excluded in let t,b = if Id.equal new_id id then t,b else let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) in let new_excluded = new_id::excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in GLambda(loc,Name new_id,k,new_t,new_b) | GProd(loc,Name id,k,t,b) -> let new_id = Namegen.next_ident_away id excluded in let new_excluded = new_id::excluded in let t,b = if Id.equal new_id id then t,b else let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in GProd(loc,Name new_id,k,new_t,new_b) | GLetIn(loc,Name id,t,b) -> let new_id = Namegen.next_ident_away id excluded in let t,b = if Id.equal new_id id then t,b else let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) in let new_excluded = new_id::excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in GLetIn(loc,Name new_id,new_t,new_b) | GLetTuple(loc,nal,(na,rto),t,b) -> let rev_new_nal,new_excluded,mapping = List.fold_left (fun (nal,excluded,mapping) na -> match na with | Anonymous -> (na::nal,excluded,mapping) | Name id -> let new_id = Namegen.next_ident_away id excluded in if Id.equal new_id id then na::nal,id::excluded,mapping else (Name new_id)::nal,id::excluded,(Id.Map.add id new_id mapping) ) ([],excluded,Id.Map.empty) nal in let new_nal = List.rev rev_new_nal in let new_rto,new_t,new_b = if Id.Map.is_empty mapping then rto,t,b else let replace = change_vars mapping in (Option.map replace rto, t,replace b) in let new_t = alpha_rt new_excluded new_t in let new_b = alpha_rt new_excluded new_b in let new_rto = Option.map (alpha_rt new_excluded) new_rto in GLetTuple(loc,new_nal,(na,new_rto),new_t,new_b) | GCases(loc,sty,infos,el,brl) -> let new_el = List.map (function (rt,i) -> alpha_rt excluded rt, i) el in GCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) | GIf(loc,b,(na,e_o),lhs,rhs) -> GIf(loc,alpha_rt excluded b, (na,Option.map (alpha_rt excluded) e_o), alpha_rt excluded lhs, alpha_rt excluded rhs ) | GRec _ -> error "Not handled GRec" | GSort _ -> rt | GHole _ -> rt | GCast (loc,b,c) -> GCast(loc,alpha_rt excluded b, Miscops.map_cast_type (alpha_rt excluded) c) | GApp(loc,f,args) -> GApp(loc, alpha_rt excluded f, List.map (alpha_rt excluded) args ) in new_rt and alpha_br excluded (loc,ids,patl,res) = let new_patl,new_excluded,mapping = alpha_patl excluded patl in let new_ids = List.fold_right raw_get_pattern_id new_patl [] in let new_excluded = new_ids@excluded in let renamed_res = change_vars mapping res in let new_res = alpha_rt new_excluded renamed_res in (loc,new_ids,new_patl,new_res) (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) let is_free_in id = let rec is_free_in = function | GRef _ -> false | GVar(_,id') -> Id.compare id' id == 0 | GEvar _ -> false | GPatVar _ -> false | GApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl) | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) | GLetIn(_,n,t,b) -> let check_in_b = match n with | Name id' -> not (Id.equal id' id) | _ -> true in is_free_in t || (check_in_b && is_free_in b) | GCases(_,_,_,el,brl) -> (List.exists (fun (e,_) -> is_free_in e) el) || List.exists is_free_in_br brl | GLetTuple(_,nal,_,b,t) -> let check_in_nal = not (List.exists (function Name id' -> Id.equal id' id | _ -> false) nal) in is_free_in t || (check_in_nal && is_free_in b) | GIf(_,cond,_,br1,br2) -> is_free_in cond || is_free_in br1 || is_free_in br2 | GRec _ -> raise (UserError("",str "Not handled GRec")) | GSort _ -> false | GHole _ -> false | GCast (_,b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t | GCast (_,b,CastCoerce) -> is_free_in b and is_free_in_br (_,ids,_,rt) = (not (Id.List.mem id ids)) && is_free_in rt in is_free_in let rec pattern_to_term = function | PatVar(loc,Anonymous) -> assert false | PatVar(loc,Name id) -> mkGVar id | PatCstr(loc,constr,patternl,_) -> let cst_narg = Inductiveops.constructor_nallargs_env (Global.env ()) constr in let implicit_args = Array.to_list (Array.init (cst_narg - List.length patternl) (fun _ -> mkGHole ()) ) in let patl_as_term = List.map pattern_to_term patternl in mkGApp(mkGRef(Globnames.ConstructRef constr), implicit_args@patl_as_term ) let replace_var_by_term x_id term = let rec replace_var_by_pattern rt = match rt with | GRef _ -> rt | GVar(_,id) when Id.compare id x_id == 0 -> term | GVar _ -> rt | GEvar _ -> rt | GPatVar _ -> rt | GApp(loc,rt',rtl) -> GApp(loc, replace_var_by_pattern rt', List.map replace_var_by_pattern rtl ) | GLambda(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt | GLambda(loc,name,k,t,b) -> GLambda(loc, name, k, replace_var_by_pattern t, replace_var_by_pattern b ) | GProd(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt | GProd(loc,name,k,t,b) -> GProd(loc, name, k, replace_var_by_pattern t, replace_var_by_pattern b ) | GLetIn(_,Name id,_,_) when Id.compare id x_id == 0 -> rt | GLetIn(loc,name,def,b) -> GLetIn(loc, name, replace_var_by_pattern def, replace_var_by_pattern b ) | GLetTuple(_,nal,_,_,_) when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal -> rt | GLetTuple(loc,nal,(na,rto),def,b) -> GLetTuple(loc, nal, (na,Option.map replace_var_by_pattern rto), replace_var_by_pattern def, replace_var_by_pattern b ) | GCases(loc,sty,infos,el,brl) -> GCases(loc,sty, infos, List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, List.map replace_var_by_pattern_br brl ) | GIf(loc,b,(na,e_option),lhs,rhs) -> GIf(loc, replace_var_by_pattern b, (na,Option.map replace_var_by_pattern e_option), replace_var_by_pattern lhs, replace_var_by_pattern rhs ) | GRec _ -> raise (UserError("",str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,c) -> GCast(loc,replace_var_by_pattern b, Miscops.map_cast_type replace_var_by_pattern c) and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = if List.exists (fun id -> Id.compare id x_id == 0) idl then br else (loc,idl,patl,replace_var_by_pattern res) in replace_var_by_pattern (* checking unifiability of patterns *) exception NotUnifiable let rec are_unifiable_aux = function | [] -> () | eq::eqs -> match eq with | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else let eqs' = try (List.combine cpl1 cpl2) @ eqs with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux") in are_unifiable_aux eqs' let are_unifiable pat1 pat2 = try are_unifiable_aux [pat1,pat2]; true with NotUnifiable -> false let rec eq_cases_pattern_aux = function | [] -> () | eq::eqs -> match eq with | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else let eqs' = try (List.combine cpl1 cpl2) @ eqs with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux") in eq_cases_pattern_aux eqs' | _ -> raise NotUnifiable let eq_cases_pattern pat1 pat2 = try eq_cases_pattern_aux [pat1,pat2]; true with NotUnifiable -> false let ids_of_pat = let rec ids_of_pat ids = function | PatVar(_,Anonymous) -> ids | PatVar(_,Name id) -> Id.Set.add id ids | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl in ids_of_pat Id.Set.empty let id_of_name = function | Names.Anonymous -> Id.of_string "x" | Names.Name x -> x (* TODO: finish Rec caes *) let ids_of_glob_constr c = let rec ids_of_glob_constr acc c = let idof = id_of_name in match c with | GVar (_,id) -> id::acc | GApp (loc,g,args) -> ids_of_glob_constr [] g @ List.flatten (List.map (ids_of_glob_constr []) args) @ acc | GLambda (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc | GProd (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc | GLetIn (loc,na,b,c) -> idof na :: ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc | GCast (loc,c,(CastConv t|CastVM t|CastNative t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc | GCast (loc,c,CastCoerce) -> ids_of_glob_constr [] c @ acc | GIf (loc,c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc | GLetTuple (_,nal,(na,po),b,c) -> List.map idof nal @ ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc | GCases (loc,sty,rtntypopt,tml,brchl) -> List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_glob_constr [] c) brchl) | GRec _ -> failwith "Fix inside a constructor branch" | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> [] in (* build the set *) List.fold_left (fun acc x -> Id.Set.add x acc) Id.Set.empty (ids_of_glob_constr [] c) let zeta_normalize = let rec zeta_normalize_term rt = match rt with | GRef _ -> rt | GVar _ -> rt | GEvar _ -> rt | GPatVar _ -> rt | GApp(loc,rt',rtl) -> GApp(loc, zeta_normalize_term rt', List.map zeta_normalize_term rtl ) | GLambda(loc,name,k,t,b) -> GLambda(loc, name, k, zeta_normalize_term t, zeta_normalize_term b ) | GProd(loc,name,k,t,b) -> GProd(loc, name, k, zeta_normalize_term t, zeta_normalize_term b ) | GLetIn(_,Name id,def,b) -> zeta_normalize_term (replace_var_by_term id def b) | GLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b | GLetTuple(loc,nal,(na,rto),def,b) -> GLetTuple(loc, nal, (na,Option.map zeta_normalize_term rto), zeta_normalize_term def, zeta_normalize_term b ) | GCases(loc,sty,infos,el,brl) -> GCases(loc,sty, infos, List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, List.map zeta_normalize_br brl ) | GIf(loc,b,(na,e_option),lhs,rhs) -> GIf(loc, zeta_normalize_term b, (na,Option.map zeta_normalize_term e_option), zeta_normalize_term lhs, zeta_normalize_term rhs ) | GRec _ -> raise (UserError("",str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,c) -> GCast(loc,zeta_normalize_term b, Miscops.map_cast_type zeta_normalize_term c) and zeta_normalize_br (loc,idl,patl,res) = (loc,idl,patl,zeta_normalize_term res) in zeta_normalize_term let expand_as = let rec add_as map pat = match pat with | PatVar _ -> map | PatCstr(_,_,patl,Name id) -> Id.Map.add id (pattern_to_term pat) (List.fold_left add_as map patl) | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl in let rec expand_as map rt = match rt with | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> rt | GVar(_,id) -> begin try Id.Map.find id map with Not_found -> rt end | GApp(loc,f,args) -> GApp(loc,expand_as map f,List.map (expand_as map) args) | GLambda(loc,na,k,t,b) -> GLambda(loc,na,k,expand_as map t, expand_as map b) | GProd(loc,na,k,t,b) -> GProd(loc,na,k,expand_as map t, expand_as map b) | GLetIn(loc,na,v,b) -> GLetIn(loc,na, expand_as map v,expand_as map b) | GLetTuple(loc,nal,(na,po),v,b) -> GLetTuple(loc,nal,(na,Option.map (expand_as map) po), expand_as map v, expand_as map b) | GIf(loc,e,(na,po),br1,br2) -> GIf(loc,expand_as map e,(na,Option.map (expand_as map) po), expand_as map br1, expand_as map br2) | GRec _ -> error "Not handled GRec" | GCast(loc,b,c) -> GCast(loc,expand_as map b, Miscops.map_cast_type (expand_as map) c) | GCases(loc,sty,po,el,brl) -> GCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, List.map (expand_as_br map) brl) and expand_as_br map (loc,idl,cpl,rt) = (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) in expand_as Id.Map.empty coq-8.6/plugins/funind/functional_principles_types.ml0000644000175000017500000005617513022274260022611 0ustar mdenesmdenesopen Printer open CErrors open Util open Term open Vars open Namegen open Names open Pp open Entries open Tactics open Context.Rel.Declaration open Indfun_common open Functional_principles_proofs open Misctypes open Sigma.Notations exception Toberemoved_with_rel of int*constr exception Toberemoved let observe s = if do_observe () then Feedback.msg_debug s (* Transform an inductive induction principle into a functional one *) let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let princ_type_info = compute_elim_sig princ_type in let env = Global.env () in let env_with_params = Environ.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in let rec change_predicates_names (avoid:Id.t list) (predicates:Context.Rel.t) : Context.Rel.t = match predicates with | [] -> [] | decl :: predicates -> (match Context.Rel.Declaration.get_name decl with | Name x -> let id = Namegen.next_ident_away x avoid in Hashtbl.add tbl id x; set_name (Name id) decl :: change_predicates_names (id::avoid) predicates | Anonymous -> anomaly (Pp.str "Anonymous property binder ")) in let avoid = (Termops.ids_of_context env_with_params ) in let princ_type_info = { princ_type_info with predicates = change_predicates_names avoid princ_type_info.predicates } in (* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) let change_predicate_sort i decl = let new_sort = sorts.(i) in let args,_ = decompose_prod (get_type decl) in let real_args = if princ_type_info.indarg_in_concl then List.tl args else args in Context.Named.Declaration.LocalAssum (Nameops.out_name (Context.Rel.Declaration.get_name decl), compose_prod real_args (mkSort new_sort)) in let new_predicates = List.map_i change_predicate_sort 0 princ_type_info.predicates in let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in let rel_as_kn = fst (match princ_type_info.indref with | Some (Globnames.IndRef ind) -> ind | _ -> error "Not a valid predicate" ) in let ptes_vars = List.map Context.Named.Declaration.get_id new_predicates in let is_pte = let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in fun t -> match kind_of_term t with | Var id -> Id.Set.mem id set | _ -> false in let pre_princ = it_mkProd_or_LetIn (it_mkProd_or_LetIn (Option.fold_right mkProd_or_LetIn princ_type_info.indarg princ_type_info.concl ) princ_type_info.args ) princ_type_info.branches in let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match kind_of_term c with | Ind((u,_),_) -> MutInd.equal u rel_as_kn | Construct(((u,_),_),_) -> MutInd.equal u rel_as_kn | _ -> false in let get_fun_num c = match kind_of_term c with | Ind((_,num),_) -> num | Construct(((_,num),_),_) -> num | _ -> assert false in let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = let res = mkApp(rel_to_fun.(i), Array.map Termops.pop (array_get_start args)) in observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); res in let rec compute_new_princ_type remove env pre_princ : types*(constr list) = let (new_princ_type,_) as res = match kind_of_term pre_princ with | Rel n -> begin try match Environ.lookup_rel n env with | LocalAssum (_,t) | LocalDef (_,_,t) when is_dom t -> raise Toberemoved | _ -> pre_princ,[] with Not_found -> assert false end | Prod(x,t,b) -> compute_new_princ_type_for_binder remove mkProd env x t b | Lambda(x,t,b) -> compute_new_princ_type_for_binder remove mkLambda env x t b | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved | App(f,args) when is_dom f -> let var_to_be_removed = destRel (Array.last args) in let num = get_fun_num f in raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) | App(f,args) -> let args = if is_pte f && remove then array_get_start args else args in let new_args,binders_to_remove = Array.fold_right (compute_new_princ_type_with_acc remove env) args ([],[]) in let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in applist(new_f, new_args), list_union_eq eq_constr binders_to_remove_from_f binders_to_remove | LetIn(x,v,t,b) -> compute_new_princ_type_for_letin remove env x v t b | _ -> pre_princ,[] in (* let _ = match kind_of_term pre_princ with *) (* | Prod _ -> *) (* observe(str "compute_new_princ_type for "++ *) (* pr_lconstr_env env pre_princ ++ *) (* str" is "++ *) (* pr_lconstr_env env new_princ_type ++ fnl ()) *) (* | _ -> () in *) res and compute_new_princ_type_for_binder remove bind_fun env x t b = begin try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in let new_x : Name.t = get_name (Termops.ids_of_context env) x in let new_env = Environ.push_rel (LocalAssum (x,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b then (Termops.pop new_b), filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b else ( bind_fun(new_x,new_t,new_b), list_union_eq eq_constr binders_to_remove_from_t (List.map Termops.pop binders_to_remove_from_b) ) with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in new_b, List.map Termops.pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b) end and compute_new_princ_type_for_letin remove env x v t b = begin try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in let new_x : Name.t = get_name (Termops.ids_of_context env) x in let new_env = Environ.push_rel (LocalDef (x,v,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b then (Termops.pop new_b),filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b else ( mkLetIn(new_x,new_v,new_t,new_b), list_union_eq eq_constr (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v) (List.map Termops.pop binders_to_remove_from_b) ) with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in new_b, List.map Termops.pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b) end and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = let new_e,to_remove_from_e = compute_new_princ_type remove env e in new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc in (* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) let pre_res,_ = compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ in let pre_res = replace_vars (List.map_i (fun i id -> (id, mkRel i)) 1 ptes_vars) (lift (List.length ptes_vars) pre_res) in it_mkProd_or_LetIn (it_mkProd_or_LetIn pre_res (List.map (function Context.Named.Declaration.LocalAssum (id,b) -> LocalAssum (Name (Hashtbl.find tbl id), b) | Context.Named.Declaration.LocalDef (id,t,b) -> LocalDef (Name (Hashtbl.find tbl id), t, b)) new_predicates) ) princ_type_info.params let change_property_sort evd toSort princ princName = let open Context.Rel.Declaration in let princ_info = compute_elim_sig princ in let change_sort_in_predicate decl = LocalAssum (get_name decl, let args,ty = decompose_prod (get_type decl) in let s = destSort ty in Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); compose_prod args (mkSort toSort) ) in let evd,princName_as_constr = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in let init = let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in mkApp(princName_as_constr, Array.init nargs (fun i -> mkRel (nargs - i ))) in evd, it_mkLambda_or_LetIn (it_mkLambda_or_LetIn init (List.map change_sort_in_predicate princ_info.predicates) ) princ_info.params let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) let mutr_nparams = (compute_elim_sig old_princ_type).nparams in (* let time1 = System.get_time () in *) let new_principle_type = compute_new_princ_type_from_rel (Array.map mkConstU funs) sorts old_princ_type in (* let time2 = System.get_time () in *) (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) let new_princ_name = next_ident_away_in_goal (Id.of_string "___________princ_________") [] in let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd new_principle_type in let hook = Lemmas.mk_hook (hook new_principle_type) in begin Lemmas.start_proof new_princ_name (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) !evd new_principle_type hook ; (* let _tim1 = System.get_time () in *) ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map mkConstU funs) mutr_nparams))); (* let _tim2 = System.get_time () in *) (* begin *) (* let dur1 = System.time_difference tim1 tim2 in *) (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) (* end; *) get_proof_clean true, CEphemeron.create hook end let generate_functional_principle (evd: Evd.evar_map ref) interactive_proof old_princ_type sorts new_princ_name funs i proof_tac = try let f = funs.(i) in let env = Global.env () in let type_sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd InType in let new_sorts = match sorts with | None -> Array.make (Array.length funs) (type_sort) | Some a -> a in let base_new_princ_name,new_princ_name = match new_princ_name with | Some (id) -> id,id | None -> let id_of_f = Label.to_id (con_label (fst f)) in id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort) in let names = ref [new_princ_name] in let hook = fun new_principle_type _ _ -> if Option.is_empty sorts then (* let id_of_f = Label.to_id (con_label f) in *) let register_with_sort fam_sort = let evd' = Evd.from_env (Global.env ()) in let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in let evd',value = change_property_sort evd' s new_principle_type new_princ_name in let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' value) in (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs:(snd (Evd.universe_context evd')) value in ignore( Declare.declare_constant name (DefinitionEntry ce, Decl_kinds.IsDefinition (Decl_kinds.Scheme)) ); Declare.definition_message name; names := name :: !names in register_with_sort InProp; register_with_sort InSet in let ((id,(entry,g_kind)),hook) = build_functional_principle evd interactive_proof old_princ_type new_sorts funs i proof_tac hook in (* Pr 1278 : Don't forget to close the goal if an error is raised !!!! *) save false new_princ_name entry g_kind hook with e when CErrors.noncritical e -> begin begin try let id = Pfedit.get_current_proof_name () in let s = Id.to_string id in let n = String.length "___________princ_________" in if String.length s >= n then if String.equal (String.sub s 0 n) "___________princ_________" then Pfedit.delete_current_proof () else () else () with e when CErrors.noncritical e -> () end; raise (Defining_principle e) end (* defined () *) exception Not_Rec let get_funs_constant mp dp = let get_funs_constant const e : (Names.constant*int) array = match kind_of_term ((strip_lam e)) with | Fix((_,(na,_,_))) -> Array.mapi (fun i na -> match na with | Name id -> let const = make_con mp dp (Label.of_id id) in const,i | Anonymous -> anomaly (Pp.str "Anonymous fix") ) na | _ -> [|const,0|] in function const -> let find_constant_body const = match Global.body_of_constant const with | Some body -> let body = Tacred.cbv_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) (Evd.from_env (Global.env ())) body in body | None -> error ( "Cannot define a principle over an axiom ") in let f = find_constant_body const in let l_const = get_funs_constant const f in (* We need to check that all the functions found are in the same block to prevent Reset stange thing *) let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in (* all the paremeter must be equal*) let _check_params = let first_params = List.hd l_params in List.iter (fun params -> if not (List.equal (fun (n1, c1) (n2, c2) -> Name.equal n1 n2 && eq_constr c1 c2) first_params params) then error "Not a mutal recursive block" ) l_params in (* The bodies has to be very similar *) let _check_bodies = try let extract_info is_first body = match kind_of_term body with | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) | _ -> if is_first && Int.equal (List.length l_bodies) 1 then raise Not_Rec else error "Not a mutal recursive block" in let first_infos = extract_info true (List.hd l_bodies) in let check body = (* Hope this is correct *) let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = Array.equal Int.equal ia1 ia2 && Array.equal Name.equal na1 na2 && Array.equal eq_constr ta1 ta2 && Array.equal eq_constr ca1 ca2 in if not (eq_infos first_infos (extract_info false body)) then error "Not a mutal recursive block" in List.iter check l_bodies with Not_Rec -> () in l_const exception No_graph_found exception Found_type of int let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_constants definition_entry list = let env = Global.env () in let funs = List.map fst fas in let first_fun = List.hd funs in let funs_mp,funs_dp,_ = KerName.repr (Constant.canonical (fst first_fun)) in let first_fun_kn = try fst (find_Function_infos (fst first_fun)).graph_ind with Not_found -> raise No_graph_found in let this_block_funs_indexes = get_funs_constant funs_mp funs_dp (fst first_fun) in let this_block_funs = Array.map (fun (c,_) -> (c,snd first_fun)) this_block_funs_indexes in let prop_sort = InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.map (function cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) funs in let ind_list = List.map (fun (idx) -> let ind = first_fun_kn,idx in (ind,snd first_fun),true,prop_sort ) funs_indexes in let sigma, schemes = Indrec.build_mutual_induction_scheme env !evd ind_list in let _ = evd := sigma in let l_schemes = List.map (Typing.unsafe_type_of env sigma) schemes in let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd (Pretyping.interp_elimination_sort x) ) fas in (* We create the first priciple by tactic *) let first_type,other_princ_types = match l_schemes with s::l_schemes -> s,l_schemes | _ -> anomaly (Pp.str "") in let ((_,(const,_)),_) = try build_functional_principle evd false first_type (Array.of_list sorts) this_block_funs 0 (prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) (fun _ _ _ -> ()) with e when CErrors.noncritical e -> begin begin try let id = Pfedit.get_current_proof_name () in let s = Id.to_string id in let n = String.length "___________princ_________" in if String.length s >= n then if String.equal (String.sub s 0 n) "___________princ_________" then Pfedit.delete_current_proof () else () else () with e when CErrors.noncritical e -> () end; raise (Defining_principle e) end in incr i; let opacity = let finfos = find_Function_infos (fst first_fun) in try let equation = Option.get finfos.equation_lemma in Declareops.is_opaque (Global.lookup_constant equation) with Option.IsNone -> (* non recursive definition *) false in let const = {const with const_entry_opaque = opacity } in (* The others are just deduced *) if List.is_empty other_princ_types then [const] else let other_fun_princ_types = let funs = Array.map mkConstU this_block_funs in let sorts = Array.of_list sorts in List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types in let first_princ_body,first_princ_type = const.const_entry_body, const.const_entry_type in let ctxt,fix = decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) let (idxs,_),(_,ta,_ as decl) = destFix fix in let other_result = List.map (* we can now compute the other principles *) (fun scheme_type -> incr i; observe (Printer.pr_lconstr scheme_type); let type_concl = (strip_prod_assum scheme_type) in let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in let f = fst (decompose_app applied_f) in try (* we search the number of the function in the fix block (name of the function) *) Array.iteri (fun j t -> let t = (strip_prod_assum t) in let applied_g = List.hd (List.rev (snd (decompose_app t))) in let g = fst (decompose_app applied_g) in if eq_constr f g then raise (Found_type j); observe (Printer.pr_lconstr f ++ str " <> " ++ Printer.pr_lconstr g) ) ta; (* If we reach this point, the two principle are not mutually recursive We fall back to the previous method *) let ((_,(const,_)),_) = build_functional_principle evd false (List.nth other_princ_types (!i - 1)) (Array.of_list sorts) this_block_funs !i (prove_princ_for_struct evd false !i (Array.of_list (List.map fst funs))) (fun _ _ _ -> ()) in const with Found_type i -> let princ_body = Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt in {const with const_entry_body = (Future.from_val (Safe_typing.mk_pure_proof princ_body)); const_entry_type = Some scheme_type } ) other_fun_princ_types in const::other_result let build_scheme fas = let evd = (ref (Evd.from_env (Global.env ()))) in let pconstants = (List.map (fun (_,f,sort) -> let f_as_constant = try Smartlocate.global_with_alias f with Not_found -> errorlabstrm "FunInd.build_scheme" (str "Cannot find " ++ Libnames.pr_reference f) in let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in let _ = evd := evd' in let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd f in (destConst f,sort) ) fas ) in let bodies_types = make_scheme evd pconstants in List.iter2 (fun (princ_id,_,_) def_entry -> ignore (Declare.declare_constant princ_id (DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); Declare.definition_message princ_id ) fas bodies_types let build_case_scheme fa = let env = Global.env () and sigma = (Evd.from_env (Global.env ())) in (* let id_to_constr id = *) (* Constrintern.global_reference id *) (* in *) let funs = let (_,f,_) = fa in try fst (Universes.unsafe_constr_of_global (Smartlocate.global_with_alias f)) with Not_found -> errorlabstrm "FunInd.build_case_scheme" (str "Cannot find " ++ Libnames.pr_reference f) in let first_fun,u = destConst funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in let prop_sort = InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.assoc_f Constant.equal (fst (destConst funs)) this_block_funs_indexes in let (ind, sf) = let ind = first_fun_kn,funs_indexes in (ind,Univ.Instance.empty)(*FIXME*),prop_sort in let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (scheme, sigma, _) = Indrec.build_case_analysis_scheme_default env sigma ind sf in let sigma = Sigma.to_evar_map sigma in let scheme_type = (Typing.unsafe_type_of env sigma ) scheme in let sorts = (fun (_,_,x) -> Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) ) fa in let princ_name = (fun (x,_,_) -> x) fa in let _ = (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs ); *) generate_functional_principle (ref (Evd.from_env (Global.env ()))) false scheme_type (Some ([|sorts|])) (Some princ_name) this_block_funs 0 (prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|fst (destConst funs)|]) in () coq-8.6/plugins/funind/functional_principles_proofs.mli0000644000175000017500000000115613022274260023113 0ustar mdenesmdenesopen Names open Term val prove_princ_for_struct : Evd.evar_map ref -> bool -> int -> constant array -> constr array -> int -> Tacmach.tactic val prove_principle_for_gen : constant*constant*constant -> (* name of the function, the functional and the fixpoint equation *) constr option ref -> (* a pointer to the obligation proofs lemma *) bool -> (* is that function uses measure *) int -> (* the number of recursive argument *) types -> (* the type of the recursive argument *) constr -> (* the wf relation used to prove the function *) Tacmach.tactic (* val is_pte : rel_declaration -> bool *) coq-8.6/plugins/funind/recdef.ml0000644000175000017500000015016413022274260016214 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (try (match constant_opt_value_in (Global.env ()) sp with | Some c -> c | _ -> raise Not_found) with Not_found -> anomaly (str "Cannot find definition of constant " ++ (Id.print (Label.to_id (con_label (fst sp))))) ) |_ -> assert false let type_of_const t = match (kind_of_term t) with Const sp -> Typeops.type_of_constant (Global.env()) sp |_ -> assert false let constr_of_global x = fst (Universes.unsafe_constr_of_global x) let constant sl s = constr_of_global (find_reference sl s) let const_of_ref = function ConstRef kn -> kn | _ -> anomaly (Pp.str "ConstRef expected") let nf_zeta env = Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) env Evd.empty let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) let clos_norm_flags flgs env sigma t = CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty (* Generic values *) let pf_get_new_ids idl g = let ids = pf_ids_of_hyps g in List.fold_right (fun id acc -> next_global_ident_away id (acc@ids)::acc) idl [] let compute_renamed_type gls c = rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) [] (pf_unsafe_type_of gls c) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" let ano_id = Id.of_string "anonymous" let x_id = Id.of_string "x" let k_id = Id.of_string "k" let v_id = Id.of_string "v" let def_id = Id.of_string "def" let p_id = Id.of_string "p" let rec_res_id = Id.of_string "rec_res";; let lt = function () -> (coq_init_constant "lt") let le = function () -> (coq_init_constant "le") let ex = function () -> (coq_init_constant "ex") let nat = function () -> (coq_init_constant "nat") let iter_ref () = try find_reference ["Recdef"] "iter" with Not_found -> error "module Recdef not loaded" let iter = function () -> (constr_of_global (delayed_force iter_ref)) let eq = function () -> (coq_init_constant "eq") let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") let le_lt_n_Sm = function () -> (coq_constant arith_Lt "le_lt_n_Sm") let le_trans = function () -> (coq_constant arith_Nat "le_trans") let le_lt_trans = function () -> (coq_constant arith_Nat "le_lt_trans") let lt_S_n = function () -> (coq_constant arith_Lt "lt_S_n") let le_n = function () -> (coq_init_constant "le_n") let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig") let coq_O = function () -> (coq_init_constant "O") let coq_S = function () -> (coq_init_constant "S") let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r") let max_ref = function () -> (find_reference ["Recdef"] "max") let max_constr = function () -> (constr_of_global (delayed_force max_ref)) let coq_conj = function () -> find_reference Coqlib.logic_module_name "conj" let f_S t = mkApp(delayed_force coq_S, [|t|]);; let rec n_x_id ids n = if Int.equal n 0 then [] else let x = next_ident_away_in_goal x_id ids in x::n_x_id (x::ids) (n-1);; let simpl_iter clause = reduce (Lazy {rBeta=true;rMatch=true;rFix=true;rCofix=true;rZeta=true;rDelta=false; rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) clause (* Others ugly things ... *) let (value_f:constr list -> global_reference -> constr) = fun al fterm -> let d0 = Loc.ghost in let rev_x_id_l = ( List.fold_left (fun x_id_l _ -> let x_id = next_ident_away_in_goal x_id x_id_l in x_id::x_id_l ) [] al ) in let context = List.map (fun (x, c) -> LocalAssum (Name x, c)) (List.combine rev_x_id_l (List.rev al)) in let env = Environ.push_rel_context context (Global.env ()) in let glob_body = GCases (d0,RegularStyle,None, [GApp(d0, GRef(d0,fterm,None), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l), (Anonymous,None)], [d0, [v_id], [PatCstr(d0,(destIndRef (delayed_force coq_sig_ref),1), [PatVar(d0, Name v_id); PatVar(d0, Anonymous)], Anonymous)], GVar(d0,v_id)]) in let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in it_mkLambda_or_LetIn body context let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> global_reference) = fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref);; (* Debugging mechanism *) let debug_queue = Stack.create () let print_debug_queue b e = if not (Stack.is_empty debug_queue) then begin let lmsg,goal = Stack.pop debug_queue in if b then Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) else begin Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)); end; (* print_debug_queue false e; *) end let observe strm = if do_observe () then Feedback.msg_debug strm else () let do_observe_tac s tac g = let goal = Printer.pr_goal g in let lmsg = (str "recdef : ") ++ s in observe (s++fnl()); Stack.push (lmsg,goal) debug_queue; try let v = tac g in ignore(Stack.pop debug_queue); v with reraise -> let reraise = CErrors.push reraise in if not (Stack.is_empty debug_queue) then print_debug_queue true (fst (ExplainErr.process_vernac_interp_error reraise)); iraise reraise let observe_tac s tac g = if do_observe () then do_observe_tac s tac g else tac g let observe_tclTHENLIST s tacl = if do_observe () then let rec aux n = function | [] -> tclIDTAC | [tac] -> observe_tac (s ++ spc () ++ int n) tac | tac::tacl -> observe_tac (s ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) in aux 0 tacl else tclTHENLIST tacl (* Conclusion tactics *) (* The boolean value is_mes expresses that the termination is expressed using a measure function instead of a well-founded relation. *) let tclUSER tac is_mes l g = let clear_tac = match l with | None -> tclIDTAC | Some l -> tclMAP (fun id -> tclTRY (Proofview.V82.of_tactic (clear [id]))) (List.rev l) in observe_tclTHENLIST (str "tclUSER1") [ clear_tac; if is_mes then observe_tclTHENLIST (str "tclUSER2") [ Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force Indfun_common.ltof_ref))]); tac ] else tac ] g let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = if is_mes then tclCOMPLETE (fun gl -> Proofview.V82.of_tactic (Simple.apply (delayed_force well_founded_ltof)) gl) else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) (tclUSER concl_tac is_mes names_to_suppress) (* Traveling term. Both definitions of [f_terminate] and [f_equation] use the same generic traveling mechanism. *) (* [check_not_nested forbidden e] checks that [e] does not contains any variable of [forbidden] *) let check_not_nested forbidden e = let rec check_not_nested e = match kind_of_term e with | Rel _ -> () | Var x -> if Id.List.mem x forbidden then errorlabstrm "Recdef.check_not_nested" (str "check_not_nested: failure " ++ pr_id x) | Meta _ | Evar _ | Sort _ -> () | Cast(e,_,t) -> check_not_nested e;check_not_nested t | Prod(_,t,b) -> check_not_nested t;check_not_nested b | Lambda(_,t,b) -> check_not_nested t;check_not_nested b | LetIn(_,v,t,b) -> check_not_nested t;check_not_nested b;check_not_nested v | App(f,l) -> check_not_nested f;Array.iter check_not_nested l | Proj (p,c) -> check_not_nested c | Const _ -> () | Ind _ -> () | Construct _ -> () | Case(_,t,e,a) -> check_not_nested t;check_not_nested e;Array.iter check_not_nested a | Fix _ -> error "check_not_nested : Fix" | CoFix _ -> error "check_not_nested : Fix" in try check_not_nested e with UserError(_,p) -> errorlabstrm "_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) type 'a infos = { nb_arg : int; (* function number of arguments *) concl_tac : tactic; (* final tactic to finish proofs *) rec_arg_id : Id.t; (*name of the declared recursive argument *) is_mes : bool; (* type of recursion *) ih : Id.t; (* induction hypothesis name *) f_id : Id.t; (* function name *) f_constr : constr; (* function term *) f_terminate : constr; (* termination proof term *) func : global_reference; (* functional reference *) info : 'a; is_main_branch : bool; (* on the main branch or on a matched expression *) is_final : bool; (* final first order term or not *) values_and_bounds : (Id.t*Id.t) list; eqs : Id.t list; forbidden_ids : Id.t list; acc_inv : constr lazy_t; acc_id : Id.t; args_assoc : ((constr list)*constr) list; } type ('a,'b) journey_info_tac = 'a -> (* the arguments of the constructor *) 'b infos -> (* infos of the caller *) ('b infos -> tactic) -> (* the continuation tactic of the caller *) 'b infos -> (* argument of the tactic *) tactic (* journey_info : specifies the actions to do on the different term constructors during the traveling of the term *) type journey_info = { letiN : ((Name.t*constr*types*constr),constr) journey_info_tac; lambdA : ((Name.t*types*constr),constr) journey_info_tac; casE : ((constr infos -> tactic) -> constr infos -> tactic) -> ((case_info * constr * constr * constr array),constr) journey_info_tac; otherS : (unit,constr) journey_info_tac; apP : (constr*(constr list),constr) journey_info_tac; app_reC : (constr*(constr list),constr) journey_info_tac; message : string } let rec add_vars forbidden e = match kind_of_term e with | Var x -> x::forbidden | _ -> fold_constr add_vars forbidden e let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = fun g -> let rev_context,b = decompose_lam_n nb_lam e in let ids = List.fold_left (fun acc (na,_) -> let pre_id = match na with | Name x -> x | Anonymous -> ano_id in pre_id::acc ) [] rev_context in let rev_ids = pf_get_new_ids (List.rev ids) g in let new_b = substl (List.map mkVar rev_ids) b in observe_tclTHENLIST (str "treat_case1") [ h_intros (List.rev rev_ids); Proofview.V82.of_tactic (intro_using teq_id); onLastHypId (fun heq -> observe_tclTHENLIST (str "treat_case2")[ Proofview.V82.of_tactic (clear to_intros); h_intros to_intros; (fun g' -> let ty_teq = pf_unsafe_type_of g' (mkVar heq) in let teq_lhs,teq_rhs = let _,args = try destApp ty_teq with DestKO -> assert false in args.(1),args.(2) in let new_b' = Termops.replace_term teq_lhs teq_rhs new_b in let new_infos = { infos with info = new_b'; eqs = heq::infos.eqs; forbidden_ids = if forbid_new_ids then add_vars infos.forbidden_ids new_b' else infos.forbidden_ids } in finalize_tac new_infos g' ) ] ) ] g let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = match kind_of_term expr_info.info with | CoFix _ | Fix _ -> error "Function cannot treat local fixpoint or cofixpoint" | Proj _ -> error "Function cannot treat projections" | LetIn(na,b,t,e) -> begin let new_continuation_tac = jinfo.letiN (na,b,t,e) expr_info continuation_tac in travel jinfo new_continuation_tac {expr_info with info = b; is_final=false} end | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !") | Prod _ -> begin try check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info with e when CErrors.noncritical e -> errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Lambda(n,t,b) -> begin try check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info with e when CErrors.noncritical e -> errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Case(ci,t,a,l) -> begin let continuation_tac_a = jinfo.casE (travel jinfo) (ci,t,a,l) expr_info continuation_tac in travel jinfo continuation_tac_a {expr_info with info = a; is_main_branch = false; is_final = false} end | App _ -> let f,args = decompose_app expr_info.info in if eq_constr f (expr_info.f_constr) then jinfo.app_reC (f,args) expr_info continuation_tac expr_info else begin match kind_of_term f with | App _ -> assert false (* f is coming from a decompose_app *) | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ | Var _ -> let new_infos = {expr_info with info=(f,args)} in let new_continuation_tac = jinfo.apP (f,args) expr_info continuation_tac in travel_args jinfo expr_info.is_main_branch new_continuation_tac new_infos | Case _ -> errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_lconstr expr_info.info) end | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in new_continuation_tac expr_info and travel_args jinfo is_final continuation_tac infos = let (f_args',args) = infos.info in match args with | [] -> continuation_tac {infos with info = f_args'; is_final = is_final} | arg::args' -> let new_continuation_tac new_infos = let new_arg = new_infos.info in travel_args jinfo is_final continuation_tac {new_infos with info = (mkApp(f_args',[|new_arg|]),args')} in travel jinfo new_continuation_tac {infos with info=arg;is_final=false} and travel jinfo continuation_tac expr_info = observe_tac (str jinfo.message ++ Printer.pr_lconstr expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) let rec prove_lt hyple g = begin try let (varx,varz) = match decompose_app (pf_concl g) with | _, x::z::_ when isVar x && isVar z -> x, z | _ -> assert false in let h = List.find (fun id -> match decompose_app (pf_unsafe_type_of g (mkVar id)) with | _, t::_ -> eq_constr t varx | _ -> false ) hyple in let y = List.hd (List.tl (snd (decompose_app (pf_unsafe_type_of g (mkVar h))))) in observe_tclTHENLIST (str "prove_lt1")[ Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); observe_tac (str "prove_lt") (prove_lt hyple) ] with Not_found -> ( ( observe_tclTHENLIST (str "prove_lt2")[ Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); (observe_tac (str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) ]) ) end g let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = match lbounds with | [] -> let ids = pf_ids_of_hyps g in let s_max = mkApp(delayed_force coq_S, [|bound|]) in let k = next_ident_away_in_goal k_id ids in let ids = k::ids in let h' = next_ident_away_in_goal (h'_id) ids in let ids = h'::ids in let def = next_ident_away_in_goal def_id ids in observe_tclTHENLIST (str "destruct_bounds_aux1")[ Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); Proofview.V82.of_tactic (intro_then (fun id -> Proofview.V82.tactic begin observe_tac (str "destruct_bounds_aux") (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) [ observe_tclTHENLIST (str "")[Proofview.V82.of_tactic (intro_using h_id); Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); Proofview.V82.of_tactic default_full_auto]; observe_tclTHENLIST (str "destruct_bounds_aux2")[ observe_tac (str "clearing k ") (Proofview.V82.of_tactic (clear [id])); h_intros [k;h';def]; observe_tac (str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); observe_tac (str "unfold functional") (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], evaluable_of_global_reference infos.func)])); ( observe_tclTHENLIST (str "test")[ list_rewrite true (List.fold_right (fun e acc -> (mkVar e,true)::acc) infos.eqs (List.map (fun e -> (e,true)) rechyps) ); (* list_rewrite true *) (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) (* ; *) (observe_tac (str "finishing") (tclORELSE (Proofview.V82.of_tactic intros_reflexivity) (observe_tac (str "calling prove_lt") (prove_lt hyple))))]) ] ] )end)) ] g | (_,v_bound)::l -> observe_tclTHENLIST (str "destruct_bounds_aux3")[ Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); Proofview.V82.of_tactic (clear [v_bound]); tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 (fun p_hyp -> (onNthHypId 2 (fun p -> observe_tclTHENLIST (str "destruct_bounds_aux4")[ Proofview.V82.of_tactic (simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); tclDO 3 (Proofview.V82.of_tactic intro); onNLastHypsId 3 (fun lids -> match lids with [hle2;hle1;pmax] -> destruct_bounds_aux infos ((mkVar pmax), hle1::hle2::hyple,(mkVar p_hyp)::rechyps) l | _ -> assert false) ; ] ) ) ) ] g let destruct_bounds infos = destruct_bounds_aux infos (delayed_force coq_O,[],[]) infos.values_and_bounds let terminate_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then observe_tclTHENLIST (str "terminate_app1")[ continuation_tac infos; observe_tac (str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); observe_tac (str "destruct_bounds (1)") (destruct_bounds infos) ] else continuation_tac infos let terminate_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then observe_tclTHENLIST (str "terminate_others")[ continuation_tac infos; observe_tac (str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); observe_tac (str "destruct_bounds") (destruct_bounds infos) ] else continuation_tac infos let terminate_letin (na,b,t,e) expr_info continuation_tac info = let new_e = subst1 info.info e in let new_forbidden = let forbid = try check_not_nested (expr_info.f_id::expr_info.forbidden_ids) b; true with e when CErrors.noncritical e -> false in if forbid then match na with | Anonymous -> info.forbidden_ids | Name id -> id::info.forbidden_ids else info.forbidden_ids in continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} let pf_type c tac gl = let evars, ty = Typing.type_of (pf_env gl) (project gl) c in tclTHEN (Refiner.tclEVARS evars) (tac ty) gl let pf_typel l tac = let rec aux tys l = match l with | [] -> tac (List.rev tys) | hd :: tl -> pf_type hd (fun ty -> aux (ty::tys) tl) in aux [] l (* This is like the previous one except that it also rewrite on all hypotheses except the ones given in the first argument. All the modified hypotheses are generalized in the process and should be introduced back later; the result is the pair of the tactic and the list of hypotheses that have been generalized and cleared. *) let mkDestructEq : Id.t list -> constr -> goal sigma -> tactic * Id.t list = fun not_on_hyp expr g -> let hyps = pf_hyps g in let to_revert = Util.List.map_filter (fun decl -> let open Context.Named.Declaration in let id = get_id decl in if Id.List.mem id not_on_hyp || not (Termops.occur_term expr (get_type decl)) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in let type_of_expr = pf_unsafe_type_of g expr in let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in pf_typel new_hyps (fun _ -> observe_tclTHENLIST (str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> let changefun patvars = { run = fun sigma -> let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in redfun.Reductionops.e_redfun (pf_env g2) sigma (pf_concl g2) } in Proofview.V82.of_tactic (change_in_concl None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let f_is_present = try check_not_nested (expr_info.f_id::expr_info.forbidden_ids) a; false with e when CErrors.noncritical e -> true in let a' = infos.info in let new_info = {infos with info = mkCase(ci,t,a',l); is_main_branch = expr_info.is_main_branch; is_final = expr_info.is_final} in let destruct_tac,rev_to_thin_intro = mkDestructEq [expr_info.rec_arg_id] a' g in let to_thin_intro = List.rev rev_to_thin_intro in observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_lconstr a') (try (tclTHENS destruct_tac (List.map_i (fun i e -> observe_tac (str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) )) with | UserError("Refiner.thensn_tac3",_) | UserError("Refiner.tclFAIL_s",_) -> (observe_tac (str "is computable " ++ Printer.pr_lconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) )) g let terminate_app_rec (f,args) expr_info continuation_tac _ = List.iter (check_not_nested (expr_info.f_id::expr_info.forbidden_ids)) args; begin try let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in observe_tclTHENLIST (str "terminate_app_rec")[ continuation_tac new_infos; if expr_info.is_final && expr_info.is_main_branch then observe_tclTHENLIST (str "terminate_app_rec1")[ observe_tac (str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); observe_tac (str "destruct_bounds (3)") (destruct_bounds new_infos) ] else tclIDTAC ] with Not_found -> observe_tac (str "terminate_app_rec not found") (tclTHENS (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) [ observe_tclTHENLIST (str "terminate_app_rec2")[ Proofview.V82.of_tactic (intro_using rec_res_id); Proofview.V82.of_tactic intro; onNthHypId 1 (fun v_bound -> (onNthHypId 2 (fun v -> let new_infos = { expr_info with info = (mkVar v); values_and_bounds = (v,v_bound)::expr_info.values_and_bounds; args_assoc=(args,mkVar v)::expr_info.args_assoc } in observe_tclTHENLIST (str "terminate_app_rec3")[ continuation_tac new_infos; if expr_info.is_final && expr_info.is_main_branch then observe_tclTHENLIST (str "terminate_app_rec4")[ observe_tac (str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); observe_tac (str "destruct_bounds (2)") (destruct_bounds new_infos) ] else tclIDTAC ] ) ) ) ]; observe_tac (str "proving decreasing") ( tclTHENS (* proof of args < formal args *) (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) [ observe_tac (str "assumption") (Proofview.V82.of_tactic assumption); observe_tclTHENLIST (str "terminate_app_rec5") [ tclTRY(list_rewrite true (List.map (fun e -> mkVar e,true) expr_info.eqs ) ); tclUSER expr_info.concl_tac true (Some ( expr_info.ih::expr_info.acc_id:: (fun (x,y) -> y) (List.split expr_info.values_and_bounds) ) ); ] ]) ]) end let terminate_info = { message = "prove_terminate with term "; letiN = terminate_letin; lambdA = (fun _ _ _ _ -> assert false); casE = terminate_case; otherS = terminate_others; apP = terminate_app; app_reC = terminate_app_rec; } let prove_terminate = travel terminate_info (* Equation proof *) let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = observe_tac (str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) let rec prove_le g = let x,z = let _,args = decompose_app (pf_concl g) in (List.hd args,List.hd (List.tl args)) in tclFIRST[ Proofview.V82.of_tactic assumption; Proofview.V82.of_tactic (apply (delayed_force le_n)); begin try let matching_fun = pf_is_matching g (Pattern.PApp(Pattern.PRef (reference_of_constr (le ())),[|Pattern.PVar (destVar x);Pattern.PMeta None|])) in let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) in let y = let _,args = decompose_app t in List.hd (List.tl args) in observe_tclTHENLIST (str "prove_le")[ Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); observe_tac (str "prove_le (rec)") (prove_le) ] with Not_found -> tclFAIL 0 (mt()) end; ] g let rec make_rewrite_list expr_info max = function | [] -> tclIDTAC | (_,p,hp)::l -> observe_tac (str "make_rewrite_list") (tclTHENS (observe_tac (str "rewrite heq on " ++ pr_id p ) ( (fun g -> let t_eq = compute_renamed_type g (mkVar hp) in let k,def = let k_na,_,t = destProd t_eq in let _,_,t = destProd t in let def_na,_,_ = destProd t in Nameops.out_name k_na,Nameops.out_name def_na in Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true (mkVar hp, ExplicitBindings[Loc.ghost,NamedHyp def, expr_info.f_constr;Loc.ghost,NamedHyp k, (f_S max)]) false) g) ) ) [make_rewrite_list expr_info max l; observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *) Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); observe_tac (str "prove_le(2)") prove_le ] ] ) let make_rewrite expr_info l hp max = tclTHENFIRST (observe_tac (str "make_rewrite") (make_rewrite_list expr_info max l)) (observe_tac (str "make_rewrite") (tclTHENS (fun g -> let t_eq = compute_renamed_type g (mkVar hp) in let k,def = let k_na,_,t = destProd t_eq in let _,_,t = destProd t in let def_na,_,_ = destProd t in Nameops.out_name k_na,Nameops.out_name def_na in observe_tac (str "general_rewrite_bindings") (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true (mkVar hp, ExplicitBindings[Loc.ghost,NamedHyp def, expr_info.f_constr;Loc.ghost,NamedHyp k, (f_S (f_S max))]) false)) g) [observe_tac(str "make_rewrite finalize") ( (* tclORELSE( h_reflexivity) *) (observe_tclTHENLIST (str "make_rewrite")[ Proofview.V82.of_tactic (simpl_iter Locusops.onConcl); observe_tac (str "unfold functional") (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], evaluable_of_global_reference expr_info.func)])); (list_rewrite true (List.map (fun e -> mkVar e,true) expr_info.eqs)); (observe_tac (str "h_reflexivity") (Proofview.V82.of_tactic intros_reflexivity) ) ])) ; observe_tclTHENLIST (str "make_rewrite1")[ (* x < S (S max) proof *) Proofview.V82.of_tactic (apply (delayed_force le_lt_SS)); observe_tac (str "prove_le (3)") prove_le ] ]) ) let rec compute_max rew_tac max l = match l with | [] -> rew_tac max | (_,p,_)::l -> observe_tclTHENLIST (str "compute_max")[ Proofview.V82.of_tactic (simplest_elim (mkApp(delayed_force max_constr, [| max; mkVar p|]))); tclDO 3 (Proofview.V82.of_tactic intro); onNLastHypsId 3 (fun lids -> match lids with | [hle2;hle1;pmax] -> compute_max rew_tac (mkVar pmax) l | _ -> assert false )] let rec destruct_hex expr_info acc l = match l with | [] -> begin match List.rev acc with | [] -> tclIDTAC | (_,p,hp)::tl -> observe_tac (str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) end | (v,hex)::l -> observe_tclTHENLIST (str "destruct_hex")[ Proofview.V82.of_tactic (simplest_case (mkVar hex)); Proofview.V82.of_tactic (clear [hex]); tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 (fun hp -> onNthHypId 2 (fun p -> observe_tac (str "destruct_hex after " ++ pr_id hp ++ spc () ++ pr_id p) (destruct_hex expr_info ((v,p,hp)::acc) l) ) ) ] let rec intros_values_eq expr_info acc = tclORELSE( observe_tclTHENLIST (str "intros_values_eq")[ tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 (fun hex -> (onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc))) ) ]) (tclCOMPLETE ( destruct_hex expr_info [] acc )) let equation_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then observe_tac (str "equation_others (cont_tac +intros) " ++ Printer.pr_lconstr expr_info.info) (tclTHEN (continuation_tac infos) (observe_tac (str "intros_values_eq equation_others " ++ Printer.pr_lconstr expr_info.info) (intros_values_eq expr_info []))) else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_lconstr expr_info.info) (continuation_tac infos) let equation_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then ((observe_tac (str "intros_values_eq equation_app") (intros_values_eq expr_info []))) else continuation_tac infos let equation_app_rec (f,args) expr_info continuation_tac info = begin try let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in observe_tac (str "app_rec found") (continuation_tac new_infos) with Not_found -> if expr_info.is_final && expr_info.is_main_branch then observe_tclTHENLIST (str "equation_app_rec") [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; observe_tac (str "app_rec intros_values_eq") (intros_values_eq expr_info []) ] else observe_tclTHENLIST (str "equation_app_rec1")[ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); observe_tac (str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) ] end let equation_info = {message = "prove_equation with term "; letiN = (fun _ -> assert false); lambdA = (fun _ _ _ _ -> assert false); casE = equation_case; otherS = equation_others; apP = equation_app; app_reC = equation_app_rec } let prove_eq = travel equation_info (* wrappers *) (* [compute_terminate_type] computes the type of the Definition f_terminate from the type of f_F *) let compute_terminate_type nb_args func = let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_global func)) in let rev_args,b = decompose_prod_n nb_args a_arrow_b in let left = mkApp(delayed_force iter, Array.of_list (lift 5 a_arrow_b:: mkRel 3:: constr_of_global func::mkRel 1:: List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args) ) ) in let right = mkRel 5 in let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in let nb_iter = mkApp(delayed_force ex, [|delayed_force nat; (mkLambda (Name p_id, delayed_force nat, (mkProd (Name k_id, delayed_force nat, mkArrow cond result))))|])in let value = mkApp(constr_of_global (delayed_force coq_sig_ref), [|b; (mkLambda (Name v_id, b, nb_iter))|]) in compose_prod rev_args value let termination_proof_header is_mes input_type ids args_id relation rec_arg_num rec_arg_id tac wf_tac : tactic = begin fun g -> let nargs = List.length args_id in let pre_rec_args = List.rev_map mkVar (fst (List.chop (rec_arg_num - 1) args_id)) in let relation = substl pre_rec_args relation in let input_type = substl pre_rec_args input_type in let wf_thm = next_ident_away_in_goal (Id.of_string ("wf_R")) ids in let wf_rec_arg = next_ident_away_in_goal (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))) (wf_thm::ids) in let hrec = next_ident_away_in_goal hrec_id (wf_rec_arg::wf_thm::ids) in let acc_inv = lazy ( mkApp ( delayed_force acc_inv_id, [|input_type;relation;mkVar rec_arg_id|] ) ) in tclTHEN (h_intros args_id) (tclTHENS (observe_tac (str "first assert") (Proofview.V82.of_tactic (assert_before (Name wf_rec_arg) (mkApp (delayed_force acc_rel, [|input_type;relation;mkVar rec_arg_id|]) ) )) ) [ (* accesibility proof *) tclTHENS (observe_tac (str "second assert") (Proofview.V82.of_tactic (assert_before (Name wf_thm) (mkApp (delayed_force well_founded,[|input_type;relation|])) )) ) [ (* interactive proof that the relation is well_founded *) observe_tac (str "wf_tac") (wf_tac is_mes (Some args_id)); (* this gives the accessibility argument *) observe_tac (str "apply wf_thm") (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) ) ] ; (* rest of the proof *) observe_tclTHENLIST (str "rest of proof") [observe_tac (str "generalize") (onNLastHypsId (nargs+1) (tclMAP (fun id -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) )) ; observe_tac (str "fix") (Proofview.V82.of_tactic (fix (Some hrec) (nargs+1))); h_intros args_id; Proofview.V82.of_tactic (Simple.intro wf_rec_arg); observe_tac (str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ] ) g end let rec instantiate_lambda t l = match l with | [] -> t | a::l -> let (_, _, body) = destLambda t in instantiate_lambda (subst1 a body) l let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = begin fun g -> let ids = Termops.ids_of_named_context (pf_hyps g) in let func_body = (def_of_const (constr_of_global func)) in let (f_name, _, body1) = destLambda func_body in let f_id = match f_name with | Name f_id -> next_ident_away_in_goal f_id ids | Anonymous -> anomaly (Pp.str "Anonymous function") in let n_names_types,_ = decompose_lam_n nb_args body1 in let n_ids,ids = List.fold_left (fun (n_ids,ids) (n_name,_) -> match n_name with | Name id -> let n_id = next_ident_away_in_goal id ids in n_id::n_ids,n_id::ids | _ -> anomaly (Pp.str "anonymous argument") ) ([],(f_id::ids)) n_names_types in let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in termination_proof_header is_mes input_type ids n_ids relation rec_arg_num rec_arg_id (fun rec_arg_id hrec acc_id acc_inv g -> (prove_terminate (fun infos -> tclIDTAC) { is_main_branch = true; (* we are on the main branche (i.e. still on a match ... with .... end *) is_final = true; (* and on leaf (more or less) *) f_terminate = delayed_force coq_O; nb_arg = nb_args; concl_tac = concl_tac; rec_arg_id = rec_arg_id; is_mes = is_mes; ih = hrec; f_id = f_id; f_constr = mkVar f_id; func = func; info = expr; acc_inv = acc_inv; acc_id = acc_id; values_and_bounds = []; eqs = []; forbidden_ids = []; args_assoc = [] } ) g ) (tclUSER_if_not_mes concl_tac) g end let get_current_subgoals_types () = let p = Proof_global.give_me_the_proof () in let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in sigma, List.map (Goal.V82.abstract_type sigma) sgs let build_and_l l = let and_constr = Coqlib.build_coq_and () in let conj_constr = coq_conj () in let mk_and p1 p2 = Term.mkApp(and_constr,[|p1;p2|]) in let rec is_well_founded t = match kind_of_term t with | Prod(_,_,t') -> is_well_founded t' | App(_,_) -> let (f,_) = decompose_app t in eq_constr f (well_founded ()) | _ -> false in let compare t1 t2 = let b1,b2= is_well_founded t1,is_well_founded t2 in if (b1&&b2) || not (b1 || b2) then 0 else if b1 && not b2 then 1 else -1 in let l = List.sort compare l in let rec f = function | [] -> failwith "empty list of subgoals!" | [p] -> p,tclIDTAC,1 | p1::pl -> let c,tac,nb = f pl in mk_and p1 c, tclTHENS (Proofview.V82.of_tactic (apply (constr_of_global conj_constr))) [tclIDTAC; tac ],nb+1 in f l let is_rec_res id = let rec_res_name = Id.to_string rec_res_id in let id_name = Id.to_string id in try String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name with Invalid_argument _ -> false let clear_goals = let rec clear_goal t = match kind_of_term t with | Prod(Name id as na,t',b) -> let b' = clear_goal b in if noccurn 1 b' && (is_rec_res id) then Termops.pop b' else if b' == b then t else mkProd(na,t',b') | _ -> Term.map_constr clear_goal t in List.map clear_goal let build_new_goal_type () = let sigma, sub_gls_types = get_current_subgoals_types () in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let res = build_and_l sub_gls_types in sigma, res let is_opaque_constant c = let cb = Global.lookup_constant c in match cb.Declarations.const_body with | Declarations.OpaqueDef _ -> Vernacexpr.Opaque None | Declarations.Undef _ -> Vernacexpr.Opaque None | Declarations.Def _ -> Vernacexpr.Transparent let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) let current_proof_name = get_current_proof_name () in let name = match goal_name with | Some s -> s | None -> try add_suffix current_proof_name "_subproof" with e when CErrors.noncritical e -> anomaly (Pp.str "open_new_goal with an unamed theorem") in let na = next_global_ident_away name [] in if Termops.occur_existential gls_type then CErrors.error "\"abstract\" cannot handle existentials"; let hook _ _ = let opacity = let na_ref = Libnames.Ident (Loc.ghost,na) in let na_global = Smartlocate.global_with_alias na_ref in match na_global with ConstRef c -> is_opaque_constant c | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant") in let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in ref_ := Some lemma ; let lid = ref [] in let h_num = ref (-1) in let env = Global.env () in Proof_global.discard_all (); build_proof (Evd.from_env env) ( fun gls -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in observe_tclTHENLIST (str "") [ Proofview.V82.of_tactic (generalize [lemma]); Proofview.V82.of_tactic (Simple.intro hid); (fun g -> let ids = pf_ids_of_hyps g in tclTHEN (Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid))) (fun g -> let ids' = pf_ids_of_hyps g in lid := List.rev (List.subtract Id.equal ids' ids); if List.is_empty !lid then lid := [hid]; tclIDTAC g ) g ); ] gls) (fun g -> match kind_of_term (pf_concl g) with | App(f,_) when eq_constr f (well_founded ()) -> Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g | _ -> incr h_num; (observe_tac (str "finishing using") ( tclCOMPLETE( tclFIRST[ tclTHEN (Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))) (Proofview.V82.of_tactic e_assumption); Eauto.eauto_with_bases (true,5) [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ] ) ) ) g) ; Lemmas.save_proof (Vernacexpr.Proved(opacity,None)); in Lemmas.start_proof na (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) sigma gls_type (Lemmas.mk_hook hook); if Indfun_common.is_strict_tcc () then ignore (by (Proofview.V82.tactic (tclIDTAC))) else begin ignore (by (Proofview.V82.tactic begin fun g -> tclTHEN (decompose_and_tac) (tclORELSE (tclFIRST (List.map (fun c -> Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST [intros; Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*); Tacticals.New.tclCOMPLETE Auto.default_auto ]) ) using_lemmas) ) tclIDTAC) g end)) end; try ignore (by (Proofview.V82.tactic tclIDTAC)); (* raises UserError _ if the proof is complete *) with UserError _ -> defined () let com_terminate tcc_lemma_name tcc_lemma_ref is_mes fonctional_ref input_type relation rec_arg_num thm_name using_lemmas nb_args ctx hook = let start_proof ctx (tac_start:tactic) (tac_end:tactic) = let (evmap, env) = Lemmas.get_current_context() in Lemmas.start_proof thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) ctx (compute_terminate_type nb_args fonctional_ref) hook; ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start))); ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref input_type relation rec_arg_num )))) in start_proof ctx tclIDTAC tclIDTAC; try let sigma, new_goal_type = build_new_goal_type () in let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in open_new_goal start_proof sigma using_lemmas tcc_lemma_ref (Some tcc_lemma_name) (new_goal_type); with Failure "empty list of subgoals!" -> (* a non recursive function declared with measure ! *) defined () let start_equation (f:global_reference) (term_f:global_reference) (cont_tactic:Id.t list -> tactic) g = let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_global term_f in let nargs = nb_prod (fst (type_of_const terminate_constr)) (*FIXME*) in let x = n_x_id ids nargs in observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [ h_intros x; Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]); observe_tac (str "simplest_case") (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))); observe_tac (str "prove_eq") (cont_tactic x)]) g;; let (com_eqn : int -> Id.t -> global_reference -> global_reference -> global_reference -> constr -> unit) = fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> let opacity = match terminate_ref with | ConstRef c -> is_opaque_constant c | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant") in let (evmap, env) = Lemmas.get_current_context() in let evmap = Evd.from_ctx (Evd.evar_universe_context evmap) in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in (Lemmas.start_proof eq_name (Global, false, Proof Lemma) ~sign:(Environ.named_context_val env) evmap equation_lemma_type (Lemmas.mk_hook (fun _ _ -> ())); ignore (by (Proofview.V82.tactic (start_equation f_ref terminate_ref (fun x -> prove_eq (fun _ -> tclIDTAC) {nb_arg=nb_arg; f_terminate = constr_of_global terminate_ref; f_constr = f_constr; concl_tac = tclIDTAC; func=functional_ref; info=(instantiate_lambda (def_of_const (constr_of_global functional_ref)) (f_constr::List.map mkVar x) ); is_main_branch = true; is_final = true; values_and_bounds = []; eqs = []; forbidden_ids = []; acc_inv = lazy (assert false); acc_id = Id.of_string "____"; args_assoc = []; f_id = Id.of_string "______"; rec_arg_id = Id.of_string "______"; is_mes = false; ih = Id.of_string "______"; } ) ))); (* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) (* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *) Flags.silently (fun () -> Lemmas.save_proof (Vernacexpr.Proved(opacity,None))) () ; (* Pp.msgnl (str "eqn finished"); *) );; let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : unit = let env = Global.env() in let evd = ref (Evd.from_env env) in let function_type = interp_type_evars env evd type_of_f in let env = push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) let ty = interp_type_evars env evd ~impls:rec_impls eq in let evm, nf = Evarutil.nf_evars_and_universes !evd in let equation_lemma_type = nf_betaiotazeta (nf ty) in let function_type = nf function_type in (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in let eq' = nf_zeta env_eq' eq' in let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) (* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) (* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) match kind_of_term eq' with | App(e,[|_;_;eq_fix|]) -> mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars eq_fix)) | _ -> failwith "Recursive Definition (res not eq)" in let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in let equation_id = add_suffix function_name "_equation" in let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(snd (Evd.universe_context evm)) res in (* Refresh the global universes, now including those of _F *) let evm = Evd.from_env (Global.env ()) in let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> LocalAssum (x,t)) pre_rec_args) env in let relation, evuctx = interp_constr env_with_pre_rec_args evm r in let evm = Evd.from_ctx evuctx in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref None in (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) let hook _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in let _ = Extraction_plugin.Table.extraction_inline true [Ident (Loc.ghost,term_id)] in (* message "start second proof"; *) let stop = try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); false with e when CErrors.noncritical e -> begin if do_observe () then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e) else CErrors.errorlabstrm "Cannot create equation Lemma" (str "Cannot create equation lemma." ++ spc () ++ str "This may be because the function is nested-recursive.") ; true end in if not stop then let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in let f_ref = destConst (constr_of_global f_ref) and functional_ref = destConst (constr_of_global functional_ref) and eq_ref = destConst (constr_of_global eq_ref) in generate_induction_principle f_ref tcc_lemma_constr functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation; if Flags.is_verbose () then msgnl (h 1 (Ppconstr.pr_id function_name ++ spc () ++ str"is defined" )++ fnl () ++ h 1 (Ppconstr.pr_id equation_id ++ spc () ++ str"is defined" ) ) in States.with_state_protection_on_exception (fun () -> com_terminate tcc_lemma_name tcc_lemma_constr is_mes functional_ref rec_arg_type relation rec_arg_num term_id using_lemmas (List.length res_vars) evm (Lemmas.mk_hook hook)) () coq-8.6/plugins/funind/recdef.mli0000644000175000017500000000120713022274260016356 0ustar mdenesmdenes (* val evaluable_of_global_reference : Libnames.global_reference -> Names.evaluable_global_reference *) val tclUSER_if_not_mes : Proof_type.tactic -> bool -> Names.Id.t list option -> Proof_type.tactic val recursive_definition : bool -> Names.Id.t -> Constrintern.internalization_env -> Constrexpr.constr_expr -> Constrexpr.constr_expr -> int -> Constrexpr.constr_expr -> (Term.pconstant -> Term.constr option ref -> Term.pconstant -> Term.pconstant -> int -> Term.types -> int -> Term.constr -> 'a) -> Constrexpr.constr_expr list -> unit coq-8.6/plugins/funind/indfun_common.mli0000644000175000017500000000665613022274260017776 0ustar mdenesmdenesopen Names open Pp (* The mk_?_id function build different name w.r.t. a function Each of their use is justified in the code *) val mk_rel_id : Id.t -> Id.t val mk_correct_id : Id.t -> Id.t val mk_complete_id : Id.t -> Id.t val mk_equation_id : Id.t -> Id.t val msgnl : std_ppcmds -> unit val fresh_id : Id.t list -> string -> Id.t val fresh_name : Id.t list -> string -> Name.t val get_name : Id.t list -> ?default:string -> Name.t -> Name.t val array_get_start : 'a array -> 'a array val id_of_name : Name.t -> Id.t val locate_ind : Libnames.reference -> inductive val locate_constant : Libnames.reference -> constant val locate_with_msg : Pp.std_ppcmds -> (Libnames.reference -> 'a) -> Libnames.reference -> 'a val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list val list_union_eq : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list val list_add_set_eq : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list val chop_rlambda_n : int -> Glob_term.glob_constr -> (Name.t*Glob_term.glob_constr*bool) list * Glob_term.glob_constr val chop_rprod_n : int -> Glob_term.glob_constr -> (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr val def_of_const : Term.constr -> Term.constr val eq : Term.constr Lazy.t val refl_equal : Term.constr Lazy.t val const_of_id: Id.t -> Globnames.global_reference(* constantyes *) val jmeq : unit -> Term.constr val jmeq_refl : unit -> Term.constr val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind -> unit Lemmas.declaration_hook CEphemeron.key -> unit (* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and abort the proof *) val get_proof_clean : bool -> Names.Id.t * (Safe_typing.private_constants Entries.definition_entry * Decl_kinds.goal_kind) (* [with_full_print f a] applies [f] to [a] in full printing environment. This function preserves the print settings *) val with_full_print : ('a -> 'b) -> 'a -> 'b (*****************) type function_info = { function_constant : constant; graph_ind : inductive; equation_lemma : constant option; correctness_lemma : constant option; completeness_lemma : constant option; rect_lemma : constant option; rec_lemma : constant option; prop_lemma : constant option; is_general : bool; } val find_Function_infos : constant -> function_info val find_Function_of_graph : inductive -> function_info (* WARNING: To be used just after the graph definition !!! *) val add_Function : bool -> constant -> unit val update_Function : function_info -> unit (** debugging *) val pr_info : function_info -> Pp.std_ppcmds val pr_table : unit -> Pp.std_ppcmds (* val function_debug : bool ref *) val do_observe : unit -> bool val do_rewrite_dependent : unit -> bool (* To localize pb *) exception Building_graph of exn exception Defining_principle of exn exception ToShow of exn val is_strict_tcc : unit -> bool val h_intros: Names.Id.t list -> Proof_type.tactic val h_id : Names.Id.t val hrec_id : Names.Id.t val acc_inv_id : Term.constr Util.delayed val ltof_ref : Globnames.global_reference Util.delayed val well_founded_ltof : Term.constr Util.delayed val acc_rel : Term.constr Util.delayed val well_founded : Term.constr Util.delayed val evaluable_of_global_reference : Globnames.global_reference -> Names.evaluable_global_reference val list_rewrite : bool -> (Term.constr*bool) list -> Proof_type.tactic coq-8.6/plugins/funind/g_indfun.ml40000644000175000017500000002025513022274260016636 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) let pr_bindings prc prlc = function | ImplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ pr_sequence prc l | ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | NoBindings -> mt () let pr_with_bindings prc prlc (c,bl) = prc c ++ hv 0 (pr_bindings prc prlc bl) let pr_fun_ind_using prc prlc _ opt_c = match opt_c with | None -> mt () | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc b) (* Duplication of printing functions because "'a with_bindings" is (internally) not uniform in 'a: indeed constr_with_bindings at the "typed" level has type "open_constr with_bindings" instead of "constr with_bindings"; hence, its printer cannot be polymorphic in (prc,prlc)... *) let pr_with_bindings_typed prc prlc (c,bl) = prc c ++ hv 0 (pr_bindings prc prlc bl) let pr_fun_ind_using_typed prc prlc _ opt_c = match opt_c with | None -> mt () | Some b -> let (b, _) = Tactics.run_delayed (Global.env ()) Evd.empty b in spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b) ARGUMENT EXTEND fun_ind_using TYPED AS constr_with_bindings option PRINTED BY pr_fun_ind_using_typed RAW_TYPED AS constr_with_bindings_opt RAW_PRINTED BY pr_fun_ind_using GLOB_TYPED AS constr_with_bindings_opt GLOB_PRINTED BY pr_fun_ind_using | [ "using" constr_with_bindings(c) ] -> [ Some c ] | [ ] -> [ None ] END TACTIC EXTEND newfuninv [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> [ Proofview.V82.tactic (Invfun.invfun hyp fname) ] END let pr_intro_as_pat _prc _ _ pat = match pat with | Some pat -> spc () ++ str "as" ++ spc () ++ (* Miscprint.pr_intro_pattern prc pat *) str"" | None -> mt () let out_disjunctive = function | loc, IntroAction (IntroOrAndPattern l) -> (loc,l) | _ -> CErrors.error "Disjunctive or conjunctive intro pattern expected." ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat | [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] | [] ->[ None ] END TACTIC EXTEND newfunind ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> [ let c = match cl with | [] -> assert false | [c] -> c | c::cl -> applist(c,cl) in Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat))) princl ] END (***** debug only ***) TACTIC EXTEND snewfunind ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> [ let c = match cl with | [] -> assert false | [c] -> c | c::cl -> applist(c,cl) in Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction false c x (Option.map out_disjunctive pat))) princl ] END let pr_constr_comma_sequence prc _ _ = prlist_with_sep pr_comma prc ARGUMENT EXTEND constr_comma_sequence' TYPED AS constr_list PRINTED BY pr_constr_comma_sequence | [ constr(c) "," constr_comma_sequence'(l) ] -> [ c::l ] | [ constr(c) ] -> [ [c] ] END let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc ARGUMENT EXTEND auto_using' TYPED AS constr_list PRINTED BY pr_auto_using | [ "using" constr_comma_sequence'(l) ] -> [ l ] | [ ] -> [ [] ] END module Gram = Pcoq.Gram module Vernac = Pcoq.Vernac_ module Tactic = Pcoq.Tactic type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located let (wit_function_rec_definition_loc : function_rec_definition_loc_argtype Genarg.uniform_genarg_type) = Genarg.create_arg "function_rec_definition_loc" let function_rec_definition_loc = Pcoq.create_generic_entry Pcoq.utactic "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) GEXTEND Gram GLOBAL: function_rec_definition_loc ; function_rec_definition_loc: [ [ g = Vernac.rec_definition -> !@loc, g ]] ; END let () = let raw_printer _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in let printer _ _ _ _ = str "" in Pptactic.declare_extra_genarg_pprule wit_function_rec_definition_loc raw_printer printer printer (* TASSI: n'importe quoi ! *) VERNAC COMMAND EXTEND Function ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] => [ let hard = List.exists (function | _,((_,(_,(CMeasureRec _|CWfRec _)),_,_,_),_) -> true | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in match Vernac_classifier.classify_vernac (Vernacexpr.VernacFixpoint(None, List.map snd recsl)) with | Vernacexpr.VtSideff ids, _ when hard -> Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) | x -> x ] -> [ do_generate_principle false (List.map snd recsl) ] END let pr_fun_scheme_arg (princ_name,fun_name,s) = Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ Ppconstr.pr_glob_sort s VERNAC ARGUMENT EXTEND fun_scheme_arg PRINTED BY pr_fun_scheme_arg | [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] END let warning_error names e = let (e, _) = ExplainErr.process_vernac_interp_error (e, Exninfo.null) in match e with | Building_graph e -> let names = pr_enum Libnames.pr_reference names in let error = if do_observe () then (spc () ++ CErrors.print e) else mt () in warn_cannot_define_graph (names,error) | Defining_principle e -> let names = pr_enum Libnames.pr_reference names in let error = if do_observe () then CErrors.print e else mt () in warn_cannot_define_principle (names,error) | _ -> raise e VERNAC COMMAND EXTEND NewFunctionalScheme ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] => [ Vernacexpr.VtSideff(List.map pi1 fas), Vernacexpr.VtLater ] -> [ begin try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> begin match fas with | (_,fun_name,_)::_ -> begin begin make_graph (Smartlocate.global_with_alias fun_name) end ; try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> CErrors.error ("Cannot generate induction principle(s)") | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end | _ -> assert false (* we can only have non empty list *) end | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end ] END (***** debug only ***) VERNAC COMMAND EXTEND NewFunctionalCase ["Functional" "Case" fun_scheme_arg(fas) ] => [ Vernacexpr.VtSideff[pi1 fas], Vernacexpr.VtLater ] -> [ Functional_principles_types.build_case_scheme fas ] END (***** debug only ***) VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY ["Generate" "graph" "for" reference(c)] -> [ make_graph (Smartlocate.global_with_alias c) ] END coq-8.6/plugins/funind/functional_principles_types.mli0000644000175000017500000000262113022274260022745 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (* do we accept interactive proving *) bool -> (* induction principle on rel *) types -> (* *) sorts array option -> (* Name of the new principle *) (Id.t) option -> (* the compute functions to use *) pconstant array -> (* We prove the nth- principle *) int -> (* The tactic to use to make the proof w.r the number of params *) (constr array -> int -> Tacmach.tactic) -> unit val compute_new_princ_type_from_rel : constr array -> sorts array -> types -> types exception No_graph_found val make_scheme : Evd.evar_map ref -> (pconstant*glob_sort) list -> Safe_typing.private_constants Entries.definition_entry list val build_scheme : (Id.t*Libnames.reference*glob_sort) list -> unit val build_case_scheme : (Id.t*Libnames.reference*glob_sort) -> unit coq-8.6/plugins/funind/recdef_plugin.mlpack0000644000175000017500000000021613022274260020421 0ustar mdenesmdenesIndfun_common Glob_termops Recdef Glob_term_to_relation Functional_principles_proofs Functional_principles_types Invfun Indfun Merge G_indfun coq-8.6/plugins/funind/glob_termops.mli0000644000175000017500000001036013022274260017622 0ustar mdenesmdenesopen Names open Glob_term open Misctypes (* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *) val get_pattern_id : cases_pattern -> Id.t list (* [pattern_to_term pat] returns a glob_constr corresponding to [pat]. [pat] must not contain occurrences of anonymous pattern *) val pattern_to_term : cases_pattern -> glob_constr (* Some basic functions to rebuild glob_constr In each of them the location is Util.Loc.ghost *) val mkGRef : Globnames.global_reference -> glob_constr val mkGVar : Id.t -> glob_constr val mkGApp : glob_constr*(glob_constr list) -> glob_constr val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr val mkGProd : Name.t * glob_constr * glob_constr -> glob_constr val mkGLetIn : Name.t * glob_constr * glob_constr -> glob_constr val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr val mkGSort : glob_sort -> glob_constr val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *) val mkGCast : glob_constr* glob_constr -> glob_constr (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) val glob_decompose_prod : glob_constr -> (Name.t*glob_constr) list * glob_constr val glob_decompose_prod_or_letin : glob_constr -> (Name.t*glob_constr option*glob_constr option) list * glob_constr val glob_decompose_prod_n : int -> glob_constr -> (Name.t*glob_constr) list * glob_constr val glob_decompose_prod_or_letin_n : int -> glob_constr -> (Name.t*glob_constr option*glob_constr option) list * glob_constr val glob_compose_prod : glob_constr -> (Name.t*glob_constr) list -> glob_constr val glob_compose_prod_or_letin: glob_constr -> (Name.t*glob_constr option*glob_constr option) list -> glob_constr val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list) (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) val glob_make_neq : glob_constr -> glob_constr -> glob_constr (* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *) val glob_make_or : glob_constr -> glob_constr -> glob_constr (* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding to [P1 \/ ( .... \/ Pn)] *) val glob_make_or_list : glob_constr list -> glob_constr (* alpha_conversion functions *) (* Replace the var mapped in the glob_constr/context *) val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr (* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. the result does not share variables with [avoid]. This function create a fresh variable for each occurrence of the anonymous pattern. Also returns a mapping from old variables to new ones and the concatenation of [avoid] with the variables appearing in the result. *) val alpha_pat : Id.Map.key list -> Glob_term.cases_pattern -> Glob_term.cases_pattern * Id.Map.key list * Id.t Id.Map.t (* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt conventions and does not share bound variables with avoid *) val alpha_rt : Id.t list -> glob_constr -> glob_constr (* same as alpha_rt but for case branches *) val alpha_br : Id.t list -> Loc.t * Id.t list * Glob_term.cases_pattern list * Glob_term.glob_constr -> Loc.t * Id.t list * Glob_term.cases_pattern list * Glob_term.glob_constr (* Reduction function *) val replace_var_by_term : Id.t -> Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) val is_free_in : Id.t -> glob_constr -> bool val are_unifiable : cases_pattern -> cases_pattern -> bool val eq_cases_pattern : cases_pattern -> cases_pattern -> bool (* ids_of_pat : cases_pattern -> Id.Set.t returns the set of variables appearing in a pattern *) val ids_of_pat : cases_pattern -> Id.Set.t (* TODO: finish this function (Fix not treated) *) val ids_of_glob_constr: glob_constr -> Id.Set.t (* removing let_in construction in a glob_constr *) val zeta_normalize : Glob_term.glob_constr -> Glob_term.glob_constr val expand_as : glob_constr -> glob_constr coq-8.6/plugins/funind/indfun.ml0000644000175000017500000007346613022274260016260 0ustar mdenesmdenesopen Context.Rel.Declaration open CErrors open Util open Names open Term open Pp open Indfun_common open Libnames open Globnames open Glob_term open Declarations open Misctypes open Decl_kinds open Sigma.Notations let is_rec_info scheme_info = let test_branche min acc decl = acc || ( let new_branche = it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (get_type decl))) in let free_rels_in_br = Termops.free_rels new_branche in let max = min + scheme_info.Tactics.npredicates in Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br ) in List.fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) let choose_dest_or_ind scheme_info = Tactics.induction_destruct (is_rec_info scheme_info) false let functional_induction with_clean c princl pat = let res = let f,args = decompose_app c in fun g -> let princ,bindings, princ_type,g' = match princl with | None -> (* No principle is given let's find the good one *) begin match kind_of_term f with | Const (c',u) -> let princ_option = let finfo = (* we first try to find out a graph on f *) try find_Function_infos c' with Not_found -> errorlabstrm "" (str "Cannot find induction information on "++ Printer.pr_lconstr (mkConst c') ) in match Tacticals.elimination_sort_of_goal g with | InProp -> finfo.prop_lemma | InSet -> finfo.rec_lemma | InType -> finfo.rect_lemma in let princ,g' = (* then we get the principle *) try let g',princ = Tacmach.pf_eapply (Evd.fresh_global) g (Globnames.ConstRef (Option.get princ_option )) in princ,g' with Option.IsNone -> (*i If there is not default lemma defined then, we cross our finger and try to find a lemma named f_ind (or f_rec, f_rect) i*) let princ_name = Indrec.make_elimination_ident (Label.to_id (con_label c')) (Tacticals.elimination_sort_of_goal g) in try let princ_ref = const_of_id princ_name in let (a,b) = Tacmach.pf_eapply (Evd.fresh_global) g princ_ref in (b,a) (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) with Not_found -> (* This one is neither defined ! *) errorlabstrm "" (str "Cannot find induction principle for " ++Printer.pr_lconstr (mkConst c') ) in (princ,NoBindings, Tacmach.pf_unsafe_type_of g' princ,g') | _ -> raise (UserError("",str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> princ,binding,Tacmach.pf_unsafe_type_of g princ,g in let princ_infos = Tactics.compute_elim_sig princ_type in let args_as_induction_constr = let c_list = if princ_infos.Tactics.farg_in_concl then [c] else [] in let encoded_pat_as_patlist = List.make (List.length args + List.length c_list - 1) None @ [pat] in List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) })),(None,pat),None)) (args@c_list) encoded_pat_as_patlist in let princ' = Some (princ,bindings) in let princ_vars = List.fold_right (fun a acc -> try Id.Set.add (destVar a) acc with DestKO -> acc) args Id.Set.empty in let old_idl = List.fold_right Id.Set.add (Tacmach.pf_ids_of_hyps g) Id.Set.empty in let old_idl = Id.Set.diff old_idl princ_vars in let subst_and_reduce g = if with_clean then let idl = List.filter (fun id -> not (Id.Set.mem id old_idl)) (Tacmach.pf_ids_of_hyps g) in let flag = Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false; } in Tacticals.tclTHEN (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Proofview.V82.of_tactic (Equality.subst_gen (do_rewrite_dependent ()) [id]))) idl ) (Proofview.V82.of_tactic (Tactics.reduce flag Locusops.allHypsAndConcl)) g else Tacticals.tclIDTAC g in Tacticals.tclTHEN (Proofview.V82.of_tactic (choose_dest_or_ind princ_infos (args_as_induction_constr,princ'))) subst_and_reduce g' in res let rec abstract_glob_constr c = function | [] -> c | Constrexpr.LocalRawDef (x,b)::bl -> Constrexpr_ops.mkLetInC(x,b,abstract_glob_constr c bl) | Constrexpr.LocalRawAssum (idl,k,t)::bl -> List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl (abstract_glob_constr c bl) | Constrexpr.LocalPattern _::bl -> assert false let interp_casted_constr_with_implicits env sigma impls c = Constrintern.intern_gen Pretyping.WithoutTypeConstraint env ~impls ~allow_patvar:false c (* Construct a fixpoint as a Glob_term and not as a constr *) let build_newrecursive lnameargsardef = let env0 = Global.env() in let sigma = Evd.from_env env0 in let (rec_sign,rec_impls) = List.fold_left (fun (env,impls) (((_,recname),_),bl,arityc,_) -> let arityc = Constrexpr_ops.prod_constr_expr arityc bl in let arity,ctx = Constrintern.interp_type env0 sigma arityc in let evdref = ref (Evd.from_env env0) in let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity impls' in let open Context.Named.Declaration in (Environ.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls)) (env0,Constrintern.empty_internalization_env) lnameargsardef in let recdef = (* Declare local notations *) let f (_,bl,_,def) = let def = abstract_glob_constr def bl in interp_casted_constr_with_implicits rec_sign sigma rec_impls def in States.with_state_protection (List.map f) lnameargsardef in recdef,rec_impls let build_newrecursive l = let l' = List.map (fun ((fixna,_,bll,ar,body_opt),lnot) -> match body_opt with | Some body -> (fixna,bll,ar,body) | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") ) l in build_newrecursive l' (* Checks whether or not the mutual bloc is recursive *) let is_rec names = let names = List.fold_right Id.Set.add names Id.Set.empty in let check_id id names = Id.Set.mem id names in let rec lookup names = function | GVar(_,id) -> check_id id names | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> false | GCast(_,b,_) -> lookup names b | GRec _ -> error "GRec not handled" | GIf(_,b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) | GLetIn(_,na,t,b) | GLambda(_,na,_,t,b) | GProd(_,na,_,t,b) -> lookup names t || lookup (Nameops.name_fold Id.Set.remove na names) b | GLetTuple(_,nal,_,t,b) -> lookup names t || lookup (List.fold_left (fun acc na -> Nameops.name_fold Id.Set.remove na acc) names nal ) b | GApp(_,f,args) -> List.exists (lookup names) (f::args) | GCases(_,_,_,el,brl) -> List.exists (fun (e,_) -> lookup names e) el || List.exists (lookup_br names) brl and lookup_br names (_,idl,_,rt) = let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt in lookup names let rec local_binders_length = function (* Assume that no `{ ... } contexts occur *) | [] -> 0 | Constrexpr.LocalRawDef _::bl -> 1 + local_binders_length bl | Constrexpr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl | Constrexpr.LocalPattern _::bl -> assert false let prepare_body ((name,_,args,types,_),_) rt = let n = local_binders_length args in (* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_glob_constr rt); *) let fun_args,rt' = chop_rlambda_n n rt in (fun_args,rt') let process_vernac_interp_error e = fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null)) let warn_funind_cannot_build_inversion = CWarnings.create ~name:"funind-cannot-build-inversion" ~category:"funind" (fun e' -> strbrk "Cannot build inversion information" ++ if do_observe () then (fnl() ++ CErrors.print e') else mt ()) let derive_inversion fix_names = try let evd' = Evd.from_env (Global.env ()) in (* we first transform the fix_names identifier into their corresponding constant *) let evd',fix_names_as_constant = List.fold_right (fun id (evd,l) -> let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in evd, destConst c::l ) fix_names (evd',[]) in (* Then we check that the graphs have been defined If one of the graphs haven't been defined we do nothing *) List.iter (fun c -> ignore (find_Function_infos (fst c))) fix_names_as_constant ; try let evd', lind = List.fold_right (fun id (evd,l) -> let evd,id = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) in evd,(fst (destInd id))::l ) fix_names (evd',[]) in Invfun.derive_correctness Functional_principles_types.make_scheme functional_induction fix_names_as_constant lind; with e when CErrors.noncritical e -> let e' = process_vernac_interp_error e in warn_funind_cannot_build_inversion e' with e when CErrors.noncritical e -> let e' = process_vernac_interp_error e in warn_funind_cannot_build_inversion e' let warn_cannot_define_graph = CWarnings.create ~name:"funind-cannot-define-graph" ~category:"funind" (fun (names,error) -> strbrk "Cannot define graph(s) for " ++ h 1 names ++ error) let warn_cannot_define_principle = CWarnings.create ~name:"funind-cannot-define-principle" ~category:"funind" (fun (names,error) -> strbrk "Cannot define induction principle(s) for "++ h 1 names ++ error) let warning_error names e = let e = process_vernac_interp_error e in let e_explain e = match e with | ToShow e -> let e = process_vernac_interp_error e in spc () ++ CErrors.print e | _ -> if do_observe () then let e = process_vernac_interp_error e in (spc () ++ CErrors.print e) else mt () in match e with | Building_graph e -> let names = prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names in warn_cannot_define_graph (names,e_explain e) | Defining_principle e -> let names = prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names in warn_cannot_define_principle (names,e_explain e) | _ -> raise e let error_error names e = let e = process_vernac_interp_error e in let e_explain e = match e with | ToShow e -> spc () ++ CErrors.print e | _ -> if do_observe () then (spc () ++ CErrors.print e) else mt () in match e with | Building_graph e -> errorlabstrm "" (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) | _ -> raise e let generate_principle (evd:Evd.evar_map ref) pconstants on_error is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs interactive_proof (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) : unit = let names = List.map (function (((_, name),_),_,_,_,_),_ -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in let funs_types = List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in try (* We then register the Inductive graphs of the functions *) Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types recdefs; if do_built then begin (*i The next call to mk_rel_id is valid since we have just construct the graph Ensures by : do_built i*) let f_R_mut = Ident (Loc.ghost,mk_rel_id (List.nth names 0)) in let ind_kn = fst (locate_with_msg (pr_reference f_R_mut++str ": Not an inductive type!") locate_ind f_R_mut) in let fname_kn (((fname,_),_,_,_,_),_) = let f_ref = Ident fname in locate_with_msg (pr_reference f_ref++str ": Not an inductive type!") locate_constant f_ref in let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in let _ = List.map_i (fun i x -> let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in let env = Global.env () in let evd = ref (Evd.from_env env) in let evd',uprinc = Evd.fresh_global env !evd princ in let _ = evd := evd' in let princ_type = Typing.e_type_of ~refresh:true env evd uprinc in Functional_principles_types.generate_functional_principle evd interactive_proof princ_type None None (Array.of_list pconstants) (* funs_kn *) i (continue_proof 0 [|funs_kn.(i)|]) ) 0 fix_rec_l in Array.iter (add_Function is_general) funs_kn; () end with e when CErrors.noncritical e -> on_error names e let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with | [(((_,fname),pl),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in Command.do_definition fname (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) pl bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ())); let evd,rev_pconstants = List.fold_left (fun (evd,l) ((((_,fname),_),_,_,_,_),_) -> let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in evd,((destConst c)::l) ) (Evd.from_env (Global.env ()),[]) fixpoint_exprl in evd,List.rev rev_pconstants | _ -> Command.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl; let evd,rev_pconstants = List.fold_left (fun (evd,l) ((((_,fname),_),_,_,_,_),_) -> let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in evd,((destConst c)::l) ) (Evd.from_env (Global.env ()),[]) fixpoint_exprl in evd,List.rev rev_pconstants let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = Functional_principles_proofs.prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body pre_hook = let type_of_f = Constrexpr_ops.prod_constr_expr ret_type args in let rec_arg_num = let names = List.map snd (Constrexpr_ops.names_of_local_assums args) in match wf_arg with | None -> if Int.equal (List.length names) 1 then 1 else error "Recursive argument must be specified" | Some wf_arg -> List.index Name.equal (Name wf_arg) names in let unbounded_eq = let f_app_args = Constrexpr.CAppExpl (Loc.ghost, (None,(Ident (Loc.ghost,fname)),None) , (List.map (function | _,Anonymous -> assert false | _,Name e -> (Constrexpr_ops.mkIdentC e) ) (Constrexpr_ops.names_of_local_assums args) ) ) in Constrexpr.CApp (Loc.ghost,(None,Constrexpr_ops.mkRefC (Qualid (Loc.ghost,(qualid_of_string "Logic.eq")))), [(f_app_args,None);(body,None)]) in let eq = Constrexpr_ops.prod_constr_expr unbounded_eq args in let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type nb_args relation = try pre_hook [fconst] (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation ); derive_inversion [fname] with e when CErrors.noncritical e -> (* No proof done *) () in Recdef.recursive_definition is_mes fname rec_impls type_of_f wf_rel_expr rec_arg_num eq hook using_lemmas let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body = let wf_arg_type,wf_arg = match wf_arg with | None -> begin match args with | [Constrexpr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x | _ -> error "Recursive argument must be specified" end | Some wf_args -> try match List.find (function | Constrexpr.LocalRawAssum(l,k,t) -> List.exists (function (_,Name id) -> Id.equal id wf_args | _ -> false) l | _ -> false ) args with | Constrexpr.LocalRawAssum(_,k,t) -> t,wf_args | _ -> assert false with Not_found -> assert false in let wf_rel_from_mes,is_mes = match wf_rel_expr_opt with | None -> let ltof = let make_dir l = DirPath.make (List.rev_map Id.of_string l) in Libnames.Qualid (Loc.ghost,Libnames.qualid_of_path (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof"))) in let fun_from_mes = let applied_mes = Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in Constrexpr_ops.mkLambdaC ([(Loc.ghost,Name wf_arg)],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) in let wf_rel_from_mes = Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) in wf_rel_from_mes,true | Some wf_rel_expr -> let wf_rel_with_mes = let a = Names.Id.of_string "___a" in let b = Names.Id.of_string "___b" in Constrexpr_ops.mkLambdaC( [Loc.ghost,Name a;Loc.ghost,Name b], Constrexpr.Default Explicit, wf_arg_type, Constrexpr_ops.mkAppC(wf_rel_expr, [ Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]); Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b]) ]) ) in wf_rel_with_mes,false in register_wf ~is_mes:is_mes fname rec_impls wf_rel_from_mes (Some wf_arg) using_lemmas args ret_type body let map_option f = function | None -> None | Some v -> Some (f v) open Constrexpr open Topconstr let make_assoc assoc l1 l2 = let fold assoc a b = match a, b with | (_, Name na), (_, Name id) -> Id.Map.add na id assoc | _, _ -> assoc in List.fold_left2 fold assoc l1 l2 let rec rebuild_bl (aux,assoc) bl typ = match bl,typ with | [], _ -> (List.rev aux,replace_vars_constr_expr assoc typ,assoc) | (Constrexpr.LocalRawAssum(nal,bk,_))::bl',typ -> rebuild_nal (aux,assoc) bk bl' nal (List.length nal) typ | (Constrexpr.LocalRawDef(na,_))::bl',Constrexpr.CLetIn(_,_,nat,typ') -> rebuild_bl ((Constrexpr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc) bl' typ' | _ -> assert false and rebuild_nal (aux,assoc) bk bl' nal lnal typ = match nal,typ with | [], _ -> rebuild_bl (aux,assoc) bl' typ | _,CProdN(_,[],typ) -> rebuild_nal (aux,assoc) bk bl' nal lnal typ | _,CProdN(_,(nal',bk',nal't)::rest,typ') -> let lnal' = List.length nal' in if lnal' >= lnal then let old_nal',new_nal' = List.chop lnal nal' in let nassoc = make_assoc assoc old_nal' nal in let assum = LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't) in rebuild_bl ((assum :: aux), nassoc) bl' (if List.is_empty new_nal' && List.is_empty rest then typ' else if List.is_empty new_nal' then CProdN(Loc.ghost,rest,typ') else CProdN(Loc.ghost,((new_nal',bk',nal't)::rest),typ')) else let captured_nal,non_captured_nal = List.chop lnal' nal in let nassoc = make_assoc assoc nal' captured_nal in let assum = LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't) in rebuild_nal ((assum :: aux), nassoc) bk bl' non_captured_nal (lnal - lnal') (CProdN(Loc.ghost,rest,typ')) | _ -> assert false let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in let ((_,_,typel),_,ctx,_) = Command.interp_fixpoint fixl ntns in let constr_expr_typel = with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx))) typel in let fixpoint_exprl_with_new_bl = List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> let new_bl',new_ret_type,_ = rebuild_bl ([],Id.Map.empty) bl fix_typ in (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixpoint_exprl constr_expr_typel in fixpoint_exprl_with_new_bl let do_generate_principle pconstants on_error register_built interactive_proof (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) :unit = List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; let _is_struct = match fixpoint_exprl with | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> let (((((_,name),pl),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) pconstants on_error true register_built fixpoint_exprl recdefs true in if register_built then register_wf name rec_impls wf_rel (map_option snd wf_x) using_lemmas args types body pre_hook; false |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> let (((((_,name),_),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) pconstants on_error true register_built fixpoint_exprl recdefs true in if register_built then register_mes name rec_impls wf_mes wf_rel_opt (map_option snd wf_x) using_lemmas args types body pre_hook; true | _ -> List.iter (function ((_na,(_,ord),_args,_body,_type),_not) -> match ord with | Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _ -> error ("Cannot use mutual definition with well-founded recursion or measure") | _ -> () ) fixpoint_exprl; let fixpoint_exprl = recompute_binder_list fixpoint_exprl in let fix_names = List.map (function ((((_,name),_),_,_,_,_),_) -> name) fixpoint_exprl in (* ok all the expressions are structural *) let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in let evd,pconstants = if register_built then register_struct is_rec fixpoint_exprl else (Evd.from_env (Global.env ()),pconstants) in let evd = ref evd in generate_principle (ref !evd) pconstants on_error false register_built fixpoint_exprl recdefs interactive_proof (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); if register_built then begin derive_inversion fix_names; end; true; in () let rec add_args id new_args b = match b with | CRef (r,_) -> begin match r with | Libnames.Ident(loc,fname) when Id.equal fname id -> CAppExpl(Loc.ghost,(None,r,None),new_args) | _ -> b end | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo") | CProdN(loc,nal,b1) -> CProdN(loc, List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, add_args id new_args b1) | CLambdaN(loc,nal,b1) -> CLambdaN(loc, List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, add_args id new_args b1) | CLetIn(loc,na,b1,b2) -> CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2) | CAppExpl(loc,(pf,r,us),exprl) -> begin match r with | Libnames.Ident(loc,fname) when Id.equal fname id -> CAppExpl(loc,(pf,r,us),new_args@(List.map (add_args id new_args) exprl)) | _ -> CAppExpl(loc,(pf,r,us),List.map (add_args id new_args) exprl) end | CApp(loc,(pf,b),bl) -> CApp(loc,(pf,add_args id new_args b), List.map (fun (e,o) -> add_args id new_args e,o) bl) | CCases(loc,sty,b_option,cel,cal) -> CCases(loc,sty,Option.map (add_args id new_args) b_option, List.map (fun (b,na,b_option) -> add_args id new_args b, na, b_option) cel, List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal ) | CLetTuple(loc,nal,(na,b_option),b1,b2) -> CLetTuple(loc,nal,(na,Option.map (add_args id new_args) b_option), add_args id new_args b1, add_args id new_args b2 ) | CIf(loc,b1,(na,b_option),b2,b3) -> CIf(loc,add_args id new_args b1, (na,Option.map (add_args id new_args) b_option), add_args id new_args b2, add_args id new_args b3 ) | CHole _ -> b | CPatVar _ -> b | CEvar _ -> b | CSort _ -> b | CCast(loc,b1,b2) -> CCast(loc,add_args id new_args b1, Miscops.map_cast_type (add_args id new_args) b2) | CRecord (loc, pars) -> CRecord (loc, List.map (fun (e,o) -> e, add_args id new_args o) pars) | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation") | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization") | CPrim _ -> b | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters") exception Stop of Constrexpr.constr_expr (* [chop_n_arrow n t] chops the [n] first arrows in [t] Acts on Constrexpr.constr_expr *) let rec chop_n_arrow n t = if n <= 0 then t (* If we have already removed all the arrows then return the type *) else (* If not we check the form of [t] *) match t with | Constrexpr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : either we need to discard more than the number of arrows contained in this product declaration then we just recall [chop_n_arrow] on the remaining number of arrow to chop and [t'] we discard it and recall [chop_n_arrow], either this product contains more arrows than the number we need to chop and then we return the new type *) begin try let new_n = let rec aux (n:int) = function [] -> n | (nal,k,t'')::nal_ta' -> let nal_l = List.length nal in if n >= nal_l then aux (n - nal_l) nal_ta' else let new_t' = Constrexpr.CProdN(Loc.ghost, ((snd (List.chop n nal)),k,t'')::nal_ta',t') in raise (Stop new_t') in aux n nal_ta' in chop_n_arrow new_n t' with Stop t -> t end | _ -> anomaly (Pp.str "Not enough products") let rec get_args b t : Constrexpr.local_binder list * Constrexpr.constr_expr * Constrexpr.constr_expr = match b with | Constrexpr.CLambdaN (loc, (nal_ta), b') -> begin let n = (List.fold_left (fun n (nal,_,_) -> n+List.length nal) 0 nal_ta ) in let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in (List.map (fun (nal,k,ta) -> (Constrexpr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' end | _ -> [],b,t let make_graph (f_ref:global_reference) = let c,c_body = match f_ref with | ConstRef c -> begin try c,Global.lookup_constant c with Not_found -> raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) end | _ -> raise (UserError ("", str "Not a function reference") ) in (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom !" | Some body -> let env = Global.env () in let sigma = Evd.from_env env in let extern_body,extern_type = with_full_print (fun () -> (Constrextern.extern_constr false env sigma body, Constrextern.extern_type false env sigma ((*FIXME*) Typeops.type_of_constant_type env c_body.const_type) ) ) () in let (nal_tas,b,t) = get_args extern_body extern_type in let expr_list = match b with | Constrexpr.CFix(loc,l_id,fixexprl) -> let l = List.map (fun (id,(n,recexp),bl,t,b) -> let loc, rec_id = Option.get n in let new_args = List.flatten (List.map (function | Constrexpr.LocalRawDef (na,_)-> [] | Constrexpr.LocalRawAssum (nal,_,_) -> List.map (fun (loc,n) -> CRef(Libnames.Ident(loc, Nameops.out_name n),None)) nal | Constrexpr.LocalPattern _ -> assert false ) nal_tas ) in let b' = add_args (snd id) new_args b in ((((id,None), ( Some (Loc.ghost,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixexprl in l | _ -> let id = Label.to_id (con_label c) in [(((Loc.ghost,id),None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] in let mp,dp,_ = repr_con c in do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list; (* We register the infos *) List.iter (fun ((((_,id),_),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id))) expr_list) let do_generate_principle = do_generate_principle [] warning_error true coq-8.6/plugins/funind/glob_term_to_relation.mli0000644000175000017500000000114513022274260021500 0ustar mdenesmdenesopen Names (* [build_inductive parametrize funnames funargs returned_types bodies] constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments and returning [returned_types] using bodies [bodies] *) val build_inductive : (* (ModPath.t * DirPath.t) option -> Id.t list -> (* The list of function name *) *) Evd.evar_map -> Term.pconstant list -> (Name.t*Glob_term.glob_constr*bool) list list -> (* The list of function args *) Constrexpr.constr_expr list -> (* The list of function returned type *) Glob_term.glob_constr list -> (* the list of body *) unit coq-8.6/plugins/funind/glob_term_to_relation.ml0000644000175000017500000014112313022274260021330 0ustar mdenesmdenesopen Printer open Pp open Names open Term open Vars open Glob_term open Glob_ops open Globnames open Indfun_common open CErrors open Util open Glob_termops open Misctypes let observe strm = if do_observe () then Feedback.msg_debug strm else () (*let observennl strm = if do_observe () then Pp.msg strm else ()*) type binder_type = | Lambda of Name.t | Prod of Name.t | LetIn of Name.t type glob_context = (binder_type*glob_constr) list (* compose_glob_context [(bt_1,n_1,t_1);......] rt returns b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the binders corresponding to the bt_i's *) let compose_glob_context = let compose_binder (bt,t) acc = match bt with | Lambda n -> mkGLambda(n,t,acc) | Prod n -> mkGProd(n,t,acc) | LetIn n -> mkGLetIn(n,t,acc) in List.fold_right compose_binder (* The main part deals with building a list of globalized constructor expressions from the rhs of a fixpoint equation. *) type 'a build_entry_pre_return = { context : glob_context; (* the binding context of the result *) value : 'a; (* The value *) } type 'a build_entry_return = { result : 'a build_entry_pre_return list; to_avoid : Id.t list } (* [combine_results combine_fun res1 res2] combine two results [res1] and [res2] w.r.t. [combine_fun]. Informally, both [res1] and [res2] are lists of "constructors" [res1_1;...] and [res2_1,....] and we need to produce [combine_fun res1_1 res2_1;combine_fun res1_1 res2_2;........] *) let combine_results (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> 'c build_entry_pre_return ) (res1: 'a build_entry_return) (res2 : 'b build_entry_return) : 'c build_entry_return = let pre_result = List.map ( fun res1 -> (* for each result in arg_res *) List.map (* we add it in each args_res *) (fun res2 -> combine_fun res1 res2 ) res2.result ) res1.result in (* and then we flatten the map *) { result = List.concat pre_result; to_avoid = List.union Id.equal res1.to_avoid res2.to_avoid } (* The combination function for an argument with a list of argument *) let combine_args arg args = { context = arg.context@args.context; (* Note that the binding context of [arg] MUST be placed before the one of [args] in order to preserve possible type dependencies *) value = arg.value::args.value; } let ids_of_binder = function | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> [] | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id] let rec change_vars_in_binder mapping = function [] -> [] | (bt,t)::l -> let new_mapping = List.fold_right Id.Map.remove (ids_of_binder bt) mapping in (bt,change_vars mapping t):: (if Id.Map.is_empty new_mapping then l else change_vars_in_binder new_mapping l ) let rec replace_var_by_term_in_binder x_id term = function | [] -> [] | (bt,t)::l -> (bt,replace_var_by_term x_id term t):: if Id.List.mem x_id (ids_of_binder bt) then l else replace_var_by_term_in_binder x_id term l let add_bt_names bt = List.append (ids_of_binder bt) let apply_args ctxt body args = let need_convert_id avoid id = List.exists (is_free_in id) args || Id.List.mem id avoid in let need_convert avoid bt = List.exists (need_convert_id avoid) (ids_of_binder bt) in let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.t list) = match na with | Name id when Id.List.mem id avoid -> let new_id = Namegen.next_ident_away id avoid in Name new_id,Id.Map.add id new_id mapping,new_id::avoid | _ -> na,mapping,avoid in let next_bt_away bt (avoid:Id.t list) = match bt with | LetIn na -> let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in LetIn new_na,mapping,new_avoid | Prod na -> let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in Prod new_na,mapping,new_avoid | Lambda na -> let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in Lambda new_na,mapping,new_avoid in let rec do_apply avoid ctxt body args = match ctxt,args with | _,[] -> (* No more args *) (ctxt,body) | [],_ -> (* no more fun *) let f,args' = glob_decompose_app body in (ctxt,mkGApp(f,args'@args)) | (Lambda Anonymous,t)::ctxt',arg::args' -> do_apply avoid ctxt' body args' | (Lambda (Name id),t)::ctxt',arg::args' -> let new_avoid,new_ctxt',new_body,new_id = if need_convert_id avoid id then let new_avoid = id::avoid in let new_id = Namegen.next_ident_away id new_avoid in let new_avoid' = new_id :: new_avoid in let mapping = Id.Map.add id new_id Id.Map.empty in let new_ctxt' = change_vars_in_binder mapping ctxt' in let new_body = change_vars mapping body in new_avoid',new_ctxt',new_body,new_id else id::avoid,ctxt',body,id in let new_body = replace_var_by_term new_id arg new_body in let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in do_apply avoid new_ctxt' new_body args' | (bt,t)::ctxt',_ -> let new_avoid,new_ctxt',new_body,new_bt = let new_avoid = add_bt_names bt avoid in if need_convert avoid bt then let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in ( new_avoid, change_vars_in_binder mapping ctxt', change_vars mapping body, new_bt ) else new_avoid,ctxt',body,bt in let new_ctxt',new_body = do_apply new_avoid new_ctxt' new_body args in (new_bt,t)::new_ctxt',new_body in do_apply [] ctxt body args let combine_app f args = let new_ctxt,new_value = apply_args f.context f.value args.value in { (* Note that the binding context of [args] MUST be placed before the one of the applied value in order to preserve possible type dependencies *) context = args.context@new_ctxt; value = new_value; } let combine_lam n t b = { context = []; value = mkGLambda(n, compose_glob_context t.context t.value, compose_glob_context b.context b.value ) } let combine_prod n t b = { context = t.context@((Prod n,t.value)::b.context); value = b.value} let combine_letin n t b = { context = t.context@((LetIn n,t.value)::b.context); value = b.value} let mk_result ctxt value avoid = { result = [{context = ctxt; value = value}] ; to_avoid = avoid } (************************************************* Some functions to deal with overlapping patterns **************************************************) let coq_True_ref = lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True") let coq_False_ref = lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False") (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with (the list of expressions on which we will do the matching) *) let make_discr_match_el = List.map (fun e -> (e,(Anonymous,None))) (* [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. that is. match ?????? with \\ | pat_1 => False \\ | pat_{i-1} => False \\ | pat_i => True \\ | pat_{i+1} => False \\ \vdots | pat_n => False end *) let make_discr_match_brl i = List.map_i (fun j (_,idl,patl,_) -> if Int.equal j i then (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_True_ref)) else (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_False_ref)) ) 0 (* [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff brl_{i} is the first branch matched by [el] Used when we want to simulate the coq pattern matching algorithm *) let make_discr_match brl = fun el i -> mkGCases(None, make_discr_match_el el, make_discr_match_brl i brl) (**********************************************************************) (* functions used to build case expression from lettuple and if ones *) (**********************************************************************) (* [build_constructors_of_type] construct the array of pattern of its inductive argument*) let build_constructors_of_type ind' argl = let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in let npar = mib.Declarations.mind_nparams in Array.mapi (fun i _ -> let construct = ind',i+1 in let constructref = ConstructRef(construct) in let _implicit_positions_of_cst = Impargs.implicits_of_global constructref in let cst_narg = Inductiveops.constructor_nallargs_env (Global.env ()) construct in let argl = if List.is_empty argl then Array.to_list (Array.init (cst_narg - npar) (fun _ -> mkGHole ()) ) else argl in let pat_as_term = mkGApp(mkGRef (ConstructRef(ind',i+1)),argl) in cases_pattern_of_glob_constr Anonymous pat_as_term ) ind.Declarations.mind_consnames (******************) (* Main functions *) (******************) let raw_push_named (na,raw_value,raw_typ) env = match na with | Anonymous -> env | Name id -> let value = Option.map (fun x-> fst (Pretyping.understand env (Evd.from_env env) x)) raw_value in let typ,ctx = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in let open Context.Named.Declaration in Environ.push_named (of_tuple (id,value,typ)) env let add_pat_variables pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = let open Context.Rel.Declaration in observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); match pat with | PatVar(_,na) -> Environ.push_rel (LocalAssum (na,typ)) env | PatCstr(_,c,patl,na) -> let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env (Evd.from_env env) typ with Not_found -> assert false in 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)) (Array.to_list constructors) in let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in let new_env = add_pat_variables env pat typ in let res = fst ( Context.Rel.fold_outside (fun decl (env,ctxt) -> let _,v,t = Context.Rel.Declaration.to_tuple decl in match Context.Rel.Declaration.get_name decl with | Anonymous -> assert false | Name id -> let new_t = substl ctxt t in let new_v = Option.map (substl ctxt) v in observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++ Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) ); let open Context.Named.Declaration in (Environ.push_named (of_tuple (id,new_v,new_t)) env,mkVar id::ctxt) ) (Environ.rel_context new_env) ~init:(env,[]) ) in observe (str "new var env := " ++ Printer.pr_named_context_of res (Evd.from_env env)); res let rec pattern_to_term_and_type env typ = function | PatVar(loc,Anonymous) -> assert false | PatVar(loc,Name id) -> mkGVar id | PatCstr(loc,constr,patternl,_) -> let cst_narg = Inductiveops.constructor_nallargs_env (Global.env ()) constr in let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env (Evd.from_env env) typ with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in let open Context.Rel.Declaration in let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in let _,cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in let implicit_args = Array.to_list (Array.init (cst_narg - List.length patternl) (fun i -> Detyping.detype false [] env (Evd.from_env env) csta.(i)) ) in let patl_as_term = List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl in mkGApp(mkGRef(ConstructRef constr), implicit_args@patl_as_term ) (* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the corresponding graphs. The idea to transform a term [t] into a list of constructors [lc] is the following: \begin{itemize} \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding to [body] and add (bind x. _) to each elements of [lc] \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], [g c1 ... cn] is an element of [lc] \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn] create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc] \item if the term is a cast just treat its body part \item if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case and concatenate them (informally, each branch of a match produces a new constructor) \end{itemize} WARNING: The terms constructed here are only USING the glob_constr syntax but are highly bad formed. We must wait to have complete all the current calculi to set the recursive calls. At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. We in fact not create a constructor list since then end of each constructor has not the expected form but only the value of the function *) let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = observe (str " Entering : " ++ Printer.pr_glob_constr rt); match rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> (* do nothing (except changing type of course) *) mk_result [] rt avoid | GApp(_,_,_) -> let f,args = glob_decompose_app rt in let args_res : (glob_constr list) build_entry_return = List.fold_right (* create the arguments lists of constructors and combine them *) (fun arg ctxt_argsl -> let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in combine_results combine_args arg_res ctxt_argsl ) args (mk_result [] [] avoid) in begin match f with | GLambda _ -> let rec aux t l = match l with | [] -> t | u::l -> match t with | GLambda(loc,na,_,nat,b) -> GLetIn(Loc.ghost,na,u,aux b l) | _ -> GApp(Loc.ghost,t,l) in build_entry_lc env funnames avoid (aux f args) | GVar(_,id) when Id.Set.mem id funnames -> (* if we have [f t1 ... tn] with [f]$\in$[fnames] then we create a fresh variable [res], add [res] and its "value" (i.e. [res v1 ... vn]) to each pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and a pseudo value "v1 ... vn". The "value" of this branch is then simply [res] *) let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) rt_as_constr in let res_raw_type = Detyping.detype false [] env (Evd.from_env env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in let new_avoid = res::args_res.to_avoid in let res_rt = mkGVar res in let new_result = List.map (fun arg_res -> let new_hyps = [Prod (Name res),res_raw_type; Prod Anonymous,mkGApp(res_rt,(mkGVar id)::arg_res.value)] in {context = arg_res.context@new_hyps; value = res_rt } ) args_res.result in { result = new_result; to_avoid = new_avoid } | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ -> (* if have [g t1 ... tn] with [g] not appearing in [funnames] then foreach [ctxt,v1 ... vn] in [args_res] we return [ctxt, g v1 .... vn] *) { args_res with result = List.map (fun args_res -> {args_res with value = mkGApp(f,args_res.value)}) args_res.result } | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *) | GLetIn(_,n,t,b) -> (* if we have [(let x := v in b) t1 ... tn] , we discard our work and compute the list of constructor for [let x = v in (b t1 ... tn)] up to alpha conversion *) let new_n,new_b,new_avoid = match n with | Name id when List.exists (is_free_in id) args -> (* need to alpha-convert the name *) let new_id = Namegen.next_ident_away id avoid in let new_avoid = id:: avoid in let new_b = replace_var_by_term id (GVar(Loc.ghost,id)) b in (Name new_id,new_b,new_avoid) | _ -> n,b,avoid in build_entry_lc env funnames avoid (mkGLetIn(new_n,t,mkGApp(new_b,args))) | GCases _ | GIf _ | GLetTuple _ -> (* we have [(match e1, ...., en with ..... end) t1 tn] we first compute the result from the case and then combine each of them with each of args one *) let f_res = build_entry_lc env funnames args_res.to_avoid f in combine_results combine_app f_res args_res | GCast(_,b,_) -> (* for an applied cast we just trash the cast part and restart the work. WARNING: We need to restart since [b] itself should be an application term *) build_entry_lc env funnames avoid (mkGApp(b,args)) | GRec _ -> error "Not handled GRec" | GProd _ -> error "Cannot apply a type" end (* end of the application treatement *) | GLambda(_,n,_,t,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the type and combine the two result *) let t_res = build_entry_lc env funnames avoid t in let new_n = match n with | Name _ -> n | Anonymous -> Name (Indfun_common.fresh_id [] "_x") in let new_env = raw_push_named (new_n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_lam new_n) t_res b_res | GProd(_,n,_,t,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the type and combine the two result *) let t_res = build_entry_lc env funnames avoid t in let new_env = raw_push_named (n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_prod n) t_res b_res | GLetIn(_,n,v,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the value [t] and combine the two result *) let v_res = build_entry_lc env funnames avoid v in let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in let new_env = let open Context.Named.Declaration in match n with Anonymous -> env | Name id -> Environ.push_named (of_tuple (id,Some v_as_constr,v_type)) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_letin n) v_res b_res | GCases(_,_,_,el,brl) -> (* we create the discrimination function and treat the case itself *) let make_discr = make_discr_match brl in build_entry_lc_from_case env funnames make_discr el brl avoid | GIf(_,b,(na,e_option),lhs,rhs) -> let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> errorlabstrm "" (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in let case_pats = build_constructors_of_type (fst ind) [] in assert (Int.equal (Array.length case_pats) 2); let brl = List.map_i (fun i x -> (Loc.ghost,[],[case_pats.(i)],x)) 0 [lhs;rhs] in let match_expr = mkGCases(None,[(b,(Anonymous,None))],brl) in (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) build_entry_lc env funnames avoid match_expr | GLetTuple(_,nal,_,b,e) -> begin let nal_as_glob_constr = List.map (function Name id -> mkGVar id | Anonymous -> mkGHole () ) nal in let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> errorlabstrm "" (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in assert (Int.equal (Array.length case_pats) 1); let br = (Loc.ghost,[],[case_pats.(0)],e) in let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in build_entry_lc env funnames avoid match_expr end | GRec _ -> error "Not handled GRec" | GCast(_,b,_) -> build_entry_lc env funnames avoid b and build_entry_lc_from_case env funname make_discr (el:tomatch_tuples) (brl:Glob_term.cases_clauses) avoid : glob_constr build_entry_return = match el with | [] -> assert false (* this case correspond to match with .... !*) | el -> (* this case correspond to match el with brl end we first compute the list of lists corresponding to [el] and combine them . Then for each element of the combinations, we compute the result we compute one list per branch in [brl] and finally we just concatenate those list *) let case_resl = List.fold_right (fun (case_arg,_) ctxt_argsl -> let arg_res = build_entry_lc env funname ctxt_argsl.to_avoid case_arg in combine_results combine_args arg_res ctxt_argsl ) el (mk_result [] [] avoid) in let types = List.map (fun (case_arg,_) -> let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in Typing.unsafe_type_of env (Evd.from_env env) case_arg_as_constr ) el in (****** The next works only if the match is not dependent ****) let results = List.map (fun ca -> let res = build_entry_lc_from_case_term env types funname (make_discr) [] brl case_resl.to_avoid ca in res ) case_resl.result in { result = List.concat (List.map (fun r -> r.result) results); to_avoid = List.fold_left (fun acc r -> List.union Id.equal acc r.to_avoid) [] results } and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid matched_expr = match brl with | [] -> (* computed_branches *) {result = [];to_avoid = avoid} | br::brl' -> (* alpha conversion to prevent name clashes *) let _,idl,patl,return = alpha_br avoid br in let new_avoid = idl@avoid in (* for now we can no more use idl as an identifier *) (* building a list of precondition stating that we are not in this branch (will be used in the following recursive calls) *) let new_env = List.fold_right2 add_pat_variables patl types env in let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = List.map2 (fun pat typ -> fun avoid pat'_as_term -> let renamed_pat,_,_ = alpha_pat avoid pat in let pat_ids = get_pattern_id renamed_pat in let env_with_pat_ids = add_pat_variables pat typ new_env in List.fold_right (fun id acc -> let typ_of_id = Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (mkVar id) in let raw_typ_of_id = Detyping.detype false [] env_with_pat_ids (Evd.from_env env) typ_of_id in mkGProd (Name id,raw_typ_of_id,acc)) pat_ids (glob_make_neq pat'_as_term (pattern_to_term renamed_pat)) ) patl types in (* Checking if we can be in this branch (will be used in the following recursive calls) *) let unify_with_those_patterns : (cases_pattern -> bool*bool) list = List.map (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') patl in (* we first compute the other branch result (in ordrer to keep the order of the matching as much as possible) *) let brl'_res = build_entry_lc_from_case_term env types funname make_discr ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) brl' avoid matched_expr in (* We now create the precondition of this branch i.e. 1- the list of variable appearing in the different patterns of this branch and the list of equation stating than el = patl (List.flatten ...) 2- If there exists a previous branch which pattern unify with the one of this branch then a discrimination precond stating that we are not in a previous branch (if List.exists ...) *) let those_pattern_preconds = (List.flatten ( List.map3 (fun pat e typ_as_constr -> let this_pat_ids = ids_of_pat pat in let typ = Detyping.detype false [] new_env (Evd.from_env env) typ_as_constr in let pat_as_term = pattern_to_term pat in List.fold_right (fun id acc -> if Id.Set.mem id this_pat_ids then (Prod (Name id), let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (mkVar id) in let raw_typ_of_id = Detyping.detype false [] new_env (Evd.from_env env) typ_of_id in raw_typ_of_id )::acc else acc ) idl [(Prod Anonymous,glob_make_eq ~typ pat_as_term e)] ) patl matched_expr.value types ) ) @ (if List.exists (function (unifl,_) -> let (unif,_) = List.split (List.map2 (fun x y -> x y) unifl patl) in List.for_all (fun x -> x) unif) patterns_to_prevent then let i = List.length patterns_to_prevent in let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in [(Prod Anonymous,make_discr pats_as_constr i )] else [] ) in (* We compute the result of the value returned by the branch*) let return_res = build_entry_lc new_env funname new_avoid return in (* and combine it with the preconds computed for this branch *) let this_branch_res = List.map (fun res -> { context = matched_expr.context@those_pattern_preconds@res.context ; value = res.value} ) return_res.result in { brl'_res with result = this_branch_res@brl'_res.result } let is_res id = try String.equal (String.sub (Id.to_string id) 0 4) "_res" with Invalid_argument _ -> false let same_raw_term rt1 rt2 = match rt1,rt2 with | GRef(_,r1,_), GRef (_,r2,_) -> Globnames.eq_gr r1 r2 | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = let rec decompose_raw_eq lhs rhs acc = observe (str "decomposing eq for " ++ pr_glob_constr lhs ++ str " " ++ pr_glob_constr rhs); let (rhd,lrhs) = glob_decompose_app rhs in let (lhd,llhs) = glob_decompose_app lhs in observe (str "lhd := " ++ pr_glob_constr lhd); observe (str "rhd := " ++ pr_glob_constr rhd); observe (str "llhs := " ++ int (List.length llhs)); observe (str "lrhs := " ++ int (List.length lrhs)); let sllhs = List.length llhs in let slrhs = List.length lrhs in if same_raw_term lhd rhd && Int.equal sllhs slrhs then (* let _ = assert false in *) List.fold_right2 decompose_raw_eq llhs lrhs acc else (lhs,rhs)::acc in decompose_raw_eq lhs rhs [] exception Continue (* The second phase which reconstruct the real type of the constructor. rebuild the globalized constructors expression. eliminates some meaningless equalities, applies some rewrites...... *) let rec rebuild_cons env nb_args relname args crossed_types depth rt = observe (str "rebuilding : " ++ pr_glob_constr rt); let open Context.Rel.Declaration in match rt with | GProd(_,n,k,t,b) -> let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t::crossed_types in begin match t with | GApp(_,(GVar(_,res_id) as res_rt),args') when is_res res_id -> begin match args' with | (GVar(_,this_relname))::args' -> (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) let new_t = mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) in let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) b in mkGProd(n,new_t,new_b), Id.Set.filter not_free_in_t id_to_exclude | _ -> (* the first args is the name of the function! *) assert false end | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;GVar(loc3,id);rt]) when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin try observe (str "computing new type for eq : " ++ pr_glob_constr rt); let t' = try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*) with e when CErrors.noncritical e -> raise Continue in let is_in_b = is_free_in id b in let _keep_eq = not (List.exists (is_free_in id) args) || is_in_b || List.exists (is_free_in id) crossed_types in let new_args = List.map (replace_var_by_term id rt) args in let subst_b = if is_in_b then b else replace_var_by_term id rt b in let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname new_args new_crossed_types (depth + 1) subst_b in mkGProd(n,t,new_b),id_to_exclude with Continue -> let jmeq = Globnames.IndRef (fst (destInd (jmeq ()))) in let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in let ind,args' = Inductive.find_inductive env ty' in let mib,_ = Global.lookup_inductive (fst ind) in let nparam = mib.Declarations.mind_nparams in let params,arg' = ((Util.List.chop nparam args')) in let rt_typ = GApp(Loc.ghost, GRef (Loc.ghost,Globnames.IndRef (fst ind),None), (List.map (fun p -> Detyping.detype false [] env (Evd.from_env env) p) params)@(Array.to_list (Array.make (List.length args' - nparam) (mkGHole ())))) in let eq' = GApp(loc1,GRef(loc2,jmeq,None),[ty;GVar(loc3,id);rt_typ;rt]) in observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in observe (str " computing new type for jmeq : done") ; let new_args = match kind_of_term eq'_as_constr with | App(_,[|_;_;ty;_|]) -> let ty = Array.to_list (snd (destApp ty)) in let ty' = snd (Util.List.chop nparam ty) in List.fold_left2 (fun acc var_as_constr arg -> if isRel var_as_constr then let open Context.Rel.Declaration in let na = get_name (Environ.lookup_rel (destRel var_as_constr) env) in match na with | Anonymous -> acc | Name id' -> (id',Detyping.detype false [] env (Evd.from_env env) arg)::acc else if isVar var_as_constr then (destVar var_as_constr,Detyping.detype false [] env (Evd.from_env env) arg)::acc else acc ) [] arg' ty' | _ -> assert false in let is_in_b = is_free_in id b in let _keep_eq = not (List.exists (is_free_in id) args) || is_in_b || List.exists (is_free_in id) crossed_types in let new_args = List.fold_left (fun args (id,rt) -> List.map (replace_var_by_term id rt) args ) args ((id,rt)::new_args) in let subst_b = if is_in_b then b else replace_var_by_term id rt b in let new_env = let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname new_args new_crossed_types (depth + 1) subst_b in mkGProd(n,eq',new_b),id_to_exclude end (* J.F:. keep this comment it explain how to remove some meaningless equalities if keep_eq then mkGProd(n,t,new_b),id_to_exclude else new_b, Id.Set.add id id_to_exclude *) | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;rt1;rt2]) when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin try let l = decompose_raw_eq rt1 rt2 in if List.length l > 1 then let new_rt = List.fold_left (fun acc (lhs,rhs) -> mkGProd(Anonymous, mkGApp(mkGRef(eq_as_ref),[mkGHole ();lhs;rhs]),acc) ) b l in rebuild_cons env nb_args relname args crossed_types depth new_rt else raise Continue with Continue -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) b in match n with | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude end | _ -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) b in match n with | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude end | GLambda(_,n,k,t,b) -> begin let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in observe (str "computing new type for lambda : " ++ pr_glob_constr rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in match n with | Name id -> let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname (args@[mkGVar id])new_crossed_types (depth + 1 ) b in if Id.Set.mem id id_to_exclude && depth >= nb_args then new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) else GProd(Loc.ghost,n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude | _ -> anomaly (Pp.str "Should not have an anonymous function here") (* We have renamed all the anonymous functions during alpha_renaming phase *) end | GLetIn(_,n,t,b) -> begin let not_free_in_t id = not (is_free_in id t) in let evd = (Evd.from_env env) in let t',ctx = Pretyping.understand env evd t in let evd = Evd.from_ctx ctx in let type_t' = Typing.unsafe_type_of env evd t' in let new_env = Environ.push_rel (LocalDef (n,t',type_t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args (t::crossed_types) (depth + 1 ) b in match n with | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) | _ -> GLetIn(Loc.ghost,n,t,new_b), Id.Set.filter not_free_in_t id_to_exclude end | GLetTuple(_,nal,(na,rto),t,b) -> assert (Option.is_empty rto); begin let not_free_in_t id = not (is_free_in id t) in let new_t,id_to_exclude' = rebuild_cons env nb_args relname args (crossed_types) depth t in let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in let new_env = Environ.push_rel (LocalAssum (na,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args (t::crossed_types) (depth + 1) b in (* match n with *) (* | Name id when Id.Set.mem id id_to_exclude -> *) (* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) (* | _ -> *) GLetTuple(Loc.ghost,nal,(na,None),t,new_b), Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') end | _ -> mkGApp(mkGVar relname,args@[rt]),Id.Set.empty (* debugging wrapper *) let rebuild_cons env nb_args relname args crossed_types rt = (* observennl (str "rebuild_cons : rt := "++ pr_glob_constr rt ++ *) (* str "nb_args := " ++ str (string_of_int nb_args)); *) let res = rebuild_cons env nb_args relname args crossed_types 0 rt in (* observe (str " leads to "++ pr_glob_constr (fst res)); *) res (* naive implementation of parameter detection. A parameter is an argument which is only preceded by parameters and whose calls are all syntactically equal. TODO: Find a valid way to deal with implicit arguments here! *) let rec compute_cst_params relnames params = function | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params | GApp(_,GVar(_,relname'),rtl) when Id.Set.mem relname' relnames -> compute_cst_params_from_app [] (params,rtl) | GApp(_,f,args) -> List.fold_left (compute_cst_params relnames) params (f::args) | GLambda(_,_,_,t,b) | GProd(_,_,_,t,b) | GLetIn(_,_,t,b) | GLetTuple(_,_,_,t,b) -> let t_params = compute_cst_params relnames params t in compute_cst_params relnames t_params b | GCases _ -> params (* If there is still cases at this point they can only be discrimination ones *) | GSort _ -> params | GHole _ -> params | GIf _ | GRec _ | GCast _ -> raise (UserError("compute_cst_params", str "Not handled case")) and compute_cst_params_from_app acc (params,rtl) = match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) | ((Name id,_,is_defined) as param)::params',(GVar(_,id'))::rtl' when Id.compare id id' == 0 && not is_defined -> compute_cst_params_from_app (param::acc) (params',rtl') | _ -> List.rev acc let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool) list array) csts = let rels_params = Array.mapi (fun i args -> List.fold_left (fun params (_,cst) -> compute_cst_params relnames params cst) args csts.(i) ) args in let l = ref [] in let _ = try List.iteri (fun i ((n,nt,is_defined) as param) -> if Array.for_all (fun l -> let (n',nt',is_defined') = List.nth l i in Name.equal n n' && glob_constr_eq nt nt' && (is_defined : bool) == is_defined') rels_params then l := param::!l ) rels_params.(0) with e when CErrors.noncritical e -> () in List.rev !l let rec rebuild_return_type rt = match rt with | Constrexpr.CProdN(loc,n,t') -> Constrexpr.CProdN(loc,n,rebuild_return_type t') | Constrexpr.CLetIn(loc,na,t,t') -> Constrexpr.CLetIn(loc,na,t,rebuild_return_type t') | _ -> Constrexpr.CProdN(Loc.ghost,[[Loc.ghost,Anonymous], Constrexpr.Default Decl_kinds.Explicit,rt], Constrexpr.CSort(Loc.ghost,GType [])) let do_build_inductive evd (funconstants: Term.pconstant list) (funsargs: (Name.t * glob_constr * bool) list list) returned_types (rtl:glob_constr list) = let _time1 = System.get_time () in let funnames = List.map (fun c -> Label.to_id (KerName.label (Constant.canonical (fst c)))) funconstants in (* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *) let funnames_as_set = List.fold_right Id.Set.add funnames Id.Set.empty in let funnames = Array.of_list funnames in let funsargs = Array.of_list funsargs in let returned_types = Array.of_list returned_types in (* alpha_renaming of the body to prevent variable capture during manipulation *) let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in let rta = Array.of_list rtl_alpha in (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) let relnames = Array.map mk_rel_id funnames in let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in (* Construction of the pseudo constructors *) let open Context.Named.Declaration in let evd,env = Array.fold_right2 (fun id c (evd,env) -> let evd,t = Typing.type_of env evd (mkConstU c) in evd, Environ.push_named (LocalAssum (id,t)) (* try *) (* Typing.e_type_of env evd (mkConstU c) *) (* with Not_found -> *) (* raise (UserError("do_build_inductive", str "Cannot handle partial fixpoint")) *) env ) funnames (Array.of_list funconstants) (evd,Global.env ()) in let resa = Array.map (build_entry_lc env funnames_as_set []) rta in let env_with_graphs = let rel_arity i funargs = (* Rebuilding arities (with parameters) *) let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list = funargs in List.fold_right (fun (n,t,is_defined) acc -> if is_defined then Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, acc) else Constrexpr.CProdN (Loc.ghost, [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], acc ) ) rel_first_args (rebuild_return_type returned_types.(i)) in (* We need to lift back our work topconstr but only with all information We mimick a Set Printing All. Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in Util.Array.fold_left2 (fun env rel_name rel_ar -> Environ.push_named (LocalAssum (rel_name, fst (with_full_print (Constrintern.interp_constr env evd) rel_ar))) env) env relnames rel_arities in (* and of the real constructors*) let constr i res = List.map (function result (* (args',concl') *) -> let rt = compose_glob_context result.context result.value in let nb_args = List.length funsargs.(i) in (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *) fst ( rebuild_cons env_with_graphs nb_args relnames.(i) [] [] rt ) ) res.result in (* adding names to constructors *) let next_constructor_id = ref (-1) in let mk_constructor_id i = incr next_constructor_id; (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) Id.of_string ((Id.to_string (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) in let rel_constructors i rt : (Id.t*glob_constr) list = next_constructor_id := (-1); List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) in let rel_constructors = Array.mapi rel_constructors resa in (* Computing the set of parameters if asked *) let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in let nrel_params = List.length rels_params in let rel_constructors = (* Taking into account the parameters in constructors *) Array.map (List.map (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) rel_constructors in let rel_arity i funargs = (* Reduilding arities (with parameters) *) let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list = (snd (List.chop nrel_params funargs)) in List.fold_right (fun (n,t,is_defined) acc -> if is_defined then Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, acc) else Constrexpr.CProdN (Loc.ghost, [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], acc ) ) rel_first_args (rebuild_return_type returned_types.(i)) in (* We need to lift back our work topconstr but only with all information We mimick a Set Printing All. Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in let rel_params_ids = List.fold_left (fun acc (na,_,_) -> match na with Anonymous -> acc | Name id -> id::acc ) [] rels_params in let rel_params = List.map (fun (n,t,is_defined) -> if is_defined then Constrexpr.LocalRawDef((Loc.ghost,n), Constrextern.extern_glob_constr Id.Set.empty t) else Constrexpr.LocalRawAssum ([(Loc.ghost,n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t) ) rels_params in let ext_rels_constructors = Array.map (List.map (fun (id,t) -> false,((Loc.ghost,id), with_full_print (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t)) ) )) (rel_constructors) in let rel_ind i ext_rel_constructors = (((Loc.ghost,relnames.(i)), None), rel_params, Some rel_arities.(i), ext_rel_constructors),[] in let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in let rel_inds = Array.to_list ext_rel_constructors in (* let _ = *) (* Pp.msgnl (\* observe *\) ( *) (* str "Inductive" ++ spc () ++ *) (* prlist_with_sep *) (* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) (* (function ((_,id),_,params,ar,constr) -> *) (* Ppconstr.pr_id id ++ spc () ++ *) (* Ppconstr.pr_binders params ++ spc () ++ *) (* str ":" ++ spc () ++ *) (* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) (* prlist_with_sep *) (* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) (* (function (_,((_,id),t)) -> *) (* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) (* Ppconstr.pr_lconstr_expr t) *) (* constr *) (* ) *) (* rel_inds *) (* ) *) (* in *) let _time2 = System.get_time () in try with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false)) Decl_kinds.Finite with | UserError(s,msg) as e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) let repacked_rel_inds = List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) rel_inds in let msg = str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds)) ++ fnl () ++ msg in observe (msg); raise e | reraise -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) let repacked_rel_inds = List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) rel_inds in let msg = str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds)) ++ fnl () ++ CErrors.print reraise in observe msg; raise reraise let build_inductive evd funconstants funsargs returned_types rtl = let pu = !Detyping.print_universes in let cu = !Constrextern.print_universes in try Detyping.print_universes := true; Constrextern.print_universes := true; do_build_inductive evd funconstants funsargs returned_types rtl; Detyping.print_universes := pu; Constrextern.print_universes := cu with e when CErrors.noncritical e -> Detyping.print_universes := pu; Constrextern.print_universes := cu; raise (Building_graph e) coq-8.6/plugins/funind/indfun_common.ml0000644000175000017500000003720313022274260017615 0ustar mdenesmdenesopen Names open Pp open Libnames open Globnames open Refiner let mk_prefix pre id = Id.of_string (pre^(Id.to_string id)) let mk_rel_id = mk_prefix "R_" let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" let mk_equation_id id = Nameops.add_suffix id "_equation" let msgnl m = () let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) avoid let fresh_name avoid s = Name (fresh_id avoid s) let get_name avoid ?(default="H") = function | Anonymous -> fresh_name avoid default | Name n -> Name n let array_get_start a = try Array.init (Array.length a - 1) (fun i -> a.(i)) with Invalid_argument "index out of bounds" -> invalid_arg "array_get_start" let id_of_name = function Name id -> id | _ -> raise Not_found let locate ref = let (loc,qid) = qualid_of_reference ref in Nametab.locate qid let locate_ind ref = match locate ref with | IndRef x -> x | _ -> raise Not_found let locate_constant ref = match locate ref with | ConstRef x -> x | _ -> raise Not_found let locate_with_msg msg f x = try f x with Not_found -> raise (CErrors.UserError("", msg)) let filter_map filter f = let rec it = function | [] -> [] | e::l -> if filter e then (f e) :: it l else it l in it let chop_rlambda_n = let rec chop_lambda_n acc n rt = if n == 0 then List.rev acc,rt else match rt with | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b | _ -> raise (CErrors.UserError("chop_rlambda_n", str "chop_rlambda_n: Not enough Lambdas")) in chop_lambda_n [] let chop_rprod_n = let rec chop_prod_n acc n rt = if n == 0 then List.rev acc,rt else match rt with | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b | _ -> raise (CErrors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) in chop_prod_n [] let list_union_eq eq_fun l1 l2 = let rec urec = function | [] -> l2 | a::l -> if List.exists (eq_fun a) l2 then urec l else a::urec l in urec l1 let list_add_set_eq eq_fun x l = if List.exists (eq_fun x) l then l else x::l let const_of_id id = let _,princ_ref = qualid_of_reference (Libnames.Ident (Loc.ghost,id)) in try Constrintern.locate_reference princ_ref with Not_found -> CErrors.errorlabstrm "IndFun.const_of_id" (str "cannot find " ++ Nameops.pr_id id) let def_of_const t = match (Term.kind_of_term t) with Term.Const sp -> (try (match Environ.constant_opt_value_in (Global.env()) sp with | Some c -> c | _ -> assert false) with Not_found -> assert false) |_ -> assert false let coq_constant s = Coqlib.gen_constant_in_modules "RecursiveDefinition" Coqlib.init_modules s;; let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in Nametab.locate (make_qualid dp (Id.of_string s)) let eq = lazy(coq_constant "eq") let refl_equal = lazy(coq_constant "eq_refl") (*****************************************************************) (* Copy of the standart save mechanism but without the much too *) (* slow reduction function *) (*****************************************************************) open Entries open Decl_kinds open Declare let definition_message = Declare.definition_message let get_locality = function | Discharge -> true | Local -> true | Global -> false let save with_clean id const (locality,_,kind) hook = let fix_exn = Future.fix_exn_of const.const_entry_body in let l,r = match locality with | Discharge when Lib.sections_are_opened () -> let k = Kindops.logical_kind_of_goal_kind kind in let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in (Local, VarRef id) | Discharge | Local | Global -> let local = get_locality locality in let k = Kindops.logical_kind_of_goal_kind kind in let kn = declare_constant id ~local (DefinitionEntry const, k) in (locality, ConstRef kn) in if with_clean then Pfedit.delete_current_proof (); CEphemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r); definition_message id let cook_proof _ = let (id,(entry,_,strength)) = Pfedit.cook_proof () in (id,(entry,strength)) let get_proof_clean do_reduce = let result = cook_proof do_reduce in Pfedit.delete_current_proof (); result let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in let old_rawprint = !Flags.raw_print in let old_printuniverses = !Constrextern.print_universes in Constrextern.print_universes := true; Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; Impargs.make_contextual_implicit_args false; Impargs.make_contextual_implicit_args false; Dumpglob.pause (); try let res = f a in Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Constrextern.print_universes := old_printuniverses; Dumpglob.continue (); res with | reraise -> Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Constrextern.print_universes := old_printuniverses; Dumpglob.continue (); raise reraise (**********************) type function_info = { function_constant : constant; graph_ind : inductive; equation_lemma : constant option; correctness_lemma : constant option; completeness_lemma : constant option; rect_lemma : constant option; rec_lemma : constant option; prop_lemma : constant option; is_general : bool; (* Has this function been defined using general recursive definition *) } (* type function_db = function_info list *) (* let function_table = ref ([] : function_db) *) let from_function = Summary.ref Cmap_env.empty ~name:"functions_db_fn" let from_graph = Summary.ref Indmap.empty ~name:"functions_db_gr" (* let rec do_cache_info finfo = function | [] -> raise Not_found | (finfo'::finfos as l) -> if finfo' == finfo then l else if finfo'.function_constant = finfo.function_constant then finfo::finfos else let res = do_cache_info finfo finfos in if res == finfos then l else finfo'::l let cache_Function (_,(finfos)) = let new_tbl = try do_cache_info finfos !function_table with Not_found -> finfos::!function_table in if new_tbl != !function_table then function_table := new_tbl *) let cache_Function (_,finfos) = from_function := Cmap_env.add finfos.function_constant finfos !from_function; from_graph := Indmap.add finfos.graph_ind finfos !from_graph let load_Function _ = cache_Function let subst_Function (subst,finfos) = let do_subst_con c = Mod_subst.subst_constant subst c and do_subst_ind i = Mod_subst.subst_ind subst i in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in let rect_lemma' = Option.smartmap do_subst_con finfos.rect_lemma in let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in let prop_lemma' = Option.smartmap do_subst_con finfos.prop_lemma in if function_constant' == finfos.function_constant && graph_ind' == finfos.graph_ind && equation_lemma' == finfos.equation_lemma && correctness_lemma' == finfos.correctness_lemma && completeness_lemma' == finfos.completeness_lemma && rect_lemma' == finfos.rect_lemma && rec_lemma' == finfos.rec_lemma && prop_lemma' == finfos.prop_lemma then finfos else { function_constant = function_constant'; graph_ind = graph_ind'; equation_lemma = equation_lemma' ; correctness_lemma = correctness_lemma' ; completeness_lemma = completeness_lemma' ; rect_lemma = rect_lemma' ; rec_lemma = rec_lemma'; prop_lemma = prop_lemma'; is_general = finfos.is_general } let classify_Function infos = Libobject.Substitute infos let discharge_Function (_,finfos) = let function_constant' = Lib.discharge_con finfos.function_constant and graph_ind' = Lib.discharge_inductive finfos.graph_ind and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma and rec_lemma' = Option.smartmap Lib.discharge_con finfos.rec_lemma and prop_lemma' = Option.smartmap Lib.discharge_con finfos.prop_lemma in if function_constant' == finfos.function_constant && graph_ind' == finfos.graph_ind && equation_lemma' == finfos.equation_lemma && correctness_lemma' == finfos.correctness_lemma && completeness_lemma' == finfos.completeness_lemma && rect_lemma' == finfos.rect_lemma && rec_lemma' == finfos.rec_lemma && prop_lemma' == finfos.prop_lemma then Some finfos else Some { function_constant = function_constant' ; graph_ind = graph_ind' ; equation_lemma = equation_lemma' ; correctness_lemma = correctness_lemma' ; completeness_lemma = completeness_lemma'; rect_lemma = rect_lemma'; rec_lemma = rec_lemma'; prop_lemma = prop_lemma' ; is_general = finfos.is_general } open Term let pr_ocst c = Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) c (mt ()) let pr_info f_info = str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ str "function_constant_type := " ++ (try Printer.pr_lconstr (Global.type_of_global_unsafe (ConstRef f_info.function_constant)) with e when CErrors.noncritical e -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++ str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++ str "correctness_lemma := " ++ pr_ocst f_info.correctness_lemma ++ fnl () ++ str "rect_lemma := " ++ pr_ocst f_info.rect_lemma ++ fnl () ++ str "rec_lemma := " ++ pr_ocst f_info.rec_lemma ++ fnl () ++ str "prop_lemma := " ++ pr_ocst f_info.prop_lemma ++ fnl () ++ str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () let pr_table tb = let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in Pp.prlist_with_sep fnl pr_info l let in_Function : function_info -> Libobject.obj = Libobject.declare_object {(Libobject.default_object "FUNCTIONS_DB") with Libobject.cache_function = cache_Function; Libobject.load_function = load_Function; Libobject.classify_function = classify_Function; Libobject.subst_function = subst_Function; Libobject.discharge_function = discharge_Function (* Libobject.open_function = open_Function; *) } let find_or_none id = try Some (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant") ) with Not_found -> None let find_Function_infos f = Cmap_env.find f !from_function let find_Function_of_graph ind = Indmap.find ind !from_graph let update_Function finfo = (* Pp.msgnl (pr_info finfo); *) Lib.add_anonymous_leaf (in_Function finfo) let add_Function is_general f = let f_id = Label.to_id (con_label f) in let equation_lemma = find_or_none (mk_equation_id f_id) and correctness_lemma = find_or_none (mk_correct_id f_id) and completeness_lemma = find_or_none (mk_complete_id f_id) and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect") and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec") and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") and graph_ind = match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) with | IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive") in let finfos = { function_constant = f; equation_lemma = equation_lemma; completeness_lemma = completeness_lemma; correctness_lemma = correctness_lemma; rect_lemma = rect_lemma; rec_lemma = rec_lemma; prop_lemma = prop_lemma; graph_ind = graph_ind; is_general = is_general } in update_Function finfos let pr_table () = pr_table !from_function (*********************************) (* Debuging *) let functional_induction_rewrite_dependent_proofs = ref true let function_debug = ref false open Goptions let functional_induction_rewrite_dependent_proofs_sig = { optsync = false; optdepr = false; optname = "Functional Induction Rewrite Dependent"; optkey = ["Functional";"Induction";"Rewrite";"Dependent"]; optread = (fun () -> !functional_induction_rewrite_dependent_proofs); optwrite = (fun b -> functional_induction_rewrite_dependent_proofs := b) } let _ = declare_bool_option functional_induction_rewrite_dependent_proofs_sig let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = true let function_debug_sig = { optsync = false; optdepr = false; optname = "Function debug"; optkey = ["Function_debug"]; optread = (fun () -> !function_debug); optwrite = (fun b -> function_debug := b) } let _ = declare_bool_option function_debug_sig let do_observe () = !function_debug let strict_tcc = ref false let is_strict_tcc () = !strict_tcc let strict_tcc_sig = { optsync = false; optdepr = false; optname = "Raw Function Tcc"; optkey = ["Function_raw_tcc"]; optread = (fun () -> !strict_tcc); optwrite = (fun b -> strict_tcc := b) } let _ = declare_bool_option strict_tcc_sig exception Building_graph of exn exception Defining_principle of exn exception ToShow of exn let jmeq () = try Coqlib.check_required_library Coqlib.jmeq_module_name; Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq" with e when CErrors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library Coqlib.jmeq_module_name; Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl" with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = tclMAP (fun x -> Proofview.V82.of_tactic (Tactics.Simple.intro x)) l let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" let well_founded = function () -> (coq_constant "well_founded") let acc_rel = function () -> (coq_constant "Acc") let acc_inv_id = function () -> (coq_constant "Acc_inv") let well_founded_ltof = function () -> (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof") let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) match r with ConstRef sp -> EvalConstRef sp | VarRef id -> EvalVarRef id | _ -> assert false;; let list_rewrite (rev:bool) (eqs: (constr*bool) list) = tclREPEAT (List.fold_right (fun (eq,b) i -> tclORELSE (Proofview.V82.of_tactic ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) i) (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; coq-8.6/plugins/funind/Recdef.v0000644000175000017500000000267113022274260016010 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A) -> A -> A := fun (fl : A -> A) (def : A) => match n with | O => def | S m => fl (iter m fl def) end. End Iter. Theorem le_lt_SS x y : x <= y -> x < S (S y). Proof. intros. now apply Nat.lt_succ_r, Nat.le_le_succ_r. Qed. Theorem Splus_lt x y : y < S (x + y). Proof. apply Nat.lt_succ_r. rewrite Nat.add_comm. apply Nat.le_add_r. Qed. Theorem SSplus_lt x y : x < S (S (x + y)). Proof. apply le_lt_SS, Nat.le_add_r. Qed. Inductive max_type (m n:nat) : Set := cmt : forall v, m <= v -> n <= v -> max_type m n. Definition max m n : max_type m n. Proof. destruct (Compare_dec.le_gt_dec m n) as [h|h]. - exists n; [exact h | apply le_n]. - exists m; [apply le_n | apply Nat.lt_le_incl; exact h]. Defined. Definition Acc_intro_generator_function := fun A R => @Acc_intro_generator A R 100. coq-8.6/plugins/funind/invfun.ml0000644000175000017500000011474713022274260016300 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) let pr_bindings prc prlc = function | ImplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ pr_sequence prc l | ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | NoBindings -> mt () let pr_with_bindings prc prlc (c,bl) = prc c ++ hv 0 (pr_bindings prc prlc bl) let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = pr_with_bindings prc prc (c,bl) (* The local debugging mechanism *) (* let msgnl = Pp.msgnl *) let observe strm = if do_observe () then Feedback.msg_debug strm else () (*let observennl strm = if do_observe () then begin Pp.msg strm;Pp.pp_flush () end else ()*) let do_observe_tac s tac g = let goal = try Printer.pr_goal g with e when CErrors.noncritical e -> assert false in try let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v with reraise -> let reraise = CErrors.push reraise in let e = ExplainErr.process_vernac_interp_error reraise in observe (hov 0 (str "observation "++ s++str " raised exception " ++ CErrors.iprint e ++ str " on goal" ++ fnl() ++ goal )); iraise reraise;; let observe_tac_strm s tac g = if do_observe () then do_observe_tac s tac g else tac g let observe_tac s tac g = if do_observe () then do_observe_tac (str s) tac g else tac g (* [nf_zeta] $\zeta$-normalization of a term *) let nf_zeta = Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) Environ.empty_env Evd.empty let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl (* (\* [id_to_constr id] finds the term associated to [id] in the global environment *\) *) (* let id_to_constr id = *) (* try *) (* Constrintern.global_reference id *) (* with Not_found -> *) (* raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id)) *) let make_eq () = try Universes.constr_of_global (Coqlib.build_coq_eq ()) with _ -> assert false let make_eq_refl () = try Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) with _ -> assert false (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. [generate_type true f i] returns \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion [generate_type false f i] returns \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion *) let generate_type evd g_to_f f graph i = (*i we deduce the number of arguments of the function and its returned type from the graph i*) let evd',graph = Evd.fresh_global (Global.env ()) !evd (Globnames.IndRef (fst (destInd graph))) in evd:=evd'; let graph_arity = Typing.e_type_of (Global.env ()) evd graph in let ctxt,_ = decompose_prod_assum graph_arity in let fun_ctxt,res_type = match ctxt with | [] | [_] -> anomaly (Pp.str "Not a valid context") | decl :: fun_ctxt -> fun_ctxt, get_type decl in let rec args_from_decl i accu = function | [] -> accu | LocalDef _ :: l -> args_from_decl (succ i) accu l | _ :: l -> let t = mkRel i in args_from_decl (succ i) (t :: accu) l in (*i We need to name the vars [res] and [fv] i*) let filter = fun decl -> match get_name decl with | Name id -> Some id | Anonymous -> None in let named_ctxt = List.map_filter filter fun_ctxt in let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (res_id :: named_ctxt) in (*i we can then type the argument to be applied to the function [f] i*) let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in (*i the hypothesis [res = fv] can then be computed We will need to lift it by one in order to use it as a conclusion i*) let make_eq = make_eq () in let res_eq_f_of_args = mkApp(make_eq ,[|lift 2 res_type;mkRel 1;mkRel 2|]) in (*i The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed We will need to lift it by one in order to use it as a conclusion i*) let args_and_res_as_rels = Array.of_list (args_from_decl 3 [] fun_ctxt) in let args_and_res_as_rels = Array.append args_and_res_as_rels [|mkRel 1|] in let graph_applied = mkApp(graph, args_and_res_as_rels) in (*i The [pre_context] is the defined to be the context corresponding to \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) let pre_ctxt = LocalAssum (Name res_id, lift 1 res_type) :: LocalDef (Name fv_id, mkApp (f,args_as_rels), res_type) :: fun_ctxt in (*i and we can return the solution depending on which lemma type we are defining i*) if g_to_f then LocalAssum (Anonymous,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph else LocalAssum (Anonymous,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph (* [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect] WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle evd f = let f_as_constant,u = match kind_of_term f with | Const c' -> c' | _ -> error "Must be used with a function" in let infos = find_Function_infos f_as_constant in match infos.rect_lemma with | None -> raise Not_found | Some rect_lemma -> let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (Globnames.ConstRef rect_lemma) in let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in evd:=evd'; rect_lemma,typ let rec generate_fresh_id x avoid i = if i == 0 then [] else let id = Namegen.next_ident_away_in_goal x avoid in id::(generate_fresh_id x (id::avoid) (pred i)) (* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. [functional_induction] is the tactic defined in [indfun] (dependency problem) [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions (resp. graphs of the functions and principles and correctness lemma types) to prove correct. [i] is the indice of the function to prove correct The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is it looks like~: [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res] The sketch of the proof is the following one~: \begin{enumerate} \item intros until $x_n$ \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i) \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the apply the corresponding constructor of the corresponding graph inductive. \end{enumerate} *) let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic = fun g -> (* first of all we recreate the lemmas types to be used as predicates of the induction principle that is~: \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] *) (* we the get the definition of the graphs block *) let graph_ind,u = destInd graphs_constr.(i) in let kn = fst graph_ind in let mib,_ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) let f_principle,princ_type = schemes.(i) in let princ_type = nf_zeta princ_type in let princ_infos = Tactics.compute_elim_sig princ_type in (* The number of args of the function is then easily computable *) let nb_fun_args = nb_prod (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* Since we cannot ensure that the functional principle is defined in the environment and due to the bug #1174, we will need to pose the principle using a name *) let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") ids in let ids = principle_id :: ids in (* We get the branches of the principle *) let branches = List.rev princ_infos.branches in (* and built the intro pattern for each of them *) let intro_pats = List.map (fun decl -> List.map (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id)) (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum (get_type decl))))) ) branches in (* before building the full intro pattern for the principle *) let eq_ind = make_eq () in let eq_construct = mkConstructUi (destInd eq_ind, 1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) let ind_number = ref 0 and min_constr_number = ref 0 in (* The tactic to prove the ith branch of the principle *) let prove_branche i g = (* We get the identifiers of this branch *) let pre_args = List.fold_right (fun (_,pat) acc -> match pat with | IntroNaming (IntroIdentifier id) -> id::acc | _ -> anomaly (Pp.str "Not an identifier") ) (List.nth intro_pats (pred i)) [] in (* and get the real args of the branch by unfolding the defined constant *) (* We can then recompute the arguments of the constructor. For each [hid] introduced by this branch, if [hid] has type $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are [ fv (hid fv (refl_equal fv)) ]. If [hid] has another type the corresponding argument of the constructor is [hid] *) let constructor_args g = List.fold_right (fun hid acc -> let type_of_hid = pf_unsafe_type_of g (mkVar hid) in match kind_of_term type_of_hid with | Prod(_,_,t') -> begin match kind_of_term t' with | Prod(_,t'',t''') -> begin match kind_of_term t'',kind_of_term t''' with | App(eq,args), App(graph',_) when (eq_constr eq eq_ind) && Array.exists (Constr.eq_constr_nounivs graph') graphs_constr -> (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) ::acc) | _ -> mkVar hid :: acc end | _ -> mkVar hid :: acc end | _ -> mkVar hid :: acc ) pre_args [] in (* in fact we must also add the parameters to the constructor args *) let constructor_args g = let params_id = fst (List.chop princ_infos.nparams args_names) in (List.map mkVar params_id)@((constructor_args g)) in (* We then get the constructor corresponding to this branch and modifies the references has needed i.e. if the constructor is the last one of the current inductive then add one the number of the inductive to take and add the number of constructor of the previous graph to the minimal constructor number *) let constructor = let constructor_num = i - !min_constr_number in let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in if constructor_num <= length then begin (kn,!ind_number),constructor_num end else begin incr ind_number; min_constr_number := !min_constr_number + length ; (kn,!ind_number),1 end in (* we can then build the final proof term *) let app_constructor g = applist((mkConstructU(constructor,u)),constructor_args g) in (* an apply the tactic *) let res,hres = match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with | [res;hres] -> res,hres | _ -> assert false in (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) ( tclTHENSEQ [ observe_tac("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in match l with | [] -> tclIDTAC | _ -> Proofview.V82.of_tactic (intro_patterns false l)); (* unfolding of all the defined variables introduced by this branch *) (* observe_tac "unfolding" pre_tac; *) (* $zeta$ normalizing of the conclusion *) Proofview.V82.of_tactic (reduce (Genredexpr.Cbv { Redops.all_flags with Genredexpr.rDelta = false ; Genredexpr.rConst = [] } ) Locusops.onConcl); observe_tac ("toto ") tclIDTAC; (* introducing the the result of the graph and the equality hypothesis *) observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); (* replacing [res] with its value *) observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); (* Conclusion *) observe_tac "exact" (fun g -> Proofview.V82.of_tactic (exact_check (app_constructor g)) g) ] ) g in (* end of branche proof *) let lemmas = Array.map (fun ((_,(ctxt,concl))) -> match ctxt with | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") | hres::res::decl::ctxt -> let res = Termops.it_mkLambda_or_LetIn (Termops.it_mkProd_or_LetIn concl [hres;res]) (LocalAssum (get_name decl, get_type decl) :: ctxt) in res ) lemmas_types_infos in let param_names = fst (List.chop princ_infos.nparams args_names) in let params = List.map mkVar param_names in let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in (* The bindings of the principle that is the params of the principle and the different lemma types *) let bindings = let params_bindings,avoid = List.fold_left2 (fun (bindings,avoid) decl p -> let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in p::bindings,id::avoid ) ([],pf_ids_of_hyps g) princ_infos.params (List.rev params) in let lemmas_bindings = List.rev (fst (List.fold_left2 (fun (bindings,avoid) decl p -> let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in (nf_zeta p)::bindings,id::avoid) ([],avoid) princ_infos.predicates (lemmas))) in (params_bindings@lemmas_bindings) in tclTHENSEQ [ observe_tac "principle" (Proofview.V82.of_tactic (assert_by (Name principle_id) princ_type (exact_check f_principle))); observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) observe_tac "idtac" tclIDTAC; tclTHEN_i (observe_tac "functional_induction" ( (fun gl -> let term = mkApp (mkVar principle_id,Array.of_list bindings) in let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in Proofview.V82.of_tactic (apply term) gl') )) (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) ] g (* [generalize_dependent_of x hyp g] generalize every hypothesis which depends of [x] but [hyp] *) let generalize_dependent_of x hyp g = let open Context.Named.Declaration in tclMAP (function | LocalAssum (id,t) when not (Id.equal id hyp) && (Termops.occur_var (pf_env g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) g (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis (unfolding, substituting, destructing cases \ldots) *) let tauto = let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in let mp = ModPath.MPfile (DirPath.make dp) in let kn = KerName.make2 mp (Label.make "tauto") in Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> let body = Tacenv.interp_ltac kn in Tacinterp.eval_tactic body end let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g and intros_with_rewrite_aux : tactic = fun g -> let eq_ind = make_eq () in match kind_of_term (pf_concl g) with | Prod(_,t,t') -> begin match kind_of_term t with | App(eq,args) when (eq_constr eq eq_ind) -> if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) then let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g else if isVar args.(1) && (Environ.evaluable_named (destVar args.(1)) (pf_env g)) then tclTHENSEQ[ Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))]); tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) ))) (pf_ids_of_hyps g); intros_with_rewrite ] g else if isVar args.(2) && (Environ.evaluable_named (destVar args.(2)) (pf_env g)) then tclTHENSEQ[ Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))]); tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) ))) (pf_ids_of_hyps g); intros_with_rewrite ] g else if isVar args.(1) then let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); generalize_dependent_of (destVar args.(1)) id; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); intros_with_rewrite ] g else if isVar args.(2) then let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); generalize_dependent_of (destVar args.(2)) id; tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); intros_with_rewrite ] g else begin let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ[ Proofview.V82.of_tactic (Simple.intro id); tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); intros_with_rewrite ] g end | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> tclTHENSEQ[ Proofview.V82.of_tactic (simplest_case v); intros_with_rewrite ] g | LetIn _ -> tclTHENSEQ[ Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false; }) Locusops.onConcl) ; intros_with_rewrite ] g | _ -> let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g end | LetIn _ -> tclTHENSEQ[ Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false; }) Locusops.onConcl) ; intros_with_rewrite ] g | _ -> tclIDTAC g let rec reflexivity_with_destruct_cases g = let destruct_case () = try match kind_of_term (snd (destApp (pf_concl g))).(2) with | Case(_,_,v,_) -> tclTHENSEQ[ Proofview.V82.of_tactic (simplest_case v); Proofview.V82.of_tactic intros; observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] | _ -> Proofview.V82.of_tactic reflexivity with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity in let eq_ind = make_eq () in let discr_inject = Tacticals.onAllHypsAndConcl ( fun sc g -> match sc with None -> tclIDTAC g | Some id -> match kind_of_term (pf_unsafe_type_of g (mkVar id)) with | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> if Equality.discriminable (pf_env g) (project g) t1 t2 then Proofview.V82.of_tactic (Equality.discrHyp id) g else if Equality.injectable (pf_env g) (project g) t1 t2 then tclTHENSEQ [Proofview.V82.of_tactic (Equality.injHyp None id);thin [id];intros_with_rewrite] g else tclIDTAC g | _ -> tclIDTAC g ) in (tclFIRST [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity); observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); (* We reach this point ONLY if the same value is matched (at least) two times along binding path. In this case, either we have a discriminable hypothesis and we are done, either at least an injectable one and we do the injection before continuing *) observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases) ]) g (* [prove_fun_complete funs graphs schemes lemmas_types_infos i] is the tactic used to prove completness lemma. [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. [i] is the indice of the function to prove complete The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is it looks like~: [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in] The sketch of the proof is the following one~: \begin{enumerate} \item intros until $H:graph\ x_1\ldots x_n\ res$ \item $elim\ H$ using schemes.(i) \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has type [x=?] with [x] a variable, then subst [x], if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else if [h] is a match then destruct it, else do just introduce it, after all intros, the conclusion should be a reflexive equality. \end{enumerate} *) let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = fun g -> (* We compute the types of the different mutually recursive lemmas in $\zeta$ normal form *) let lemmas = Array.map (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in let graph_principle = nf_zeta schemes.(i) in let princ_type = pf_unsafe_type_of g graph_principle in let princ_infos = Tactics.compute_elim_sig princ_type in (* Then we get the number of argument of the function and compute a fresh name for each of them *) let nb_fun_args = nb_prod (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* and fresh names for res H and the principle (cf bug bug #1174) *) let res,hres,graph_principle_id = match generate_fresh_id (Id.of_string "z") ids 3 with | [res;hres;graph_principle_id] -> res,hres,graph_principle_id | _ -> assert false in let ids = res::hres::graph_principle_id::ids in (* we also compute fresh names for each hyptohesis of each branch of the principle *) let branches = List.rev princ_infos.branches in let intro_pats = List.map (fun decl -> List.map (fun id -> id) (generate_fresh_id (Id.of_string "y") ids (nb_prod (get_type decl))) ) branches in (* We will need to change the function by its body using [f_equation] if it is recursive (that is the graph is infinite or unfold if the graph is finite *) let rewrite_tac j ids : tactic = let graph_def = graphs.(j) in let infos = try find_Function_infos (fst (destConst funcs.(j))) with Not_found -> error "No graph found" in if infos.is_general || Rtree.is_infinite Declareops.eq_recarg graph_def.mind_recargs then let eq_lemma = try Option.get (infos).equation_lemma with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma") in tclTHENSEQ[ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false; }) Locusops.onConcl) ; Proofview.V82.of_tactic (generalize (List.map mkVar ids)); thin ids ] else Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))]) in (* The proof of each branche itself *) let ind_number = ref 0 in let min_constr_number = ref 0 in let prove_branche i g = (* we fist compute the inductive corresponding to the branch *) let this_ind_number = let constructor_num = i - !min_constr_number in let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in if constructor_num <= length then !ind_number else begin incr ind_number; min_constr_number := !min_constr_number + length; !ind_number end in let this_branche_ids = List.nth intro_pats (pred i) in tclTHENSEQ[ (* we expand the definition of the function *) observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); (* introduce hypothesis with some rewrite *) observe_tac "intros_with_rewrite (all)" intros_with_rewrite; (* The proof is (almost) complete *) observe_tac "reflexivity" (reflexivity_with_destruct_cases) ] g in let params_names = fst (List.chop princ_infos.nparams args_names) in let params = List.map mkVar params_names in tclTHENSEQ [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); observe_tac "h_generalize" (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); Proofview.V82.of_tactic (Simple.intro graph_principle_id); observe_tac "" (tclTHEN_i (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings))))) (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) ] g (* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and [functional_induction] is Indfun.functional_induction (same pb) *) let derive_correctness make_scheme functional_induction (funs: pconstant list) (graphs:inductive list) = assert (funs <> []); assert (graphs <> []); let funs = Array.of_list funs and graphs = Array.of_list graphs in let funs_constr = Array.map mkConstU funs in States.with_state_protection_on_exception (fun () -> let env = Global.env () in let evd = ref (Evd.from_env env) in let graphs_constr = Array.map mkInd graphs in let lemmas_types_infos = Util.Array.map2_i (fun i f_constr graph -> (* let const_of_f,u = destConst f_constr in *) let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = generate_type evd false f_constr graph i in let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let _ = Typing.e_type_of (Global.env ()) evd type_of_lemma in let type_of_lemma = nf_zeta type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_lconstr_env (Global.env ()) !evd type_of_lemma); type_of_lemma,type_info ) funs_constr graphs_constr in let schemes = (* The functional induction schemes are computed and not saved if there is more that one function if the block contains only one function we can safely reuse [f_rect] *) try if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; [| find_induction_principle evd funs_constr.(0) |] with Not_found -> ( Array.of_list (List.map (fun entry -> (fst (fst(Future.force entry.Entries.const_entry_body)), Option.get entry.Entries.const_entry_type ) ) (make_scheme evd (Array.map_to_list (fun const -> const,GType []) funs)) ) ) in let proving_tac = prove_fun_correct !evd functional_induction funs_constr graphs_constr schemes lemmas_types_infos in Array.iteri (fun i f_as_constant -> let f_id = Label.to_id (con_label (fst f_as_constant)) in (*i The next call to mk_correct_id is valid since we are constructing the lemma Ensures by: obvious i*) let lem_id = mk_correct_id f_id in let (typ,_) = lemmas_types_infos.(i) in Lemmas.start_proof lem_id (Decl_kinds.Global,Flags.is_universe_polymorphism (),((Decl_kinds.Proof Decl_kinds.Theorem))) !evd typ (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") (proving_tac i)))); (Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None)))); let finfo = find_Function_infos (fst f_as_constant) in (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in let (lem_cst,_) = destConst lem_cst_constr in update_Function {finfo with correctness_lemma = Some lem_cst}; ) funs; let lemmas_types_infos = Util.Array.map2_i (fun i f_constr graph -> let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = generate_type evd true f_constr graph i in let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); type_of_lemma,type_info ) funs_constr graphs_constr in let (kn,_) as graph_ind,u = (destInd graphs_constr.(0)) in let mib,mip = Global.lookup_inductive graph_ind in let sigma, scheme = (Indrec.build_mutual_induction_scheme (Global.env ()) !evd (Array.to_list (Array.mapi (fun i _ -> ((kn,i),u(* Univ.Instance.empty *)),true,InType) mib.Declarations.mind_packets ) ) ) in let schemes = Array.of_list scheme in let proving_tac = prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos in Array.iteri (fun i f_as_constant -> let f_id = Label.to_id (con_label (fst f_as_constant)) in (*i The next call to mk_complete_id is valid since we are constructing the lemma Ensures by: obvious i*) let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_id (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) sigma (fst lemmas_types_infos.(i)) (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") (proving_tac i)))) ; (Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None)))); let finfo = find_Function_infos (fst f_as_constant) in let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in let (lem_cst,_) = destConst lem_cst_constr in update_Function {finfo with completeness_lemma = Some lem_cst} ) funs) () (***********************************************) (* [revert_graph kn post_tac hid] transforme an hypothesis [hid] having type Ind(kn,num) t1 ... tn res when [kn] denotes a graph block into f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) let revert_graph kn post_tac hid g = let typ = pf_unsafe_type_of g (mkVar hid) in match kind_of_term typ with | App(i,args) when isInd i -> let ((kn',num) as ind'),u = destInd i in if MutInd.equal kn kn' then (* We have generated a graph hypothesis so that we must change it if we can *) let info = try find_Function_of_graph ind' with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) anomaly (Pp.str "Cannot retrieve infos about a mutual block") in (* if we can find a completeness lemma for this function then we can come back to the functional form. If not, we do nothing *) match info.completeness_lemma with | None -> tclIDTAC g | Some f_complete -> let f_args,res = Array.chop (Array.length args - 1) args in tclTHENSEQ [ Proofview.V82.of_tactic (generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]); thin [hid]; Proofview.V82.of_tactic (Simple.intro hid); post_tac hid ] g else tclIDTAC g | _ -> tclIDTAC g (* [functional_inversion hid fconst f_correct ] is the functional version of [inversion] [hid] is the hypothesis to invert, [fconst] is the function to invert and [f_correct] is the correctness lemma for [fconst]. The sketch is the follwing~: \begin{enumerate} \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$ (fails if it is not possible) \item replace [hid] with $R\_f t_1 \ldots t_n res$ using [f_correct] \item apply [inversion] on [hid] \item finally in each branch, replace each hypothesis [R\_f ..] by [f ...] using [f_complete] (whenever such a lemma exists) \end{enumerate} *) let functional_inversion kn hid fconst f_correct : tactic = fun g -> let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in let type_of_h = pf_unsafe_type_of g (mkVar hid) in match kind_of_term type_of_h with | App(eq,args) when eq_constr eq (make_eq ()) -> let pre_tac,f_args,res = match kind_of_term args.(1),kind_of_term args.(2) with | App(f,f_args),_ when eq_constr f fconst -> ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.onHyp hid))),f_args,args.(2)) |_,App(f,f_args) when eq_constr f fconst -> ((fun hid -> tclIDTAC),f_args,args.(1)) | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) in tclTHENSEQ[ pre_tac hid; Proofview.V82.of_tactic (generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]); thin [hid]; Proofview.V82.of_tactic (Simple.intro hid); Proofview.V82.of_tactic (Inv.inv FullInversion None (NamedHyp hid)); (fun g -> let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps g) in tclMAP (revert_graph kn pre_tac) (hid::new_ids) g ); ] g | _ -> tclFAIL 1 (mt ()) g let invfun qhyp f = let f = match f with | ConstRef f -> f | _ -> raise (CErrors.UserError("",str "Not a function")) in try let finfos = find_Function_infos f in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in Proofview.V82.of_tactic ( Tactics.try_intros_until (fun hid -> Proofview.V82.tactic (functional_inversion kn hid (mkConst f) f_correct)) qhyp ) with | Not_found -> error "No graph found" | Option.IsNone -> error "Cannot use equivalence with graph!" let invfun qhyp f g = match f with | Some f -> invfun qhyp f g | None -> Proofview.V82.of_tactic begin Tactics.try_intros_until (fun hid -> Proofview.V82.tactic begin fun g -> let hyp_typ = pf_unsafe_type_of g (mkVar hid) in match kind_of_term hyp_typ with | App(eq,args) when eq_constr eq (make_eq ()) -> begin let f1,_ = decompose_app args.(1) in try if not (isConst f1) then failwith ""; let finfos = find_Function_infos (fst (destConst f1)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f1 f_correct g with | Failure "" | Option.IsNone | Not_found -> try let f2,_ = decompose_app args.(2) in if not (isConst f2) then failwith ""; let finfos = find_Function_infos (fst (destConst f2)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f2 f_correct g with | Failure "" -> errorlabstrm "" (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") | Option.IsNone -> if do_observe () then error "Cannot use equivalence with graph for any side of the equality" else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) | Not_found -> if do_observe () then error "No graph found for any side of equality" else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) end | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") end) qhyp end g coq-8.6/plugins/funind/vo.itarget0000644000175000017500000000001213022274260016421 0ustar mdenesmdenesRecdef.vo coq-8.6/plugins/fourier/0000755000175000017500000000000013022274260014613 5ustar mdenesmdenescoq-8.6/plugins/fourier/fourier.ml0000644000175000017500000001415313022274260016624 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* match ie.coef with [] -> raise (Failure "empty ineq") |(c::r) -> if rinf c r0 then pop ie lneg else if rinf r0 c then pop ie lpos else pop ie lnul) s; [!lneg;!lnul;!lpos] ;; (* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!): (add_hist [(equation 1, s1);...;(équation n, sn)]) = [{équation 1, [1;0;...;0], s1}; {équation 2, [0;1;...;0], s2}; ... {équation n, [0;0;...;1], sn}] *) let add_hist le = let n = List.length le in let i = ref 0 in List.map (fun (ie,s) -> let h = ref [] in for _k = 1 to (n - (!i) - 1) do pop r0 h; done; pop r1 h; for _k = 1 to !i do pop r0 h; done; i:=!i+1; {coef=ie;hist=(!h);strict=s}) le ;; (* additionne deux inéquations *) let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef; hist=List.map2 rplus ie1.hist ie2.hist; strict=ie1.strict || ie2.strict} ;; (* multiplication d'une inéquation par un rationnel (positif) *) let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef; hist=List.map (fun x -> rmult a x) ie.hist; strict= ie.strict} ;; (* on enlève le premier coefficient *) let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict} ;; (* le premier coefficient: "tête" de l'inéquation *) let hd_coef ie = List.hd ie.coef ;; (* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient. *) let deduce_add lneg lpos = let res=ref [] in List.iter (fun i1 -> List.iter (fun i2 -> let a = rop (hd_coef i1) in let b = hd_coef i2 in pop (ie_tl (ie_add (ie_emult b i1) (ie_emult a i2))) res) lpos) lneg; !res ;; (* élimination de la première variable à partir d'une liste d'inéquations: opération qu'on itère dans l'algorithme de Fourier. *) let deduce1 s = match (partitionne s) with [lneg;lnul;lpos] -> let lnew = deduce_add lneg lpos in (List.map ie_tl lnul)@lnew |_->assert false ;; (* algorithme de Fourier: on élimine successivement toutes les variables. *) let deduce lie = let n = List.length (fst (List.hd lie)) in let lie=ref (add_hist lie) in for _i = 1 to n - 1 do lie:= deduce1 !lie; done; !lie ;; (* donne [] si le système a des solutions, sinon donne [c,s,lc] où lc est la combinaison linéaire des inéquations de départ qui donne 0 < c si s=true ou 0 <= c sinon cette inéquation étant absurde. *) exception Contradiction of (rational * bool * rational list) list let unsolvable lie = let lr = deduce lie in let check = function | {coef=[c];hist=lc;strict=s} -> if (rinf c r0 && (not s)) || (rinfeq c r0 && s) then raise (Contradiction [c,s,lc]) |_->assert false in try List.iter check lr; [] with Contradiction l -> l (* Exemples: let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];; deduce test1;; unsolvable test1;; let test2=[ [r1;r1;r0;r0;r0],false; [r0;r1;r1;r0;r0],false; [r0;r0;r1;r1;r0],false; [r0;r0;r0;r1;r1],false; [r1;r0;r0;r0;r1],false; [rop r1;rop r1;r0;r0;r0],false; [r0;rop r1;rop r1;r0;r0],false; [r0;r0;rop r1;rop r1;r0],false; [r0;r0;r0;rop r1;rop r1],false; [rop r1;r0;r0;r0;rop r1],false ];; deduce test2;; unsolvable test2;; *) coq-8.6/plugins/fourier/Fourier.v0000644000175000017500000000145213022274260016417 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 < a -> a * x1 < a * y1. intros; apply Rmult_lt_compat_l; assumption. Qed. Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1. red. intros. case H; auto with real. Qed. Lemma Rfourier_lt_lt : forall x1 y1 x2 y2 a:R, x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. intros x1 y1 x2 y2 a H H0 H1; try assumption. apply Rplus_lt_compat. try exact H. apply Rfourier_lt. try exact H0. try exact H1. Qed. Lemma Rfourier_lt_le : forall x1 y1 x2 y2 a:R, x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. intros x1 y1 x2 y2 a H H0 H1; try assumption. case H0; intros. apply Rplus_lt_compat. try exact H. apply Rfourier_lt; auto with real. rewrite H2. rewrite (Rplus_comm y1 (a * y2)). rewrite (Rplus_comm x1 (a * y2)). apply Rplus_lt_compat_l. try exact H. Qed. Lemma Rfourier_le_lt : forall x1 y1 x2 y2 a:R, x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. intros x1 y1 x2 y2 a H H0 H1; try assumption. case H; intros. apply Rfourier_lt_le; auto with real. rewrite H2. apply Rplus_lt_compat_l. apply Rfourier_lt; auto with real. Qed. Lemma Rfourier_le_le : forall x1 y1 x2 y2 a:R, x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2. intros x1 y1 x2 y2 a H H0 H1; try assumption. case H0; intros. red. left; try assumption. apply Rfourier_le_lt; auto with real. rewrite H2. case H; intros. red. left; try assumption. rewrite (Rplus_comm x1 (a * y2)). rewrite (Rplus_comm y1 (a * y2)). apply Rplus_lt_compat_l. try exact H3. rewrite H3. red. right; try assumption. auto with real. Qed. Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. intros x H; try assumption. rewrite Rplus_comm. apply Rle_lt_0_plus_1. red; auto with real. Qed. Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. intros x y H H0; try assumption. replace 0 with (x * 0). apply Rmult_lt_compat_l; auto with real. ring. Qed. Lemma Rlt_zero_1 : 0 < 1. exact Rlt_0_1. Qed. Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. intros x H; try assumption. case H; intros. red. left; try assumption. apply Rlt_zero_pos_plus1; auto with real. rewrite <- H0. replace (1 + 0) with 1. red; left. exact Rlt_zero_1. ring. Qed. Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. intros x y H H0; try assumption. case H; intros. red; left. apply Rlt_mult_inv_pos; auto with real. rewrite <- H1. red; right; ring. Qed. Lemma Rle_zero_1 : 0 <= 1. red; left. exact Rlt_zero_1. Qed. Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d. intros n d H; red; intros H0; try exact H0. generalize (Rgt_not_le 0 (n * / d)). intros H1; elim H1; try assumption. replace (n * / d) with (- - (n * / d)). replace 0 with (- -0). replace (- (n * / d)) with (- n * / d). replace (-0) with 0. red. apply Ropp_gt_lt_contravar. red. exact H0. ring. ring. ring. ring. Qed. Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x. intros x; try assumption. replace (0 * x) with 0. apply Rlt_irrefl. ring. Qed. Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d. intros n d H; try assumption. apply Rgt_not_le. replace 0 with (-0). replace (- n * / d) with (- (n * / d)). apply Ropp_lt_gt_contravar. try exact H. ring. ring. Qed. Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y. unfold not; intros. apply H. apply Rplus_lt_reg_l with x. replace (x + 0) with x. replace (x + (y - x)) with y. try exact H0. ring. ring. Qed. Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y. unfold not; intros. apply H. case H0; intros. left. apply Rplus_lt_reg_l with x. replace (x + 0) with x. replace (x + (y - x)) with y. try exact H1. ring. ring. right. rewrite H1; ring. Qed. Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y. unfold Rgt; intros; assumption. Qed. Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y. intros x y; exact (Rge_le y x). Qed. Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y. exact Req_le. Qed. Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y. exact Req_le_sym. Qed. Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y. exact Rnot_ge_lt. Qed. Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y. exact Rnot_gt_le. Qed. Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y. exact Rnot_le_lt. Qed. Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y. exact Rnot_lt_ge. Qed. coq-8.6/plugins/fourier/fourierR.ml0000644000175000017500000005172713022274260016756 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* r0;; let flin_add f x c = let cx = flin_coef f x in Constrhash.replace f.fhom x (rplus cx c); f ;; let flin_add_cste f c = {fhom=f.fhom; fcste=rplus f.fcste c} ;; let flin_one () = flin_add_cste (flin_zero()) r1;; let flin_plus f1 f2 = let f3 = flin_zero() in Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom; flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste; ;; let flin_minus f1 f2 = let f3 = flin_zero() in Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; Constrhash.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom; flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste); ;; let flin_emult a f = let f2 = flin_zero() in Constrhash.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom; flin_add_cste f2 (rmult a f.fcste); ;; (*****************************************************************************) type ineq = Rlt | Rle | Rgt | Rge let string_of_R_constant kn = match Names.repr_con kn with | MPfile dir, sec_dir, id when sec_dir = DirPath.empty && DirPath.to_string dir = "Coq.Reals.Rdefinitions" -> Label.to_string id | _ -> "constant_not_of_R" let rec string_of_R_constr c = match kind_of_term c with Cast (c,_,_) -> string_of_R_constr c |Const (c,_) -> string_of_R_constant c | _ -> "not_of_constant" exception NoRational let rec rational_of_constr c = match kind_of_term c with | Cast (c,_,_) -> (rational_of_constr c) | App (c,args) -> (match (string_of_R_constr c) with | "Ropp" -> rop (rational_of_constr args.(0)) | "Rinv" -> rinv (rational_of_constr args.(0)) | "Rmult" -> rmult (rational_of_constr args.(0)) (rational_of_constr args.(1)) | "Rdiv" -> rdiv (rational_of_constr args.(0)) (rational_of_constr args.(1)) | "Rplus" -> rplus (rational_of_constr args.(0)) (rational_of_constr args.(1)) | "Rminus" -> rminus (rational_of_constr args.(0)) (rational_of_constr args.(1)) | _ -> raise NoRational) | Const (kn,_) -> (match (string_of_R_constant kn) with "R1" -> r1 |"R0" -> r0 | _ -> raise NoRational) | _ -> raise NoRational ;; exception NoLinear let rec flin_of_constr c = try( match kind_of_term c with | Cast (c,_,_) -> (flin_of_constr c) | App (c,args) -> (match (string_of_R_constr c) with "Ropp" -> flin_emult (rop r1) (flin_of_constr args.(0)) | "Rplus"-> flin_plus (flin_of_constr args.(0)) (flin_of_constr args.(1)) | "Rminus"-> flin_minus (flin_of_constr args.(0)) (flin_of_constr args.(1)) | "Rmult"-> (try let a = rational_of_constr args.(0) in try let b = rational_of_constr args.(1) in flin_add_cste (flin_zero()) (rmult a b) with NoRational -> flin_add (flin_zero()) args.(1) a with NoRational -> flin_add (flin_zero()) args.(0) (rational_of_constr args.(1))) | "Rinv"-> let a = rational_of_constr args.(0) in flin_add_cste (flin_zero()) (rinv a) | "Rdiv"-> (let b = rational_of_constr args.(1) in try let a = rational_of_constr args.(0) in flin_add_cste (flin_zero()) (rdiv a b) with NoRational -> flin_add (flin_zero()) args.(0) (rinv b)) |_-> raise NoLinear) | Const (c,_) -> (match (string_of_R_constant c) with "R1" -> flin_one () |"R0" -> flin_zero () |_-> raise NoLinear) |_-> raise NoLinear) with NoRational | NoLinear -> flin_add (flin_zero()) c r1 ;; let flin_to_alist f = let res=ref [] in Constrhash.iter (fun x c -> res:=(c,x)::(!res)) f; !res ;; (* Représentation des hypothèses qui sont des inéquations ou des équations. *) type hineq={hname:constr; (* le nom de l'hypothèse *) htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *) hleft:constr; hright:constr; hflin:flin; hstrict:bool} ;; (* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0 *) exception NoIneq let ineq1_of_constr (h,t) = match (kind_of_term t) with | App (f,args) -> (match kind_of_term f with | Const (c,_) when Array.length args = 2 -> let t1= args.(0) in let t2= args.(1) in (match (string_of_R_constant c) with |"Rlt" -> [{hname=h; htype="Rlt"; hleft=t1; hright=t2; hflin= flin_minus (flin_of_constr t1) (flin_of_constr t2); hstrict=true}] |"Rgt" -> [{hname=h; htype="Rgt"; hleft=t2; hright=t1; hflin= flin_minus (flin_of_constr t2) (flin_of_constr t1); hstrict=true}] |"Rle" -> [{hname=h; htype="Rle"; hleft=t1; hright=t2; hflin= flin_minus (flin_of_constr t1) (flin_of_constr t2); hstrict=false}] |"Rge" -> [{hname=h; htype="Rge"; hleft=t2; hright=t1; hflin= flin_minus (flin_of_constr t2) (flin_of_constr t1); hstrict=false}] |_-> raise NoIneq) | Ind ((kn,i),_) -> if not (eq_gr (IndRef(kn,i)) Coqlib.glob_eq) then raise NoIneq; let t0= args.(0) in let t1= args.(1) in let t2= args.(2) in (match (kind_of_term t0) with | Const (c,_) -> (match (string_of_R_constant c) with | "R"-> [{hname=h; htype="eqTLR"; hleft=t1; hright=t2; hflin= flin_minus (flin_of_constr t1) (flin_of_constr t2); hstrict=false}; {hname=h; htype="eqTRL"; hleft=t2; hright=t1; hflin= flin_minus (flin_of_constr t2) (flin_of_constr t1); hstrict=false}] |_-> raise NoIneq) |_-> raise NoIneq) |_-> raise NoIneq) |_-> raise NoIneq ;; (* Applique la méthode de Fourier à une liste d'hypothèses (type hineq) *) let fourier_lineq lineq1 = let nvar=ref (-1) in let hvar=Constrhash.create 50 in (* la table des variables des inéquations *) List.iter (fun f -> Constrhash.iter (fun x _ -> if not (Constrhash.mem hvar x) then begin nvar:=(!nvar)+1; Constrhash.add hvar x (!nvar) end) f.hflin.fhom) lineq1; let sys= List.map (fun h-> let v=Array.make ((!nvar)+1) r0 in Constrhash.iter (fun x c -> v.(Constrhash.find hvar x)<-c) h.hflin.fhom; ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict)) lineq1 in unsolvable sys ;; (*********************************************************************) (* Defined constants *) let get = Lazy.force let constant = Coqlib.gen_constant "Fourier" (* Standard library *) open Coqlib let coq_sym_eqT = lazy (build_coq_eq_sym ()) let coq_False = lazy (build_coq_False ()) let coq_not = lazy (build_coq_not ()) let coq_eq = lazy (build_coq_eq ()) (* Rdefinitions *) let constant_real = constant ["Reals";"Rdefinitions"] let coq_Rlt = lazy (constant_real "Rlt") let coq_Rgt = lazy (constant_real "Rgt") let coq_Rle = lazy (constant_real "Rle") let coq_Rge = lazy (constant_real "Rge") let coq_R = lazy (constant_real "R") let coq_Rminus = lazy (constant_real "Rminus") let coq_Rmult = lazy (constant_real "Rmult") let coq_Rplus = lazy (constant_real "Rplus") let coq_Ropp = lazy (constant_real "Ropp") let coq_Rinv = lazy (constant_real "Rinv") let coq_R0 = lazy (constant_real "R0") let coq_R1 = lazy (constant_real "R1") (* RIneq *) let coq_Rinv_1 = lazy (constant ["Reals";"RIneq"] "Rinv_1") (* Fourier_util *) let constant_fourier = constant ["fourier";"Fourier_util"] let coq_Rlt_zero_1 = lazy (constant_fourier "Rlt_zero_1") let coq_Rlt_zero_pos_plus1 = lazy (constant_fourier "Rlt_zero_pos_plus1") let coq_Rle_zero_pos_plus1 = lazy (constant_fourier "Rle_zero_pos_plus1") let coq_Rlt_mult_inv_pos = lazy (constant_fourier "Rlt_mult_inv_pos") let coq_Rle_zero_zero = lazy (constant_fourier "Rle_zero_zero") let coq_Rle_zero_1 = lazy (constant_fourier "Rle_zero_1") let coq_Rle_mult_inv_pos = lazy (constant_fourier "Rle_mult_inv_pos") let coq_Rnot_lt0 = lazy (constant_fourier "Rnot_lt0") let coq_Rle_not_lt = lazy (constant_fourier "Rle_not_lt") let coq_Rfourier_gt_to_lt = lazy (constant_fourier "Rfourier_gt_to_lt") let coq_Rfourier_ge_to_le = lazy (constant_fourier "Rfourier_ge_to_le") let coq_Rfourier_eqLR_to_le = lazy (constant_fourier "Rfourier_eqLR_to_le") let coq_Rfourier_eqRL_to_le = lazy (constant_fourier "Rfourier_eqRL_to_le") let coq_Rfourier_not_ge_lt = lazy (constant_fourier "Rfourier_not_ge_lt") let coq_Rfourier_not_gt_le = lazy (constant_fourier "Rfourier_not_gt_le") let coq_Rfourier_not_le_gt = lazy (constant_fourier "Rfourier_not_le_gt") let coq_Rfourier_not_lt_ge = lazy (constant_fourier "Rfourier_not_lt_ge") let coq_Rfourier_lt = lazy (constant_fourier "Rfourier_lt") let coq_Rfourier_le = lazy (constant_fourier "Rfourier_le") let coq_Rfourier_lt_lt = lazy (constant_fourier "Rfourier_lt_lt") let coq_Rfourier_lt_le = lazy (constant_fourier "Rfourier_lt_le") let coq_Rfourier_le_lt = lazy (constant_fourier "Rfourier_le_lt") let coq_Rfourier_le_le = lazy (constant_fourier "Rfourier_le_le") let coq_Rnot_lt_lt = lazy (constant_fourier "Rnot_lt_lt") let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le") let coq_Rlt_not_le_frac_opp = lazy (constant_fourier "Rlt_not_le_frac_opp") (****************************************************************************** Construction de la preuve en cas de succès de la méthode de Fourier, i.e. on obtient une contradiction. *) let is_int x = (x.den)=1 ;; (* fraction = couple (num,den) *) let rational_to_fraction x= (x.num,x.den) ;; (* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1))) *) let int_to_real n = let nn=abs n in if nn=0 then get coq_R0 else (let s=ref (get coq_R1) in for _i = 1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done; if n<0 then mkApp (get coq_Ropp, [|!s|]) else !s) ;; (* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1))) *) let rational_to_real x = let (n,d)=rational_to_fraction x in mkApp (get coq_Rmult, [|int_to_real n;mkApp(get coq_Rinv,[|int_to_real d|])|]) ;; (* preuve que 0 False *) let tac_zero_inf_false gl (n,d) = if n=0 then (apply (get coq_Rnot_lt0)) else (Tacticals.New.tclTHEN (apply (get coq_Rle_not_lt)) (tac_zero_infeq_pos gl (-n,d))) ;; (* preuve que 0<=(-n)*(1/d) => False *) let tac_zero_infeq_false gl (n,d) = (Tacticals.New.tclTHEN (apply (get coq_Rlt_not_le_frac_opp)) (tac_zero_inf_pos gl (-n,d))) ;; let exact = exact_check;; let tac_use h = let tac = exact h.hname in match h.htype with "Rlt" -> tac |"Rle" -> tac |"Rgt" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_gt_to_lt)) tac) |"Rge" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_ge_to_le)) tac) |"eqTLR" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqLR_to_le)) tac) |"eqTRL" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqRL_to_le)) tac) |_->assert false ;; (* let is_ineq (h,t) = match (kind_of_term t) with App (f,args) -> (match (string_of_R_constr f) with "Rlt" -> true | "Rgt" -> true | "Rle" -> true | "Rge" -> true (* Wrong:not in Rdefinitions: *) | "eqT" -> (match (string_of_R_constr args.(0)) with "R" -> true | _ -> false) | _ ->false) |_->false ;; *) let list_of_sign s = let open Context.Named.Declaration in List.map (function LocalAssum (name, typ) -> name, typ | LocalDef (name, _, typ) -> name, typ) s;; let mkAppL a = let l = Array.to_list a in mkApp(List.hd l, Array.of_list (List.tl l)) ;; exception GoalDone (* Résolution d'inéquations linéaires dans R *) let rec fourier () = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; let goal = strip_outer_cast concl in let fhyp=Id.of_string "new_hyp_for_fourier" in (* si le but est une inéquation, on introduit son contraire, et le but à prouver devient False *) try match (kind_of_term goal) with App (f,args) -> (match (string_of_R_constr f) with "Rlt" -> (Tacticals.New.tclTHEN (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_ge_lt)) (intro_using fhyp)) (fourier ())) |"Rle" -> (Tacticals.New.tclTHEN (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_gt_le)) (intro_using fhyp)) (fourier ())) |"Rgt" -> (Tacticals.New.tclTHEN (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_le_gt)) (intro_using fhyp)) (fourier ())) |"Rge" -> (Tacticals.New.tclTHEN (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_lt_ge)) (intro_using fhyp)) (fourier ())) |_-> raise GoalDone) |_-> raise GoalDone with GoalDone -> (* les hypothèses *) let hyps = List.map (fun (h,t)-> (mkVar h,t)) (list_of_sign (Proofview.Goal.hyps gl)) in let lineq =ref [] in List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) with NoIneq -> ()) hyps; (* lineq = les inéquations découlant des hypothèses *) if !lineq=[] then CErrors.error "No inequalities"; let res=fourier_lineq (!lineq) in let tac=ref (Proofview.tclUNIT ()) in if res=[] then CErrors.error "fourier failed" (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *) else (match res with [(cres,sres,lc)]-> (* lc=coefficients multiplicateurs des inéquations qui donnent 0 if c<>r0 then (lutil:=(h,c)::(!lutil)(*; print_rational(c);print_string " "*))) (List.combine (!lineq) lc); (* on construit la combinaison linéaire des inéquation *) (match (!lutil) with (h1,c1)::lutil -> let s=ref (h1.hstrict) in let t1=ref (mkAppL [|get coq_Rmult; rational_to_real c1; h1.hleft|]) in let t2=ref (mkAppL [|get coq_Rmult; rational_to_real c1; h1.hright|]) in List.iter (fun (h,c) -> s:=(!s)||(h.hstrict); t1:=(mkAppL [|get coq_Rplus; !t1; mkAppL [|get coq_Rmult; rational_to_real c; h.hleft|] |]); t2:=(mkAppL [|get coq_Rplus; !t2; mkAppL [|get coq_Rmult; rational_to_real c; h.hright|] |])) lutil; let ineq=mkAppL [|if (!s) then get coq_Rlt else get coq_Rle; !t1; !t2 |] in let tc=rational_to_real cres in (* puis sa preuve *) let tac1=ref (if h1.hstrict then (Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt)) [tac_use h1; tac_zero_inf_pos gl (rational_to_fraction c1)]) else (Tacticals.New.tclTHENS (apply (get coq_Rfourier_le)) [tac_use h1; tac_zero_inf_pos gl (rational_to_fraction c1)])) in s:=h1.hstrict; List.iter (fun (h,c)-> (if (!s) then (if h.hstrict then tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt_lt)) [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)]) else tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt_le)) [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)])) else (if h.hstrict then tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_le_lt)) [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)]) else tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_le_le)) [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)]))); s:=(!s)||(h.hstrict)) lutil; let tac2= if sres then tac_zero_inf_false gl (rational_to_fraction cres) else tac_zero_infeq_false gl (rational_to_fraction cres) in tac:=(Tacticals.New.tclTHENS (cut ineq) [Tacticals.New.tclTHEN (change_concl (mkAppL [| get coq_not; ineq|] )) (Tacticals.New.tclTHEN (apply (if sres then get coq_Rnot_lt_lt else get coq_Rnot_le_le)) (Tacticals.New.tclTHENS (Equality.replace (mkAppL [|get coq_Rminus;!t2;!t1|] ) tc) [tac2; (Tacticals.New.tclTHENS (Equality.replace (mkApp (get coq_Rinv, [|get coq_R1|])) (get coq_R1)) (* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *) [Tacticals.New.tclORELSE (* TODO : Ring.polynom []*) (Proofview.tclUNIT ()) (Proofview.tclUNIT ()); Tacticals.New.pf_constr_of_global (get coq_sym_eqT) (fun symeq -> (Tacticals.New.tclTHEN (apply symeq) (apply (get coq_Rinv_1))))] ) ])); !tac1]); tac:=(Tacticals.New.tclTHENS (cut (get coq_False)) [Tacticals.New.tclTHEN intro (contradiction None); !tac]) |_-> assert false) |_-> assert false ); (* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) !tac (* ((tclABSTRACT None !tac) gl) *) end } ;; (* let fourier_tac x gl = fourier gl ;; let v_fourier = add_tactic "Fourier" fourier_tac *) coq-8.6/plugins/fourier/g_fourier.ml40000644000175000017500000000124613022274260017215 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ fourier () ] END coq-8.6/plugins/fourier/vo.itarget0000644000175000017500000000003313022274260016614 0ustar mdenesmdenesFourier_util.vo Fourier.vo coq-8.6/plugins/cc/0000755000175000017500000000000013022274260013525 5ustar mdenesmdenescoq-8.6/plugins/cc/g_congruence.ml40000644000175000017500000000175313022274260016607 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ congruence_tac 1000 [] ] |[ "congruence" integer(n) ] -> [ congruence_tac n [] ] |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ] |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> [ congruence_tac n l ] END TACTIC EXTEND f_equal [ "f_equal" ] -> [ f_equal ] END coq-8.6/plugins/cc/ccproof.mli0000644000175000017500000000324313022274260015665 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* proof val pcongr: proof -> proof -> proof val ptrans: proof -> proof -> proof val psym: proof -> proof val pax : (Ccalgo.term * Ccalgo.term) Ccalgo.Constrhash.t -> Ccalgo.Constrhash.key -> proof val psymax : (Ccalgo.term * Ccalgo.term) Ccalgo.Constrhash.t -> Ccalgo.Constrhash.key -> proof val pinject : proof -> pconstructor -> int -> int -> proof (** Proof building functions *) val equal_proof : forest -> int -> int -> proof val edge_proof : forest -> (int*int)*equality -> proof val path_proof : forest -> int -> ((int*int)*equality) list -> proof val congr_proof : forest -> int -> int -> proof val ind_proof : forest -> int -> pa_constructor -> int -> pa_constructor -> proof (** Main proof building function *) val build_proof : forest -> [ `Discr of int * pa_constructor * int * pa_constructor | `Prove of int * int ] -> proof coq-8.6/plugins/cc/cctac.mli0000644000175000017500000000143313022274260015306 0ustar mdenesmdenes (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit Proofview.tactic val cc_tactic : int -> constr list -> unit Proofview.tactic val cc_fail : tactic val congruence_tac : int -> constr list -> unit Proofview.tactic val f_equal : unit Proofview.tactic coq-8.6/plugins/cc/ccalgo.mli0000644000175000017500000001356213022274260015467 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* term = app(constr,t) *) type cl = Rep of representative| Eqto of int*equality type vertex = Leaf| Node of (int*int) type node = {mutable clas:cl; mutable cpath: int; mutable constructors: int PacMap.t; vertex:vertex; term:term} type forest= {mutable max_size:int; mutable size:int; mutable map: node array; axioms: (term*term) Constrhash.t; mutable epsilons: pa_constructor list; syms: int Termhash.t} type state type explanation = Discrimination of (int*pa_constructor*int*pa_constructor) | Contradiction of disequality | Incomplete type matching_problem val term_equal : term -> term -> bool val constr_of_term : term -> constr val debug : (unit -> Pp.std_ppcmds) -> unit val forest : state -> forest val axioms : forest -> (term * term) Constrhash.t val epsilons : forest -> pa_constructor list val empty : int -> Proof_type.goal Tacmach.sigma -> state val add_term : state -> term -> int val add_equality : state -> constr -> term -> term -> unit val add_disequality : state -> from -> term -> term -> unit val add_quant : state -> Id.t -> bool -> int * patt_kind * ccpattern * patt_kind * ccpattern -> unit val tail_pac : pa_constructor -> pa_constructor val find : forest -> int -> int val find_pac : forest -> int -> pa_constructor -> int val find_oldest_pac : forest -> int -> pa_constructor -> int val term : forest -> int -> term val get_constructor_info : forest -> int -> cinfo val subterms : forest -> int -> int * int val join_path : forest -> int -> int -> ((int * int) * equality) list * ((int * int) * equality) list val make_fun_table : state -> Int.Set.t PafMap.t val do_match : state -> (quant_eq * int array) list ref -> matching_problem Stack.t -> unit val init_pb_stack : state -> matching_problem Stack.t val paf_of_patt : int Termhash.t -> ccpattern -> pa_fun val find_instances : state -> (quant_eq * int array) list val execute : bool -> state -> explanation option val pr_idx_term : forest -> int -> Pp.std_ppcmds val empty_forest: unit -> forest (*type pa_constructor module PacMap:CSig.MapS with type key=pa_constructor type term = Symb of Term.constr | Eps | Appli of term * term | Constructor of Names.constructor*int*int type rule = Congruence | Axiom of Names.Id.t | Injection of int*int*int*int type equality = {lhs : int; rhs : int; rule : rule} module ST : sig type t val empty : unit -> t val enter : int -> int * int -> t -> unit val query : int * int -> t -> int val delete : int -> t -> unit val delete_list : int list -> t -> unit end module UF : sig type t exception Discriminable of int * int * int * int * t val empty : unit -> t val find : t -> int -> int val size : t -> int -> int val get_constructor : t -> int -> Names.constructor val pac_arity : t -> int -> int * int -> int val mem_node_pac : t -> int -> int * int -> int val add_pacs : t -> int -> pa_constructor PacMap.t -> int list * equality list val term : t -> int -> term val subterms : t -> int -> int * int val add : t -> term -> int val union : t -> int -> int -> equality -> int list * equality list val join_path : t -> int -> int -> ((int*int)*equality) list* ((int*int)*equality) list end val combine_rec : UF.t -> int list -> equality list val process_rec : UF.t -> equality list -> int list val cc : UF.t -> unit val make_uf : (Names.Id.t * (term * term)) list -> UF.t val add_one_diseq : UF.t -> (term * term) -> int * int val add_disaxioms : UF.t -> (Names.Id.t * (term * term)) list -> (Names.Id.t * (int * int)) list val check_equal : UF.t -> int * int -> bool val find_contradiction : UF.t -> (Names.Id.t * (int * int)) list -> (Names.Id.t * (int * int)) *) coq-8.6/plugins/cc/ccalgo.ml0000644000175000017500000007004313022274260015313 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !cc_verbose); optwrite=(fun b -> cc_verbose := b)} in declare_bool_option gdopt (* Signature table *) module ST=struct (* l: sign -> term r: term -> sign *) module IntTable = Hashtbl.Make(Int) module IntPair = struct type t = int * int let equal (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 let hash (i, j) = Hashset.Combine.combine (Int.hash i) (Int.hash j) end module IntPairTable = Hashtbl.Make(IntPair) type t = {toterm: int IntPairTable.t; tosign: (int * int) IntTable.t} let empty ()= {toterm=IntPairTable.create init_size; tosign=IntTable.create init_size} let enter t sign st= if IntPairTable.mem st.toterm sign then anomaly ~label:"enter" (Pp.str "signature already entered") else IntPairTable.replace st.toterm sign t; IntTable.replace st.tosign t sign let query sign st=IntPairTable.find st.toterm sign let delete st t= try let sign=IntTable.find st.tosign t in IntPairTable.remove st.toterm sign; IntTable.remove st.tosign t with Not_found -> () let delete_set st s = Int.Set.iter (delete st) s end type pa_constructor= { cnode : int; arity : int; args : int list} type pa_fun= {fsym:int; fnargs:int} type pa_mark= Fmark of pa_fun | Cmark of pa_constructor module PacOrd = struct type t = pa_constructor let compare { cnode = cnode0; arity = arity0; args = args0 } { cnode = cnode1; arity = arity1; args = args1 } = let cmp = Int.compare cnode0 cnode1 in if cmp = 0 then let cmp' = Int.compare arity0 arity1 in if cmp' = 0 then List.compare Int.compare args0 args1 else cmp' else cmp end module PafOrd = struct type t = pa_fun let compare { fsym = fsym0; fnargs = fnargs0 } { fsym = fsym1; fnargs = fnargs1 } = let cmp = Int.compare fsym0 fsym1 in if cmp = 0 then Int.compare fnargs0 fnargs1 else cmp end module PacMap=Map.Make(PacOrd) module PafMap=Map.Make(PafOrd) type cinfo= {ci_constr: pconstructor; (* inductive type *) ci_arity: int; (* # args *) ci_nhyps: int} (* # projectable args *) let family_eq f1 f2 = match f1, f2 with | Prop Pos, Prop Pos | Prop Null, Prop Null | Type _, Type _ -> true | _ -> false type term= Symb of constr | Product of sorts * sorts | Eps of Id.t | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) let rec term_equal t1 t2 = match t1, t2 with | Symb c1, Symb c2 -> eq_constr_nounivs c1 c2 | Product (s1, t1), Product (s2, t2) -> family_eq s1 s2 && family_eq t1 t2 | Eps i1, Eps i2 -> Id.equal i1 i2 | 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? *) | _ -> false open Hashset.Combine let rec hash_term = function | Symb c -> combine 1 (hash_constr c) | 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 type ccpattern = PApp of term * ccpattern list (* arguments are reversed *) | PVar of int type rule= Congruence | Axiom of constr * bool | Injection of int * pa_constructor * int * pa_constructor * int type from= Goal | Hyp of constr | HeqG of constr | HeqnH of constr * constr type 'a eq = {lhs:int;rhs:int;rule:'a} type equality = rule eq type disequality = from eq type patt_kind = Normal | Trivial of types | Creates_variables type quant_eq = { qe_hyp_id: Id.t; qe_pol: bool; qe_nvars:int; qe_lhs: ccpattern; qe_lhs_valid:patt_kind; qe_rhs: ccpattern; qe_rhs_valid:patt_kind } let swap eq : equality = let swap_rule=match eq.rule with Congruence -> Congruence | Injection (i,pi,j,pj,k) -> Injection (j,pj,i,pi,k) | Axiom (id,reversed) -> Axiom (id,not reversed) in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule} type inductive_status = Unknown | Partial of pa_constructor | Partial_applied | Total of (int * pa_constructor) type representative= {mutable weight:int; mutable lfathers:Int.Set.t; mutable fathers:Int.Set.t; mutable inductive_status: inductive_status; class_type : Term.types; mutable functions: Int.Set.t PafMap.t} (*pac -> term = app(constr,t) *) type cl = Rep of representative| Eqto of int*equality type vertex = Leaf| Node of (int*int) type node = {mutable clas:cl; mutable cpath: int; mutable constructors: int PacMap.t; vertex:vertex; term:term} module Constrhash = Hashtbl.Make (struct type t = constr let equal = eq_constr_nounivs let hash = hash_constr end) module Typehash = Constrhash module Termhash = Hashtbl.Make (struct type t = term let equal = term_equal let hash = hash_term end) module Identhash = Hashtbl.Make (struct type t = Id.t let equal = Id.equal let hash = Id.hash end) type forest= {mutable max_size:int; mutable size:int; mutable map: node array; axioms: (term*term) Constrhash.t; mutable epsilons: pa_constructor list; syms: int Termhash.t} type state = {uf: forest; sigtable:ST.t; mutable terms: Int.Set.t; combine: equality Queue.t; marks: (int * pa_mark) Queue.t; mutable diseq: disequality list; mutable quant: quant_eq list; mutable pa_classes: Int.Set.t; q_history: (int array) Identhash.t; mutable rew_depth:int; mutable changed:bool; by_type: Int.Set.t Typehash.t; mutable gls:Proof_type.goal Tacmach.sigma} let dummy_node = { clas=Eqto (min_int,{lhs=min_int;rhs=min_int;rule=Congruence}); cpath=min_int; constructors=PacMap.empty; vertex=Leaf; term=Symb (mkRel min_int) } let empty_forest() = { max_size=init_size; size=0; map=Array.make init_size dummy_node; epsilons=[]; axioms=Constrhash.create init_size; syms=Termhash.create init_size } let empty depth gls:state = { uf= empty_forest (); terms=Int.Set.empty; combine=Queue.create (); marks=Queue.create (); sigtable=ST.empty (); diseq=[]; quant=[]; pa_classes=Int.Set.empty; q_history=Identhash.create init_size; rew_depth=depth; by_type=Constrhash.create init_size; changed=false; gls=gls } let forest state = state.uf let compress_path uf i j = uf.map.(j).cpath<-i let rec find_aux uf visited i= let j = uf.map.(i).cpath in if j<0 then let _ = List.iter (compress_path uf i) visited in i else find_aux uf (i::visited) j let find uf i= find_aux uf [] i let get_representative uf i= match uf.map.(i).clas with Rep r -> r | _ -> anomaly ~label:"get_representative" (Pp.str "not a representative") let get_constructors uf i= uf.map.(i).constructors let find_pac uf i pac = PacMap.find pac (get_constructors uf i) let rec find_oldest_pac uf i pac= try PacMap.find pac (get_constructors uf i) with Not_found -> match uf.map.(i).clas with Eqto (j,_) -> find_oldest_pac uf j pac | Rep _ -> raise Not_found let get_constructor_info uf i= match uf.map.(i).term with Constructor cinfo->cinfo | _ -> anomaly ~label:"get_constructor" (Pp.str "not a constructor") let size uf i= (get_representative uf i).weight let axioms uf = uf.axioms let epsilons uf = uf.epsilons let add_lfather uf i t= let r=get_representative uf i in r.weight<-r.weight+1; r.lfathers<-Int.Set.add t r.lfathers; r.fathers <-Int.Set.add t r.fathers let add_rfather uf i t= let r=get_representative uf i in r.weight<-r.weight+1; r.fathers <-Int.Set.add t r.fathers exception Discriminable of int * pa_constructor * int * pa_constructor let append_pac t p = {p with arity=pred p.arity;args=t::p.args} let tail_pac p= {p with arity=succ p.arity;args=List.tl p.args} let fsucc paf = {paf with fnargs=succ paf.fnargs} let add_pac node pac t = if not (PacMap.mem pac node.constructors) then node.constructors<-PacMap.add pac t node.constructors let add_paf rep paf t = let already = try PafMap.find paf rep.functions with Not_found -> Int.Set.empty in rep.functions<- PafMap.add paf (Int.Set.add t already) rep.functions let term uf i=uf.map.(i).term let subterms uf i= match uf.map.(i).vertex with Node(j,k) -> (j,k) | _ -> anomaly ~label:"subterms" (Pp.str "not a node") let signature uf i= let j,k=subterms uf i in (find uf j,find uf k) let next uf= let size=uf.size in let nsize= succ size in if Int.equal nsize uf.max_size then let newmax=uf.max_size * 3 / 2 + 1 in let newmap=Array.make newmax dummy_node in begin uf.max_size<-newmax; Array.blit uf.map 0 newmap 0 size; uf.map<-newmap end else (); uf.size<-nsize; size let new_representative typ = {weight=0; lfathers=Int.Set.empty; fathers=Int.Set.empty; inductive_status=Unknown; class_type=typ; functions=PafMap.empty} (* rebuild a constr from an applicative term *) let _A_ = Name (Id.of_string "A") let _B_ = Name (Id.of_string "A") let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2) let cc_product s1 s2 = mkLambda(_A_,mkSort(s1), mkLambda(_B_,mkSort(s2),_body_)) let rec constr_of_term = function Symb s-> applist_projection s [] | Product(s1,s2) -> cc_product s1 s2 | Eps id -> mkVar id | Constructor cinfo -> mkConstructU cinfo.ci_constr | Appli (s1,s2)-> make_app [(constr_of_term s2)] s1 and make_app l=function Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1 | other -> applist_proj other l and applist_proj c l = match c with | Symb s -> applist_projection s l | _ -> applistc (constr_of_term c) l and applist_projection c l = match kind_of_term c with | Const c when Environ.is_projection (fst c) (Global.env()) -> let p = Projection.make (fst c) false in (match l with | [] -> (* Expand the projection *) let ty,_ = Typeops.type_of_constant (Global.env ()) c in let pb = Environ.lookup_projection p (Global.env()) in let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx | hd :: tl -> applistc (mkProj (p, hd)) tl) | _ -> applistc c l let rec canonize_name c = let func = canonize_name in match kind_of_term c with | Const (kn,u) -> let canon_const = constant_of_kn (canonical_con kn) in (mkConstU (canon_const,u)) | Ind ((kn,i),u) -> let canon_mind = mind_of_kn (canonical_mind kn) in (mkIndU ((canon_mind,i),u)) | Construct (((kn,i),j),u) -> let canon_mind = mind_of_kn (canonical_mind kn) in mkConstructU (((canon_mind,i),j),u) | Prod (na,t,ct) -> mkProd (na,func t, func ct) | Lambda (na,t,ct) -> mkLambda (na, func t,func ct) | LetIn (na,b,t,ct) -> mkLetIn (na, func b,func t,func ct) | App (ct,l) -> mkApp (func ct,Array.smartmap func l) | Proj(p,c) -> let p' = Projection.map (fun kn -> constant_of_kn (canonical_con kn)) p in (mkProj (p', func c)) | _ -> c (* rebuild a term from a pattern and a substitution *) let build_subst uf subst = Array.map (fun i -> try term uf i with e when CErrors.noncritical e -> anomaly (Pp.str "incomplete matching")) subst let rec inst_pattern subst = function PVar i -> subst.(pred i) | PApp (t, args) -> List.fold_right (fun spat f -> Appli (f,inst_pattern subst spat)) args t let pr_idx_term uf i = str "[" ++ int i ++ str ":=" ++ Termops.print_constr (constr_of_term (term uf i)) ++ str "]" let pr_term t = str "[" ++ Termops.print_constr (constr_of_term t) ++ str "]" let rec add_term state t= let uf=state.uf in try Termhash.find uf.syms t with Not_found -> let b=next uf in let trm = constr_of_term t in let typ = pf_unsafe_type_of state.gls trm in let typ = canonize_name typ in let new_node= match t with Symb _ | Product (_,_) -> let paf = {fsym=b; fnargs=0} in Queue.add (b,Fmark paf) state.marks; {clas= Rep (new_representative typ); cpath= -1; constructors=PacMap.empty; vertex= Leaf; term= t} | Eps id -> {clas= Rep (new_representative typ); cpath= -1; constructors=PacMap.empty; vertex= Leaf; term= t} | Appli (t1,t2) -> let i1=add_term state t1 and i2=add_term state t2 in add_lfather uf (find uf i1) b; add_rfather uf (find uf i2) b; state.terms<-Int.Set.add b state.terms; {clas= Rep (new_representative typ); cpath= -1; constructors=PacMap.empty; vertex= Node(i1,i2); term= t} | Constructor cinfo -> let paf = {fsym=b; fnargs=0} in Queue.add (b,Fmark paf) state.marks; let pac = {cnode= b; arity= cinfo.ci_arity; args=[]} in Queue.add (b,Cmark pac) state.marks; {clas=Rep (new_representative typ); cpath= -1; constructors=PacMap.empty; vertex=Leaf; term=t} in uf.map.(b)<-new_node; Termhash.add uf.syms t b; Typehash.replace state.by_type typ (Int.Set.add b (try Typehash.find state.by_type typ with Not_found -> Int.Set.empty)); b let add_equality state c s t= let i = add_term state s in let j = add_term state t in Queue.add {lhs=i;rhs=j;rule=Axiom(c,false)} state.combine; Constrhash.add state.uf.axioms c (s,t) let add_disequality state from s t = let i = add_term state s in let j = add_term state t in state.diseq<-{lhs=i;rhs=j;rule=from}::state.diseq let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) = state.quant<- {qe_hyp_id= id; qe_pol= pol; qe_nvars=nvars; qe_lhs= patt1; qe_lhs_valid=valid1; qe_rhs= patt2; qe_rhs_valid=valid2}::state.quant let is_redundant state id args = try let norm_args = Array.map (find state.uf) args in let prev_args = Identhash.find_all state.q_history id in List.exists (fun old_args -> Util.Array.for_all2 (fun i j -> Int.equal i (find state.uf j)) norm_args old_args) prev_args with Not_found -> false let add_inst state (inst,int_subst) = Control.check_for_interrupt (); if state.rew_depth > 0 then if is_redundant state inst.qe_hyp_id int_subst then debug (fun () -> str "discarding redundant (dis)equality") else begin Identhash.add state.q_history inst.qe_hyp_id int_subst; let subst = build_subst (forest state) int_subst in let prfhead= mkVar inst.qe_hyp_id in let args = Array.map constr_of_term subst in let _ = Array.rev args in (* highest deBruijn index first *) let prf= mkApp(prfhead,args) in let s = inst_pattern subst inst.qe_lhs and t = inst_pattern subst inst.qe_rhs in state.changed<-true; state.rew_depth<-pred state.rew_depth; if inst.qe_pol then begin debug (fun () -> (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Termops.print_constr prf ++ str " : " ++ pr_term s ++ str " == " ++ pr_term t ++ str "]")); add_equality state prf s t end else begin debug (fun () -> (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Termops.print_constr prf ++ str " : " ++ pr_term s ++ str " <> " ++ pr_term t ++ str "]")); add_disequality state (Hyp prf) s t end end let link uf i j eq = (* links i -> j *) let node=uf.map.(i) in node.clas<-Eqto (j,eq); node.cpath<-j let rec down_path uf i l= match uf.map.(i).clas with Eqto (j,eq) ->down_path uf j (((i,j),eq)::l) | Rep _ ->l let eq_pair (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 let rec min_path=function ([],l2)->([],l2) | (l1,[])->(l1,[]) | (((c1,t1)::q1),((c2,t2)::q2)) when eq_pair c1 c2 -> min_path (q1,q2) | cpl -> cpl let join_path uf i j= assert (Int.equal (find uf i) (find uf j)); min_path (down_path uf i [],down_path uf j []) let union state i1 i2 eq= debug (fun () -> str "Linking " ++ pr_idx_term state.uf i1 ++ str " and " ++ pr_idx_term state.uf i2 ++ str "."); let r1= get_representative state.uf i1 and r2= get_representative state.uf i2 in link state.uf i1 i2 eq; Constrhash.replace state.by_type r1.class_type (Int.Set.remove i1 (try Constrhash.find state.by_type r1.class_type with Not_found -> Int.Set.empty)); let f= Int.Set.union r1.fathers r2.fathers in r2.weight<-Int.Set.cardinal f; r2.fathers<-f; r2.lfathers<-Int.Set.union r1.lfathers r2.lfathers; ST.delete_set state.sigtable r1.fathers; state.terms<-Int.Set.union state.terms r1.fathers; PacMap.iter (fun pac b -> Queue.add (b,Cmark pac) state.marks) state.uf.map.(i1).constructors; PafMap.iter (fun paf -> Int.Set.iter (fun b -> Queue.add (b,Fmark paf) state.marks)) r1.functions; match r1.inductive_status,r2.inductive_status with Unknown,_ -> () | Partial pac,Unknown -> r2.inductive_status<-Partial pac; state.pa_classes<-Int.Set.remove i1 state.pa_classes; state.pa_classes<-Int.Set.add i2 state.pa_classes | Partial _ ,(Partial _ |Partial_applied) -> state.pa_classes<-Int.Set.remove i1 state.pa_classes | Partial_applied,Unknown -> r2.inductive_status<-Partial_applied | Partial_applied,Partial _ -> state.pa_classes<-Int.Set.remove i2 state.pa_classes; r2.inductive_status<-Partial_applied | Total cpl,Unknown -> r2.inductive_status<-Total cpl; | Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks | _,_ -> () let merge eq state = (* merge and no-merge *) debug (fun () -> str "Merging " ++ pr_idx_term state.uf eq.lhs ++ str " and " ++ pr_idx_term state.uf eq.rhs ++ str "."); let uf=state.uf in let i=find uf eq.lhs and j=find uf eq.rhs in if not (Int.equal i j) then if (size uf i)<(size uf j) then union state i j eq else union state j i (swap eq) let update t state = (* update 1 and 2 *) debug (fun () -> str "Updating term " ++ pr_idx_term state.uf t ++ str "."); let (i,j) as sign = signature state.uf t in let (u,v) = subterms state.uf t in let rep = get_representative state.uf i in begin match rep.inductive_status with Partial _ -> rep.inductive_status <- Partial_applied; state.pa_classes <- Int.Set.remove i state.pa_classes | _ -> () end; PacMap.iter (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) (get_constructors state.uf i); PafMap.iter (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) rep.functions; try let s = ST.query sign state.sigtable in Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine with Not_found -> ST.enter t sign state.sigtable let process_function_mark t rep paf state = add_paf rep paf t; state.terms<-Int.Set.union rep.lfathers state.terms let process_constructor_mark t i rep pac state = add_pac state.uf.map.(i) pac t; match rep.inductive_status with Total (s,opac) -> if not (Int.equal pac.cnode opac.cnode) then (* Conflict *) raise (Discriminable (s,opac,t,pac)) else (* Match *) let cinfo = get_constructor_info state.uf pac.cnode in let rec f n oargs args= if n > 0 then match (oargs,args) with s1::q1,s2::q2-> Queue.add {lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)} state.combine; f (n-1) q1 q2 | _-> anomaly ~label:"add_pacs" (Pp.str "weird error in injection subterms merge") in f cinfo.ci_nhyps opac.args pac.args | Partial_applied | Partial _ -> (* add_pac state.uf.map.(i) pac t; *) state.terms<-Int.Set.union rep.lfathers state.terms | Unknown -> if Int.equal pac.arity 0 then rep.inductive_status <- Total (t,pac) else begin (* add_pac state.uf.map.(i) pac t; *) state.terms<-Int.Set.union rep.lfathers state.terms; rep.inductive_status <- Partial pac; state.pa_classes<- Int.Set.add i state.pa_classes end let process_mark t m state = debug (fun () -> str "Processing mark for term " ++ pr_idx_term state.uf t ++ str "."); let i=find state.uf t in let rep=get_representative state.uf i in match m with Fmark paf -> process_function_mark t rep paf state | Cmark pac -> process_constructor_mark t i rep pac state type explanation = Discrimination of (int*pa_constructor*int*pa_constructor) | Contradiction of disequality | Incomplete let check_disequalities state = let uf=state.uf in let rec check_aux = function | dis::q -> let (info, ans) = if Int.equal (find uf dis.lhs) (find uf dis.rhs) then (str "Yes", Some dis) else (str "No", check_aux q) in let _ = debug (fun () -> str "Checking if " ++ pr_idx_term state.uf dis.lhs ++ str " = " ++ pr_idx_term state.uf dis.rhs ++ str " ... " ++ info) in ans | [] -> None in check_aux state.diseq let one_step state = try let eq = Queue.take state.combine in merge eq state; true with Queue.Empty -> try let (t,m) = Queue.take state.marks in process_mark t m state; true with Queue.Empty -> try let t = Int.Set.choose state.terms in state.terms<-Int.Set.remove t state.terms; update t state; true with Not_found -> false let __eps__ = Id.of_string "_eps_" let new_state_var typ state = let id = pf_get_new_id __eps__ state.gls in let {it=gl ; sigma=sigma} = state.gls in let gls = Goal.V82.new_goal_with sigma gl [Context.Named.Declaration.LocalAssum (id,typ)] in state.gls<- gls; id let complete_one_class state i= match (get_representative state.uf i).inductive_status with Partial pac -> let rec app t typ n = if n<=0 then t else let _,etyp,rest= destProd typ in let id = new_state_var etyp state in app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in let _c = pf_unsafe_type_of state.gls (constr_of_term (term state.uf pac.cnode)) in let _args = List.map (fun i -> constr_of_term (term state.uf i)) pac.args in let typ = prod_applist _c (List.rev _args) in let ct = app (term state.uf i) typ pac.arity in state.uf.epsilons <- pac :: state.uf.epsilons; ignore (add_term state ct) | _ -> anomaly (Pp.str "wrong incomplete class") let complete state = Int.Set.iter (complete_one_class state) state.pa_classes type matching_problem = {mp_subst : int array; mp_inst : quant_eq; mp_stack : (ccpattern*int) list } let make_fun_table state = let uf= state.uf in let funtab=ref PafMap.empty in Array.iteri (fun i inode -> if i < uf.size then match inode.clas with Rep rep -> PafMap.iter (fun paf _ -> let elem = try PafMap.find paf !funtab with Not_found -> Int.Set.empty in funtab:= PafMap.add paf (Int.Set.add i elem) !funtab) rep.functions | _ -> ()) state.uf.map; !funtab let do_match state res pb_stack = let mp=Stack.pop pb_stack in match mp.mp_stack with [] -> res:= (mp.mp_inst,mp.mp_subst) :: !res | (patt,cl)::remains -> let uf=state.uf in match patt with PVar i -> if mp.mp_subst.(pred i)<0 then begin mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *) Stack.push {mp with mp_stack=remains} pb_stack end else if Int.equal mp.mp_subst.(pred i) cl then Stack.push {mp with mp_stack=remains} pb_stack else (* mismatch for non-linear variable in pattern *) () | PApp (f,[]) -> begin try let j=Termhash.find uf.syms f in if Int.equal (find uf j) cl then Stack.push {mp with mp_stack=remains} pb_stack with Not_found -> () end | PApp(f, ((last_arg::rem_args) as args)) -> try let j=Termhash.find uf.syms f in let paf={fsym=j;fnargs=List.length args} in let rep=get_representative uf cl in let good_terms = PafMap.find paf rep.functions in let aux i = let (s,t) = signature state.uf i in Stack.push {mp with mp_subst=Array.copy mp.mp_subst; mp_stack= (PApp(f,rem_args),s) :: (last_arg,t) :: remains} pb_stack in Int.Set.iter aux good_terms with Not_found -> () let paf_of_patt syms = function PVar _ -> invalid_arg "paf_of_patt: pattern is trivial" | PApp (f,args) -> {fsym=Termhash.find syms f; fnargs=List.length args} let init_pb_stack state = let syms= state.uf.syms in let pb_stack = Stack.create () in let funtab = make_fun_table state in let aux inst = begin let good_classes = match inst.qe_lhs_valid with Creates_variables -> Int.Set.empty | Normal -> begin try let paf= paf_of_patt syms inst.qe_lhs in PafMap.find paf funtab with Not_found -> Int.Set.empty end | Trivial typ -> begin try Typehash.find state.by_type typ with Not_found -> Int.Set.empty end in Int.Set.iter (fun i -> Stack.push {mp_subst = Array.make inst.qe_nvars (-1); mp_inst=inst; mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes end; begin let good_classes = match inst.qe_rhs_valid with Creates_variables -> Int.Set.empty | Normal -> begin try let paf= paf_of_patt syms inst.qe_rhs in PafMap.find paf funtab with Not_found -> Int.Set.empty end | Trivial typ -> begin try Typehash.find state.by_type typ with Not_found -> Int.Set.empty end in Int.Set.iter (fun i -> Stack.push {mp_subst = Array.make inst.qe_nvars (-1); mp_inst=inst; mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes end in List.iter aux state.quant; pb_stack let find_instances state = let pb_stack= init_pb_stack state in let res =ref [] in let _ = debug (fun () -> str "Running E-matching algorithm ... "); try while true do Control.check_for_interrupt (); do_match state res pb_stack done; anomaly (Pp.str "get out of here !") with Stack.Empty -> () in !res let rec execute first_run state = debug (fun () -> str "Executing ... "); try while Control.check_for_interrupt (); one_step state do () done; match check_disequalities state with None -> if not(Int.Set.is_empty state.pa_classes) then begin debug (fun () -> str "First run was incomplete, completing ... "); complete state; execute false state end else if state.rew_depth>0 then let l=find_instances state in List.iter (add_inst state) l; if state.changed then begin state.changed <- false; execute true state end else begin debug (fun () -> str "Out of instances ... "); None end else begin debug (fun () -> str "Out of depth ... "); None end | Some dis -> Some begin if first_run then Contradiction dis else Incomplete end with Discriminable(s,spac,t,tpac) -> Some begin if first_run then Discrimination (s,spac,t,tpac) else Incomplete end coq-8.6/plugins/cc/README0000644000175000017500000000104013022274260014400 0ustar mdenesmdenes cctac: congruence-closure for coq author: Pierre Corbineau, Stage de DEA au LSV, ENS Cachan Thèse au LRI, Université Paris Sud XI Files : - ccalgo.ml : congruence closure algorithm - ccproof.ml : proof generation code - cctac.ml4 : the tactic itself - CCSolve.v : a small Ltac tactic based on congruence Known Bugs : the congruence tactic can fail due to type dependencies. Related documents: Peter J. Downey, Ravi Sethi, and Robert E. Tarjan. Variations on the common subexpression problem. JACM, 27(4):758-771, October 1980. coq-8.6/plugins/cc/cctac.ml0000644000175000017500000004563113022274260015145 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* CClosure.whd_val infos (CClosure.inject t)) let whd_delta env= let infos=CClosure.create_clos_infos CClosure.all env in (fun t -> CClosure.whd_val infos (CClosure.inject t)) (* decompose member of equality in an applicative format *) (** FIXME: evar leak *) let sf_of env sigma c = e_sort_of env (ref sigma) c let rec decompose_term env sigma t= match kind_of_term (whd env t) with App (f,args)-> let tf=decompose_term env sigma f in let targs=Array.map (decompose_term env sigma) args in Array.fold_left (fun s t->Appli (s,t)) tf targs | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) -> let b = Termops.pop _b in let sort_b = sf_of env sigma b in let sort_a = sf_of env sigma a in Appli(Appli(Product (sort_a,sort_b) , decompose_term env sigma a), decompose_term env sigma b) | Construct c -> let (((mind,i_ind),i_con),u)= c in let canon_mind = mind_of_kn (canonical_mind mind) in let canon_ind = canon_mind,i_ind in let (oib,_)=Global.lookup_inductive (canon_ind) in let nargs=constructor_nallargs_env env (canon_ind,i_con) in Constructor {ci_constr= ((canon_ind,i_con),u); ci_arity=nargs; ci_nhyps=nargs-oib.mind_nparams} | Ind c -> let (mind,i_ind),u = c in let canon_mind = mind_of_kn (canonical_mind mind) in let canon_ind = canon_mind,i_ind in (Symb (mkIndU (canon_ind,u))) | Const (c,u) -> let canon_const = constant_of_kn (canonical_con c) in (Symb (mkConstU (canon_const,u))) | Proj (p, c) -> let canon_const kn = constant_of_kn (canonical_con kn) in let p' = Projection.map canon_const p in (Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c)) | _ -> let t = strip_outer_cast t in if closed0 t then Symb t else raise Not_found (* decompose equality in members and type *) open Globnames let atom_of_constr env sigma term = let wh = (whd_delta env term) in let kot = kind_of_term wh in match kot with App (f,args)-> if is_global (Lazy.force _eq) f && Int.equal (Array.length args) 3 then `Eq (args.(0), decompose_term env sigma args.(1), decompose_term env sigma args.(2)) else `Other (decompose_term env sigma term) | _ -> `Other (decompose_term env sigma term) let rec pattern_of_constr env sigma c = match kind_of_term (whd env c) with App (f,args)-> let pf = decompose_term env sigma f in let pargs,lrels = List.split (Array.map_to_list (pattern_of_constr env sigma) args) in PApp (pf,List.rev pargs), List.fold_left Int.Set.union Int.Set.empty lrels | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) -> let b = Termops.pop _b in let pa,sa = pattern_of_constr env sigma a in let pb,sb = pattern_of_constr env sigma b in let sort_b = sf_of env sigma b in let sort_a = sf_of env sigma a in PApp(Product (sort_a,sort_b), [pa;pb]),(Int.Set.union sa sb) | Rel i -> PVar i,Int.Set.singleton i | _ -> let pf = decompose_term env sigma c in PApp (pf,[]),Int.Set.empty let non_trivial = function PVar _ -> false | _ -> true let patterns_of_constr env sigma nrels term= let f,args= try destApp (whd_delta env term) with DestKO -> raise Not_found in if is_global (Lazy.force _eq) f && Int.equal (Array.length args) 3 then let patt1,rels1 = pattern_of_constr env sigma args.(1) and patt2,rels2 = pattern_of_constr env sigma args.(2) in let valid1 = if not (Int.equal (Int.Set.cardinal rels1) nrels) then Creates_variables else if non_trivial patt1 then Normal else Trivial args.(0) and valid2 = if not (Int.equal (Int.Set.cardinal rels2) nrels) then Creates_variables else if non_trivial patt2 then Normal else Trivial args.(0) in if valid1 != Creates_variables || valid2 != Creates_variables then nrels,valid1,patt1,valid2,patt2 else raise Not_found else raise Not_found let rec quantified_atom_of_constr env sigma nrels term = match kind_of_term (whd_delta env term) with Prod (id,atom,ff) -> if is_global (Lazy.force _False) ff then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma (succ nrels) ff | _ -> let patts=patterns_of_constr env sigma nrels term in `Rule patts let litteral_of_constr env sigma term= match kind_of_term (whd_delta env term) with | Prod (id,atom,ff) -> if is_global (Lazy.force _False) ff then match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) | `Other(p) -> `Nother(p) else begin try quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma 1 ff with Not_found -> `Other (decompose_term env sigma term) end | _ -> atom_of_constr env sigma term (* store all equalities from the context *) let make_prb gls depth additionnal_terms = let env=pf_env gls in let sigma=sig_sig gls in let state = empty depth gls in let pos_hyps = ref [] in let neg_hyps =ref [] in List.iter (fun c -> let t = decompose_term env sigma c in ignore (add_term state t)) additionnal_terms; List.iter (fun decl -> let (id,_,e) = Context.Named.Declaration.to_tuple decl in begin let cid=mkVar id in match litteral_of_constr env sigma e with `Eq (t,a,b) -> add_equality state cid a b | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b | `Other ph -> List.iter (fun (cidn,nh) -> add_disequality state (HeqnH (cid,cidn)) ph nh) !neg_hyps; pos_hyps:=(cid,ph):: !pos_hyps | `Nother nh -> List.iter (fun (cidp,ph) -> add_disequality state (HeqnH (cidp,cid)) ph nh) !pos_hyps; neg_hyps:=(cid,nh):: !neg_hyps | `Rule patts -> add_quant state id true patts | `Nrule patts -> add_quant state id false patts end) (Environ.named_context_of_val (Goal.V82.nf_hyps gls.sigma gls.it)); begin match atom_of_constr env sigma (Evarutil.nf_evar sigma (pf_concl gls)) with `Eq (t,a,b) -> add_disequality state Goal a b | `Other g -> List.iter (fun (idp,ph) -> add_disequality state (HeqG idp) ph g) !pos_hyps end; state (* indhyps builds the array of arrays of constructor hyps for (ind largs) *) let build_projection intype (cstr:pconstructor) special default gls= let ci= (snd(fst cstr)) in let body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in let id=pf_get_new_id (Id.of_string "t") gls in mkLambda(Name id,intype,body) (* generate an adhoc tactic following the proof tree *) let _M =mkMeta let app_global f args k = Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args))) let new_app_global f args k = Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args))) let new_refine c = Proofview.V82.tactic (refine c) let assert_before n c = Proofview.Goal.enter { enter = begin fun gl -> let evm, _ = Tacmach.New.pf_apply type_of gl c in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (assert_before n c) end } let refresh_type env evm ty = Evarsolve.refresh_universes ~status:Evd.univ_flexible ~refreshset:true (Some false) env evm ty let refresh_universes ty k = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let evm = Tacmach.New.project gl in let evm, ty = refresh_type env evm ty in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (k ty) end } let rec proof_tac p : unit Proofview.tactic = Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of t = Tacmach.New.pf_unsafe_type_of gl t in try (* type_of can raise exceptions *) match p.p_rule with Ax c -> exact_check c | SymAx c -> let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in refresh_universes (type_of l) (fun typ -> new_app_global _sym_eq [|typ;r;l;c|] exact_check) | Refl t -> let lr = constr_of_term t in refresh_universes (type_of lr) (fun typ -> new_app_global _refl_equal [|typ;constr_of_term t|] exact_check) | Trans (p1,p2)-> let t1 = constr_of_term p1.p_lhs and t2 = constr_of_term p1.p_rhs and t3 = constr_of_term p2.p_rhs in refresh_universes (type_of t2) (fun typ -> let prf = new_app_global _trans_eq [|typ;t1;t2;t3;_M 1;_M 2|] in Tacticals.New.tclTHENS (prf new_refine) [(proof_tac p1);(proof_tac p2)]) | Congr (p1,p2)-> let tf1=constr_of_term p1.p_lhs and tx1=constr_of_term p2.p_lhs and tf2=constr_of_term p1.p_rhs and tx2=constr_of_term p2.p_rhs in refresh_universes (type_of tf1) (fun typf -> refresh_universes (type_of tx1) (fun typx -> refresh_universes (type_of (mkApp (tf1,[|tx1|]))) (fun typfx -> let id = Tacmach.New.of_old (fun gls -> pf_get_new_id (Id.of_string "f") gls) gl in let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in let lemma1 = app_global _f_equal [|typf;typfx;appx1;tf1;tf2;_M 1|] in let lemma2 = app_global _f_equal [|typx;typfx;tf2;tx1;tx2;_M 1|] in let prf = app_global _trans_eq [|typfx; mkApp(tf1,[|tx1|]); mkApp(tf2,[|tx1|]); mkApp(tf2,[|tx2|]);_M 2;_M 3|] in Tacticals.New.tclTHENS (Proofview.V82.tactic (prf refine)) [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma1 refine)) (proof_tac p1); Tacticals.New.tclFIRST [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma2 refine)) (proof_tac p2); reflexivity; Tacticals.New.tclZEROMSG (Pp.str "I don't know how to handle dependent equality")]]))) | Inject (prf,cstr,nargs,argind) -> let ti=constr_of_term prf.p_lhs in let tj=constr_of_term prf.p_rhs in let default=constr_of_term p.p_lhs in let special=mkRel (1+nargs-argind) in refresh_universes (type_of ti) (fun intype -> refresh_universes (type_of default) (fun outtype -> let proj = Tacmach.New.of_old (build_projection intype cstr special default) gl in let injt= app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf))) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end } let refute_tac c t1 t2 p = Proofview.Goal.nf_enter { enter = begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in let false_t=mkApp (c,[|mkVar hid|]) in let k intype = let neweq= new_app_global _eq [|intype;tt1;tt2|] in Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; simplest_elim false_t] in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt1) k end } let refine_exact_check c gl = let evm, _ = pf_apply type_of gl c in Tacticals.tclTHEN (Refiner.tclEVARS evm) (Proofview.V82.of_tactic (exact_check c)) gl let convert_to_goal_tac c t1 t2 p = Proofview.Goal.nf_enter { enter = begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let k sort = let neweq= new_app_global _eq [|sort;tt1;tt2|] in let e = Tacmach.New.of_old (pf_get_new_id (Id.of_string "e")) gl in let x = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in let identity=mkLambda (Name x,sort,mkRel 1) in let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in Tacticals.New.tclTHENS (neweq (assert_before (Name e))) [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)] in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt2) k end } let convert_to_hyp_tac c1 t1 c2 t2 p = Proofview.Goal.nf_enter { enter = begin fun gl -> let tt2=constr_of_term t2 in let h = Tacmach.New.of_old (pf_get_new_id (Id.of_string "H")) gl in let false_t=mkApp (c2,[|mkVar h|]) in Tacticals.New.tclTHENS (assert_before (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; simplest_elim false_t] end } let discriminate_tac (cstr,u as cstru) p = Proofview.Goal.nf_enter { enter = begin fun gl -> let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let xid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in let identity = Universes.constr_of_global (Lazy.force _I) in let trivial = Universes.constr_of_global (Lazy.force _True) in let evm = Tacmach.New.project gl in let evm, intype = refresh_type env evm (Tacmach.New.pf_unsafe_type_of gl t1) in let evm, outtype = Evd.new_sort_variable Evd.univ_flexible evm in let outtype = mkSort outtype in let pred = mkLambda(Name xid,outtype,mkRel 1) in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in let proj = Tacmach.New.of_old (build_projection intype cstru trivial concl) gl in let injt=app_global _f_equal [|intype;outtype;proj;t1;t2;mkVar hid|] in let endt k = injt (fun injt -> app_global _eq_rect [|outtype;trivial;pred;identity;concl;injt|] k) in let neweq=new_app_global _eq [|intype;t1;t2|] in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) (Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)]) end } (* wrap everything *) let build_term_to_complete uf meta pac = let cinfo = get_constructor_info uf pac.cnode in let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in let dummy_args = List.rev (List.init pac.arity meta) in let all_args = List.rev_append real_args dummy_args in applistc (mkConstructU cinfo.ci_constr) all_args let cc_tactic depth additionnal_terms = Proofview.Goal.nf_enter { enter = begin fun gl -> Coqlib.check_required_library Coqlib.logic_module_name; let _ = debug (fun () -> Pp.str "Reading subgoal ...") in let state = Tacmach.New.of_old (fun gls -> make_prb gls depth additionnal_terms) gl in let _ = debug (fun () -> Pp.str "Problem built, solving ...") in let sol = execute true state in let _ = debug (fun () -> Pp.str "Computation completed.") in let uf=forest state in match sol with None -> Tacticals.New.tclFAIL 0 (str "congruence failed") | Some reason -> debug (fun () -> Pp.str "Goal solved, generating proof ..."); match reason with Discrimination (i,ipac,j,jpac) -> let p=build_proof uf (`Discr (i,ipac,j,jpac)) in let cstr=(get_constructor_info uf ipac.cnode).ci_constr in discriminate_tac cstr p | Incomplete -> let env = Proofview.Goal.env gl in let metacnt = ref 0 in let newmeta _ = incr metacnt; _M !metacnt in let terms_to_complete = List.map (build_term_to_complete uf newmeta) (epsilons uf) in Feedback.msg_info (Pp.str "Goal is solvable by congruence but \ some arguments are missing."); Feedback.msg_info (Pp.str " Try " ++ hov 8 begin str "\"congruence with (" ++ prlist_with_sep (fun () -> str ")" ++ spc () ++ str "(") (Termops.print_constr_env env) terms_to_complete ++ str ")\"," end ++ Pp.str " replacing metavariables by arbitrary terms."); Tacticals.New.tclFAIL 0 (str "Incomplete") | Contradiction dis -> let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in let ta=term uf dis.lhs and tb=term uf dis.rhs in match dis.rule with Goal -> proof_tac p | Hyp id -> refute_tac id ta tb p | HeqG id -> convert_to_goal_tac id ta tb p | HeqnH (ida,idb) -> convert_to_hyp_tac ida ta idb tb p end } let cc_fail gls = errorlabstrm "Congruence" (Pp.str "congruence failed.") let congruence_tac depth l = Tacticals.New.tclORELSE (Tacticals.New.tclTHEN (Tacticals.New.tclREPEAT introf) (cc_tactic depth l)) (Proofview.V82.tactic cc_fail) (* Beware: reflexivity = constructor 1 = apply refl_equal might be slow now, let's rather do something equivalent to a "simple apply refl_equal" *) (* The [f_equal] tactic. It mimics the use of lemmas [f_equal], [f_equal2], etc. This isn't particularly related with congruence, apart from the fact that congruence is called internally. *) let mk_eq f c1 c2 k = Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> Proofview.Goal.enter { enter = begin fun gl -> let open Tacmach.New in let evm, ty = pf_apply type_of gl c1 in let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm ty in let term = mkApp (fc, [| ty; c1; c2 |]) in let evm, _ = type_of (pf_env gl) evm term in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (k term) end }) let f_equal = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let cut_eq c1 c2 = try (* type_of can raise an exception *) Tacticals.New.tclTHENS (mk_eq _eq c1 c2 Tactics.cut) [Proofview.tclUNIT ();Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply)] with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in Proofview.tclORELSE begin match kind_of_term concl with | App (r,[|_;t;t'|]) when Globnames.is_global (Lazy.force _eq) r -> begin match kind_of_term t, kind_of_term t' with | App (f,v), App (f',v') when Int.equal (Array.length v) (Array.length v') -> let rec cuts i = if i < 0 then Tacticals.New.tclTRY (congruence_tac 1000 []) else Tacticals.New.tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1)) in cuts (Array.length v - 1) | _ -> Proofview.tclUNIT () end | _ -> Proofview.tclUNIT () end begin function (e, info) -> match e with | Type_errors.TypeError _ -> Proofview.tclUNIT () | e -> Proofview.tclZERO ~info e end end } coq-8.6/plugins/cc/ccproof.ml0000644000175000017500000001124713022274260015517 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* prefl (Appli (t1,t2)) | _, _ -> {p_lhs=Appli (p1.p_lhs,p2.p_lhs); p_rhs=Appli (p1.p_rhs,p2.p_rhs); p_rule=Congr (p1,p2)} let rec ptrans p1 p3= match p1.p_rule,p3.p_rule with Refl _, _ ->p3 | _, Refl _ ->p1 | Trans(p1,p2), _ ->ptrans p1 (ptrans p2 p3) | Congr(p1,p2), Congr(p3,p4) ->pcongr (ptrans p1 p3) (ptrans p2 p4) | Congr(p1,p2), Trans({p_rule=Congr(p3,p4)},p5) -> ptrans (pcongr (ptrans p1 p3) (ptrans p2 p4)) p5 | _, _ -> if term_equal p1.p_rhs p3.p_lhs then {p_lhs=p1.p_lhs; p_rhs=p3.p_rhs; p_rule=Trans (p1,p3)} else anomaly (Pp.str "invalid cc transitivity") let rec psym p = match p.p_rule with Refl _ -> p | SymAx s -> {p_lhs=p.p_rhs; p_rhs=p.p_lhs; p_rule=Ax s} | Ax s-> {p_lhs=p.p_rhs; p_rhs=p.p_lhs; p_rule=SymAx s} | Inject (p0,c,n,a)-> {p_lhs=p.p_rhs; p_rhs=p.p_lhs; p_rule=Inject (psym p0,c,n,a)} | Trans (p1,p2)-> ptrans (psym p2) (psym p1) | Congr (p1,p2)-> pcongr (psym p1) (psym p2) let pax axioms s = let l,r = Constrhash.find axioms s in {p_lhs=l; p_rhs=r; p_rule=Ax s} let psymax axioms s = let l,r = Constrhash.find axioms s in {p_lhs=r; p_rhs=l; p_rule=SymAx s} let rec nth_arg t n= match t with Appli (t1,t2)-> if n>0 then nth_arg t1 (n-1) else t2 | _ -> anomaly ~label:"nth_arg" (Pp.str "not enough args") let pinject p c n a = {p_lhs=nth_arg p.p_lhs (n-a); p_rhs=nth_arg p.p_rhs (n-a); p_rule=Inject(p,c,n,a)} let rec equal_proof uf i j= debug (fun () -> str "equal_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); if i=j then prefl (term uf i) else let (li,lj)=join_path uf i j in ptrans (path_proof uf i li) (psym (path_proof uf j lj)) and edge_proof uf ((i,j),eq)= debug (fun () -> str "edge_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); let pi=equal_proof uf i eq.lhs in let pj=psym (equal_proof uf j eq.rhs) in let pij= match eq.rule with Axiom (s,reversed)-> if reversed then psymax (axioms uf) s else pax (axioms uf) s | Congruence ->congr_proof uf eq.lhs eq.rhs | Injection (ti,ipac,tj,jpac,k) -> (* pi_k ipac = p_k jpac *) let p=ind_proof uf ti ipac tj jpac in let cinfo= get_constructor_info uf ipac.cnode in pinject p cinfo.ci_constr cinfo.ci_nhyps k in ptrans (ptrans pi pij) pj and constr_proof uf i ipac= debug (fun () -> str "constr_proof " ++ pr_idx_term uf i ++ brk (1,20)); let t=find_oldest_pac uf i ipac in let eq_it=equal_proof uf i t in if ipac.args=[] then eq_it else let fipac=tail_pac ipac in let (fi,arg)=subterms uf t in let targ=term uf arg in let p=constr_proof uf fi fipac in ptrans eq_it (pcongr p (prefl targ)) and path_proof uf i l= debug (fun () -> str "path_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ str "{" ++ (prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}"); match l with | [] -> prefl (term uf i) | x::q->ptrans (path_proof uf (snd (fst x)) q) (edge_proof uf x) and congr_proof uf i j= debug (fun () -> str "congr_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); let (i1,i2) = subterms uf i and (j1,j2) = subterms uf j in pcongr (equal_proof uf i1 j1) (equal_proof uf i2 j2) and ind_proof uf i ipac j jpac= debug (fun () -> str "ind_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); let p=equal_proof uf i j and p1=constr_proof uf i ipac and p2=constr_proof uf j jpac in ptrans (psym p1) (ptrans p p2) let build_proof uf= function | `Prove (i,j) -> equal_proof uf i j | `Discr (i,ci,j,cj)-> ind_proof uf i ci j cj coq-8.6/plugins/cc/cc_plugin.mlpack0000644000175000017500000000004213022274260016655 0ustar mdenesmdenesCcalgo Ccproof Cctac G_congruence coq-8.6/plugins/rtauto/0000755000175000017500000000000013022274260014456 5ustar mdenesmdenescoq-8.6/plugins/rtauto/Rtauto.v0000644000175000017500000002421713022274260016131 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* form | Arrow : form -> form -> form | Bot | Conjunct : form -> form -> form | Disjunct : form -> form -> form. Notation "[ n ]":=(Atom n). Notation "A =>> B":= (Arrow A B) (at level 59, right associativity). Notation "#" := Bot. Notation "A //\\ B" := (Conjunct A B) (at level 57, left associativity). Notation "A \\// B" := (Disjunct A B) (at level 58, left associativity). Definition ctx := Store form. Fixpoint pos_eq (m n:positive) {struct m} :bool := match m with xI mm => match n with xI nn => pos_eq mm nn | _ => false end | xO mm => match n with xO nn => pos_eq mm nn | _ => false end | xH => match n with xH => true | _ => false end end. Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. induction m;simpl;destruct n;congruence || (intro e;apply f_equal;auto). Qed. Fixpoint form_eq (p q:form) {struct p} :bool := match p with Atom m => match q with Atom n => pos_eq m n | _ => false end | Arrow p1 p2 => match q with Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2 | _ => false end | Bot => match q with Bot => true | _ => false end | Conjunct p1 p2 => match q with Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 | _ => false end | Disjunct p1 p2 => match q with Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 | _ => false end end. Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q. induction p;destruct q;simpl;clean. intro h;generalize (pos_eq_refl _ _ h);congruence. case_eq (form_eq p1 q1);clean. intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. case_eq (form_eq p1 q1);clean. intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. case_eq (form_eq p1 q1);clean. intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. Qed. Arguments form_eq_refl [p q] _. Section with_env. Variable env:Store Prop. Fixpoint interp_form (f:form): Prop := match f with [n]=> match get n env with PNone => True | PSome P => P end | A =>> B => (interp_form A) -> (interp_form B) | # => False | A //\\ B => (interp_form A) /\ (interp_form B) | A \\// B => (interp_form A) \/ (interp_form B) end. Notation "[[ A ]]" := (interp_form A). Fixpoint interp_ctx (hyps:ctx) (F:Full hyps) (G:Prop) {struct F} : Prop := match F with F_empty => G | F_push H hyps0 F0 => interp_ctx hyps0 F0 ([[H]] -> G) end. Require Export BinPos. Ltac wipe := intros;simpl;constructor. Lemma compose0 : forall hyps F (A:Prop), A -> (interp_ctx hyps F A). induction F;intros A H;simpl;auto. Qed. Lemma compose1 : forall hyps F (A B:Prop), (A -> B) -> (interp_ctx hyps F A) -> (interp_ctx hyps F B). induction F;intros A B H;simpl;auto. apply IHF;auto. Qed. Theorem compose2 : forall hyps F (A B C:Prop), (A -> B -> C) -> (interp_ctx hyps F A) -> (interp_ctx hyps F B) -> (interp_ctx hyps F C). induction F;intros A B C H;simpl;auto. apply IHF;auto. Qed. Theorem compose3 : forall hyps F (A B C D:Prop), (A -> B -> C -> D) -> (interp_ctx hyps F A) -> (interp_ctx hyps F B) -> (interp_ctx hyps F C) -> (interp_ctx hyps F D). induction F;intros A B C D H;simpl;auto. apply IHF;auto. Qed. Lemma weaken : forall hyps F f G, (interp_ctx hyps F G) -> (interp_ctx (hyps\f) (F_push f hyps F) G). induction F;simpl;intros;auto. apply compose1 with ([[a]]-> G);auto. Qed. Theorem project_In : forall hyps F g, In g hyps F -> interp_ctx hyps F [[g]]. induction F;simpl. contradiction. intros g H;destruct H. subst;apply compose0;simpl;trivial. apply compose1 with [[g]];auto. Qed. Theorem project : forall hyps F p g, get p hyps = PSome g-> interp_ctx hyps F [[g]]. intros hyps F p g e; apply project_In. apply get_In with p;assumption. Qed. Arguments project [hyps] F [p g] _. Inductive proof:Set := Ax : positive -> proof | I_Arrow : proof -> proof | E_Arrow : positive -> positive -> proof -> proof | D_Arrow : positive -> proof -> proof -> proof | E_False : positive -> proof | I_And: proof -> proof -> proof | E_And: positive -> proof -> proof | D_And: positive -> proof -> proof | I_Or_l: proof -> proof | I_Or_r: proof -> proof | E_Or: positive -> proof -> proof -> proof | D_Or: positive -> proof -> proof | Cut: form -> proof -> proof -> proof. Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := match P with Ax i => match get i hyps with PSome F => form_eq F gl | _ => false end | I_Arrow p => match gl with A =>> B => check_proof (hyps \ A) B p | _ => false end | E_Arrow i j p => match get i hyps,get j hyps with PSome A,PSome (B =>>C) => form_eq A B && check_proof (hyps \ C) (gl) p | _,_ => false end | D_Arrow i p1 p2 => match get i hyps with PSome ((A =>>B)=>>C) => (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2) | _ => false end | E_False i => match get i hyps with PSome # => true | _ => false end | I_And p1 p2 => match gl with A //\\ B => check_proof hyps A p1 && check_proof hyps B p2 | _ => false end | E_And i p => match get i hyps with PSome (A //\\ B) => check_proof (hyps \ A \ B) gl p | _=> false end | D_And i p => match get i hyps with PSome (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p | _=> false end | I_Or_l p => match gl with (A \\// B) => check_proof hyps A p | _ => false end | I_Or_r p => match gl with (A \\// B) => check_proof hyps B p | _ => false end | E_Or i p1 p2 => match get i hyps with PSome (A \\// B) => check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2 | _=> false end | D_Or i p => match get i hyps with PSome (A \\// B =>> C) => (check_proof (hyps \ A=>>C \ B=>>C) gl p) | _=> false end | Cut A p1 p2 => check_proof hyps A p1 && check_proof (hyps \ A) gl p2 end. Theorem interp_proof: forall p hyps F gl, check_proof hyps gl p = true -> interp_ctx hyps F [[gl]]. induction p;intros hyps F gl. (* cas Axiom *) Focus 1. simpl;case_eq (get p hyps);clean. intros f nth_f e;rewrite <- (form_eq_refl e). apply project with p;trivial. (* Cas Arrow_Intro *) Focus 1. destruct gl;clean. simpl;intros. change (interp_ctx (hyps\gl1) (F_push gl1 hyps F) [[gl2]]). apply IHp;try constructor;trivial. (* Cas Arrow_Elim *) Focus 1. simpl check_proof;case_eq (get p hyps);clean. intros f ef;case_eq (get p0 hyps);clean. intros f0 ef0;destruct f0;clean. case_eq (form_eq f f0_1);clean. simpl;intros e check_p1. generalize (project F ef) (project F ef0) (IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1); clear check_p1 IHp p p0 p1 ef ef0. simpl. apply compose3. rewrite (form_eq_refl e). auto. (* cas Arrow_Destruct *) Focus 1. simpl;case_eq (get p1 hyps);clean. intros f ef;destruct f;clean. destruct f1;clean. case_eq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean. intros check_p1 check_p2. generalize (project F ef) (IHp1 (hyps \ f1_2 =>> f2 \ f1_1) (F_push f1_1 (hyps \ f1_2 =>> f2) (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1) (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2). simpl;apply compose3;auto. (* Cas False_Elim *) Focus 1. simpl;case_eq (get p hyps);clean. intros f ef;destruct f;clean. intros _; generalize (project F ef). apply compose1;apply False_ind. (* Cas And_Intro *) Focus 1. simpl;destruct gl;clean. case_eq (check_proof hyps gl1 p1);clean. intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2). apply compose2 ;simpl;auto. (* cas And_Elim *) Focus 1. simpl;case_eq (get p hyps);clean. intros f ef;destruct f;clean. intro check_p;generalize (project F ef) (IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p). simpl;apply compose2;intros [h1 h2];auto. (* cas And_Destruct *) Focus 1. simpl;case_eq (get p hyps);clean. intros f ef;destruct f;clean. destruct f1;clean. intro H;generalize (project F ef) (IHp (hyps \ f1_1 =>> f1_2 =>> f2) (F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);clear H;simpl. apply compose2;auto. (* cas Or_Intro_left *) Focus 1. destruct gl;clean. intro Hp;generalize (IHp hyps F gl1 Hp). apply compose1;simpl;auto. (* cas Or_Intro_right *) Focus 1. destruct gl;clean. intro Hp;generalize (IHp hyps F gl2 Hp). apply compose1;simpl;auto. (* cas Or_elim *) Focus 1. simpl;case_eq (get p1 hyps);clean. intros f ef;destruct f;clean. case_eq (check_proof (hyps \ f1) gl p2);clean. intros check_p1 check_p2;generalize (project F ef) (IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1) (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2); simpl;apply compose3;simpl;intro h;destruct h;auto. (* cas Or_Destruct *) Focus 1. simpl;case_eq (get p hyps);clean. intros f ef;destruct f;clean. destruct f1;clean. intro check_p0;generalize (project F ef) (IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2) (F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2) (F_push (f1_1 =>> f2) hyps F)) gl check_p0);simpl. apply compose2;auto. (* cas Cut *) Focus 1. simpl;case_eq (check_proof hyps f p1);clean. intros check_p1 check_p2; generalize (IHp1 hyps F f check_p1) (IHp2 (hyps\f) (F_push f hyps F) gl check_p2); simpl; apply compose2;auto. Qed. Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True. intros gl prf;case_eq (check_proof empty gl prf);intro check_prf. change (interp_ctx empty F_empty [[gl]]) ; apply interp_proof with prf;assumption. trivial. Qed. End with_env. (* (* A small example *) Parameters A B C D:Prop. Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C). exact (Reflect (empty \ A \ B \ C) ([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3]) (I_Arrow (E_And 1 (E_Or 3 (I_Or_l (I_And (Ax 2) (Ax 4))) (I_Or_r (I_And (Ax 2) (Ax 4))))))). Qed. Print toto. *) coq-8.6/plugins/rtauto/refl_tauto.mli0000644000175000017500000000165513022274260017334 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Proof_type.goal Tacmach.sigma -> Term.types -> Proof_search.form val make_hyps : atom_env -> Proof_type.goal Tacmach.sigma -> Term.types list -> Context.Named.t -> (Names.Id.t * Proof_search.form) list val rtauto_tac : Proof_type.tactic coq-8.6/plugins/rtauto/rtauto_plugin.mlpack0000644000175000017500000000004113022274260020536 0ustar mdenesmdenesProof_search Refl_tauto G_rtauto coq-8.6/plugins/rtauto/Bintree.v0000644000175000017500000002222113022274260016234 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (p ?= q) = Gt. Proof. intros. rewrite <- Pos.compare_succ_succ. now apply Pos.lt_gt, Pos.lt_lt_succ, Pos.gt_lt. Qed. Lemma Psucc_Gt : forall p, (Pos.succ p ?= p) = Gt. Proof. intros. apply Pos.lt_gt, Pos.lt_succ_diag_r. Qed. Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A := match l with nil => None | x::q => match n with O => Some x | S m => Lget A m q end end . Arguments Lget [A] n l. Lemma map_app : forall (A B:Set) (f:A -> B) l m, List.map f (l ++ m) = List.map f l ++ List.map f m. induction l. reflexivity. simpl. intro m ; apply f_equal;apply IHl. Qed. Lemma length_map : forall (A B:Set) (f:A -> B) l, length (List.map f l) = length l. induction l. reflexivity. simpl; apply f_equal;apply IHl. Qed. Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, Lget i (List.map f l) = match Lget i l with Some a => Some (f a) | None => None end. induction i;intros [ | x l ] ;trivial. simpl;auto. Qed. Lemma Lget_app : forall (A:Set) (a:A) l i, Lget i (l ++ a :: nil) = if Arith.EqNat.beq_nat i (length l) then Some a else Lget i l. Proof. induction l;simpl Lget;simpl length. intros [ | i];simpl;reflexivity. intros [ | i];simpl. reflexivity. auto. Qed. Lemma Lget_app_Some : forall (A:Set) l delta i (a: A), Lget i l = Some a -> Lget i (l ++ delta) = Some a. induction l;destruct i;simpl;try congruence;auto. Qed. Section Store. Variable A:Type. Inductive Poption : Type:= PSome : A -> Poption | PNone : Poption. Inductive Tree : Type := Tempty : Tree | Branch0 : Tree -> Tree -> Tree | Branch1 : A -> Tree -> Tree -> Tree. Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := match T with Tempty => PNone | Branch0 T1 T2 => match p with xI pp => Tget pp T2 | xO pp => Tget pp T1 | xH => PNone end | Branch1 a T1 T2 => match p with xI pp => Tget pp T2 | xO pp => Tget pp T1 | xH => PSome a end end. Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree := match T with | Tempty => match p with | xI pp => Branch0 Tempty (Tadd pp a Tempty) | xO pp => Branch0 (Tadd pp a Tempty) Tempty | xH => Branch1 a Tempty Tempty end | Branch0 T1 T2 => match p with | xI pp => Branch0 T1 (Tadd pp a T2) | xO pp => Branch0 (Tadd pp a T1) T2 | xH => Branch1 a T1 T2 end | Branch1 b T1 T2 => match p with | xI pp => Branch1 b T1 (Tadd pp a T2) | xO pp => Branch1 b (Tadd pp a T1) T2 | xH => Branch1 a T1 T2 end end. Definition mkBranch0 (T1 T2:Tree) := match T1,T2 with Tempty ,Tempty => Tempty | _,_ => Branch0 T1 T2 end. Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree := match T with | Tempty => Tempty | Branch0 T1 T2 => match p with | xI pp => mkBranch0 T1 (Tremove pp T2) | xO pp => mkBranch0 (Tremove pp T1) T2 | xH => T end | Branch1 b T1 T2 => match p with | xI pp => Branch1 b T1 (Tremove pp T2) | xO pp => Branch1 b (Tremove pp T1) T2 | xH => mkBranch0 T1 T2 end end. Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone. destruct p;reflexivity. Qed. Theorem Tget_Tadd: forall i j a T, Tget i (Tadd j a T) = match (i ?= j) with Eq => PSome a | Lt => Tget i T | Gt => Tget i T end. Proof. intros i j. case_eq (i ?= j). intro H;rewrite (Pos.compare_eq _ _ H);intros a;clear i H. induction j;destruct T;simpl;try (apply IHj);congruence. unfold Pos.compare. generalize i;clear i;induction j;destruct T;simpl in H|-*; destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. unfold Pos.compare. generalize i;clear i;induction j;destruct T;simpl in H|-*; destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. Qed. Record Store : Type := mkStore {index:positive;contents:Tree}. Definition empty := mkStore xH Tempty. Definition push a S := mkStore (Pos.succ (index S)) (Tadd (index S) a (contents S)). Definition get i S := Tget i (contents S). Lemma get_empty : forall i, get i empty = PNone. intro i; case i; unfold empty,get; simpl;reflexivity. Qed. Inductive Full : Store -> Type:= F_empty : Full empty | F_push : forall a S, Full S -> Full (push a S). Theorem get_Full_Gt : forall S, Full S -> forall i, (i ?= index S) = Gt -> get i S = PNone. Proof. intros S W;induction W. unfold empty,index,get,contents;intros;apply Tget_Tempty. unfold index,get,push. simpl @contents. intros i e;rewrite Tget_Tadd. rewrite (Gt_Psucc _ _ e). unfold get in IHW. apply IHW;apply Gt_Psucc;assumption. Qed. Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone. intros [index0 contents0] F. case F. unfold empty,index,get,contents;intros;apply Tget_Tempty. unfold push,index,get;simpl @contents. intros a S. rewrite Tget_Tadd. rewrite Psucc_Gt. intro W. change (get (Pos.succ (index S)) S =PNone). apply get_Full_Gt; auto. apply Psucc_Gt. Qed. Theorem get_push_Full : forall i a S, Full S -> get i (push a S) = match (i ?= index S) with Eq => PSome a | Lt => get i S | Gt => PNone end. Proof. intros i a S F. case_eq (i ?= index S). intro e;rewrite (Pos.compare_eq _ _ e). destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd. rewrite Pos.compare_refl;reflexivity. intros;destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd. simpl @index in H;rewrite H;reflexivity. intro H;generalize H;clear H. unfold get,push;simpl. rewrite Tget_Tadd;intro e;rewrite e. change (get i S=PNone). apply get_Full_Gt;auto. Qed. Lemma Full_push_compat : forall i a S, Full S -> forall x, get i S = PSome x -> get i (push a S) = PSome x. Proof. intros i a S F x H. case_eq (i ?= index S);intro test. rewrite (Pos.compare_eq _ _ test) in H. rewrite (get_Full_Eq _ F) in H;congruence. rewrite <- H. rewrite (get_push_Full i a). rewrite test;reflexivity. assumption. rewrite (get_Full_Gt _ F) in H;congruence. Qed. Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. intros [ind cont] F one; inversion F. reflexivity. simpl @index in one;assert (h:=Pos.succ_not_1 (index S)). congruence. Qed. Lemma push_not_empty: forall a S, (push a S) <> empty. intros a [ind cont];unfold push,empty. intros [= H%Pos.succ_not_1]. assumption. Qed. Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop := match F with F_empty => False | F_push a SS FF => x=a \/ In x SS FF end. Lemma get_In : forall (x:A) (S:Store) (F:Full S) i , get i S = PSome x -> In x S F. induction F. intro i;rewrite get_empty; congruence. intro i;rewrite get_push_Full;trivial. case_eq (i ?= index S);simpl. left;congruence. right;eauto. congruence. Qed. End Store. Arguments PNone [A]. Arguments PSome [A] _. Arguments Tempty [A]. Arguments Branch0 [A] _ _. Arguments Branch1 [A] _ _ _. Arguments Tget [A] p T. Arguments Tadd [A] p a T. Arguments Tget_Tempty [A] p. Arguments Tget_Tadd [A] i j a T. Arguments mkStore [A] index contents. Arguments index [A] s. Arguments contents [A] s. Arguments empty [A]. Arguments get [A] i S. Arguments push [A] a S. Arguments get_empty [A] i. Arguments get_push_Full [A] i a S _. Arguments Full [A] _. Arguments F_empty [A]. Arguments F_push [A] a S _. Arguments In [A] x S F. Section Map. Variables A B:Set. Variable f: A -> B. Fixpoint Tmap (T: Tree A) : Tree B := match T with Tempty => Tempty | Branch0 t1 t2 => Branch0 (Tmap t1) (Tmap t2) | Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2) end. Lemma Tget_Tmap: forall T i, Tget i (Tmap T)= match Tget i T with PNone => PNone | PSome a => PSome (f a) end. induction T;intro i;case i;simpl;auto. Defined. Lemma Tmap_Tadd: forall i a T, Tmap (Tadd i a T) = Tadd i (f a) (Tmap T). induction i;intros a T;case T;simpl;intros;try (rewrite IHi);simpl;reflexivity. Defined. Definition map (S:Store A) : Store B := mkStore (index S) (Tmap (contents S)). Lemma get_map: forall i S, get i (map S)= match get i S with PNone => PNone | PSome a => PSome (f a) end. destruct S;unfold get,map,contents,index;apply Tget_Tmap. Defined. Lemma map_push: forall a S, map (push a S) = push (f a) (map S). intros a S. case S. unfold push,map,contents,index. intros;rewrite Tmap_Tadd;reflexivity. Defined. Theorem Full_map : forall S, Full S -> Full (map S). intros S F. induction F. exact F_empty. rewrite map_push;constructor 2;assumption. Defined. End Map. Arguments Tmap [A B] f T. Arguments map [A B] f S. Arguments Full_map [A B f] S _. Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). coq-8.6/plugins/rtauto/proof_search.ml0000644000175000017500000003542613022274260017474 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !pruning); optwrite=(fun b -> pruning:=b)} let _ = declare_bool_option opt_pruning type form= Atom of int | Arrow of form * form | Bot | Conjunct of form * form | Disjunct of form * form module FOrd = struct type t = form let rec compare x y = match x, y with | Bot, Bot -> 0 | Bot, _ -> -1 | Atom _, Bot -> 1 | Atom a1, Atom a2 -> Int.compare a1 a2 | Atom _, _ -> -1 | Arrow _, (Bot | Atom _) -> 1 | Arrow (f1, g1), Arrow (f2, g2) -> let cmp = compare f1 f2 in if cmp = 0 then compare g1 g2 else cmp | Arrow _, _ -> -1 | Conjunct _, (Bot | Atom _ | Arrow _) -> 1 | Conjunct (f1, g1), Conjunct (f2, g2) -> let cmp = compare f1 f2 in if cmp = 0 then compare g1 g2 else cmp | Conjunct _, _ -> -1 | Disjunct _, (Bot | Atom _ | Arrow _ | Conjunct _) -> 1 | Disjunct (f1, g1), Disjunct (f2, g2) -> let cmp = compare f1 f2 in if cmp = 0 then compare g1 g2 else cmp end module Fmap = Map.Make(FOrd) type sequent = {rev_hyps: form Int.Map.t; norev_hyps: form Int.Map.t; size:int; left:int Fmap.t; right:(int*form) list Fmap.t; cnx:(int*int*form*form) list; abs:int option; gl:form} let add_one_arrow i f1 f2 m= try Fmap.add f1 ((i,f2)::(Fmap.find f1 m)) m with Not_found -> Fmap.add f1 [i,f2] m type proof = Ax of int | I_Arrow of proof | E_Arrow of int*int*proof | D_Arrow of int*proof*proof | E_False of int | I_And of proof*proof | E_And of int*proof | D_And of int*proof | I_Or_l of proof | I_Or_r of proof | E_Or of int*proof*proof | D_Or of int*proof | Pop of int*proof type rule = SAx of int | SI_Arrow | SE_Arrow of int*int | SD_Arrow of int | SE_False of int | SI_And | SE_And of int | SD_And of int | SI_Or_l | SI_Or_r | SE_Or of int | SD_Or of int let add_step s sub = match s,sub with SAx i,[] -> Ax i | SI_Arrow,[p] -> I_Arrow p | SE_Arrow(i,j),[p] -> E_Arrow (i,j,p) | SD_Arrow i,[p1;p2] -> D_Arrow (i,p1,p2) | SE_False i,[] -> E_False i | SI_And,[p1;p2] -> I_And(p1,p2) | SE_And i,[p] -> E_And(i,p) | SD_And i,[p] -> D_And(i,p) | SI_Or_l,[p] -> I_Or_l p | SI_Or_r,[p] -> I_Or_r p | SE_Or i,[p1;p2] -> E_Or(i,p1,p2) | SD_Or i,[p] -> D_Or(i,p) | _,_ -> anomaly ~label:"add_step" (Pp.str "wrong arity") type 'a with_deps = {dep_it:'a; dep_goal:bool; dep_hyps:Int.Set.t} type slice= {proofs_done:proof list; proofs_todo:sequent with_deps list; step:rule; needs_goal:bool; needs_hyps:Int.Set.t; changes_goal:bool; creates_hyps:Int.Set.t} type state = Complete of proof | Incomplete of sequent * slice list let project = function Complete prf -> prf | Incomplete (_,_) -> anomaly (Pp.str "not a successful state") let pop n prf = let nprf= match prf.dep_it with Pop (i,p) -> Pop (i+n,p) | p -> Pop(n,p) in {prf with dep_it = nprf} let rec fill stack proof = match stack with [] -> Complete proof.dep_it | slice::super -> if !pruning && List.is_empty slice.proofs_done && not (slice.changes_goal && proof.dep_goal) && not (Int.Set.exists (fun i -> Int.Set.mem i proof.dep_hyps) slice.creates_hyps) then begin s_info.pruned_steps<-s_info.pruned_steps+1; s_info.pruned_branches<- s_info.pruned_branches + List.length slice.proofs_todo; let created_here=Int.Set.cardinal slice.creates_hyps in s_info.pruned_hyps<-s_info.pruned_hyps+ List.fold_left (fun sum dseq -> sum + Int.Set.cardinal dseq.dep_hyps) created_here slice.proofs_todo; fill super (pop (Int.Set.cardinal slice.creates_hyps) proof) end else let dep_hyps= Int.Set.union slice.needs_hyps (Int.Set.diff proof.dep_hyps slice.creates_hyps) in let dep_goal= slice.needs_goal || ((not slice.changes_goal) && proof.dep_goal) in let proofs_done= proof.dep_it::slice.proofs_done in match slice.proofs_todo with [] -> fill super {dep_it = add_step slice.step (List.rev proofs_done); dep_goal = dep_goal; dep_hyps = dep_hyps} | current::next -> let nslice= {proofs_done=proofs_done; proofs_todo=next; step=slice.step; needs_goal=dep_goal; needs_hyps=dep_hyps; changes_goal=current.dep_goal; creates_hyps=current.dep_hyps} in Incomplete (current.dep_it,nslice::super) let append stack (step,subgoals) = s_info.created_steps<-s_info.created_steps+1; match subgoals with [] -> s_info.branch_successes<-s_info.branch_successes+1; fill stack {dep_it=add_step step.dep_it []; dep_goal=step.dep_goal; dep_hyps=step.dep_hyps} | hd :: next -> s_info.created_branches<- s_info.created_branches+List.length next; let slice= {proofs_done=[]; proofs_todo=next; step=step.dep_it; needs_goal=step.dep_goal; needs_hyps=step.dep_hyps; changes_goal=hd.dep_goal; creates_hyps=hd.dep_hyps} in Incomplete(hd.dep_it,slice::stack) let embed seq= {dep_it=seq; dep_goal=false; dep_hyps=Int.Set.empty} let change_goal seq gl= {seq with dep_it={seq.dep_it with gl=gl}; dep_goal=true} let add_hyp seqwd f= s_info.created_hyps<-s_info.created_hyps+1; let seq=seqwd.dep_it in let num = seq.size+1 in let left = Fmap.add f num seq.left in let cnx,right= try let l=Fmap.find f seq.right in List.fold_right (fun (i,f0) l0 -> (num,i,f,f0)::l0) l seq.cnx, Fmap.remove f seq.right with Not_found -> seq.cnx,seq.right in let nseq= match f with Bot -> {seq with left=left; right=right; size=num; abs=Some num; cnx=cnx} | Atom _ -> {seq with size=num; left=left; right=right; cnx=cnx} | Conjunct (_,_) | Disjunct (_,_) -> {seq with rev_hyps=Int.Map.add num f seq.rev_hyps; size=num; left=left; right=right; cnx=cnx} | Arrow (f1,f2) -> let ncnx,nright= try let i = Fmap.find f1 seq.left in (i,num,f1,f2)::cnx,right with Not_found -> cnx,(add_one_arrow num f1 f2 right) in match f1 with Conjunct (_,_) | Disjunct (_,_) -> {seq with rev_hyps=Int.Map.add num f seq.rev_hyps; size=num; left=left; right=nright; cnx=ncnx} | Arrow(_,_) -> {seq with norev_hyps=Int.Map.add num f seq.norev_hyps; size=num; left=left; right=nright; cnx=ncnx} | _ -> {seq with size=num; left=left; right=nright; cnx=ncnx} in {seqwd with dep_it=nseq; dep_hyps=Int.Set.add num seqwd.dep_hyps} exception Here_is of (int*form) let choose m= try Int.Map.iter (fun i f -> raise (Here_is (i,f))) m; raise Not_found with Here_is (i,f) -> (i,f) let search_or seq= match seq.gl with Disjunct (f1,f2) -> [{dep_it = SI_Or_l; dep_goal = true; dep_hyps = Int.Set.empty}, [change_goal (embed seq) f1]; {dep_it = SI_Or_r; dep_goal = true; dep_hyps = Int.Set.empty}, [change_goal (embed seq) f2]] | _ -> [] let search_norev seq= let goals=ref (search_or seq) in let add_one i f= match f with Arrow (Arrow (f1,f2),f3) -> let nseq = {seq with norev_hyps=Int.Map.remove i seq.norev_hyps} in goals:= ({dep_it=SD_Arrow(i); dep_goal=false; dep_hyps=Int.Set.singleton i}, [add_hyp (add_hyp (change_goal (embed nseq) f2) (Arrow(f2,f3))) f1; add_hyp (embed nseq) f3]):: !goals | _ -> anomaly ~label:"search_no_rev" (Pp.str "can't happen") in Int.Map.iter add_one seq.norev_hyps; List.rev !goals let search_in_rev_hyps seq= try let i,f=choose seq.rev_hyps in let make_step step= {dep_it=step; dep_goal=false; dep_hyps=Int.Set.singleton i} in let nseq={seq with rev_hyps=Int.Map.remove i seq.rev_hyps} in match f with Conjunct (f1,f2) -> [make_step (SE_And(i)), [add_hyp (add_hyp (embed nseq) f1) f2]] | Disjunct (f1,f2) -> [make_step (SE_Or(i)), [add_hyp (embed nseq) f1;add_hyp (embed nseq) f2]] | Arrow (Conjunct (f1,f2),f0) -> [make_step (SD_And(i)), [add_hyp (embed nseq) (Arrow (f1,Arrow (f2,f0)))]] | Arrow (Disjunct (f1,f2),f0) -> [make_step (SD_Or(i)), [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]] | _ -> anomaly ~label:"search_in_rev_hyps" (Pp.str "can't happen") with Not_found -> search_norev seq let search_rev seq= match seq.cnx with (i,j,f1,f2)::next -> let nseq= match f1 with Conjunct (_,_) | Disjunct (_,_) -> {seq with cnx=next; rev_hyps=Int.Map.remove j seq.rev_hyps} | Arrow (_,_) -> {seq with cnx=next; norev_hyps=Int.Map.remove j seq.norev_hyps} | _ -> {seq with cnx=next} in [{dep_it=SE_Arrow(i,j); dep_goal=false; dep_hyps=Int.Set.add i (Int.Set.singleton j)}, [add_hyp (embed nseq) f2]] | [] -> match seq.gl with Arrow (f1,f2) -> [{dep_it=SI_Arrow; dep_goal=true; dep_hyps=Int.Set.empty}, [add_hyp (change_goal (embed seq) f2) f1]] | Conjunct (f1,f2) -> [{dep_it=SI_And; dep_goal=true; dep_hyps=Int.Set.empty},[change_goal (embed seq) f1; change_goal (embed seq) f2]] | _ -> search_in_rev_hyps seq let search_all seq= match seq.abs with Some i -> [{dep_it=SE_False (i); dep_goal=false; dep_hyps=Int.Set.singleton i},[]] | None -> try let ax = Fmap.find seq.gl seq.left in [{dep_it=SAx (ax); dep_goal=true; dep_hyps=Int.Set.singleton ax},[]] with Not_found -> search_rev seq let bare_sequent = embed {rev_hyps=Int.Map.empty; norev_hyps=Int.Map.empty; size=0; left=Fmap.empty; right=Fmap.empty; cnx=[]; abs=None; gl=Bot} let init_state hyps gl= let init = change_goal bare_sequent gl in let goal=List.fold_right (fun (_,f,_) seq ->add_hyp seq f) hyps init in Incomplete (goal.dep_it,[]) let success= function Complete _ -> true | Incomplete (_,_) -> false let branching = function Incomplete (seq,stack) -> Control.check_for_interrupt (); let successors = search_all seq in let _ = match successors with [] -> s_info.branch_failures<-s_info.branch_failures+1 | _::next -> s_info.nd_branching<-s_info.nd_branching+List.length next in List.map (append stack) successors | Complete prf -> anomaly (Pp.str "already succeeded") open Pp let rec pp_form = function Arrow(f1,f2) -> (pp_or f1) ++ (str " -> ") ++ (pp_form f2) | f -> pp_or f and pp_or = function Disjunct(f1,f2) -> (pp_or f1) ++ (str " \\/ ") ++ (pp_and f2) | f -> pp_and f and pp_and = function Conjunct(f1,f2) -> (pp_and f1) ++ (str " /\\ ") ++ (pp_atom f2) | f -> pp_atom f and pp_atom= function Bot -> str "#" | Atom n -> int n | f -> str "(" ++ hv 2 (pp_form f) ++ str ")" let pr_form f = pp_form f let pp_intmap map = let pp=ref (str "") in Int.Map.iter (fun i obj -> pp:= (!pp ++ pp_form obj ++ cut ())) map; str "{ " ++ v 0 (!pp) ++ str " }" let pp_list pp_obj l= let pp=ref (str "") in List.iter (fun o -> pp := !pp ++ (pp_obj o) ++ str ", ") l; str "[ " ++ !pp ++ str "]" let pp_mapint map = let pp=ref (str "") in Fmap.iter (fun obj l -> pp:= (!pp ++ pp_form obj ++ str " => " ++ pp_list (fun (i,f) -> pp_form f) l ++ cut ()) ) map; str "{ " ++ vb 0 ++ (!pp) ++ str " }" ++ close () let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2 let pp_gl gl= cut () ++ str "{ " ++ vb 0 ++ begin match gl.abs with None -> str "" | Some i -> str "ABSURD" ++ cut () end ++ str "rev =" ++ pp_intmap gl.rev_hyps ++ cut () ++ str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++ str "arrows=" ++ pp_mapint gl.right ++ cut () ++ str "cnx =" ++ pp_list pp_connect gl.cnx ++ cut () ++ str "goal =" ++ pp_form gl.gl ++ str " }" ++ close () let pp = function Incomplete(gl,ctx) -> pp_gl gl ++ fnl () | _ -> str "" let pp_info () = let count_info = if !pruning then str "Proof steps : " ++ int s_info.created_steps ++ str " created / " ++ int s_info.pruned_steps ++ str " pruned" ++ fnl () ++ str "Proof branches : " ++ int s_info.created_branches ++ str " created / " ++ int s_info.pruned_branches ++ str " pruned" ++ fnl () ++ str "Hypotheses : " ++ int s_info.created_hyps ++ str " created / " ++ int s_info.pruned_hyps ++ str " pruned" ++ fnl () else str "Pruning is off" ++ fnl () ++ str "Proof steps : " ++ int s_info.created_steps ++ str " created" ++ fnl () ++ str "Proof branches : " ++ int s_info.created_branches ++ str " created" ++ fnl () ++ str "Hypotheses : " ++ int s_info.created_hyps ++ str " created" ++ fnl () in Feedback.msg_info ( str "Proof-search statistics :" ++ fnl () ++ count_info ++ str "Branch ends: " ++ int s_info.branch_successes ++ str " successes / " ++ int s_info.branch_failures ++ str " failures" ++ fnl () ++ str "Non-deterministic choices : " ++ int s_info.nd_branching ++ str " branches") coq-8.6/plugins/rtauto/g_rtauto.ml40000644000175000017500000000126713022274260016726 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ Proofview.V82.tactic (Refl_tauto.rtauto_tac) ] END coq-8.6/plugins/rtauto/proof_search.mli0000644000175000017500000000233313022274260017634 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* proof val init_state : ('a * form * 'b) list -> form -> state val branching: state -> state list val success: state -> bool val pp: state -> Pp.std_ppcmds val pr_form : form -> Pp.std_ppcmds val reset_info : unit -> unit val pp_info : unit -> unit coq-8.6/plugins/rtauto/refl_tauto.ml0000644000175000017500000002354013022274260017160 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* CClosure.whd_val infos (CClosure.inject t)) let special_nf gl= let infos=CClosure.create_clos_infos CClosure.betaiotazeta (pf_env gl) in (fun t -> CClosure.norm_val infos (CClosure.inject t)) type atom_env= {mutable next:int; mutable env:(constr*int) list} let make_atom atom_env term= try let (_,i)= List.find (fun (t,_)-> eq_constr term t) atom_env.env in Atom i with Not_found -> let i=atom_env.next in atom_env.env <- (term,i)::atom_env.env; atom_env.next<- i + 1; Atom i let rec make_form atom_env gls term = let normalize=special_nf gls in let cciterm=special_whd gls term in match kind_of_term cciterm with Prod(_,a,b) -> if not (Termops.dependent (mkRel 1) b) && Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) a == InProp then let fa=make_form atom_env gls a in let fb=make_form atom_env gls b in Arrow (fa,fb) else make_atom atom_env (normalize term) | Cast(a,_,_) -> make_form atom_env gls a | Ind (ind, _) -> if Names.eq_ind ind (fst (Lazy.force li_False)) then Bot else make_atom atom_env (normalize term) | App(hd,argv) when Int.equal (Array.length argv) 2 -> begin try let ind, _ = destInd hd in if Names.eq_ind ind (fst (Lazy.force li_and)) then let fa=make_form atom_env gls argv.(0) in let fb=make_form atom_env gls argv.(1) in Conjunct (fa,fb) else if Names.eq_ind ind (fst (Lazy.force li_or)) then let fa=make_form atom_env gls argv.(0) in let fb=make_form atom_env gls argv.(1) in Disjunct (fa,fb) else make_atom atom_env (normalize term) with DestKO -> make_atom atom_env (normalize term) end | _ -> make_atom atom_env (normalize term) let rec make_hyps atom_env gls lenv = function [] -> [] | LocalDef (_,body,typ)::rest -> make_hyps atom_env gls (typ::body::lenv) rest | LocalAssum (id,typ)::rest -> let hrec= make_hyps atom_env gls (typ::lenv) rest in if List.exists (Termops.dependent (mkVar id)) lenv || (Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) typ != InProp) then hrec else (id,make_form atom_env gls typ)::hrec let rec build_pos n = if n<=1 then force node_count l_xH else if Int.equal (n land 1) 0 then mkApp (force node_count l_xO,[|build_pos (n asr 1)|]) else mkApp (force node_count l_xI,[|build_pos (n asr 1)|]) let rec build_form = function Atom n -> mkApp (force node_count l_Atom,[|build_pos n|]) | Arrow (f1,f2) -> mkApp (force node_count l_Arrow,[|build_form f1;build_form f2|]) | Bot -> force node_count l_Bot | Conjunct (f1,f2) -> mkApp (force node_count l_Conjunct,[|build_form f1;build_form f2|]) | Disjunct (f1,f2) -> mkApp (force node_count l_Disjunct,[|build_form f1;build_form f2|]) let rec decal k = function [] -> k | (start,delta)::rest -> if k>start then k - delta else decal k rest let add_pop size d pops= match pops with [] -> [size+d,d] | (_,sum)::_ -> (size+sum,sum+d)::pops let rec build_proof pops size = function Ax i -> mkApp (force step_count l_Ax, [|build_pos (decal i pops)|]) | I_Arrow p -> mkApp (force step_count l_I_Arrow, [|build_proof pops (size + 1) p|]) | E_Arrow(i,j,p) -> mkApp (force step_count l_E_Arrow, [|build_pos (decal i pops); build_pos (decal j pops); build_proof pops (size + 1) p|]) | D_Arrow(i,p1,p2) -> mkApp (force step_count l_D_Arrow, [|build_pos (decal i pops); build_proof pops (size + 2) p1; build_proof pops (size + 1) p2|]) | E_False i -> mkApp (force step_count l_E_False, [|build_pos (decal i pops)|]) | I_And(p1,p2) -> mkApp (force step_count l_I_And, [|build_proof pops size p1; build_proof pops size p2|]) | E_And(i,p) -> mkApp (force step_count l_E_And, [|build_pos (decal i pops); build_proof pops (size + 2) p|]) | D_And(i,p) -> mkApp (force step_count l_D_And, [|build_pos (decal i pops); build_proof pops (size + 1) p|]) | I_Or_l(p) -> mkApp (force step_count l_I_Or_l, [|build_proof pops size p|]) | I_Or_r(p) -> mkApp (force step_count l_I_Or_r, [|build_proof pops size p|]) | E_Or(i,p1,p2) -> mkApp (force step_count l_E_Or, [|build_pos (decal i pops); build_proof pops (size + 1) p1; build_proof pops (size + 1) p2|]) | D_Or(i,p) -> mkApp (force step_count l_D_Or, [|build_pos (decal i pops); build_proof pops (size + 2) p|]) | Pop(d,p) -> build_proof (add_pop size d pops) size p let build_env gamma= List.fold_right (fun (p,_) e -> mkApp(force node_count l_push,[|mkProp;p;e|])) gamma.env (mkApp (force node_count l_empty,[|mkProp|])) open Goptions let verbose = ref false let opt_verbose= {optsync=true; optdepr=false; optname="Rtauto Verbose"; optkey=["Rtauto";"Verbose"]; optread=(fun () -> !verbose); optwrite=(fun b -> verbose:=b)} let _ = declare_bool_option opt_verbose let check = ref false let opt_check= {optsync=true; optdepr=false; optname="Rtauto Check"; optkey=["Rtauto";"Check"]; optread=(fun () -> !check); optwrite=(fun b -> check:=b)} let _ = declare_bool_option opt_check open Pp let rtauto_tac gls= Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"]; let gamma={next=1;env=[]} in let gl=pf_concl gls in let _= if Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) gl != InProp then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in let glf=make_form gamma gls gl in let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in let formula= List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in let search_fun = match Tacinterp.get_debug() with | Tactic_debug.DebugOn 0 -> Search.debug_depth_first | _ -> Search.depth_first in let _ = begin reset_info (); if !verbose then Feedback.msg_info (str "Starting proof-search ..."); end in let search_start_time = System.get_time () in let prf = try project (search_fun (init_state [] formula)) with Not_found -> errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in let search_end_time = System.get_time () in let _ = if !verbose then begin Feedback.msg_info (str "Proof tree found in " ++ System.fmt_time_difference search_start_time search_end_time); pp_info (); Feedback.msg_info (str "Building proof term ... ") end in let build_start_time=System.get_time () in let _ = step_count := 0; node_count := 0 in let main = mkApp (force node_count l_Reflect, [|build_env gamma; build_form formula; build_proof [] 0 prf|]) in let term= applist (main,List.rev_map (fun (id,_) -> mkVar id) hyps) in let build_end_time=System.get_time () in let _ = if !verbose then begin Feedback.msg_info (str "Proof term built in " ++ System.fmt_time_difference build_start_time build_end_time ++ fnl () ++ str "Proof size : " ++ int !step_count ++ str " steps" ++ fnl () ++ str "Proof term size : " ++ int (!step_count+ !node_count) ++ str " nodes (constants)" ++ fnl () ++ str "Giving proof term to Coq ... ") end in let tac_start_time = System.get_time () in let result= if !check then Proofview.V82.of_tactic (Tactics.exact_check term) gls else Proofview.V82.of_tactic (Tactics.exact_no_check term) gls in let tac_end_time = System.get_time () in let _ = if !check then Feedback.msg_info (str "Proof term type-checking is on"); if !verbose then Feedback.msg_info (str "Internal tactic executed in " ++ System.fmt_time_difference tac_start_time tac_end_time) in result coq-8.6/plugins/rtauto/vo.itarget0000644000175000017500000000002513022274260016460 0ustar mdenesmdenesBintree.vo Rtauto.vo coq-8.6/plugins/syntax/0000755000175000017500000000000013022274260014466 5ustar mdenesmdenescoq-8.6/plugins/syntax/numbers_syntax_plugin.mlpack0000644000175000017500000000001713022274260022314 0ustar mdenesmdenesNumbers_syntax coq-8.6/plugins/syntax/nat_syntax.ml0000644000175000017500000000503413022274260017212 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* > *) let threshold = of_int 5000 let warn_large_nat = CWarnings.create ~name:"large-nat" ~category:"numbers" (fun () -> strbrk "Stack overflow or segmentation fault happens when " ++ strbrk "working with large numbers in nat (observed threshold " ++ strbrk "may vary from 5000 to 70000 depending on your system " ++ strbrk "limits and on the command executed).") let nat_of_int dloc n = if is_pos_or_zero n then begin if less_than threshold n then warn_large_nat (); let ref_O = GRef (dloc, glob_O, None) in let ref_S = GRef (dloc, glob_S, None) in let rec mk_nat acc n = if n <> zero then mk_nat (GApp (dloc,ref_S, [acc])) (sub_1 n) else acc in mk_nat ref_O n end else user_err_loc (dloc, "nat_of_int", str "Cannot interpret a negative number as a number of type nat") (************************************************************************) (* Printing via scopes *) exception Non_closed_number let rec int_of_nat = function | GApp (_,GRef (_,s,_),[a]) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) | GRef (_,z,_) when Globnames.eq_gr z glob_O -> zero | _ -> raise Non_closed_number let uninterp_nat p = try Some (int_of_nat p) with Non_closed_number -> None (************************************************************************) (* Declare the primitive parsers and printers *) let _ = Notation.declare_numeral_interpreter "nat_scope" (nat_path,datatypes_module_name) nat_of_int ([GRef (Loc.ghost,glob_S,None); GRef (Loc.ghost,glob_O,None)], uninterp_nat, true) coq-8.6/plugins/syntax/r_syntax_plugin.mlpack0000644000175000017500000000001113022274260021074 0ustar mdenesmdenesR_syntax coq-8.6/plugins/syntax/z_syntax.ml0000644000175000017500000001525313022274260016705 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* GApp (dloc, ref_xO,[pos_of q]) | (q,true) when not (Bigint.equal q zero) -> GApp (dloc,ref_xI,[pos_of q]) | (q,true) -> ref_xH in pos_of x let error_non_positive dloc = user_err_loc (dloc, "interp_positive", str "Only strictly positive numbers in type \"positive\".") let interp_positive dloc n = if is_strictly_pos n then pos_of_bignat dloc n else error_non_positive dloc (**********************************************************************) (* Printing positive via scopes *) (**********************************************************************) let rec bignat_of_pos = function | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one | _ -> raise Non_closed_number let uninterp_positive p = try Some (bignat_of_pos p) with Non_closed_number -> None (************************************************************************) (* Declaring interpreters and uninterpreters for positive *) (************************************************************************) let _ = Notation.declare_numeral_interpreter "positive_scope" (positive_path,binnums) interp_positive ([GRef (Loc.ghost, glob_xI, None); GRef (Loc.ghost, glob_xO, None); GRef (Loc.ghost, glob_xH, None)], uninterp_positive, true) (**********************************************************************) (* Parsing N via scopes *) (**********************************************************************) let n_kn = make_kn (make_dir binnums) (Id.of_string "N") let glob_n = IndRef (n_kn,0) let path_of_N0 = ((n_kn,0),1) let path_of_Npos = ((n_kn,0),2) let glob_N0 = ConstructRef path_of_N0 let glob_Npos = ConstructRef path_of_Npos let n_path = make_path binnums "N" let n_of_binnat dloc pos_or_neg n = if not (Bigint.equal n zero) then GApp(dloc, GRef (dloc,glob_Npos,None), [pos_of_bignat dloc n]) else GRef (dloc, glob_N0, None) let error_negative dloc = user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".") let n_of_int dloc n = if is_pos_or_zero n then n_of_binnat dloc true n else error_negative dloc (**********************************************************************) (* Printing N via scopes *) (**********************************************************************) let bignat_of_n = function | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_Npos -> bignat_of_pos a | GRef (_, a,_) when Globnames.eq_gr a glob_N0 -> Bigint.zero | _ -> raise Non_closed_number let uninterp_n p = try Some (bignat_of_n p) with Non_closed_number -> None (************************************************************************) (* Declaring interpreters and uninterpreters for N *) let _ = Notation.declare_numeral_interpreter "N_scope" (n_path,binnums) n_of_int ([GRef (Loc.ghost, glob_N0, None); GRef (Loc.ghost, glob_Npos, None)], uninterp_n, true) (**********************************************************************) (* Parsing Z via scopes *) (**********************************************************************) let z_path = make_path binnums "Z" let z_kn = make_kn (make_dir binnums) (Id.of_string "Z") let glob_z = IndRef (z_kn,0) let path_of_ZERO = ((z_kn,0),1) let path_of_POS = ((z_kn,0),2) let path_of_NEG = ((z_kn,0),3) let glob_ZERO = ConstructRef path_of_ZERO let glob_POS = ConstructRef path_of_POS let glob_NEG = ConstructRef path_of_NEG let z_of_int dloc n = if not (Bigint.equal n zero) then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n]) else GRef (dloc, glob_ZERO, None) (**********************************************************************) (* Printing Z via scopes *) (**********************************************************************) let bigint_of_z = function | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number let uninterp_z p = try Some (bigint_of_z p) with Non_closed_number -> None (************************************************************************) (* Declaring interpreters and uninterpreters for Z *) let _ = Notation.declare_numeral_interpreter "Z_scope" (z_path,binnums) z_of_int ([GRef (Loc.ghost, glob_ZERO, None); GRef (Loc.ghost, glob_POS, None); GRef (Loc.ghost, glob_NEG, None)], uninterp_z, true) coq-8.6/plugins/syntax/string_syntax_plugin.mlpack0000644000175000017500000000001613022274260022146 0ustar mdenesmdenesString_syntax coq-8.6/plugins/syntax/ascii_syntax.ml0000644000175000017500000000552513022274260017525 0ustar mdenesmdenes(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 | GRef (_,k,_)::l when Globnames.eq_gr k glob_true -> 1+2*(uninterp_bool_list (n-1) l) | GRef (_,k,_)::l when Globnames.eq_gr k glob_false -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in try let aux = function | GApp (_,GRef (_,k,_),l) when Globnames.eq_gr k (force glob_Ascii) -> uninterp_bool_list 8 l | _ -> raise Non_closed_ascii in Some (aux r) with Non_closed_ascii -> None let make_ascii_string n = if n>=32 && n<=126 then String.make 1 (char_of_int n) else Printf.sprintf "%03d" n let uninterp_ascii_string r = Option.map make_ascii_string (uninterp_ascii r) let _ = Notation.declare_string_interpreter "char_scope" (ascii_path,ascii_module) interp_ascii_string ([GRef (Loc.ghost,static_glob_Ascii,None)], uninterp_ascii_string, true) coq-8.6/plugins/syntax/numbers_syntax.ml0000644000175000017500000002221713022274260020105 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* cur | (GRef (_,b,_))::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur) | (GRef (_,b,_))::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur)) | _ -> raise Non_closed in function | GApp (_, GRef (_, c, _), args) when eq_gr c int31_construct -> args_parsing args zero | _ -> raise Non_closed let uninterp_int31 i = try Some (bigint_of_int31 i) with Non_closed -> None (* Actually declares the interpreter for int31 *) let _ = Notation.declare_numeral_interpreter int31_scope (int31_path, int31_module) interp_int31 ([GRef (Loc.ghost, int31_construct, None)], uninterp_int31, true) (*** Parsing for bigN in digital notation ***) (* the base for bigN (in Coq) that is 2^31 in our case *) let base = pow two 31 (* base of the bigN of height N : (2^31)^(2^n) *) let rank n = let rec rk n pow2 = if n <= 0 then pow2 else rk (n-1) (mult pow2 pow2) in rk n base (* splits a number bi at height n, that is the rest needs 2^n int31 to be stored it is expected to be used only when the quotient would also need 2^n int31 to be stored *) let split_at n bi = euclid bi (rank (n-1)) (* search the height of the Coq bigint needed to represent the integer bi *) let height bi = let rec hght n pow2 = if less_than bi pow2 then n else hght (n+1) (mult pow2 pow2) in hght 0 base (* n must be a non-negative integer (from bigint.ml) *) let word_of_pos_bigint dloc hght n = let ref_W0 = GRef (dloc, zn2z_W0, None) in let ref_WW = GRef (dloc, zn2z_WW, None) in let rec decomp hgt n = if hgt <= 0 then int31_of_pos_bigint dloc n else if equal n zero then GApp (dloc, ref_W0, [GHole (dloc, Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None)]) else let (h,l) = split_at hgt n in GApp (dloc, ref_WW, [GHole (dloc, Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None); decomp (hgt-1) h; decomp (hgt-1) l]) in decomp hght n let bigN_of_pos_bigint dloc n = let h = height n in let ref_constructor = GRef (dloc, bigN_constructor h, None) in let word = word_of_pos_bigint dloc h n in let args = if h < n_inlined then [word] else [Nat_syntax_plugin.Nat_syntax.nat_of_int dloc (of_int (h-n_inlined));word] in GApp (dloc, ref_constructor, args) let bigN_error_negative dloc = CErrors.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.") let interp_bigN dloc n = if is_pos_or_zero n then bigN_of_pos_bigint dloc n else bigN_error_negative dloc (* Pretty prints a bigN *) let bigint_of_word = let rec get_height rc = match rc with | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW -> 1+max (get_height lft) (get_height rght) | _ -> 0 in let rec transform hght rc = match rc with | GApp (_,GRef(_,c,_),_) when eq_gr c zn2z_W0-> zero | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW-> let new_hght = hght-1 in add (mult (rank new_hght) (transform new_hght lft)) (transform new_hght rght) | _ -> bigint_of_int31 rc in fun rc -> let hght = get_height rc in transform hght rc let bigint_of_bigN rc = match rc with | GApp (_,_,[one_arg]) -> bigint_of_word one_arg | GApp (_,_,[_;second_arg]) -> bigint_of_word second_arg | _ -> raise Non_closed let uninterp_bigN rc = try Some (bigint_of_bigN rc) with Non_closed -> None (* declare the list of constructors of bigN used in the declaration of the numeral interpreter *) let bigN_list_of_constructors = let rec build i = if i < n_inlined+1 then GRef (Loc.ghost, bigN_constructor i,None)::(build (i+1)) else [] in build 0 (* Actually declares the interpreter for bigN *) let _ = Notation.declare_numeral_interpreter bigN_scope (bigN_path, bigN_module) interp_bigN (bigN_list_of_constructors, uninterp_bigN, true) (*** Parsing for bigZ in digital notation ***) let interp_bigZ dloc n = let ref_pos = GRef (dloc, bigZ_pos, None) in let ref_neg = GRef (dloc, bigZ_neg, None) in if is_pos_or_zero n then GApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n]) else GApp (dloc, ref_neg, [bigN_of_pos_bigint dloc (neg n)]) (* pretty printing functions for bigZ *) let bigint_of_bigZ = function | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_pos -> bigint_of_bigN one_arg | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_neg -> let opp_val = bigint_of_bigN one_arg in if equal opp_val zero then raise Non_closed else neg opp_val | _ -> raise Non_closed let uninterp_bigZ rc = try Some (bigint_of_bigZ rc) with Non_closed -> None (* Actually declares the interpreter for bigZ *) let _ = Notation.declare_numeral_interpreter bigZ_scope (bigZ_path, bigZ_module) interp_bigZ ([GRef (Loc.ghost, bigZ_pos, None); GRef (Loc.ghost, bigZ_neg, None)], uninterp_bigZ, true) (*** Parsing for bigQ in digital notation ***) let interp_bigQ dloc n = let ref_z = GRef (dloc, bigQ_z, None) in GApp (dloc, ref_z, [interp_bigZ dloc n]) let uninterp_bigQ rc = try match rc with | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigQ_z -> Some (bigint_of_bigZ one_arg) | _ -> None (* we don't pretty-print yet fractions *) with Non_closed -> None (* Actually declares the interpreter for bigQ *) let _ = Notation.declare_numeral_interpreter bigQ_scope (bigQ_path, bigQ_module) interp_bigQ ([GRef (Loc.ghost, bigQ_z, None)], uninterp_bigQ, true) coq-8.6/plugins/syntax/ascii_syntax_plugin.mlpack0000644000175000017500000000001513022274260021727 0ustar mdenesmdenesAscii_syntax coq-8.6/plugins/syntax/z_syntax_plugin.mlpack0000644000175000017500000000001113022274260021104 0ustar mdenesmdenesZ_syntax coq-8.6/plugins/syntax/string_syntax.ml0000644000175000017500000000430013022274260017731 0ustar mdenesmdenes(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (match uninterp_ascii a with | Some c -> Buffer.add_char b (Char.chr c); aux s | _ -> raise Non_closed_string) | GRef (_,z,_) when eq_gr z (force glob_EmptyString) -> Some (Buffer.contents b) | _ -> raise Non_closed_string in aux r with Non_closed_string -> None let _ = Notation.declare_string_interpreter "string_scope" (string_path,["Coq";"Strings";"String"]) interp_string ([GRef (Loc.ghost,static_glob_String,None); GRef (Loc.ghost,static_glob_EmptyString,None)], uninterp_string, true) coq-8.6/plugins/syntax/r_syntax.ml0000644000175000017500000001075113022274260016673 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 1 *) let rec bignat_of_pos = function (* 1+1 *) | GApp (_,GRef (_,p,_), [GRef (_,o1,_); GRef (_,o2,_)]) when Globnames.eq_gr p glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 -> two (* 1+(1+1) *) | GApp (_,GRef (_,p1,_), [GRef (_,o1,_); GApp(_,GRef (_,p2,_),[GRef(_,o2,_);GRef(_,o3,_)])]) when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 && Globnames.eq_gr o3 glob_R1 -> three (* (1+1)*b *) | GApp (_,GRef (_,p,_), [a; b]) when Globnames.eq_gr p glob_Rmult -> if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; mult_2 (bignat_of_pos b) (* 1+(1+1)*b *) | GApp (_,GRef (_,p1,_), [GRef (_,o,_); GApp (_,GRef (_,p2,_),[a;b])]) when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rmult && Globnames.eq_gr o glob_R1 -> if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; add_1 (mult_2 (bignat_of_pos b)) | _ -> raise Non_closed_number in let bignat_of_r = function | GRef (_,a,_) when Globnames.eq_gr a glob_R0 -> zero | GRef (_,a,_) when Globnames.eq_gr a glob_R1 -> one | r -> bignat_of_pos r in bignat_of_r let bigint_of_r = function | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_Ropp -> let n = bignat_of_r a in if Bigint.equal n zero then raise Non_closed_number; neg n | a -> bignat_of_r a let uninterp_r p = try Some (bigint_of_r p) with Non_closed_number -> None let mkGRef gr = GRef (Loc.ghost,gr,None) let _ = Notation.declare_numeral_interpreter "R_scope" (r_path,["Coq";"Reals";"Rdefinitions"]) r_of_int (List.map mkGRef [glob_Ropp;glob_R0;glob_Rplus;glob_Rmult;glob_R1], uninterp_r, false) coq-8.6/plugins/syntax/nat_syntax_plugin.mlpack0000644000175000017500000000001313022274260021417 0ustar mdenesmdenesNat_syntax coq-8.6/plugins/omega/0000755000175000017500000000000013022274260014230 5ustar mdenesmdenescoq-8.6/plugins/omega/omega_plugin.mlpack0000644000175000017500000000003013022274260020060 0ustar mdenesmdenesOmega Coq_omega G_omega coq-8.6/plugins/omega/omega.ml0000644000175000017500000006322213022274260015657 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bigint -> bool val less_than : bigint -> bigint -> bool val add : bigint -> bigint -> bigint val sub : bigint -> bigint -> bigint val mult : bigint -> bigint -> bigint val euclid : bigint -> bigint -> bigint * bigint val neg : bigint -> bigint val zero : bigint val one : bigint val to_string : bigint -> string end let debug = ref false module MakeOmegaSolver (I:INT) = struct type bigint = I.bigint let (=?) = I.equal let (?) x y = I.less_than y x let (>=?) x y = I.less_than y x || x = y let (+) = I.add let (-) = I.sub let ( * ) = I.mult let (/) x y = fst (I.euclid x y) let (mod) x y = snd (I.euclid x y) let zero = I.zero let one = I.one let two = one + one let negone = I.neg one let abs x = if I.less_than x zero then I.neg x else x let string_of_bigint = I.to_string let neg = I.neg (* To ensure that polymorphic (<) is not used mistakenly on big integers *) (* Warning: do not use (=) either on big int *) let (<) = ((<) : int -> int -> bool) let (>) = ((>) : int -> int -> bool) let (<=) = ((<=) : int -> int -> bool) let (>=) = ((>=) : int -> int -> bool) let pp i = print_int i; print_newline (); flush stdout let push v l = l := v :: !l let rec pgcd x y = if y =? zero then x else pgcd y (x mod y) let pgcd_l = function | [] -> failwith "pgcd_l" | x :: l -> List.fold_left pgcd x l let floor_div a b = match a >=? zero , b >? zero with | true,true -> a / b | false,false -> a / b | true, false -> (a-one) / b - one | false,true -> (a+one) / b - one type coeff = {c: bigint ; v: int} type linear = coeff list type eqn_kind = EQUA | INEQ | DISE type afine = { (* a number uniquely identifying the equation *) id: int ; (* a boolean true for an eq, false for an ineq (Sigma a_i x_i >= 0) *) kind: eqn_kind; (* the variables and their coefficient *) body: coeff list; (* a constant *) constant: bigint } type state_action = { st_new_eq : afine; st_def : afine; st_orig : afine; st_coef : bigint; st_var : int } type action = | DIVIDE_AND_APPROX of afine * afine * bigint * bigint | NOT_EXACT_DIVIDE of afine * bigint | FORGET_C of int | EXACT_DIVIDE of afine * bigint | SUM of int * (bigint * afine) * (bigint * afine) | STATE of state_action | HYP of afine | FORGET of int * int | FORGET_I of int * int | CONTRADICTION of afine * afine | NEGATE_CONTRADICT of afine * afine * bool | MERGE_EQ of int * afine * int | CONSTANT_NOT_NUL of int * bigint | CONSTANT_NUL of int | CONSTANT_NEG of int * bigint | SPLIT_INEQ of afine * (int * action list) * (int * action list) | WEAKEN of int * bigint exception UNSOLVABLE exception NO_CONTRADICTION let display_eq print_var (l,e) = let _ = List.fold_left (fun not_first f -> print_string (if f.c ? zero then Printf.printf "+ %s " (string_of_bigint e) else if e accu + one + trace_length l1 + trace_length l2 | _ -> accu + one in List.fold_left action_length zero l let operator_of_eq = function | EQUA -> "=" | DISE -> "!=" | INEQ -> ">=" let kind_of = function | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation" let display_system print_var l = List.iter (fun { kind=b; body=e; constant=c; id=id} -> Printf.printf "E%d: " id; display_eq print_var (e,c); Printf.printf "%s 0\n" (operator_of_eq b)) l; print_string "------------------------\n\n" let display_inequations print_var l = List.iter (fun e -> display_eq print_var e;print_string ">= 0\n") l; print_string "------------------------\n\n" let sbi = string_of_bigint let rec display_action print_var = function | act :: l -> begin match act with | DIVIDE_AND_APPROX (e1,e2,k,d) -> Printf.printf "Inequation E%d is divided by %s and the constant coefficient is \ rounded by substracting %s.\n" e1.id (sbi k) (sbi d) | NOT_EXACT_DIVIDE (e,k) -> Printf.printf "Constant in equation E%d is not divisible by the pgcd \ %s of its other coefficients.\n" e.id (sbi k) | EXACT_DIVIDE (e,k) -> Printf.printf "Equation E%d is divided by the pgcd \ %s of its coefficients.\n" e.id (sbi k) | WEAKEN (e,k) -> Printf.printf "To ensure a solution in the dark shadow \ the equation E%d is weakened by %s.\n" e (sbi k) | SUM (e,(c1,e1),(c2,e2)) -> Printf.printf "We state %s E%d = %s %s E%d + %s %s E%d.\n" (kind_of e1.kind) e (sbi c1) (kind_of e1.kind) e1.id (sbi c2) (kind_of e2.kind) e2.id | STATE { st_new_eq = e } -> Printf.printf "We define a new equation E%d: " e.id; display_eq print_var (e.body,e.constant); print_string (operator_of_eq e.kind); print_string " 0" | HYP e -> Printf.printf "We define E%d: " e.id; display_eq print_var (e.body,e.constant); print_string (operator_of_eq e.kind); print_string " 0\n" | FORGET_C e -> Printf.printf "E%d is trivially satisfiable.\n" e | FORGET (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 | FORGET_I (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 | MERGE_EQ (e,e1,e2) -> Printf.printf "E%d and E%d can be merged into E%d.\n" e1.id e2 e | CONTRADICTION (e1,e2) -> Printf.printf "Equations E%d and E%d imply a contradiction on their \ constant factors.\n" e1.id e2.id | NEGATE_CONTRADICT(e1,e2,b) -> Printf.printf "Equations E%d and E%d state that their body is at the same time \ equal and different\n" e1.id e2.id | CONSTANT_NOT_NUL (e,k) -> Printf.printf "Equation E%d states %s = 0.\n" e (sbi k) | CONSTANT_NEG(e,k) -> Printf.printf "Equation E%d states %s >= 0.\n" e (sbi k) | CONSTANT_NUL e -> Printf.printf "Inequation E%d states 0 != 0.\n" e | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> Printf.printf "Equation E%d is split in E%d and E%d\n\n" e.id e1 e2; display_action print_var l1; print_newline (); display_action print_var l2; print_newline () end; display_action print_var l | [] -> flush stdout let default_print_var v = Printf.sprintf "X%d" v (* For debugging *) (*""*) let add_event, history, clear_history = let accu = ref [] in (fun (v:action) -> if !debug then display_action default_print_var [v]; push v accu), (fun () -> !accu), (fun () -> accu := []) let nf_linear = List.sort (fun x y -> Pervasives.(-) y.v x.v) let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x)) let map_eq_linear f = let rec loop = function | x :: l -> let c = f x.c in if c=?zero then loop l else {v=x.v; c=c} :: loop l | [] -> [] in loop let map_eq_afine f e = { id = e.id; kind = e.kind; body = map_eq_linear f e.body; constant = f e.constant } let negate_eq = map_eq_afine (fun x -> neg x) let rec sum p0 p1 = match (p0,p1) with | ([], l) -> l | (l, []) -> l | (((x1::l1) as l1'), ((x2::l2) as l2')) -> if x1.v = x2.v then let c = x1.c + x2.c in if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2 else if x1.v > x2.v then x1 :: sum l1 l2' else x2 :: sum l1' l2 let sum_afine new_eq_id eq1 eq2 = { kind = eq1.kind; id = new_eq_id (); body = sum eq1.body eq2.body; constant = eq1.constant + eq2.constant } exception FACTOR1 let rec chop_factor_1 = function | x :: l -> if abs x.c =? one then x,l else let (c',l') = chop_factor_1 l in (c',x::l') | [] -> raise FACTOR1 exception CHOPVAR let rec chop_var v = function | f :: l -> if f.v = v then f,l else let (f',l') = chop_var v l in (f',f::l') | [] -> raise CHOPVAR let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = if e = [] then begin match eq_flag with | EQUA -> if x =? zero then [] else begin add_event (CONSTANT_NOT_NUL(id,x)); raise UNSOLVABLE end | DISE -> if x <> zero then [] else begin add_event (CONSTANT_NUL id); raise UNSOLVABLE end | INEQ -> if x >=? zero then [] else begin add_event (CONSTANT_NEG(id,x)); raise UNSOLVABLE end end else let gcd = pgcd_l (List.map (fun f -> abs f.c) e) in if eq_flag=EQUA && x mod gcd <> zero then begin add_event (NOT_EXACT_DIVIDE (eq,gcd)); raise UNSOLVABLE end else if eq_flag=DISE && x mod gcd <> zero then begin add_event (FORGET_C eq.id); [] end else if gcd <> one then begin let c = floor_div x gcd in let d = x - c * gcd in let new_eq = {id=id; kind=eq_flag; constant=c; body=map_eq_linear (fun c -> c / gcd) e} in add_event (if eq_flag=EQUA || eq_flag = DISE then EXACT_DIVIDE(eq,gcd) else DIVIDE_AND_APPROX(eq,new_eq,gcd,d)); [new_eq] end else [eq] let eliminate_with_in new_eq_id {v=v;c=c_unite} eq2 ({body=e1; constant=c1} as eq1) = try let (f,_) = chop_var v e1 in let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c else failwith "eliminate_with_in" in let res = sum_afine new_eq_id eq1 (map_eq_afine (fun c -> c * coeff) eq2) in add_event (SUM (res.id,(one,eq1),(coeff,eq2))); res with CHOPVAR -> eq1 let omega_mod a b = a - b * floor_div (two * a + b) (two * b) let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = let e = original.body in let sigma = new_var_id () in let smallest,var = try List.fold_left (fun (v,p) c -> if v >? (abs c.c) then abs c.c,c.v else (v,p)) (abs (List.hd e).c, (List.hd e).v) (List.tl e) with Failure "tl" -> display_system print_var [original] ; failwith "TL" in let m = smallest + one in let new_eq = { constant = omega_mod original.constant m; body = {c= neg m;v=sigma} :: map_eq_linear (fun a -> omega_mod a m) original.body; id = new_eq_id (); kind = EQUA } in let definition = { constant = neg (floor_div (two * original.constant + m) (two * m)); body = map_eq_linear (fun a -> neg (floor_div (two * a + m) (two * m))) original.body; id = new_eq_id (); kind = EQUA } in add_event (STATE {st_new_eq = new_eq; st_def = definition; st_orig = original; st_coef = m; st_var = sigma}); let new_eq = List.hd (normalize new_eq) in let eliminated_var, def = chop_var var new_eq.body in let other_equations = Util.List.map_append (fun e -> normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in let inequations = Util.List.map_append (fun e -> normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in let original' = eliminate_with_in new_eq_id eliminated_var new_eq original in let mod_original = map_eq_afine (fun c -> c / m) original' in add_event (EXACT_DIVIDE (original',m)); List.hd (normalize mod_original),other_equations,inequations let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = if !debug then display_system print_var (e::other); try let v,def = chop_factor_1 e.body in (Util.List.map_append (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other, Util.List.map_append (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) ineqs) with FACTOR1 -> eliminate_one_equation new_ids (banerjee_step new_ids e other ineqs) let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) = let rec fst_eq_1 = function (eq::l) -> if List.exists (fun x -> abs x.c =? one) eq.body then eq,l else let (eq',l') = fst_eq_1 l in (eq',eq::l') | [] -> raise Not_found in match sys_eq with [] -> if !debug then display_system print_var sys_ineq; sys_ineq | (e1::rest) -> let eq,other = try fst_eq_1 sys_eq with Not_found -> (e1,rest) in if eq.body = [] then if eq.constant =? zero then begin add_event (FORGET_C eq.id); banerjee new_ids (other,sys_ineq) end else begin add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE end else banerjee new_ids (eliminate_one_equation new_ids (eq,other,sys_ineq)) type kind = INVERTED | NORMAL let redundancy_elimination new_eq_id system = let normal = function ({body=f::_} as e) when f.c negate_eq e, INVERTED | e -> e,NORMAL in let table = Hashtbl.create 7 in List.iter (fun e -> let ({body=ne} as nx) ,kind = normal e in if ne = [] then if nx.constant let kept = if v.constant Some nx,optinvert end else begin match optinvert with Some v -> let _kept = if v.constant >? nx.constant then begin add_event (FORGET_I (v.id,nx.id));v end else begin add_event (FORGET_I (nx.id,v.id));nx end in (optnormal,Some(if v.constant >? nx.constant then v else nx)) | None -> optnormal,Some nx end in begin match final with (Some high, Some low) -> if high.constant () end; Hashtbl.remove table ne; Hashtbl.add table ne final with Not_found -> Hashtbl.add table ne (if kind = NORMAL then (Some nx,None) else (None,Some nx))) system; let accu_eq = ref [] in let accu_ineq = ref [] in Hashtbl.iter (fun p0 p1 -> match (p0,p1) with | (e, (Some x, Some y)) when x.constant =? y.constant -> let id=new_eq_id () in add_event (MERGE_EQ(id,x,y.id)); push {id=id; kind=EQUA; body=x.body; constant=x.constant} accu_eq | (e, (optnorm,optinvert)) -> begin match optnorm with Some x -> push x accu_ineq | _ -> () end; begin match optinvert with Some x -> push (negate_eq x) accu_ineq | _ -> () end) table; !accu_eq,!accu_ineq exception SOLVED_SYSTEM let select_variable system = let table = Hashtbl.create 7 in let push v c= try let r = Hashtbl.find table v in r := max !r (abs c) with Not_found -> Hashtbl.add table v (ref (abs c)) in List.iter (fun {body=l} -> List.iter (fun f -> push f.v f.c) l) system; let vmin,cmin = ref (-1), ref zero in let var_cpt = ref 0 in Hashtbl.iter (fun v ({contents = c}) -> incr var_cpt; if c try let f,eq' = chop_var v eq.body in if f.c >=? zero then (not_occ,((f.c,eq) :: below),over) else (not_occ,below,((neg f.c,eq) :: over)) with CHOPVAR -> (eq::not_occ,below,over)) ([],[],[]) system let product new_eq_id dark_shadow low high = List.fold_left (fun accu (a,eq1) -> List.fold_left (fun accu (b,eq2) -> let eq = sum_afine new_eq_id (map_eq_afine (fun c -> c * b) eq1) (map_eq_afine (fun c -> c * a) eq2) in add_event(SUM(eq.id,(b,eq1),(a,eq2))); match normalize eq with | [eq] -> let final_eq = if dark_shadow then let delta = (a - one) * (b - one) in add_event(WEAKEN(eq.id,delta)); {id = eq.id; kind=INEQ; body = eq.body; constant = eq.constant - delta} else eq in final_eq :: accu | (e::_) -> failwith "Product dardk" | [] -> accu) accu high) [] low let fourier_motzkin (new_eq_id,_,print_var) dark_shadow system = let v = select_variable system in let (ineq_out, ineq_low,ineq_high) = classify v system in let expanded = ineq_out @ product new_eq_id dark_shadow ineq_low ineq_high in if !debug then display_system print_var expanded; expanded let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system = if List.exists (fun e -> e.kind = DISE) system then failwith "disequation in simplify"; clear_history (); List.iter (fun e -> add_event (HYP e)) system; let system = Util.List.map_append normalize system in let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in let system = (eqs @ simp_eq,simp_ineq) in let rec loop1a system = let sys_ineq = banerjee new_ids system in loop1b sys_ineq and loop1b sys_ineq = let simp_eq,simp_ineq = redundancy_elimination new_eq_id sys_ineq in if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) in let rec loop2 system = try let expanded = fourier_motzkin new_ids dark_shadow system in loop2 (loop1b expanded) with SOLVED_SYSTEM -> if !debug then display_system print_var system; system in loop2 (loop1a system) let rec depend relie_on accu = function | act :: l -> begin match act with | DIVIDE_AND_APPROX (e,_,_,_) -> if Int.List.mem e.id relie_on then depend relie_on (act::accu) l else depend relie_on accu l | EXACT_DIVIDE (e,_) -> if Int.List.mem e.id relie_on then depend relie_on (act::accu) l else depend relie_on accu l | WEAKEN (e,_) -> if Int.List.mem e relie_on then depend relie_on (act::accu) l else depend relie_on accu l | SUM (e,(_,e1),(_,e2)) -> if Int.List.mem e relie_on then depend (e1.id::e2.id::relie_on) (act::accu) l else depend relie_on accu l | STATE {st_new_eq=e;st_orig=o} -> if Int.List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l else depend relie_on accu l | HYP e -> if Int.List.mem e.id relie_on then depend relie_on (act::accu) l else depend relie_on accu l | FORGET_C _ -> depend relie_on accu l | FORGET _ -> depend relie_on accu l | FORGET_I _ -> depend relie_on accu l | MERGE_EQ (e,e1,e2) -> if Int.List.mem e relie_on then depend (e1.id::e2::relie_on) (act::accu) l else depend relie_on accu l | NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l | CONTRADICTION (e1,e2) -> depend (e1.id::e2.id::relie_on) (act::accu) l | CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l | CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l | CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l | NEGATE_CONTRADICT (e1,e2,_) -> depend (e1.id::e2.id::relie_on) (act::accu) l | SPLIT_INEQ _ -> failwith "depend" end | [] -> relie_on, accu let solve (new_eq_id,new_eq_var,print_var) system = try let _ = simplify new_eq_id false system in failwith "no contradiction" with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ()))) let negation (eqs,ineqs) = let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in let normal = function | ({body=f::_} as e) when f.c negate_eq e, INVERTED | e -> e,NORMAL in let table = Hashtbl.create 7 in List.iter (fun e -> let {body=ne;constant=c} ,kind = normal e in Hashtbl.add table (ne,c) (kind,e)) diseq; List.iter (fun e -> assert (e.kind = EQUA); let {body=ne;constant=c},kind = normal e in try let (kind',e') = Hashtbl.find table (ne,c) in add_event (NEGATE_CONTRADICT (e,e',kind=kind')); raise UNSOLVABLE with Not_found -> ()) eqs exception FULL_SOLUTION of action list * int list let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = clear_history (); List.iter (fun e -> add_event (HYP e)) system; (* Initial simplification phase *) let rec loop1a system = negation system; let sys_ineq = banerjee new_ids system in loop1b sys_ineq and loop1b sys_ineq = let dise,ine = List.partition (fun e -> e.kind = DISE) sys_ineq in let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in if simp_eq = [] then dise @ simp_ineq else loop1a (simp_eq,dise @ simp_ineq) in let rec loop2 system = try let expanded = fourier_motzkin new_ids false system in loop2 (loop1b expanded) with SOLVED_SYSTEM -> if !debug then display_system print_var system; system in let rec explode_diseq = function | (de::diseq,ineqs,expl_map) -> let id1 = new_eq_id () and id2 = new_eq_id () in let e1 = {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in let e2 = {id = id2; kind=INEQ; body = map_eq_linear neg de.body; constant = neg de.constant - one} in let new_sys = List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) ineqs @ List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) ineqs in explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map) | ([],ineqs,expl_map) -> ineqs,expl_map in try let system = Util.List.map_append normalize system in let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in let system = (eqs @ simp_eq,simp_ineq @ dise) in let system' = loop1a system in let diseq,ineq = List.partition (fun e -> e.kind = DISE) system' in let first_segment = history () in let sys_exploded,explode_map = explode_diseq (diseq,[[],ineq],[]) in let all_solutions = List.map (fun (decomp,sys) -> clear_history (); try let _ = loop2 sys in raise NO_CONTRADICTION with UNSOLVABLE -> let relie_on,path = depend [] [] (history ()) in let dc,_ = List.partition (fun (_,id,_) -> Int.List.mem id relie_on) decomp in let red = List.map (fun (x,_,_) -> x) dc in (red,relie_on,decomp,path)) sys_exploded in let max_count sys = let tbl = Hashtbl.create 7 in let augment x = try incr (Hashtbl.find tbl x) with Not_found -> Hashtbl.add tbl x (ref 1) in let eq = ref (-1) and c = ref 0 in List.iter (function | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on)) | (l,_,_,_) -> List.iter augment l) sys; Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl; !eq in let rec solve systems = try let id = max_count systems in let rec sign = function | ((id',_,b)::l) -> if id=id' then b else sign l | [] -> failwith "solve" in let s1,s2 = List.partition (fun (_,_,decomp,_) -> sign decomp) systems in let remove_int (dep,ro,dc,pa) = (Util.List.except Int.equal id dep,ro,dc,pa) in let s1' = List.map remove_int s1 in let s2' = List.map remove_int s2 in let (r1,relie1) = solve s1' and (r2,relie2) = solve s2' in let (eq,id1,id2) = Int.List.assoc id explode_map in [SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.List.union Int.equal relie1 relie2 with FULL_SOLUTION (x0,x1) -> (x0,x1) in let act,relie_on = solve all_solutions in snd(depend relie_on act first_segment) with UNSOLVABLE -> snd (depend [] [] (history ())) end coq-8.6/plugins/omega/OmegaLemmas.v0000644000175000017500000001775713022274260016627 0ustar mdenesmdenes(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 <= x -> 0 <= y. Proof. now intros ->. Qed. Lemma OMEGA2 x y : 0 <= x -> 0 <= y -> 0 <= x + y. Proof. Z.order_pos. Qed. Lemma OMEGA3 x y k : k > 0 -> x = y * k -> x = 0 -> y = 0. Proof. intros LT -> EQ. apply Z.mul_eq_0 in EQ. destruct EQ; now subst. Qed. Lemma OMEGA4 x y z : x > 0 -> y > x -> z * y + x <> 0. Proof. Z.swap_greater. intros Hx Hxy. rewrite Z.add_move_0_l, <- Z.mul_opp_l. destruct (Z.lt_trichotomy (-z) 1) as [LT|[->|GT]]. - intro. revert LT. apply Z.le_ngt, (Z.le_succ_l 0). apply Z.mul_pos_cancel_r with y; Z.order. - Z.nzsimpl. Z.order. - rewrite (Z.mul_lt_mono_pos_r y), Z.mul_1_l in GT; Z.order. Qed. Lemma OMEGA5 x y z : x = 0 -> y = 0 -> x + y * z = 0. Proof. now intros -> ->. Qed. Lemma OMEGA6 x y z : 0 <= x -> y = 0 -> 0 <= x + y * z. Proof. intros H ->. now Z.nzsimpl. Qed. Lemma OMEGA7 x y z t : z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t. Proof. intros. Z.swap_greater. Z.order_pos. Qed. Lemma OMEGA8 x y : 0 <= x -> 0 <= y -> x = - y -> x = 0. Proof. intros H1 H2 H3. rewrite <- Z.opp_nonpos_nonneg in H2. Z.order. Qed. Lemma OMEGA9 x y z t : y = 0 -> x = z -> y + (- x + z) * t = 0. Proof. intros. subst. now rewrite Z.add_opp_diag_l. Qed. Lemma OMEGA10 v c1 c2 l1 l2 k1 k2 : (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). Proof. rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. rewrite <- !Z.add_assoc. f_equal. apply Z.add_shuffle3. Qed. Lemma OMEGA11 v1 c1 l1 l2 k1 : (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). Proof. rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. now rewrite Z.add_assoc. Qed. Lemma OMEGA12 v2 c2 l1 l2 k2 : l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). Proof. rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. apply Z.add_shuffle3. Qed. Lemma OMEGA13 (v l1 l2 : Z) (x : positive) : v * Zpos x + l1 + (v * Zneg x + l2) = l1 + l2. Proof. rewrite Z.add_shuffle1. rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r. now Z.nzsimpl. Qed. Lemma OMEGA14 (v l1 l2 : Z) (x : positive) : v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2. Proof. rewrite Z.add_shuffle1. rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r. now Z.nzsimpl. Qed. Lemma OMEGA15 v c1 c2 l1 l2 k2 : v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). Proof. rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. apply Z.add_shuffle1. Qed. Lemma OMEGA16 v c l k : (v * c + l) * k = v * (c * k) + l * k. Proof. now rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. Qed. Lemma OMEGA17 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0. Proof. unfold Zne, not. intros NE EQ. subst. now Z.nzsimpl. Qed. Lemma OMEGA18 x y k : x = y * k -> Zne x 0 -> Zne y 0. Proof. unfold Zne, not. intros. subst; auto. Qed. Lemma OMEGA19 x : Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1. Proof. unfold Zne. intros Hx. apply Z.lt_gt_cases in Hx. destruct Hx as [LT|GT]. - right. change (-1) with (-(1)). rewrite Z.mul_opp_r, <- Z.opp_add_distr. Z.nzsimpl. rewrite Z.opp_nonneg_nonpos. now apply Z.le_succ_l. - left. now apply Z.lt_le_pred. Qed. Lemma OMEGA20 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0. Proof. unfold Zne, not. intros H1 H2 H3; apply H1; rewrite H2 in H3; simpl in H3; rewrite Z.add_0_r in H3; trivial with arith. Qed. Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop) (H : P (y + x)) := eq_ind_r P H (Z.add_comm x y). Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop) (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p). Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) (H : P (n + m + p)) := eq_ind_r P H (Z.add_assoc n m p). Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop) (H : P (m + (n + p))) := eq_ind_r P H (Z.add_shuffle3 n m p). Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2 : Z) (P : Z -> Prop) (H : P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))) := eq_ind_r P H (OMEGA10 v c1 c2 l1 l2 k1 k2). Definition fast_OMEGA11 (v1 c1 l1 l2 k1 : Z) (P : Z -> Prop) (H : P (v1 * (c1 * k1) + (l1 * k1 + l2))) := eq_ind_r P H (OMEGA11 v1 c1 l1 l2 k1). Definition fast_OMEGA12 (v2 c2 l1 l2 k2 : Z) (P : Z -> Prop) (H : P (v2 * (c2 * k2) + (l1 + l2 * k2))) := eq_ind_r P H (OMEGA12 v2 c2 l1 l2 k2). Definition fast_OMEGA15 (v c1 c2 l1 l2 k2 : Z) (P : Z -> Prop) (H : P (v * (c1 + c2 * k2) + (l1 + l2 * k2))) := eq_ind_r P H (OMEGA15 v c1 c2 l1 l2 k2). Definition fast_OMEGA16 (v c l k : Z) (P : Z -> Prop) (H : P (v * (c * k) + l * k)) := eq_ind_r P H (OMEGA16 v c l k). Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) (H : P (l1 + l2)) := eq_ind_r P H (OMEGA13 v l1 l2 x). Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x). Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x). Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop) (H : P (x * -1)) := eq_ind_r P H (Z.opp_eq_mul_m1 x). Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop) (H : P (y * x)) := eq_ind_r P H (Z.mul_comm x y). Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop) (H : P (- x + - y)) := eq_ind_r P H (Z.opp_add_distr x y). Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) := eq_ind_r P H (Z.opp_involutive x). Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y). Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop) (H : P (n * p + m * p)) := eq_ind_r P H (Z.mul_add_distr_r n m p). Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop) (H : P (x * - y)) := eq_ind_r P H (Z.mul_opp_comm x y). Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop) (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p). Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop) (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x). Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop) (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor2 x y). Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop) (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor3 x y). Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop) (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z). Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) (H : P y) := eq_ind_r P H (Zred_factor5 x y). Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x). Theorem intro_Z : forall n:nat, exists y : Z, Z.of_nat n = y /\ 0 <= y * 1 + 0. Proof. intros n; exists (Z.of_nat n); split; trivial. rewrite Z.mul_1_r, Z.add_0_r. apply Nat2Z.is_nonneg. Qed. coq-8.6/plugins/omega/coq_omega.ml0000644000175000017500000020640713022274260016525 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* simplest_elim (Tacmach.New.pf_global id gl) end } let resolve_id id gl = Proofview.V82.of_tactic (apply (pf_global gl id)) gl let timing timer_name f arg = f arg let display_time_flag = ref false let display_system_flag = ref false let display_action_flag = ref false let old_style_flag = ref false (* Should we reset all variable labels between two runs of omega ? *) let reset_flag = ref true (* Coq < 8.5 was not performing such resets, hence omega was slightly non-deterministic: successive runs of omega on the same problem may lead to distinct proof-terms. At the very least, these terms differed on the inner variable names, but they could even be non-convertible : the OmegaSolver relies on Hashtbl.iter, it can hence find a different solution when variable indices differ. *) let read f () = !f let write f x = f:=x open Goptions let _ = declare_bool_option { optsync = false; optdepr = false; optname = "Omega system time displaying flag"; optkey = ["Omega";"System"]; optread = read display_system_flag; optwrite = write display_system_flag } let _ = declare_bool_option { optsync = false; optdepr = false; optname = "Omega action display flag"; optkey = ["Omega";"Action"]; optread = read display_action_flag; optwrite = write display_action_flag } let _ = declare_bool_option { optsync = false; optdepr = false; optname = "Omega old style flag"; optkey = ["Omega";"OldStyle"]; optread = read old_style_flag; optwrite = write old_style_flag } let _ = declare_bool_option { optsync = true; optdepr = true; optname = "Omega automatic reset of generated names"; optkey = ["Stable";"Omega"]; optread = read reset_flag; optwrite = write reset_flag } let intref, reset_all_references = let refs = ref [] in (fun n -> let r = ref n in refs := (r,n) :: !refs; r), (fun () -> List.iter (fun (r,n) -> r:=n) !refs) let new_identifier = let cpt = intref 0 in (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; Id.of_string s) let new_identifier_state = let cpt = intref 0 in (fun () -> let s = make_ident "State" (Some !cpt) in incr cpt; s) let new_identifier_var = let cpt = intref 0 in (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; Id.of_string s) let new_id = let cpt = intref 0 in fun () -> incr cpt; !cpt let new_var_num = let cpt = intref 1000 in (fun () -> incr cpt; !cpt) let new_var = let cpt = intref 0 in fun () -> incr cpt; Nameops.make_ident "WW" (Some !cpt) let display_var i = Printf.sprintf "X%d" i let intern_id,unintern_id,reset_intern_tables = let cpt = ref 0 in let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in (fun (name : Id.t) -> try Hashtbl.find table name with Not_found -> let idx = !cpt in Hashtbl.add table name idx; Hashtbl.add co_table idx name; incr cpt; idx), (fun idx -> try Hashtbl.find co_table idx with Not_found -> let v = new_var () in Hashtbl.add table v idx; Hashtbl.add co_table idx v; v), (fun () -> cpt := 0; Hashtbl.clear table) let mk_then = tclTHENLIST let exists_tac c = constructor_tac false (Some 1) 1 (ImplicitBindings [c]) let generalize_tac t = generalize t let elim t = simplest_elim t let exact t = Tacmach.refine t let unfold s = Tactics.unfold_in_concl [Locus.AllOccurrences, Lazy.force s] let rev_assoc k = let rec loop = function | [] -> raise Not_found | (v,k')::_ when Int.equal k k' -> v | _ :: l -> loop l in loop let tag_hypothesis,tag_of_hyp, hyp_of_tag, clear_tags = let l = ref ([]:(Id.t * int) list) in (fun h id -> l := (h,id):: !l), (fun h -> try Id.List.assoc h !l with Not_found -> failwith "tag_hypothesis"), (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis"), (fun () -> l := []) let hide_constr,find_constr,clear_constr_tables,dump_tables = let l = ref ([]:(constr * (Id.t * Id.t * bool)) list) in (fun h id eg b -> l := (h,(id,eg,b)):: !l), (fun h -> try List.assoc_f eq_constr_nounivs h !l with Not_found -> failwith "find_contr"), (fun () -> l := []), (fun () -> !l) let reset_all () = if !reset_flag then begin reset_all_references (); reset_intern_tables (); clear_tags (); clear_constr_tables () end (* Lazy evaluation is used for Coq constants, because this code is evaluated before the compiled modules are loaded. To use the constant Zplus, one must type "Lazy.force coq_Zplus" This is the right way to access to Coq constants in tactics ML code *) open Coqlib let logic_dir = ["Coq";"Logic";"Decidable"] let coq_modules = init_modules @arith_modules @ [logic_dir] @ zarith_base_modules @ [["Coq"; "omega"; "OmegaLemmas"]] let init_constant = gen_constant_in_modules "Omega" init_modules let constant = gen_constant_in_modules "Omega" coq_modules let z_constant = gen_constant_in_modules "Omega" [["Coq";"ZArith"]] let zbase_constant = gen_constant_in_modules "Omega" [["Coq";"ZArith";"BinInt"]] (* Zarith *) let coq_xH = lazy (constant "xH") let coq_xO = lazy (constant "xO") let coq_xI = lazy (constant "xI") let coq_Z0 = lazy (constant "Z0") let coq_Zpos = lazy (constant "Zpos") let coq_Zneg = lazy (constant "Zneg") let coq_Z = lazy (constant "Z") let coq_comparison = lazy (constant "comparison") let coq_Gt = lazy (constant "Gt") let coq_Zplus = lazy (zbase_constant "Z.add") let coq_Zmult = lazy (zbase_constant "Z.mul") let coq_Zopp = lazy (zbase_constant "Z.opp") let coq_Zminus = lazy (zbase_constant "Z.sub") let coq_Zsucc = lazy (zbase_constant "Z.succ") let coq_Zpred = lazy (zbase_constant "Z.pred") let coq_Z_of_nat = lazy (zbase_constant "Z.of_nat") let coq_inj_plus = lazy (z_constant "Nat2Z.inj_add") let coq_inj_mult = lazy (z_constant "Nat2Z.inj_mul") let coq_inj_minus1 = lazy (z_constant "Nat2Z.inj_sub") let coq_inj_minus2 = lazy (constant "inj_minus2") let coq_inj_S = lazy (z_constant "Nat2Z.inj_succ") let coq_inj_le = lazy (z_constant "Znat.inj_le") let coq_inj_lt = lazy (z_constant "Znat.inj_lt") let coq_inj_ge = lazy (z_constant "Znat.inj_ge") let coq_inj_gt = lazy (z_constant "Znat.inj_gt") let coq_inj_neq = lazy (z_constant "inj_neq") let coq_inj_eq = lazy (z_constant "inj_eq") let coq_fast_Zplus_assoc_reverse = lazy (constant "fast_Zplus_assoc_reverse") let coq_fast_Zplus_assoc = lazy (constant "fast_Zplus_assoc") let coq_fast_Zmult_assoc_reverse = lazy (constant "fast_Zmult_assoc_reverse") let coq_fast_Zplus_permute = lazy (constant "fast_Zplus_permute") let coq_fast_Zplus_comm = lazy (constant "fast_Zplus_comm") let coq_fast_Zmult_comm = lazy (constant "fast_Zmult_comm") let coq_Zmult_le_approx = lazy (constant "Zmult_le_approx") let coq_OMEGA1 = lazy (constant "OMEGA1") let coq_OMEGA2 = lazy (constant "OMEGA2") let coq_OMEGA3 = lazy (constant "OMEGA3") let coq_OMEGA4 = lazy (constant "OMEGA4") let coq_OMEGA5 = lazy (constant "OMEGA5") let coq_OMEGA6 = lazy (constant "OMEGA6") let coq_OMEGA7 = lazy (constant "OMEGA7") let coq_OMEGA8 = lazy (constant "OMEGA8") let coq_OMEGA9 = lazy (constant "OMEGA9") let coq_fast_OMEGA10 = lazy (constant "fast_OMEGA10") let coq_fast_OMEGA11 = lazy (constant "fast_OMEGA11") let coq_fast_OMEGA12 = lazy (constant "fast_OMEGA12") let coq_fast_OMEGA13 = lazy (constant "fast_OMEGA13") let coq_fast_OMEGA14 = lazy (constant "fast_OMEGA14") let coq_fast_OMEGA15 = lazy (constant "fast_OMEGA15") let coq_fast_OMEGA16 = lazy (constant "fast_OMEGA16") let coq_OMEGA17 = lazy (constant "OMEGA17") let coq_OMEGA18 = lazy (constant "OMEGA18") let coq_OMEGA19 = lazy (constant "OMEGA19") let coq_OMEGA20 = lazy (constant "OMEGA20") let coq_fast_Zred_factor0 = lazy (constant "fast_Zred_factor0") let coq_fast_Zred_factor1 = lazy (constant "fast_Zred_factor1") let coq_fast_Zred_factor2 = lazy (constant "fast_Zred_factor2") let coq_fast_Zred_factor3 = lazy (constant "fast_Zred_factor3") let coq_fast_Zred_factor4 = lazy (constant "fast_Zred_factor4") let coq_fast_Zred_factor5 = lazy (constant "fast_Zred_factor5") let coq_fast_Zred_factor6 = lazy (constant "fast_Zred_factor6") let coq_fast_Zmult_plus_distr_l = lazy (constant "fast_Zmult_plus_distr_l") let coq_fast_Zmult_opp_comm = lazy (constant "fast_Zmult_opp_comm") let coq_fast_Zopp_plus_distr = lazy (constant "fast_Zopp_plus_distr") let coq_fast_Zopp_mult_distr_r = lazy (constant "fast_Zopp_mult_distr_r") let coq_fast_Zopp_eq_mult_neg_1 = lazy (constant "fast_Zopp_eq_mult_neg_1") let coq_fast_Zopp_involutive = lazy (constant "fast_Zopp_involutive") let coq_Zegal_left = lazy (constant "Zegal_left") let coq_Zne_left = lazy (constant "Zne_left") let coq_Zlt_left = lazy (constant "Zlt_left") let coq_Zge_left = lazy (constant "Zge_left") let coq_Zgt_left = lazy (constant "Zgt_left") let coq_Zle_left = lazy (constant "Zle_left") let coq_new_var = lazy (constant "new_var") let coq_intro_Z = lazy (constant "intro_Z") let coq_dec_eq = lazy (zbase_constant "Z.eq_decidable") let coq_dec_Zne = lazy (constant "dec_Zne") let coq_dec_Zle = lazy (zbase_constant "Z.le_decidable") let coq_dec_Zlt = lazy (zbase_constant "Z.lt_decidable") let coq_dec_Zgt = lazy (constant "dec_Zgt") let coq_dec_Zge = lazy (constant "dec_Zge") let coq_not_Zeq = lazy (constant "not_Zeq") let coq_not_Zne = lazy (constant "not_Zne") let coq_Znot_le_gt = lazy (constant "Znot_le_gt") let coq_Znot_lt_ge = lazy (constant "Znot_lt_ge") let coq_Znot_ge_lt = lazy (constant "Znot_ge_lt") let coq_Znot_gt_le = lazy (constant "Znot_gt_le") let coq_neq = lazy (constant "neq") let coq_Zne = lazy (constant "Zne") let coq_Zle = lazy (zbase_constant "Z.le") let coq_Zgt = lazy (zbase_constant "Z.gt") let coq_Zge = lazy (zbase_constant "Z.ge") let coq_Zlt = lazy (zbase_constant "Z.lt") (* Peano/Datatypes *) let coq_le = lazy (init_constant "le") let coq_lt = lazy (init_constant "lt") let coq_ge = lazy (init_constant "ge") let coq_gt = lazy (init_constant "gt") let coq_minus = lazy (init_constant "Nat.sub") let coq_plus = lazy (init_constant "Nat.add") let coq_mult = lazy (init_constant "Nat.mul") let coq_pred = lazy (init_constant "Nat.pred") let coq_nat = lazy (init_constant "nat") let coq_S = lazy (init_constant "S") let coq_O = lazy (init_constant "O") (* Compare_dec/Peano_dec/Minus *) let coq_pred_of_minus = lazy (constant "pred_of_minus") let coq_le_gt_dec = lazy (constant "le_gt_dec") let coq_dec_eq_nat = lazy (constant "dec_eq_nat") let coq_dec_le = lazy (constant "dec_le") let coq_dec_lt = lazy (constant "dec_lt") let coq_dec_ge = lazy (constant "dec_ge") let coq_dec_gt = lazy (constant "dec_gt") let coq_not_eq = lazy (constant "not_eq") let coq_not_le = lazy (constant "not_le") let coq_not_lt = lazy (constant "not_lt") let coq_not_ge = lazy (constant "not_ge") let coq_not_gt = lazy (constant "not_gt") (* Logic/Decidable *) let coq_eq_ind_r = lazy (constant "eq_ind_r") let coq_dec_or = lazy (constant "dec_or") let coq_dec_and = lazy (constant "dec_and") let coq_dec_imp = lazy (constant "dec_imp") let coq_dec_iff = lazy (constant "dec_iff") let coq_dec_not = lazy (constant "dec_not") let coq_dec_False = lazy (constant "dec_False") let coq_dec_not_not = lazy (constant "dec_not_not") let coq_dec_True = lazy (constant "dec_True") let coq_not_or = lazy (constant "not_or") let coq_not_and = lazy (constant "not_and") let coq_not_imp = lazy (constant "not_imp") let coq_not_iff = lazy (constant "not_iff") let coq_not_not = lazy (constant "not_not") let coq_imp_simp = lazy (constant "imp_simp") let coq_iff = lazy (constant "iff") (* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) (* For unfold *) let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with | Const (kn,u) when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> EvalConstRef kn | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant")) let sp_Zsucc = lazy (evaluable_ref_of_constr "Z.succ" coq_Zsucc) let sp_Zpred = lazy (evaluable_ref_of_constr "Z.pred" coq_Zpred) let sp_Zminus = lazy (evaluable_ref_of_constr "Z.sub" coq_Zminus) let sp_Zle = lazy (evaluable_ref_of_constr "Z.le" coq_Zle) let sp_Zgt = lazy (evaluable_ref_of_constr "Z.gt" coq_Zgt) let sp_Zge = lazy (evaluable_ref_of_constr "Z.ge" coq_Zge) let sp_Zlt = lazy (evaluable_ref_of_constr "Z.lt" coq_Zlt) let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ()))) let mk_var v = mkVar (Id.of_string v) let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) let mk_eq t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()), [| Lazy.force coq_Z; t1; t2 |]) let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |]) let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) let mk_and t1 t2 = mkApp (build_coq_and (), [| t1; t2 |]) let mk_or t1 t2 = mkApp (build_coq_or (), [| t1; t2 |]) let mk_not t = mkApp (build_coq_not (), [| t |]) let mk_eq_rel t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()), [| Lazy.force coq_comparison; t1; t2 |]) let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) let mk_integer n = let rec loop n = if n =? one then Lazy.force coq_xH else mkApp((if n mod two =? zero then Lazy.force coq_xO else Lazy.force coq_xI), [| loop (n/two) |]) in if n =? zero then Lazy.force coq_Z0 else mkApp ((if n >? zero then Lazy.force coq_Zpos else Lazy.force coq_Zneg), [| loop (abs n) |]) type omega_constant = | Zplus | Zmult | Zminus | Zsucc | Zopp | Zpred | Plus | Mult | Minus | Pred | S | O | Zpos | Zneg | Z0 | Z_of_nat | Eq | Neq | Zne | Zle | Zlt | Zge | Zgt | Z | Nat | And | Or | False | True | Not | Iff | Le | Lt | Ge | Gt | Other of string type omega_proposition = | Keq of constr * constr * constr | Kn type result = | Kvar of Id.t | Kapp of omega_constant * constr list | Kimp of constr * constr | Kufo (* Nota: Kimp correspond to a binder (Prod), but hopefully we won't have to bother with term lifting: Kimp will correspond to anonymous product, for which (Rel 1) doesn't occur in the right term. Moreover, we'll work on fully introduced goals, hence no Rel's in the term parts that we manipulate, but rather Var's. Said otherwise: all constr manipulated here are closed *) let destructurate_prop t = let c, args = decompose_app t in match kind_of_term c, args with | _, [_;_;_] when is_global (build_coq_eq ()) c -> Kapp (Eq,args) | _, [_;_] when eq_constr c (Lazy.force coq_neq) -> Kapp (Neq,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zne) -> Kapp (Zne,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zle) -> Kapp (Zle,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zlt) -> Kapp (Zlt,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zge) -> Kapp (Zge,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zgt) -> Kapp (Zgt,args) | _, [_;_] when eq_constr c (build_coq_and ()) -> Kapp (And,args) | _, [_;_] when eq_constr c (build_coq_or ()) -> Kapp (Or,args) | _, [_;_] when eq_constr c (Lazy.force coq_iff) -> Kapp (Iff, args) | _, [_] when eq_constr c (build_coq_not ()) -> Kapp (Not,args) | _, [] when eq_constr c (build_coq_False ()) -> Kapp (False,args) | _, [] when eq_constr c (build_coq_True ()) -> Kapp (True,args) | _, [_;_] when eq_constr c (Lazy.force coq_le) -> Kapp (Le,args) | _, [_;_] when eq_constr c (Lazy.force coq_lt) -> Kapp (Lt,args) | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args) | _, [_;_] when eq_constr c (Lazy.force coq_gt) -> Kapp (Gt,args) | Const (sp,_), args -> Kapp (Other (string_of_path (path_of_global (ConstRef sp))),args) | Construct (csp,_) , args -> Kapp (Other (string_of_path (path_of_global (ConstructRef csp))), args) | Ind (isp,_), args -> Kapp (Other (string_of_path (path_of_global (IndRef isp))),args) | Var id,[] -> Kvar id | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal" | _ -> Kufo let destructurate_type t = let c, args = decompose_app t in match kind_of_term c, args with | _, [] when eq_constr c (Lazy.force coq_Z) -> Kapp (Z,args) | _, [] when eq_constr c (Lazy.force coq_nat) -> Kapp (Nat,args) | _ -> Kufo let destructurate_term t = let c, args = decompose_app t in match kind_of_term c, args with | _, [_;_] when eq_constr c (Lazy.force coq_Zplus) -> Kapp (Zplus,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zmult) -> Kapp (Zmult,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zminus) -> Kapp (Zminus,args) | _, [_] when eq_constr c (Lazy.force coq_Zsucc) -> Kapp (Zsucc,args) | _, [_] when eq_constr c (Lazy.force coq_Zpred) -> Kapp (Zpred,args) | _, [_] when eq_constr c (Lazy.force coq_Zopp) -> Kapp (Zopp,args) | _, [_;_] when eq_constr c (Lazy.force coq_plus) -> Kapp (Plus,args) | _, [_;_] when eq_constr c (Lazy.force coq_mult) -> Kapp (Mult,args) | _, [_;_] when eq_constr c (Lazy.force coq_minus) -> Kapp (Minus,args) | _, [_] when eq_constr c (Lazy.force coq_pred) -> Kapp (Pred,args) | _, [_] when eq_constr c (Lazy.force coq_S) -> Kapp (S,args) | _, [] when eq_constr c (Lazy.force coq_O) -> Kapp (O,args) | _, [_] when eq_constr c (Lazy.force coq_Zpos) -> Kapp (Zneg,args) | _, [_] when eq_constr c (Lazy.force coq_Zneg) -> Kapp (Zpos,args) | _, [] when eq_constr c (Lazy.force coq_Z0) -> Kapp (Z0,args) | _, [_] when eq_constr c (Lazy.force coq_Z_of_nat) -> Kapp (Z_of_nat,args) | Var id,[] -> Kvar id | _ -> Kufo let recognize_number t = let rec loop t = match decompose_app t with | f, [t] when eq_constr f (Lazy.force coq_xI) -> one + two * loop t | f, [t] when eq_constr f (Lazy.force coq_xO) -> two * loop t | f, [] when eq_constr f (Lazy.force coq_xH) -> one | _ -> failwith "not a number" in match decompose_app t with | f, [t] when eq_constr f (Lazy.force coq_Zpos) -> loop t | f, [t] when eq_constr f (Lazy.force coq_Zneg) -> neg (loop t) | f, [] when eq_constr f (Lazy.force coq_Z0) -> zero | _ -> failwith "not a number" type constr_path = | P_APP of int (* Abstraction and product *) | P_BODY | P_TYPE (* Case *) | P_BRANCH of int | P_ARITY | P_ARG let context operation path (t : constr) = let rec loop i p0 t = match (p0,kind_of_term t) with | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t) | ([], _) -> operation i t | ((P_APP n :: p), App (f,v)) -> let v' = Array.copy v in v'.(pred n) <- loop i p v'.(pred n); mkApp (f, v') | ((P_BRANCH n :: p), Case (ci,q,c,v)) -> (* avant, y avait mkApp... anyway, BRANCH seems nowhere used *) let v' = Array.copy v in v'.(n) <- loop i p v'.(n); (mkCase (ci,q,c,v')) | ((P_ARITY :: p), App (f,l)) -> appvect (loop i p f,l) | ((P_ARG :: p), App (f,v)) -> let v' = Array.copy v in v'.(0) <- loop i p v'.(0); mkApp (f,v') | (p, Fix ((_,n as ln),(tys,lna,v))) -> let l = Array.length v in let v' = Array.copy v in v'.(n)<- loop (Pervasives.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) | ((P_BODY :: p), Prod (n,t,c)) -> (mkProd (n,t,loop (succ i) p c)) | ((P_BODY :: p), Lambda (n,t,c)) -> (mkLambda (n,t,loop (succ i) p c)) | ((P_BODY :: p), LetIn (n,b,t,c)) -> (mkLetIn (n,b,t,loop (succ i) p c)) | ((P_TYPE :: p), Prod (n,t,c)) -> (mkProd (n,loop i p t,c)) | ((P_TYPE :: p), Lambda (n,t,c)) -> (mkLambda (n,loop i p t,c)) | ((P_TYPE :: p), LetIn (n,b,t,c)) -> (mkLetIn (n,b,loop i p t,c)) | (p, _) -> failwith ("abstract_path " ^ string_of_int(List.length p)) in loop 1 path t let occurrence path (t : constr) = let rec loop p0 t = match (p0,kind_of_term t) with | (p, Cast (c,_,_)) -> loop p c | ([], _) -> t | ((P_APP n :: p), App (f,v)) -> loop p v.(pred n) | ((P_BRANCH n :: p), Case (_,_,_,v)) -> loop p v.(n) | ((P_ARITY :: p), App (f,_)) -> loop p f | ((P_ARG :: p), App (f,v)) -> loop p v.(0) | (p, Fix((_,n) ,(_,_,v))) -> loop p v.(n) | ((P_BODY :: p), Prod (n,t,c)) -> loop p c | ((P_BODY :: p), Lambda (n,t,c)) -> loop p c | ((P_BODY :: p), LetIn (n,b,t,c)) -> loop p c | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term | (p, _) -> failwith ("occurrence " ^ string_of_int(List.length p)) in loop path t let abstract_path typ path t = let term_occur = ref (mkRel 0) in let abstract = context (fun i t -> term_occur:= t; mkRel i) path t in mkLambda (Name (Id.of_string "x"), typ, abstract), !term_occur let focused_simpl path gl = let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in Proofview.V82.of_tactic (convert_concl_no_check newc DEFAULTcast) gl let focused_simpl path = focused_simpl path type oformula = | Oplus of oformula * oformula | Oinv of oformula | Otimes of oformula * oformula | Oatom of Id.t | Oz of bigint | Oufo of constr let rec oprint = function | Oplus(t1,t2) -> print_string "("; oprint t1; print_string "+"; oprint t2; print_string ")" | Oinv t -> print_string "~"; oprint t | Otimes (t1,t2) -> print_string "("; oprint t1; print_string "*"; oprint t2; print_string ")" | Oatom s -> print_string (Id.to_string s) | Oz i -> print_string (string_of_bigint i) | Oufo f -> print_string "?" let rec weight = function | Oatom c -> intern_id c | Oz _ -> -1 | Oinv c -> weight c | Otimes(c,_) -> weight c | Oplus _ -> failwith "weight" | Oufo _ -> -1 let rec val_of = function | Oatom c -> mkVar c | Oz c -> mk_integer c | Oinv c -> mkApp (Lazy.force coq_Zopp, [| val_of c |]) | Otimes (t1,t2) -> mkApp (Lazy.force coq_Zmult, [| val_of t1; val_of t2 |]) | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |]) | Oufo c -> c let compile name kind = let rec loop accu = function | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r | Oz n -> let id = new_id () in tag_hypothesis name id; {kind = kind; body = List.rev accu; constant = n; id = id} | _ -> anomaly (Pp.str "compile_equation") in loop [] let decompile af = let rec loop = function | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) | [] -> Oz af.constant in loop af.body let mkNewMeta () = mkMeta (Evarutil.new_meta()) let clever_rewrite_base_poly typ p result theorem gl = let full = pf_concl gl in let (abstracted,occ) = abstract_path typ (List.rev p) full in let t = applist (mkLambda (Name (Id.of_string "P"), mkArrow typ mkProp, mkLambda (Name (Id.of_string "H"), applist (mkRel 1,[result]), mkApp (Lazy.force coq_eq_ind_r, [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), [abstracted]) in exact (applist(t,[mkNewMeta()])) gl let clever_rewrite_base p result theorem gl = clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl let clever_rewrite_base_nat p result theorem gl = clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem gl let clever_rewrite_gen p result (t,args) = let theorem = applist(t, args) in clever_rewrite_base p result theorem let clever_rewrite_gen_nat p result (t,args) = let theorem = applist(t, args) in clever_rewrite_base_nat p result theorem let clever_rewrite p vpath t gl = let full = pf_concl gl in let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in let vargs = List.map (fun p -> occurrence p occ) vpath in let t' = applist(t, (vargs @ [abstracted])) in exact (applist(t',[mkNewMeta()])) gl let rec shuffle p (t1,t2) = match t1,t2 with | Oplus(l1,r1), Oplus(l2,r2) -> if weight l1 > weight l2 then let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in (clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: tac, Oplus(l1,t')) else let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zplus_permute) :: tac, Oplus(l2,t')) | Oplus(l1,r1), t2 -> if weight l1 > weight t2 then let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: tac, Oplus(l1, t') else [clever_rewrite p [[P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zplus_comm)], Oplus(t2,t1) | t1,Oplus(l2,r2) -> if weight l2 > weight t1 then let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zplus_permute) :: tac, Oplus(l2,t') else [],Oplus(t1,t2) | Oz t1,Oz t2 -> [focused_simpl p], Oz(Bigint.add t1 t2) | t1,t2 -> if weight t1 < weight t2 then [clever_rewrite p [[P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zplus_comm)], Oplus(t2,t1) else [],Oplus(t1,t2) let shuffle_mult p_init k1 e1 k2 e2 = let rec loop p = function | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> if Int.equal v1 v2 then let tac = clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA10) in if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then let tac' = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) in tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: loop p (l1,l2) else tac :: loop (P_APP 2 :: p) (l1,l2) else if v1 > v2 then clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) (l1,l2') else clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) (l1',l2) | ({c=c1;v=v1}::l1), [] -> clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) (l1,[]) | [],({c=c2;v=v2}::l2) -> clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) ([],l2) | [],[] -> [focused_simpl p_init] in loop p_init (e1,e2) let shuffle_mult_right p_init e1 k2 e2 = let rec loop p = function | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> if Int.equal v1 v2 then let tac = clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 2]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA15) in if Bigint.add c1 (Bigint.mult k2 c2) =? zero then let tac' = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) in tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: loop p (l1,l2) else tac :: loop (P_APP 2 :: p) (l1,l2) else if v1 > v2 then clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: loop (P_APP 2 :: p) (l1,l2') else clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) (l1',l2) | ({c=c1;v=v1}::l1), [] -> clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: loop (P_APP 2 :: p) (l1,[]) | [],({c=c2;v=v2}::l2) -> clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) ([],l2) | [],[] -> [focused_simpl p_init] in loop p_init (e1,e2) let rec shuffle_cancel p = function | [] -> [focused_simpl p] | ({c=c1}::l1) -> let tac = clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2; P_APP 1]] (if c1 >? zero then (Lazy.force coq_fast_OMEGA13) else (Lazy.force coq_fast_OMEGA14)) in tac :: shuffle_cancel p l1 let rec scalar p n = function | Oplus(t1,t2) -> let tac1,t1' = scalar (P_APP 1 :: p) n t1 and tac2,t2' = scalar (P_APP 2 :: p) n t2 in clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zmult_plus_distr_l) :: (tac1 @ tac2), Oplus(t1',t2') | Oinv t -> [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zmult_opp_comm); focused_simpl (P_APP 2 :: p)], Otimes(t,Oz(neg n)) | Otimes(t1,Oz x) -> [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zmult_assoc_reverse); focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (n*x)) | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> [], Otimes(t,Oz n) | Oz i -> [focused_simpl p],Oz(n*i) | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |])) let scalar_norm p_init = let rec loop p = function | [] -> [focused_simpl p_init] | (_::l) -> clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l in loop p_init let norm_add p_init = let rec loop p = function | [] -> [focused_simpl p_init] | _:: l -> clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: loop (P_APP 2 :: p) l in loop p_init let scalar_norm_add p_init = let rec loop p = function | [] -> [focused_simpl p_init] | _ :: l -> clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l in loop p_init let rec negate p = function | Oplus(t1,t2) -> let tac1,t1' = negate (P_APP 1 :: p) t1 and tac2,t2' = negate (P_APP 2 :: p) t2 in clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] (Lazy.force coq_fast_Zopp_plus_distr) :: (tac1 @ tac2), Oplus(t1',t2') | Oinv t -> [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_involutive)], t | Otimes(t1,Oz x) -> [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] (Lazy.force coq_fast_Zopp_mult_distr_r); focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (neg x)) | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> let r = Otimes(t,Oz(negone)) in [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1)], r | Oz i -> [focused_simpl p],Oz(neg i) | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |])) let rec transform p t = let default isnat t' = try let v,th,_ = find_constr t' in [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v with e when CErrors.noncritical e -> let v = new_identifier_var () and th = new_identifier () in hide_constr t' v th isnat; [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v in try match destructurate_term t with | Kapp(Zplus,[t1;t2]) -> let tac1,t1' = transform (P_APP 1 :: p) t1 and tac2,t2' = transform (P_APP 2 :: p) t2 in let tac,t' = shuffle p (t1',t2') in tac1 @ tac2 @ tac, t' | Kapp(Zminus,[t1;t2]) -> let tac,t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in Proofview.V82.of_tactic (unfold sp_Zminus) :: tac,t | Kapp(Zsucc,[t1]) -> let tac,t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; mk_integer one |])) in Proofview.V82.of_tactic (unfold sp_Zsucc) :: tac,t | Kapp(Zpred,[t1]) -> let tac,t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; mk_integer negone |])) in Proofview.V82.of_tactic (unfold sp_Zpred) :: tac,t | Kapp(Zmult,[t1;t2]) -> let tac1,t1' = transform (P_APP 1 :: p) t1 and tac2,t2' = transform (P_APP 2 :: p) t2 in begin match t1',t2' with | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t' | (Oz n,_) -> let sym = clever_rewrite p [[P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zmult_comm) in let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t' | _ -> default false t end | Kapp((Zpos|Zneg|Z0),_) -> (try ([],Oz(recognize_number t)) with e when CErrors.noncritical e -> default false t) | Kvar s -> [],Oatom s | Kapp(Zopp,[t]) -> let tac,t' = transform (P_APP 1 :: p) t in let tac',t'' = negate p t' in tac @ tac', t'' | Kapp(Z_of_nat,[t']) -> default true t' | _ -> default false t with e when catchable_exception e -> default false t let shrink_pair p f1 f2 = match f1,f2 with | Oatom v,Oatom _ -> let r = Otimes(Oatom v,Oz two) in clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r | Oatom v, Otimes(_,c2) -> let r = Otimes(Oatom v,Oplus(c2,Oz one)) in clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zred_factor2), r | Otimes (v1,c1),Oatom v -> let r = Otimes(Oatom v,Oplus(c1,Oz one)) in clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]] (Lazy.force coq_fast_Zred_factor3), r | Otimes (Oatom v,c1),Otimes (v2,c2) -> let r = Otimes(Oatom v,Oplus(c1,c2)) in clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zred_factor4),r | t1,t2 -> begin oprint t1; print_newline (); oprint t2; print_newline (); flush Pervasives.stdout; error "shrink.1" end let reduce_factor p = function | Oatom v -> let r = Otimes(Oatom v,Oz one) in [clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor0)],r | Otimes(Oatom v,Oz n) as f -> [],f | Otimes(Oatom v,c) -> let rec compute = function | Oz n -> n | Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2) | _ -> error "condense.1" in [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c)) | t -> oprint t; error "reduce_factor.1" let rec condense p = function | Oplus(f1,(Oplus(f2,r) as t)) -> if Int.equal (weight f1) (weight f2) then begin let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in let assoc_tac = clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zplus_assoc) in let tac_list,t' = condense p (Oplus(t,r)) in (assoc_tac :: shrink_tac :: tac_list), t' end else begin let tac,f = reduce_factor (P_APP 1 :: p) f1 in let tac',t' = condense (P_APP 2 :: p) t in (tac @ tac'), Oplus(f,t') end | Oplus(f1,Oz n) -> let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n) | Oplus(f1,f2) -> if Int.equal (weight f1) (weight f2) then begin let tac_shrink,t = shrink_pair p f1 f2 in let tac,t' = condense p t in tac_shrink :: tac,t' end else begin let tac,f = reduce_factor (P_APP 1 :: p) f1 in let tac',t' = condense (P_APP 2 :: p) f2 in (tac @ tac'),Oplus(f,t') end | Oz _ as t -> [],t | t -> let tac,t' = reduce_factor p t in let final = Oplus(t',Oz zero) in let tac' = clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor6) in tac @ [tac'], final let rec clear_zero p = function | Oplus(Otimes(Oatom v,Oz n),r) when n =? zero -> let tac = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) in let tac',t = clear_zero p r in tac :: tac',t | Oplus(f,r) -> let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t) | t -> [],t let replay_history tactic_normalisation = let aux = Id.of_string "auxiliary" in let aux1 = Id.of_string "auxiliary_1" in let aux2 = Id.of_string "auxiliary_2" in let izero = mk_integer zero in let rec loop t : unit Proofview.tactic = match t with | HYP e :: l -> begin try Tacticals.New.tclTHEN (Id.List.assoc (hyp_of_tag e.id) tactic_normalisation) (loop l) with Not_found -> loop l end | NEGATE_CONTRADICT (e2,e1,b) :: l -> let eq1 = decompile e1 and eq2 = decompile e2 in let id1 = hyp_of_tag e1.id and id2 = hyp_of_tag e2.id in let k = if b then negone else one in let p_initial = [P_APP 1;P_TYPE] in let tac= shuffle_mult_right p_initial e1.body k e2.body in Tacticals.New.tclTHENLIST [ generalize_tac [mkApp (Lazy.force coq_OMEGA17, [| val_of eq1; val_of eq2; mk_integer k; mkVar id1; mkVar id2 |])]; Proofview.V82.tactic (mk_then tac); (intros_using [aux]); Proofview.V82.tactic (resolve_id aux); reflexivity ] | CONTRADICTION (e1,e2) :: l -> let eq1 = decompile e1 and eq2 = decompile e2 in let p_initial = [P_APP 2;P_TYPE] in let tac = shuffle_cancel p_initial e1.body in let solve_le = let not_sup_sup = mkApp (Universes.constr_of_global (build_coq_eq ()), [| Lazy.force coq_comparison; Lazy.force coq_Gt; Lazy.force coq_Gt |]) in Tacticals.New.tclTHENS (Tacticals.New.tclTHENLIST [ unfold sp_Zle; simpl_in_concl; intro; (absurd not_sup_sup) ]) [ assumption ; reflexivity ] in let theorem = mkApp (Lazy.force coq_OMEGA2, [| val_of eq1; val_of eq2; mkVar (hyp_of_tag e1.id); mkVar (hyp_of_tag e2.id) |]) in Proofview.tclTHEN (Proofview.V82.tactic (tclTHEN (Proofview.V82.of_tactic (generalize_tac [theorem])) (mk_then tac))) (solve_le) | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> let id = hyp_of_tag e1.id in let eq1 = val_of(decompile e1) and eq2 = val_of(decompile e2) in let kk = mk_integer k and dd = mk_integer d in let rhs = mk_plus (mk_times eq2 kk) dd in let state_eg = mk_eq eq1 rhs in let tac = scalar_norm_add [P_APP 3] e2.body in Tacticals.New.tclTHENS (cut state_eg) [ Tacticals.New.tclTHENS (Tacticals.New.tclTHENLIST [ (intros_using [aux]); (generalize_tac [mkApp (Lazy.force coq_OMEGA1, [| eq1; rhs; mkVar aux; mkVar id |])]); (clear [aux;id]); (intros_using [id]); (cut (mk_gt kk dd)) ]) [ Tacticals.New.tclTHENS (cut (mk_gt kk izero)) [ Tacticals.New.tclTHENLIST [ (intros_using [aux1; aux2]); (generalize_tac [mkApp (Lazy.force coq_Zmult_le_approx, [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); (clear [aux1;aux2;id]); (intros_using [id]); (loop l) ]; Tacticals.New.tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] ]; Tacticals.New.tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ]; Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] | NOT_EXACT_DIVIDE (e1,k) :: l -> let c = floor_div e1.constant k in let d = Bigint.sub e1.constant (Bigint.mult c k) in let e2 = {id=e1.id; kind=EQUA;constant = c; body = map_eq_linear (fun c -> c / k) e1.body } in let eq2 = val_of(decompile e2) in let kk = mk_integer k and dd = mk_integer d in let tac = scalar_norm_add [P_APP 2] e2.body in Tacticals.New.tclTHENS (cut (mk_gt dd izero)) [ Tacticals.New.tclTHENS (cut (mk_gt kk dd)) [Tacticals.New.tclTHENLIST [ (intros_using [aux2;aux1]); (generalize_tac [mkApp (Lazy.force coq_OMEGA4, [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); (clear [aux1;aux2]); unfold sp_not; (intros_using [aux]); Proofview.V82.tactic (resolve_id aux); Proofview.V82.tactic (mk_then tac); assumption ] ; Tacticals.New.tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ]; Tacticals.New.tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ] | EXACT_DIVIDE (e1,k) :: l -> let id = hyp_of_tag e1.id in let e2 = map_eq_afine (fun c -> c / k) e1 in let eq1 = val_of(decompile e1) and eq2 = val_of(decompile e2) in let kk = mk_integer k in let state_eq = mk_eq eq1 (mk_times eq2 kk) in if e1.kind == DISE then let tac = scalar_norm [P_APP 3] e2.body in Tacticals.New.tclTHENS (cut state_eq) [Tacticals.New.tclTHENLIST [ (intros_using [aux1]); (generalize_tac [mkApp (Lazy.force coq_OMEGA18, [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); (clear [aux1;id]); (intros_using [id]); (loop l) ]; Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] else let tac = scalar_norm [P_APP 3] e2.body in Tacticals.New.tclTHENS (cut state_eq) [ Tacticals.New.tclTHENS (cut (mk_gt kk izero)) [Tacticals.New.tclTHENLIST [ (intros_using [aux2;aux1]); (generalize_tac [mkApp (Lazy.force coq_OMEGA3, [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); (clear [aux1;aux2;id]); (intros_using [id]); (loop l) ]; Tacticals.New.tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ]; Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] | (MERGE_EQ(e3,e1,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; let id1 = hyp_of_tag e1.id and id2 = hyp_of_tag e2 in let eq1 = val_of(decompile e1) and eq2 = val_of (decompile (negate_eq e1)) in let tac = clever_rewrite [P_APP 3] [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: scalar_norm [P_APP 3] e1.body in Tacticals.New.tclTHENS (cut (mk_eq eq1 (mk_inv eq2))) [Tacticals.New.tclTHENLIST [ (intros_using [aux]); (generalize_tac [mkApp (Lazy.force coq_OMEGA8, [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); (clear [id1;id2;aux]); (intros_using [id]); (loop l) ]; Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity] | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l -> let id = new_identifier () and id2 = hyp_of_tag orig.id in tag_hypothesis id e.id; let eq1 = val_of(decompile def) and eq2 = val_of(decompile orig) in let vid = unintern_id v in let theorem = mkApp (build_coq_ex (), [| Lazy.force coq_Z; mkLambda (Name vid, Lazy.force coq_Z, mk_eq (mkRel 1) eq1) |]) in let mm = mk_integer m in let p_initial = [P_APP 2;P_TYPE] in let tac = clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: shuffle_mult_right p_initial orig.body m ({c= negone;v= v}::def.body) in Tacticals.New.tclTHENS (cut theorem) [Tacticals.New.tclTHENLIST [ (intros_using [aux]); (elim_id aux); (clear [aux]); (intros_using [vid; aux]); (generalize_tac [mkApp (Lazy.force coq_OMEGA9, [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); Proofview.V82.tactic (mk_then tac); (clear [aux]); (intros_using [id]); (loop l) ]; Tacticals.New.tclTHEN (exists_tac eq1) reflexivity ] | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> let id1 = new_identifier () and id2 = new_identifier () in tag_hypothesis id1 e1; tag_hypothesis id2 e2; let id = hyp_of_tag e.id in let tac1 = norm_add [P_APP 2;P_TYPE] e.body in let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in let eq = val_of(decompile e) in Tacticals.New.tclTHENS (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) [Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac1); (intros_using [id1]); (loop act1) ]; Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac2); (intros_using [id2]); (loop act2) ]] | SUM(e3,(k1,e1),(k2,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; let id1 = hyp_of_tag e1.id and id2 = hyp_of_tag e2.id in let eq1 = val_of(decompile e1) and eq2 = val_of(decompile e2) in if k1 =? one && e2.kind == EQUA then let tac_thm = match e1.kind with | EQUA -> Lazy.force coq_OMEGA5 | INEQ -> Lazy.force coq_OMEGA6 | DISE -> Lazy.force coq_OMEGA20 in let kk = mk_integer k2 in let p_initial = if e1.kind == DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in let tac = shuffle_mult_right p_initial e1.body k2 e2.body in Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); Proofview.V82.tactic (mk_then tac); (intros_using [id]); (loop l) ] else let kk1 = mk_integer k1 and kk2 = mk_integer k2 in let p_initial = [P_APP 2;P_TYPE] in let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in Tacticals.New.tclTHENS (cut (mk_gt kk1 izero)) [Tacticals.New.tclTHENS (cut (mk_gt kk2 izero)) [Tacticals.New.tclTHENLIST [ (intros_using [aux2;aux1]); (generalize_tac [mkApp (Lazy.force coq_OMEGA7, [| eq1;eq2;kk1;kk2; mkVar aux1;mkVar aux2; mkVar id1;mkVar id2 |])]); (clear [aux1;aux2]); Proofview.V82.tactic (mk_then tac); (intros_using [id]); (loop l) ]; Tacticals.New.tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ]; Tacticals.New.tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ] | CONSTANT_NOT_NUL(e,k) :: l -> Tacticals.New.tclTHEN ((generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl | CONSTANT_NUL(e) :: l -> Tacticals.New.tclTHEN (Proofview.V82.tactic (resolve_id (hyp_of_tag e))) reflexivity | CONSTANT_NEG(e,k) :: l -> Tacticals.New.tclTHENLIST [ (generalize_tac [mkVar (hyp_of_tag e)]); unfold sp_Zle; simpl_in_concl; unfold sp_not; (intros_using [aux]); Proofview.V82.tactic (resolve_id aux); reflexivity ] | _ -> Proofview.tclUNIT () in loop let normalize p_initial t = let (tac,t') = transform p_initial t in let (tac',t'') = condense p_initial t' in let (tac'',t''') = clear_zero p_initial t'' in tac @ tac' @ tac'' , t''' let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) = let p_initial = [P_APP pos ;P_TYPE] in let (tac,t') = normalize p_initial t in let shift_left = tclTHEN (Proofview.V82.of_tactic (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ])) (tclTRY (Proofview.V82.of_tactic (clear [id]))) in if not (List.is_empty tac) then let id' = new_identifier () in ((id',(Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (shift_left); Proofview.V82.tactic (mk_then tac); (intros_using [id']) ])) :: tactic, compile id' flag t' :: defs) else (tactic,defs) let destructure_omega gl tac_def (id,c) = if String.equal (atompart_of_id id) "State" then tac_def else try match destructurate_prop c with | Kapp(Eq,[typ;t1;t2]) when begin match destructurate_type (pf_nf gl typ) with Kapp(Z,[]) -> true | _ -> false end -> let t = mk_plus t1 (mk_inv t2) in normalize_equation id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def | Kapp(Zne,[t1;t2]) -> let t = mk_plus t1 (mk_inv t2) in normalize_equation id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def | Kapp(Zle,[t1;t2]) -> let t = mk_plus t2 (mk_inv t1) in normalize_equation id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def | Kapp(Zlt,[t1;t2]) -> let t = mk_plus (mk_plus t2 (mk_integer negone)) (mk_inv t1) in normalize_equation id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def | Kapp(Zge,[t1;t2]) -> let t = mk_plus t1 (mk_inv t2) in normalize_equation id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def | Kapp(Zgt,[t1;t2]) -> let t = mk_plus (mk_plus t1 (mk_integer negone)) (mk_inv t2) in normalize_equation id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def | _ -> tac_def with e when catchable_exception e -> tac_def let reintroduce id = (* [id] cannot be cleared if dependent: protect it by a try *) Tacticals.New.tclTHEN (Tacticals.New.tclTRY (clear [id])) (intro_using id) open Proofview.Notations let coq_omega = Proofview.Goal.nf_enter { enter = begin fun gl -> clear_constr_tables (); let hyps_types = Tacmach.New.pf_hyps_types gl in let destructure_omega = Tacmach.New.of_old destructure_omega gl in let tactic_normalisation, system = List.fold_left destructure_omega ([],[]) hyps_types in let prelude,sys = List.fold_left (fun (tac,sys) (t,(v,th,b)) -> if b then let id = new_identifier () in let i = new_id () in tag_hypothesis id i; (Tacticals.New.tclTHENLIST [ (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); (intros_using [v; id]); (elim_id id); (clear [id]); (intros_using [th;id]); tac ]), {kind = INEQ; body = [{v=intern_id v; c=one}]; constant = zero; id = i} :: sys else (Tacticals.New.tclTHENLIST [ (simplest_elim (applist (Lazy.force coq_new_var, [t]))); (intros_using [v;th]); tac ]), sys) (Proofview.tclUNIT (),[]) (dump_tables ()) in let system = system @ sys in if !display_system_flag then display_system display_var system; if !old_style_flag then begin try let _ = simplify (new_id,new_var_num,display_var) false system in Proofview.tclUNIT () with UNSOLVABLE -> let _,path = depend [] [] (history ()) in if !display_action_flag then display_action display_var path; (Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path)) end else begin try let path = simplify_strong (new_id,new_var_num,display_var) system in if !display_action_flag then display_action display_var path; Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path) with NO_CONTRADICTION -> Tacticals.New.tclZEROMSG (Pp.str"Omega can't solve this system") end end } let coq_omega = coq_omega let nat_inject = Proofview.Goal.nf_enter { enter = begin fun gl -> let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in let rec explore p t : unit Proofview.tactic = try match destructurate_term t with | Kapp(Plus,[t1;t2]) -> Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_plus),[t1;t2])); (explore (P_APP 1 :: p) t1); (explore (P_APP 2 :: p) t2) ] | Kapp(Mult,[t1;t2]) -> Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_mult),[t1;t2])); (explore (P_APP 1 :: p) t1); (explore (P_APP 2 :: p) t2) ] | Kapp(Minus,[t1;t2]) -> let id = new_identifier () in Tacticals.New.tclTHENS (Tacticals.New.tclTHEN (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) (intros_using [id])) [ Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (clever_rewrite_gen p (mk_minus (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id])); (loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]); (explore (P_APP 1 :: p) t1); (explore (P_APP 2 :: p) t2) ]; (Tacticals.New.tclTHEN (Proofview.V82.tactic (clever_rewrite_gen p (mk_integer zero) ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id]))) (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])])) ] | Kapp(S,[t']) -> let rec is_number t = try match destructurate_term t with Kapp(S,[t]) -> is_number t | Kapp(O,[]) -> true | _ -> false with e when catchable_exception e -> false in let rec loop p t : unit Proofview.tactic = try match destructurate_term t with Kapp(S,[t]) -> (Tacticals.New.tclTHEN (Proofview.V82.tactic (clever_rewrite_gen p (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |])) ((Lazy.force coq_inj_S),[t]))) (loop (P_APP 1 :: p) t)) | _ -> explore p t with e when catchable_exception e -> explore p t in if is_number t' then Proofview.V82.tactic (focused_simpl p) else loop p t | Kapp(Pred,[t]) -> let t_minus_one = mkApp (Lazy.force coq_minus, [| t; mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in Tacticals.New.tclTHEN (Proofview.V82.tactic (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one ((Lazy.force coq_pred_of_minus),[t]))) (explore p t_minus_one) | Kapp(O,[]) -> Proofview.V82.tactic (focused_simpl p) | _ -> Proofview.tclUNIT () with e when catchable_exception e -> Proofview.tclUNIT () and loop = function | [] -> Proofview.tclUNIT () | (i,t)::lit -> begin try match destructurate_prop t with Kapp(Le,[t1;t2]) -> Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); (reintroduce i); (loop lit) ] | Kapp(Lt,[t1;t2]) -> Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); (reintroduce i); (loop lit) ] | Kapp(Ge,[t1;t2]) -> Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); (reintroduce i); (loop lit) ] | Kapp(Gt,[t1;t2]) -> Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); (reintroduce i); (loop lit) ] | Kapp(Neq,[t1;t2]) -> Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); (reintroduce i); (loop lit) ] | Kapp(Eq,[typ;t1;t2]) -> if is_conv typ (Lazy.force coq_nat) then Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); (explore [P_APP 2; P_TYPE] t1); (explore [P_APP 3; P_TYPE] t2); (reintroduce i); (loop lit) ] else loop lit | _ -> loop lit with e when catchable_exception e -> loop lit end in let hyps_types = Tacmach.New.pf_hyps_types gl in loop (List.rev hyps_types) end } let dec_binop = function | Zne -> coq_dec_Zne | Zle -> coq_dec_Zle | Zlt -> coq_dec_Zlt | Zge -> coq_dec_Zge | Zgt -> coq_dec_Zgt | Le -> coq_dec_le | Lt -> coq_dec_lt | Ge -> coq_dec_ge | Gt -> coq_dec_gt | _ -> raise Not_found let not_binop = function | Zne -> coq_not_Zne | Zle -> coq_Znot_le_gt | Zlt -> coq_Znot_lt_ge | Zge -> coq_Znot_ge_lt | Zgt -> coq_Znot_gt_le | Le -> coq_not_le | Lt -> coq_not_lt | Ge -> coq_not_ge | Gt -> coq_not_gt | _ -> raise Not_found (** A decidability check : for some [t], could we build a term of type [decidable t] (i.e. [t\/~t]) ? Otherwise, we raise [Undecidable]. Note that a successful check implies that [t] has type Prop. *) exception Undecidable let rec decidability gl t = match destructurate_prop t with | Kapp(Or,[t1;t2]) -> mkApp (Lazy.force coq_dec_or, [| t1; t2; decidability gl t1; decidability gl t2 |]) | Kapp(And,[t1;t2]) -> mkApp (Lazy.force coq_dec_and, [| t1; t2; decidability gl t1; decidability gl t2 |]) | Kapp(Iff,[t1;t2]) -> mkApp (Lazy.force coq_dec_iff, [| t1; t2; decidability gl t1; decidability gl t2 |]) | Kimp(t1,t2) -> (* This is the only situation where it's not obvious that [t] is in Prop. The recursive call on [t2] will ensure that. *) mkApp (Lazy.force coq_dec_imp, [| t1; t2; decidability gl t1; decidability gl t2 |]) | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; decidability gl t1 |]) | Kapp(Eq,[typ;t1;t2]) -> begin match destructurate_type (pf_nf gl typ) with | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) | _ -> raise Undecidable end | Kapp(op,[t1;t2]) -> (try mkApp (Lazy.force (dec_binop op), [| t1; t2 |]) with Not_found -> raise Undecidable) | Kapp(False,[]) -> Lazy.force coq_dec_False | Kapp(True,[]) -> Lazy.force coq_dec_True | _ -> raise Undecidable let onClearedName id tac = (* We cannot ensure that hyps can be cleared (because of dependencies), *) (* so renaming may be necessary *) Tacticals.New.tclTHEN (Tacticals.New.tclTRY (clear [id])) (Proofview.Goal.nf_enter { enter = begin fun gl -> let id = Tacmach.New.of_old (fresh_id [] id) gl in Tacticals.New.tclTHEN (introduction id) (tac id) end }) let onClearedName2 id tac = Tacticals.New.tclTHEN (Tacticals.New.tclTRY (clear [id])) (Proofview.Goal.nf_enter { enter = begin fun gl -> let id1 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_left")) gl in let id2 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_right")) gl in Tacticals.New.tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] end }) let destructure_hyps = Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in let decidability = Tacmach.New.of_old decidability gl in let pf_nf = Tacmach.New.of_old pf_nf gl in let rec loop = function | [] -> (Tacticals.New.tclTHEN nat_inject coq_omega) | decl::lit -> let (i,_,t) = to_tuple decl in begin try match destructurate_prop t with | Kapp(False,[]) -> elim_id i | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit | Kapp(Or,[t1;t2]) -> (Tacticals.New.tclTHENS (elim_id i) [ onClearedName i (fun i -> (loop (LocalAssum (i,t1)::lit))); onClearedName i (fun i -> (loop (LocalAssum (i,t2)::lit))) ]) | Kapp(And,[t1;t2]) -> Tacticals.New.tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> loop (LocalAssum (i1,t1) :: LocalAssum (i2,t2) :: lit))) | Kapp(Iff,[t1;t2]) -> Tacticals.New.tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> loop (LocalAssum (i1,mkArrow t1 t2) :: LocalAssum (i2,mkArrow t2 t1) :: lit))) | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) if is_Prop (type_of t2) then let d1 = decidability t1 in Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_imp_simp, [| t1; t2; d1; mkVar i|])]); (onClearedName i (fun i -> (loop (LocalAssum (i,mk_or (mk_not t1) t2) :: lit)))) ] else loop lit | Kapp(Not,[t]) -> begin match destructurate_prop t with Kapp(Or,[t1;t2]) -> Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); (onClearedName i (fun i -> (loop (LocalAssum (i,mk_and (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(And,[t1;t2]) -> let d1 = decidability t1 in Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_and, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> (loop (LocalAssum (i,mk_or (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(Iff,[t1;t2]) -> let d1 = decidability t1 in let d2 = decidability t2 in Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_iff, [| t1; t2; d1; d2; mkVar i |])]); (onClearedName i (fun i -> (loop (LocalAssum (i, mk_or (mk_and t1 (mk_not t2)) (mk_and (mk_not t1) t2)) :: lit)))) ] | Kimp(t1,t2) -> (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok. For t1, being decidable implies being Prop. *) let d1 = decidability t1 in Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_imp, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> (loop (LocalAssum (i,mk_and t1 (mk_not t2)) :: lit)))) ] | Kapp(Not,[t]) -> let d = decidability t in Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); (onClearedName i (fun i -> (loop (LocalAssum (i,t) :: lit)))) ] | Kapp(op,[t1;t2]) -> (try let thm = not_binop op in Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]); (onClearedName i (fun _ -> loop lit)) ] with Not_found -> loop lit) | Kapp(Eq,[typ;t1;t2]) -> if !old_style_flag then begin match destructurate_type (pf_nf typ) with | Kapp(Nat,_) -> Tacticals.New.tclTHENLIST [ (simplest_elim (mkApp (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); (onClearedName i (fun _ -> loop lit)) ] | Kapp(Z,_) -> Tacticals.New.tclTHENLIST [ (simplest_elim (mkApp (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); (onClearedName i (fun _ -> loop lit)) ] | _ -> loop lit end else begin match destructurate_type (pf_nf typ) with | Kapp(Nat,_) -> (Tacticals.New.tclTHEN (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) decl)) (loop lit)) | Kapp(Z,_) -> (Tacticals.New.tclTHEN (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) decl)) (loop lit)) | _ -> loop lit end | _ -> loop lit end | _ -> loop lit with | Undecidable -> loop lit | e when catchable_exception e -> loop lit end in let hyps = Proofview.Goal.hyps gl in loop hyps end } let destructure_goal = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let decidability = Tacmach.New.of_old decidability gl in let rec loop t = match destructurate_prop t with | Kapp(Not,[t]) -> (Tacticals.New.tclTHEN (Tacticals.New.tclTHEN (unfold sp_not) intro) destructure_hyps) | Kimp(a,b) -> (Tacticals.New.tclTHEN intro (loop b)) | Kapp(False,[]) -> destructure_hyps | _ -> let goal_tac = try let dec = decidability t in Tacticals.New.tclTHEN (Proofview.V82.tactic (Tacmach.refine (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |])))) intro with Undecidable -> Tactics.elim_type (build_coq_False ()) in Tacticals.New.tclTHEN goal_tac destructure_hyps in (loop concl) end } let destructure_goal = destructure_goal let omega_solver = Proofview.tclUNIT () >>= fun () -> (* delay for [check_required_library] *) Coqlib.check_required_library ["Coq";"omega";"Omega"]; reset_all (); destructure_goal coq-8.6/plugins/omega/OmegaPlugin.v0000644000175000017500000000123013022274260016622 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* eval_tactic "zify_nat" | "positive" -> eval_tactic "zify_positive" | "N" -> eval_tactic "zify_N" | "Z" -> eval_tactic "zify_op" | s -> CErrors.error ("No Omega knowledge base for type "^s)) (Util.List.sort_uniquize String.compare l) in Tacticals.New.tclTHEN (Tacticals.New.tclREPEAT (Tacticals.New.tclTHENLIST tacs)) (omega_solver) TACTIC EXTEND omega | [ "omega" ] -> [ omega_tactic [] ] END TACTIC EXTEND omega' | [ "omega" "with" ne_ident_list(l) ] -> [ omega_tactic (List.map Names.Id.to_string l) ] | [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ] END coq-8.6/plugins/omega/PreOmega.v0000644000175000017500000003654413022274260016132 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* simpl (t a) in * | _ => zify_unop_var_or_term t thm a end. Ltac zify_unop_nored t thm a := (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *) let isz := isZcst a in match isz with | true => zify_unop_core t thm a | _ => zify_unop_var_or_term t thm a end. Ltac zify_binop t thm a b:= (* works as zify_unop, except that we should be careful when dealing with b, since it can be equal to a *) let isza := isZcst a in match isza with | true => zify_unop (t a) (thm a) b | _ => let za := fresh "z" in (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) || (remember a as za; match goal with | H : za = b |- _ => zify_unop_nored (t za) (thm za) za | _ => zify_unop_nored (t za) (thm za) b end) end. Ltac zify_op_1 := match goal with | |- context [ Z.max ?a ?b ] => zify_binop Z.max Z.max_spec a b | H : context [ Z.max ?a ?b ] |- _ => zify_binop Z.max Z.max_spec a b | |- context [ Z.min ?a ?b ] => zify_binop Z.min Z.min_spec a b | H : context [ Z.min ?a ?b ] |- _ => zify_binop Z.min Z.min_spec a b | |- context [ Z.sgn ?a ] => zify_unop Z.sgn Z.sgn_spec a | H : context [ Z.sgn ?a ] |- _ => zify_unop Z.sgn Z.sgn_spec a | |- context [ Z.abs ?a ] => zify_unop Z.abs Z.abs_spec a | H : context [ Z.abs ?a ] |- _ => zify_unop Z.abs Z.abs_spec a end. Ltac zify_op := repeat zify_op_1. (** II) Conversion from nat to Z *) Definition Z_of_nat' := Z.of_nat. Ltac hide_Z_of_nat t := let z := fresh "z" in set (z:=Z.of_nat t) in *; change Z.of_nat with Z_of_nat' in z; unfold z in *; clear z. Ltac zify_nat_rel := match goal with (* I: equalities *) | |- (@eq nat ?a ?b) => apply (Nat2Z.inj a b) (* shortcut *) | H : context [ @eq nat ?a ?b ] |- _ => rewrite <- (Nat2Z.inj_iff a b) in H | |- context [ @eq nat ?a ?b ] => rewrite <- (Nat2Z.inj_iff a b) (* II: less than *) | H : context [ lt ?a ?b ] |- _ => rewrite (Nat2Z.inj_lt a b) in H | |- context [ lt ?a ?b ] => rewrite (Nat2Z.inj_lt a b) (* III: less or equal *) | H : context [ le ?a ?b ] |- _ => rewrite (Nat2Z.inj_le a b) in H | |- context [ le ?a ?b ] => rewrite (Nat2Z.inj_le a b) (* IV: greater than *) | H : context [ gt ?a ?b ] |- _ => rewrite (Nat2Z.inj_gt a b) in H | |- context [ gt ?a ?b ] => rewrite (Nat2Z.inj_gt a b) (* V: greater or equal *) | H : context [ ge ?a ?b ] |- _ => rewrite (Nat2Z.inj_ge a b) in H | |- context [ ge ?a ?b ] => rewrite (Nat2Z.inj_ge a b) end. Ltac zify_nat_op := match goal with (* misc type conversions: positive/N/Z to nat *) | H : context [ Z.of_nat (Pos.to_nat ?a) ] |- _ => rewrite (positive_nat_Z a) in H | |- context [ Z.of_nat (Pos.to_nat ?a) ] => rewrite (positive_nat_Z a) | H : context [ Z.of_nat (N.to_nat ?a) ] |- _ => rewrite (N_nat_Z a) in H | |- context [ Z.of_nat (N.to_nat ?a) ] => rewrite (N_nat_Z a) | H : context [ Z.of_nat (Z.abs_nat ?a) ] |- _ => rewrite (Zabs2Nat.id_abs a) in H | |- context [ Z.of_nat (Z.abs_nat ?a) ] => rewrite (Zabs2Nat.id_abs a) (* plus -> Z.add *) | H : context [ Z.of_nat (plus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_add a b) in H | |- context [ Z.of_nat (plus ?a ?b) ] => rewrite (Nat2Z.inj_add a b) (* min -> Z.min *) | H : context [ Z.of_nat (min ?a ?b) ] |- _ => rewrite (Nat2Z.inj_min a b) in H | |- context [ Z.of_nat (min ?a ?b) ] => rewrite (Nat2Z.inj_min a b) (* max -> Z.max *) | H : context [ Z.of_nat (max ?a ?b) ] |- _ => rewrite (Nat2Z.inj_max a b) in H | |- context [ Z.of_nat (max ?a ?b) ] => rewrite (Nat2Z.inj_max a b) (* minus -> Z.max (Z.sub ... ...) 0 *) | H : context [ Z.of_nat (minus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_sub_max a b) in H | |- context [ Z.of_nat (minus ?a ?b) ] => rewrite (Nat2Z.inj_sub_max a b) (* pred -> minus ... -1 -> Z.max (Z.sub ... -1) 0 *) | H : context [ Z.of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H | |- context [ Z.of_nat (pred ?a) ] => rewrite (pred_of_minus a) (* mult -> Z.mul and a positivity hypothesis *) | H : context [ Z.of_nat (mult ?a ?b) ] |- _ => pose proof (Nat2Z.is_nonneg (mult a b)); rewrite (Nat2Z.inj_mul a b) in * | |- context [ Z.of_nat (mult ?a ?b) ] => pose proof (Nat2Z.is_nonneg (mult a b)); rewrite (Nat2Z.inj_mul a b) in * (* O -> Z0 *) | H : context [ Z.of_nat O ] |- _ => simpl (Z.of_nat O) in H | |- context [ Z.of_nat O ] => simpl (Z.of_nat O) (* S -> number or Z.succ *) | H : context [ Z.of_nat (S ?a) ] |- _ => let isnat := isnatcst a in match isnat with | true => simpl (Z.of_nat (S a)) in H | _ => rewrite (Nat2Z.inj_succ a) in H end | |- context [ Z.of_nat (S ?a) ] => let isnat := isnatcst a in match isnat with | true => simpl (Z.of_nat (S a)) | _ => rewrite (Nat2Z.inj_succ a) end (* atoms of type nat : we add a positivity condition (if not already there) *) | _ : 0 <= Z.of_nat ?a |- _ => hide_Z_of_nat a | _ : context [ Z.of_nat ?a ] |- _ => pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a | |- context [ Z.of_nat ?a ] => pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a end. Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. (* III) conversion from positive to Z *) Definition Zpos' := Zpos. Definition Zneg' := Zneg. Ltac hide_Zpos t := let z := fresh "z" in set (z:=Zpos t) in *; change Zpos with Zpos' in z; unfold z in *; clear z. Ltac zify_positive_rel := match goal with (* I: equalities *) | |- (@eq positive ?a ?b) => apply Pos2Z.inj | H : context [ @eq positive ?a ?b ] |- _ => rewrite <- (Pos2Z.inj_iff a b) in H | |- context [ @eq positive ?a ?b ] => rewrite <- (Pos2Z.inj_iff a b) (* II: less than *) | H : context [ (?a < ?b)%positive ] |- _ => change (a change (a change (a<=b)%positive with (Zpos a<=Zpos b) in H | |- context [ (?a <= ?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b) (* IV: greater than *) | H : context [ (?a > ?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H | |- context [ (?a > ?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b) (* V: greater or equal *) | H : context [ (?a >= ?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H | |- context [ (?a >= ?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) end. Ltac zify_positive_op := match goal with (* Zneg -> -Zpos (except for numbers) *) | H : context [ Zneg ?a ] |- _ => let isp := isPcst a in match isp with | true => change (Zneg a) with (Zneg' a) in H | _ => change (Zneg a) with (- Zpos a) in H end | |- context [ Zneg ?a ] => let isp := isPcst a in match isp with | true => change (Zneg a) with (Zneg' a) | _ => change (Zneg a) with (- Zpos a) end (* misc type conversions: nat to positive *) | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) (* Pos.add -> Z.add *) | H : context [ Zpos (?a + ?b) ] |- _ => change (Zpos (a+b)) with (Zpos a + Zpos b) in H | |- context [ Zpos (?a + ?b) ] => change (Zpos (a+b)) with (Zpos a + Zpos b) (* Pos.min -> Z.min *) | H : context [ Zpos (Pos.min ?a ?b) ] |- _ => rewrite (Pos2Z.inj_min a b) in H | |- context [ Zpos (Pos.min ?a ?b) ] => rewrite (Pos2Z.inj_min a b) (* Pos.max -> Z.max *) | H : context [ Zpos (Pos.max ?a ?b) ] |- _ => rewrite (Pos2Z.inj_max a b) in H | |- context [ Zpos (Pos.max ?a ?b) ] => rewrite (Pos2Z.inj_max a b) (* Pos.sub -> Z.max 1 (Z.sub ... ...) *) | H : context [ Zpos (Pos.sub ?a ?b) ] |- _ => rewrite (Pos2Z.inj_sub a b) in H | |- context [ Zpos (Pos.sub ?a ?b) ] => rewrite (Pos2Z.inj_sub a b) (* Pos.succ -> Z.succ *) | H : context [ Zpos (Pos.succ ?a) ] |- _ => rewrite (Pos2Z.inj_succ a) in H | |- context [ Zpos (Pos.succ ?a) ] => rewrite (Pos2Z.inj_succ a) (* Pos.pred -> Pos.sub ... -1 -> Z.max 1 (Z.sub ... - 1) *) | H : context [ Zpos (Pos.pred ?a) ] |- _ => rewrite <- (Pos.sub_1_r a) in H | |- context [ Zpos (Pos.pred ?a) ] => rewrite <- (Pos.sub_1_r a) (* Pos.mul -> Z.mul and a positivity hypothesis *) | H : context [ Zpos (?a * ?b) ] |- _ => pose proof (Pos2Z.is_pos (Pos.mul a b)); change (Zpos (a*b)) with (Zpos a * Zpos b) in * | |- context [ Zpos (?a * ?b) ] => pose proof (Pos2Z.is_pos (Pos.mul a b)); change (Zpos (a*b)) with (Zpos a * Zpos b) in * (* xO *) | H : context [ Zpos (xO ?a) ] |- _ => let isp := isPcst a in match isp with | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H | _ => rewrite (Pos2Z.inj_xO a) in H end | |- context [ Zpos (xO ?a) ] => let isp := isPcst a in match isp with | true => change (Zpos (xO a)) with (Zpos' (xO a)) | _ => rewrite (Pos2Z.inj_xO a) end (* xI *) | H : context [ Zpos (xI ?a) ] |- _ => let isp := isPcst a in match isp with | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H | _ => rewrite (Pos2Z.inj_xI a) in H end | |- context [ Zpos (xI ?a) ] => let isp := isPcst a in match isp with | true => change (Zpos (xI a)) with (Zpos' (xI a)) | _ => rewrite (Pos2Z.inj_xI a) end (* xI : nothing to do, just prevent adding a useless positivity condition *) | H : context [ Zpos xH ] |- _ => hide_Zpos xH | |- context [ Zpos xH ] => hide_Zpos xH (* atoms of type positive : we add a positivity condition (if not already there) *) | _ : 0 < Zpos ?a |- _ => hide_Zpos a | _ : context [ Zpos ?a ] |- _ => pose proof (Pos2Z.is_pos a); hide_Zpos a | |- context [ Zpos ?a ] => pose proof (Pos2Z.is_pos a); hide_Zpos a end. Ltac zify_positive := repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *. (* IV) conversion from N to Z *) Definition Z_of_N' := Z.of_N. Ltac hide_Z_of_N t := let z := fresh "z" in set (z:=Z.of_N t) in *; change Z.of_N with Z_of_N' in z; unfold z in *; clear z. Ltac zify_N_rel := match goal with (* I: equalities *) | |- (@eq N ?a ?b) => apply (N2Z.inj a b) (* shortcut *) | H : context [ @eq N ?a ?b ] |- _ => rewrite <- (N2Z.inj_iff a b) in H | |- context [ @eq N ?a ?b ] => rewrite <- (N2Z.inj_iff a b) (* II: less than *) | H : context [ (?a < ?b)%N ] |- _ => rewrite (N2Z.inj_lt a b) in H | |- context [ (?a < ?b)%N ] => rewrite (N2Z.inj_lt a b) (* III: less or equal *) | H : context [ (?a <= ?b)%N ] |- _ => rewrite (N2Z.inj_le a b) in H | |- context [ (?a <= ?b)%N ] => rewrite (N2Z.inj_le a b) (* IV: greater than *) | H : context [ (?a > ?b)%N ] |- _ => rewrite (N2Z.inj_gt a b) in H | |- context [ (?a > ?b)%N ] => rewrite (N2Z.inj_gt a b) (* V: greater or equal *) | H : context [ (?a >= ?b)%N ] |- _ => rewrite (N2Z.inj_ge a b) in H | |- context [ (?a >= ?b)%N ] => rewrite (N2Z.inj_ge a b) end. Ltac zify_N_op := match goal with (* misc type conversions: nat to positive *) | H : context [ Z.of_N (N.of_nat ?a) ] |- _ => rewrite (nat_N_Z a) in H | |- context [ Z.of_N (N.of_nat ?a) ] => rewrite (nat_N_Z a) | H : context [ Z.of_N (Z.abs_N ?a) ] |- _ => rewrite (N2Z.inj_abs_N a) in H | |- context [ Z.of_N (Z.abs_N ?a) ] => rewrite (N2Z.inj_abs_N a) | H : context [ Z.of_N (Npos ?a) ] |- _ => rewrite (N2Z.inj_pos a) in H | |- context [ Z.of_N (Npos ?a) ] => rewrite (N2Z.inj_pos a) | H : context [ Z.of_N N0 ] |- _ => change (Z.of_N N0) with Z0 in H | |- context [ Z.of_N N0 ] => change (Z.of_N N0) with Z0 (* N.add -> Z.add *) | H : context [ Z.of_N (N.add ?a ?b) ] |- _ => rewrite (N2Z.inj_add a b) in H | |- context [ Z.of_N (N.add ?a ?b) ] => rewrite (N2Z.inj_add a b) (* N.min -> Z.min *) | H : context [ Z.of_N (N.min ?a ?b) ] |- _ => rewrite (N2Z.inj_min a b) in H | |- context [ Z.of_N (N.min ?a ?b) ] => rewrite (N2Z.inj_min a b) (* N.max -> Z.max *) | H : context [ Z.of_N (N.max ?a ?b) ] |- _ => rewrite (N2Z.inj_max a b) in H | |- context [ Z.of_N (N.max ?a ?b) ] => rewrite (N2Z.inj_max a b) (* N.sub -> Z.max 0 (Z.sub ... ...) *) | H : context [ Z.of_N (N.sub ?a ?b) ] |- _ => rewrite (N2Z.inj_sub_max a b) in H | |- context [ Z.of_N (N.sub ?a ?b) ] => rewrite (N2Z.inj_sub_max a b) (* N.succ -> Z.succ *) | H : context [ Z.of_N (N.succ ?a) ] |- _ => rewrite (N2Z.inj_succ a) in H | |- context [ Z.of_N (N.succ ?a) ] => rewrite (N2Z.inj_succ a) (* N.mul -> Z.mul and a positivity hypothesis *) | H : context [ Z.of_N (N.mul ?a ?b) ] |- _ => pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * | |- context [ Z.of_N (N.mul ?a ?b) ] => pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * (* atoms of type N : we add a positivity condition (if not already there) *) | _ : 0 <= Z.of_N ?a |- _ => hide_Z_of_N a | _ : context [ Z.of_N ?a ] |- _ => pose proof (N2Z.is_nonneg a); hide_Z_of_N a | |- context [ Z.of_N ?a ] => pose proof (N2Z.is_nonneg a); hide_Z_of_N a end. Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. (** The complete Z-ification tactic *) Ltac zify := repeat (zify_nat; zify_positive; zify_N); zify_op. coq-8.6/plugins/omega/Omega.v0000644000175000017500000000477413022274260015463 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* nat) => abstract omega: zarith. Hint Extern 10 (_ <= _) => abstract omega: zarith. Hint Extern 10 (_ < _) => abstract omega: zarith. Hint Extern 10 (_ >= _) => abstract omega: zarith. Hint Extern 10 (_ > _) => abstract omega: zarith. Hint Extern 10 (_ <> _ :>nat) => abstract omega: zarith. Hint Extern 10 (~ _ <= _) => abstract omega: zarith. Hint Extern 10 (~ _ < _) => abstract omega: zarith. Hint Extern 10 (~ _ >= _) => abstract omega: zarith. Hint Extern 10 (~ _ > _) => abstract omega: zarith. Hint Extern 10 (_ = _ :>Z) => abstract omega: zarith. Hint Extern 10 (_ <= _)%Z => abstract omega: zarith. Hint Extern 10 (_ < _)%Z => abstract omega: zarith. Hint Extern 10 (_ >= _)%Z => abstract omega: zarith. Hint Extern 10 (_ > _)%Z => abstract omega: zarith. Hint Extern 10 (_ <> _ :>Z) => abstract omega: zarith. Hint Extern 10 (~ (_ <= _)%Z) => abstract omega: zarith. Hint Extern 10 (~ (_ < _)%Z) => abstract omega: zarith. Hint Extern 10 (~ (_ >= _)%Z) => abstract omega: zarith. Hint Extern 10 (~ (_ > _)%Z) => abstract omega: zarith. Hint Extern 10 False => abstract omega: zarith. coq-8.6/plugins/omega/vo.itarget0000644000175000017500000000010213022274260016226 0ustar mdenesmdenesOmegaLemmas.vo OmegaPlugin.vo OmegaTactic.vo Omega.vo PreOmega.vo coq-8.6/plugins/ssrmatching/0000755000175000017500000000000013022274260015462 5ustar mdenesmdenescoq-8.6/plugins/ssrmatching/ssrmatching.ml40000644000175000017500000016204513022274260020432 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ()) let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s) let _ = try ignore(Sys.getenv "SSRMATCHINGDEBUG"); pp_ref := ssr_pp with Not_found -> () let debug b = if b then pp_ref := ssr_pp else pp_ref := fun _ -> () let _ = Goptions.declare_bool_option { Goptions.optsync = false; Goptions.optname = "ssrmatching debugging"; Goptions.optkey = ["Debug";"SsrMatching"]; Goptions.optdepr = false; Goptions.optread = (fun _ -> !pp_ref == ssr_pp); Goptions.optwrite = debug } let pp s = !pp_ref s (** Utils {{{ *****************************************************************) let env_size env = List.length (Environ.named_context env) let safeDestApp c = match kind_of_term c with App (f, a) -> f, a | _ -> c, [| |] let get_index = function ArgArg i -> i | _ -> CErrors.anomaly (str"Uninterpreted index") (* Toplevel constr must be globalized twice ! *) let glob_constr ist genv = function | _, Some ce -> let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.lfun Id.Set.empty in let ltacvars = { Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in Constrintern.intern_gen WithoutTypeConstraint ~ltacvars:ltacvars genv ce | rc, None -> rc (* Term printing utilities functions for deciding bracketing. *) let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") (* String lexing utilities *) let skip_wschars s = let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop (* We also guard characters that might interfere with the ssreflect *) (* tactic syntax. *) let guard_term ch1 s i = match s.[i] with | '(' -> false | '{' | '/' | '=' -> true | _ -> ch1 = '(' (* The call 'guard s i' should return true if the contents of s *) (* starting at i need bracketing to avoid ambiguities. *) let pr_guarded guard prc c = let s = Pp.string_of_ppcmds (prc c) ^ "$" in if guard s (skip_wschars s 0) then pr_paren prc c else prc c (* More sensible names for constr printers *) let pr_constr = pr_constr let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c let prl_constr_expr = pr_lconstr_expr let pr_constr_expr = pr_constr_expr let prl_glob_constr_and_expr = function | _, Some c -> prl_constr_expr c | c, None -> prl_glob_constr c let pr_glob_constr_and_expr = function | _, Some c -> pr_constr_expr c | c, None -> pr_glob_constr c let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c (** Adding a new uninterpreted generic argument type *) let add_genarg tag pr = let wit = Genarg.make0 tag in let tag = Geninterp.Val.create tag in let glob ist x = (ist, x) in let subst _ x = x in let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in let gen_pr _ _ _ = pr in let () = Genintern.register_intern0 wit glob in let () = Genintern.register_subst0 wit subst in let () = Geninterp.register_interp0 wit interp in let () = Geninterp.register_val0 wit (Some (Geninterp.Val.Base tag)) in Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr; wit (** Constructors for cast type *) let dC t = CastConv t (** Constructors for constr_expr *) let isCVar = function CRef (Ident _, _) -> true | _ -> false let destCVar = function CRef (Ident (_, id), _) -> id | _ -> CErrors.anomaly (str"not a CRef") let mkCHole loc = CHole (loc, None, IntroAnonymous, None) let mkCLambda loc name ty t = CLambdaN (loc, [[loc, name], Default Explicit, ty], t) let mkCLetIn loc name bo t = CLetIn (loc, (loc, name), bo, t) let mkCCast loc t ty = CCast (loc,t, dC ty) (** Constructors for rawconstr *) let mkRHole = GHole (dummy_loc, InternalHole, IntroAnonymous, None) let mkRApp f args = if args = [] then f else GApp (dummy_loc, f, args) let mkRCast rc rt = GCast (dummy_loc, rc, dC rt) let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t) (* ssrterm conbinators *) let combineCG t1 t2 f g = match t1, t2 with | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2)) | _, (_, (_, None)) -> CErrors.anomaly (str"have: mixed C-G constr") | _ -> CErrors.anomaly (str"have: mixed G-C constr") let loc_ofCG = function | (_, (s, None)) -> Glob_ops.loc_of_glob_constr s | (_, (_, Some s)) -> Constrexpr_ops.constr_loc s let mk_term k c = k, (mkRHole, Some c) let mk_lterm = mk_term ' ' let pf_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty (* }}} *) (** Profiling {{{ *************************************************************) type profiler = { profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; reset : unit -> unit; print : unit -> unit } let profile_now = ref false let something_profiled = ref false let profilers = ref [] let add_profiler f = profilers := f :: !profilers;; let profile b = profile_now := b; if b then List.iter (fun f -> f.reset ()) !profilers; if not b then List.iter (fun f -> f.print ()) !profilers ;; let _ = Goptions.declare_bool_option { Goptions.optsync = false; Goptions.optname = "ssrmatching profiling"; Goptions.optkey = ["SsrMatchingProfiling"]; Goptions.optread = (fun _ -> !profile_now); Goptions.optdepr = false; Goptions.optwrite = profile } let () = let prof_total = let init = ref 0.0 in { profile = (fun f x -> assert false); reset = (fun () -> init := Unix.gettimeofday ()); print = (fun () -> if !something_profiled then prerr_endline (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in let prof_legenda = { profile = (fun f x -> assert false); reset = (fun () -> ()); print = (fun () -> if !something_profiled then begin prerr_endline (Printf.sprintf "!! %39s ---------- --------- --------- ---------" (String.make 39 '-')); prerr_endline (Printf.sprintf "!! %-39s %10s %9s %9s %9s" "function" "#calls" "total" "max" "average") end) } in add_profiler prof_legenda; add_profiler prof_total ;; let mk_profiler s = let total, calls, max = ref 0.0, ref 0, ref 0.0 in let reset () = total := 0.0; calls := 0; max := 0.0 in let profile f x = if not !profile_now then f x else let before = Unix.gettimeofday () in try incr calls; let res = f x in let after = Unix.gettimeofday () in let delta = after -. before in total := !total +. delta; if delta > !max then max := delta; res with exc -> let after = Unix.gettimeofday () in let delta = after -. before in total := !total +. delta; if delta > !max then max := delta; raise exc in let print () = if !calls <> 0 then begin something_profiled := true; prerr_endline (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" s !calls !total !max (!total /. (float_of_int !calls))) end in let prof = { profile = profile; reset = reset; print = print } in add_profiler prof; prof ;; (* }}} *) exception NoProgress (** Unification procedures. *) (* To enforce the rigidity of the rooted match we always split *) (* top applications, so the unification procedures operate on *) (* arrays of patterns and terms. *) (* We perform three kinds of unification: *) (* EQ: exact conversion check *) (* FO: first-order unification of evars, without conversion *) (* HO: higher-order unification with conversion *) (* The subterm unification strategy is to find the first FO *) (* match, if possible, and the first HO match otherwise, then *) (* compute all the occurrences that are EQ matches for the *) (* relevant subterm. *) (* Additional twists: *) (* - If FO/HO fails then we attempt to fill evars using *) (* typeclasses before raising an outright error. We also *) (* fill typeclasses even after a successful match, since *) (* beta-reduction and canonical instances may leave *) (* undefined evars. *) (* - We do postchecks to rule out matches that are not *) (* closed or that assign to a global evar; these can be *) (* disabled for rewrite or dependent family matches. *) (* - We do a full FO scan before turning to HO, as the FO *) (* comparison can be much faster than the HO one. *) let unif_EQ env sigma p c = let evars = existential_opt_value sigma, Evd.universes sigma in try let _ = Reduction.conv env p ~evars c in true with _ -> false let unif_EQ_args env sigma pa a = let n = Array.length pa in let rec loop i = (i = n) || unif_EQ env sigma pa.(i) a.(i) && loop (i + 1) in loop 0 let prof_unif_eq_args = mk_profiler "unif_EQ_args";; let unif_EQ_args env sigma pa a = prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a ;; let unif_HO env ise p c = Evarconv.the_conv_x env p c ise let unif_HOtype env ise p c = Evarconv.the_conv_x_leq env p c ise let unif_HO_args env ise0 pa i ca = let n = Array.length pa in let rec loop ise j = if j = n then ise else loop (unif_HO env ise pa.(j) ca.(i + j)) (j + 1) in loop ise0 0 (* FO unification should boil down to calling w_unify with no_delta, but *) (* alas things are not so simple: w_unify does partial type-checking, *) (* which breaks down when the no-delta flag is on (as the Coq type system *) (* requires full convertibility. The workaround here is to convert all *) (* evars into metas, since 8.2 does not TC metas. This means some lossage *) (* for HO evars, though hopefully Miller patterns can pick up some of *) (* those cases, and HO matching will mop up the rest. *) let flags_FO = let flags = { (Unification.default_no_delta_unify_flags ()).Unification.core_unify_flags with Unification.modulo_conv_on_closed_terms = None; Unification.modulo_eta = true; Unification.modulo_betaiota = true; Unification.modulo_delta_types = full_transparent_state} in { Unification.core_unify_flags = flags; Unification.merge_unify_flags = flags; Unification.subterm_unify_flags = flags; Unification.allow_K_in_toplevel_higher_order_unification = false; Unification.resolve_evars = (Unification.default_no_delta_unify_flags ()).Unification.resolve_evars } let unif_FO env ise p c = Unification.w_unify env ise Reduction.CONV ~flags:flags_FO p c (* Perform evar substitution in main term and prune substitution. *) let nf_open_term sigma0 ise c = let s = ise and s' = ref sigma0 in let rec nf c' = match kind_of_term c' with | Evar ex -> begin try nf (existential_value s ex) with _ -> let k, a = ex in let a' = Array.map nf a in if not (Evd.mem !s' k) then s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k)); mkEvar (k, a') end | _ -> map_constr nf c' in let copy_def k evi () = if evar_body evi != Evd.Evar_empty then () else match Evd.evar_body (Evd.find s k) with | Evar_defined c' -> s' := Evd.define k (nf c') !s' | _ -> () in let c' = nf c in let _ = Evd.fold copy_def sigma0 () in !s', Evd.evar_universe_context s, c' let unif_end env sigma0 ise0 pt ok = let ise = Evarconv.solve_unif_constraints_with_heuristics env ise0 in let s, uc, t = nf_open_term sigma0 ise pt in let ise1 = create_evar_defs s in let ise1 = Evd.set_universe_context ise1 uc in let ise2 = Typeclasses.resolve_typeclasses ~fail:true env ise1 in if not (ok ise) then raise NoProgress else if ise2 == ise1 then (s, uc, t) else let s, uc', t = nf_open_term sigma0 ise2 t in s, Evd.union_evar_universe_context uc uc', t let pf_unif_HO gl sigma pt p c = let env = pf_env gl in let ise = unif_HO env (create_evar_defs sigma) p c in unif_end env (project gl) ise pt (fun _ -> true) let unify_HO env sigma0 t1 t2 = let sigma = unif_HO env sigma0 t1 t2 in let sigma, uc, _ = unif_end env sigma0 sigma t2 (fun _ -> true) in Evd.set_universe_context sigma uc let pf_unify_HO gl t1 t2 = let env, sigma0, si = pf_env gl, project gl, sig_it gl in let sigma = unify_HO env sigma0 t1 t2 in re_sig si sigma (* This is what the definition of iter_constr should be... *) let iter_constr_LR f c = match kind_of_term c with | Evar (k, a) -> Array.iter f a | Cast (cc, _, t) -> f cc; f t | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b | LetIn (_, v, t, b) -> f v; f t; f b | App (cf, a) -> f cf; Array.iter f a | Case (_, p, v, b) -> f v; f p; Array.iter f b | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done | Proj(_,a) -> f a | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () (* The comparison used to determine which subterms matches is KEYED *) (* CONVERSION. This looks for convertible terms that either have the same *) (* same head constant as pat if pat is an application (after beta-iota), *) (* or start with the same constr constructor (esp. for LetIn); this is *) (* disregarded if the head term is let x := ... in x, and casts are always *) (* ignored and removed). *) (* Record projections get special treatment: in addition to the projection *) (* constant itself, ssreflect also recognizes head constants of canonical *) (* projections. *) exception NoMatch type ssrdir = L2R | R2L let pr_dir_side = function L2R -> str "LHS" | R2L -> str "RHS" let inv_dir = function L2R -> R2L | R2L -> L2R type pattern_class = | KpatFixed | KpatConst | KpatEvar of existential_key | KpatLet | KpatLam | KpatRigid | KpatFlex | KpatProj of constant type tpattern = { up_k : pattern_class; up_FO : constr; up_f : constr; up_a : constr array; up_t : constr; (* equation proof term or matched term *) up_dir : ssrdir; (* direction of the rule *) up_ok : constr -> evar_map -> bool; (* progess test for rewrite *) } let all_ok _ _ = true let proj_nparams c = try 1 + Recordops.find_projection_nparams (ConstRef c) with _ -> 0 let isFixed c = match kind_of_term c with | Var _ | Ind _ | Construct _ | Const _ | Proj _ -> true | _ -> false let isRigid c = match kind_of_term c with | Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _ -> true | _ -> false exception UndefPat let hole_var = mkVar (id_of_string "_") let pr_constr_pat c0 = let rec wipe_evar c = if isEvar c then hole_var else map_constr wipe_evar c in pr_constr (wipe_evar c0) (* Turn (new) evars into metas *) let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = let ise = ref ise0 in let sigma = ref ise0 in let nenv = env_size env + if hack then 1 else 0 in let rec put c = match kind_of_term c with | Evar (k, a as ex) -> begin try put (existential_value !sigma ex) with NotInstantiatedEvar -> if Evd.mem sigma0 k then map_constr put c else let evi = Evd.find !sigma k in let dc = List.firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in let abs_dc (d, c) = function | Context.Named.Declaration.LocalDef (x, b, t) -> d, mkNamedLetIn x (put b) (put t) c | Context.Named.Declaration.LocalAssum (x, t) -> mkVar x :: d, mkNamedProd x (put t) c in let a, t = Context.Named.fold_inside abs_dc ~init:([], (put evi.evar_concl)) dc in let m = Evarutil.new_meta () in ise := meta_declare m t !ise; sigma := Evd.define k (applist (mkMeta m, a)) !sigma; put (existential_value !sigma ex) end | _ -> map_constr put c in let c1 = put c0 in !ise, c1 (* Compile a match pattern from a term; t is the term to fill. *) (* p_origin can be passed to obtain a better error message *) let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = let k, f, a = let f, a = Reductionops.whd_betaiota_stack ise p in match kind_of_term f with | Const (p,_) -> let np = proj_nparams p in if np = 0 || np > List.length a then KpatConst, f, a else let a1, a2 = List.chop np a in KpatProj p, applist(f, a1), a2 | Proj (p,arg) -> KpatProj (Projection.constant p), f, a | Var _ | Ind _ | Construct _ -> KpatFixed, f, a | Evar (k, _) -> if Evd.mem sigma0 k then KpatEvar k, f, a else if a <> [] then KpatFlex, f, a else (match p_origin with None -> CErrors.error "indeterminate pattern" | Some (dir, rule) -> errorstrm (str "indeterminate " ++ pr_dir_side dir ++ str " in " ++ pr_constr_pat rule)) | LetIn (_, v, _, b) -> if b <> mkRel 1 then KpatLet, f, a else KpatFlex, v, a | Lambda _ -> KpatLam, f, a | _ -> KpatRigid, f, a in let aa = Array.of_list a in let ise', p' = evars_for_FO ~hack env sigma0 ise (mkApp (f, aa)) in ise', { up_k = k; up_FO = p'; up_f = f; up_a = aa; up_ok = ok; up_dir = dir; up_t = t} (* Specialize a pattern after a successful match: assign a precise head *) (* kind and arity for Proj and Flex patterns. *) let ungen_upat lhs (sigma, uc, t) u = let f, a = safeDestApp lhs in let k = match kind_of_term f with | Var _ | Ind _ | Construct _ -> KpatFixed | Const _ -> KpatConst | Evar (k, _) -> if is_defined sigma k then raise NoMatch else KpatEvar k | LetIn _ -> KpatLet | Lambda _ -> KpatLam | _ -> KpatRigid in sigma, uc, {u with up_k = k; up_FO = lhs; up_f = f; up_a = a; up_t = t} let nb_cs_proj_args pc f u = let na k = List.length (snd (lookup_canonical_conversion (ConstRef pc, k))).o_TCOMPS in try match kind_of_term f with | Prod _ -> na Prod_cs | Sort s -> na (Sort_cs (family_of_sort s)) | Const (c',_) when Constant.equal c' pc -> begin match kind_of_term u.up_f with | App(_,args) -> Array.length args | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be the number of arguments including the projected *) | _ -> assert false end | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) | _ -> -1 with Not_found -> -1 let isEvar_k k f = match kind_of_term f with Evar (k', _) -> k = k' | _ -> false let nb_args c = match kind_of_term c with App (_, a) -> Array.length a | _ -> 0 let mkSubArg i a = if i = Array.length a then a else Array.sub a 0 i let mkSubApp f i a = if i = 0 then f else mkApp (f, mkSubArg i a) let splay_app ise = let rec loop c a = match kind_of_term c with | App (f, a') -> loop f (Array.append a' a) | Cast (c', _, _) -> loop c' a | Evar ex -> (try loop (existential_value ise ex) a with _ -> c, a) | _ -> c, a in fun c -> match kind_of_term c with | App (f, a) -> loop f a | Cast _ | Evar _ -> loop c [| |] | _ -> c, [| |] let filter_upat i0 f n u fpats = let na = Array.length u.up_a in if n < na then fpats else let np = match u.up_k with | KpatConst when Term.eq_constr u.up_f f -> na | KpatFixed when Term.eq_constr u.up_f f -> na | KpatEvar k when isEvar_k k f -> na | KpatLet when isLetIn f -> na | KpatLam when isLambda f -> na | KpatRigid when isRigid f -> na | KpatFlex -> na | KpatProj pc -> let np = na + nb_cs_proj_args pc f u in if n < np then -1 else np | _ -> -1 in if np < na then fpats else let () = if !i0 < np then i0 := n in (u, np) :: fpats let eq_prim_proj c t = match kind_of_term t with | Proj(p,_) -> Constant.equal (Projection.constant p) c | _ -> false let filter_upat_FO i0 f n u fpats = let np = nb_args u.up_FO in if n < np then fpats else let ok = match u.up_k with | KpatConst -> Term.eq_constr u.up_f f | KpatFixed -> Term.eq_constr u.up_f f | KpatEvar k -> isEvar_k k f | KpatLet -> isLetIn f | KpatLam -> isLambda f | KpatRigid -> isRigid f | KpatProj pc -> Term.eq_constr f (mkConst pc) || eq_prim_proj pc f | KpatFlex -> i0 := n; true in if ok then begin if !i0 < np then i0 := np; (u, np) :: fpats end else fpats exception FoundUnif of (evar_map * evar_universe_context * tpattern) (* Note: we don't update env as we descend into the term, as the primitive *) (* unification procedure always rejects subterms with bound variables. *) let dont_impact_evars_in cl = let evs_in_cl = Evd.evars_of_term cl in fun sigma -> Evar.Set.for_all (fun k -> try let _ = Evd.find_undefined sigma k in true with Not_found -> false) evs_in_cl (* We are forced to duplicate code between the FO/HO matching because we *) (* have to work around several kludges in unify.ml: *) (* - w_unify drops into second-order unification when the pattern is an *) (* application whose head is a meta. *) (* - w_unify tries to unify types without subsumption when the pattern *) (* head is an evar or meta (e.g., it fails on ?1 = nat when ?1 : Type). *) (* - w_unify expands let-in (zeta conversion) eagerly, whereas we want to *) (* match a head let rigidly. *) let match_upats_FO upats env sigma0 ise orig_c = let dont_impact_evars = dont_impact_evars_in orig_c in let rec loop c = let f, a = splay_app ise c in let i0 = ref (-1) in let fpats = List.fold_right (filter_upat_FO i0 f (Array.length a)) upats [] in while !i0 >= 0 do let i = !i0 in i0 := -1; let c' = mkSubApp f i a in let one_match (u, np) = let skip = if i <= np then i < np else if u.up_k == KpatFlex then begin i0 := i - 1; false end else begin if !i0 < np then i0 := np; true end in if skip || not (closed0 c') then () else try let _ = match u.up_k with | KpatFlex -> let kludge v = mkLambda (Anonymous, mkProp, v) in unif_FO env ise (kludge u.up_FO) (kludge c') | KpatLet -> let kludge vla = let vl, a = safeDestApp vla in let x, v, t, b = destLetIn vl in mkApp (mkLambda (x, t, b), Array.cons v a) in unif_FO env ise (kludge u.up_FO) (kludge c') | _ -> unif_FO env ise u.up_FO c' in let ise' = (* Unify again using HO to assign evars *) let p = mkApp (u.up_f, u.up_a) in try unif_HO env ise p c' with _ -> raise NoMatch in let lhs = mkSubApp f i a in let pt' = unif_end env sigma0 ise' u.up_t (u.up_ok lhs) in raise (FoundUnif (ungen_upat lhs pt' u)) with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u | Not_found -> CErrors.anomaly (str"incomplete ise in match_upats_FO") | _ -> () in List.iter one_match fpats done; iter_constr_LR loop f; Array.iter loop a in try loop orig_c with Invalid_argument _ -> CErrors.anomaly (str"IN FO") let prof_FO = mk_profiler "match_upats_FO";; let match_upats_FO upats env sigma0 ise c = prof_FO.profile (match_upats_FO upats env sigma0) ise c ;; let match_upats_HO ~on_instance upats env sigma0 ise c = let dont_impact_evars = dont_impact_evars_in c in let it_did_match = ref false in let failed_because_of_TC = ref false in let rec aux upats env sigma0 ise c = let f, a = splay_app ise c in let i0 = ref (-1) in let fpats = List.fold_right (filter_upat i0 f (Array.length a)) upats [] in while !i0 >= 0 do let i = !i0 in i0 := -1; let one_match (u, np) = let skip = if i <= np then i < np else if u.up_k == KpatFlex then begin i0 := i - 1; false end else begin if !i0 < np then i0 := np; true end in if skip then () else try let ise' = match u.up_k with | KpatFixed | KpatConst -> ise | KpatEvar _ -> let _, pka = destEvar u.up_f and _, ka = destEvar f in unif_HO_args env ise pka 0 ka | KpatLet -> let x, v, t, b = destLetIn f in let _, pv, _, pb = destLetIn u.up_f in let ise' = unif_HO env ise pv v in unif_HO (Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env) ise' pb b | KpatFlex | KpatProj _ -> unif_HO env ise u.up_f (mkSubApp f (i - Array.length u.up_a) a) | _ -> unif_HO env ise u.up_f f in let ise'' = unif_HO_args env ise' u.up_a (i - Array.length u.up_a) a in let lhs = mkSubApp f i a in let pt' = unif_end env sigma0 ise'' u.up_t (u.up_ok lhs) in on_instance (ungen_upat lhs pt' u) with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u | NoProgress -> it_did_match := true | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsatisfiableConstraints _) -> failed_because_of_TC:=true | e when CErrors.noncritical e -> () in List.iter one_match fpats done; iter_constr_LR (aux upats env sigma0 ise) f; Array.iter (aux upats env sigma0 ise) a in aux upats env sigma0 ise c; if !it_did_match then raise NoProgress; !failed_because_of_TC let prof_HO = mk_profiler "match_upats_HO";; let match_upats_HO ~on_instance upats env sigma0 ise c = prof_HO.profile (match_upats_HO ~on_instance upats env sigma0) ise c ;; let fixed_upat = function | {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false | {up_t = t} -> not (occur_existential t) let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) let assert_done r = match !r with Some x -> x | None -> CErrors.anomaly (str"do_once never called") let assert_done_multires r = match !r with | None -> CErrors.anomaly (str"do_once never called") | Some (n, xs) -> r := Some (n+1,xs); try List.nth xs n with Failure _ -> raise NoMatch type subst = Environ.env -> Term.constr -> Term.constr -> int -> Term.constr type find_P = Environ.env -> Term.constr -> int -> k:subst -> Term.constr type conclude = unit -> Term.constr * ssrdir * (Evd.evar_map * Evd.evar_universe_context * Term.constr) (* upats_origin makes a better error message only *) let mk_tpattern_matcher ?(all_instances=false) ?(raise_NoMatch=false) ?upats_origin sigma0 occ (ise, upats) = let nocc = ref 0 and skip_occ = ref false in let use_occ, occ_list = match occ with | Some (true, ol) -> ol = [], ol | Some (false, ol) -> ol <> [], ol | None -> false, [] in let max_occ = List.fold_right max occ_list 0 in let subst_occ = let occ_set = Array.make max_occ (not use_occ) in let _ = List.iter (fun i -> occ_set.(i - 1) <- use_occ) occ_list in let _ = if max_occ = 0 then skip_occ := use_occ in fun () -> incr nocc; if !nocc = max_occ then skip_occ := use_occ; if !nocc <= max_occ then occ_set.(!nocc - 1) else not use_occ in let upat_that_matched = ref None in let match_EQ env sigma u = match u.up_k with | KpatLet -> let x, pv, t, pb = destLetIn u.up_f in let env' = Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env in let match_let f = match kind_of_term f with | LetIn (_, v, _, b) -> unif_EQ env sigma pv v && unif_EQ env' sigma pb b | _ -> false in match_let | KpatFixed -> Term.eq_constr u.up_f | KpatConst -> Term.eq_constr u.up_f | KpatLam -> fun c -> (match kind_of_term c with | Lambda _ -> unif_EQ env sigma u.up_f c | _ -> false) | _ -> unif_EQ env sigma u.up_f in let p2t p = mkApp(p.up_f,p.up_a) in let source () = match upats_origin, upats with | None, [p] -> (if fixed_upat p then str"term " else str"partial term ") ++ pr_constr_pat (p2t p) ++ spc() | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ pr_constr_pat rule ++ fnl() ++ ws 4 ++ pr_constr_pat (p2t p) ++ fnl() | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ pr_constr_pat rule ++ spc() | _, [] | None, _::_::_ -> CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin") in let on_instance, instances = let instances = ref [] in (fun x -> if all_instances then instances := !instances @ [x] else raise (FoundUnif x)), (fun () -> !instances) in let rec uniquize = function | [] -> [] | (sigma,_,{ up_f = f; up_a = a; up_t = t } as x) :: xs -> let t = Reductionops.nf_evar sigma t in let f = Reductionops.nf_evar sigma f in let a = Array.map (Reductionops.nf_evar sigma) a in let neq (sigma1,_,{ up_f = f1; up_a = a1; up_t = t1 }) = let t1 = Reductionops.nf_evar sigma1 t1 in let f1 = Reductionops.nf_evar sigma1 f1 in let a1 = Array.map (Reductionops.nf_evar sigma1) a1 in not (Term.eq_constr t t1 && Term.eq_constr f f1 && CArray.for_all2 Term.eq_constr a a1) in x :: uniquize (List.filter neq xs) in ((fun env c h ~k -> do_once upat_that_matched (fun () -> let failed_because_of_TC = ref false in try if not all_instances then match_upats_FO upats env sigma0 ise c; failed_because_of_TC:=match_upats_HO ~on_instance upats env sigma0 ise c; raise NoMatch with FoundUnif sigma_u -> 0,[sigma_u] | (NoMatch|NoProgress) when all_instances && instances () <> [] -> 0, uniquize (instances ()) | NoMatch when (not raise_NoMatch) -> if !failed_because_of_TC then errorstrm (source ()++strbrk"matches but type classes inference fails") else errorstrm (source () ++ str "does not match any subterm of the goal") | NoProgress when (not raise_NoMatch) -> let dir = match upats_origin with Some (d,_) -> d | _ -> CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin") in errorstrm (str"all matches of "++source()++ str"are equal to the " ++ pr_dir_side (inv_dir dir)) | NoProgress -> raise NoMatch); let sigma, _, ({up_f = pf; up_a = pa} as u) = if all_instances then assert_done_multires upat_that_matched else List.hd (snd(assert_done upat_that_matched)) in (* pp(lazy(str"sigma@tmatch=" ++ pr_evar_map None sigma)); *) if !skip_occ then ((*ignore(k env u.up_t 0);*) c) else let match_EQ = match_EQ env sigma u in let pn = Array.length pa in let rec subst_loop (env,h as acc) c' = if !skip_occ then c' else let f, a = splay_app sigma c' in if Array.length a >= pn && match_EQ f && unif_EQ_args env sigma pa a then let a1, a2 = Array.chop (Array.length pa) a in let fa1 = mkApp (f, a1) in let f' = if subst_occ () then k env u.up_t fa1 h else fa1 in mkApp (f', Array.map_left (subst_loop acc) a2) else (* TASSI: clear letin values to avoid unfolding *) let inc_h rd (env,h') = let ctx_item = match rd with | Context.Rel.Declaration.LocalAssum _ as x -> x | Context.Rel.Declaration.LocalDef (x,_,y) -> Context.Rel.Declaration.LocalAssum(x,y) in Environ.push_rel ctx_item env, h' + 1 in let f' = map_constr_with_binders_left_to_right inc_h subst_loop acc f in mkApp (f', Array.map_left (subst_loop acc) a) in subst_loop (env,h) c) : find_P), ((fun () -> let sigma, uc, ({up_f = pf; up_a = pa} as u) = match !upat_that_matched with | Some (_,x) -> List.hd x | None when raise_NoMatch -> raise NoMatch | None -> CErrors.anomaly (str"companion function never called") in let p' = mkApp (pf, pa) in if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t) else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++ str(String.plural !nocc " occurence") ++ match upats_origin with | None -> str" of" ++ spc() ++ pr_constr_pat p' | Some (dir,rule) -> str" of the " ++ pr_dir_side dir ++ fnl() ++ ws 4 ++ pr_constr_pat p' ++ fnl () ++ str"of " ++ pr_constr_pat rule)) : conclude) type ('ident, 'term) ssrpattern = | T of 'term | In_T of 'term | X_In_T of 'ident * 'term | In_X_In_T of 'ident * 'term | E_In_X_In_T of 'term * 'ident * 'term | E_As_X_In_T of 'term * 'ident * 'term let pr_pattern = function | T t -> prl_term t | In_T t -> str "in " ++ prl_term t | X_In_T (x,t) -> prl_term x ++ str " in " ++ prl_term t | In_X_In_T (x,t) -> str "in " ++ prl_term x ++ str " in " ++ prl_term t | E_In_X_In_T (e,x,t) -> prl_term e ++ str " in " ++ prl_term x ++ str " in " ++ prl_term t | E_As_X_In_T (e,x,t) -> prl_term e ++ str " as " ++ prl_term x ++ str " in " ++ prl_term t let pr_pattern_w_ids = function | T t -> prl_term t | In_T t -> str "in " ++ prl_term t | X_In_T (x,t) -> pr_id x ++ str " in " ++ prl_term t | In_X_In_T (x,t) -> str "in " ++ pr_id x ++ str " in " ++ prl_term t | E_In_X_In_T (e,x,t) -> prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_term t | E_As_X_In_T (e,x,t) -> prl_term e ++ str " as " ++ pr_id x ++ str " in " ++ prl_term t let pr_pattern_aux pr_constr = function | T t -> pr_constr t | In_T t -> str "in " ++ pr_constr t | X_In_T (x,t) -> pr_constr x ++ str " in " ++ pr_constr t | In_X_In_T (x,t) -> str "in " ++ pr_constr x ++ str " in " ++ pr_constr t | E_In_X_In_T (e,x,t) -> pr_constr e ++ str " in " ++ pr_constr x ++ str " in " ++ pr_constr t | E_As_X_In_T (e,x,t) -> pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t let pp_pattern (sigma, p) = pr_pattern_aux (fun t -> pr_constr_pat (pi3 (nf_open_term sigma sigma t))) p let pr_cpattern = pr_term let pr_rpattern _ _ _ = pr_pattern let pr_option f = function None -> mt() | Some x -> f x let pr_ssrpattern _ _ _ = pr_option pr_pattern let pr_pattern_squarep = pr_option (fun r -> str "[" ++ pr_pattern r ++ str "]") let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep let pr_pattern_roundp = pr_option (fun r -> str "(" ++ pr_pattern r ++ str ")") let pr_ssrpattern_roundp _ _ _ = pr_pattern_roundp let wit_rpatternty = add_genarg "rpatternty" pr_pattern let glob_ssrterm gs = function | k, (_, Some c) -> k, let x = Tacintern.intern_constr gs c in fst x, Some c | ct -> ct (* This piece of code asserts the following notations are reserved *) (* Reserved Notation "( a 'in' b )" (at level 0). *) (* Reserved Notation "( a 'as' b )" (at level 0). *) (* Reserved Notation "( a 'in' b 'in' c )" (at level 0). *) (* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *) let glob_cpattern gs p = pp(lazy(str"globbing pattern: " ++ pr_term p)); let glob x = snd (glob_ssrterm gs (mk_lterm x)) in let encode k s l = let name = Name (id_of_string ("_ssrpat_" ^ s)) in k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None) in let bind_in t1 t2 = let d = dummy_loc in let n = Name (destCVar t1) in fst (glob (mkCCast d (mkCHole d) (mkCLambda d n (mkCHole d) t2))) in let check_var t2 = if not (isCVar t2) then loc_error (constr_loc t2) "Only identifiers are allowed here" in match p with | _, (_, None) as x -> x | k, (v, Some t) as orig -> if k = 'x' then glob_ssrterm gs ('(', (v, Some t)) else match t with | CNotation(_, "( _ in _ )", ([t1; t2], [], [])) -> (try match glob t1, glob t2 with | (r1, None), (r2, None) -> encode k "In" [r1;r2] | (r1, Some _), (r2, Some _) when isCVar t1 -> encode k "In" [r1; r2; bind_in t1 t2] | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] | _ -> CErrors.anomaly (str"where are we?") with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) | CNotation(_, "( _ in _ in _ )", ([t1; t2; t3], [], [])) -> check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] | CNotation(_, "( _ as _ )", ([t1; t2], [], [])) -> encode k "As" [fst (glob t1); fst (glob t2)] | CNotation(_, "( _ as _ in _ )", ([t1; t2; t3], [], [])) -> check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] | _ -> glob_ssrterm gs orig ;; let glob_rpattern s p = match p with | T t -> T (glob_cpattern s t) | In_T t -> In_T (glob_ssrterm s t) | X_In_T(x,t) -> X_In_T (x,glob_ssrterm s t) | In_X_In_T(x,t) -> In_X_In_T (x,glob_ssrterm s t) | E_In_X_In_T(e,x,t) -> E_In_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) | E_As_X_In_T(e,x,t) -> E_As_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) let subst_ssrterm s (k, c) = k, Tacsubst.subst_glob_constr_and_expr s c let subst_rpattern s = function | T t -> T (subst_ssrterm s t) | In_T t -> In_T (subst_ssrterm s t) | X_In_T(x,t) -> X_In_T (x,subst_ssrterm s t) | In_X_In_T(x,t) -> In_X_In_T (x,subst_ssrterm s t) | E_In_X_In_T(e,x,t) -> E_In_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) | E_As_X_In_T(e,x,t) -> E_As_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) ARGUMENT EXTEND rpattern TYPED AS rpatternty PRINTED BY pr_rpattern GLOBALIZED BY glob_rpattern SUBSTITUTED BY subst_rpattern | [ lconstr(c) ] -> [ T (mk_lterm c) ] | [ "in" lconstr(c) ] -> [ In_T (mk_lterm c) ] | [ lconstr(x) "in" lconstr(c) ] -> [ X_In_T (mk_lterm x, mk_lterm c) ] | [ "in" lconstr(x) "in" lconstr(c) ] -> [ In_X_In_T (mk_lterm x, mk_lterm c) ] | [ lconstr(e) "in" lconstr(x) "in" lconstr(c) ] -> [ E_In_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ] | [ lconstr(e) "as" lconstr(x) "in" lconstr(c) ] -> [ E_As_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ] END type cpattern = char * glob_constr_and_expr let tag_of_cpattern = fst let loc_of_cpattern = loc_ofCG let cpattern_of_term t = t type occ = (bool * int list) option type rpattern = (cpattern, cpattern) ssrpattern let pr_rpattern = pr_pattern type pattern = Evd.evar_map * (Term.constr, Term.constr) ssrpattern let id_of_cpattern = function | _,(_,Some (CRef (Ident (_, x), _))) -> Some x | _,(_,Some (CAppExpl (_, (_, Ident (_, x), _), []))) -> Some x | _,(GRef (_, VarRef x, _) ,None) -> Some x | _ -> None let id_of_Cterm t = match id_of_cpattern t with | Some x -> x | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here" let of_ftactic ftac gl = let r = ref None in let tac = Ftactic.run ftac (fun ans -> r := Some ans; Proofview.tclUNIT ()) in let tac = Proofview.V82.of_tactic tac in let { sigma = sigma } = tac gl in let ans = match !r with | None -> assert false (** If the tactic failed we should not reach this point *) | Some ans -> ans in (sigma, ans) let interp_wit wit ist gl x = let globarg = in_gen (glbwit wit) x in let arg = interp_genarg ist globarg in let (sigma, arg) = of_ftactic arg gl in sigma, Value.cast (topwit wit) arg let interp_constr = interp_wit wit_constr let interp_open_constr ist gl gc = interp_wit wit_open_constr ist gl gc let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c let interp_term ist gl (_, c) = (interp_open_constr ist gl c) let pr_ssrterm _ _ _ = pr_term let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with | Tok.KEYWORD "(" -> '(' | Tok.KEYWORD "@" -> '@' | _ -> ' ' let ssrtermkind = Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind let interp_ssrterm _ gl t = Tacmach.project gl, t ARGUMENT EXTEND cpattern PRINTED BY pr_ssrterm INTERPRETED BY interp_ssrterm GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm RAW_PRINTED BY pr_ssrterm GLOB_PRINTED BY pr_ssrterm | [ "Qed" constr(c) ] -> [ mk_lterm c ] END let (!@) = Compat.to_coqloc GEXTEND Gram GLOBAL: cpattern; cpattern: [[ k = ssrtermkind; c = constr -> let pattern = mk_term k c in if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]]; END ARGUMENT EXTEND lcpattern TYPED AS cpattern PRINTED BY pr_ssrterm INTERPRETED BY interp_ssrterm GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm RAW_PRINTED BY pr_ssrterm GLOB_PRINTED BY pr_ssrterm | [ "Qed" lconstr(c) ] -> [ mk_lterm c ] END GEXTEND Gram GLOBAL: lcpattern; lcpattern: [[ k = ssrtermkind; c = lconstr -> let pattern = mk_term k c in if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]]; END let thin id sigma goal = let ids = Id.Set.singleton id in let env = Goal.V82.env sigma goal in let cl = Goal.V82.concl sigma goal in let evdref = ref (Evd.clear_metas sigma) in let ans = try Some (Evarutil.clear_hyps_in_evi env evdref (Environ.named_context_val env) cl ids) with Evarutil.ClearDependencyError _ -> None in match ans with | None -> sigma | Some (hyps, concl) -> let sigma = !evdref in let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in let sigma = Goal.V82.partial_solution_to sigma goal gl ev in sigma let pr_ist { lfun= lfun } = prlist_with_sep spc (fun (id, Geninterp.Val.Dyn(ty,_)) -> pr_id id ++ str":" ++ Geninterp.Val.pr ty) (Id.Map.bindings lfun) let interp_pattern ?wit_ssrpatternarg ist gl red redty = pp(lazy(str"interpreting: " ++ pr_pattern red)); pp(lazy(str" in ist: " ++ pr_ist ist)); let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in let eAsXInT e x t = E_As_X_In_T(e,x,t) in let mkG ?(k=' ') x = k,(x,None) in let decode ist t ?reccall f g = try match (pf_intern_term ist gl t) with | GCast(_,GHole _,CastConv(GLambda(_,Name x,_,_,c))) -> f x (' ',(c,None)) | GVar(_,id) when Id.Map.mem id ist.lfun && not(Option.is_empty reccall) && not(Option.is_empty wit_ssrpatternarg) -> let v = Id.Map.find id ist.lfun in Option.get reccall (Value.cast (topwit (Option.get wit_ssrpatternarg)) v) | it -> g t with e when CErrors.noncritical e -> g t in let decodeG t f g = decode ist (mkG t) f g in let bad_enc id _ = CErrors.anomaly (str"bad encoding for pattern "++str id) in let cleanup_XinE h x rp sigma = let h_k = match kind_of_term h with Evar (k,_) -> k | _ -> assert false in let to_clean, update = (* handle rename if x is already used *) let ctx = pf_hyps gl in let len = Context.Named.length ctx in let name = ref None in try ignore(Context.Named.lookup x ctx); (name, fun k -> if !name = None then let nctx = Evd.evar_context (Evd.find sigma k) in let nlen = Context.Named.length nctx in if nlen > len then begin name := Some (Context.Named.Declaration.get_id (List.nth nctx (nlen - len - 1))) end) with Not_found -> ref (Some x), fun _ -> () in let sigma0 = project gl in let new_evars = let rec aux acc t = match kind_of_term t with | Evar (k,_) -> if k = h_k || List.mem k acc || Evd.mem sigma0 k then acc else (update k; k::acc) | _ -> fold_constr aux acc t in aux [] (Evarutil.nf_evar sigma rp) in let sigma = List.fold_left (fun sigma e -> if Evd.is_defined sigma e then sigma else (* clear may be recursive *) if Option.is_empty !to_clean then sigma else let name = Option.get !to_clean in pp(lazy(pr_id name)); thin name sigma e) sigma new_evars in sigma in let red = let rec decode_red (ist,red) = match red with | T(k,(GCast (_,GHole _,(CastConv(GLambda (_,Name id,_,_,t)))),None)) when let id = string_of_id id in let len = String.length id in (len > 8 && String.sub id 0 8 = "_ssrpat_") -> let id = string_of_id id in let len = String.length id in (match String.sub id 8 (len - 8), t with | "In", GApp(_, _, [t]) -> decodeG t xInT (fun x -> T x) | "In", GApp(_, _, [e; t]) -> decodeG t (eInXInT (mkG e)) (bad_enc id) | "In", GApp(_, _, [e; t; e_in_t]) -> decodeG t (eInXInT (mkG e)) (fun _ -> decodeG e_in_t xInT (fun _ -> assert false)) | "As", GApp(_, _, [e; t]) -> decodeG t (eAsXInT (mkG e)) (bad_enc id) | _ -> bad_enc id ()) | T t -> decode ist ~reccall:decode_red t xInT (fun x -> T x) | In_T t -> decode ist t inXInT inT | X_In_T (e,t) -> decode ist t (eInXInT e) (fun x -> xInT (id_of_Cterm e) x) | In_X_In_T (e,t) -> inXInT (id_of_Cterm e) t | E_In_X_In_T (e,x,rp) -> eInXInT e (id_of_Cterm x) rp | E_As_X_In_T (e,x,rp) -> eAsXInT e (id_of_Cterm x) rp in decode_red (ist,red) in pp(lazy(str"decoded as: " ++ pr_pattern_w_ids red)); let red = match redty with None -> red | Some ty -> let ty = ' ', ty in match red with | T t -> T (combineCG t ty (mkCCast (loc_ofCG t)) mkRCast) | X_In_T (x,t) -> let ty = pf_intern_term ist gl ty in E_As_X_In_T (mkG (mkRCast mkRHole ty), x, t) | E_In_X_In_T (e,x,t) -> let ty = mkG (pf_intern_term ist gl ty) in E_In_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t) | E_As_X_In_T (e,x,t) -> let ty = mkG (pf_intern_term ist gl ty) in E_As_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t) | red -> red in pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); let mkXLetIn loc x (a,(g,c)) = match c with | Some b -> a,(g,Some (mkCLetIn loc x (mkCHole loc) b)) | None -> a,(GLetIn (loc,x,(GHole (loc, BinderType x, IntroAnonymous, None)), g), None) in match red with | T t -> let sigma, t = interp_term ist gl t in sigma, T t | In_T t -> let sigma, t = interp_term ist gl t in sigma, In_T t | X_In_T (x, rp) | In_X_In_T (x, rp) -> let mk x p = match red with X_In_T _ -> X_In_T(x,p) | _ -> In_X_In_T(x,p) in let rp = mkXLetIn dummy_loc (Name x) rp in let sigma, rp = interp_term ist gl rp in let _, h, _, rp = destLetIn rp in let sigma = cleanup_XinE h x rp sigma in let rp = subst1 h (Evarutil.nf_evar sigma rp) in sigma, mk h rp | E_In_X_In_T(e, x, rp) | E_As_X_In_T (e, x, rp) -> let mk e x p = match red with E_In_X_In_T _ ->E_In_X_In_T(e,x,p)|_->E_As_X_In_T(e,x,p) in let rp = mkXLetIn dummy_loc (Name x) rp in let sigma, rp = interp_term ist gl rp in let _, h, _, rp = destLetIn rp in let sigma = cleanup_XinE h x rp sigma in let rp = subst1 h (Evarutil.nf_evar sigma rp) in let sigma, e = interp_term ist (re_sig (sig_it gl) sigma) e in sigma, mk e h rp ;; let interp_cpattern ist gl red redty = interp_pattern ist gl (T red) redty;; let interp_rpattern ~wit_ssrpatternarg ist gl red = interp_pattern ~wit_ssrpatternarg ist gl red None;; let id_of_pattern = function | _, T t -> (match kind_of_term t with Var id -> Some id | _ -> None) | _ -> None (* The full occurrence set *) let noindex = Some(false,[]) (* calls do_subst on every sub-term identified by (pattern,occ) *) let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let fs sigma x = Reductionops.nf_evar sigma x in let pop_evar sigma e p = let { Evd.evar_body = e_body } as e_def = Evd.find sigma e in let e_body = match e_body with Evar_defined c -> c | _ -> errorstrm (str "Matching the pattern " ++ pr_constr p ++ str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++ str "Does the variable bound by the \"in\" construct occur "++ str "in the pattern?") in let sigma = Evd.add (Evd.remove sigma e) e {e_def with Evd.evar_body = Evar_empty} in sigma, e_body in let ex_value hole = match kind_of_term hole with Evar (e,_) -> e | _ -> assert false in let mk_upat_for ?hack env sigma0 (sigma, t) ?(p=t) ok = let sigma,pat= mk_tpattern ?hack env sigma0 (sigma,p) ok L2R (fs sigma t) in sigma, [pat] in match pattern with | None -> do_subst env0 concl0 concl0 1 | Some (sigma, (T rp | In_T rp)) -> let rp = fs sigma rp in let ise = create_evar_defs sigma in let occ = match pattern with Some (_, T _) -> occ | _ -> noindex in let rp = mk_upat_for env0 sigma0 (ise, rp) all_ok in let find_T, end_T = mk_tpattern_matcher ?raise_NoMatch sigma0 occ rp in let concl = find_T env0 concl0 1 do_subst in let _ = end_T () in concl | Some (sigma, (X_In_T (hole, p) | In_X_In_T (hole, p))) -> let p = fs sigma p in let occ = match pattern with Some (_, X_In_T _) -> occ | _ -> noindex in let ex = ex_value hole in let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in (* we start from sigma, so hole is considered a rigid head *) let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in let find_X, end_X = mk_tpattern_matcher ?raise_NoMatch sigma occ holep in let concl = find_T env0 concl0 1 (fun env c _ h -> let p_sigma = unify_HO env (create_evar_defs sigma) c p in let sigma, e_body = pop_evar p_sigma ex p in fs p_sigma (find_X env (fs sigma p) h (fun env _ -> do_subst env e_body))) in let _ = end_X () in let _ = end_T () in concl | Some (sigma, E_In_X_In_T (e, hole, p)) -> let p, e = fs sigma p, fs sigma e in let ex = ex_value hole in let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in let find_X, end_X = mk_tpattern_matcher sigma noindex holep in let re = mk_upat_for env0 sigma0 (sigma, e) all_ok in let find_E, end_E = mk_tpattern_matcher ?raise_NoMatch sigma0 occ re in let concl = find_T env0 concl0 1 (fun env c _ h -> let p_sigma = unify_HO env (create_evar_defs sigma) c p in let sigma, e_body = pop_evar p_sigma ex p in fs p_sigma (find_X env (fs sigma p) h (fun env c _ h -> find_E env e_body h do_subst))) in let _ = end_E () in let _ = end_X () in let _ = end_T () in concl | Some (sigma, E_As_X_In_T (e, hole, p)) -> let p, e = fs sigma p, fs sigma e in let ex = ex_value hole in let rp = let e_sigma = unify_HO env0 sigma hole e in e_sigma, fs e_sigma p in let rp = mk_upat_for ~hack:true env0 sigma0 rp all_ok in let find_TE, end_TE = mk_tpattern_matcher sigma0 noindex rp in let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in let find_X, end_X = mk_tpattern_matcher sigma occ holep in let concl = find_TE env0 concl0 1 (fun env c _ h -> let p_sigma = unify_HO env (create_evar_defs sigma) c p in let sigma, e_body = pop_evar p_sigma ex p in fs p_sigma (find_X env (fs sigma p) h (fun env c _ h -> let e_sigma = unify_HO env sigma e_body e in let e_body = fs e_sigma e in do_subst env e_body e_body h))) in let _ = end_X () in let _ = end_TE () in concl ;; let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) = let e = match p with | In_T _ | In_X_In_T _ -> CErrors.anomaly (str"pattern without redex") | T e | X_In_T (e, _) | E_As_X_In_T (e, _, _) | E_In_X_In_T (e, _, _) -> e in let sigma = if not resolve_typeclasses then sigma else Typeclasses.resolve_typeclasses ~fail:false env sigma in Reductionops.nf_evar sigma e, Evd.evar_universe_context sigma let fill_occ_pattern ?raise_NoMatch env sigma cl pat occ h = let do_make_rel, occ = if occ = Some(true,[]) then false, Some(false,[1]) else true, occ in let find_R, conclude = let r = ref None in (fun env c _ h' -> do_once r (fun () -> c, Evd.empty_evar_universe_context); if do_make_rel then mkRel (h'+h-1) else c), (fun _ -> if !r = None then redex_of_pattern env pat else assert_done r) in let cl = eval_pattern ?raise_NoMatch env sigma cl (Some pat) occ find_R in let e = conclude cl in e, cl ;; (* clenup interface for external use *) let mk_tpattern ?p_origin env sigma0 sigma_t f dir c = mk_tpattern ?p_origin env sigma0 sigma_t f dir c ;; let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h = let ise = create_evar_defs sigma in let ise, u = mk_tpattern env sigma0 (ise,t) ok L2R p in let find_U, end_U = mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in let concl = find_U env concl h (fun _ _ _ -> mkRel) in let rdx, _, (sigma, uc, p) = end_U () in sigma, uc, p, concl, rdx let fill_occ_term env cl occ sigma0 (sigma, t) = try let sigma',uc,t',cl,_= pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in if sigma' != sigma0 then CErrors.error "matching impacts evars" else cl, (Evd.merge_universe_context sigma' uc, t') with NoMatch -> try let sigma', uc, t' = unif_end env sigma0 (create_evar_defs sigma) t (fun _ -> true) in if sigma' != sigma0 then raise NoMatch else cl, (Evd.merge_universe_context sigma' uc, t') with _ -> errorstrm (str "partial term " ++ pr_constr_pat t ++ str " does not match any subterm of the goal") let pf_fill_occ_term gl occ t = let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in let cl,(_,t) = fill_occ_term env concl occ sigma0 t in cl, t let cpattern_of_id id = ' ', (GRef (dummy_loc, VarRef id, None), None) let is_wildcard = function | _,(_,Some (CHole _)|GHole _,None) -> true | _ -> false (* "ssrpattern" *) let pr_ssrpatternarg _ _ _ (_,cpat) = pr_rpattern cpat let pr_ssrpatternarg_glob _ _ _ cpat = pr_rpattern cpat let interp_ssrpatternarg ist gl p = project gl, (ist, p) ARGUMENT EXTEND ssrpatternarg PRINTED BY pr_ssrpatternarg INTERPRETED BY interp_ssrpatternarg GLOBALIZED BY glob_rpattern RAW_PRINTED BY pr_ssrpatternarg_glob GLOB_PRINTED BY pr_ssrpatternarg_glob | [ rpattern(pat) ] -> [ pat ] END let pf_merge_uc uc gl = re_sig (sig_it gl) (Evd.merge_universe_context (project gl) uc) let pf_unsafe_merge_uc uc gl = re_sig (sig_it gl) (Evd.set_universe_context (project gl) uc) let interp_rpattern ist gl red = interp_rpattern ~wit_ssrpatternarg ist gl red let ssrpatterntac _ist (arg_ist,arg) gl = let pat = interp_rpattern arg_ist gl arg in let sigma0 = project gl in let concl0 = pf_concl gl in let (t, uc), concl_x = fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in let gl, tty = pf_type_of gl t in let concl = mkLetIn (Name (id_of_string "selected"), t, tty, concl_x) in Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl (* Register "ssrpattern" tactic *) let () = let mltac _ ist = let arg = let v = Id.Map.find (Names.Id.of_string "pattern") ist.lfun in Value.cast (topwit wit_ssrpatternarg) v in Proofview.V82.tactic (ssrpatterntac ist arg) in let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in let () = Tacenv.register_ml_tactic name [|mltac|] in let tac = TacFun ([Some (Id.of_string "pattern")], TacML (Loc.ghost, { mltac_name = name; mltac_index = 0 }, [])) in let obj () = Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in Mltop.declare_cache_obj obj "ssrmatching_plugin" let ssrinstancesof ist arg gl = let ok rhs lhs ise = true in (* not (Term.eq_constr lhs (Evarutil.nf_evar ise rhs)) in *) let env, sigma, concl = pf_env gl, project gl, pf_concl gl in let sigma0, cpat = interp_cpattern ist gl arg None in let pat = match cpat with T x -> x | _ -> errorstrm (str"Not supported") in let etpat, tpat = mk_tpattern env sigma (sigma0,pat) (ok pat) L2R pat in let find, conclude = mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true sigma None (etpat,[tpat]) in let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr c)); c in ppnl (str"BEGIN INSTANCES"); try while true do ignore(find env concl 1 ~k:print) done; raise NoMatch with NoMatch -> ppnl (str"END INSTANCES"); tclIDTAC gl TACTIC EXTEND ssrinstoftpat | [ "ssrinstancesoftpat" cpattern(arg) ] -> [ Proofview.V82.tactic (ssrinstancesof ist arg) ] END (* We wipe out all the keywords generated by the grammar rules we defined. *) (* The user is supposed to Require Import ssreflect or Require ssreflect *) (* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) (* consequence the extended ssreflect grammar. *) let () = CLexer.unfreeze frozen_lexer ;; (* vim: set filetype=ocaml foldmethod=marker: *) coq-8.6/plugins/ssrmatching/ssrmatching.mli0000644000175000017500000002350513022274260020514 0ustar mdenesmdenes(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) open Genarg open Tacexpr open Environ open Tacmach open Evd open Proof_type open Term (** ******** Small Scale Reflection pattern matching facilities ************* *) (** Pattern parsing *) (** The type of context patterns, the patterns of the [set] tactic and [:] tactical. These are patterns that identify a precise subterm. *) type cpattern val pr_cpattern : cpattern -> Pp.std_ppcmds (** CS cpattern: (f _), (X in t), (t in X in t), (t as X in t) *) val cpattern : cpattern Pcoq.Gram.entry val wit_cpattern : cpattern uniform_genarg_type (** OS cpattern: f _, (X in t), (t in X in t), (t as X in t) *) val lcpattern : cpattern Pcoq.Gram.entry val wit_lcpattern : cpattern uniform_genarg_type (** The type of rewrite patterns, the patterns of the [rewrite] tactic. These patterns also include patterns that identify all the subterms of a context (i.e. "in" prefix) *) type rpattern val pr_rpattern : rpattern -> Pp.std_ppcmds (** OS rpattern: f _, in t, X in t, in X in t, t in X in t, t as X in t *) val rpattern : rpattern Pcoq.Gram.entry val wit_rpattern : rpattern uniform_genarg_type (** Pattern interpretation and matching *) exception NoMatch exception NoProgress (** AST for [rpattern] (and consequently [cpattern]) *) type ('ident, 'term) ssrpattern = | T of 'term | In_T of 'term | X_In_T of 'ident * 'term | In_X_In_T of 'ident * 'term | E_In_X_In_T of 'term * 'ident * 'term | E_As_X_In_T of 'term * 'ident * 'term type pattern = evar_map * (constr, constr) ssrpattern val pp_pattern : pattern -> Pp.std_ppcmds (** Extracts the redex and applies to it the substitution part of the pattern. @raise Anomaly if called on [In_T] or [In_X_In_T] *) val redex_of_pattern : ?resolve_typeclasses:bool -> env -> pattern -> constr Evd.in_evar_universe_context (** [interp_rpattern ise gl rpat] "internalizes" and "interprets" [rpat] in the current [Ltac] interpretation signature [ise] and tactic input [gl]*) val interp_rpattern : Tacinterp.interp_sign -> goal sigma -> rpattern -> pattern (** [interp_cpattern ise gl cpat ty] "internalizes" and "interprets" [cpat] in the current [Ltac] interpretation signature [ise] and tactic input [gl]. [ty] is an optional type for the redex of [cpat] *) val interp_cpattern : Tacinterp.interp_sign -> goal sigma -> cpattern -> glob_constr_and_expr option -> pattern (** The set of occurrences to be matched. The boolean is set to true * to signal the complement of this set (i.e. {-1 3}) *) type occ = (bool * int list) option (** [subst e p t i]. [i] is the number of binders traversed so far, [p] the term from the pattern, [t] the matched one *) type subst = env -> constr -> constr -> int -> constr (** [eval_pattern b env sigma t pat occ subst] maps [t] calling [subst] on every [occ] occurrence of [pat]. The [int] argument is the number of binders traversed. If [pat] is [None] then then subst is called on [t]. [t] must live in [env] and [sigma], [pat] must have been interpreted in (an extension of) [sigma]. @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) @return [t] where all [occ] occurrences of [pat] have been mapped using [subst] *) val eval_pattern : ?raise_NoMatch:bool -> env -> evar_map -> constr -> pattern option -> occ -> subst -> constr (** [fill_occ_pattern b env sigma t pat occ h] is a simplified version of [eval_pattern]. It replaces all [occ] occurrences of [pat] in [t] with Rel [h]. [t] must live in [env] and [sigma], [pat] must have been interpreted in (an extension of) [sigma]. @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) @return the instance of the redex of [pat] that was matched and [t] transformed as described above. *) val fill_occ_pattern : ?raise_NoMatch:bool -> env -> evar_map -> constr -> pattern -> occ -> int -> constr Evd.in_evar_universe_context * constr (** *************************** Low level APIs ****************************** *) (* The primitive matching facility. It matches of a term with holes, like the T pattern above, and calls a continuation on its occurrences. *) type ssrdir = L2R | R2L val pr_dir_side : ssrdir -> Pp.std_ppcmds (** a pattern for a term with wildcards *) type tpattern (** [mk_tpattern env sigma0 sigma_p ok p_origin dir t] compiles a term [t] living in [env] [sigma] (an extension of [sigma0]) intro a [tpattern]. The [tpattern] can hold a (proof) term [p] and a diction [dir]. The [ok] callback is used to filter occurrences. @return the compiled [tpattern] and its [evar_map] @raise UserEerror is the pattern is a wildcard *) val mk_tpattern : ?p_origin:ssrdir * constr -> env -> evar_map -> evar_map * constr -> (constr -> evar_map -> bool) -> ssrdir -> constr -> evar_map * tpattern (** [findP env t i k] is a stateful function that finds the next occurrence of a tpattern and calls the callback [k] to map the subterm matched. The [int] argument passed to [k] is the number of binders traversed so far plus the initial value [i]. @return [t] where the subterms identified by the selected occurrences of the patter have been mapped using [k] @raise NoMatch if the raise_NoMatch flag given to [mk_tpattern_matcher] is [true] and if the pattern did not match @raise UserEerror if the raise_NoMatch flag given to [mk_tpattern_matcher] is [false] and if the pattern did not match *) type find_P = env -> constr -> int -> k:subst -> constr (** [conclude ()] asserts that all mentioned ocurrences have been visited. @return the instance of the pattern, the evarmap after the pattern instantiation, the proof term and the ssrdit stored in the tpattern @raise UserEerror if too many occurrences were specified *) type conclude = unit -> constr * ssrdir * (evar_map * Evd.evar_universe_context * constr) (** [mk_tpattern_matcher b o sigma0 occ sigma_tplist] creates a pair a function [find_P] and [conclude] with the behaviour explained above. The flag [b] (default [false]) changes the error reporting behaviour of [find_P] if none of the [tpattern] matches. The argument [o] can be passed to tune the [UserError] eventually raised (useful if the pattern is coming from the LHS/RHS of an equation) *) val mk_tpattern_matcher : ?all_instances:bool -> ?raise_NoMatch:bool -> ?upats_origin:ssrdir * constr -> evar_map -> occ -> evar_map * tpattern list -> find_P * conclude (** Example of [mk_tpattern_matcher] to implement [rewrite \{occ\}\[in t\]rules]. It first matches "in t" (called [pat]), then in all matched subterms it matches the LHS of the rules using [find_R]. [concl0] is the initial goal, [concl] will be the goal where some terms are replaced by a De Bruijn index. The [rw_progress] extra check selects only occurrences that are not rewritten to themselves (e.g. an occurrence "x + x" rewritten with the commutativity law of addition is skipped) {[ let find_R, conclude = match pat with | Some (_, In_T _) -> let aux (sigma, pats) (d, r, lhs, rhs) = let sigma, pat = mk_tpattern env0 sigma0 (sigma, r) (rw_progress rhs) d lhs in sigma, pats @ [pat] in let rpats = List.fold_left aux (r_sigma, []) rules in let find_R, end_R = mk_tpattern_matcher sigma0 occ rpats in find_R ~k:(fun _ _ h -> mkRel h), fun cl -> let rdx, d, r = end_R () in (d,r),rdx | _ -> ... in let concl = eval_pattern env0 sigma0 concl0 pat occ find_R in let (d, r), rdx = conclude concl in ]} *) (* convenience shortcut: [pf_fill_occ_term gl occ (sigma,t)] returns * the conclusion of [gl] where [occ] occurrences of [t] have been replaced * by [Rel 1] and the instance of [t] *) val pf_fill_occ_term : goal sigma -> occ -> evar_map * constr -> constr * constr (* It may be handy to inject a simple term into the first form of cpattern *) val cpattern_of_term : char * glob_constr_and_expr -> cpattern (** Helpers to make stateful closures. Example: a [find_P] function may be called many times, but the pattern instantiation phase is performed only the first time. The corresponding [conclude] has to return the instantiated pattern redex. Since it is up to [find_P] to raise [NoMatch] if the pattern has no instance, [conclude] considers it an anomaly if the pattern did not match *) (** [do_once r f] calls [f] and updates the ref only once *) val do_once : 'a option ref -> (unit -> 'a) -> unit (** [assert_done r] return the content of r. @raise Anomaly is r is [None] *) val assert_done : 'a option ref -> 'a (** Very low level APIs. these are calls to evarconv's [the_conv_x] followed by [solve_unif_constraints_with_heuristics] and [resolve_typeclasses]. In case of failure they raise [NoMatch] *) val unify_HO : env -> evar_map -> constr -> constr -> evar_map val pf_unify_HO : goal sigma -> constr -> constr -> goal sigma (** Some more low level functions needed to implement the full SSR language on top of the former APIs *) val tag_of_cpattern : cpattern -> char val loc_of_cpattern : cpattern -> Loc.t val id_of_pattern : pattern -> Names.variable option val is_wildcard : cpattern -> bool val cpattern_of_id : Names.variable -> cpattern val cpattern_of_id : Names.variable -> cpattern val pr_constr_pat : constr -> Pp.std_ppcmds val pf_merge_uc : Evd.evar_universe_context -> goal Evd.sigma -> goal Evd.sigma val pf_unsafe_merge_uc : Evd.evar_universe_context -> goal Evd.sigma -> goal Evd.sigma (* One can also "Set SsrMatchingDebug" from a .v *) val debug : bool -> unit (* One should delimit a snippet with "Set SsrMatchingProfiling" and * "Unset SsrMatchingProfiling" to get timings *) val profile : bool -> unit (* eof *) coq-8.6/plugins/ssrmatching/ssrmatching_plugin.mlpack0000644000175000017500000000001413022274260022546 0ustar mdenesmdenesSsrmatching coq-8.6/plugins/ssrmatching/ssrmatching.v0000644000175000017500000000205513022274260020175 0ustar mdenesmdenes(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) (* Distributed under the terms of CeCILL-B. *) Declare ML Module "ssrmatching_plugin". Module SsrMatchingSyntax. (* Reserve the notation for rewrite patterns so that the user is not allowed *) (* to declare it at a different level. *) Reserved Notation "( a 'in' b )" (at level 0). Reserved Notation "( a 'as' b )" (at level 0). Reserved Notation "( a 'in' b 'in' c )" (at level 0). Reserved Notation "( a 'as' b 'in' c )" (at level 0). (* Notation to define shortcuts for the "X in t" part of a pattern. *) Notation "( X 'in' t )" := (_ : fun X => t) : ssrpatternscope. Delimit Scope ssrpatternscope with pattern. (* Some shortcuts for recurrent "X in t" parts. *) Notation RHS := (X in _ = X)%pattern. Notation LHS := (X in X = _)%pattern. End SsrMatchingSyntax. Export SsrMatchingSyntax. Tactic Notation "ssrpattern" ssrpatternarg(p) := ssrpattern p . coq-8.6/plugins/ssrmatching/vo.itarget0000644000175000017500000000001713022274260017465 0ustar mdenesmdenesssrmatching.vo coq-8.6/plugins/derive/0000755000175000017500000000000013022274260014416 5ustar mdenesmdenescoq-8.6/plugins/derive/derive.mli0000644000175000017500000000151513022274260016401 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Constrexpr.constr_expr -> Names.Id.t -> unit coq-8.6/plugins/derive/g_derive.ml40000644000175000017500000000162413022274260016623 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ Derive.start_deriving f suchthat lemma ] END coq-8.6/plugins/derive/derive.ml0000644000175000017500000001137413022274260016234 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Term.constr) (x:Safe_typing.private_constants Entries.const_entry_body) : Safe_typing.private_constants Entries.const_entry_body = Future.chain ~pure:true x begin fun ((b,ctx),fx) -> (f b , ctx) , fx end (** [start_deriving f suchthat lemma] starts a proof of [suchthat] (which can contain references to [f]) in the context extended by [f:=?x]. When the proof ends, [f] is defined as the value of [?x] and [lemma] as the proof. *) let start_deriving f suchthat lemma = let env = Global.env () in let sigma = Evd.from_env env in let kind = Decl_kinds.(Global,false,DefinitionBody Definition) in (** create a sort variable for the type of [f] *) (* spiwack: I don't know what the rigidity flag does, picked the one that looked the most general. *) let (sigma,f_type_sort) = Evd.new_sort_variable Evd.univ_flexible_alg sigma in let f_type_type = Term.mkSort f_type_sort in (** create the initial goals for the proof: |- Type ; |- ?1 ; f:=?2 |- suchthat *) let goals = let open Proofview in TCons ( env , sigma , f_type_type , (fun sigma f_type -> TCons ( env , sigma , f_type , (fun sigma ef -> let env' = Environ.push_named (LocalDef (f, ef, f_type)) env in let evdref = ref sigma in let suchthat = Constrintern.interp_type_evars env' evdref suchthat in TCons ( env' , !evdref , suchthat , (fun sigma _ -> TNil sigma)))))) in (** The terminator handles the registering of constants when the proof is closed. *) let terminator com = let open Proof_global in (** Extracts the relevant information from the proof. [Admitted] and [Save] result in user errors. [opaque] is [true] if the proof was concluded by [Qed], and [false] if [Defined]. [f_def] and [lemma_def] correspond to the proof of [f] and of [suchthat], respectively. *) let (opaque,f_def,lemma_def) = match com with | Admitted _ -> CErrors.error"Admitted isn't supported in Derive." | Proved (_,Some _,_) -> CErrors.error"Cannot save a proof of Derive with an explicit name." | Proved (opaque, None, obj) -> match Proof_global.(obj.entries) with | [_;f_def;lemma_def] -> opaque <> Vernacexpr.Transparent , f_def , lemma_def | _ -> assert false in (** The opacity of [f_def] is adjusted to be [false], as it must. Then [f] is declared in the global environment. *) let f_def = { f_def with Entries.const_entry_opaque = false } in let f_def = Entries.DefinitionEntry f_def , Decl_kinds.(IsDefinition Definition) in let f_kn = Declare.declare_constant f f_def in let f_kn_term = Term.mkConst f_kn in (** In the type and body of the proof of [suchthat] there can be references to the variable [f]. It needs to be replaced by references to the constant [f] declared above. This substitution performs this precise action. *) let substf c = Vars.replace_vars [f,f_kn_term] c in (** Extracts the type of the proof of [suchthat]. *) let lemma_pretype = match Entries.(lemma_def.const_entry_type) with | Some t -> t | None -> assert false (* Proof_global always sets type here. *) in (** The references of [f] are subsituted appropriately. *) let lemma_type = substf lemma_pretype in (** The same is done in the body of the proof. *) let lemma_body = map_const_entry_body substf Entries.(lemma_def.const_entry_body) in let lemma_def = let open Entries in { lemma_def with const_entry_body = lemma_body ; const_entry_type = Some lemma_type ; const_entry_opaque = opaque ; } in let lemma_def = Entries.DefinitionEntry lemma_def , Decl_kinds.(IsProof Proposition) in ignore (Declare.declare_constant lemma lemma_def) in let terminator = Proof_global.make_terminator terminator in let () = Proof_global.start_dependent_proof lemma kind goals terminator in let _ = Proof_global.with_current_proof begin fun _ p -> Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p end in () coq-8.6/plugins/derive/vo.itarget0000644000175000017500000000001113022274260016413 0ustar mdenesmdenesDerive.vocoq-8.6/plugins/derive/Derive.v0000644000175000017500000000004213022274260016017 0ustar mdenesmdenesDeclare ML Module "derive_plugin".coq-8.6/plugins/derive/derive_plugin.mlpack0000644000175000017500000000002013022274260020433 0ustar mdenesmdenesDerive G_derive coq-8.6/plugins/decl_mode/0000755000175000017500000000000013022274260015053 5ustar mdenesmdenescoq-8.6/plugins/decl_mode/ppdecl_proof.mli0000644000175000017500000000065413022274260020237 0ustar mdenesmdenes open Decl_expr open Pptactic val pr_gen_proof_instr : ('var -> Pp.std_ppcmds) -> ('constr -> Pp.std_ppcmds) -> ('pat -> Pp.std_ppcmds) -> ('tac -> Pp.std_ppcmds) -> ('var,'constr,'pat,'tac) gen_proof_instr -> Pp.std_ppcmds val pr_raw_proof_instr : raw_proof_instr raw_extra_genarg_printer val pr_glob_proof_instr : glob_proof_instr glob_extra_genarg_printer val pr_proof_instr : proof_instr extra_genarg_printer coq-8.6/plugins/decl_mode/ppdecl_proof.ml0000644000175000017500000001627613022274260020075 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mt () | Name id -> pr_id id ++ spc () ++ str ":" ++ spc () let pr_justification_items pr_constr = function Some [] -> mt () | Some (_::_ as l) -> spc () ++ str "by" ++ spc () ++ prlist_with_sep (fun () -> str ",") pr_constr l | None -> spc () ++ str "by *" let pr_justification_method pr_tac = function None -> mt () | Some tac -> spc () ++ str "using" ++ spc () ++ pr_tac tac let pr_statement pr_constr st = pr_label st.st_label ++ pr_constr st.st_it let pr_or_thesis pr_this = function Thesis Plain -> str "thesis" | Thesis (For id) -> str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id | This c -> pr_this c let pr_cut pr_constr pr_tac pr_it c = hov 1 (pr_it c.cut_stat) ++ pr_justification_items pr_constr c.cut_by ++ pr_justification_method pr_tac c.cut_using let type_or_thesis = function Thesis _ -> Term.mkProp | This c -> c let _I x = x let rec pr_hyps pr_var pr_constr gtyp sep _be _have hyps = let pr_sep = if sep then str "and" ++ spc () else mt () in match hyps with (Hvar _ ::_) as rest -> spc () ++ pr_sep ++ str _have ++ pr_vars pr_var pr_constr gtyp false _be _have rest | Hprop st :: rest -> begin (* let npr_constr env = pr_constr (Environ.push_named (id,None,gtyp st.st_it) env)*) spc() ++ pr_sep ++ pr_statement pr_constr st ++ pr_hyps pr_var pr_constr gtyp true _be _have rest end | [] -> mt () and pr_vars pr_var pr_constr gtyp sep _be _have vars = match vars with Hvar st :: rest -> begin (* let npr_constr env = pr_constr (Environ.push_named (id,None,gtyp st.st_it) env)*) let pr_sep = if sep then pr_comma () else mt () in spc() ++ pr_sep ++ pr_var st ++ pr_vars pr_var pr_constr gtyp true _be _have rest end | (Hprop _ :: _) as rest -> let _st = if _be then str "be such that" else str "such that" in spc() ++ _st ++ pr_hyps pr_var pr_constr gtyp false _be _have rest | [] -> mt () let pr_suffices_clause pr_var pr_constr (hyps,c) = pr_hyps pr_var pr_constr _I false false "to have" hyps ++ spc () ++ str "to show" ++ spc () ++ pr_or_thesis pr_constr c let pr_elim_type = function ET_Case_analysis -> str "cases" | ET_Induction -> str "induction" let pr_block_type = function B_elim et -> pr_elim_type et | B_proof -> str "proof" | B_claim -> str "claim" | B_focus -> str "focus" let pr_casee pr_constr pr_tac =function Real c -> str "on" ++ spc () ++ pr_constr c | Virtual cut -> str "of" ++ spc () ++ pr_cut pr_constr pr_tac (pr_statement pr_constr) cut let pr_side = function Lhs -> str "=~" | Rhs -> str "~=" let rec pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac _then _thus = function | Pescape -> str "escape" | Pthen i -> pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac true _thus i | Pthus i -> pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac _then true i | Phence i -> pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac true true i | Pcut c -> begin match _then,_thus with false,false -> str "have" ++ spc () ++ pr_cut pr_constr pr_tac (pr_statement (pr_or_thesis pr_constr)) c | false,true -> str "thus" ++ spc () ++ pr_cut pr_constr pr_tac (pr_statement (pr_or_thesis pr_constr)) c | true,false -> str "then" ++ spc () ++ pr_cut pr_constr pr_tac (pr_statement (pr_or_thesis pr_constr)) c | true,true -> str "hence" ++ spc () ++ pr_cut pr_constr pr_tac (pr_statement (pr_or_thesis pr_constr)) c end | Psuffices c -> str "suffices" ++ pr_cut pr_constr pr_tac (pr_suffices_clause pr_var pr_constr) c | Prew (sid,c) -> (if _thus then str "thus" else str " ") ++ spc () ++ pr_side sid ++ spc () ++ pr_cut pr_constr pr_tac (pr_statement pr_constr) c | Passume hyps -> str "assume" ++ pr_hyps pr_var pr_constr _I false false "we have" hyps | Plet hyps -> str "let" ++ pr_vars pr_var pr_constr _I false true "let" hyps | Pclaim st -> str "claim" ++ spc () ++ pr_statement pr_constr st | Pfocus st -> str "focus on" ++ spc () ++ pr_statement pr_constr st | Pconsider (id,hyps) -> str "consider" ++ pr_vars pr_var pr_constr _I false false "consider" hyps ++ spc () ++ str "from " ++ pr_constr id | Pgiven hyps -> str "given" ++ pr_vars pr_var pr_constr _I false false "given" hyps | Ptake witl -> str "take" ++ spc () ++ prlist_with_sep pr_comma pr_constr witl | Pdefine (id,args,body) -> str "define" ++ spc () ++ pr_id id ++ spc () ++ prlist_with_sep spc (fun st -> str "(" ++ pr_var st ++ str ")") args ++ spc () ++ str "as" ++ (pr_constr body) | Pcast (id,typ) -> str "reconsider" ++ spc () ++ pr_or_thesis pr_id id ++ spc () ++ str "as" ++ spc () ++ (pr_constr typ) | Psuppose hyps -> str "suppose" ++ pr_hyps pr_var pr_constr _I false false "we have" hyps | Pcase (params,pat,hyps) -> str "suppose it is" ++ spc () ++ pr_pat pat ++ (if params = [] then mt () else (spc () ++ str "with" ++ spc () ++ prlist_with_sep spc (fun st -> str "(" ++ pr_var st ++ str ")") params ++ spc ())) ++ (if hyps = [] then mt () else (spc () ++ str "and" ++ pr_hyps pr_var (pr_or_thesis pr_constr) type_or_thesis false false "we have" hyps)) | Pper (et,c) -> str "per" ++ spc () ++ pr_elim_type et ++ spc () ++ pr_casee pr_constr pr_tac c | Pend blk -> str "end" ++ spc () ++ pr_block_type blk let pr_emph = function 0 -> str " " | 1 -> str "* " | 2 -> str "** " | 3 -> str "*** " | _ -> anomaly (Pp.str "unknown emphasis") let pr_gen_proof_instr pr_var pr_constr pr_pat pr_tac instr = pr_emph instr.emph ++ spc () ++ pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac false false instr.instr let pr_raw_proof_instr pconstr1 pconstr2 ptac (instr : raw_proof_instr) = pr_gen_proof_instr (fun (_,(id,otyp)) -> match otyp with None -> pr_id id | Some typ -> str "(" ++ pr_id id ++ str ":" ++ pconstr1 typ ++str ")" ) pconstr2 Ppconstr.pr_cases_pattern_expr (ptac Pptactic.ltop) instr let pr_glob_proof_instr pconstr1 pconstr2 ptac (instr : glob_proof_instr) = pr_gen_proof_instr (fun (_,(id,otyp)) -> match otyp with None -> pr_id id | Some typ -> str "(" ++ pr_id id ++ str ":" ++ pconstr1 typ ++str ")") pconstr2 Ppconstr.pr_cases_pattern_expr (ptac Pptactic.ltop) instr let pr_proof_instr pconstr1 pconstr2 ptac (instr : proof_instr) = pr_gen_proof_instr (fun st -> pr_statement pconstr1 st) pconstr2 (fun mpat -> Ppconstr.pr_cases_pattern_expr mpat.pat_expr) (ptac Pptactic.ltop) instr coq-8.6/plugins/decl_mode/decl_expr.mli0000644000175000017500000000572613022274260017535 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* raw_proof_instr -> glob_proof_instr val interp_proof_instr : Decl_mode.pm_info -> Environ.env -> Evd.evar_map -> glob_proof_instr -> proof_instr coq-8.6/plugins/decl_mode/g_decl_mode.ml40000644000175000017500000003216713022274260017723 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* pr_goal { Evd.it = goal ; sigma = sigma } | _ -> (* spiwack: it's not very nice to have to call proof global here, a more robust solution would be to add a hook for [Printer.pr_open_subgoals] in proof modes, in order to compute the end command. Yet a more robust solution would be to have focuses give explanations of their unfocusing behaviour. *) let p = Proof_global.give_me_the_proof () in let close_cmd = Decl_mode.get_end_command p in str "Subproof completed, now type " ++ str close_cmd ++ str "." let interp_proof_instr _ { Evd.it = gl ; sigma = sigma }= Decl_interp.interp_proof_instr (Decl_mode.get_info sigma gl) (Goal.V82.env sigma gl) (sigma) let vernac_decl_proof () = let pf = Proof_global.give_me_the_proof () in if Proof.is_done pf then CErrors.error "Nothing left to prove here." else begin Decl_proof_instr.go_to_proof_mode () ; Proof_global.set_proof_mode "Declarative" end (* spiwack: some bureaucracy is not performed here *) let vernac_return () = begin Decl_proof_instr.return_from_tactic_mode () ; Proof_global.set_proof_mode "Declarative" end let vernac_proof_instr instr = Decl_proof_instr.proof_instr instr (* Before we can write an new toplevel command (see below) which takes a [proof_instr] as argument, we need to declare how to parse it, print it, globalise it and interprete it. Normally we could do that easily through ARGUMENT EXTEND, but as the parsing is fairly complicated we will do it manually to indirect through the [proof_instr] grammar entry. *) (* spiwack: proposal: doing that directly from argextend.ml4, maybe ? *) (* Only declared at raw level, because only used in vernac commands. *) let wit_proof_instr : (raw_proof_instr, glob_proof_instr, proof_instr) Genarg.genarg_type = Genarg.make0 "proof_instr" (* We create a new parser entry [proof_mode]. The Declarative proof mode will replace the normal parser entry for tactics with this one. *) let proof_mode : vernac_expr Gram.entry = Gram.entry_create "vernac:proof_command" (* Auxiliary grammar entry. *) let proof_instr : raw_proof_instr Gram.entry = Pcoq.create_generic_entry Pcoq.utactic "proof_instr" (Genarg.rawwit wit_proof_instr) let _ = Pptactic.declare_extra_genarg_pprule wit_proof_instr pr_raw_proof_instr pr_glob_proof_instr pr_proof_instr let classify_proof_instr = function | { instr = Pescape |Pend B_proof } -> VtProofMode "Classic", VtNow | _ -> Vernac_classifier.classify_as_proofstep (* We use the VERNAC EXTEND facility with a custom non-terminal to populate [proof_mode] with a new toplevel interpreter. The "-" indicates that the rule does not start with a distinguished string. *) VERNAC proof_mode EXTEND ProofInstr [ - proof_instr(instr) ] => [classify_proof_instr instr] -> [ vernac_proof_instr instr ] END (* It is useful to use GEXTEND directly to call grammar entries that have been defined previously VERNAC EXTEND. In this case we allow, in proof mode, the use of commands like Check or Print. VERNAC EXTEND does quite a bit of bureaucracy for us, but it is not needed in this sort of case, and it would require to have an ARGUMENT EXTEND version of the "proof_mode" grammar entry. *) GEXTEND Gram GLOBAL: proof_mode ; proof_mode: LAST [ [ c=G_vernac.subgoal_command -> c (Some (Vernacexpr.SelectNth 1)) ] ] ; END (* We register a new proof mode here *) let _ = Proof_global.register_proof_mode { Proof_global. name = "Declarative" ; (* name for identifying and printing *) (* function [set] goes from No Proof Mode to Declarative Proof Mode performing side effects *) set = begin fun () -> (* We set the command non terminal to [proof_mode] (which we just defined). *) Pcoq.set_command_entry proof_mode ; (* We substitute the goal printer, by the one we built for the proof mode. *) Printer.set_printer_pr { Printer.default_printer_pr with Printer.pr_goal = pr_goal; pr_subgoals = pr_subgoals; } end ; (* function [reset] goes back to No Proof Mode from Declarative Proof Mode *) reset = begin fun () -> (* We restore the command non terminal to [noedit_mode]. *) Pcoq.set_command_entry Pcoq.Vernac_.noedit_mode ; (* We restore the goal printer to default *) Printer.set_printer_pr Printer.default_printer_pr end } VERNAC COMMAND EXTEND DeclProof [ "proof" ] => [ VtProofMode "Declarative", VtNow ] -> [ vernac_decl_proof () ] END VERNAC COMMAND EXTEND DeclReturn [ "return" ] => [ VtProofMode "Declarative", VtNow ] -> [ vernac_return () ] END let none_is_empty = function None -> [] | Some l -> l GEXTEND Gram GLOBAL: proof_instr; thesis : [[ "thesis" -> Plain | "thesis"; "for"; i=ident -> (For i) ]]; statement : [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c} | i=ident -> {st_label=Anonymous; st_it=Constrexpr.CRef (Libnames.Ident (!@loc, i), None)} | c=constr -> {st_label=Anonymous;st_it=c} ]]; constr_or_thesis : [[ t=thesis -> Thesis t ] | [ c=constr -> This c ]]; statement_or_thesis : [ [ t=thesis -> {st_label=Anonymous;st_it=Thesis t} ] | [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot} | i=ident -> {st_label=Anonymous; st_it=This (Constrexpr.CRef (Libnames.Ident (!@loc, i), None))} | c=constr -> {st_label=Anonymous;st_it=This c} ] ]; justification_items : [[ -> Some [] | "by"; l=LIST1 constr SEP "," -> Some l | "by"; "*" -> None ]] ; justification_method : [[ -> None | "using"; tac = tactic -> Some tac ]] ; simple_cut_or_thesis : [[ ls = statement_or_thesis; j = justification_items; taco = justification_method -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] ; simple_cut : [[ ls = statement; j = justification_items; taco = justification_method -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] ; elim_type: [[ IDENT "induction" -> ET_Induction | IDENT "cases" -> ET_Case_analysis ]] ; block_type : [[ IDENT "claim" -> B_claim | IDENT "focus" -> B_focus | IDENT "proof" -> B_proof | et=elim_type -> B_elim et ]] ; elim_obj: [[ IDENT "on"; c=constr -> Real c | IDENT "of"; c=simple_cut -> Virtual c ]] ; elim_step: [[ IDENT "consider" ; h=consider_vars ; IDENT "from" ; c=constr -> Pconsider (c,h) | IDENT "per"; et=elim_type; obj=elim_obj -> Pper (et,obj) | IDENT "suffices"; ls=suff_clause; j = justification_items; taco = justification_method -> Psuffices {cut_stat=ls;cut_by=j;cut_using=taco} ]] ; rew_step : [[ "~=" ; c=simple_cut -> (Rhs,c) | "=~" ; c=simple_cut -> (Lhs,c)]] ; cut_step: [[ "then"; tt=elim_step -> Pthen tt | "then"; c=simple_cut_or_thesis -> Pthen (Pcut c) | IDENT "thus"; tt=rew_step -> Pthus (let s,c=tt in Prew (s,c)) | IDENT "thus"; c=simple_cut_or_thesis -> Pthus (Pcut c) | IDENT "hence"; c=simple_cut_or_thesis -> Phence (Pcut c) | tt=elim_step -> tt | tt=rew_step -> let s,c=tt in Prew (s,c); | IDENT "have"; c=simple_cut_or_thesis -> Pcut c; | IDENT "claim"; c=statement -> Pclaim c; | IDENT "focus"; IDENT "on"; c=statement -> Pfocus c; | "end"; bt = block_type -> Pend bt; | IDENT "escape" -> Pescape ]] ; (* examiner s'il est possible de faire R _ et _ R pour R une relation qcq*) loc_id: [[ id=ident -> fun x -> (!@loc,(id,x)) ]]; hyp: [[ id=loc_id -> id None ; | id=loc_id ; ":" ; c=constr -> id (Some c)]] ; consider_vars: [[ name=hyp -> [Hvar name] | name=hyp; ","; v=consider_vars -> (Hvar name) :: v | name=hyp; IDENT "such"; IDENT "that"; h=consider_hyps -> (Hvar name)::h ]] ; consider_hyps: [[ st=statement; IDENT "and"; h=consider_hyps -> Hprop st::h | st=statement; IDENT "and"; IDENT "consider" ; v=consider_vars -> Hprop st::v | st=statement -> [Hprop st] ]] ; assume_vars: [[ name=hyp -> [Hvar name] | name=hyp; ","; v=assume_vars -> (Hvar name) :: v | name=hyp; IDENT "such"; IDENT "that"; h=assume_hyps -> (Hvar name)::h ]] ; assume_hyps: [[ st=statement; IDENT "and"; h=assume_hyps -> Hprop st::h | st=statement; IDENT "and"; IDENT "we"; IDENT "have" ; v=assume_vars -> Hprop st::v | st=statement -> [Hprop st] ]] ; assume_clause: [[ IDENT "we" ; IDENT "have" ; v=assume_vars -> v | h=assume_hyps -> h ]] ; suff_vars: [[ name=hyp; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> [Hvar name],c | name=hyp; ","; v=suff_vars -> let (q,c) = v in ((Hvar name) :: q),c | name=hyp; IDENT "such"; IDENT "that"; h=suff_hyps -> let (q,c) = h in ((Hvar name) :: q),c ]]; suff_hyps: [[ st=statement; IDENT "and"; h=suff_hyps -> let (q,c) = h in (Hprop st::q),c | st=statement; IDENT "and"; IDENT "to" ; IDENT "have" ; v=suff_vars -> let (q,c) = v in (Hprop st::q),c | st=statement; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> [Hprop st],c ]] ; suff_clause: [[ IDENT "to" ; IDENT "have" ; v=suff_vars -> v | h=suff_hyps -> h ]] ; let_vars: [[ name=hyp -> [Hvar name] | name=hyp; ","; v=let_vars -> (Hvar name) :: v | name=hyp; IDENT "be"; IDENT "such"; IDENT "that"; h=let_hyps -> (Hvar name)::h ]] ; let_hyps: [[ st=statement; IDENT "and"; h=let_hyps -> Hprop st::h | st=statement; IDENT "and"; "let"; v=let_vars -> Hprop st::v | st=statement -> [Hprop st] ]]; given_vars: [[ name=hyp -> [Hvar name] | name=hyp; ","; v=given_vars -> (Hvar name) :: v | name=hyp; IDENT "such"; IDENT "that"; h=given_hyps -> (Hvar name)::h ]] ; given_hyps: [[ st=statement; IDENT "and"; h=given_hyps -> Hprop st::h | st=statement; IDENT "and"; IDENT "given"; v=given_vars -> Hprop st::v | st=statement -> [Hprop st] ]]; suppose_vars: [[name=hyp -> [Hvar name] |name=hyp; ","; v=suppose_vars -> (Hvar name) :: v |name=hyp; OPT[IDENT "be"]; IDENT "such"; IDENT "that"; h=suppose_hyps -> (Hvar name)::h ]] ; suppose_hyps: [[ st=statement_or_thesis; IDENT "and"; h=suppose_hyps -> Hprop st::h | st=statement_or_thesis; IDENT "and"; IDENT "we"; IDENT "have"; v=suppose_vars -> Hprop st::v | st=statement_or_thesis -> [Hprop st] ]] ; suppose_clause: [[ IDENT "we"; IDENT "have"; v=suppose_vars -> v; | h=suppose_hyps -> h ]] ; intro_step: [[ IDENT "suppose" ; h=assume_clause -> Psuppose h | IDENT "suppose" ; IDENT "it"; IDENT "is" ; c=pattern LEVEL "0" ; po=OPT[ "with"; p=LIST1 hyp SEP ","-> p ] ; ho=OPT[ IDENT "and" ; h=suppose_clause -> h ] -> Pcase (none_is_empty po,c,none_is_empty ho) | "let" ; v=let_vars -> Plet v | IDENT "take"; witnesses = LIST1 constr SEP "," -> Ptake witnesses | IDENT "assume"; h=assume_clause -> Passume h | IDENT "given"; h=given_vars -> Pgiven h | IDENT "define"; id=ident; args=LIST0 hyp; "as"; body=constr -> Pdefine(id,args,body) | IDENT "reconsider"; id=ident; "as" ; typ=constr -> Pcast (This id,typ) | IDENT "reconsider"; t=thesis; "as" ; typ=constr -> Pcast (Thesis t ,typ) ]] ; emphasis : [[ -> 0 | "*" -> 1 | "**" -> 2 | "***" -> 3 ]] ; bare_proof_instr: [[ c = cut_step -> c ; | i = intro_step -> i ]] ; proof_instr : [[ e=emphasis;i=bare_proof_instr;"." -> {emph=e;instr=i}]] ; END;; coq-8.6/plugins/decl_mode/decl_interp.ml0000644000175000017500000004155313022274260017705 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Thesis n | This c -> This (intern_constr globs c) let add_var id globs= {globs with ltacvars = Id.Set.add id globs.ltacvars} let add_name nam globs= match nam with Anonymous -> globs | Name id -> add_var id globs let intern_hyp iconstr globs = function Hvar (loc,(id,topt)) -> add_var id globs, Hvar (loc,(id,Option.map (intern_constr globs) topt)) | Hprop st -> add_name st.st_label globs, Hprop (intern_statement iconstr globs st) let intern_hyps iconstr globs hyps = snd (List.fold_map (intern_hyp iconstr) globs hyps) let intern_cut intern_it globs cut= let nglobs,nstat=intern_it globs cut.cut_stat in {cut_stat=nstat; cut_by=intern_justification_items nglobs cut.cut_by; cut_using=intern_justification_method nglobs cut.cut_using} let intern_casee globs = function Real c -> Real (intern_constr globs c) | Virtual cut -> Virtual (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut) let intern_hyp_list args globs = let intern_one globs (loc,(id,opttyp)) = (add_var id globs), (loc,(id,Option.map (intern_constr globs) opttyp)) in List.fold_map intern_one globs args let intern_suffices_clause globs (hyps,c) = let nglobs,nhyps = List.fold_map (intern_hyp intern_constr) globs hyps in nglobs,(nhyps,intern_constr_or_thesis nglobs c) let intern_fundecl args body globs= let nglobs,nargs = intern_hyp_list args globs in nargs,intern_constr nglobs body let rec add_vars_of_simple_pattern globs = function CPatAlias (loc,p,id) -> add_vars_of_simple_pattern (add_var id globs) p (* Loc.raise loc (UserError ("simple_pattern",str "\"as\" is not allowed here"))*) | CPatOr (loc, _)-> Loc.raise loc (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) | CPatDelimiters (_,_,p) -> add_vars_of_simple_pattern globs p | CPatCstr (_,_,pl1,pl2) -> List.fold_left add_vars_of_simple_pattern (Option.fold_left (List.fold_left add_vars_of_simple_pattern) globs pl1) pl2 | CPatNotation(_,_,(pl,pll),pl') -> List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pl'::pll)) | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs | _ -> globs let rec intern_bare_proof_instr globs = function Pthus i -> Pthus (intern_bare_proof_instr globs i) | Pthen i -> Pthen (intern_bare_proof_instr globs i) | Phence i -> Phence (intern_bare_proof_instr globs i) | Pcut c -> Pcut (intern_cut (intern_no_bind (intern_statement intern_constr_or_thesis)) globs c) | Psuffices c -> Psuffices (intern_cut intern_suffices_clause globs c) | Prew (s,c) -> Prew (s,intern_cut (intern_no_bind (intern_statement intern_constr)) globs c) | Psuppose hyps -> Psuppose (intern_hyps intern_constr globs hyps) | Pcase (params,pat,hyps) -> let nglobs,nparams = intern_hyp_list params globs in let nnglobs= add_vars_of_simple_pattern nglobs pat in let nhyps = intern_hyps intern_constr_or_thesis nnglobs hyps in Pcase (nparams,pat,nhyps) | Ptake witl -> Ptake (List.map (intern_constr globs) witl) | Pconsider (c,hyps) -> Pconsider (intern_constr globs c, intern_hyps intern_constr globs hyps) | Pper (et,c) -> Pper (et,intern_casee globs c) | Pend bt -> Pend bt | Pescape -> Pescape | Passume hyps -> Passume (intern_hyps intern_constr globs hyps) | Pgiven hyps -> Pgiven (intern_hyps intern_constr globs hyps) | Plet hyps -> Plet (intern_hyps intern_constr globs hyps) | Pclaim st -> Pclaim (intern_statement intern_constr globs st) | Pfocus st -> Pfocus (intern_statement intern_constr globs st) | Pdefine (id,args,body) -> let nargs,nbody = intern_fundecl args body globs in Pdefine (id,nargs,nbody) | Pcast (id,typ) -> Pcast (id,intern_constr globs typ) let intern_proof_instr globs instr= {emph = instr.emph; instr = intern_bare_proof_instr globs instr.instr} (* INTERP *) let interp_justification_items env sigma = Option.map (List.map (fun c -> fst (*FIXME*)(understand env sigma (fst c)))) let interp_constr check_sort env sigma c = if check_sort then fst (understand env sigma ~expected_type:IsType (fst c) (* FIXME *)) else fst (understand env sigma (fst c)) let special_whd env = let infos=CClosure.create_clos_infos CClosure.all env in (fun t -> CClosure.whd_val infos (CClosure.inject t)) let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq)) let decompose_eq env id = let typ = Environ.named_type id env in let whd = special_whd env typ in match kind_of_term whd with App (f,args)-> if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 then args.(0) else error "Previous step is not an equality." | _ -> error "Previous step is not an equality." let get_eq_typ info env = let typ = decompose_eq env (get_last env) in typ let interp_constr_in_type typ env sigma c = fst (understand env sigma (fst c) ~expected_type:(OfType typ))(*FIXME*) let interp_statement interp_it env sigma st = {st_label=st.st_label; st_it=interp_it env sigma st.st_it} let interp_constr_or_thesis check_sort env sigma = function Thesis n -> Thesis n | This c -> This (interp_constr check_sort env sigma c) let abstract_one_hyp inject h glob = match h with Hvar (loc,(id,None)) -> GProd (Loc.ghost,Name id, Explicit, GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob) | Hvar (loc,(id,Some typ)) -> GProd (Loc.ghost,Name id, Explicit, fst typ, glob) | Hprop st -> GProd (Loc.ghost,st.st_label, Explicit, inject st.st_it, glob) let glob_constr_of_hyps inject hyps head = List.fold_right (abstract_one_hyp inject) hyps head let glob_prop = GSort (Loc.ghost,GProp) let rec match_hyps blend names constr = function [] -> [],substl names constr | hyp::q -> let (name,typ,body)=destProd constr in let st= {st_label=name;st_it=substl names typ} in let qnames= match name with Anonymous -> mkMeta 0 :: names | Name id -> mkVar id :: names in let qhyp = match hyp with Hprop st' -> Hprop (blend st st') | Hvar _ -> Hvar st in let rhyps,head = match_hyps blend qnames body q in qhyp::rhyps,head let interp_hyps_gen inject blend env sigma hyps head = let constr= fst(*FIXME*) (understand env sigma (glob_constr_of_hyps inject hyps head)) in match_hyps blend [] constr hyps let interp_hyps env sigma hyps = fst (interp_hyps_gen fst (fun x _ -> x) env sigma hyps glob_prop) let dummy_prefix= Id.of_string "__" let rec deanonymize ids = function PatVar (loc,Anonymous) -> let (found,known) = !ids in let new_id=Namegen.next_ident_away dummy_prefix known in let _= ids:= (loc,new_id) :: found , new_id :: known in PatVar (loc,Name new_id) | PatVar (loc,Name id) as pat -> let (found,known) = !ids in let _= ids:= (loc,id) :: found , known in pat | PatCstr(loc,cstr,lpat,nam) -> PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam) let rec glob_of_pat = function PatVar (loc,Anonymous) -> anomaly (Pp.str "Anonymous pattern variable") | PatVar (loc,Name id) -> GVar (loc,id) | PatCstr(loc,((ind,_) as cstr),lpat,_) -> let mind= fst (Global.lookup_inductive ind) in let rec add_params n q = if n<=0 then q else add_params (pred n) (GHole(Loc.ghost, Evar_kinds.TomatchTypeParameter(ind,n), Misctypes.IntroAnonymous, None)::q) in let args = List.map glob_of_pat lpat in glob_app(loc,GRef(Loc.ghost,Globnames.ConstructRef cstr,None), add_params mind.Declarations.mind_nparams args) let prod_one_hyp = function (loc,(id,None)) -> (fun glob -> GProd (Loc.ghost,Name id, Explicit, GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob)) | (loc,(id,Some typ)) -> (fun glob -> GProd (Loc.ghost,Name id, Explicit, fst typ, glob)) let prod_one_id (loc,id) glob = GProd (Loc.ghost,Name id, Explicit, GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob) let let_in_one_alias (id,pat) glob = GLetIn (Loc.ghost,Name id, glob_of_pat pat, glob) let rec bind_primary_aliases map pat = match pat with PatVar (_,_) -> map | PatCstr(loc,_,lpat,nam) -> let map1 = match nam with Anonymous -> map | Name id -> (id,pat)::map in List.fold_left bind_primary_aliases map1 lpat let bind_secondary_aliases map subst = Id.Map.fold (fun ids idp map -> (ids,Id.List.assoc idp map)::map) subst map let bind_aliases patvars subst patt = let map = bind_primary_aliases [] patt in let map1 = bind_secondary_aliases map subst in List.rev map1 let interp_pattern env pat_expr = let patvars,pats = Constrintern.intern_pattern env pat_expr in match pats with [] -> anomaly (Pp.str "empty pattern list") | [subst,patt] -> (patvars,bind_aliases patvars subst patt,patt) | _ -> anomaly (Pp.str "undetected disjunctive pattern") let rec match_args dest names constr = function [] -> [],names,substl names constr | _::q -> let (name,typ,body)=dest constr in let st={st_label=name;st_it=substl names typ} in let qnames= match name with Anonymous -> assert false | Name id -> mkVar id :: names in let args,bnames,body = match_args dest qnames body q in st::args,bnames,body let rec match_aliases names constr = function [] -> [],names,substl names constr | _::q -> let (name,c,typ,body)=destLetIn constr in let st={st_label=name;st_it=(substl names c,substl names typ)} in let qnames= match name with Anonymous -> assert false | Name id -> mkVar id :: names in let args,bnames,body = match_aliases qnames body q in st::args,bnames,body let detype_ground env c = Detyping.detype false [] env Evd.empty c let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = let et,pinfo = match info.pm_stack with Per(et,pi,_,_)::_ -> et,pi | _ -> error "No proof per cases/induction/inversion in progress." in let mib,oib=Global.lookup_inductive pinfo.per_ind in let num_params = pinfo.per_nparams in let _ = let expected = mib.Declarations.mind_nparams - num_params in if not (Int.equal (List.length params) expected) then errorlabstrm "suppose it is" (str "Wrong number of extra arguments: " ++ (if Int.equal expected 0 then str "none" else int expected) ++ spc () ++ str "expected.") in let app_ind = let rind = GRef (Loc.ghost,Globnames.IndRef pinfo.per_ind,None) in let rparams = List.map (detype_ground env) pinfo.per_params in let rparams_rec = List.map (fun (loc,(id,_)) -> GVar (loc,id)) params in let dum_args= List.init oib.Declarations.mind_nrealargs (fun _ -> GHole (Loc.ghost,Evar_kinds.QuestionMark (Evar_kinds.Define false),Misctypes.IntroAnonymous, None)) in glob_app(Loc.ghost,rind,rparams@rparams_rec@dum_args) in let pat_vars,aliases,patt = interp_pattern env pat in let inject = function Thesis (Plain) -> Glob_term.GSort(Loc.ghost,GProp) | Thesis (For rec_occ) -> if not (Id.List.mem rec_occ pat_vars) then errorlabstrm "suppose it is" (str "Variable " ++ Nameops.pr_id rec_occ ++ str " does not occur in pattern."); Glob_term.GSort(Loc.ghost,GProp) | This (c,_) -> c in let term1 = glob_constr_of_hyps inject hyps glob_prop in let loc_ids,npatt = let rids=ref ([],pat_vars) in let npatt= deanonymize rids patt in List.rev (fst !rids),npatt in let term2 = GLetIn(Loc.ghost,Anonymous, GCast(Loc.ghost,glob_of_pat npatt, CastConv app_ind),term1) in let term3=List.fold_right let_in_one_alias aliases term2 in let term4=List.fold_right prod_one_id loc_ids term3 in let term5=List.fold_right prod_one_hyp params term4 in let constr = fst (understand env sigma term5)(*FIXME*) in let tparams,nam4,rest4 = match_args destProd [] constr params in let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in let (_,pat_pat,pat_typ,rest1) = destLetIn rest2 in let blend st st' = match st'.st_it with Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} | This _ -> {st_it = This st.st_it;st_label=st.st_label} in let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in tparams,{pat_vars=tpatvars; pat_aliases=taliases; pat_constr=pat_pat; pat_typ=pat_typ; pat_pat=patt; pat_expr=pat},thyps let interp_cut interp_it env sigma cut= let nenv,nstat = interp_it env sigma cut.cut_stat in { cut_using=Option.map (Tacinterp.Value.of_closure (Tacinterp.default_ist ())) cut.cut_using; cut_stat=nstat; cut_by=interp_justification_items nenv sigma cut.cut_by} let interp_no_bind interp_it env sigma x = env,interp_it env sigma x let interp_suffices_clause env sigma (hyps,cot)= let (locvars,_) as res = match cot with This (c,_) -> let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) env sigma hyps c in nhyps,This nc | Thesis Plain as th -> interp_hyps env sigma hyps,th | Thesis (For n) -> error "\"thesis for\" is not applicable here." in let push_one hyp env0 = match hyp with (Hprop st | Hvar st) -> match st.st_label with Name id -> Environ.push_named (Context.Named.Declaration.LocalAssum (id,st.st_it)) env0 | _ -> env in let nenv = List.fold_right push_one locvars env in nenv,res let interp_casee env sigma = function Real c -> Real (fst (understand env sigma (fst c)))(*FIXME*) | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) env sigma cut) let abstract_one_arg = function (loc,(id,None)) -> (fun glob -> GLambda (Loc.ghost,Name id, Explicit, GHole (loc,Evar_kinds.BinderType (Name id),Misctypes.IntroAnonymous,None), glob)) | (loc,(id,Some typ)) -> (fun glob -> GLambda (Loc.ghost,Name id, Explicit, fst typ, glob)) let glob_constr_of_fun args body = List.fold_right abstract_one_arg args (fst body) let interp_fun env sigma args body = let constr=fst (*FIXME*) (understand env sigma (glob_constr_of_fun args body)) in match_args destLambda [] constr args let rec interp_bare_proof_instr info env sigma = function Pthus i -> Pthus (interp_bare_proof_instr info env sigma i) | Pthen i -> Pthen (interp_bare_proof_instr info env sigma i) | Phence i -> Phence (interp_bare_proof_instr info env sigma i) | Pcut c -> Pcut (interp_cut (interp_no_bind (interp_statement (interp_constr_or_thesis true))) env sigma c) | Psuffices c -> Psuffices (interp_cut interp_suffices_clause env sigma c) | Prew (s,c) -> Prew (s,interp_cut (interp_no_bind (interp_statement (interp_constr_in_type (get_eq_typ info env)))) env sigma c) | Psuppose hyps -> Psuppose (interp_hyps env sigma hyps) | Pcase (params,pat,hyps) -> let tparams,tpat,thyps = interp_cases info env sigma params pat hyps in Pcase (tparams,tpat,thyps) | Ptake witl -> Ptake (List.map (fun c -> fst (*FIXME*) (understand env sigma (fst c))) witl) | Pconsider (c,hyps) -> Pconsider (interp_constr false env sigma c, interp_hyps env sigma hyps) | Pper (et,c) -> Pper (et,interp_casee env sigma c) | Pend bt -> Pend bt | Pescape -> Pescape | Passume hyps -> Passume (interp_hyps env sigma hyps) | Pgiven hyps -> Pgiven (interp_hyps env sigma hyps) | Plet hyps -> Plet (interp_hyps env sigma hyps) | Pclaim st -> Pclaim (interp_statement (interp_constr true) env sigma st) | Pfocus st -> Pfocus (interp_statement (interp_constr true) env sigma st) | Pdefine (id,args,body) -> let nargs,_,nbody = interp_fun env sigma args body in Pdefine (id,nargs,nbody) | Pcast (id,typ) -> Pcast(id,interp_constr true env sigma typ) let interp_proof_instr info env sigma instr= {emph = instr.emph; instr = interp_bare_proof_instr info env sigma instr.instr} coq-8.6/plugins/decl_mode/decl_proof_instr.mli0000644000175000017500000000652113022274260021115 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val return_from_tactic_mode: unit -> unit val register_automation_tac: unit Proofview.tactic -> unit val automation_tac : unit Proofview.tactic val concl_refiner: Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr val do_instr: Decl_expr.raw_proof_instr -> Proof.proof -> unit val proof_instr: Decl_expr.raw_proof_instr -> unit val tcl_change_info : Decl_mode.pm_info -> tactic val execute_cases : Name.t -> Decl_mode.per_info -> (Term.constr -> Proof_type.tactic) -> (Id.Set.elt * (Term.constr option * Term.constr list) list) list -> Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic val tree_of_pats : Id.t * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> split_tree val add_branch : Id.t * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> split_tree -> split_tree val append_branch : Id.t *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> (Id.Set.t * Decl_mode.split_tree) option -> (Id.Set.t * Decl_mode.split_tree) option val append_tree : Id.t * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> split_tree -> split_tree val build_dep_clause : Term.types Decl_expr.statement list -> Decl_expr.proof_pattern -> Decl_mode.per_info -> (Term.types Decl_expr.statement, Term.types Decl_expr.or_thesis) Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types val register_dep_subcase : Id.t * (int * int) -> Environ.env -> Decl_mode.per_info -> Glob_term.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind val thesis_for : Term.constr -> Term.constr -> Decl_mode.per_info -> Environ.env -> Term.constr val close_previous_case : Proof.proof -> unit val pop_stacks : (Id.t * (Term.constr option * Term.constr list) list) list -> (Id.t * (Term.constr option * Term.constr list) list) list val push_head : Term.constr -> Id.Set.t -> (Id.t * (Term.constr option * Term.constr list) list) list -> (Id.t * (Term.constr option * Term.constr list) list) list val push_arg : Term.constr -> (Id.t * (Term.constr option * Term.constr list) list) list -> (Id.t * (Term.constr option * Term.constr list) list) list val hrec_for: Id.t -> Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> Id.t -> Term.constr val consider_match : bool -> (Id.Set.elt*bool) list -> Id.Set.elt list -> (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list -> Proof_type.tactic val init_tree: Id.Set.t -> inductive -> int option * Declarations.wf_paths -> (int -> (int option * Declarations.recarg Rtree.t) array -> (Id.Set.t * Decl_mode.split_tree) option) -> Decl_mode.split_tree coq-8.6/plugins/decl_mode/decl_mode_plugin.mlpack0000644000175000017500000000010013022274260021524 0ustar mdenesmdenesDecl_mode Decl_interp Decl_proof_instr Ppdecl_proof G_decl_mode coq-8.6/plugins/decl_mode/decl_mode.mli0000644000175000017500000000407513022274260017477 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val clear_daimon_flag : unit -> unit val get_daimon_flag : unit -> bool type command_mode = Mode_tactic | Mode_proof | Mode_none val mode_of_pftreestate : Proof.proof -> command_mode val get_current_mode : unit -> command_mode val check_not_proof_mode : string -> unit type split_tree= Skip_patt of Id.Set.t * split_tree | Split_patt of Id.Set.t * inductive * (bool array * (Id.Set.t * split_tree) option) array | Close_patt of split_tree | End_patt of (Id.t * (int * int)) type elim_kind = EK_dep of split_tree | EK_nodep | EK_unknown type recpath = int option*Declarations.wf_paths type per_info = {per_casee:constr; per_ctype:types; per_ind:inductive; per_pred:constr; per_args:constr list; per_params:constr list; per_nparams:int; per_wf:recpath} type stack_info = Per of Decl_expr.elim_type * per_info * elim_kind * Names.Id.t list | Suppose_case | Claim | Focus_claim type pm_info = {pm_stack : stack_info list } val info : pm_info Store.field val get_info : Evd.evar_map -> Proof_type.goal -> pm_info val try_get_info : Evd.evar_map -> Proof_type.goal -> pm_info option val get_stack : Proof.proof -> stack_info list val get_top_stack : Proof.proof -> stack_info list val get_last: Environ.env -> Id.t (** [get_last] raises a [UserError] when it cannot find a previous statement in the environment. *) val get_end_command : Proof.proof -> string val focus : Proof.proof -> unit val unfocus : unit -> unit coq-8.6/plugins/decl_mode/decl_mode.ml0000644000175000017500000000713613022274260017327 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Mode_tactic | Some _ -> Mode_proof let get_current_mode () = try mode_of_pftreestate (Pfedit.get_pftreestate ()) with Proof_global.NoCurrentProof -> Mode_none let check_not_proof_mode str = match get_current_mode () with | Mode_proof -> error str | _ -> () let get_info sigma gl= match Store.get (Goal.V82.extra sigma gl) info with | None -> invalid_arg "get_info" | Some pm -> pm let try_get_info sigma gl = Store.get (Goal.V82.extra sigma gl) info let get_goal_stack pts = let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in let info = get_info sigma (List.hd goals) in info.pm_stack let proof_focus = Proof.new_focus_kind () let proof_cond = Proof.done_cond proof_focus let focus p = let inf = get_goal_stack p in Proof_global.simple_with_current_proof (fun _ -> Proof.focus proof_cond inf 1) let unfocus () = Proof_global.simple_with_current_proof (fun _ p -> Proof.unfocus proof_focus p ()) let get_top_stack pts = try Proof.get_at_focus proof_focus pts with Proof.NoSuchFocus -> let { it = gl ; sigma = sigma } = Proof.V82.top_goal pts in let info = get_info sigma gl in info.pm_stack let get_stack pts = Proof.get_at_focus proof_focus pts let get_last env = match Environ.named_context env with | decl :: _ -> Context.Named.Declaration.get_id decl | [] -> error "no previous statement to use" let get_end_command pts = match get_top_stack pts with | [] -> "\"end proof\"" | Claim::_ -> "\"end claim\"" | Focus_claim::_-> "\"end focus\"" | Suppose_case :: Per (et,_,_,_) :: _ | Per (et,_,_,_) :: _ -> begin match et with Decl_expr.ET_Case_analysis -> "\"end cases\" or start a new case" | Decl_expr.ET_Induction -> "\"end induction\" or start a new case" end | _ -> anomaly (Pp.str"lonely suppose") coq-8.6/plugins/decl_mode/decl_proof_instr.ml0000644000175000017500000014122113022274260020741 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Id.Set.add x accu) Id.Set.empty ids in let env = Goal.V82.env sigma goal in let sign = Goal.V82.hyps sigma goal in let cl = Goal.V82.concl sigma goal in let evdref = ref (Evd.clear_metas sigma) in let (hyps, concl) = try Evarutil.clear_hyps_in_evi env evdref sign cl ids with Evarutil.ClearDependencyError (id, _) -> errorlabstrm "" (str "Cannot clear " ++ pr_id id) in let sigma = !evdref in let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in let sigma = Goal.V82.partial_solution_to sigma goal gl ev in { it = [gl]; sigma } let get_its_info gls = get_info gls.sigma gls.it let get_strictness,set_strictness = let strictness = ref false in (fun () -> (!strictness)),(fun b -> strictness:=b) let _ = declare_bool_option { optsync = true; optdepr = false; optname = "strict proofs"; optkey = ["Strict";"Proofs"]; optread = get_strictness; optwrite = set_strictness } let tcl_change_info_gen info_gen = (fun gls -> let it = sig_it gls in let concl = pf_concl gls in let hyps = Goal.V82.hyps (project gls) it in let extra = Goal.V82.extra (project gls) it in let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps concl (info_gen extra) in let sigma = Goal.V82.partial_solution sigma it ev in { it = [gl] ; sigma= sigma; } ) let tcl_change_info info gls = let info_gen s = Store.set s Decl_mode.info info in tcl_change_info_gen info_gen gls let tcl_erase_info gls = let info_gen s = Store.remove s Decl_mode.info in tcl_change_info_gen info_gen gls let special_whd gl= let infos=CClosure.create_clos_infos CClosure.all (pf_env gl) in (fun t -> CClosure.whd_val infos (CClosure.inject t)) let special_nf gl= let infos=CClosure.create_clos_infos CClosure.betaiotazeta (pf_env gl) in (fun t -> CClosure.norm_val infos (CClosure.inject t)) let is_good_inductive env ind = let mib,oib = Inductive.lookup_mind_specif env ind in Int.equal oib.mind_nrealargs 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib)) let check_not_per pts = if not (Proof.is_done pts) then match get_stack pts with Per (_,_,_,_)::_ -> error "You are inside a proof per cases/induction.\n\ Please \"suppose\" something or \"end\" it now." | _ -> () let mk_evd metalist gls = let evd0= clear_metas (sig_sig gls) in let add_one (meta,typ) evd = meta_declare meta typ evd in List.fold_right add_one metalist evd0 let is_tmp id = (Id.to_string id).[0] == '_' let tmp_ids gls = let ctx = pf_hyps gls in match ctx with [] -> [] | _::q -> List.filter is_tmp (ids_of_named_context q) let clean_tmp gls = let clean_id id0 gls0 = tclTRY (clear [id0]) gls0 in let rec clean_all = function [] -> tclIDTAC | id :: rest -> tclTHEN (clean_id id) (clean_all rest) in clean_all (tmp_ids gls) gls let assert_postpone id t = assert_before (Name id) t (* start a proof *) let start_proof_tac gls= let info={pm_stack=[]} in tcl_change_info info gls let go_to_proof_mode () = ignore (Pfedit.by (Proofview.V82.tactic start_proof_tac)); let p = Proof_global.give_me_the_proof () in Decl_mode.focus p (* closing gaps *) (* spiwack: should use [Proofview.give_up] but that would require moving the whole declarative mode into the new proof engine. It will eventually have to be done. As far as I can tell, [daimon_tac] is used after a [thus thesis], it will leave uninstantiated variables instead of giving a relevant message at [Qed]. *) let daimon_tac gls = set_daimon_flag (); {it=[];sigma=sig_sig gls;} let daimon_instr env p = let (p,(status,_)) = Proof.run_tactic env begin Proofview.tclINDEPENDENT Proofview.give_up end p in p,status let do_daimon () = let env = Global.env () in let status = Proof_global.with_current_proof begin fun _ p -> daimon_instr env p end in if not status then Feedback.feedback Feedback.AddedAxiom else () (* post-instruction focus management *) let goto_current_focus () = Decl_mode.unfocus () (* spiwack: used to catch errors indicating lack of "focusing command" in the proof tree. In the current implementation, however, entering the declarative mode puts a focus first, there should, therefore, never be exception raised here. *) let goto_current_focus_or_top () = goto_current_focus () (* return *) let close_tactic_mode () = try do_daimon ();goto_current_focus () with Not_found -> error "\"return\" cannot be used outside of Declarative Proof Mode." let return_from_tactic_mode () = close_tactic_mode () (* end proof/claim *) let close_block bt pts = if Proof.no_focused_goal pts then goto_current_focus () else let stack = if Proof.is_done pts then get_top_stack pts else get_stack pts in match bt,stack with B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> do_daimon ();goto_current_focus () | _, Claim::_ -> error "\"end claim\" expected." | _, Focus_claim::_ -> error "\"end focus\" expected." | _, [] -> error "\"end proof\" expected." | _, (Per (et,_,_,_)::_|Suppose_case::Per (et,_,_,_)::_) -> begin match et with ET_Case_analysis -> error "\"end cases\" expected." | ET_Induction -> error "\"end induction\" expected." end | _,_ -> anomaly (Pp.str "Lonely suppose on stack.") (* utility for suppose / suppose it is *) let close_previous_case pts = if Proof.is_done pts then match get_top_stack pts with Per (et,_,_,_) :: _ -> anomaly (Pp.str "Weird case occurred ...") | Suppose_case :: Per (et,_,_,_) :: _ -> goto_current_focus () | _ -> error "Not inside a proof per cases or induction." else match get_stack pts with Per (et,_,_,_) :: _ -> () | Suppose_case :: Per (et,_,_,_) :: _ -> do_daimon ();goto_current_focus () | _ -> error "Not inside a proof per cases or induction." (* Proof instructions *) (* automation *) let filter_hyps f gls = let filter_aux id = let id = get_id id in if f id then tclIDTAC else tclTRY (clear [id]) in tclMAP filter_aux (pf_hyps gls) gls let local_hyp_prefix = Id.of_string "___" let add_justification_hyps keep items gls = let add_aux c gls= match kind_of_term c with Var id -> keep:=Id.Set.add id !keep; tclIDTAC gls | _ -> let id=pf_get_new_id local_hyp_prefix gls in keep:=Id.Set.add id !keep; tclTHEN (Proofview.V82.of_tactic (letin_tac None (Names.Name id) c None Locusops.nowhere)) (Proofview.V82.of_tactic (clear_body [id])) gls in tclMAP add_aux items gls let prepare_goal items gls = let tokeep = ref Id.Set.empty in let auxres = add_justification_hyps tokeep items gls in tclTHENLIST [ (fun _ -> auxres); filter_hyps (let keep = !tokeep in fun id -> Id.Set.mem id keep)] gls let my_automation_tac = ref (Proofview.tclZERO (CErrors.make_anomaly (Pp.str"No automation registered"))) let register_automation_tac tac = my_automation_tac:= tac let automation_tac = Proofview.tclBIND (Proofview.tclUNIT ()) (fun () -> !my_automation_tac) let warn_insufficient_justification = CWarnings.create ~name:"declmode-insufficient-justification" ~category:"declmode" (fun () -> strbrk "Insufficient justification.") let justification tac gls= tclORELSE (tclSOLVE [tclTHEN tac (Proofview.V82.of_tactic assumption)]) (fun gls -> if get_strictness () then error "Insufficient justification." else begin warn_insufficient_justification (); daimon_tac gls end) gls let default_justification elems gls= justification (tclTHEN (prepare_goal elems) (Proofview.V82.of_tactic automation_tac)) gls (* code for conclusion refining *) let constant dir s = lazy (Coqlib.gen_constant "Declarative" dir s) let _and = constant ["Init";"Logic"] "and" let _and_rect = constant ["Init";"Logic"] "and_rect" let _prod = constant ["Init";"Datatypes"] "prod" let _prod_rect = constant ["Init";"Datatypes"] "prod_rect" let _ex = constant ["Init";"Logic"] "ex" let _ex_ind = constant ["Init";"Logic"] "ex_ind" let _sig = constant ["Init";"Specif"] "sig" let _sig_rect = constant ["Init";"Specif"] "sig_rect" let _sigT = constant ["Init";"Specif"] "sigT" let _sigT_rect = constant ["Init";"Specif"] "sigT_rect" type stackd_elt = {se_meta:metavariable; se_type:types; se_last_meta:metavariable; se_meta_list:(metavariable*types) list; se_evd: evar_map} let rec replace_in_list m l = function [] -> raise Not_found | c::q -> if Int.equal m (fst c) then l@q else c::replace_in_list m l q let enstack_subsubgoals env se stack gls= let hd,params = decompose_app (special_whd gls se.se_type) in match kind_of_term hd with Ind (ind,u as indu) when is_good_inductive env ind -> (* MS: FIXME *) let mib,oib= Inductive.lookup_mind_specif env ind in let gentypes= Inductive.arities_of_constructors indu (mib,oib) in let process i gentyp = let constructor = mkConstructU ((ind,succ i),u) (* constructors numbering*) in let appterm = applist (constructor,params) in let apptype = prod_applist gentyp params in let rc,_ = Reduction.dest_prod env apptype in let rec meta_aux last lenv = function [] -> (last,lenv,[]) | decl::q -> let nlast=succ last in let (llast,holes,metas) = meta_aux nlast (mkMeta nlast :: lenv) q in let open Context.Rel.Declaration in (llast,holes,(nlast,special_nf gls (substl lenv (get_type decl)))::metas) in let (nlast,holes,nmetas) = meta_aux se.se_last_meta [] (List.rev rc) in let refiner = applist (appterm,List.rev holes) in let evd = meta_assign se.se_meta (refiner,(Conv,TypeProcessed (* ? *))) se.se_evd in let ncreated = replace_in_list se.se_meta nmetas se.se_meta_list in let evd0 = List.fold_left (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in List.iter (fun (m,typ) -> Stack.push {se_meta=m; se_type=typ; se_evd=evd0; se_meta_list=ncreated; se_last_meta=nlast} stack) (List.rev nmetas) in Array.iteri process gentypes | _ -> () let rec nf_list evd = function [] -> [] | (m,typ)::others -> if meta_defined evd m then nf_list evd others else (m,Reductionops.nf_meta evd typ)::nf_list evd others let find_subsubgoal c ctyp skip submetas gls = let env= pf_env gls in let concl = pf_concl gls in let evd = mk_evd ((0,concl)::submetas) gls in let stack = Stack.create () in let max_meta = List.fold_left (fun a (m,_) -> max a m) 0 submetas in let _ = Stack.push {se_meta=0; se_type=concl; se_last_meta=max_meta; se_meta_list=[0,concl]; se_evd=evd} stack in let rec dfs n = let se = Stack.pop stack in try let unifier = Unification.w_unify env se.se_evd Reduction.CUMUL ~flags:(Unification.elim_flags ()) ctyp se.se_type in if n <= 0 then {se with se_evd=meta_assign se.se_meta (c,(Conv,TypeNotProcessed (* ?? *))) unifier; se_meta_list=replace_in_list se.se_meta submetas se.se_meta_list} else dfs (pred n) with e when CErrors.noncritical e -> begin enstack_subsubgoals env se stack gls; dfs n end in let nse= try dfs skip with Stack.Empty -> raise Not_found in nf_list nse.se_evd nse.se_meta_list,Reductionops.nf_meta nse.se_evd (mkMeta 0) let concl_refiner metas body gls = let concl = pf_concl gls in let evd = sig_sig gls in let env = pf_env gls in let sort = family_of_sort (Typing.e_sort_of env (ref evd) concl) in let rec aux env avoid subst = function [] -> anomaly ~label:"concl_refiner" (Pp.str "cannot happen") | (n,typ)::rest -> let _A = subst_meta subst typ in let x = id_of_name_using_hdchar env _A Anonymous in let _x = fresh_id avoid x gls in let nenv = Environ.push_named (LocalAssum (_x,_A)) env in let asort = family_of_sort (Typing.e_sort_of nenv (ref evd) _A) in let nsubst = (n,mkVar _x)::subst in if List.is_empty rest then asort,_A,mkNamedLambda _x _A (subst_meta nsubst body) else let bsort,_B,nbody = aux nenv (_x::avoid) ((n,mkVar _x)::subst) rest in let body = mkNamedLambda _x _A nbody in if occur_term (mkVar _x) _B then begin let _P = mkNamedLambda _x _A _B in match bsort,sort with InProp,InProp -> let _AxB = mkApp(Lazy.force _ex,[|_A;_P|]) in InProp,_AxB, mkApp(Lazy.force _ex_ind,[|_A;_P;concl;body|]) | InProp,_ -> let _AxB = mkApp(Lazy.force _sig,[|_A;_P|]) in let _P0 = mkLambda(Anonymous,_AxB,concl) in InType,_AxB, mkApp(Lazy.force _sig_rect,[|_A;_P;_P0;body|]) | _,_ -> let _AxB = mkApp(Lazy.force _sigT,[|_A;_P|]) in let _P0 = mkLambda(Anonymous,_AxB,concl) in InType,_AxB, mkApp(Lazy.force _sigT_rect,[|_A;_P;_P0;body|]) end else begin match asort,bsort with InProp,InProp -> let _AxB = mkApp(Lazy.force _and,[|_A;_B|]) in InProp,_AxB, mkApp(Lazy.force _and_rect,[|_A;_B;concl;body|]) |_,_ -> let _AxB = mkApp(Lazy.force _prod,[|_A;_B|]) in let _P0 = mkLambda(Anonymous,_AxB,concl) in InType,_AxB, mkApp(Lazy.force _prod_rect,[|_A;_B;_P0;body|]) end in let (_,_,prf) = aux env [] [] metas in mkApp(prf,[|mkMeta 1|]) let thus_tac c ctyp submetas gls = let list,proof = try find_subsubgoal c ctyp 0 submetas gls with Not_found -> error "I could not relate this statement to the thesis." in if List.is_empty list then Proofview.V82.of_tactic (exact_check proof) gls else let refiner = concl_refiner list proof gls in Tacmach.refine refiner gls (* general forward step *) let mk_stat_or_thesis info gls = function This c -> c | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> pf_concl gls let just_tac _then cut info gls0 = let last_item = if _then then try [mkVar (get_last (pf_env gls0))] with UserError _ -> error "\"then\" and \"hence\" require at least one previous fact" else [] in let items_tac gls = match cut.cut_by with None -> tclIDTAC gls | Some items -> prepare_goal (last_item@items) gls in let method_tac gls = match cut.cut_using with None -> Proofview.V82.of_tactic automation_tac gls | Some tac -> Proofview.V82.of_tactic (Tacinterp.tactic_of_value (Tacinterp.default_ist ()) tac) gls in justification (tclTHEN items_tac method_tac) gls0 let instr_cut mkstat _thus _then cut gls0 = let info = get_its_info gls0 in let stat = cut.cut_stat in let (c_id,_) = match stat.st_label with Anonymous -> pf_get_new_id (Id.of_string "_fact") gls0,false | Name id -> id,true in let c_stat = mkstat info gls0 stat.st_it in let thus_tac gls= if _thus then thus_tac (mkVar c_id) c_stat [] gls else tclIDTAC gls in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id c_stat)) [tclTHEN tcl_erase_info (just_tac _then cut info); thus_tac] gls0 (* iterated equality *) let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq)) let decompose_eq id gls = let typ = pf_get_hyp_typ gls id in let whd = (special_whd gls typ) in match kind_of_term whd with App (f,args)-> if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 then (args.(0), args.(1), args.(2)) else error "Previous step is not an equality." | _ -> error "Previous step is not an equality." let instr_rew _thus rew_side cut gls0 = let last_id = try get_last (pf_env gls0) with UserError _ -> error "No previous equality." in let typ,lhs,rhs = decompose_eq last_id gls0 in let items_tac gls = match cut.cut_by with None -> tclIDTAC gls | Some items -> prepare_goal items gls in let method_tac gls = match cut.cut_using with None -> Proofview.V82.of_tactic automation_tac gls | Some tac -> Proofview.V82.of_tactic (Tacinterp.tactic_of_value (Tacinterp.default_ist ()) tac) gls in let just_tac gls = justification (tclTHEN items_tac method_tac) gls in let (c_id,_) = match cut.cut_stat.st_label with Anonymous -> pf_get_new_id (Id.of_string "_eq") gls0,false | Name id -> id,true in let thus_tac new_eq gls= if _thus then thus_tac (mkVar c_id) new_eq [] gls else tclIDTAC gls in match rew_side with Lhs -> let new_eq = mkApp(Lazy.force _eq,[|typ;cut.cut_stat.st_it;rhs|]) in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq)) [tclTHEN tcl_erase_info (tclTHENS (Proofview.V82.of_tactic (transitivity lhs)) [just_tac;Proofview.V82.of_tactic (exact_check (mkVar last_id))]); thus_tac new_eq] gls0 | Rhs -> let new_eq = mkApp(Lazy.force _eq,[|typ;lhs;cut.cut_stat.st_it|]) in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq)) [tclTHEN tcl_erase_info (tclTHENS (Proofview.V82.of_tactic (transitivity rhs)) [Proofview.V82.of_tactic (exact_check (mkVar last_id));just_tac]); thus_tac new_eq] gls0 (* tactics for claim/focus *) let instr_claim _thus st gls0 = let info = get_its_info gls0 in let (id,_) = match st.st_label with Anonymous -> pf_get_new_id (Id.of_string "_claim") gls0,false | Name id -> id,true in let thus_tac gls= if _thus then thus_tac (mkVar id) st.st_it [] gls else tclIDTAC gls in let ninfo1 = {pm_stack= (if _thus then Focus_claim else Claim)::info.pm_stack} in tclTHENS (Proofview.V82.of_tactic (assert_postpone id st.st_it)) [thus_tac; tcl_change_info ninfo1] gls0 (* tactics for assume *) let push_intro_tac coerce nam gls = let (hid,_) = match nam with Anonymous -> pf_get_new_id (Id.of_string "_hyp") gls,false | Name id -> id,true in tclTHENLIST [Proofview.V82.of_tactic (intro_mustbe_force hid); coerce hid] gls let assume_tac hyps gls = List.fold_right (fun (Hvar st | Hprop st) -> tclTHEN (push_intro_tac (fun id -> Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label)) hyps tclIDTAC gls let assume_hyps_or_theses hyps gls = List.fold_right (function (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) -> tclTHEN (push_intro_tac (fun id -> Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,c)))) nam) | Hprop {st_label=nam;st_it=Thesis (tk)} -> tclTHEN (push_intro_tac (fun id -> tclIDTAC) nam)) hyps tclIDTAC gls let assume_st hyps gls = List.fold_right (fun st -> tclTHEN (push_intro_tac (fun id -> Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label)) hyps tclIDTAC gls let assume_st_letin hyps gls = List.fold_right (fun st -> tclTHEN (push_intro_tac (fun id -> Proofview.V82.of_tactic (convert_hyp (LocalDef (id, fst st.st_it, snd st.st_it)))) st.st_label)) hyps tclIDTAC gls (* suffices *) let rec metas_from n hyps = match hyps with _ :: q -> n :: metas_from (succ n) q | [] -> [] let rec build_product args body = match args with (Hprop st| Hvar st )::rest -> let pprod= lift 1 (build_product rest body) in let lbody = match st.st_label with Anonymous -> pprod | Name id -> subst_term (mkVar id) pprod in mkProd (st.st_label, st.st_it, lbody) | [] -> body let rec build_applist prod = function [] -> [],prod | n::q -> let (_,typ,_) = destProd prod in let ctx,head = build_applist (prod_applist prod [mkMeta n]) q in (n,typ)::ctx,head let instr_suffices _then cut gls0 = let info = get_its_info gls0 in let c_id = pf_get_new_id (Id.of_string "_cofact") gls0 in let ctx,hd = cut.cut_stat in let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in let metas = metas_from 1 ctx in let c_ctx,c_head = build_applist c_stat metas in let c_term = applist (mkVar c_id,List.map mkMeta metas) in let thus_tac gls= thus_tac c_term c_head c_ctx gls in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id c_stat)) [tclTHENLIST [ assume_tac ctx; tcl_erase_info; just_tac _then cut info]; thus_tac] gls0 (* tactics for consider/given *) let conjunction_arity id gls = let typ = pf_get_hyp_typ gls id in let hd,params = decompose_app (special_whd gls typ) in let env =pf_env gls in match kind_of_term hd with Ind (ind,u as indu) when is_good_inductive env ind -> let mib,oib= Inductive.lookup_mind_specif env ind in let gentypes= Inductive.arities_of_constructors indu (mib,oib) in let _ = if not (Int.equal (Array.length gentypes) 1) then raise Not_found in let apptype = prod_applist gentypes.(0) params in let rc,_ = Reduction.dest_prod env apptype in List.length rc | _ -> raise Not_found let rec intron_then n ids ltac gls = if n<=0 then ltac ids gls else let id = pf_get_new_id (Id.of_string "_tmp") gls in tclTHEN (Proofview.V82.of_tactic (intro_mustbe_force id)) (intron_then (pred n) (id::ids) ltac) gls let rec consider_match may_intro introduced available expected gls = match available,expected with [],[] -> tclIDTAC gls | _,[] -> error "Last statements do not match a complete hypothesis." (* should tell which ones *) | [],hyps -> if may_intro then begin let id = pf_get_new_id (Id.of_string "_tmp") gls in tclIFTHENELSE (Proofview.V82.of_tactic (intro_mustbe_force id)) (consider_match true [] [id] hyps) (fun _ -> error "Not enough sub-hypotheses to match statements.") gls end else error "Not enough sub-hypotheses to match statements." (* should tell which ones *) | id::rest_ids,(Hvar st | Hprop st)::rest -> tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) begin match st.st_label with Anonymous -> consider_match may_intro ((id,false)::introduced) rest_ids rest | Name hid -> tclTHENLIST [Proofview.V82.of_tactic (rename_hyp [id,hid]); consider_match may_intro ((hid,true)::introduced) rest_ids rest] end begin (fun gls -> let nhyps = try conjunction_arity id gls with Not_found -> error "Matching hypothesis not found." in tclTHENLIST [Proofview.V82.of_tactic (simplest_case (mkVar id)); intron_then nhyps [] (fun l -> consider_match may_intro introduced (List.rev_append l rest_ids) expected)] gls) end gls let consider_tac c hyps gls = match kind_of_term (strip_outer_cast c) with Var id -> consider_match false [] [id] hyps gls | _ -> let id = pf_get_new_id (Id.of_string "_tmp") gls in tclTHEN (Proofview.V82.of_tactic (pose_proof (Name id) c)) (consider_match false [] [id] hyps) gls let given_tac hyps gls = consider_match true [] [] hyps gls (* tactics for take *) let rec take_tac wits gls = match wits with [] -> tclIDTAC gls | wit::rest -> let typ = pf_unsafe_type_of gls wit in tclTHEN (thus_tac wit typ []) (take_tac rest) gls (* tactics for define *) let rec build_function args body = match args with st::rest -> let pfun= lift 1 (build_function rest body) in let id = match st.st_label with Anonymous -> assert false | Name id -> id in mkLambda (Name id, st.st_it, subst_term (mkVar id) pfun) | [] -> body let define_tac id args body gls = let t = build_function args body in Proofview.V82.of_tactic (letin_tac None (Name id) t None Locusops.nowhere) gls (* tactics for reconsider *) let cast_tac id_or_thesis typ gls = match id_or_thesis with This id -> let body = pf_get_hyp gls id |> get_value in Proofview.V82.of_tactic (convert_hyp (of_tuple (id,body,typ))) gls | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> Proofview.V82.of_tactic (convert_concl typ DEFAULTcast) gls (* per cases *) let is_rec_pos (main_ind,wft) = match main_ind with None -> false | Some index -> match fst (Rtree.dest_node wft) with Mrec (_,i) when Int.equal i index -> true | _ -> false let rec constr_trees (main_ind,wft) ind = match Rtree.dest_node wft with Norec,_ -> let itree = (snd (Global.lookup_inductive ind)).mind_recargs in constr_trees (None,itree) ind | _,constrs -> main_ind,constrs let ind_args rp ind = let main_ind,constrs = constr_trees rp ind in let args ctree = Array.map (fun t -> main_ind,t) (snd (Rtree.dest_node ctree)) in Array.map args constrs let init_tree ids ind rp nexti = let indargs = ind_args rp ind in let do_i i arp = (Array.map is_rec_pos arp),nexti i arp in Split_patt (ids,ind,Array.mapi do_i indargs) let map_tree_rp rp id_fun mapi = function Split_patt (ids,ind,branches) -> let indargs = ind_args rp ind in let do_i i (recargs,bri) = recargs,mapi i indargs.(i) bri in Split_patt (id_fun ids,ind,Array.mapi do_i branches) | _ -> failwith "map_tree_rp: not a splitting node" let map_tree id_fun mapi = function Split_patt (ids,ind,branches) -> let do_i i (recargs,bri) = recargs,mapi i bri in Split_patt (id_fun ids,ind,Array.mapi do_i branches) | _ -> failwith "map_tree: not a splitting node" let start_tree env ind rp = init_tree Id.Set.empty ind rp (fun _ _ -> None) let build_per_info etype casee gls = let concl=pf_concl gls in let env=pf_env gls in let ctyp=pf_unsafe_type_of gls casee in let is_dep = dependent casee concl in let hd,args = decompose_app (special_whd gls ctyp) in let (ind,u) = try destInd hd with DestKO -> error "Case analysis must be done on an inductive object." in let mind,oind = Global.lookup_inductive ind in let nparams,index = match etype with ET_Induction -> mind.mind_nparams_rec,Some (snd ind) | _ -> mind.mind_nparams,None in let params,real_args = List.chop nparams args in let abstract_obj c body = let typ=pf_unsafe_type_of gls c in lambda_create env (typ,subst_term c body) in let pred= List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term casee concl)) in is_dep, {per_casee=casee; per_ctype=ctyp; per_ind=ind; per_pred=pred; per_args=real_args; per_params=params; per_nparams=nparams; per_wf=index,oind.mind_recargs} let per_tac etype casee gls= let env=pf_env gls in let info = get_its_info gls in match casee with Real c -> let is_dep,per_info = build_per_info etype c gls in let ek = if is_dep then EK_dep (start_tree env per_info.per_ind per_info.per_wf) else EK_unknown in tcl_change_info {pm_stack= Per(etype,per_info,ek,[])::info.pm_stack} gls | Virtual cut -> assert (cut.cut_stat.st_label == Anonymous); let id = pf_get_new_id (Id.of_string "anonymous_matched") gls in let c = mkVar id in let modified_cut = {cut with cut_stat={cut.cut_stat with st_label=Name id}} in tclTHEN (instr_cut (fun _ _ c -> c) false false modified_cut) (fun gls0 -> let is_dep,per_info = build_per_info etype c gls0 in assert (not is_dep); tcl_change_info {pm_stack= Per(etype,per_info,EK_unknown,[])::info.pm_stack} gls0) gls (* suppose *) let register_nodep_subcase id= function Per(et,pi,ek,clauses)::s -> begin match ek with EK_unknown -> clauses,Per(et,pi,EK_nodep,id::clauses)::s | EK_nodep -> clauses,Per(et,pi,EK_nodep,id::clauses)::s | EK_dep _ -> error "Do not mix \"suppose\" with \"suppose it is\"." end | _ -> anomaly (Pp.str "wrong stack state") let suppose_tac hyps gls0 = let info = get_its_info gls0 in let thesis = pf_concl gls0 in let id = pf_get_new_id (Id.of_string "subcase_") gls0 in let clause = build_product hyps thesis in let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in let old_clauses,stack = register_nodep_subcase id info.pm_stack in let ninfo2 = {pm_stack=stack} in tclTHENS (Proofview.V82.of_tactic (assert_postpone id clause)) [tclTHENLIST [tcl_change_info ninfo1; assume_tac hyps; clear old_clauses]; tcl_change_info ninfo2] gls0 (* suppose it is ... *) (* pattern matching compiling *) let rec skip_args rest ids n = if n <= 0 then Close_patt rest else Skip_patt (ids,skip_args rest ids (pred n)) let rec tree_of_pats ((id,_) as cpl) pats = match pats with [] -> End_patt cpl | args::stack -> match args with [] -> Close_patt (tree_of_pats cpl stack) | (patt,rp) :: rest_args -> match patt with PatVar (_,v) -> Skip_patt (Id.Set.singleton id, tree_of_pats cpl (rest_args::stack)) | PatCstr (_,(ind,cnum),args,nam) -> let nexti i ati = if Int.equal i (pred cnum) then let nargs = List.map_i (fun j a -> (a,ati.(j))) 0 args in Some (Id.Set.singleton id, tree_of_pats cpl (nargs::rest_args::stack)) else None in init_tree Id.Set.empty ind rp nexti let rec add_branch ((id,_) as cpl) pats tree= match pats with [] -> begin match tree with End_patt cpl0 -> End_patt cpl0 (* this ensures precedence for overlapping patterns *) | _ -> anomaly (Pp.str "tree is expected to end here") end | args::stack -> match args with [] -> begin match tree with Close_patt t -> Close_patt (add_branch cpl stack t) | _ -> anomaly (Pp.str "we should pop here") end | (patt,rp) :: rest_args -> match patt with PatVar (_,v) -> begin match tree with Skip_patt (ids,t) -> Skip_patt (Id.Set.add id ids, add_branch cpl (rest_args::stack) t) | Split_patt (_,_,_) -> map_tree (Id.Set.add id) (fun i bri -> append_branch cpl 1 (rest_args::stack) bri) tree | _ -> anomaly (Pp.str "No pop/stop expected here") end | PatCstr (_,(ind,cnum),args,nam) -> match tree with Skip_patt (ids,t) -> let nexti i ati = if Int.equal i (pred cnum) then let nargs = List.map_i (fun j a -> (a,ati.(j))) 0 args in Some (Id.Set.add id ids, add_branch cpl (nargs::rest_args::stack) (skip_args t ids (Array.length ati))) else Some (ids, skip_args t ids (Array.length ati)) in init_tree ids ind rp nexti | Split_patt (_,ind0,_) -> if (not (eq_ind ind ind0)) then error (* this can happen with coercions *) "Case pattern belongs to wrong inductive type."; let mapi i ati bri = if Int.equal i (pred cnum) then let nargs = List.map_i (fun j a -> (a,ati.(j))) 0 args in append_branch cpl 0 (nargs::rest_args::stack) bri else bri in map_tree_rp rp (fun ids -> ids) mapi tree | _ -> anomaly (Pp.str "No pop/stop expected here") and append_branch ((id,_) as cpl) depth pats = function Some (ids,tree) -> Some (Id.Set.add id ids,append_tree cpl depth pats tree) | None -> Some (Id.Set.singleton id,tree_of_pats cpl pats) and append_tree ((id,_) as cpl) depth pats tree = if depth<=0 then add_branch cpl pats tree else match tree with Close_patt t -> Close_patt (append_tree cpl (pred depth) pats t) | Skip_patt (ids,t) -> Skip_patt (Id.Set.add id ids,append_tree cpl depth pats t) | End_patt _ -> anomaly (Pp.str "Premature end of branch") | Split_patt (_,_,_) -> map_tree (Id.Set.add id) (fun i bri -> append_branch cpl (succ depth) pats bri) tree (* suppose it is *) let rec st_assoc id = function [] -> raise Not_found | st::_ when Name.equal st.st_label id -> st.st_it | _ :: rest -> st_assoc id rest let thesis_for obj typ per_info env= let rc,hd1=decompose_prod typ in let cind,all_args=decompose_app typ in let ind,u = destInd cind in let _ = if not (eq_ind ind per_info.per_ind) then errorlabstrm "thesis_for" ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str"cannot give an induction hypothesis (wrong inductive type).") in let params,args = List.chop per_info.per_nparams all_args in let _ = if not (List.for_all2 eq_constr params per_info.per_params) then errorlabstrm "thesis_for" ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str "cannot give an induction hypothesis (wrong parameters).") in let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in compose_prod rc (Reductionops.whd_beta Evd.empty hd2) let rec build_product_dep pat_info per_info args body gls = match args with (Hprop {st_label=nam;st_it=This c} | Hvar {st_label=nam;st_it=c})::rest -> let pprod= lift 1 (build_product_dep pat_info per_info rest body gls) in let lbody = match nam with Anonymous -> body | Name id -> subst_var id pprod in mkProd (nam,c,lbody) | Hprop ({st_it=Thesis tk} as st)::rest -> let pprod= lift 1 (build_product_dep pat_info per_info rest body gls) in let lbody = match st.st_label with Anonymous -> body | Name id -> subst_var id pprod in let ptyp = match tk with For id -> let obj = mkVar id in let typ = try st_assoc (Name id) pat_info.pat_vars with Not_found -> snd (st_assoc (Name id) pat_info.pat_aliases) in thesis_for obj typ per_info (pf_env gls) | Plain -> pf_concl gls in mkProd (st.st_label,ptyp,lbody) | [] -> body let build_dep_clause params pat_info per_info hyps gls = let concl= thesis_for pat_info.pat_constr pat_info.pat_typ per_info (pf_env gls) in let open_clause = build_product_dep pat_info per_info hyps concl gls in let prod_one st body = match st.st_label with Anonymous -> mkProd(Anonymous,st.st_it,lift 1 body) | Name id -> mkNamedProd id st.st_it (lift 1 body) in let let_one_in st body = match st.st_label with Anonymous -> mkLetIn(Anonymous,fst st.st_it,snd st.st_it,lift 1 body) | Name id -> mkNamedLetIn id (fst st.st_it) (snd st.st_it) (lift 1 body) in let aliased_clause = List.fold_right let_one_in pat_info.pat_aliases open_clause in List.fold_right prod_one (params@pat_info.pat_vars) aliased_clause let rec register_dep_subcase id env per_info pat = function EK_nodep -> error "Only \"suppose it is\" can be used here." | EK_unknown -> register_dep_subcase id env per_info pat (EK_dep (start_tree env per_info.per_ind per_info.per_wf)) | EK_dep tree -> EK_dep (add_branch id [[pat,per_info.per_wf]] tree) let case_tac params pat_info hyps gls0 = let info = get_its_info gls0 in let id = pf_get_new_id (Id.of_string "subcase_") gls0 in let et,per_info,ek,old_clauses,rest = match info.pm_stack with Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) | _ -> anomaly (Pp.str "wrong place for cases") in let clause = build_dep_clause params pat_info per_info hyps gls0 in let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in let nek = register_dep_subcase (id,(List.length params,List.length hyps)) (pf_env gls0) per_info pat_info.pat_pat ek in let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in tclTHENS (Proofview.V82.of_tactic (assert_postpone id clause)) [tclTHENLIST [tcl_change_info ninfo1; assume_st (params@pat_info.pat_vars); assume_st_letin pat_info.pat_aliases; assume_hyps_or_theses hyps; clear old_clauses]; tcl_change_info ninfo2] gls0 (* end cases *) type ('a, 'b) instance_stack = ('b * (('a option * constr list) list)) list let initial_instance_stack ids : (_, _) instance_stack = List.map (fun id -> id,[None,[]]) ids let push_one_arg arg = function [] -> anomaly (Pp.str "impossible") | (head,args) :: ctx -> ((head,(arg::args)) :: ctx) let push_arg arg stacks = List.map (fun (id,stack) -> (id,push_one_arg arg stack)) stacks let push_one_head c ids (id,stack) = let head = if Id.Set.mem id ids then Some c else None in id,(head,[]) :: stack let push_head c ids stacks = List.map (push_one_head c ids) stacks let pop_one (id,stack) = let nstack= match stack with [] -> anomaly (Pp.str "impossible") | [c] as l -> l | (Some head,args)::(head0,args0)::ctx -> let arg = applist (head,(List.rev args)) in (head0,(arg::args0))::ctx | (None,args)::(head0,args0)::ctx -> (head0,(args@args0))::ctx in id,nstack let pop_stacks stacks = List.map pop_one stacks let hrec_for fix_id per_info gls obj_id = let obj=mkVar obj_id in let typ=pf_get_hyp_typ gls obj_id in let rc,hd1=decompose_prod typ in let cind,all_args=decompose_app typ in let ind,u = destInd cind in assert (eq_ind ind per_info.per_ind); let params,args= List.chop per_info.per_nparams all_args in assert begin try List.for_all2 eq_constr params per_info.per_params with Invalid_argument _ -> false end; let hd2 = applist (mkVar fix_id,args@[obj]) in compose_lam rc (Reductionops.whd_beta gls.sigma hd2) let warn_missing_case = CWarnings.create ~name:"declmode-missing-case" ~category:"declmode" (fun () -> strbrk "missing case") let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = match tree, objs with Close_patt t,_ -> let args0 = pop_stacks args in execute_cases fix_name per_info tacnext args0 objs nhrec t gls | Skip_patt (_,t),skipped::next_objs -> let args0 = push_arg skipped args in execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls | End_patt (id,(nparams,nhyps)),[] -> begin match Id.List.assoc id args with [None,br_args] -> let all_metas = List.init (nparams + nhyps) (fun n -> mkMeta (succ n)) in let param_metas,hyp_metas = List.chop nparams all_metas in tclTHEN (tclDO nhrec (Proofview.V82.of_tactic introf)) (tacnext (applist (mkVar id, List.append param_metas (List.rev_append br_args hyp_metas)))) gls | _ -> anomaly (Pp.str "wrong stack size") end | Split_patt (ids,ind,br), casee::next_objs -> let (mind,oind) as spec = Global.lookup_inductive ind in let nparams = mind.mind_nparams in let concl=pf_concl gls in let env=pf_env gls in let ctyp=pf_unsafe_type_of gls casee in let hd,all_args = decompose_app (special_whd gls ctyp) in let ind', u = destInd hd in let _ = assert (eq_ind ind' ind) in (* just in case *) let params,real_args = List.chop nparams all_args in let abstract_obj c body = let typ=pf_unsafe_type_of gls c in lambda_create env (typ,subst_term c body) in let elim_pred = List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term casee concl)) in let case_info = Inductiveops.make_case_info env ind RegularStyle in let gen_arities = Inductive.arities_of_constructors (ind,u) spec in let f_ids typ = let sign = (prod_assum (prod_applist typ params)) in find_intro_names sign gls in let constr_args_ids = Array.map f_ids gen_arities in let case_term = mkCase(case_info,elim_pred,casee, Array.mapi (fun i _ -> mkMeta (succ i)) constr_args_ids) in let branch_tac i (recargs,bro) gls0 = let args_ids = constr_args_ids.(i) in let rec aux n = function [] -> assert (Int.equal n (Array.length recargs)); next_objs,[],nhrec | id :: q -> let objs,recs,nrec = aux (succ n) q in if recargs.(n) then (mkVar id::objs),(id::recs),succ nrec else (mkVar id::objs),recs,nrec in let objs,recs,nhrec = aux 0 args_ids in tclTHENLIST [tclMAP (fun id -> Proofview.V82.of_tactic (intro_mustbe_force id)) args_ids; begin fun gls1 -> let hrecs = List.map (fun id -> hrec_for (out_name fix_name) per_info gls1 id) recs in Proofview.V82.of_tactic (generalize hrecs) gls1 end; match bro with None -> warn_missing_case (); tacnext (mkMeta 1) | Some (sub_ids,tree) -> let br_args = List.filter (fun (id,_) -> Id.Set.mem id sub_ids) args in let construct = applist (mkConstruct(ind,succ i),params) in let p_args = push_head construct ids br_args in execute_cases fix_name per_info tacnext p_args objs nhrec tree] gls0 in tclTHENSV (refine case_term) (Array.mapi branch_tac br) gls | Split_patt (_, _, _) , [] -> anomaly ~label:"execute_cases " (Pp.str "Nothing to split") | Skip_patt _ , [] -> anomaly ~label:"execute_cases " (Pp.str "Nothing to skip") | End_patt (_,_) , _ :: _ -> anomaly ~label:"execute_cases " (Pp.str "End of branch with garbage left") let understand_my_constr env sigma c concl = let env = env in let rawc = Detyping.detype false [] env Evd.empty c in let rec frob = function | GEvar _ -> GHole (Loc.ghost,Evar_kinds.QuestionMark Evar_kinds.Expand,Misctypes.IntroAnonymous,None) | rc -> map_glob_constr frob rc in Pretyping.understand_tcc env sigma ~expected_type:(Pretyping.OfType concl) (frob rawc) let my_refine c gls = let oc = { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in Sigma.Unsafe.of_pair (c, sigma) end } in Proofview.V82.of_tactic (Tactics.New.refine oc) gls (* end focus/claim *) let end_tac et2 gls = let info = get_its_info gls in let et1,pi,ek,clauses = match info.pm_stack with Suppose_case::_ -> anomaly (Pp.str "This case should already be trapped") | Claim::_ -> error "\"end claim\" expected." | Focus_claim::_ -> error "\"end focus\" expected." | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) | [] -> anomaly (Pp.str "This case should already be trapped") in let et = match et1, et2 with | ET_Case_analysis, ET_Case_analysis -> et1 | ET_Induction, ET_Induction -> et1 | ET_Case_analysis, _ -> error "\"end cases\" expected." | ET_Induction, _ -> error "\"end induction\" expected." in tclTHEN tcl_erase_info begin match et,ek with _,EK_unknown -> tclSOLVE [Proofview.V82.of_tactic (simplest_elim pi.per_casee)] | ET_Case_analysis,EK_nodep -> tclTHEN (Proofview.V82.of_tactic (simplest_case pi.per_casee)) (default_justification (List.map mkVar clauses)) | ET_Induction,EK_nodep -> tclTHENLIST [Proofview.V82.of_tactic (generalize (pi.per_args@[pi.per_casee])); Proofview.V82.of_tactic (simple_induct (AnonHyp (succ (List.length pi.per_args)))); default_justification (List.map mkVar clauses)] | ET_Case_analysis,EK_dep tree -> execute_cases Anonymous pi (fun c -> tclTHENLIST [my_refine c; clear clauses; justification (Proofview.V82.of_tactic assumption)]) (initial_instance_stack clauses) [pi.per_casee] 0 tree | ET_Induction,EK_dep tree -> let nargs = (List.length pi.per_args) in tclTHEN (Proofview.V82.of_tactic (generalize (pi.per_args@[pi.per_casee]))) begin fun gls0 -> let fix_id = pf_get_new_id (Id.of_string "_fix") gls0 in let c_id = pf_get_new_id (Id.of_string "_main_arg") gls0 in tclTHENLIST [Proofview.V82.of_tactic (fix (Some fix_id) (succ nargs)); tclDO nargs (Proofview.V82.of_tactic introf); Proofview.V82.of_tactic (intro_mustbe_force c_id); execute_cases (Name fix_id) pi (fun c -> tclTHENLIST [clear [fix_id]; my_refine c; clear clauses; justification (Proofview.V82.of_tactic assumption)]) (initial_instance_stack clauses) [mkVar c_id] 0 tree] gls0 end end gls (* escape *) let escape_tac gls = (* spiwack: sets an empty info stack to avoid interferences. We could erase the info altogether, but that doesn't play well with the Decl_mode.focus (used in post_processing). *) let info={pm_stack=[]} in tcl_change_info info gls (* General instruction engine *) let rec do_proof_instr_gen _thus _then instr = match instr with Pthus i -> assert (not _thus); do_proof_instr_gen true _then i | Pthen i -> assert (not _then); do_proof_instr_gen _thus true i | Phence i -> assert (not (_then || _thus)); do_proof_instr_gen true true i | Pcut c -> instr_cut mk_stat_or_thesis _thus _then c | Psuffices c -> instr_suffices _then c | Prew (s,c) -> assert (not _then); instr_rew _thus s c | Pconsider (c,hyps) -> consider_tac c hyps | Pgiven hyps -> given_tac hyps | Passume hyps -> assume_tac hyps | Plet hyps -> assume_tac hyps | Pclaim st -> instr_claim false st | Pfocus st -> instr_claim true st | Ptake witl -> take_tac witl | Pdefine (id,args,body) -> define_tac id args body | Pcast (id,typ) -> cast_tac id typ | Pper (et,cs) -> per_tac et cs | Psuppose hyps -> suppose_tac hyps | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps | Pend (B_elim et) -> end_tac et | Pend _ -> anomaly (Pp.str "Not applicable") | Pescape -> escape_tac let eval_instr {instr=instr} = do_proof_instr_gen false false instr let rec preprocess pts instr = match instr with Phence i |Pthus i | Pthen i -> preprocess pts i | Psuffices _ | Pcut _ | Passume _ | Plet _ | Pclaim _ | Pfocus _ | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Pper _ | Prew _ -> check_not_per pts; true | Pescape -> check_not_per pts; true | Pcase _ | Psuppose _ | Pend (B_elim _) -> close_previous_case pts ; true | Pend bt -> close_block bt pts ; false let rec postprocess pts instr = match instr with Phence i | Pthus i | Pthen i -> postprocess pts i | Pcut _ | Psuffices _ | Passume _ | Plet _ | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> () | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ -> Decl_mode.focus pts | Pescape -> Decl_mode.focus pts; Proof_global.set_proof_mode "Classic" | Pend (B_elim ET_Induction) -> begin let pfterm = List.hd (Proof.partial_proof pts) in let { it = gls ; sigma = sigma } = Proof.V82.subgoals pts in let env = try Goal.V82.env sigma (List.hd gls) with Failure "hd" -> Global.env () in try Inductiveops.control_only_guard env pfterm; goto_current_focus_or_top () with Type_errors.TypeError(env, Type_errors.IllFormedRecBody(_,_,_,_,_)) -> anomaly (Pp.str "\"end induction\" generated an ill-formed fixpoint") end | Pend (B_elim ET_Case_analysis) -> goto_current_focus () | Pend B_proof -> Proof_global.set_proof_mode "Classic" | Pend _ -> () let do_instr raw_instr pts = let has_tactic = preprocess pts raw_instr.instr in (* spiwack: hack! [preprocess] assumes that the [pts] is indeed the current proof (and, actually so does [do_instr] later one, so it's ok to do the same here. Ideally the proof should be properly threaded through the commands here, but since the are interleaved with actions on the proof mode, which is attached to the global proof environment, it is not possible without heavy lifting. *) let pts = Proof_global.give_me_the_proof () in let pts = if has_tactic then let { it=gls ; sigma=sigma; } = Proof.V82.subgoals pts in let gl = { it=List.hd gls ; sigma=sigma; } in let env= pf_env gl in let ist = {ltacvars = Id.Set.empty; genv = env} in let glob_instr = intern_proof_instr ist raw_instr in let instr = interp_proof_instr (get_its_info gl) env sigma glob_instr in let (pts',_) = Proof.run_tactic (Global.env()) (Proofview.V82.tactic (tclTHEN (eval_instr instr) clean_tmp)) pts in pts' else pts in Proof_global.simple_with_current_proof (fun _ _ -> pts); postprocess pts raw_instr.instr let proof_instr raw_instr = let p = Proof_global.give_me_the_proof () in do_instr raw_instr p (* (* STUFF FOR ITERATED RELATIONS *) let decompose_bin_app t= let hd,args = destApp let identify_transitivity_lemma c = let varx,tx,c1 = destProd c in let vary,ty,c2 = destProd (pop c1) in let varz,tz,c3 = destProd (pop c2) in let _,p1,c4 = destProd (pop c3) in let _,lp2,lp3 = destProd (pop c4) in let p2=pop lp2 in let p3=pop lp3 in *) coq-8.6/tools/0000755000175000017500000000000013022274260012617 5ustar mdenesmdenescoq-8.6/tools/check-translate0000755000175000017500000000171713022274260015623 0ustar mdenesmdenes#!/bin/sh echo -------------- Producing translated files --------------------- rm */*/*.v8 >& /dev/null make COQ_XML=-translate theories || { echo ---- Failed to translate; exit 1; } if [ -e translated ]; then rm -r translated; fi if [ -e successful-translation ]; then rm -r successful-translation; fi if [ -e failed-translation ]; then rm -r failed-translation; fi mv theories translated mkdir theories echo -------------------- Upgrading files -------------------------- cd translated for i in */*.v do mkdir ../theories/`dirname $i` >& /dev/null mv "$i"8 ../theories/$i done cd .. echo --------------- Recompiling translated files ------------------ make theories || { echo ---- Failed to recompile; mv theories failed-translation; mv translated theories; exit 1; } echo ----------------- Recompilation successful -------------------- if [ -e successful-translation ]; then rm -r successful-translation; fi mv theories successful-translation; mv translated theories coq-8.6/tools/gallina.ml0000644000175000017500000000343013022274260014560 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* begin flush !chan_out; close_in chan_in; if not !option_stdout then close_out !chan_out end with Sys_error _ -> () let traite_stdin () = try let buf = Lexing.from_channel stdin in try while true do Gallina_lexer.action buf done with Fin_fichier -> flush !chan_out with Sys_error _ -> () let _ = let lg_command = Array.length Sys.argv in if lg_command < 2 then begin output_string stderr "Usage: gallina [-] [-stdout] file1 file2 ...\n"; flush stderr; exit 1 end; let treat = function | "-" -> option_moins := true | "-stdout" -> option_stdout := true | "-nocomments" -> comments := false | f -> if Filename.check_suffix f ".v" then vfiles := (Filename.chop_suffix f ".v") :: !vfiles in Array.iter treat Sys.argv; if !option_moins then traite_stdin () else List.iter traite_fichier !vfiles coq-8.6/tools/coqmktop.ml0000644000175000017500000002446013022274260015014 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Str.split spaces str let (/) = Filename.concat (** Which user files do we support (and propagate to ocamlopt) ? *) let supported_suffix f = match CUnix.get_extension f with | ".ml" | ".cmx" | ".cmo" | ".cmxa" | ".cma" | ".c" -> true | _ -> false (** From bytecode extension to native *) let native_suffix f = match CUnix.get_extension f with | ".cmo" -> (Filename.chop_suffix f ".cmo") ^ ".cmx" | ".cma" -> (Filename.chop_suffix f ".cma") ^ ".cmxa" | ".a" -> f | _ -> failwith ("File "^f^" has not extension .cmo, .cma or .a") (** Transforms a file name in the corresponding Caml module name. *) let module_of_file name = String.capitalize (try Filename.chop_extension name with Invalid_argument _ -> name) (** Run a command [prog] with arguments [args]. We do not use [Sys.command] anymore, see comment in [CUnix.sys_command]. *) let run_command prog args = match CUnix.sys_command prog args with | Unix.WEXITED 127 -> failwith ("no such command "^prog) | Unix.WEXITED n -> n | Unix.WSIGNALED n -> failwith (prog^" killed by signal "^string_of_int n) | Unix.WSTOPPED n -> failwith (prog^" stopped by signal "^string_of_int n) (** {6 Coqmktop options} *) let opt = ref false let top = ref false let echo = ref false let no_start = ref false let is_ocaml4 = Coq_config.caml_version.[0] <> '3' let is_camlp5 = Coq_config.camlp4 = "camlp5" (** {6 Includes options} *) (** Since the Coq core .cma are given with their relative paths (e.g. "lib/clib.cma"), we only need to include directories mentionned in the temp main ml file below (for accessing the corresponding .cmi). *) let std_includes basedir = let rebase d = match basedir with None -> d | Some base -> base / d in ["-I"; rebase "."; "-I"; rebase "lib"; "-I"; rebase "toplevel"; "-I"; rebase "kernel/byterun"; "-I"; Envars.camlp4lib () ] @ (if is_ocaml4 then ["-I"; "+compiler-libs"] else []) (** For the -R option, visit all directories under [dir] and add corresponding -I to the [opts] option list (in reversed order) *) let incl_all_subdirs dir opts = let l = ref opts in let add f = l := f :: "-I" :: !l in let rec traverse dir = if Sys.file_exists dir && Sys.is_directory dir then let () = add dir in let subdirs = try Sys.readdir dir with any -> [||] in Array.iter (fun f -> traverse (dir/f)) subdirs in traverse dir; !l (** {6 Objects to link} *) (** NB: dynlink is now always linked, it is used for loading plugins and compiled vm code (see native-compiler). We now reject platforms with ocamlopt but no dynlink.cmxa during ./configure, and give instructions there about how to build a dummy dynlink.cmxa, cf. dev/dynlink.ml. *) (** OCaml + CamlpX libraries *) let ocaml_libs = ["str.cma";"unix.cma";"nums.cma";"dynlink.cma";"threads.cma"] let camlp4_libs = if is_camlp5 then ["gramlib.cma"] else ["camlp4lib.cma"] let libobjs = ocaml_libs @ camlp4_libs (** Toplevel objects *) let ocaml_topobjs = if is_ocaml4 then ["ocamlcommon.cma";"ocamlbytecomp.cma";"ocamltoplevel.cma"] else ["toplevellib.cma"] let camlp4_topobjs = if is_camlp5 then ["camlp5_top.cma"; "pa_o.cmo"; "pa_extend.cmo"] else [ "Camlp4Top.cmo"; "Camlp4Parsers/Camlp4OCamlRevisedParser.cmo"; "Camlp4Parsers/Camlp4OCamlParser.cmo"; "Camlp4Parsers/Camlp4GrammarParser.cmo" ] let topobjs = ocaml_topobjs @ camlp4_topobjs (** Coq Core objects *) let copts = (split_list Coq_config.osdeplibs) @ (split_list Tolink.copts) let core_objs = split_list Tolink.core_objs let core_libs = split_list Tolink.core_libs (** Build the list of files to link and the list of modules names *) let files_to_link userfiles = let top = if !top then topobjs else [] in let modules = List.map module_of_file (top @ core_objs @ userfiles) in let objs = libobjs @ top @ core_libs in let objs' = (if !opt then List.map native_suffix objs else objs) @ userfiles in (modules, objs') (** {6 Parsing of the command-line} *) let usage () = prerr_endline "Usage: coqmktop files\ \nFlags are:\ \n -coqlib dir Specify where the Coq object files are\ \n -ocamlfind dir Specify where the ocamlfind binary is\ \n -camlp4bin dir Specify where the Camlp4/5 binaries are\ \n -o exec-file Specify the name of the resulting toplevel\ \n -boot Run in boot mode\ \n -echo Print calls to external commands\ \n -opt Compile in native code\ \n -top Build Coq on a OCaml toplevel (incompatible with -opt)\ \n -R dir Add recursively dir to OCaml search path\ \n"; exit 1 let parse_args () = let rec parse (op,fl) = function | [] -> List.rev op, List.rev fl (* Directories *) | "-coqlib" :: d :: rem -> Flags.coqlib_spec := true; Flags.coqlib := d ; parse (op,fl) rem | "-ocamlfind" :: d :: rem -> Flags.ocamlfind_spec := true; Flags.ocamlfind := d ; parse (op,fl) rem | "-camlp4bin" :: d :: rem -> Flags.camlp4bin_spec := true; Flags.camlp4bin := d ; parse (op,fl) rem | "-R" :: d :: rem -> parse (incl_all_subdirs d op,fl) rem | ("-coqlib"|"-camlbin"|"-camlp4bin"|"-R") :: [] -> usage () (* Boolean options of coqmktop *) | "-boot" :: rem -> Flags.boot := true; parse (op,fl) rem | "-opt" :: rem -> opt := true ; parse (op,fl) rem | "-top" :: rem -> top := true ; parse (op,fl) rem | "-no-start" :: rem -> no_start:=true; parse (op, fl) rem | "-echo" :: rem -> echo := true ; parse (op,fl) rem | ("-v8"|"-full" as o) :: rem -> Printf.eprintf "warning: option %s deprecated\n" o; parse (op,fl) rem (* Extra options with arity 0 or 1, directly passed to ocamlc/ocamlopt *) | ("-noassert"|"-compact"|"-g"|"-p"|"-thread"|"-dtypes" as o) :: rem -> parse (o::op,fl) rem | ("-cclib"|"-ccopt"|"-I"|"-o"|"-w" as o) :: rem' -> begin match rem' with | a :: rem -> parse (a::o::op,fl) rem | [] -> usage () end | ("-h"|"-help"|"--help") :: _ -> usage () | f :: rem when supported_suffix f -> parse (op,f::fl) rem | f :: _ -> prerr_endline ("Don't know what to do with " ^ f); exit 1 in parse ([],[]) (List.tl (Array.to_list Sys.argv)) (** {6 Temporary main file} *) (** remove the temporary main file *) let clean file = let rm f = if Sys.file_exists f then Sys.remove f in let basename = Filename.chop_suffix file ".ml" in if not !echo then begin rm file; rm (basename ^ ".o"); rm (basename ^ ".cmi"); rm (basename ^ ".cmo"); rm (basename ^ ".cmx") end (** Initializes the kind of loading in the main program *) let declare_loading_string () = if not !top then "Mltop.remove ();;" else "begin try\ \n (* Enable rectypes in the toplevel if it has the directive #rectypes *)\ \n begin match Hashtbl.find Toploop.directive_table \"rectypes\" with\ \n | Toploop.Directive_none f -> f ()\ \n | _ -> ()\ \n end\ \n with\ \n | Not_found -> ()\ \n end;;\ \n\ \n let ppf = Format.std_formatter;;\ \n Mltop.set_top\ \n {Mltop.load_obj=\ \n (fun f -> if not (Topdirs.load_file ppf f)\ \n then CErrors.error (\"Could not load plugin \"^f));\ \n Mltop.use_file=Topdirs.dir_use ppf;\ \n Mltop.add_dir=Topdirs.dir_directory;\ \n Mltop.ml_loop=(fun () -> Toploop.loop ppf) };;\ \n" (** create a temporary main file to link *) let create_tmp_main_file modules = let main_name,oc = Filename.open_temp_file "coqmain" ".ml" in try (* Add the pre-linked modules *) output_string oc "List.iter Mltop.add_known_module [\""; output_string oc (String.concat "\";\"" modules); output_string oc "\"];;\n"; (* Initializes the kind of loading *) output_string oc (declare_loading_string()); (* Start the toplevel loop *) if not !no_start then output_string oc "Coqtop.start();;\n"; close_out oc; main_name with reraise -> clean main_name; raise reraise (** {6 Main } *) let main () = let (options, userfiles) = parse_args () in (* Directories: *) let () = Envars.set_coqlib ~fail:CErrors.error in let basedir = if !Flags.boot then None else Some (Envars.coqlib ()) in (* Which ocaml compiler to invoke *) let prog = if !opt then "opt" else "ocamlc" in (* Which arguments ? *) if !opt && !top then failwith "no custom toplevel in native code !"; let flags = if !opt then [] else Coq_config.vmbyteflags in let topstart = if !top then [ "topstart.cmo" ] else [] in let (modules, tolink) = files_to_link userfiles in let main_file = create_tmp_main_file modules in try (* - We add topstart.cmo explicitly because we shunted ocamlmktop wrapper. - With the coq .cma, we MUST use the -linkall option. *) let args = "-linkall" :: "-rectypes" :: "-w" :: "-31" :: flags @ copts @ options @ (std_includes basedir) @ tolink @ [ main_file ] @ topstart in if !echo then begin let command = String.concat " " (Envars.ocamlfind ()::prog::args) in print_endline command; print_endline ("(command length is " ^ (string_of_int (String.length command)) ^ " characters)"); flush Pervasives.stdout end; let exitcode = run_command (Envars.ocamlfind ()) (prog::args) in clean main_file; exitcode with reraise -> clean main_file; raise reraise let pr_exn = function | Failure msg -> msg | Unix.Unix_error (err,fn,arg) -> fn^" "^arg^" : "^Unix.error_message err | any -> Printexc.to_string any let _ = try exit (main ()) with any -> Printf.eprintf "Error: %s\n" (pr_exn any); exit 1 coq-8.6/tools/coqdep_boot.ml0000644000175000017500000000405213022274260015450 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* option_natdynlk := false; parse ll | "-c" :: ll -> option_c := true; parse ll | "-boot" :: ll -> parse ll (* We're already in boot mode by default *) | "-mldep" :: ocamldep :: ll -> option_mldep := Some ocamldep; option_c := true; parse ll | "-I" :: r :: ll -> (* To solve conflict (e.g. same filename in kernel and checker) we allow to state an explicit order *) add_caml_dir r; norec_dirs := StrSet.add r !norec_dirs; parse ll | f :: ll -> treat_file None f; parse ll | [] -> () let _ = let () = option_boot := true in if Array.length Sys.argv < 2 then exit 1; parse (List.tl (Array.to_list Sys.argv)); if !option_c then begin add_rec_dir_import add_known "." []; add_rec_dir_import (fun _ -> add_caml_known) "." ["Coq"]; end else begin add_rec_dir_import add_known "theories" ["Coq"]; add_rec_dir_import add_known "plugins" ["Coq"]; add_caml_dir "tactics"; add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; end; if !option_c then mL_dependencies (); coq_dependencies () coq-8.6/tools/mkwinapp.ml0000644000175000017500000000571013022274260015002 0ustar mdenesmdenes(* OCaml-Win32 * mkwinapp.ml * Copyright (c) 2002-2004 by Harry Chomsky * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU Library General Public * License along with this library; if not, write to the Free * Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (********************************************************************* * This program alters an .exe file to make it use the "windows subsystem" * instead of the "console subsystem". In other words, when Windows runs * the program, it will not create a console for it. *) (* Pierre Letouzey 23/12/2010 : modification to allow selecting the subsystem to use instead of just setting the windows subsystem *) (* This tool can be run directly via : ocaml unix.cma mkwinapp.ml [-set|-unset] *) exception Invalid_file_format let input_word ic = let lo = input_byte ic in let hi = input_byte ic in (hi lsl 8) + lo let find_pe_header ic = seek_in ic 0x3C; let peheader = input_word ic in seek_in ic peheader; if input_char ic <> 'P' then raise Invalid_file_format; if input_char ic <> 'E' then raise Invalid_file_format; peheader let find_optional_header ic = let peheader = find_pe_header ic in let coffheader = peheader + 4 in seek_in ic (coffheader + 16); let optsize = input_word ic in if optsize < 96 then raise Invalid_file_format; let optheader = coffheader + 20 in seek_in ic optheader; let magic = input_word ic in if magic <> 0x010B && magic <> 0x020B then raise Invalid_file_format; optheader let change flag ic oc = let optheader = find_optional_header ic in seek_out oc (optheader + 64); for i = 1 to 4 do output_byte oc 0 done; output_byte oc (if flag then 2 else 3) let usage () = print_endline "Alters a Win32 executable file to use the Windows subsystem or not."; print_endline "Usage: mkwinapp [-set|-unset] "; print_endline "Giving no option is equivalent to -set"; exit 1 let main () = let n = Array.length Sys.argv - 1 in if not (n = 1 || n = 2) then usage (); let flag = if n = 1 then true else if Sys.argv.(1) = "-set" then true else if Sys.argv.(1) = "-unset" then false else usage () in let filename = Sys.argv.(n) in let f = Unix.openfile filename [Unix.O_RDWR] 0 in let ic = Unix.in_channel_of_descr f and oc = Unix.out_channel_of_descr f in change flag ic oc let _ = main () coq-8.6/tools/gallina_lexer.mll0000644000175000017500000001136213022274260016136 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 then comment lexbuf } | "*)" [' ''\t']*'\n' { (if !comments then print (Lexing.lexeme lexbuf)); comment_depth := pred !comment_depth; if !comment_depth > 0 then comment lexbuf } | eof { raise Fin_fichier } | _ { (if !comments then print (Lexing.lexeme lexbuf)); comment lexbuf } and skip_comment = parse | "(*" { comment_depth := succ !comment_depth; skip_comment lexbuf } | "*)" { comment_depth := pred !comment_depth; if !comment_depth > 0 then skip_comment lexbuf } | eof { raise Fin_fichier } | _ { skip_comment lexbuf } and body_def = parse | [^'.']* ":=" { print (Lexing.lexeme lexbuf); () } | _ { print (Lexing.lexeme lexbuf); body lexbuf } and body = parse | enddot { print ".\n"; skip_proof lexbuf } | ":=" { print ".\n"; skip_proof lexbuf } | "(*" { print "(*"; comment_depth := 1; comment lexbuf; body lexbuf } | eof { raise Fin_fichier } | _ { print (Lexing.lexeme lexbuf); body lexbuf } and body_pgm = parse | enddot { print ".\n"; skip_proof lexbuf } | "(*" { print "(*"; comment_depth := 1; comment lexbuf; body_pgm lexbuf } | eof { raise Fin_fichier } | _ { print (Lexing.lexeme lexbuf); body_pgm lexbuf } and skip_until_point = parse | '.' '\n' { () } | enddot { end_of_line lexbuf } | "(*" { comment_depth := 1; skip_comment lexbuf; skip_until_point lexbuf } | eof { raise Fin_fichier } | _ { skip_until_point lexbuf } and end_of_line = parse | [' ' '\t' ]* { end_of_line lexbuf } | '\n' { () } | eof { raise Fin_fichier } | _ { print (Lexing.lexeme lexbuf) } and skip_proof = parse | "Save." { end_of_line lexbuf } | "Save" space { skip_until_point lexbuf } | "Qed." { end_of_line lexbuf } | "Qed" space { skip_until_point lexbuf } | "Defined." { end_of_line lexbuf } | "Defined" space { skip_until_point lexbuf } | "Abort." { end_of_line lexbuf } | "Abort" space { skip_until_point lexbuf } | "Proof" space { skip_until_point lexbuf } | "Proof" [' ' '\t']* '.' { skip_proof lexbuf } | "(*" { comment_depth := 1; skip_comment lexbuf; skip_proof lexbuf } | eof { raise Fin_fichier } | _ { skip_proof lexbuf } coq-8.6/tools/coqdep_common.mli0000644000175000017500000000624613022274260016155 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string list val option_c : bool ref val option_noglob : bool ref val option_boot : bool ref val option_natdynlk : bool ref val option_mldep : string option ref val norec_dirs : StrSet.t ref val suffixe : string ref type dir = string option val get_extension : string -> string list -> string * string val basename_noext : string -> string val mlAccu : (string * string * dir) list ref val mliAccu : (string * dir) list ref val mllibAccu : (string * dir) list ref val vAccu : (string * string) list ref val addQueue : 'a list ref -> 'a -> unit val add_ml_known : string -> dir -> string -> unit val iter_ml_known : (string -> dir -> unit) -> unit val search_ml_known : string -> dir option val add_mli_known : string -> dir -> string -> unit val iter_mli_known : (string -> dir -> unit) -> unit val search_mli_known : string -> dir option val add_mllib_known : string -> dir -> string -> unit val search_mllib_known : string -> dir option val search_v_known : ?from:string list -> string list -> string option val file_name : string -> string option -> string val escape : string -> string val canonize : string -> string val mL_dependencies : unit -> unit val coq_dependencies : unit -> unit val suffixes : 'a list -> 'a list list val add_known : bool -> string -> string list -> string -> unit val add_coqlib_known : bool -> string -> string list -> string -> unit val add_caml_known : string -> string list -> string -> unit val add_caml_dir : string -> unit (** Simply add this directory and imports it, no subdirs. This is used by the implicit adding of the current path. *) val add_norec_dir_import : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit (** -Q semantic: go in subdirs but only full logical paths are known. *) val add_rec_dir_no_import : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit (** -R semantic: go in subdirs and suffixes of logical paths are known. *) val add_rec_dir_import : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit val add_rec_uppercase_subdirs : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit val treat_file : dir -> string -> unit val error_cannot_parse : string -> int * int -> 'a coq-8.6/tools/coqdep.ml0000644000175000017500000004372413022274260014436 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (Filename.dirname (file_name f d')) then begin eprintf "*** Warning : the file %s is defined twice!\n" (f ^ suf); flush stderr end with Not_found -> () end; Hashtbl.add tab f d in iter check let sort () = let seen = Hashtbl.create 97 in let rec loop file = let file = canonize file in if not (Hashtbl.mem seen file) then begin Hashtbl.add seen file (); let cin = open_in (file ^ ".v") in let lb = Lexing.from_channel cin in try while true do match coq_action lb with | Require (from, sl) -> List.iter (fun s -> match search_v_known ?from s with | None -> () | Some f -> loop f) sl | _ -> () done with Fin_fichier -> close_in cin; printf "%s%s " file !suffixe end in List.iter (fun (name,_) -> loop name) !vAccu let (dep_tab : (string,string list) Hashtbl.t) = Hashtbl.create 151 let mL_dep_list b f = try Hashtbl.find dep_tab f with Not_found -> let deja_vu = ref ([] : string list) in try let chan = open_in f in let buf = Lexing.from_channel chan in try while true do let (Use_module str) = caml_action buf in if str = b then begin eprintf "*** Warning : in file %s the" f; eprintf " notation %s. is useless !\n" b; flush stderr end else if not (List.mem str !deja_vu) then addQueue deja_vu str done; [] with Fin_fichier -> begin close_in chan; let rl = List.rev !deja_vu in Hashtbl.add dep_tab f rl; rl end with Sys_error _ -> [] let affiche_Declare f dcl = printf "\n*** In file %s: \n" f; printf "Declare ML Module"; List.iter (fun str -> printf " \"%s\"" str) dcl; printf ".\n"; flush stdout let warning_Declare f dcl = eprintf "*** Warning : in file %s, the ML modules" f; eprintf " declaration should be\n"; eprintf "*** Declare ML Module"; List.iter (fun str -> eprintf " \"%s\"" str) dcl; eprintf ".\n"; flush stderr let traite_Declare f = let decl_list = ref ([] : string list) in let rec treat = function | s :: ll -> let s' = basename_noext s in (match search_ml_known s with | Some mldir when not (List.mem s' !decl_list) -> let fullname = file_name s' mldir in let depl = mL_dep_list s (fullname ^ ".ml") in treat depl; decl_list := s :: !decl_list | _ -> ()); treat ll | [] -> () in try let chan = open_in f in let buf = Lexing.from_channel chan in begin try while true do let tok = coq_action buf in (match tok with | Declare sl -> decl_list := []; treat sl; decl_list := List.rev !decl_list; if !option_D then affiche_Declare f !decl_list else if !decl_list <> sl then warning_Declare f !decl_list | _ -> ()) done with Fin_fichier -> () end; close_in chan with Sys_error _ -> () let declare_dependencies () = List.iter (fun (name,_) -> traite_Declare (name^".v"); flush stdout) (List.rev !vAccu) (** DAGs guaranteed to be transitive reductions *) module DAG (Node : Set.OrderedType) : sig type node = Node.t type t val empty : t val add_transitive_edge : node -> node -> t -> t val iter : (node -> node -> unit) -> t -> unit end = struct type node = Node.t module NSet = Set.Make(Node) module NMap = Map.Make(Node) (** Associate to a node the set of its neighbours *) type _t = NSet.t NMap.t (** Optimisation: construct the reverse graph at the same time *) type t = { dir : _t; rev : _t; } let node_equal x y = Node.compare x y = 0 let add_edge x y graph = let set = try NMap.find x graph with Not_found -> NSet.empty in NMap.add x (NSet.add y set) graph let remove_edge x y graph = let set = try NMap.find x graph with Not_found -> NSet.empty in let set = NSet.remove y set in if NSet.is_empty set then NMap.remove x graph else NMap.add x set graph let has_edge x y graph = let set = try NMap.find x graph with Not_found -> NSet.empty in NSet.mem y set let connected x y graph = let rec aux rem seen = if NSet.is_empty rem then false else let x = NSet.choose rem in if node_equal x y then true else let rem = NSet.remove x rem in if NSet.mem x seen then aux rem seen else let seen = NSet.add x seen in let next = try NMap.find x graph with Not_found -> NSet.empty in let rem = NSet.union next rem in aux rem seen in aux (NSet.singleton x) NSet.empty (** Check whether there is a path from a to b going through the edge x -> y. *) let connected_through a b x y graph = let rec aux rem seen = if NMap.is_empty rem then false else let (n, through) = NMap.choose rem in if node_equal n b && through then true else let rem = NMap.remove n rem in let is_seen = try Some (NMap.find n seen) with Not_found -> None in match is_seen with | None -> let seen = NMap.add n through seen in let next = try NMap.find n graph with Not_found -> NSet.empty in let is_x = node_equal n x in let push m accu = let through = through || (is_x && node_equal m y) in NMap.add m through accu in let rem = NSet.fold push next rem in aux rem seen | Some false -> (** The path we took encountered x -> y but not the one in seen *) if through then aux (NMap.add n true rem) (NMap.add n true seen) else aux rem seen | Some true -> aux rem seen in aux (NMap.singleton a false) NMap.empty let closure x graph = let rec aux rem seen = if NSet.is_empty rem then seen else let x = NSet.choose rem in let rem = NSet.remove x rem in if NSet.mem x seen then aux rem seen else let seen = NSet.add x seen in let next = try NMap.find x graph with Not_found -> NSet.empty in let rem = NSet.union next rem in aux rem seen in aux (NSet.singleton x) NSet.empty let empty = { dir = NMap.empty; rev = NMap.empty; } (** Online transitive reduction algorithm *) let add_transitive_edge x y graph = if connected x y graph.dir then graph else let dir = add_edge x y graph.dir in let rev = add_edge y x graph.rev in let graph = { dir; rev; } in let ancestors = closure x rev in let descendents = closure y dir in let fold_ancestor a graph = let fold_descendent b graph = let to_remove = has_edge a b graph.dir in let to_remove = to_remove && not (node_equal x a && node_equal y b) in let to_remove = to_remove && connected_through a b x y graph.dir in if to_remove then let dir = remove_edge a b graph.dir in let rev = remove_edge b a graph.rev in { dir; rev; } else graph in NSet.fold fold_descendent descendents graph in NSet.fold fold_ancestor ancestors graph let iter f graph = let iter x set = NSet.iter (fun y -> f x y) set in NMap.iter iter graph.dir end module Graph = struct (** Dumping a dependency graph **) module DAG = DAG(struct type t = string let compare = compare end) (** TODO: we should share this code with Coqdep_common *) module VData = struct type t = string list option * string list let compare = Pervasives.compare end module VCache = Set.Make(VData) let treat_coq_file chan = let buf = Lexing.from_channel chan in let deja_vu_v = ref VCache.empty in let deja_vu_ml = ref StrSet.empty in let mark_v_done from acc str = let seen = VCache.mem (from, str) !deja_vu_v in if not seen then let () = deja_vu_v := VCache.add (from, str) !deja_vu_v in match search_v_known ?from str with | None -> acc | Some file_str -> (canonize file_str, !suffixe) :: acc else acc in let rec loop acc = let token = try Some (coq_action buf) with Fin_fichier -> None in match token with | None -> acc | Some action -> let acc = match action with | Require (from, strl) -> List.fold_left (fun accu v -> mark_v_done from accu v) acc strl | Declare sl -> let declare suff dir s = let base = file_name s dir in let opt = if !option_natdynlk then " " ^ base ^ ".cmxs" else "" in (escape base, suff ^ opt) in let decl acc str = let s = basename_noext str in if not (StrSet.mem s !deja_vu_ml) then let () = deja_vu_ml := StrSet.add s !deja_vu_ml in match search_mllib_known s with | Some mldir -> (declare ".cma" mldir s) :: acc | None -> match search_ml_known s with | Some mldir -> (declare ".cmo" mldir s) :: acc | None -> acc else acc in List.fold_left decl acc sl | Load str -> let str = Filename.basename str in let seen = VCache.mem (None, [str]) !deja_vu_v in if not seen then let () = deja_vu_v := VCache.add (None, [str]) !deja_vu_v in match search_v_known [str] with | None -> acc | Some file_str -> (canonize file_str, ".v") :: acc else acc | AddLoadPath _ | AddRecLoadPath _ -> acc (** TODO *) in loop acc in loop [] let treat_coq_file f = let chan = try Some (open_in f) with Sys_error _ -> None in match chan with | None -> [] | Some chan -> try let ans = treat_coq_file chan in let () = close_in chan in ans with Syntax_error (i, j) -> close_in chan; error_cannot_parse f (i, j) type graph = | Element of string | Subgraph of string * graph list let rec insert_graph name path graphs = match path, graphs with | [] , graphs -> (Element name) :: graphs | (box :: boxes), (Subgraph (hd, names)) :: tl when hd = box -> Subgraph (hd, insert_graph name boxes names) :: tl | _, hd :: tl -> hd :: (insert_graph name path tl) | (box :: boxes), [] -> [ Subgraph (box, insert_graph name boxes []) ] let print_graphs chan graph = let rec print_aux name = function | [] -> name | (Element str) :: tl -> fprintf chan "\"%s\";\n" str; print_aux name tl | Subgraph (box, names) :: tl -> fprintf chan "subgraph cluster%n {\nlabel=\"%s\";\n" name box; let name = print_aux (name + 1) names in fprintf chan "}\n"; print_aux name tl in ignore (print_aux 0 graph) let rec pop_common_prefix = function | [Subgraph (_, graphs)] -> pop_common_prefix graphs | graphs -> graphs let split_path = Str.split (Str.regexp "/") let rec pop_last = function | [] -> [] | [ x ] -> [] | x :: xs -> x :: pop_last xs let get_boxes path = pop_last (split_path path) let insert_raw_graph file = insert_graph file (get_boxes file) let rec get_dependencies name args = let vdep = treat_coq_file (name ^ ".v") in let fold (deps, graphs, alseen) (dep, _) = let dag = DAG.add_transitive_edge name dep deps in if not (List.mem dep alseen) then get_dependencies dep (dag, insert_raw_graph dep graphs, dep :: alseen) else (dag, graphs, alseen) in List.fold_left fold args vdep let coq_dependencies_dump chan dumpboxes = let (deps, graphs, _) = List.fold_left (fun ih (name, _) -> get_dependencies name ih) (DAG.empty, List.fold_left (fun ih (file, _) -> insert_raw_graph file ih) [] !vAccu, List.map fst !vAccu) !vAccu in fprintf chan "digraph dependencies {\n"; flush chan; if dumpboxes then print_graphs chan (pop_common_prefix graphs) else List.iter (fun (name, _) -> fprintf chan "\"%s\"[label=\"%s\"]\n" name (basename_noext name)) !vAccu; DAG.iter (fun name dep -> fprintf chan "\"%s\" -> \"%s\"\n" dep name) deps; fprintf chan "}\n" end let usage () = eprintf " usage: coqdep [options] +\n"; eprintf " options:\n"; eprintf " -c : Also print the dependencies of caml modules (=ocamldep).\n"; (* Does not work anymore *) (* eprintf " -w : Print informations on missing or wrong \"Declare ML Module\" commands in coq files.\n"; *) (* Does not work anymore: *) (* eprintf " -D : Prints the missing ocmal module names. No dependency computed.\n"; *) eprintf " -boot : For coq developpers, prints dependencies over coq library files (omitted by default).\n"; eprintf " -sort : output the given file name ordered by dependencies\n"; eprintf " -noglob | -no-glob : \n"; eprintf " -I dir -as logname : add (non recursively) dir to coq load path under logical name logname\n"; eprintf " -I dir : add (non recursively) dir to ocaml path\n"; eprintf " -R dir -as logname : add and import dir recursively to coq load path under logical name logname\n"; (* deprecate? *) eprintf " -R dir logname : add and import dir recursively to coq load path under logical name logname\n"; eprintf " -Q dir logname : add (recusively) and open (non recursively) dir to coq load path under logical name logname\n"; eprintf " -dumpgraph f : print a dot dependency graph in file 'f'\n"; eprintf " -dumpgraphbox f : print a dot dependency graph box in file 'f'\n"; eprintf " -exclude-dir dir : skip subdirectories named 'dir' during -R/-Q search\n"; eprintf " -coqlib dir : set the coq standard library directory\n"; eprintf " -suffix s : \n"; eprintf " -slash : deprecated, no effect\n"; exit 1 let split_period = Str.split (Str.regexp (Str.quote ".")) let rec parse = function | "-c" :: ll -> option_c := true; parse ll | "-D" :: ll -> option_D := true; parse ll | "-w" :: ll -> option_w := true; parse ll | "-boot" :: ll -> option_boot := true; parse ll | "-sort" :: ll -> option_sort := true; parse ll | ("-noglob" | "-no-glob") :: ll -> option_noglob := true; parse ll | "-I" :: r :: ll -> add_caml_dir r; parse ll | "-I" :: [] -> usage () | "-R" :: r :: ln :: ll -> add_rec_dir_import add_known r (split_period ln); parse ll | "-Q" :: r :: ln :: ll -> add_rec_dir_no_import add_known r (split_period ln); parse ll | "-R" :: ([] | [_]) -> usage () | "-dumpgraph" :: f :: ll -> option_dump := Some (false, f); parse ll | "-dumpgraphbox" :: f :: ll -> option_dump := Some (true, f); parse ll | "-exclude-dir" :: r :: ll -> System.exclude_directory r; parse ll | "-exclude-dir" :: [] -> usage () | "-coqlib" :: r :: ll -> Flags.coqlib_spec := true; Flags.coqlib := r; parse ll | "-coqlib" :: [] -> usage () | "-suffix" :: s :: ll -> suffixe := s ; parse ll | "-suffix" :: [] -> usage () | "-slash" :: ll -> Printf.eprintf "warning: option -slash has no effect and is deprecated.\n"; parse ll | ("-h"|"--help"|"-help") :: _ -> usage () | f :: ll -> treat_file None f; parse ll | [] -> () let coqdep () = if Array.length Sys.argv < 2 then usage (); parse (List.tl (Array.to_list Sys.argv)); (* Add current dir with empty logical path if not set by options above. *) (try ignore (Coqdep_common.find_dir_logpath (Sys.getcwd())) with Not_found -> add_norec_dir_import add_known "." []); if not Coq_config.has_natdynlink then option_natdynlk := false; (* NOTE: These directories are searched from last to first *) if !option_boot then begin add_rec_dir_import add_known "theories" ["Coq"]; add_rec_dir_import add_known "plugins" ["Coq"]; add_caml_dir "tactics"; add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; end else begin Envars.set_coqlib ~fail:CErrors.error; let coqlib = Envars.coqlib () in add_rec_dir_import add_coqlib_known (coqlib//"theories") ["Coq"]; add_rec_dir_import add_coqlib_known (coqlib//"plugins") ["Coq"]; let user = coqlib//"user-contrib" in if Sys.file_exists user then add_rec_dir_no_import add_coqlib_known user []; List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) (Envars.xdg_dirs (fun x -> Feedback.msg_warning (Pp.str x))); List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) Envars.coqpath; end; List.iter (fun (f,d) -> add_mli_known f d ".mli") !mliAccu; List.iter (fun (f,d) -> add_mllib_known f d ".mllib") !mllibAccu; List.iter (fun (f,suff,d) -> add_ml_known f d suff) !mlAccu; warning_mult ".mli" iter_mli_known; warning_mult ".ml" iter_ml_known; if !option_sort then begin sort (); exit 0 end; if !option_c && not !option_D then mL_dependencies (); if not !option_D then coq_dependencies (); if !option_w || !option_D then declare_dependencies (); begin match !option_dump with | None -> () | Some (box, file) -> let chan = open_out file in try Graph.coq_dependencies_dump chan box; close_out chan with e -> close_out chan; raise e end let _ = try coqdep () with CErrors.UserError(s,p) -> let pp = if s <> "_" then Pp.(str s ++ str ": " ++ p) else p in Feedback.msg_error pp coq-8.6/tools/gallina-syntax.el0000644000175000017500000013012113022274260016072 0ustar mdenesmdenes;; gallina-syntax.el Font lock expressions for Coq ;; Copyright (C) 1997-2007 LFCS Edinburgh. ;; Authors: Thomas Kleymann, Healfdene Goguen, Pierre Courtieu ;; License: GPL (GNU GENERAL PUBLIC LICENSE) ;; Maintainer: Pierre Courtieu ;; gallina-syntax.el,v 9.9 2008/07/21 15:14:58 pier Exp ;(require 'proof-syntax) ;(require 'proof-utils) ; proof-locate-executable (require 'gallina-db) ;;; keyword databases (defcustom coq-user-tactics-db nil "User defined tactic information. See `coq-syntax-db' for syntax. It is not necessary to add your own tactics here (it is not needed by the synchronizing/backtracking system). You may however do so for the following reasons: 1 your tactics will be colorized by font-lock 2 your tactics will be added to the menu and to completion when calling \\[coq-insert-tactic] 3 you may define an abbreviation for your tactic." :type '(repeat sexp) :group 'coq) (defcustom coq-user-commands-db nil "User defined command information. See `coq-syntax-db' for syntax. It is not necessary to add your own commands here (it is not needed by the synchronizing/backtracking system). You may however do so for the following reasons: 1 your commands will be colorized by font-lock 2 your commands will be added to the menu and to completion when calling \\[coq-insert-command] 3 you may define an abbreviation for your command." :type '(repeat sexp) :group 'coq) (defcustom coq-user-tacticals-db nil "User defined tactical information. See `coq-syntax-db' for syntax. It is not necessary to add your own commands here (it is not needed by the synchronizing/backtracking system). You may however do so for the following reasons: 1 your commands will be colorized by font-lock 2 your commands will be added to the menu and to completion when calling \\[coq-insert-command] 3 you may define an abbreviation for your command." :type '(repeat sexp) :group 'coq) (defcustom coq-user-solve-tactics-db nil "User defined closing tactics. See `coq-syntax-db' for syntax. It is not necessary to add your own commands here (it is not needed by the synchronizing/backtracking system). You may however do so for the following reasons: 1 your commands will be colorized by font-lock 2 your commands will be added to the menu and to completion when calling \\[coq-insert-command] 3 you may define an abbreviation for your command." :type '(repeat sexp) :group 'coq) (defcustom coq-user-reserved-db nil "User defined reserved keywords information. See `coq-syntax-db' for syntax. It is not necessary to add your own commands here (it is not needed by the synchronizing/backtracking system). You may however do so for the following reasons: 1 your commands will be colorized by font-lock 2 your commands will be added to the menu and to completion when calling \\[coq-insert-command] 3 you may define an abbreviation for your command." :type '(repeat sexp) :group 'coq) (defvar coq-tactics-db (append coq-user-tactics-db '( ("absurd " "abs" "absurd " t "absurd") ("apply" "ap" "apply " t "apply") ("assert by" "assb" "assert ( # : # ) by #" t "assert") ("assert" "ass" "assert ( # : # )" t) ;; ("assumption" "as" "assumption" t "assumption") ("auto with arith" "awa" "auto with arith" t) ("auto with" "aw" "auto with @{db}" t) ("auto" "a" "auto" t "auto") ("autorewrite with in using" "arwiu" "autorewrite with @{db,db...} in @{hyp} using @{tac}" t) ("autorewrite with in" "arwi" "autorewrite with @{db,db...} in @{hyp}" t) ("autorewrite with using" "arwu" "autorewrite with @{db,db...} using @{tac}" t) ("autorewrite with" "ar" "autorewrite with @{db,db...}" t "autorewrite") ("case" "c" "case " t "case") ("cbv" "cbv" "cbv beta [#] delta iota zeta" t "cbv") ("change in" "chi" "change # in #" t) ("change with in" "chwi" "change # with # in #" t) ("change with" "chw" "change # with" t) ("change" "ch" "change " t "change") ("clear" "cl" "clear" t "clear") ("clearbody" "cl" "clearbody" t "clearbody") ("cofix" "cof" "cofix" t "cofix") ("coinduction" "coind" "coinduction" t "coinduction") ("compare" "cmpa" "compare # #" t "compare") ("compute" "cmpu" "compute" t "compute") ;; ("congruence" "cong" "congruence" t "congruence") ("constructor" "cons" "constructor" t "constructor") ;; ("contradiction" "contr" "contradiction" t "contradiction") ("cut" "cut" "cut" t "cut") ("cutrewrite" "cutr" "cutrewrite -> # = #" t "cutrewrite") ;; ("decide equality" "deg" "decide equality" t "decide\\s-+equality") ("decompose record" "decr" "decompose record #" t "decompose\\s-+record") ("decompose sum" "decs" "decompose sum #" t "decompose\\s-+sum") ("decompose" "dec" "decompose [#] #" t "decompose") ("dependent inversion" "depinv" "dependent inversion" t "dependent\\s-+inversion") ("dependent inversion with" "depinvw" "dependent inversion # with #" t) ("dependent inversion_clear" "depinvc" "dependent inversion_clear" t "dependent\\s-+inversion_clear") ("dependent inversion_clear with" "depinvw" "dependent inversion_clear # with #" t) ("dependent rewrite ->" "depr" "dependent rewrite -> @{id}" t "dependent\\s-+rewrite") ("dependent rewrite <-" "depr<" "dependent rewrite <- @{id}" t) ("destruct as" "desa" "destruct # as #" t) ("destruct using" "desu" "destruct # using #" t) ("destruct" "des" "destruct " t "destruct") ;; ("discriminate" "dis" "discriminate" t "discriminate") ("discrR" "discrR" "discrR" t "discrR") ("double induction" "dind" "double induction # #" t "double\\s-+induction") ("eapply" "eap" "eapply #" t "eapply") ("eauto with arith" "eawa" "eauto with arith" t) ("eauto with" "eaw" "eauto with @{db}" t) ("eauto" "ea" "eauto" t "eauto") ("econstructor" "econs" "econstructor" t "econstructor") ("eexists" "eex" "eexists" t "eexists") ("eleft" "eleft" "eleft" t "eleft") ("elim using" "elu" "elim # using #" t) ("elim" "e" "elim #" t "elim") ("elimtype" "elt" "elimtype" "elimtype") ("eright" "erig" "eright" "eright") ("esplit" "esp" "esplit" t "esplit") ;; ("exact" "exa" "exact" t "exact") ("exists" "ex" "exists #" t "exists") ;; ("fail" "fa" "fail" nil) ;; ("field" "field" "field" t "field") ("firstorder" "fsto" "firstorder" t "firstorder") ("firstorder with" "fsto" "firstorder with #" t) ("firstorder with using" "fsto" "firstorder # with #" t) ("fold" "fold" "fold #" t "fold") ;; ("fourier" "four" "fourier" t "fourier") ("functional induction" "fi" "functional induction @{f} @{args}" t "functional\\s-+induction") ("generalize dependent" "gd" "generalize dependent #" t "generalize\\s-+dependent") ("generalize" "g" "generalize #" t "generalize") ("hnf" "hnf" "hnf" t "hnf") ("idtac" "id" "idtac" nil "idtac") ; also in tacticals with abbrev id ("idtac \"" "id\"" "idtac \"#\"") ; also in tacticals ("induction" "ind" "induction #" t "induction") ("induction using" "indu" "induction # using #" t) ("injection" "inj" "injection #" t "injection") ("instantiate" "inst" "instantiate" t "instantiate") ("intro" "i" "intro" t "intro") ("intro after" "ia" "intro # after #" t) ("intros" "is" "intros #" t "intros") ("intros! (guess names)" nil "intros #" nil nil coq-insert-intros) ("intros until" "isu" "intros until #" t) ("intuition" "intu" "intuition #" t "intuition") ("inversion" "inv" "inversion #" t "inversion") ("inversion in" "invi" "inversion # in #" t) ("inversion using" "invu" "inversion # using #" t) ("inversion using in" "invui" "inversion # using # in #" t) ("inversion_clear" "invcl" "inversion_clear" t "inversion_clear") ("lapply" "lap" "lapply" t "lapply") ("lazy" "lazy" "lazy beta [#] delta iota zeta" t "lazy") ("left" "left" "left" t "left") ("linear" "lin" "linear" t "linear") ("load" "load" "load" t "load") ("move after" "mov" "move # after #" t "move") ("omega" "o" "omega" t "omega") ("pattern" "pat" "pattern" t "pattern") ("pattern(s)" "pats" "pattern # , #" t) ("pattern at" "pata" "pattern # at #" t) ("pose" "po" "pose ( # := # )" t "pose") ("prolog" "prol" "prolog" t "prolog") ("quote" "quote" "quote" t "quote") ("quote []" "quote2" "quote # [#]" t) ("red" "red" "red" t "red") ("refine" "ref" "refine" t "refine") ;; ("reflexivity" "refl" "reflexivity #" t "reflexivity") ("rename into" "ren" "rename # into #" t "rename") ("replace with" "rep" "replace # with #" t "replace") ("replace with in" "repi" "replace # with # in #" t) ("rewrite <- in" "ri<" "rewrite <- # in #" t) ("rewrite <-" "r<" "rewrite <- #" t) ("rewrite in" "ri" "rewrite # in #" t) ("rewrite" "r" "rewrite #" t "rewrite") ("right" "rig" "right" t "right") ;; ("ring" "ring" "ring #" t "ring") ("set in * |-" "seth" "set ( # := #) in * |-" t) ("set in *" "set*" "set ( # := #) in *" t) ("set in |- *" "setg" "set ( # := #) in |- *" t) ("set in" "seti" "set ( # := #) in #" t) ("set" "set" "set ( # := #)" t "set") ("setoid_replace with" "strep2" "setoid_replace # with #" t "setoid_replace") ("setoid replace with" "strep" "setoid replace # with #" t "setoid\\s-+replace") ("setoid_rewrite" "strew" "setoid_rewrite #" t "setoid_rewrite") ("setoid rewrite" "strew" "setoid rewrite #" t "setoid\\s-+rewrite") ("simpl" "s" "simpl" t "simpl") ("simpl" "sa" "simpl # at #" t) ("simple destruct" "sdes" "simple destruct" t "simple\\s-+destruct") ("simple inversion" "sinv" "simple inversion" t "simple\\s-+inversion") ("simple induction" "sind" "simple induction" t "simple\\s-+induction") ("simplify_eq" "simeq" "simplify_eq @{hyp}" t "simplify_eq") ("specialize" "spec" "specialize" t "specialize") ("split" "sp" "split" t "split") ("split_Rabs" "spra" "splitRabs" t "split_Rabs") ("split_Rmult" "sprm" "splitRmult" t "split_Rmult") ("stepl" "stl" "stepl #" t "stepl") ("stepl by" "stlb" "stepl # by #" t) ("stepr" "str" "stepr #" t "stepr") ("stepr by" "strb" "stepr # by #" t) ("subst" "su" "subst #" t "subst") ("symmetry" "sy" "symmetry" t "symmetry") ("symmetry in" "syi" "symmetry in #" t) ;; ("tauto" "ta" "tauto" t "tauto") ("transitivity" "trans" "transitivity #" t "transitivity") ("trivial" "t" "trivial" t "trivial") ("trivial with" "tw" "trivial with @{db}" t) ("unfold" "u" "unfold #" t "unfold") ("unfold(s)" "us" "unfold # , #" t) ("unfold in" "unfi" "unfold # in #" t) ("unfold at" "unfa" "unfold # at #" t) )) "Coq tactics information list. See `coq-syntax-db' for syntax. " ) (defvar coq-solve-tactics-db (append coq-user-solve-tactics-db '( ("assumption" "as" "assumption" t "assumption") ("by" "by" "by #" t "by") ("congruence" "cong" "congruence" t "congruence") ("contradiction" "contr" "contradiction" t "contradiction") ("decide equality" "deg" "decide equality" t "decide\\s-+equality") ("discriminate" "dis" "discriminate" t "discriminate") ("exact" "exa" "exact" t "exact") ("fourier" "four" "fourier" t "fourier") ("fail" "fa" "fail" nil) ("field" "field" "field" t "field") ("omega" "o" "omega" t "omega") ("reflexivity" "refl" "reflexivity #" t "reflexivity") ("ring" "ring" "ring #" t "ring") ("solve" nil "solve [ # | # ]" nil "solve") ("tauto" "ta" "tauto" t "tauto") )) "Coq tactic(al)s that solve a subgoal." ) (defvar coq-tacticals-db (append coq-user-tacticals-db '( ("info" nil "info #" nil "info") ("first" nil "first [ # | # ]" nil "first") ("abstract" nil "abstract @{tac} using @{name}." nil "abstract") ("do" nil "do @{num} @{tac}" nil "do") ("idtac" nil "idtac") ; also in tactics ; ("idtac \"" nil "idtac \"#\"") ; also in tactics ("fail" "fa" "fail" nil "fail") ; ("fail \"" "fa\"" "fail" nil) ; ; ("orelse" nil "orelse #" t "orelse") ("repeat" nil "repeat #" nil "repeat") ("try" nil "try #" nil "try") ("progress" nil "progress #" nil "progress") ("|" nil "[ # | # ]" nil) ("||" nil "# || #" nil) )) "Coq tacticals information list. See `coq-syntax-db' for syntax.") (defvar coq-decl-db '( ("Axiom" "ax" "Axiom # : #" t "Axiom") ("Hint Constructors" "hc" "Hint Constructors # : #." t "Hint\\s-+Constructors") ("Hint Extern" "he" "Hint Extern @{cost} @{pat} => @{tac} : @{db}." t "Hint\\s-+Extern") ("Hint Immediate" "hi" "Hint Immediate # : @{db}." t "Hint\\s-+Immediate") ("Hint Resolve" "hr" "Hint Resolve # : @{db}." t "Hint\\s-+Resolve") ("Hint Rewrite ->" "hrw" "Hint Rewrite -> @{t1,t2...} using @{tac} : @{db}." t "Hint\\s-+Rewrite") ("Hint Rewrite <-" "hrw" "Hint Rewrite <- @{t1,t2...} using @{tac} : @{db}." t ) ("Hint Unfold" "hu" "Hint Unfold # : #." t "Hint\\s-+Unfold") ("Hypothesis" "hyp" "Hypothesis #: #" t "Hypothesis") ("Hypotheses" "hyp" "Hypotheses #: #" t "Hypotheses") ("Parameter" "par" "Parameter #: #" t "Parameter") ("Parameters" "par" "Parameter #: #" t "Parameters") ("Conjecture" "conj" "Conjecture #: #." t "Conjecture") ("Variable" "v" "Variable #: #." t "Variable") ("Variables" "vs" "Variables # , #: #." t "Variables") ("Coercion" "coerc" "Coercion @{id} : @{typ1} >-> @{typ2}." t "Coercion") ) "Coq declaration keywords information list. See `coq-syntax-db' for syntax." ) (defvar coq-defn-db '( ("CoFixpoint" "cfix" "CoFixpoint # (#:#) : # :=\n#." t "CoFixpoint") ("CoInductive" "coindv" "CoInductive # : # :=\n|# : #." t "CoInductive") ("Declare Module : :=" "dm" "Declare Module # : # := #." t "Declare\\s-+Module") ("Declare Module <: :=" "dm2" "Declare Module # <: # := #." t);; careful ("Declare Module Import : :=" "dmi" "Declare Module # : # := #." t) ("Declare Module Import <: :=" "dmi2" "Declare Module # <: # := #." t);; careful ("Declare Module Export : :=" "dme" "Declare Module # : # := #." t) ("Declare Module Export <: :=" "dme2" "Declare Module # <: # := #." t);; careful ("Definition" "def" "Definition #:# := #." t "Definition");; careful ("Definition (2 args)" "def2" "Definition # (# : #) (# : #):# := #." t) ("Definition (3 args)" "def3" "Definition # (# : #) (# : #) (# : #):# := #." t) ("Definition (4 args)" "def4" "Definition # (# : #) (# : #) (# : #) (# : #):# := #." t) ("Program Definition" "pdef" "Program Definition #:# := #." t "Program\\s-+Definition");; careful ? ("Program Definition (2 args)" "pdef2" "Program Definition # (# : #) (# : #):# := #." t) ("Program Definition (3 args)" "pdef3" "Program Definition # (# : #) (# : #) (# : #):# := #." t) ("Program Definition (4 args)" "pdef4" "Program Definition # (# : #) (# : #) (# : #) (# : #):# := #." t) ("Derive Inversion" nil "Derive Inversion @{id} with # Sort #." t "Derive\\s-+Inversion") ("Derive Dependent Inversion" nil "Derive Dependent Inversion @{id} with # Sort #." t "Derive\\s-+Dependent\\s-+Inversion") ("Derive Inversion_clear" nil "Derive Inversion_clear @{id} with # Sort #." t) ("Fixpoint" "fix" "Fixpoint # (#:#) {struct @{arg}} : # :=\n#." t "Fixpoint") ("Program Fixpoint" "pfix" "Program Fixpoint # (#:#) {struct @{arg}} : # :=\n#." t "Program\\s-+Fixpoint") ("Program Fixpoint measure" "pfixm" "Program Fixpoint # (#:#) {measure @{arg} @{f}} : # :=\n#." t) ("Program Fixpoint wf" "pfixwf" "Program Fixpoint # (#:#) {wf @{arg} @{f}} : # :=\n#." t) ("Function" "func" "Function # (#:#) {struct @{arg}} : # :=\n#." t "Function") ("Function measure" "funcm" "Function # (#:#) {measure @{f} @{arg}} : # :=\n#." t) ("Function wf" "func wf" "Function # (#:#) {wf @{R} @{arg}} : # :=\n#." t) ("Functional Scheme with" "fsw" "Functional Scheme @{name} := Induction for @{fun} with @{mutfuns}." t ) ("Functional Scheme" "fs" "Functional Scheme @{name} := Induction for @{fun}." t "Functional\\s-+Scheme") ("Inductive" "indv" "Inductive # : # := # : #." t "Inductive") ("Inductive (2 args)" "indv2" "Inductive # : # :=\n| # : #\n| # : #." t ) ("Inductive (3 args)" "indv3" "Inductive # : # :=\n| # : #\n| # : #\n| # : #." t ) ("Inductive (4 args)" "indv4" "Inductive # : # :=\n| # : #\n| # : #\n| # : #\n| # : #." t ) ("Inductive (5 args)" "indv5" "Inductive # : # :=\n| # : #\n| # : #\n| # : #\n| # : #\n| # : #." t ) ("Variant" "indv" "Variant # : # := # : #." t "Variant") ("Variant (2 args)" "indv2" "Variant # : # :=\n| # : #\n| # : #." t ) ("Variant (3 args)" "indv3" "Variant # : # :=\n| # : #\n| # : #\n| # : #." t ) ("Variant (4 args)" "indv4" "Variant # : # :=\n| # : #\n| # : #\n| # : #\n| # : #." t ) ("Variant (5 args)" "indv5" "Variant # : # :=\n| # : #\n| # : #\n| # : #\n| # : #\n| # : #." t ) ("Let" "Let" "Let # : # := #." t "Let") ("Ltac" "ltac" "Ltac # := #" t "Ltac") ("Module :=" "mo" "Module # : # := #." t ) ; careful ("Module <: :=" "mo2" "Module # <: # := #." t ) ; careful ("Module Import :=" "moi" "Module Import # : # := #." t ) ; careful ("Module Import <: :=" "moi2" "Module Import # <: # := #." t ) ; careful ("Module Export :=" "moe" "Module Export # : # := #." t ) ; careful ("Module Export <: :=" "moe2" "Module Export# <: # := #." t ) ; careful ("Record" "rec" "Record # : # := {\n# : #;\n# : # }" t "Record") ("Scheme" "sc" "Scheme @{name} := #." t "Scheme") ("Scheme Induction" "sci" "Scheme @{name} := Induction for # Sort #." t) ("Scheme Minimality" "scm" "Scheme @{name} := Minimality for # Sort #." t) ("Structure" "str" "Structure # : # := {\n# : #;\n# : # }" t "Structure") ) "Coq definition keywords information list. See `coq-syntax-db' for syntax. " ) ;; modules and section are indented like goal starters (defvar coq-goal-starters-db '( ("Add Morphism" "addmor" "Add Morphism @{f} : @{id}" t "Add\\s-+Morphism") ("Chapter" "chp" "Chapter # : #." t "Chapter") ("Corollary" "cor" "Corollary # : #.\nProof.\n#\nQed." t "Corollary") ("Declare Module :" "dmi" "Declare Module # : #.\n#\nEnd #." t) ("Declare Module <:" "dmi2" "Declare Module # <: #.\n#\nEnd #." t) ("Definition goal" "defg" "Definition #:#.\n#\nSave." t);; careful ("Fact" "fct" "Fact # : #." t "Fact") ("Goal" nil "Goal #." t "Goal") ("Lemma" "l" "Lemma # : #.\nProof.\n#\nQed." t "Lemma") ("Program Lemma" "pl" "Program Lemma # : #.\nProof.\n#\nQed." t "Program\\s-+Lemma") ("Module! (interactive)" nil "Module # : #.\n#\nEnd #." nil nil coq-insert-section-or-module) ("Module Type" "mti" "Module Type #.\n#\nEnd #." t "Module\\s-+Type") ; careful ("Module :" "moi" "Module # : #.\n#\nEnd #." t "Module") ; careful ("Module <:" "moi2" "Module # <: #.\n#\nEnd #." t ) ; careful ("Remark" "rk" "Remark # : #.\n#\nQed." t "Remark") ("Section" "sec" "Section #." t "Section") ("Theorem" "th" "Theorem # : #.\n#\nQed." t "Theorem") ("Program Theorem" "pth" "Program Theorem # : #.\nProof.\n#\nQed." t "Program\\s-+Theorem") ("Obligation" "obl" "Obligation #.\n#\nQed." t "Obligation") ("Next Obligation" "nobl" "Next Obligation.\n#\nQed." t "Next Obligation") ) "Coq goal starters keywords information list. See `coq-syntax-db' for syntax. " ) ;; command that are not declarations, definition or goal starters (defvar coq-other-commands-db '( ;; ("Abort" nil "Abort." t "Abort" nil nil);don't appear in menu ("About" nil "About #." nil "About") ("Add" nil "Add #." nil "Add" nil t) ("Add Abstract Ring" nil "Add Abstract Ring #." t "Add\\s-+Abstract\\s-+Ring") ("Add Abstract Semi Ring" nil "Add Abstract Semi Ring #." t "Add\\s-+Abstract\\s-+Semi\\s-+Ring") ("Add Field" nil "Add Field #." t "Add\\s-+Field") ("Add LoadPath" nil "Add LoadPath #." nil "Add\\s-+LoadPath") ("Add ML Path" nil "Add ML Path #." nil "Add\\s-+ML\\s-+Path") ("Add Morphism" nil "Add Morphism #." t "Add\\s-+Morphism") ("Add Printing" nil "Add Printing #." t "Add\\s-+Printing") ("Add Printing Constructor" nil "Add Printing Constructor #." t "Add\\s-+Printing\\s-+Constructor") ("Add Printing If" nil "Add Printing If #." t "Add\\s-+Printing\\s-+If") ("Add Printing Let" nil "Add Printing Let #." t "Add\\s-+Printing\\s-+Let") ("Add Printing Record" nil "Add Printing Record #." t "Add\\s-+Printing\\s-+Record") ("Add Rec LoadPath" nil "Add Rec LoadPath #." nil "Add\\s-+Rec\\s-+LoadPath") ("Add Rec ML Path" nil "Add Rec ML Path #." nil "Add\\s-+Rec\\s-+ML\\s-+Path") ("Add Ring" nil "Add Ring #." t "Add\\s-+Ring") ("Add Semi Ring" nil "Add Semi Ring #." t "Add\\s-+Semi\\s-+Ring") ("Add Setoid" nil "Add Setoid #." t "Add\\s-+Setoid") ("Admit Obligations" "oblsadmit" "Admit Obligations." nil "Admit\\s-+Obligations") ("Arguments Scope" "argsc" "Arguments Scope @{id} [ @{_} ]" t "Arguments\\s-+Scope") ("Bind Scope" "bndsc" "Bind Scope @{scope} with @{type}" t "Bind\\s-+Scope") ("Canonical Structure" nil "Canonical Structure #." t "Canonical\\s-+Structure") ("Cd" nil "Cd #." nil "Cd") ("Check" nil "Check" nil "Check") ("Close Local Scope" "cllsc" "Close Local Scope #" t "Close\\s-+Local\\s-+Scope") ("Close Scope" "clsc" "Close Scope #" t "Close\\s-+Scope") ("Comments" nil "Comments #." nil "Comments") ("Delimit Scope" "delsc" "Delimit Scope @{scope} with @{id}." t "Delimit\\s-+Scope" ) ("Eval" nil "Eval #." nil "Eval") ("Export" nil "Export #." t "Export") ("Extract Constant" "extrc" "Extract Constant @{id} => \"@{id}\"." nil "Extract\\s-+Constant") ("Extract Inlined Constant" "extric" "Extract Inlined Constant @{id} => \"@{id}\"." nil "Extract\\s-+Inlined\\s-+Constant") ("Extract Inductive" "extri" "Extract Inductive @{id} => \"@{id}\" [\"@{id}\" \"@{id...}\"]." nil "Extract") ("Extraction" "extr" "Extraction @{id}." nil "Extraction") ("Extraction (in a file)" "extrf" "Extraction \"@{file}\" @{id}." nil) ("Extraction Inline" nil "Extraction Inline #." t "Extraction\\s-+Inline") ("Extraction NoInline" nil "Extraction NoInline #." t "Extraction\\s-+NoInline") ("Extraction Language" "extrlang" "Extraction Language #." t "Extraction\\s-+Language") ("Extraction Library" "extrl" "Extraction Library @{id}." nil "Extraction\\s-+Library") ("Focus" nil "Focus #." nil "Focus") ("Identity Coercion" nil "Identity Coercion #." t "Identity\\s-+Coercion") ("Implicit Arguments Off" nil "Implicit Arguments Off." t "Implicit\\s-+Arguments\\s-+Off") ("Implicit Arguments On" nil "Implicit Arguments On." t "Implicit\\s-+Arguments\\s-+On") ("Implicit Arguments" nil "Implicit Arguments # [#]." t "Implicit\\s-+Arguments") ("Import" nil "Import #." t "Import") ("Infix" "inf" "Infix \"#\" := # (at level #) : @{scope}." t "Infix") ("Inspect" nil "Inspect #." nil "Inspect") ("Locate" nil "Locate" nil "Locate") ("Locate File" nil "Locate File \"#\"." nil "Locate\\s-+File") ("Locate Library" nil "Locate Library #." nil "Locate\\s-+Library") ("Notation (assoc)" "notas" "Notation \"#\" := # (at level #, # associativity)." t) ("Notation (at assoc)" "notassc" "Notation \"#\" := # (at level #, # associativity) : @{scope}." t) ("Notation (at at scope)" "notasc" "Notation \"#\" := # (at level #, # at level #) : @{scope}." t) ("Notation (at at)" "nota" "Notation \"#\" := # (at level #, # at level #)." t) ("Notation (only parsing)" "notsp" "Notation # := # (only parsing)." t) ("Notation Local (only parsing)" "notslp" "Notation Local # := # (only parsing)." t) ("Notation Local" "notsl" "Notation Local # := #." t "Notation\\s-+Local") ("Notation (simple)" "nots" "Notation # := #." t "Notation") ("Opaque" nil "Opaque #." nil "Opaque") ("Obligations Tactic" nil "Obligations Tactic := #." t "Obligations\\s-+Tactic") ("Open Local Scope" "oplsc" "Open Local Scope #" t "Open\\s-+Local\\s-+Scope") ("Open Scope" "opsc" "Open Scope #" t "Open\\s-+Scope") ("Print Coercions" nil "Print Coercions." nil "Print\\s-+Coercions") ("Print Hint" nil "Print Hint." nil "Print\\s-+Hint" coq-PrintHint) ("Print" "p" "Print #." nil "Print") ("Qed" nil "Qed." nil "Qed") ("Pwd" nil "Pwd." nil "Pwd") ("Recursive Extraction" "recextr" "Recursive Extraction @{id}." nil "Recursive\\s-+Extraction") ("Recursive Extraction Library" "recextrl" "Recursive Extraction Library @{id}." nil "Recursive\\s-+Extraction\\s-+Library") ("Recursive Extraction Module" "recextrm" "Recursive Extraction Module @{id}." nil "Recursive\\s-+Extraction\\s-+Module") ("Remove LoadPath" nil "Remove LoadPath" nil "Remove\\s-+LoadPath") ("Remove LoadPath" nil "Remove LoadPath" nil "Remove\\s-+LoadPath") ("Remove Printing If" nil "Remove Printing If #." t "Remove\\s-+Printing\\s-+If") ("Remove Printing Let" nil "Remove Printing Let #." t "Remove\\s-+Printing\\s-+Let") ("Require Export" nil "Require Export #." t "Require\\s-+Export") ("Require Import" nil "Require Import #." t "Require\\s-+Import") ("Require" nil "Require #." t "Require") ("Reserved Notation" nil "Reserved Notation" nil "Reserved\\s-+Notation") ("Reset Extraction Inline" nil "Reset Extraction Inline." t "Reset\\s-+Extraction\\s-+Inline") ("Save" nil "Save." t "Save") ("Search" nil "Search #" nil "Search") ("SearchAbout" nil "SearchAbout #" nil "SearchAbout") ("SearchPattern" nil "SearchPattern #" nil "SearchPattern") ("SearchRewrite" nil "SearchRewrite #" nil "SearchRewrite") ("Set Extraction AutoInline" nil "Set Extraction AutoInline" t "Set\\s-+Extraction\\s-+AutoInline") ("Set Extraction Optimize" nil "Set Extraction Optimize" t "Set\\s-+Extraction\\s-+Optimize") ("Set Implicit Arguments" nil "Set Implicit Arguments" t "Set\\s-+Implicit\\s-+Arguments") ("Set Strict Implicit" nil "Set Strict Implicit" t "Set\\s-+Strict\\s-+Implicit") ("Set Printing Synth" nil "Set Printing Synth" t "Set\\s-+Printing\\s-+Synth") ("Set Printing Wildcard" nil "Set Printing Wildcard" t "Set\\s-+Printing\\s-+Wildcard") ("Set Printing All" "sprall" "Set Printing All" t "Set\\s-+Printing\\s-+All") ("Set Printing Records" nil "Set Printing Records" t "Set\\s-+Printing\\s-+Records") ("Set Hyps Limit" nil "Set Hyps Limit #." nil "Set\\s-+Hyps\\s-+Limit") ("Set Printing Coercions" nil "Set Printing Coercions." t "Set\\s-+Printing\\s-+Coercions") ("Set Printing Notations" "sprn" "Set Printing Notations" t "Set\\s-+Printing\\s-+Notations") ("Set Undo" nil "Set Undo #." nil "Set\\s-+Undo") ("Show" nil "Show #." nil "Show") ("Solve Obligations" "oblssolve" "Solve Obligations using #." nil "Solve\\s-+Obligations") ("Test" nil "Test" nil "Test" nil t) ("Test Printing Depth" nil "Test Printing Depth." nil "Test\\s-+Printing\\s-+Depth") ("Test Printing If" nil "Test Printing If #." nil "Test\\s-+Printing\\s-+If") ("Test Printing Let" nil "Test Printing Let #." nil "Test\\s-+Printing\\s-+Let") ("Test Printing Synth" nil "Test Printing Synth." nil "Test\\s-+Printing\\s-+Synth") ("Test Printing Width" nil "Test Printing Width." nil "Test\\s-+Printing\\s-+Width") ("Test Printing Wildcard" nil "Test Printing Wildcard." nil "Test\\s-+Printing\\s-+Wildcard") ("Transparent" nil "Transparent #." nil "Transparent") ("Unfocus" nil "Unfocus." nil "Unfocus") ("Unset Extraction AutoInline" nil "Unset Extraction AutoInline" t "Unset\\s-+Extraction\\s-+AutoInline") ("Unset Extraction Optimize" nil "Unset Extraction Optimize" t "Unset\\s-+Extraction\\s-+Optimize") ("Unset Implicit Arguments" nil "Unset Implicit Arguments" t "Unset\\s-+Implicit\\s-+Arguments") ("Unset Strict Implicit" nil "Unset Strict Implicit" t "Unset\\s-+Strict\\s-+Implicit") ("Unset Printing Synth" nil "Unset Printing Synth" t "Unset\\s-+Printing\\s-+Synth") ("Unset Printing Wildcard" nil "Unset Printing Wildcard" t "Unset\\s-+Printing\\s-+Wildcard") ("Unset Hyps Limit" nil "Unset Hyps Limit" nil "Unset\\s-+Hyps\\s-+Limit") ("Unset Printing All" "unsprall" "Unset Printing All" nil "Unset\\s-+Printing\\s-+All") ("Unset Printing Coercion" nil "Unset Printing Coercion #." t "Unset\\s-+Printing\\s-+Coercion") ("Unset Printing Coercions" nil "Unset Printing Coercions." nil "Unset\\s-+Printing\\s-+Coercions") ("Unset Printing Notations" "unsprn" "Unset Printing Notations" nil "Unset\\s-+Printing\\s-+Notations") ("Unset Undo" nil "Unset Undo." nil "Unset\\s-+Undo") ; ("print" "pr" "print #" "print") ) "Command that are not declarations, definition or goal starters." ) (defvar coq-commands-db (append coq-decl-db coq-defn-db coq-goal-starters-db coq-other-commands-db coq-user-commands-db) "Coq all commands keywords information list. See `coq-syntax-db' for syntax. " ) (defvar coq-terms-db '( ("fun (1 args)" "f" "fun #:# => #" nil "fun") ("fun (2 args)" "f2" "fun (#:#) (#:#) => #") ("fun (3 args)" "f3" "fun (#:#) (#:#) (#:#) => #") ("fun (4 args)" "f4" "fun (#:#) (#:#) (#:#) (#:#) => #") ("forall" "fo" "forall #:#,#" nil "forall") ("forall (2 args)" "fo2" "forall (#:#) (#:#), #") ("forall (3 args)" "fo3" "forall (#:#) (#:#) (#:#), #") ("forall (4 args)" "fo4" "forall (#:#) (#:#) (#:#) (#:#), #") ("if" "if" "if # then # else #" nil "if") ("let in" "li" "let # := # in #" nil "let") ("match! (from type)" nil "" nil "match" coq-insert-match) ("match with" "m" "match # with\n| # => #\nend") ("match with 2" "m2" "match # with\n| # => #\n| # => #\nend") ("match with 3" "m3" "match # with\n| # => #\n| # => #\n| # => #\nend") ("match with 4" "m4" "match # with\n| # => #\n| # => #\n| # => #\n| # => #\nend") ("match with 5" "m5" "match # with\n| # => #\n| # => #\n| # => #\n| # => #\n| # => #\nend") ) "Coq terms keywords information list. See `coq-syntax-db' for syntax. " ) ;;; Goals (and module/sections) starters detection ;; ----- keywords for font-lock. ;; FIXME da: this one function breaks the nice configuration of Proof General: ;; would like to have proof-goal-regexp instead. ;; Unfortunately Coq allows "Definition" and friends to perhaps have a goal, ;; so it appears more difficult than just a proof-goal-regexp setting. ;; Future improvement may simply to be allow a function value for ;; proof-goal-regexp. ;; FIXME Pierre: the right way IMHO here would be to set a span ;; property 'goalcommand when coq prompt says it (if the name of ;; current proof has changed). ;; excerpt of Jacek Chrzaszcz, implementer of the module system: sorry ;; for the french: ;;*) suivant les suggestions de Chritine, pas de mode preuve dans un type de ;; module (donc pas de Definition truc:machin. Lemma, Theorem ... ) ;; ;; *) la commande Module M [ ( : | <: ) MTYP ] [ := MEXPR ] est valable ;; uniquement hors d'un MT ;; - si :=MEXPR est absent, elle demarre un nouveau module interactif ;; - si :=MEXPR est present, elle definit un module ;; (la fonction vernac_define_module dans toplevel/vernacentries) ;; ;; *) la nouvelle commande Declare Module M [ ( : | <: ) MTYP ] [ := MEXPR ] ;; est valable uniquement dans un MT ;; - si :=MEXPR absent, :MTYP absent, elle demarre un nouveau module ;; interactif ;; - si (:=MEXPR absent, :MTYP present) ;; ou (:=MEXPR present, :MTYP absent) ;; elle declare un module. ;; (la fonction vernac_declare_module dans toplevel/vernacentries) (defun coq-count-match (regexp strg) "Count the number of (maximum, non overlapping) matching substring of STRG matching REGEXP. Empty match are counted once." (let ((nbmatch 0) (str strg)) (while (and (proof-string-match regexp str) (not (string-equal str ""))) (incf nbmatch) (if (= (match-end 0) 0) (setq str (substring str 1)) (setq str (substring str (match-end 0))))) nbmatch)) ;; This function is used for amalgamating a proof into a single ;; goal-save region (proof-goal-command-p used in ;; proof-done-advancing-save in generic/proof-script.el) for coq < ;; 8.0. It is the test when looking backward the start of the proof. ;; It is NOT used for coq > v8.1 ;; (coq-find-and-forget in gallina.el uses state numbers, proof numbers and ;; lemma names given in the prompt) ;; compatibility with v8.0, will delete it some day (defun coq-goal-command-str-v80-p (str) "See `coq-goal-command-p'." (let* ((match (coq-count-match "\\" str)) (with (coq-count-match "\\" str)) (letwith (+ (coq-count-match "\\" str) (- with match))) (affect (coq-count-match ":=" str))) (and (proof-string-match coq-goal-command-regexp str) (not ; (and (proof-string-match "\\`\\(Local\\|Definition\\|Lemma\\|Module\\)\\>" str) (not (= letwith affect)))) (not (proof-string-match "\\`Declare\\s-+Module\\(\\w\\|\\s-\\|<\\)*:" str)) ) ) ) ;; Module and or section openings are detected syntactically. Module ;; *openings* are difficult to detect because there can be Module ;; ...with X := ... . So we need to count :='s to detect real openings. ;; TODO: have opened section/chapter in the prompt too, and get rid of ;; syntactical tests everywhere (defun coq-module-opening-p (str) "Decide whether STR is a module or section opening or not. Used by `coq-goal-command-p'" (let* ((match (coq-count-match "\\" str)) (with (coq-count-match "\\" str)) (letwith (+ (coq-count-match "\\" str) (- with match))) (affect (coq-count-match ":=" str))) (and (proof-string-match "\\`\\(Module\\)\\>" str) (= letwith affect)) )) (defun coq-section-command-p (str) (proof-string-match "\\`\\(Section\\|Chapter\\)\\>" str)) (defun coq-goal-command-str-v81-p (str) "Decide syntactically whether STR is a goal start or not. Use `coq-goal-command-p-v81' on a span instead if possible." (coq-goal-command-str-v80-p str) ) ;; This is the function that tests if a SPAN is a goal start. All it ;; has to do is look at the 'goalcmd attribute of the span. ;; It also looks if this is not a module start. ;; TODO: have also attributes 'modulecmd and 'sectioncmd. This needs ;; something in the coq prompt telling the name of all opened modules ;; (like for open goals), and use it to set goalcmd --> no more need ;; to look at Modules and section (actually indentation will still ;; need it) (defun coq-goal-command-p-v81 (span) "see `coq-goal-command-p'" (or (span-property span 'goalcmd) ;; module and section starts are detected here (let ((str (or (span-property span 'cmd) ""))) (or (coq-section-command-p str) (coq-module-opening-p str)) ))) ;; In coq > 8.1 This is used only for indentation. (defun coq-goal-command-str-p (str) "Decide whether argument is a goal or not. Use `coq-goal-command-p' on a span instead if posible." (cond (coq-version-is-V8-1 (coq-goal-command-str-v81-p str)) (coq-version-is-V8-0 (coq-goal-command-str-v80-p str)) (t (coq-goal-command-str-v80-p str));; this is temporary )) ;; This is used for backtracking (defun coq-goal-command-p (span) "Decide whether argument is a goal or not." (cond (coq-version-is-V8-1 (coq-goal-command-p-v81 span)) (coq-version-is-V8-0 (coq-goal-command-str-v80-p (span-property span 'cmd))) (t (coq-goal-command-str-v80-p (span-property span 'cmd)));; this is temporary )) (defvar coq-keywords-save-strict '("Defined" "Save" "Qed" "End" "Admitted" "Abort" )) (defvar coq-keywords-save (append coq-keywords-save-strict '("Proof")) ) (defun coq-save-command-p (span str) "Decide whether argument is a Save command or not" (or (proof-string-match coq-save-command-regexp-strict str) (and (proof-string-match "\\`Proof\\>" str) (not (proof-string-match "Proof\\s-*\\(\\.\\|\\\\)" str))) ) ) (defvar coq-keywords-kill-goal '("Abort")) ;; Following regexps are all state changing (defvar coq-keywords-state-changing-misc-commands (coq-build-regexp-list-from-db coq-commands-db 'filter-state-changing)) (defvar coq-keywords-goal (coq-build-regexp-list-from-db coq-goal-starters-db)) (defvar coq-keywords-decl (coq-build-regexp-list-from-db coq-decl-db)) (defvar coq-keywords-defn (coq-build-regexp-list-from-db coq-defn-db)) (defvar coq-keywords-state-changing-commands (append coq-keywords-state-changing-misc-commands coq-keywords-decl ; all state changing coq-keywords-defn ; idem coq-keywords-goal)) ; idem ;; (defvar coq-keywords-state-preserving-commands (coq-build-regexp-list-from-db coq-commands-db 'filter-state-preserving)) ;; concat this is faster that redoing coq-build-regexp-list-from-db on ;; whole commands-db (defvar coq-keywords-commands (append coq-keywords-state-changing-commands coq-keywords-state-preserving-commands) "All commands keyword.") (defvar coq-solve-tactics (coq-build-regexp-list-from-db coq-solve-tactics-db) "Keywords for closing tactic(al)s.") (defvar coq-tacticals (coq-build-regexp-list-from-db coq-tacticals-db) "Keywords for tacticals in a Coq script.") ;; From JF Monin: (defvar coq-reserved (append coq-user-reserved-db '( "False" "True" "after" "as" "cofix" "fix" "forall" "fun" "match" "return" "struct" "else" "end" "if" "in" "into" "let" "then" "using" "with" "beta" "delta" "iota" "zeta" "after" "until" "at" "Sort" "Time")) "Reserved keywords of Coq.") (defvar coq-state-changing-tactics (coq-build-regexp-list-from-db coq-tactics-db 'filter-state-changing)) (defvar coq-state-preserving-tactics (coq-build-regexp-list-from-db coq-tactics-db 'filter-state-preserving)) (defvar coq-tactics (append coq-state-changing-tactics coq-state-preserving-tactics)) (defvar coq-retractable-instruct (append coq-state-changing-tactics coq-keywords-state-changing-commands)) (defvar coq-non-retractable-instruct (append coq-state-preserving-tactics coq-keywords-state-preserving-commands)) (defvar coq-keywords (append coq-keywords-goal coq-keywords-save coq-keywords-decl coq-keywords-defn coq-keywords-commands) "All keywords in a Coq script.") (defvar coq-symbols '("|" "||" ":" ";" "," "(" ")" "[" "]" "{" "}" ":=" "=>" "->" ".") "Punctuation Symbols used by Coq.") ;; ----- regular expressions (defvar coq-error-regexp "^\\(Error:\\|Discarding pattern\\|Syntax error:\\|System Error:\\|User Error:\\|User error:\\|Anomaly[:.]\\|Toplevel input[,]\\)" "A regexp indicating that the Coq process has identified an error.") (defvar coq-id proof-id) (defvar coq-id-shy "\\(?:\\w\\(?:\\w\\|\\s_\\)*\\)") (defvar coq-ids (proof-ids coq-id " ")) (defun coq-first-abstr-regexp (paren end) (concat paren "\\s-*\\(" coq-ids "\\)\\s-*" end)) (defcustom coq-variable-highlight-enable t "Activates partial bound variable highlighting" :type 'boolean :group 'coq) (defvar coq-font-lock-terms (if coq-variable-highlight-enable (list ;; lambda binders (list (coq-first-abstr-regexp "\\" "\\(?:=>\\|:\\)") 1 'font-lock-variable-name-face) ;; forall binder (list (coq-first-abstr-regexp "\\" "\\(?:,\\|:\\)") 1 'font-lock-variable-name-face) ; (list "\\" ; (list 0 font-lock-type-face) ; (list (concat "[^ :]\\s-*\\(" coq-ids "\\)\\s-*") nil nil ; (list 0 font-lock-variable-name-face))) ;; parenthesized binders (list (coq-first-abstr-regexp "(" ":[ a-zA-Z]") 1 'font-lock-variable-name-face) )) "*Font-lock table for Coq terms.") ;; According to Coq, "Definition" is both a declaration and a goal. ;; It is understood here as being a goal. This is important for ;; recognizing global identifiers, see coq-global-p. (defconst coq-save-command-regexp-strict (proof-anchor-regexp (concat "\\(Time\\s-+\\|\\)\\(" (proof-ids-to-regexp coq-keywords-save-strict) "\\)"))) (defconst coq-save-command-regexp (proof-anchor-regexp (concat "\\(Time\\s-+\\|\\)\\(" (proof-ids-to-regexp coq-keywords-save) "\\)"))) (defconst coq-save-with-hole-regexp (concat "\\(Time\\s-+\\|\\)\\(" (proof-ids-to-regexp coq-keywords-save-strict) "\\)\\s-+\\(" coq-id "\\)\\s-*\\.")) (defconst coq-goal-command-regexp (proof-anchor-regexp (proof-ids-to-regexp coq-keywords-goal))) (defconst coq-goal-with-hole-regexp (concat "\\(" (proof-ids-to-regexp coq-keywords-goal) "\\)\\s-+\\(" coq-id "\\)\\s-*:?")) (defconst coq-decl-with-hole-regexp (concat "\\(" (proof-ids-to-regexp coq-keywords-decl) "\\)\\s-+\\(" coq-ids "\\)\\s-*:")) ;; (defconst coq-decl-with-hole-regexp ;; (if coq-variable-highlight-enable coq-decl-with-hole-regexp-1 'nil)) (defconst coq-defn-with-hole-regexp (concat "\\(" (proof-ids-to-regexp coq-keywords-defn) "\\)\\s-+\\(" coq-id "\\)")) ;; must match: ;; "with f x y :" (followed by = or not) ;; "with f x y (z:" (not followed by =) ;; BUT NOT: ;; "with f ... (x:=" ;; "match ... with .. => " (defconst coq-with-with-hole-regexp (concat "\\(with\\)\\s-+\\(" coq-id "\\)\\s-*\\([^=(.]*:\\|[^(]*(\\s-*" coq-id "\\s-*:[^=]\\)")) ;; marche aussi a peu pres ;; (concat "\\(with\\)\\s-+\\(" coq-id "\\)\\s-*\\([^(.]*:\\|.*)[^(.]*:=\\)")) ;;"\\\\|\\\\|\\" (defvar coq-font-lock-keywords-1 (append coq-font-lock-terms (list (cons (proof-ids-to-regexp coq-solve-tactics) 'coq-solve-tactics-face) (cons (proof-ids-to-regexp coq-keywords) 'font-lock-keyword-face) (cons (proof-ids-to-regexp coq-reserved) 'font-lock-type-face) (cons (proof-ids-to-regexp coq-tactics ) 'proof-tactics-name-face) (cons (proof-ids-to-regexp coq-tacticals) 'proof-tacticals-name-face) (cons (proof-ids-to-regexp (list "Set" "Type" "Prop")) 'font-lock-type-face) (cons "============================" 'font-lock-keyword-face) (cons "Subtree proved!" 'font-lock-keyword-face) (cons "subgoal [0-9]+ is:" 'font-lock-keyword-face) (list "^\\([^ \n]+\\) \\(is defined\\)" (list 2 'font-lock-keyword-face t) (list 1 'font-lock-function-name-face t)) (list coq-goal-with-hole-regexp 2 'font-lock-function-name-face)) (if coq-variable-highlight-enable (list (list coq-decl-with-hole-regexp 2 'font-lock-variable-name-face))) (list (list coq-defn-with-hole-regexp 2 'font-lock-function-name-face) (list coq-with-with-hole-regexp 2 'font-lock-function-name-face) (list coq-save-with-hole-regexp 2 'font-lock-function-name-face) ;; Remove spurious variable and function faces on commas. '(proof-zap-commas)))) (defvar coq-font-lock-keywords coq-font-lock-keywords-1) (defun coq-init-syntax-table () "Set appropriate values for syntax table in current buffer." (modify-syntax-entry ?\$ ".") (modify-syntax-entry ?\/ ".") (modify-syntax-entry ?\\ ".") (modify-syntax-entry ?+ ".") (modify-syntax-entry ?- ".") (modify-syntax-entry ?= ".") (modify-syntax-entry ?% ".") (modify-syntax-entry ?< ".") (modify-syntax-entry ?> ".") (modify-syntax-entry ?\& ".") (modify-syntax-entry ?_ "_") (modify-syntax-entry ?\' "_") (modify-syntax-entry ?\| ".") ;; should maybe be "_" but it makes coq-find-and-forget (in gallina.el) bug (modify-syntax-entry ?\. ".") (condition-case nil ;; Try to use Emacs-21's nested comments. (modify-syntax-entry ?\* ". 23n") ;; Revert to non-nested comments if that failed. (error (modify-syntax-entry ?\* ". 23"))) (modify-syntax-entry ?\( "()1") (modify-syntax-entry ?\) ")(4")) (defconst coq-generic-expression (mapcar (lambda (kw) (list (capitalize kw) (concat "\\<" kw "\\>" "\\s-+\\(\\w+\\)\\W" ) 1)) (append coq-keywords-decl coq-keywords-defn coq-keywords-goal))) (provide 'gallina-syntax) ;;; gallina-syntax.el ends here ; Local Variables: *** ; indent-tabs-mode: nil *** ; End: *** coq-8.6/tools/coq-font-lock.el0000644000175000017500000001144413022274260015621 0ustar mdenesmdenes;; coq-font-lock.el --- Coq syntax highlighting for Emacs - compatibilty code ;; Pierre Courtieu, may 2009 ;; ;; Authors: Pierre Courtieu ;; License: GPL (GNU GENERAL PUBLIC LICENSE) ;; Maintainer: Pierre Courtieu ;; This is copy paste from ProofGeneral by David Aspinall ;; . ProofGeneral is under GPL and Copyright ;; (C) LFCS Edinburgh. ;;; Commentary: ;; This file contains the code necessary to coq-syntax.el and ;; coq-db.el from ProofGeneral. It is also pocked from ProofGeneral. ;;; History: ;; First created from ProofGeneral may 28th 2009 ;;; Code: (setq coq-version-is-V8-1 t) (defun coq-build-regexp-list-from-db (db &optional filter) "Take a keyword database DB and return the list of regexps for font-lock. If non-nil Optional argument FILTER is a function applying to each line of DB. For each line if FILTER returns nil, then the keyword is not added to the regexp. See `coq-syntax-db' for DB structure." (let ((l db) (res ())) (while l (let* ((hd (car l)) (tl (cdr l)) ; hd is the first infos list (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion (e4 (car-safe tl3)) (tl4 (cdr-safe tl3)) ; e4 = state changing (e5 (car-safe tl4)) (tl5 (cdr-safe tl4)) ; e5 = colorization string ) ;; TODO delete doublons (when (and e5 (or (not filter) (funcall filter hd))) (setq res (nconc res (list e5)))) ; careful: nconc destructive! (setq l tl))) res )) (defun filter-state-preserving (l) ; checkdoc-params: (l) "Not documented." (not (nth 3 l))) ; fourth argument is nil --> state preserving command (defun filter-state-changing (l) ; checkdoc-params: (l) "Not documented." (nth 3 l)) ; fourth argument is nil --> state preserving command ;; Generic font-lock (defvar proof-id "\\(\\w\\(\\w\\|\\s_\\)*\\)" "A regular expression for parsing identifiers.") ;; For font-lock, we treat ,-separated identifiers as one identifier ;; and refontify commata using \{proof-zap-commas}. (defun proof-anchor-regexp (e) "Anchor (\\`) and group the regexp E." (concat "\\`\\(" e "\\)")) (defun proof-ids (proof-id &optional sepregexp) "Generate a regular expression for separated lists of identifiers PROOF-ID. Default is comma separated, or SEPREGEXP if set." (concat proof-id "\\(\\s-*" (or sepregexp ",") "\\s-*" proof-id "\\)*")) (defun proof-ids-to-regexp (l) "Maps a non-empty list of tokens `L' to a regexp matching any element." (if (featurep 'xemacs) (mapconcat (lambda (s) (concat "\\_<" s "\\_>")) l "\\|") ;; old version (concat "\\_<\\(?:" (mapconcat 'identity l "\\|") "\\)\\_>"))) ;; TODO: get rid of this list. Does 'default work widely enough ;; by now? (defconst pg-defface-window-systems '(x ;; bog standard mswindows ;; Windows w32 ;; Windows gtk ;; gtk emacs (obsolete?) mac ;; used by Aquamacs carbon ;; used by Carbon XEmacs ns ;; NeXTstep Emacs (Emacs.app) x-toolkit) ;; possible catch all (but probably not) "A list of possible values for variable `window-system'. If you are on a window system and your value of variable `window-system' is not listed here, you may not get the correct syntax colouring behaviour.") (defmacro proof-face-specs (bl bd ow) "Return a spec for `defface' with BL for light bg, BD for dark, OW o/w." `(append (apply 'append (mapcar (lambda (ty) (list (list (list (list 'type ty) '(class color) (list 'background 'light)) (quote ,bl)) (list (list (list 'type ty) '(class color) (list 'background 'dark)) (quote ,bd)))) pg-defface-window-systems)) (list (list t (quote ,ow))))) ;;A new face for tactics (defface coq-solve-tactics-face (proof-face-specs (:foreground "forestgreen" t) ; for bright backgrounds (:foreground "forestgreen" t) ; for dark backgrounds ()) ; for black and white "Face for names of closing tactics in proof scripts." :group 'proof-faces) ;;A new face for tactics which fail when they don't kill the current goal (defface coq-solve-tactics-face (proof-face-specs (:foreground "red" t) ; for bright backgrounds (:foreground "red" t) ; for dark backgrounds ()) ; for black and white "Face for names of closing tactics in proof scripts." :group 'proof-faces) (defconst coq-solve-tactics-face 'coq-solve-tactics-face "Expression that evaluates to a face. Required so that 'proof-solve-tactics-face is a proper facename") (defconst proof-tactics-name-face 'coq-solve-tactics-face) (defconst proof-tacticals-name-face 'coq-solve-tactics-face) (provide 'coq-font-lock) ;;; coq-font-lock.el ends here coq-8.6/tools/coq-sl.sty0000644000175000017500000000134413022274260014560 0ustar mdenesmdenes% COQ style option, for use with the coq-latex filter. \typeout{Document Style option `coq-sl' <7 Apr 92>.} \ifcase\@ptsize \font\sltt = cmsltt10 \or \font\sltt = cmsltt10 \@halfmag \or \font\sltt = cmsltt10 \@magscale1 \fi {\catcode`\^^M=\active % \gdef\@coqinputline#1^^M{\tt Coq < #1\par} % \gdef\@coqoutputline#1^^M{\sltt#1\par} } % \def\@coqblankline{\medskip} \chardef\@coqbackslash="5C \def\coq{ \bgroup \flushleft \parindent 0pt \parskip 0pt \let\do\@makeother\dospecials \catcode`\^^M=\active \catcode`\\=0 \catcode`\ \active \frenchspacing \@vobeyspaces \let\?\@coqinputline \let\:\@coqoutputline \let\;\@coqblankline \let\\\@coqbackslash } \def\endcoq{ \endflushleft \egroup\noindent } coq-8.6/tools/README.emacs0000644000175000017500000000150113022274260014563 0ustar mdenesmdenes DESCRIPTION: An emacs mode to help editing Coq vernacular files. AUTHOR: Jean-Christophe Filliatre (jcfillia@lri.fr), from the Caml mode of Xavier Leroy. CONTENTS: gallina.el A major mode for editing Coq files in Gnu Emacs USAGE: Add the following lines to your .emacs file: (setq auto-mode-alist (cons '("\\.v$" . coq-mode) auto-mode-alist)) (autoload 'coq-mode "gallina" "Major mode for editing Coq vernacular." t) The Coq major mode is triggered by visiting a file with extension .v, or manually by M-x coq-mode. It gives you the correct syntax table for the Coq language, and also a rudimentary indentation facility: - pressing TAB at the beginning of a line indents the line like the line above - extra TABs increase the indentation level (by 2 spaces by default) - M-TAB decreases the indentation level. coq-8.6/tools/coqdep_lexer.mll0000644000175000017500000002300713022274260016001 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* " | "." | ".." | ".(" | ".[" | ":" | "::" | ":=" | ";" | ";;" | "<-" | "=" | "[" | "[|" | "[<" | "]" | "_" | "{" | "|" | "||" | "|]" | ">]" | "}" | "!=" | "-" | "-." { caml_action lexbuf } | ['!' '?' '~'] ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * { caml_action lexbuf } | ['=' '<' '>' '@' '^' '|' '&' '$'] ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * { caml_action lexbuf } | ['+' '-'] ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * { caml_action lexbuf } | "**" ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * { caml_action lexbuf } | ['*' '/' '%'] ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * { caml_action lexbuf } | eof { raise Fin_fichier } | _ { caml_action lexbuf } and comment = parse | "(*" { comment lexbuf; comment lexbuf } | "*)" { () } | "'" [^ '\\' '\''] "'" { comment lexbuf } | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" { comment lexbuf } | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { comment lexbuf } | eof { raise Fin_fichier } | _ { comment lexbuf } and string = parse | '"' (* '"' *) { () } | '\\' ("\010" | "\013" | "\010\013") [' ' '\009'] * { string lexbuf } | '\\' ['\\' '"' 'n' 't' 'b' 'r'] (*'"'*) { string lexbuf } | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { string lexbuf } | eof { raise Fin_fichier } | _ { string lexbuf } and load_file = parse | '"' [^ '"']* '"' (*'"'*) { let s = lexeme lexbuf in parse_dot lexbuf; Load (unquote_vfile_string s) } | coq_ident { let s = lexeme lexbuf in skip_to_dot lexbuf; Load s } | eof { syntax_error lexbuf } | _ { syntax_error lexbuf } and require_file from = parse | "(*" { comment lexbuf; require_file from lexbuf } | space+ { require_file from lexbuf } | coq_ident { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in let qid = coq_qual_id_list [name] lexbuf in parse_dot lexbuf; Require (from, qid) } | eof { syntax_error lexbuf } | _ { syntax_error lexbuf } and skip_to_dot = parse | dot { () } | eof { syntax_error lexbuf } | _ { skip_to_dot lexbuf } and parse_dot = parse | dot { () } | eof { syntax_error lexbuf } | _ { syntax_error lexbuf } and coq_qual_id = parse | "(*" { comment lexbuf; coq_qual_id lexbuf } | space+ { coq_qual_id lexbuf } | coq_ident { coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf } | _ { syntax_error lexbuf } and coq_qual_id_tail module_name = parse | "(*" { comment lexbuf; coq_qual_id_tail module_name lexbuf } | space+ { coq_qual_id_tail module_name lexbuf } | coq_field { coq_qual_id_tail (field_name (Lexing.lexeme lexbuf) :: module_name) lexbuf } | eof { syntax_error lexbuf } | _ { backtrack lexbuf; List.rev module_name } and coq_qual_id_list module_names = parse | "(*" { comment lexbuf; coq_qual_id_list module_names lexbuf } | space+ { coq_qual_id_list module_names lexbuf } | coq_ident { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in coq_qual_id_list (name :: module_names) lexbuf } | eof { syntax_error lexbuf } | _ { backtrack lexbuf; List.rev module_names } and modules mllist = parse | space+ { modules mllist lexbuf } | "(*" { comment lexbuf; modules mllist lexbuf } | '"' [^'"']* '"' { let lex = (Lexing.lexeme lexbuf) in let str = String.sub lex 1 (String.length lex - 2) in modules (str :: mllist) lexbuf} | eof { syntax_error lexbuf } | _ { Declare (List.rev mllist) } and qual_id ml_module_name = parse | '.' [^ '.' '(' '['] { Use_module (String.uncapitalize ml_module_name) } | eof { raise Fin_fichier } | _ { caml_action lexbuf } and mllib_list = parse | caml_up_ident { let s = String.uncapitalize (Lexing.lexeme lexbuf) in s :: mllib_list lexbuf } | "*predef*" { mllib_list lexbuf } | space+ { mllib_list lexbuf } | eof { [] } | _ { syntax_error lexbuf } and ocamldep_parse = parse | [^ ':' ]* ':' { mllib_list lexbuf } coq-8.6/tools/coqdep_lexer.mli0000644000175000017500000000175513022274260016004 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* coq_token val caml_action : Lexing.lexbuf -> mL_token val mllib_list : Lexing.lexbuf -> string list val ocamldep_parse : Lexing.lexbuf -> string list coq-8.6/tools/gallina.el0000644000175000017500000001133613022274260014554 0ustar mdenesmdenes;; gallina.el --- Coq mode editing commands for Emacs ;; ;; Jean-Christophe Filliatre, march 1995 ;; Shamelessly copied from caml.el, Xavier Leroy, july 1993. ;; ;; modified by Marco Maggesi for gallina-inferior ; compatibility code for proofgeneral files (require 'coq-font-lock) ; ProofGeneral files. remember to remove coq version tests in ; gallina-syntax.el (require 'gallina-syntax) (defvar coq-mode-map nil "Keymap used in Coq mode.") (if coq-mode-map () (setq coq-mode-map (make-sparse-keymap)) (define-key coq-mode-map "\t" 'coq-indent-command) (define-key coq-mode-map "\M-\t" 'coq-unindent-command) (define-key coq-mode-map "\C-c\C-c" 'compile) ) (defvar coq-mode-syntax-table nil "Syntax table in use in Coq mode buffers.") (if coq-mode-syntax-table () (setq coq-mode-syntax-table (make-syntax-table)) ; ( is first character of comment start (modify-syntax-entry ?\( "()1" coq-mode-syntax-table) ; * is second character of comment start, ; and first character of comment end (modify-syntax-entry ?* ". 23" coq-mode-syntax-table) ; ) is last character of comment end (modify-syntax-entry ?\) ")(4" coq-mode-syntax-table) ; quote is a string-like delimiter (for character literals) (modify-syntax-entry ?' "\"" coq-mode-syntax-table) ; quote is part of words (modify-syntax-entry ?' "w" coq-mode-syntax-table) ) (defvar coq-mode-indentation 2 "*Indentation for each extra tab in Coq mode.") (defun coq-mode-variables () (set-syntax-table coq-mode-syntax-table) (make-local-variable 'paragraph-start) (setq paragraph-start (concat "^$\\|" page-delimiter)) (make-local-variable 'paragraph-separate) (setq paragraph-separate paragraph-start) (make-local-variable 'paragraph-ignore-fill-prefix) (setq paragraph-ignore-fill-prefix t) (make-local-variable 'require-final-newline) (setq require-final-newline t) (make-local-variable 'comment-start) (setq comment-start "(* ") (make-local-variable 'comment-end) (setq comment-end " *)") (make-local-variable 'comment-column) (setq comment-column 40) (make-local-variable 'comment-start-skip) (setq comment-start-skip "(\\*+ *") (make-local-variable 'parse-sexp-ignore-comments) (setq parse-sexp-ignore-comments nil) (make-local-variable 'indent-line-function) (setq indent-line-function 'coq-indent-command) (make-local-variable 'font-lock-keywords) (setq font-lock-defaults '(coq-font-lock-keywords-1))) ;;; The major mode (defun coq-mode () "Major mode for editing Coq code. Tab at the beginning of a line indents this line like the line above. Extra tabs increase the indentation level. \\{coq-mode-map} The variable coq-mode-indentation indicates how many spaces are inserted for each indentation level." (interactive) (kill-all-local-variables) (setq major-mode 'coq-mode) (setq mode-name "coq") (use-local-map coq-mode-map) (coq-mode-variables) (run-hooks 'coq-mode-hook)) ;;; Indentation stuff (defun coq-in-indentation () "Tests whether all characters between beginning of line and point are blanks." (save-excursion (skip-chars-backward " \t") (bolp))) (defun coq-indent-command () "Indent the current line in Coq mode. When the point is at the beginning of an empty line, indent this line like the line above. When the point is at the beginning of an indented line \(i.e. all characters between beginning of line and point are blanks\), increase the indentation by one level. The indentation size is given by the variable coq-mode-indentation. In all other cases, insert a tabulation (using insert-tab)." (interactive) (let* ((begline (save-excursion (beginning-of-line) (point))) (current-offset (- (point) begline)) (previous-indentation (save-excursion (if (eq (forward-line -1) 0) (current-indentation) 0)))) (cond ((and (bolp) (looking-at "[ \t]*$") (> previous-indentation 0)) (indent-to previous-indentation)) ((coq-in-indentation) (indent-to (+ current-offset coq-mode-indentation))) (t (insert-tab))))) (defun coq-unindent-command () "Decrease indentation by one level in Coq mode. Works only if the point is at the beginning of an indented line \(i.e. all characters between beginning of line and point are blanks\). Does nothing otherwise." (interactive) (let* ((begline (save-excursion (beginning-of-line) (point))) (current-offset (- (point) begline))) (if (and (>= current-offset coq-mode-indentation) (coq-in-indentation)) (backward-delete-char-untabify coq-mode-indentation)))) ;;; gallina.el ends here (provide 'gallina) coq-8.6/tools/coqdep_common.ml0000644000175000017500000004766413022274260016015 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (f, "") | s :: _ when Filename.check_suffix f s -> (Filename.chop_suffix f s, s) | _ :: l -> get_extension f l (** [basename_noext] removes both the directory part and the extension (if necessary) of a filename *) let basename_noext filename = let fn = Filename.basename filename in try Filename.chop_extension fn with Invalid_argument _ -> fn (** ML Files specified on the command line. In the entries: - the first string is the basename of the file, without extension nor directory part - the second string of [mlAccu] is the extension (either .ml or .ml4) - the [dir] part is the directory, with None used as the current directory *) let mlAccu = ref ([] : (string * string * dir) list) and mliAccu = ref ([] : (string * dir) list) and mllibAccu = ref ([] : (string * dir) list) and mlpackAccu = ref ([] : (string * dir) list) (** Coq files specifies on the command line: - first string is the full filename, with only its extension removed - second string is the absolute version of the previous (via getcwd) *) let vAccu = ref ([] : (string * string) list) (** Queue operations *) let addQueue q v = q := v :: !q let safe_hash_add cmp clq q (k, (v, b)) = try let (v2, _) = Hashtbl.find q k in if not (cmp v v2) then let nv = try v :: StrListMap.find k !clq with Not_found -> [v; v2] in clq := StrListMap.add k nv !clq; (* overwrite previous bindings, as coqc does *) Hashtbl.add q k (v, b) with Not_found -> Hashtbl.add q k (v, b) (** Files found in the loadpaths. For the ML files, the string is the basename without extension. *) let warning_ml_clash x s suff s' suff' = if suff = suff' then eprintf "*** Warning: %s%s already found in %s (discarding %s%s)\n" x suff (match s with None -> "." | Some d -> d) ((match s' with None -> "." | Some d -> d) // x) suff let mkknown () = let h = (Hashtbl.create 19 : (string, dir * string) Hashtbl.t) in let add x s suff = try let s',suff' = Hashtbl.find h x in warning_ml_clash x s' suff' s suff with Not_found -> Hashtbl.add h x (s,suff) and iter f = Hashtbl.iter (fun x (s,_) -> f x s) h and search x = try Some (fst (Hashtbl.find h x)) with Not_found -> None in add, iter, search let add_ml_known, iter_ml_known, search_ml_known = mkknown () let add_mli_known, iter_mli_known, search_mli_known = mkknown () let add_mllib_known, _, search_mllib_known = mkknown () let add_mlpack_known, _, search_mlpack_known = mkknown () let vKnown = (Hashtbl.create 19 : (string list, string * bool) Hashtbl.t) (** The associated boolean is true if this is a root path. *) let coqlibKnown = (Hashtbl.create 19 : (string list, unit) Hashtbl.t) let get_prefix p l = let rec drop_prefix_rec = function | (h1::tp, h2::tl) when h1 = h2 -> drop_prefix_rec (tp,tl) | ([], tl) -> Some tl | _ -> None in drop_prefix_rec (p, l) let search_table (type r) is_root table ?from s = match from with | None -> Hashtbl.find table s | Some from -> let module M = struct exception Found of r end in let iter logpath binding = if is_root binding then match get_prefix from logpath with | None -> () | Some rem -> match get_prefix (List.rev s) (List.rev rem) with | None -> () | Some _ -> raise (M.Found binding) in try Hashtbl.iter iter table; raise Not_found with M.Found s -> s let search_v_known ?from s = let is_root (_, root) = root in try let (phys_dir, _) = search_table is_root vKnown ?from s in Some phys_dir with Not_found -> None let is_in_coqlib ?from s = let is_root _ = true in try search_table is_root coqlibKnown ?from s; true with Not_found -> false let clash_v = ref (StrListMap.empty : string list StrListMap.t) let error_cannot_parse s (i,j) = Printf.eprintf "File \"%s\", characters %i-%i: Syntax error\n" s i j; exit 1 let warning_module_notfound f s = eprintf "*** Warning: in file %s, library %s is required and has not been found in the loadpath!\n%!" f (String.concat "." s) let warning_declare f s = eprintf "*** Warning: in file %s, declared ML module " f; eprintf "%s has not been found!\n" s; flush stderr let warning_clash file dir = match StrListMap.find dir !clash_v with (f1::f2::fl) -> let f = Filename.basename f1 in let d1 = Filename.dirname f1 in let d2 = Filename.dirname f2 in let dl = List.rev_map Filename.dirname fl in eprintf "*** Warning: in file %s, \n required library %s matches several files in path\n (found %s.v in " file (String.concat "." dir) f; List.iter (fun s -> eprintf "%s, " s) dl; eprintf "%s and %s; used the latter)\n" d2 d1 | _ -> assert false let warning_cannot_open_dir dir = eprintf "*** Warning: cannot open %s\n" dir; flush stderr let safe_assoc from verbose file k = if verbose && StrListMap.mem k !clash_v then warning_clash file k; match search_v_known ?from k with | None -> raise Not_found | Some path -> path let absolute_dir dir = let current = Sys.getcwd () in Sys.chdir dir; let dir' = Sys.getcwd () in Sys.chdir current; dir' let absolute_file_name basename odir = let dir = match odir with Some dir -> dir | None -> "." in absolute_dir dir // basename (** [find_dir_logpath dir] Return the logical path of directory [dir] if it has been given one. Raise [Not_found] otherwise. In particular we can check if "." has been attributed a logical path after processing all options and silently give the default one if it hasn't. We may also use this to warn if ap hysical path is met twice.*) let register_dir_logpath,find_dir_logpath = let tbl: (string, string list) Hashtbl.t = Hashtbl.create 19 in let reg physdir logpath = Hashtbl.add tbl (absolute_dir physdir) logpath in let fnd physdir = Hashtbl.find tbl (absolute_dir physdir) in reg,fnd let file_name s = function | None -> s | Some "." -> s | Some d -> d // s let depend_ML str = match search_mli_known str, search_ml_known str with | Some mlidir, Some mldir -> let mlifile = file_name str mlidir and mlfile = file_name str mldir in (" "^mlifile^".cmi"," "^mlfile^".cmx") | None, Some mldir -> let mlfile = file_name str mldir in (" "^mlfile^".cmo"," "^mlfile^".cmx") | Some mlidir, None -> let mlifile = file_name str mlidir in (" "^mlifile^".cmi"," "^mlifile^".cmi") | None, None -> "", "" let soustraite_fichier_ML dep md ext = try let chan = open_process_in (dep^" -modules "^md^ext) in let list = ocamldep_parse (Lexing.from_channel chan) in let a_faire = ref "" in let a_faire_opt = ref "" in List.iter (fun str -> let byte,opt = depend_ML str in a_faire := !a_faire ^ byte; a_faire_opt := !a_faire_opt ^ opt) (List.rev list); (!a_faire, !a_faire_opt) with | Sys_error _ -> ("","") | _ -> Printf.eprintf "Coqdep: subprocess %s failed on file %s%s\n" dep md ext; exit 1 let autotraite_fichier_ML md ext = try let chan = open_in (md ^ ext) in let buf = Lexing.from_channel chan in let deja_vu = ref (StrSet.singleton md) in let a_faire = ref "" in let a_faire_opt = ref "" in begin try while true do let (Use_module str) = caml_action buf in if StrSet.mem str !deja_vu then () else begin deja_vu := StrSet.add str !deja_vu; let byte,opt = depend_ML str in a_faire := !a_faire ^ byte; a_faire_opt := !a_faire_opt ^ opt end done with Fin_fichier -> () end; close_in chan; (!a_faire, !a_faire_opt) with Sys_error _ -> ("","") let traite_fichier_ML md ext = match !option_mldep with | Some dep -> soustraite_fichier_ML dep md ext | None -> autotraite_fichier_ML md ext let traite_fichier_modules md ext = try let chan = open_in (md ^ ext) in let list = mllib_list (Lexing.from_channel chan) in List.fold_left (fun a_faire str -> match search_mlpack_known str with | Some mldir -> let file = file_name str mldir in a_faire^" "^file | None -> match search_ml_known str with | Some mldir -> let file = file_name str mldir in a_faire^" "^file | None -> a_faire) "" list with | Sys_error _ -> "" | Syntax_error (i,j) -> error_cannot_parse (md^ext) (i,j) (* Makefile's escaping rules are awful: $ is escaped by doubling and other special characters are escaped by backslash prefixing while backslashes themselves must be escaped only if part of a sequence followed by a special character (i.e. in case of ambiguity with a use of it as escaping character). Moreover (even if not crucial) it is apparently not possible to directly escape ';' and leading '\t'. *) let escape = let s' = Buffer.create 10 in fun s -> Buffer.clear s'; for i = 0 to String.length s - 1 do let c = s.[i] in if c = ' ' || c = '#' || c = ':' (* separators and comments *) || c = '%' (* pattern *) || c = '?' || c = '[' || c = ']' || c = '*' (* expansion in filenames *) || i=0 && c = '~' && (String.length s = 1 || s.[1] = '/' || 'A' <= s.[1] && s.[1] <= 'Z' || 'a' <= s.[1] && s.[1] <= 'z') (* homedir expansion *) then begin let j = ref (i-1) in while !j >= 0 && s.[!j] = '\\' do Buffer.add_char s' '\\'; decr j (* escape all preceding '\' *) done; Buffer.add_char s' '\\'; end; if c = '$' then Buffer.add_char s' '$'; Buffer.add_char s' c done; Buffer.contents s' let compare_file f1 f2 = absolute_file_name (Filename.basename f1) (Some (Filename.dirname f1)) = absolute_file_name (Filename.basename f2) (Some (Filename.dirname f2)) let canonize f = let f' = absolute_dir (Filename.dirname f) // Filename.basename f in match List.filter (fun (_,full) -> f' = full) !vAccu with | (f,_) :: _ -> escape f | _ -> escape f module VData = struct type t = string list option * string list let compare = Pervasives.compare end module VCache = Set.Make(VData) let rec traite_fichier_Coq suffixe verbose f = try let chan = open_in f in let buf = Lexing.from_channel chan in let deja_vu_v = ref VCache.empty in let deja_vu_ml = ref StrSet.empty in try while true do let tok = coq_action buf in match tok with | Require (from, strl) -> List.iter (fun str -> if not (VCache.mem (from, str) !deja_vu_v) then begin deja_vu_v := VCache.add (from, str) !deja_vu_v; try let file_str = safe_assoc from verbose f str in printf " %s%s" (canonize file_str) suffixe with Not_found -> if verbose && not (is_in_coqlib ?from str) then let str = match from with | None -> str | Some pth -> pth @ str in warning_module_notfound f str end) strl | Declare sl -> let declare suff dir s = let base = file_name s dir in let opt = if !option_natdynlk then " "^base^".cmxs" else "" in printf " %s%s%s" (escape base) suff opt in let decl str = let s = basename_noext str in if not (StrSet.mem s !deja_vu_ml) then begin deja_vu_ml := StrSet.add s !deja_vu_ml; match search_mllib_known s with | Some mldir -> declare ".cma" mldir s | None -> match search_mlpack_known s with | Some mldir -> declare ".cmo" mldir s | None -> match search_ml_known s with | Some mldir -> declare ".cmo" mldir s | None -> warning_declare f str end in List.iter decl sl | Load str -> let str = Filename.basename str in if not (VCache.mem (None, [str]) !deja_vu_v) then begin deja_vu_v := VCache.add (None, [str]) !deja_vu_v; try let (file_str, _) = Hashtbl.find vKnown [str] in let canon = canonize file_str in printf " %s.v" canon; traite_fichier_Coq suffixe true (canon ^ ".v") with Not_found -> () end | AddLoadPath _ | AddRecLoadPath _ -> (* TODO *) () done with Fin_fichier -> close_in chan | Syntax_error (i,j) -> close_in chan; error_cannot_parse f (i,j) with Sys_error _ -> () let mL_dependencies () = List.iter (fun (name,ext,dirname) -> let fullname = file_name name dirname in let (dep,dep_opt) = traite_fichier_ML fullname ext in let intf = match search_mli_known name with | None -> "" | Some mldir -> " "^(file_name name mldir)^".cmi" in let efullname = escape fullname in printf "%s.cmo:%s%s\n" efullname dep intf; printf "%s.cmx:%s%s\n" efullname dep_opt intf; flush stdout) (List.rev !mlAccu); List.iter (fun (name,dirname) -> let fullname = file_name name dirname in let (dep,_) = traite_fichier_ML fullname ".mli" in printf "%s.cmi:%s\n" (escape fullname) dep; flush stdout) (List.rev !mliAccu); List.iter (fun (name,dirname) -> let fullname = file_name name dirname in let dep = traite_fichier_modules fullname ".mllib" in let efullname = escape fullname in printf "%s_MLLIB_DEPENDENCIES:=%s\n" efullname dep; printf "%s.cma:$(addsuffix .cmo,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname; printf "%s.cmxa:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname; flush stdout) (List.rev !mllibAccu); List.iter (fun (name,dirname) -> let fullname = file_name name dirname in let dep = traite_fichier_modules fullname ".mlpack" in let efullname = escape fullname in printf "%s_MLPACK_DEPENDENCIES:=%s\n" efullname dep; printf "%s.cmo:$(addsuffix .cmo,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname; printf "%s.cmx:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname; flush stdout) (List.rev !mlpackAccu) let coq_dependencies () = List.iter (fun (name,_) -> let ename = escape name in let glob = if !option_noglob then "" else " "^ename^".glob" in printf "%s%s%s %s.v.beautified: %s.v" ename !suffixe glob ename ename; traite_fichier_Coq !suffixe true (name ^ ".v"); printf "\n"; printf "%s.vio: %s.v" ename ename; traite_fichier_Coq ".vio" true (name ^ ".v"); printf "\n"; flush stdout) (List.rev !vAccu) let rec suffixes = function | [] -> assert false | [name] -> [[name]] | dir::suffix as l -> l::suffixes suffix let add_caml_known phys_dir _ f = let basename,suff = get_extension f [".ml";".mli";".ml4";".mllib";".mlpack"] in match suff with | ".ml"|".ml4" -> add_ml_known basename (Some phys_dir) suff | ".mli" -> add_mli_known basename (Some phys_dir) suff | ".mllib" -> add_mllib_known basename (Some phys_dir) suff | ".mlpack" -> add_mlpack_known basename (Some phys_dir) suff | _ -> () let add_coqlib_known recur phys_dir log_dir f = match get_extension f [".vo"; ".vio"] with | (basename, (".vo" | ".vio")) -> let name = log_dir@[basename] in let paths = if recur then suffixes name else [name] in List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths | _ -> () let add_known recur phys_dir log_dir f = match get_extension f [".v"; ".vo"; ".vio"] with | (basename,".v") -> let name = log_dir@[basename] in let file = phys_dir//basename in let () = safe_hash_add compare_file clash_v vKnown (name, (file, true)) in if recur then let paths = List.tl (suffixes name) in let iter n = safe_hash_add compare_file clash_v vKnown (n, (file, false)) in List.iter iter paths | (basename, (".vo" | ".vio")) when not(!option_boot) -> let name = log_dir@[basename] in let paths = if recur then suffixes name else [name] in List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths | _ -> () (* Visits all the directories under [dir], including [dir] *) let is_not_seen_directory phys_f = not (StrSet.mem phys_f !norec_dirs) let rec add_directory recur add_file phys_dir log_dir = register_dir_logpath phys_dir log_dir; let f = function | FileDir (phys_f,f) -> if is_not_seen_directory phys_f && recur then add_directory true add_file phys_f (log_dir @ [f]) | FileRegular f -> add_file phys_dir log_dir f in if exists_dir phys_dir then process_directory f phys_dir else warning_cannot_open_dir phys_dir (** Simply add this directory and imports it, no subdirs. This is used by the implicit adding of the current path (which is not recursive). *) let add_norec_dir_import add_file phys_dir log_dir = try add_directory false (add_file true) phys_dir log_dir with Unix_error _ -> () (** -Q semantic: go in subdirs but only full logical paths are known. *) let add_rec_dir_no_import add_file phys_dir log_dir = try add_directory true (add_file false) phys_dir log_dir with Unix_error _ -> () (** -R semantic: go in subdirs and suffixes of logical paths are known. *) let add_rec_dir_import add_file phys_dir log_dir = add_directory true (add_file true) phys_dir log_dir (** -R semantic but only on immediate capitalized subdirs *) let add_rec_uppercase_subdirs add_file phys_dir log_dir = process_subdirectories (fun phys_dir f -> add_directory true (add_file true) phys_dir (log_dir@[String.capitalize f])) phys_dir (** -I semantic: do not go in subdirs. *) let add_caml_dir phys_dir = add_directory false add_caml_known phys_dir [] let rec treat_file old_dirname old_name = let name = Filename.basename old_name and new_dirname = Filename.dirname old_name in let dirname = match (old_dirname,new_dirname) with | (d, ".") -> d | (None,d) -> Some d | (Some d1,d2) -> Some (d1//d2) in let complete_name = file_name name dirname in match try (stat complete_name).st_kind with _ -> S_BLK with | S_DIR -> (if name.[0] <> '.' then let newdirname = match dirname with | None -> name | Some d -> d//name in Array.iter (treat_file (Some newdirname)) (Sys.readdir complete_name)) | S_REG -> (match get_extension name [".v";".ml";".mli";".ml4";".mllib";".mlpack"] with | (base,".v") -> let name = file_name base dirname and absname = absolute_file_name base dirname in addQueue vAccu (name, absname) | (base,(".ml"|".ml4" as ext)) -> addQueue mlAccu (base,ext,dirname) | (base,".mli") -> addQueue mliAccu (base,dirname) | (base,".mllib") -> addQueue mllibAccu (base,dirname) | (base,".mlpack") -> addQueue mlpackAccu (base,dirname) | _ -> ()) | _ -> () coq-8.6/tools/coqc.ml0000644000175000017500000001260313022274260014100 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ". *) (* Environment *) let environment = Unix.environment () let binary = ref "coqtop" let image = ref "" let verbose = ref false let rec make_compilation_args = function | [] -> [] | file :: fl -> (if !verbose then "-compile-verbose" else "-compile") :: file :: (make_compilation_args fl) (* compilation of files [files] with command [command] and args [args] *) let compile command args files = let args' = command :: args @ (make_compilation_args files) in match Sys.os_type with | "Win32" -> let pid = Unix.create_process_env command (Array.of_list args') environment Unix.stdin Unix.stdout Unix.stderr in let status = snd (Unix.waitpid [] pid) in let errcode = match status with Unix.WEXITED c|Unix.WSTOPPED c|Unix.WSIGNALED c -> c in exit errcode | _ -> Unix.execvpe command (Array.of_list args') environment let usage () = Usage.print_usage_coqc () ; flush stderr ; exit 1 (* parsing of the command line *) let extra_arg_needed = ref true let parse_args () = let rec parse (cfiles,args) = function | [] -> List.rev cfiles, List.rev args | ("-verbose" | "--verbose") :: rem -> verbose := true ; parse (cfiles,args) rem | "-image" :: f :: rem -> image := f; parse (cfiles,args) rem | "-image" :: [] -> usage () | "-byte" :: rem -> binary := "coqtop.byte"; parse (cfiles,args) rem | "-opt" :: rem -> binary := "coqtop"; parse (cfiles,args) rem (* Informative options *) | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () | ("-v"|"--version") :: _ -> Usage.version 0 | ("-where") :: _ -> Envars.set_coqlib (fun x -> x); print_endline (Envars.coqlib ()); exit 0 | ("-config" | "--config") :: _ -> Envars.set_coqlib (fun x -> x); Usage.print_config (); exit 0 (* Options for coqtop : a) options with 0 argument *) | ("-notactics"|"-bt"|"-debug"|"-nolib"|"-boot"|"-time"|"-profile-ltac" |"-batch"|"-noinit"|"-nois"|"-noglob"|"-no-glob" |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet" |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit" |"-dont-load-proofs"|"-load-proofs"|"-force-load-proofs" |"-impredicative-set"|"-vm"|"-native-compiler" |"-indices-matter"|"-quick"|"-type-in-type" |"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch" as o) :: rem -> parse (cfiles,o::args) rem (* Options for coqtop : b) options with 1 argument *) | ("-outputstate"|"-inputstate"|"-is"|"-exclude-dir"|"-color" |"-load-vernac-source"|"-l"|"-load-vernac-object" |"-load-ml-source"|"-require"|"-load-ml-object" |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top" |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" |"-w" |"-o"|"-profile-ltac-cutoff" as o) :: rem -> begin match rem with | s :: rem' -> parse (cfiles,s::o::args) rem' | [] -> usage () end | ("-I"|"-include" as o) :: s :: rem -> parse (cfiles,s::o::args) rem (* Options for coqtop : c) options with 1 argument and possibly more *) | ("-R"|"-Q" as o) :: s :: t :: rem -> parse (cfiles,t::s::o::args) rem | ("-schedule-vio-checking" |"-check-vio-tasks" | "-schedule-vio2vo" as o) :: s :: rem -> let nodash, rem = CList.split_when (fun x -> String.length x > 1 && x.[0] = '-') rem in extra_arg_needed := false; parse (cfiles, List.rev nodash @ s :: o :: args) rem | f :: rem -> if Sys.file_exists f then parse (f::cfiles,args) rem else let fv = f ^ ".v" in if Sys.file_exists fv then parse (fv::cfiles,args) rem else begin prerr_endline ("coqc: "^f^": no such file or directory") ; exit 1 end in parse ([],[]) (List.tl (Array.to_list Sys.argv)) (* main: we parse the command line, define the command to compile files * and then call the compilation on each file *) let main () = let cfiles, args = parse_args () in if cfiles = [] && !extra_arg_needed then begin prerr_endline "coqc: too few arguments" ; usage () end; let coqtopname = if !image <> "" then !image else Filename.concat Envars.coqbin (!binary ^ Coq_config.exec_extension) in (* List.iter (compile coqtopname args) cfiles*) Unix.handle_unix_error (compile coqtopname args) cfiles let _ = Printexc.print main () coq-8.6/tools/fake_ide.ml0000644000175000017500000002735713022274260014716 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* output_string chan s | Xml_datatype.Element (_, _, children) -> List.iter print children in print xml let error_xml s = Printf.eprintf "fake_id: error: %a\n%!" print_xml s; exit 1 let logger level content = Printf.eprintf "%a\n%! " print_xml (Richpp.repr content) let base_eval_call ?(print=true) ?(fail=true) call coqtop = if print then prerr_endline (Xmlprotocol.pr_call call); let xml_query = Xmlprotocol.of_call call in Xml_printer.print coqtop.xml_printer xml_query; let rec loop () = let xml = Xml_parser.parse coqtop.xml_parser in match Xmlprotocol.is_message xml with | Some (level, _loc, content) -> logger level content; loop () | None -> if Xmlprotocol.is_feedback xml then loop () else Xmlprotocol.to_answer call xml in let res = loop () in if print then prerr_endline (Xmlprotocol.pr_full_value call res); match res with | Interface.Fail (_,_,s) when fail -> error_xml (Richpp.repr s) | Interface.Fail (_,_,s) as x -> Printf.eprintf "%a\n%!" print_xml (Richpp.repr s); x | x -> x let eval_call c q = ignore(base_eval_call c q) module Parser = struct (* {{{ *) exception Err of string exception More type token = | Tok of string * string | Top of token list type grammar = | Alt of grammar list | Seq of grammar list | Opt of grammar | Item of (string * (string -> token * int)) let eat_rex x = x, fun s -> if Str.string_match (Str.regexp x) s 0 then begin let m = Str.match_end () in let w = String.sub s 0 m in Tok(x,w), m end else raise (Err ("Regexp "^x^" not found in: "^s)) let eat_balanced c = let c' = match c with | '{' -> '}' | '(' -> ')' | '[' -> ']' | _ -> assert false in let sc, sc' = String.make 1 c, String.make 1 c' in let name = sc ^ "..." ^ sc' in let unescape s = Str.global_replace (Str.regexp ("\\\\"^sc)) sc (Str.global_replace (Str.regexp ("\\\\"^sc')) sc' s) in name, fun s -> if s.[0] = c then let rec find n m = if String.length s <= m then raise More; if s.[m] = c' then if n = 0 then Tok (name, unescape (String.sub s 1 (m-1))), m+1 else find (n-1) (m+1) else if s.[m] = c then find (n+1) (m+1) else if s.[m] = '\\' && String.length s > m+1 && s.[m+1] = c then find n (m+2) else if s.[m] = '\\' && String.length s > m+1 && s.[m+1] = c' then find n (m+2) else find n (m+1) in find ~-1 0 else raise (Err ("Balanced "^String.make 1 c^" not found in: "^s)) let eat_blanks s = snd (eat_rex "[ \r\n\t]*") s let s = ref "" let parse g ic = let read_more () = s := !s ^ input_line ic ^ "\n" in let ensure_non_empty n = if n = String.length !s then read_more () in let cut_after s n = String.sub s n (String.length s - n) in let rec wrap f n = try ensure_non_empty n; let _, n' = eat_blanks (cut_after !s n) in ensure_non_empty n'; let t, m = f (cut_after !s (n+n')) in let _, m' = eat_blanks (cut_after !s (n+n'+m)) in t, n+n'+m+m' with More -> read_more (); wrap f n in let rec aux n g res : token list * int = match g with | Item (_,f) -> let t, n = wrap f n in t :: res, n | Opt g -> (try let res', n = aux n g [] in Top (List.rev res') :: res, n with Err _ -> Top [] :: res, n) | Alt gl -> let rec fst = function | [] -> raise (Err ("No more alternatives for: "^cut_after !s n)) | g :: gl -> try aux n g res with Err s -> fst gl in fst gl | Seq gl -> let rec all (res,n) = function | [] -> res, n | g :: gl -> all (aux n g res) gl in all (res,n) gl in let res, n = aux 0 g [] in s := cut_after !s n; List.rev res let clean s = Str.global_replace (Str.regexp "\n") "\\n" s let rec print g = match g with | Item (s,_) -> Printf.sprintf "%s" (clean s) | Opt g -> Printf.sprintf "[%s]" (print g) | Alt gs -> Printf.sprintf "( %s )" (String.concat " | " (List.map print gs)) | Seq gs -> String.concat " " (List.map print gs) let rec print_toklist = function | [] -> "" | Tok(k,v) :: rest when k = v -> clean k ^ " " ^ print_toklist rest | Tok(k,v) :: rest -> clean k ^ " = \"" ^ clean v ^ "\" " ^ print_toklist rest | Top l :: rest -> print_toklist l ^ " " ^ print_toklist rest end (* }}} *) type sentence = { name : string; text : string; edit_id : int; } let doc : sentence Document.document = Document.create () let tip_id () = try Document.tip doc with | Document.Empty -> Stateid.initial | Invalid_argument _ -> error "add_sentence on top of non assigned tip" let add_sentence = let edit_id = ref 0 in fun ?(name="") text -> let tip_id = tip_id () in decr edit_id; Document.push doc { name; text; edit_id = !edit_id }; !edit_id, tip_id let print_document () = let ellipsize s = Str.global_replace (Str.regexp "^[\n ]*") "" (if String.length s > 20 then String.sub s 0 17 ^ "..." else s) in prerr_endline (Pp.string_of_ppcmds (Document.print doc (fun b state_id { name; text } -> Pp.str (Printf.sprintf "%s[%10s, %3s] %s" (if b then "*" else " ") name (Stateid.to_string (Option.default Stateid.dummy state_id)) (ellipsize text))))) (* This module is the logic a GUI has to implement *) module GUILogic = struct let after_add = function | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) | Interface.Good (id, (Util.Inl (), _)) -> Document.assign_tip_id doc id | Interface.Good (id, (Util.Inr tip, _)) -> Document.assign_tip_id doc id; Document.unfocus doc; ignore(Document.cut_at doc tip); print_document () let at id id' _ = Stateid.equal id' id let after_edit_at (id,need_unfocus) = function | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) | Interface.Good (Util.Inl ()) -> if need_unfocus then Document.unfocus doc; ignore(Document.cut_at doc id); print_document () | Interface.Good (Util.Inr (stop_id,(start_id,tip))) -> if need_unfocus then Document.unfocus doc; ignore(Document.cut_at doc tip); Document.focus doc ~cond_top:(at start_id) ~cond_bot:(at stop_id); ignore(Document.cut_at doc id); print_document () let get_id_pred pred = try Document.find_id doc pred with Not_found -> error "No state found" let get_id id = get_id_pred (fun _ { name } -> name = id) let after_fail coq = function | Interface.Fail (safe_id,_,s) -> prerr_endline "The command failed as expected"; let to_id, need_unfocus = get_id_pred (fun id _ -> Stateid.equal id safe_id) in after_edit_at (to_id, need_unfocus) (base_eval_call (Xmlprotocol.edit_at to_id) coq) | Interface.Good _ -> error "The command was expected to fail but did not" end open GUILogic let eval_print l coq = let open Parser in let open Xmlprotocol in (* prerr_endline ("Interpreting: " ^ print_toklist l); *) match l with | [ Tok(_,"ADD"); Top []; Tok(_,phrase) ] -> let eid, tip = add_sentence phrase in after_add (base_eval_call (add ((phrase,eid),(tip,true))) coq) | [ Tok(_,"ADD"); Top [Tok(_,name)]; Tok(_,phrase) ] -> let eid, tip = add_sentence ~name phrase in after_add (base_eval_call (add ((phrase,eid),(tip,true))) coq) | [ Tok(_,"GOALS"); ] -> eval_call (goals ()) coq | [ Tok(_,"FAILGOALS"); ] -> after_fail coq (base_eval_call ~fail:false (goals ()) coq) | [ Tok(_,"EDIT_AT"); Tok(_,id) ] -> let to_id, need_unfocus = get_id id in after_edit_at (to_id, need_unfocus) (base_eval_call (edit_at to_id) coq) | [ Tok(_,"QUERY"); Top []; Tok(_,phrase) ] -> eval_call (query (phrase,tip_id())) coq | [ Tok(_,"QUERY"); Top [Tok(_,id)]; Tok(_,phrase) ] -> let to_id, _ = get_id id in eval_call (query (phrase, to_id)) coq | [ Tok(_,"WAIT") ] -> let phrase = "Stm Wait." in eval_call (query (phrase,tip_id())) coq | [ Tok(_,"JOIN") ] -> let phrase = "Stm JoinDocument." in eval_call (query (phrase,tip_id())) coq | [ Tok(_,"ASSERT"); Tok(_,"TIP"); Tok(_,id) ] -> let to_id, _ = get_id id in if not(Stateid.equal (Document.tip doc) to_id) then error "Wrong tip" else prerr_endline "Good tip" | Tok("#[^\n]*",_) :: _ -> () | _ -> error "syntax error" let grammar = let open Parser in let eat_id = eat_rex "[a-zA-Z_][a-zA-Z0-9_]*" in let eat_phrase = eat_balanced '{' in Alt [ Seq [Item (eat_rex "ADD"); Opt (Item eat_id); Item eat_phrase] ; Seq [Item (eat_rex "EDIT_AT"); Item eat_id] ; Seq [Item (eat_rex "QUERY"); Opt (Item eat_id); Item eat_phrase] ; Seq [Item (eat_rex "WAIT")] ; Seq [Item (eat_rex "JOIN")] ; Seq [Item (eat_rex "GOALS")] ; Seq [Item (eat_rex "FAILGOALS")] ; Seq [Item (eat_rex "ASSERT"); Item (eat_rex "TIP"); Item eat_id ] ; Item (eat_rex "#[^\n]*") ] let read_command inc = Parser.parse grammar inc let usage () = error (Printf.sprintf "A fake coqide process talking to a coqtop -ideslave.\n\ Usage: %s (file|-) []\n\ Input syntax is the following:\n%s\n" (Filename.basename Sys.argv.(0)) (Parser.print grammar)) module Coqide = Spawn.Sync(struct end) let main = Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> prerr_endline "Broken Pipe (coqtop died ?)"; exit 1)); let coqtop_name, coqtop_args, input_file = match Sys.argv with | [| _; f |] -> "coqtop",[|"-ideslave"|], f | [| _; f; ct |] -> let ct = Str.split (Str.regexp " ") ct in List.hd ct, Array.of_list ("-ideslave" :: List.tl ct), f | _ -> usage () in let inc = if input_file = "-" then stdin else open_in input_file in let coq = let _p, cin, cout = Coqide.spawn coqtop_name coqtop_args in let ip = Xml_parser.make (Xml_parser.SChannel cin) in let op = Xml_printer.make (Xml_printer.TChannel cout) in Xml_parser.check_eof ip false; { xml_printer = op; xml_parser = ip } in let init () = match base_eval_call ~print:false (Xmlprotocol.init None) coq with | Interface.Good id -> let dir = Filename.dirname input_file in let phrase = Printf.sprintf "Add LoadPath \"%s\". " dir in let eid, tip = add_sentence ~name:"initial" phrase in after_add (base_eval_call (Xmlprotocol.add ((phrase,eid),(tip,true))) coq) | Interface.Fail _ -> error "init call failed" in let finish () = match base_eval_call (Xmlprotocol.status true) coq with | Interface.Good _ -> exit 0 | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) in (* The main loop *) init (); while true do let cmd = try read_command inc with End_of_file -> finish () in try eval_print cmd coq with e -> error ("Uncaught exception " ^ Printexc.to_string e) done (* vim:set foldmethod=marker: *) coq-8.6/tools/coq-inferior.el0000644000175000017500000002654213022274260015547 0ustar mdenesmdenes;;; inferior-coq.el --- Run an inferior Coq process. ;;; ;;; Copyright (C) Marco Maggesi ;;; Time-stamp: "2002-02-28 12:15:04 maggesi" ;; Emacs Lisp Archive Entry ;; Filename: inferior-coq.el ;; Version: 1.0 ;; Keywords: process coq ;; Author: Marco Maggesi ;; Maintainer: Marco Maggesi ;; Description: Run an inferior Coq process. ;; URL: http://www.math.unifi.it/~maggesi/ ;; Compatibility: Emacs20, Emacs21, XEmacs21 ;; This is free software; you can redistribute it and/or modify it under ;; the terms of the GNU General Public License as published by the Free ;; Software Foundation; either version 2, or (at your option) any later ;; version. ;; ;; This is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License ;; for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ;; MA 02111-1307, USA. ;;; Commentary: ;; Coq is a proof assistant (http://coq.inria.fr/). This code run an ;; inferior Coq process and defines functions to send bits of code ;; from other buffers to the inferior process. This is a ;; customisation of comint-mode (see comint.el). For a more complex ;; and full featured Coq interface under Emacs look at Proof General ;; (http://zermelo.dcs.ed.ac.uk/~proofgen/). ;; ;; Written by Marco Maggesi with code heavly ;; borrowed from emacs cmuscheme.el ;; ;; Please send me bug reports, bug fixes, and extensions, so that I can ;; merge them into the master source. ;;; Installation: ;; You need to have gallina.el already installed (it comes with the ;; standard Coq distribution) in order to use this code. Put this ;; file somewhere in you load-path and add the following lines in your ;; "~/.emacs": ;; ;; (setq auto-mode-alist (cons '("\\.v$" . coq-mode) auto-mode-alist)) ;; (autoload 'coq-mode "gallina" "Major mode for editing Coq vernacular." t) ;; (autoload 'run-coq "inferior-coq" "Run an inferior Coq process." t) ;; (autoload 'run-coq-other-window "inferior-coq" ;; "Run an inferior Coq process in a new window." t) ;; (autoload 'run-coq-other-frame "inferior-coq" ;; "Run an inferior Coq process in a new frame." t) ;;; Usage: ;; Call `M-x "run-coq'. ;; ;; Functions and key bindings (Learn more keys with `C-c C-h' or `C-h m'): ;; C-return ('M-x coq-send-line) send the current line. ;; C-c C-r (`M-x coq-send-region') send the current region. ;; C-c C-a (`M-x coq-send-abort') send the command "Abort". ;; C-c C-t (`M-x coq-send-restart') send the command "Restart". ;; C-c C-s (`M-x coq-send-show') send the command "Show". ;; C-c C-u (`M-x coq-send-undo') send the command "Undo". ;; C-c C-v (`M-x coq-check-region') run command "Check" on region. ;; C-c . (`M-x coq-come-here') Restart and send until current point. ;;; Change Log: ;; From -0.0 to 1.0 brought into existence. (require 'gallina) (require 'comint) (setq coq-program-name "coqtop") (defgroup inferior-coq nil "Run a coq process in a buffer." :group 'coq) (defcustom inferior-coq-mode-hook nil "*Hook for customising inferior-coq mode." :type 'hook :group 'coq) (defvar inferior-coq-mode-map (let ((m (make-sparse-keymap))) (define-key m "\C-c\C-r" 'coq-send-region) (define-key m "\C-c\C-a" 'coq-send-abort) (define-key m "\C-c\C-t" 'coq-send-restart) (define-key m "\C-c\C-s" 'coq-send-show) (define-key m "\C-c\C-u" 'coq-send-undo) (define-key m "\C-c\C-v" 'coq-check-region) m)) ;; Install the process communication commands in the coq-mode keymap. (define-key coq-mode-map [(control return)] 'coq-send-line) (define-key coq-mode-map "\C-c\C-r" 'coq-send-region) (define-key coq-mode-map "\C-c\C-a" 'coq-send-abort) (define-key coq-mode-map "\C-c\C-t" 'coq-send-restart) (define-key coq-mode-map "\C-c\C-s" 'coq-send-show) (define-key coq-mode-map "\C-c\C-u" 'coq-send-undo) (define-key coq-mode-map "\C-c\C-v" 'coq-check-region) (define-key coq-mode-map "\C-c." 'coq-come-here) (defvar coq-buffer) (define-derived-mode inferior-coq-mode comint-mode "Inferior Coq" "\ Major mode for interacting with an inferior Coq process. The following commands are available: \\{inferior-coq-mode-map} A Coq process can be fired up with M-x run-coq. Customisation: Entry to this mode runs the hooks on comint-mode-hook and inferior-coq-mode-hook (in that order). You can send text to the inferior Coq process from other buffers containing Coq source. Functions and key bindings (Learn more keys with `C-c C-h'): C-return ('M-x coq-send-line) send the current line. C-c C-r (`M-x coq-send-region') send the current region. C-c C-a (`M-x coq-send-abort') send the command \"Abort\". C-c C-t (`M-x coq-send-restart') send the command \"Restart\". C-c C-s (`M-x coq-send-show') send the command \"Show\". C-c C-u (`M-x coq-send-undo') send the command \"Undo\". C-c C-v (`M-x coq-check-region') run command \"Check\" on region. C-c . (`M-x coq-come-here') Restart and send until current point. " ;; Customise in inferior-coq-mode-hook (setq comint-prompt-regexp "^[^<]* < *") (coq-mode-variables) (setq mode-line-process '(":%s")) (setq comint-input-filter (function coq-input-filter)) (setq comint-get-old-input (function coq-get-old-input))) (defcustom inferior-coq-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'" "*Input matching this regexp are not saved on the history list. Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters." :type 'regexp :group 'inferior-coq) (defun coq-input-filter (str) "Don't save anything matching `inferior-coq-filter-regexp'." (not (string-match inferior-coq-filter-regexp str))) (defun coq-get-old-input () "Snarf the sexp ending at point." (save-excursion (let ((end (point))) (backward-sexp) (buffer-substring (point) end)))) (defun coq-args-to-list (string) (let ((where (string-match "[ \t]" string))) (cond ((null where) (list string)) ((not (= where 0)) (cons (substring string 0 where) (coq-args-to-list (substring string (+ 1 where) (length string))))) (t (let ((pos (string-match "[^ \t]" string))) (if (null pos) nil (coq-args-to-list (substring string pos (length string))))))))) ;;;###autoload (defun run-coq (cmd) "Run an inferior Coq process, input and output via buffer *coq*. If there is a process already running in `*coq*', switch to that buffer. With argument, allows you to edit the command line (default is value of `coq-program-name'). Runs the hooks `inferior-coq-mode-hook' \(after the `comint-mode-hook' is run). \(Type \\[describe-mode] in the process buffer for a list of commands.)" (interactive (list (if current-prefix-arg (read-string "Run Coq: " coq-program-name) coq-program-name))) (if (not (comint-check-proc "*coq*")) (let ((cmdlist (coq-args-to-list cmd))) (set-buffer (apply 'make-comint "coq" (car cmdlist) nil (cdr cmdlist))) (inferior-coq-mode))) (setq coq-program-name cmd) (setq coq-buffer "*coq*") (switch-to-buffer "*coq*")) ;;;###autoload (add-hook 'same-window-buffer-names "*coq*") ;;;###autoload (defun run-coq-other-window (cmd) "Run an inferior Coq process, input and output via buffer *coq*. If there is a process already running in `*coq*', switch to that buffer. With argument, allows you to edit the command line (default is value of `coq-program-name'). Runs the hooks `inferior-coq-mode-hook' \(after the `comint-mode-hook' is run). \(Type \\[describe-mode] in the process buffer for a list of commands.)" (interactive (list (if current-prefix-arg (read-string "Run Coq: " coq-program-name) coq-program-name))) (if (not (comint-check-proc "*coq*")) (let ((cmdlist (coq-args-to-list cmd))) (set-buffer (apply 'make-comint "coq" (car cmdlist) nil (cdr cmdlist))) (inferior-coq-mode))) (setq coq-program-name cmd) (setq coq-buffer "*coq*") (pop-to-buffer "*coq*")) ;;;###autoload (add-hook 'same-window-buffer-names "*coq*") (defun run-coq-other-frame (cmd) "Run an inferior Coq process, input and output via buffer *coq*. If there is a process already running in `*coq*', switch to that buffer. With argument, allows you to edit the command line (default is value of `coq-program-name'). Runs the hooks `inferior-coq-mode-hook' \(after the `comint-mode-hook' is run). \(Type \\[describe-mode] in the process buffer for a list of commands.)" (interactive (list (if current-prefix-arg (read-string "Run Coq: " coq-program-name) coq-program-name))) (if (not (comint-check-proc "*coq*")) (let ((cmdlist (coq-args-to-list cmd))) (set-buffer (apply 'make-comint "coq" (car cmdlist) nil (cdr cmdlist))) (inferior-coq-mode))) (setq coq-program-name cmd) (setq coq-buffer "*coq*") (switch-to-buffer-other-frame "*coq*")) (defun switch-to-coq (eob-p) "Switch to the coq process buffer. With argument, position cursor at end of buffer." (interactive "P") (if (get-buffer coq-buffer) (pop-to-buffer coq-buffer) (error "No current process buffer. See variable `coq-buffer'")) (cond (eob-p (push-mark) (goto-char (point-max))))) (defun coq-send-region (start end) "Send the current region to the inferior Coq process." (interactive "r") (comint-send-region (coq-proc) start end) (comint-send-string (coq-proc) "\n")) (defun coq-send-line () "Send the current line to the Coq process." (interactive) (save-excursion (end-of-line) (let ((end (point))) (beginning-of-line) (coq-send-region (point) end))) (next-line 1)) (defun coq-send-abort () "Send the command \"Abort.\" to the inferior Coq process." (interactive) (comint-send-string (coq-proc) "Abort.\n")) (defun coq-send-restart () "Send the command \"Restart.\" to the inferior Coq process." (interactive) (comint-send-string (coq-proc) "Restart.\n")) (defun coq-send-undo () "Reset coq to the initial state and send the region between the beginning of file and the point." (interactive) (comint-send-string (coq-proc) "Undo.\n")) (defun coq-check-region (start end) "Run the commmand \"Check\" on the current region." (interactive "r") (comint-proc-query (coq-proc) (concat "Check " (buffer-substring start end) ".\n"))) (defun coq-send-show () "Send the command \"Show.\" to the inferior Coq process." (interactive) (comint-send-string (coq-proc) "Show.\n")) (defun coq-come-here () "Reset coq to the initial state and send the region between the beginning of file and the point." (interactive) (comint-send-string (coq-proc) "Reset Initial.\n") (coq-send-region 1 (point))) (defvar coq-buffer nil "*The current coq process buffer.") (defun coq-proc () "Return the current coq process. See variable `coq-buffer'." (let ((proc (get-buffer-process (if (eq major-mode 'inferior-coq-mode) (current-buffer) coq-buffer)))) (or proc (error "No current process. See variable `coq-buffer'")))) (defcustom inferior-coq-load-hook nil "This hook is run when inferior-coq is loaded in. This is a good place to put keybindings." :type 'hook :group 'inferior-coq) (run-hooks 'inferior-coq-load-hook) (provide 'inferior-coq) coq-8.6/tools/gallina-db.el0000644000175000017500000002075413022274260015143 0ustar mdenesmdenes;;; gallina-db.el --- coq keywords database utility functions ;; ;; Author: Pierre Courtieu ;; License: GPL (GNU GENERAL PUBLIC LICENSE) ;; ;;; We store all information on keywords (tactics or command) in big ;; tables (ex: `coq-tactics-db') From there we get: menus including ;; "smart" commands, completions for command coq-insert-... ;; abbrev tables and font-lock keyword ;;; real value defined below ;;; Commentary: ;; ;;; Code: ;(require 'proof-config) ; for proof-face-specs, a macro ;(require 'holes) (defconst coq-syntax-db nil "Documentation-only variable, for coq keyword databases. Each element of a keyword database contains the definition of a \"form\", of the form: (MENUNAME ABBREV INSERT STATECH KWREG INSERT-FUN HIDE) MENUNAME is the name of form (or form variant) as it should appear in menus or completion lists. ABBREV is the abbreviation for completion via \\[expand-abbrev]. INSERT is the complete text of the form, which may contain holes denoted by \"#\" or \"@{xxx}\". If non-nil the optional STATECH specifies that the command is not state preserving for coq. If non-nil the optional KWREG is the regexp to colorize correponding to the keyword. ex: \"simple\\\\s-+destruct\" (\\\\s-+ meaning \"one or more spaces\"). *WARNING*: A regexp longer than another one should be put FIRST. For example: (\"Module Type\" ... ... t \"Module\\s-+Type\") (\"Module\" ... ... t \"Module\") Is ok because the longer regexp is recognized first. If non-nil the optional INSERT-FUN is the function to be called when inserting the form (instead of inserting INSERT, except when using \\[expand-abbrev]). This allows writing functions asking for more information to assist the user. If non-nil the optional HIDE specifies that this form should not appear in the menu but only in interactive completions. Example of what could be in your emacs init file: (defvar coq-user-tactics-db '( (\"mytac\" \"mt\" \"mytac # #\" t \"mytac\") (\"myassert by\" \"massb\" \"myassert ( # : # ) by #\" t \"assert\") )) Explanation of the first line: the tactic menu entry mytac, abbreviated by mt, will insert \"mytac # #\" where #s are holes to fill, and \"mytac\" becomes a new keyword to colorize." ) (defun coq-insert-from-db (db prompt) "Ask for a keyword, with completion on keyword database DB and insert. Insert corresponding string with holes at point. If an insertion function is present for the keyword, call it instead. see `coq-syntax-db' for DB structure." (let* ((tac (completing-read (concat prompt " (tab for completion) : ") db nil nil)) (infos (cddr (assoc tac db))) (s (car infos)) ; completion to insert (f (car-safe (cdr-safe (cdr-safe (cdr infos))))) ; insertion function (pt (point))) (if f (funcall f) ; call f if present (insert (or s tac)) ; insert completion and indent otherwise (holes-replace-string-by-holes-backward-jump pt) (indent-according-to-mode)))) (defun coq-build-regexp-list-from-db (db &optional filter) "Take a keyword database DB and return the list of regexps for font-lock. If non-nil Optional argument FILTER is a function applying to each line of DB. For each line if FILTER returns nil, then the keyword is not added to the regexp. See `coq-syntax-db' for DB structure." (let ((l db) (res ())) (while l (let* ((hd (car l)) (tl (cdr l)) ; hd is the first infos list (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion (e4 (car-safe tl3)) (tl4 (cdr-safe tl3)) ; e4 = state changing (e5 (car-safe tl4)) (tl5 (cdr-safe tl4)) ; e5 = colorization string ) ;; TODO delete doublons (when (and e5 (or (not filter) (funcall filter hd))) (setq res (nconc res (list e5)))) ; careful: nconc destructive! (setq l tl))) res )) ;; Computes the max length of strings in a list (defun max-length-db (db) "Return the length of the longest first element (menu label) of DB. See `coq-syntax-db' for DB structure." (let ((l db) (res 0)) (while l (let ((lgth (length (car (car l))))) (setq res (max lgth res)) (setq l (cdr l)))) res)) (defun coq-build-menu-from-db-internal (db lgth menuwidth) "Take a keyword database DB and return one insertion submenu. Argument LGTH is the max size of the submenu. Argument MENUWIDTH is the width of the largest line in the menu (without abbrev and shortcut specifications). Used by `coq-build-menu-from-db', which you should probably use instead. See `coq-syntax-db' for DB structure." (let ((l db) (res ()) (size lgth) (keybind-abbrev (substitute-command-keys " \\[expand-abbrev]"))) (while (and l (> size 0)) (let* ((hd (car l))(tl (cdr l)) ; hd is a list of length 3 or 4 (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion (e4 (car-safe tl3)) (tl4 (cdr-safe tl3)) ; e4 = state changing (e5 (car-safe tl4)) (tl5 (cdr-safe tl4)) ; e5 = colorization string (e6 (car-safe tl5)) ; e6 = function for smart insertion (e7 (car-safe (cdr-safe tl5))) ; e7 = if non-nil : hide in menu (entry-with (max (- menuwidth (length e1)) 0)) (spaces (make-string entry-with ? )) ;;(restofmenu (coq-build-menu-from-db-internal tl (- size 1) menuwidth)) ) (when (not e7) ;; if not hidden (let ((menu-entry (vector ;; menu entry label (concat e1 (if (not e2) "" (concat spaces "(" e2 keybind-abbrev ")"))) ;;insertion function if present otherwise insert completion (if e6 e6 `(holes-insert-and-expand ,e3)) t))) (setq res (nconc res (list menu-entry)))));; append *in place* (setq l tl) (setq size (- size 1)))) res)) (defun coq-build-title-menu (db size) "Build a title for the first submenu of DB, of size SIZE. Return the string made of the first and the SIZE nth first element of DB, separated by \"...\". Used by `coq-build-menu-from-db'. See `coq-syntax-db' for DB structure." (concat (car-safe (car-safe db)) " ... " (car-safe (car-safe (nthcdr (- size 1) db))))) (defun coq-sort-menu-entries (menu) (sort menu '(lambda (x y) (string< (downcase (elt x 0)) (downcase (elt y 0)))))) (defun coq-build-menu-from-db (db &optional size) "Take a keyword database DB and return a list of insertion menus for them. Submenus contain SIZE entries (default 30). See `coq-syntax-db' for DB structure." ;; sort is destructive for the list, so copy list before sorting (let* ((l (coq-sort-menu-entries (copy-list db))) (res ()) (wdth (+ 2 (max-length-db db))) (sz (or size 30)) (lgth (length l))) (while l (if (<= lgth sz) (setq res ;; careful: nconc destructive! (nconc res (list (cons (coq-build-title-menu l lgth) (coq-build-menu-from-db-internal l lgth wdth))))) (setq res ; careful: nconc destructive! (nconc res (list (cons (coq-build-title-menu l sz) (coq-build-menu-from-db-internal l sz wdth)))))) (setq l (nthcdr sz l)) (setq lgth (length l))) res)) (defun coq-build-abbrev-table-from-db (db) "Take a keyword database DB and return an abbrev table. See `coq-syntax-db' for DB structure." (let ((l db) (res ())) (while l (let* ((hd (car l))(tl (cdr l)) ; hd is a list of length 3 or 4 (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion ) ;; careful: nconc destructive! (when e2 (setq res (nconc res (list `(,e2 ,e3 holes-abbrev-complete))))) (setq l tl))) res)) (defun filter-state-preserving (l) ; checkdoc-params: (l) "Not documented." (not (nth 3 l))) ; fourth argument is nil --> state preserving command (defun filter-state-changing (l) ; checkdoc-params: (l) "Not documented." (nth 3 l)) ; fourth argument is nil --> state preserving command (defconst coq-solve-tactics-face 'coq-solve-tactics-face "Expression that evaluates to a face. Required so that 'proof-solve-tactics-face is a proper facename") ;;A new face for tactics which fail when they don't kill the current goal (defface coq-solve-tactics-face '((t (:background "red"))) "Face for names of closing tactics in proof scripts." :group 'proof-faces) (provide 'gallina-db) ;;; gallina-db.el ends here ;** Local Variables: *** ;** fill-column: 80 *** ;** End: *** coq-8.6/tools/coqdoc/0000755000175000017500000000000013022274260014067 5ustar mdenesmdenescoq-8.6/tools/coqdoc/cpretty.mll0000644000175000017500000011670513022274260016301 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [] | (l :: ls) -> l :: (take (n-1) ls) (* count the number of spaces at the beginning of a string *) let count_spaces s = let n = String.length s in let rec count c i = if i == n then c,i else match s.[i] with | '\t' -> count (c + (8 - (c mod 8))) (i + 1) | ' ' -> count (c + 1) (i + 1) | _ -> c,i in count 0 0 let remove_newline s = let n = String.length s in let rec count i = if i == n || s.[i] <> '\n' then i else count (i + 1) in let i = count 0 in i, String.sub s i (n - i) let count_dashes s = let c = ref 0 in for i = 0 to String.length s - 1 do if s.[i] = '-' then incr c done; !c let cut_head_tail_spaces s = let n = String.length s in let rec look_up i = if i == n || s.[i] <> ' ' then i else look_up (i+1) in let rec look_dn i = if i == -1 || s.[i] <> ' ' then i else look_dn (i-1) in let l = look_up 0 in let r = look_dn (n-1) in if l <= r then String.sub s l (r-l+1) else s let sec_title s = let rec count lev i = if s.[i] = '*' then count (succ lev) (succ i) else let t = String.sub s i (String.length s - i) in lev, cut_head_tail_spaces t in count 0 (String.index s '*') let strip_eol s = let eol = s.[String.length s - 1] = '\n' in (eol, if eol then String.sub s 1 (String.length s - 1) else s) let formatted = ref false let brackets = ref 0 let comment_level = ref 0 let in_proof = ref None let in_env start stop = let r = ref false in let start_env () = r := true; start () in let stop_env () = if !r then stop (); r := false in (fun x -> !r), start_env, stop_env let _, start_emph, stop_emph = in_env Output.start_emph Output.stop_emph let in_quote, start_quote, stop_quote = in_env Output.start_quote Output.stop_quote let url_buffer = Buffer.create 40 let url_name_buffer = Buffer.create 40 let backtrack lexbuf = lexbuf.lex_curr_pos <- lexbuf.lex_start_pos; lexbuf.lex_curr_p <- lexbuf.lex_start_p let backtrack_past_newline lexbuf = let buf = lexeme lexbuf in let splits = Str.bounded_split_delim (Str.regexp "['\n']") buf 2 in match splits with | [] -> () | (_ :: []) -> () | (s1 :: rest :: _) -> let length_skip = 1 + String.length s1 in lexbuf.lex_curr_pos <- lexbuf.lex_start_pos + length_skip (* saving/restoring the PP state *) type state = { st_gallina : bool; st_light : bool } let state_stack = Stack.create () let save_state () = Stack.push { st_gallina = !Cdglobals.gallina; st_light = !Cdglobals.light } state_stack let restore_state () = let s = Stack.pop state_stack in Cdglobals.gallina := s.st_gallina; Cdglobals.light := s.st_light let begin_show () = save_state (); Cdglobals.gallina := false; Cdglobals.light := false let end_show () = restore_state () (* Reset the globals *) let reset () = formatted := false; brackets := 0; comment_level := 0 (* erasing of Section/End *) let section_re = Str.regexp "[ \t]*Section" let end_re = Str.regexp "[ \t]*End" let is_section s = Str.string_match section_re s 0 let is_end s = Str.string_match end_re s 0 let sections_to_close = ref 0 let section_or_end s = if is_section s then begin incr sections_to_close; true end else if is_end s then begin if !sections_to_close > 0 then begin decr sections_to_close; true end else false end else true (* for item lists *) type list_compare = | Before | StartLevel of int | InLevel of int * bool (* Before : we're before any levels StartLevel : at the same column as the dash in a level InLevel : after the dash of this level, but before any deeper dashes. bool is true if this is the last level *) let find_level levels cur_indent = match levels with | [] -> Before | (l::ls) -> if cur_indent < l then Before else (* cur_indent will never be less than the head of the list *) let rec findind ls n = match ls with | [] -> InLevel (n,true) | (l :: []) -> if cur_indent = l then StartLevel n else InLevel (n,true) | (l1 :: l2 :: ls) -> if cur_indent = l1 then StartLevel n else if cur_indent < l2 then InLevel (n,false) else findind (l2 :: ls) (n+1) in findind (l::ls) 1 type is_start_list = | Rule | List of int | Neither let check_start_list str = let n_dashes = count_dashes str in let (n_spaces,_) = count_spaces str in if n_dashes >= 4 && not !Cdglobals.plain_comments then Rule else if n_dashes = 1 && not !Cdglobals.plain_comments then List n_spaces else Neither (* examine a string for subtitleness *) let subtitle m s = match Str.split_delim (Str.regexp ":") s with | [] -> false | (name::_) -> if (cut_head_tail_spaces name) = m then true else false (* tokens pretty-print *) let token_buffer = Buffer.create 1024 let token_re = Str.regexp "[ \t]*(\\*\\*[ \t]+printing[ \t]+\\([^ \t]+\\)" let printing_token_re = Str.regexp "[ \t]*\\(\\(%\\([^%]*\\)%\\)\\|\\(\\$[^$]*\\$\\)\\)?[ \t]*\\(#\\(\\(&#\\|[^#]\\)*\\)#\\)?" let add_printing_token toks pps = try if Str.string_match token_re toks 0 then let tok = Str.matched_group 1 toks in if Str.string_match printing_token_re pps 0 then let pp = (try Some (Str.matched_group 3 pps) with _ -> try Some (Str.matched_group 4 pps) with _ -> None), (try Some (Str.matched_group 6 pps) with _ -> None) in Output.add_printing_token tok pp with _ -> () let remove_token_re = Str.regexp "[ \t]*(\\*\\*[ \t]+remove[ \t]+printing[ \t]+\\([^ \t]+\\)[ \t]*\\*)" let remove_printing_token toks = try if Str.string_match remove_token_re toks 0 then let tok = Str.matched_group 1 toks in Output.remove_printing_token tok with _ -> () let output_indented_keyword s lexbuf = let nbsp,isp = count_spaces s in Output.indentation nbsp; let s = String.sub s isp (String.length s - isp) in Output.keyword s (lexeme_start lexbuf + isp) let only_gallina () = !Cdglobals.gallina && !in_proof <> None let parse_comments () = !Cdglobals.parse_comments && not (only_gallina ()) } (*s Regular expressions *) let space = [' ' '\t'] let space_nl = [' ' '\t' '\n' '\r'] let nl = "\r\n" | '\n' let firstchar = ['A'-'Z' 'a'-'z' '_'] | (* superscript 1 *) '\194' '\185' | (* utf-8 latin 1 supplement *) '\195' ['\128'-'\150'] | '\195' ['\152'-'\182'] | '\195' ['\184'-'\191'] | (* utf-8 letterlike symbols *) '\206' (['\145'-'\161'] | ['\163'-'\191']) | '\207' (['\145'-'\191']) | '\226' ('\130' [ '\128'-'\137' ] (* subscripts *) | '\129' [ '\176'-'\187' ] (* superscripts *) | '\132' ['\128'-'\191'] | '\133' ['\128'-'\143']) let identchar = firstchar | ['\'' '0'-'9' '@' ] let id = firstchar identchar* let pfx_id = (id '.')* let identifier = id | pfx_id id (* This misses unicode stuff, and it adds "[" and "]". It's only an approximation of idents - used for detecting whether an underscore is part of an identifier or meant to indicate emphasis *) let nonidentchar = [^ 'A'-'Z' 'a'-'z' '_' '[' ']' '\'' '0'-'9' '@' ] let printing_token = [^ ' ' '\t']* let thm_token = "Theorem" | "Lemma" | "Fact" | "Remark" | "Corollary" | "Proposition" | "Property" | "Goal" let prf_token = "Next" space+ "Obligation" | "Proof" (space* "." | space+ "with" | space+ "using") let immediate_prf_token = (* Approximation of a proof term, if not in the prf_token case *) (* To be checked after prf_token *) "Proof" space* [^ '.' 'w' 'u'] let def_token = "Definition" | "Let" | "Class" | "SubClass" | "Example" | "Fixpoint" | "Function" | "Boxed" | "CoFixpoint" | "Record" | "Variant" | "Structure" | "Scheme" | "Inductive" | "CoInductive" | "Equations" | "Instance" | "Declare" space+ "Instance" | "Global" space+ "Instance" | "Functional" space+ "Scheme" let decl_token = "Hypothesis" | "Hypotheses" | "Parameter" 's'? | "Axiom" 's'? | "Conjecture" let gallina_ext = "Module" | "Include" space+ "Type" | "Include" | "Declare" space+ "Module" | "Transparent" | "Opaque" | "Canonical" | "Coercion" | "Identity" | "Implicit" | "Tactic" space+ "Notation" | "Section" | "Context" | "Variable" 's'? | ("Hypothesis" | "Hypotheses") | "End" let notation_kw = "Notation" | "Infix" | "Reserved" space+ "Notation" let commands = "Pwd" | "Cd" | "Drop" | "ProtectedLoop" | "Quit" | "Restart" | "Load" | "Add" | "Remove" space+ "Loadpath" | "Print" | "Inspect" | "About" | "SearchAbout" | "SearchRewrite" | "Search" | "Locate" | "Eval" | "Reset" | "Check" | "Type" | "Section" | "Chapter" | "Variable" 's'? | ("Hypothesis" | "Hypotheses") | "End" let end_kw = immediate_prf_token | "Qed" | "Defined" | "Save" | "Admitted" | "Abort" let extraction = "Extraction" | "Recursive" space+ "Extraction" | "Extract" let gallina_kw = thm_token | def_token | decl_token | gallina_ext | commands | extraction let prog_kw = "Program" space+ gallina_kw | "Obligation" | "Obligations" | "Solve" let hint_kw = "Extern" | "Rewrite" | "Resolve" | "Immediate" | "Transparent" | "Opaque" | "Unfold" | "Constructors" let set_kw = "Printing" space+ ("Coercions" | "Universes" | "All") | "Implicit" space+ "Arguments" let gallina_kw_to_hide = "Implicit" space+ "Arguments" | ("Local" space+)? "Ltac" | "Require" | "Import" | "Export" | "Load" | "Hint" space+ hint_kw | "Open" | "Close" | "Delimit" | "Transparent" | "Opaque" | ("Declare" space+ ("Morphism" | "Step") ) | ("Set" | "Unset") space+ set_kw | "Declare" space+ ("Left" | "Right") space+ "Step" | "Debug" space+ ("On" | "Off") let section = "*" | "**" | "***" | "****" let item_space = " " let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* nl let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* nl let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* nl let end_show = "(*" space* "end" space+ "show" space* "*)" space* nl (* let begin_verb = "(*" space* "begin" space+ "verb" space* "*)" let end_verb = "(*" space* "end" space+ "verb" space* "*)" *) (*s Scanning Coq, at beginning of line *) rule coq_bol = parse | space* nl+ { if not (!in_proof <> None && (!Cdglobals.gallina || !Cdglobals.light)) then Output.empty_line_of_code (); coq_bol lexbuf } | space* "(**" space_nl { Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then coq_bol lexbuf else coq lexbuf } | space* "Comments" space_nl { Output.end_coq (); Output.start_doc (); comments lexbuf; Output.end_doc (); Output.start_coq (); coq lexbuf } | space* begin_hide { skip_hide lexbuf; coq_bol lexbuf } | space* begin_show { begin_show (); coq_bol lexbuf } | space* end_show { end_show (); coq_bol lexbuf } | space* (("Local"|"Global") space+)? gallina_kw_to_hide { let s = lexeme lexbuf in if !Cdglobals.light && section_or_end s then let eol = skip_to_dot lexbuf in if eol then (coq_bol lexbuf) else coq lexbuf else begin output_indented_keyword s lexbuf; let eol = body lexbuf in if eol then coq_bol lexbuf else coq lexbuf end } | space* thm_token { let s = lexeme lexbuf in output_indented_keyword s lexbuf; let eol = body lexbuf in in_proof := Some eol; if eol then coq_bol lexbuf else coq lexbuf } | space* prf_token { in_proof := Some true; let eol = if not !Cdglobals.gallina then begin backtrack lexbuf; body_bol lexbuf end else let s = lexeme lexbuf in if s.[String.length s - 1] = '.' then false else skip_to_dot lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | space* end_kw { let eol = if not (only_gallina ()) then begin backtrack lexbuf; body_bol lexbuf end else skip_to_dot lexbuf in in_proof := None; if eol then coq_bol lexbuf else coq lexbuf } | space* gallina_kw { in_proof := None; let s = lexeme lexbuf in output_indented_keyword s lexbuf; let eol= body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | space* prog_kw { in_proof := None; let s = lexeme lexbuf in output_indented_keyword s lexbuf; let eol= body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | space* notation_kw { let s = lexeme lexbuf in output_indented_keyword s lexbuf; let eol= start_notation_string lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | space* "(**" space+ "printing" space+ printing_token space+ { let tok = lexeme lexbuf in let s = printing_token_body lexbuf in add_printing_token tok s; coq_bol lexbuf } | space* "(**" space+ "printing" space+ { eprintf "warning: bad 'printing' command at character %d\n" (lexeme_start lexbuf); flush stderr; comment_level := 1; ignore (comment lexbuf); coq_bol lexbuf } | space* "(**" space+ "remove" space+ "printing" space+ printing_token space* "*)" { remove_printing_token (lexeme lexbuf); coq_bol lexbuf } | space* "(**" space+ "remove" space+ "printing" space+ { eprintf "warning: bad 'remove printing' command at character %d\n" (lexeme_start lexbuf); flush stderr; comment_level := 1; ignore (comment lexbuf); coq_bol lexbuf } | space* "(*" { comment_level := 1; let eol = if parse_comments () then begin let s = lexeme lexbuf in let nbsp, isp = count_spaces s in Output.indentation nbsp; Output.start_comment (); comment lexbuf end else skipped_comment lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | eof { () } | _ { let eol = if not !Cdglobals.gallina then begin backtrack lexbuf; body_bol lexbuf end else skip_to_dot_or_brace lexbuf in if eol then coq_bol lexbuf else coq lexbuf } (*s Scanning Coq elsewhere *) and coq = parse | nl { if not (only_gallina ()) then Output.line_break(); coq_bol lexbuf } | "(**" space_nl { Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then coq_bol lexbuf else coq lexbuf } | "(*" { comment_level := 1; let eol = if parse_comments () then begin Output.start_comment (); comment lexbuf end else skipped_comment lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | nl+ space* "]]" { if not !formatted then begin (* Isn't this an anomaly *) let s = lexeme lexbuf in let nlsp,s = remove_newline s in let nbsp,isp = count_spaces s in Output.indentation nbsp; let loc = lexeme_start lexbuf + isp + nlsp in Output.sublexer ']' loc; Output.sublexer ']' (loc+1); coq lexbuf end } | eof { () } | (("Local"|"Global") space+)? gallina_kw_to_hide { let s = lexeme lexbuf in if !Cdglobals.light && section_or_end s then begin let eol = skip_to_dot lexbuf in if eol then coq_bol lexbuf else coq lexbuf end else begin Output.ident s None; let eol=body lexbuf in if eol then coq_bol lexbuf else coq lexbuf end } | prf_token { let eol = if not !Cdglobals.gallina then begin backtrack lexbuf; body lexbuf end else let s = lexeme lexbuf in let eol = if s.[String.length s - 1] = '.' then false else skip_to_dot lexbuf in eol in if eol then coq_bol lexbuf else coq lexbuf } | end_kw { let eol = if not !Cdglobals.gallina then begin backtrack lexbuf; body lexbuf end else let eol = skip_to_dot lexbuf in if !in_proof <> Some true && eol then Output.line_break (); eol in in_proof := None; if eol then coq_bol lexbuf else coq lexbuf } | gallina_kw { let s = lexeme lexbuf in Output.ident s None; let eol = body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | notation_kw { let s = lexeme lexbuf in Output.ident s None; let eol= start_notation_string lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | prog_kw { let s = lexeme lexbuf in Output.ident s None; let eol = body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | space+ { Output.char ' '; coq lexbuf } | eof { () } | _ { let eol = if not !Cdglobals.gallina then begin backtrack lexbuf; body lexbuf end else skip_to_dot_or_brace lexbuf in if eol then coq_bol lexbuf else coq lexbuf} (*s Scanning documentation, at beginning of line *) and doc_bol = parse | space* section space+ ([^'\n' '*'] | '*'+ [^'\n' ')' '*'])* ('*'+ '\n')? { let eol, lex = strip_eol (lexeme lexbuf) in let lev, s = sec_title lex in if (!Cdglobals.lib_subtitles) && (subtitle (Output.get_module false) s) then () else Output.section lev (fun () -> ignore (doc None (from_string s))); if eol then doc_bol lexbuf else doc None lexbuf } | space_nl* '-'+ { let buf' = lexeme lexbuf in let bufs = Str.split_delim (Str.regexp "['\n']") buf' in let lines = (List.length bufs) - 1 in let line = match bufs with | [] -> eprintf "Internal error bad_split1 - please report\n"; exit 1 | _ -> List.nth bufs lines in match check_start_list line with | Neither -> backtrack_past_newline lexbuf; doc None lexbuf | List n -> if lines > 0 then Output.paragraph (); Output.item 1; doc (Some [n]) lexbuf | Rule -> Output.rule (); doc None lexbuf } | space* nl+ { Output.paragraph (); doc_bol lexbuf } | "<<" space* { Output.start_verbatim false; verbatim false lexbuf; doc_bol lexbuf } | eof { true } | '_' { if !Cdglobals.plain_comments then Output.char '_' else start_emph (); doc None lexbuf } | _ { backtrack lexbuf; doc None lexbuf } (*s Scanning lists - using whitespace *) and doc_list_bol indents = parse | space* '-' { let (n_spaces,_) = count_spaces (lexeme lexbuf) in match find_level indents n_spaces with | Before -> backtrack lexbuf; doc_bol lexbuf | StartLevel n -> Output.item n; doc (Some (take n indents)) lexbuf | InLevel (n,true) -> let items = List.length indents in Output.item (items+1); doc (Some (List.append indents [n_spaces])) lexbuf | InLevel (_,false) -> backtrack lexbuf; doc_bol lexbuf } | "<<" space* { Output.start_verbatim false; verbatim false lexbuf; doc_list_bol indents lexbuf } | "[[" nl { formatted := true; Output.start_inline_coq_block (); ignore(body_bol lexbuf); Output.end_inline_coq_block (); formatted := false; doc_list_bol indents lexbuf } | "[[[" nl { inf_rules (Some indents) lexbuf } | space* nl space* '-' { (* Like in the doc_bol production, these two productions exist only to deal properly with whitespace *) Output.paragraph (); backtrack_past_newline lexbuf; doc_list_bol indents lexbuf } | space* nl space* _ { let buf' = lexeme lexbuf in let buf = let bufs = Str.split_delim (Str.regexp "['\n']") buf' in match bufs with | (_ :: s :: []) -> s | (_ :: _ :: s :: _) -> s | _ -> eprintf "Internal error bad_split2 - please report\n"; exit 1 in let (n_spaces,_) = count_spaces buf in match find_level indents n_spaces with | StartLevel 1 | Before -> (* Here we were at the beginning of a line, and it was blank. The next line started before any list items. So: insert a paragraph for the empty line, rewind to whatever's just after the newline, then toss over to doc_bol for whatever comes next. *) Output.stop_item (); Output.paragraph (); backtrack_past_newline lexbuf; doc_bol lexbuf | StartLevel _ | InLevel _ -> Output.paragraph (); backtrack_past_newline lexbuf; doc_list_bol indents lexbuf } | space* _ { let (n_spaces,_) = count_spaces (lexeme lexbuf) in match find_level indents n_spaces with | Before -> Output.stop_item (); backtrack lexbuf; doc_bol lexbuf | StartLevel n -> Output.reach_item_level (n-1); backtrack lexbuf; doc (Some (take (n-1) indents)) lexbuf | InLevel (n,_) -> Output.reach_item_level n; backtrack lexbuf; doc (Some (take n indents)) lexbuf } (*s Scanning documentation elsewhere *) and doc indents = parse | nl { Output.char '\n'; match indents with | Some ls -> doc_list_bol ls lexbuf | None -> doc_bol lexbuf } | "[[" nl { if !Cdglobals.plain_comments then (Output.char '['; Output.char '['; doc indents lexbuf) else (formatted := true; Output.start_inline_coq_block (); let eol = body_bol lexbuf in Output.end_inline_coq_block (); formatted := false; if eol then match indents with | Some ls -> doc_list_bol ls lexbuf | None -> doc_bol lexbuf else doc indents lexbuf)} | "[[[" nl { inf_rules indents lexbuf } | "[]" { Output.proofbox (); doc indents lexbuf } | "{{" { url lexbuf; doc indents lexbuf } | "[" { if !Cdglobals.plain_comments then Output.char '[' else (brackets := 1; Output.start_inline_coq (); escaped_coq lexbuf; Output.end_inline_coq ()); doc indents lexbuf } | "(*" { backtrack lexbuf ; let bol_parse = match indents with | Some is -> doc_list_bol is | None -> doc_bol in let eol = if !Cdglobals.parse_comments then comment lexbuf else skipped_comment lexbuf in if eol then bol_parse lexbuf else doc indents lexbuf } | '*'* "*)" space_nl* "(**" {(match indents with | Some _ -> Output.stop_item () | None -> ()); (* this says - if there is a blank line between the two comments, insert one in the output too *) let lines = List.length (Str.split_delim (Str.regexp "['\n']") (lexeme lexbuf)) in if lines > 2 then Output.paragraph (); doc_bol lexbuf } | '*'* "*)" space* nl { true } | '*'* "*)" { false } | "$" { if !Cdglobals.plain_comments then Output.char '$' else (Output.start_latex_math (); escaped_math_latex lexbuf); doc indents lexbuf } | "$$" { if !Cdglobals.plain_comments then Output.char '$'; Output.char '$'; doc indents lexbuf } | "%" { if !Cdglobals.plain_comments then Output.char '%' else escaped_latex lexbuf; doc indents lexbuf } | "%%" { if !Cdglobals.plain_comments then Output.char '%'; Output.char '%'; doc indents lexbuf } | "#" { if !Cdglobals.plain_comments then Output.char '#' else escaped_html lexbuf; doc indents lexbuf } | "##" { if !Cdglobals.plain_comments then Output.char '#'; Output.char '#'; doc indents lexbuf } | nonidentchar '_' nonidentchar { List.iter (fun x -> Output.char (lexeme_char lexbuf x)) [0;1;2]; doc indents lexbuf} | nonidentchar '_' { Output.char (lexeme_char lexbuf 0); if !Cdglobals.plain_comments then Output.char '_' else start_emph () ; doc indents lexbuf } | '_' nonidentchar { if !Cdglobals.plain_comments then Output.char '_' else stop_emph () ; Output.char (lexeme_char lexbuf 1); doc indents lexbuf } | "<<" space* { Output.start_verbatim true; verbatim true lexbuf; doc_bol lexbuf } | '"' { if !Cdglobals.plain_comments then Output.char '"' else if in_quote () then stop_quote () else start_quote (); doc indents lexbuf } | eof { false } | _ { Output.char (lexeme_char lexbuf 0); doc indents lexbuf } (*s Various escapings *) and escaped_math_latex = parse | "$" { Output.stop_latex_math () } | eof { Output.stop_latex_math () } | "*)" { Output.stop_latex_math (); backtrack lexbuf } | _ { Output.latex_char (lexeme_char lexbuf 0); escaped_math_latex lexbuf } and escaped_latex = parse | "%" { () } | eof { () } | "*)" { backtrack lexbuf } | _ { Output.latex_char (lexeme_char lexbuf 0); escaped_latex lexbuf } and escaped_html = parse | "#" { () } | "&#" { Output.html_char '&'; Output.html_char '#'; escaped_html lexbuf } | "##" { Output.html_char '#'; escaped_html lexbuf } | eof { () } | "*)" { backtrack lexbuf } | _ { Output.html_char (lexeme_char lexbuf 0); escaped_html lexbuf } and verbatim inline = parse | nl ">>" space* nl { Output.verbatim_char inline '\n'; Output.stop_verbatim inline } | nl ">>" { Output.verbatim_char inline '\n'; Output.stop_verbatim inline } | ">>" { Output.stop_verbatim inline } | "*)" { Output.stop_verbatim inline; backtrack lexbuf } | eof { Output.stop_verbatim inline } | _ { Output.verbatim_char inline (lexeme_char lexbuf 0); verbatim inline lexbuf } and url = parse | "}}" { Output.url (Buffer.contents url_buffer) None; Buffer.clear url_buffer } | "}" { url_name lexbuf } | _ { Buffer.add_char url_buffer (lexeme_char lexbuf 0); url lexbuf } and url_name = parse | "}" { Output.url (Buffer.contents url_buffer) (Some (Buffer.contents url_name_buffer)); Buffer.clear url_buffer; Buffer.clear url_name_buffer } | _ { Buffer.add_char url_name_buffer (lexeme_char lexbuf 0); url_name lexbuf } (*s Coq, inside quotations *) and escaped_coq = parse | "]" { decr brackets; if !brackets > 0 then (Output.sublexer_in_doc ']'; escaped_coq lexbuf) else Tokens.flush_sublexer () } | "[" { incr brackets; Output.sublexer_in_doc '['; escaped_coq lexbuf } | "(*" { Tokens.flush_sublexer (); comment_level := 1; ignore (if !Cdglobals.parse_comments then comment lexbuf else skipped_comment lexbuf); escaped_coq lexbuf } | "*)" { (* likely to be a syntax error: we escape *) backtrack lexbuf } | eof { Tokens.flush_sublexer () } | (identifier '.')* identifier { Tokens.flush_sublexer(); Output.ident (lexeme lexbuf) None; escaped_coq lexbuf } | space_nl* { let str = lexeme lexbuf in Tokens.flush_sublexer(); (if !Cdglobals.inline_notmono then () else Output.end_inline_coq ()); String.iter Output.char str; (if !Cdglobals.inline_notmono then () else Output.start_inline_coq ()); escaped_coq lexbuf } | _ { Output.sublexer_in_doc (lexeme_char lexbuf 0); escaped_coq lexbuf } (*s Coq "Comments" command. *) and comments = parse | space_nl+ { Output.char ' '; comments lexbuf } | '"' [^ '"']* '"' { let s = lexeme lexbuf in let s = String.sub s 1 (String.length s - 2) in ignore (doc None (from_string s)); comments lexbuf } | ([^ '.' '"'] | '.' [^ ' ' '\t' '\n'])+ { escaped_coq (from_string (lexeme lexbuf)); comments lexbuf } | "." (space_nl | eof) { () } | eof { () } | _ { Output.char (lexeme_char lexbuf 0); comments lexbuf } and skipped_comment = parse | "(*" { incr comment_level; skipped_comment lexbuf } | "*)" space* nl { decr comment_level; if !comment_level > 0 then skipped_comment lexbuf else true } | "*)" { decr comment_level; if !comment_level > 0 then skipped_comment lexbuf else false } | eof { false } | _ { skipped_comment lexbuf } and comment = parse | "(*" { incr comment_level; Output.start_comment (); comment lexbuf } | "*)" space* nl { Output.end_comment (); Output.line_break (); decr comment_level; if !comment_level > 0 then comment lexbuf else true } | "*)" { Output.end_comment (); decr comment_level; if !comment_level > 0 then comment lexbuf else false } | "[" { if !Cdglobals.plain_comments then Output.char '[' else (brackets := 1; Output.start_inline_coq (); escaped_coq lexbuf; Output.end_inline_coq ()); comment lexbuf } | "[[" nl { if !Cdglobals.plain_comments then (Output.char '['; Output.char '[') else (formatted := true; Output.start_inline_coq_block (); let _ = body_bol lexbuf in Output.end_inline_coq_block (); formatted := false); comment lexbuf } | "$" { if !Cdglobals.plain_comments then Output.char '$' else (Output.start_latex_math (); escaped_math_latex lexbuf); comment lexbuf } | "$$" { if !Cdglobals.plain_comments then Output.char '$'; Output.char '$'; comment lexbuf } | "%" { if !Cdglobals.plain_comments then Output.char '%' else escaped_latex lexbuf; comment lexbuf } | "%%" { if !Cdglobals.plain_comments then Output.char '%'; Output.char '%'; comment lexbuf } | "#" { if !Cdglobals.plain_comments then Output.char '#' else escaped_html lexbuf; comment lexbuf } | "##" { if !Cdglobals.plain_comments then Output.char '#'; Output.char '#'; comment lexbuf } | eof { false } | space+ { Output.indentation (fst (count_spaces (lexeme lexbuf))); comment lexbuf } | nl { Output.line_break (); comment lexbuf } | _ { Output.char (lexeme_char lexbuf 0); comment lexbuf } and skip_to_dot = parse | '.' space* nl { true } | eof | '.' space+ { false } | "(*" { comment_level := 1; ignore (skipped_comment lexbuf); skip_to_dot lexbuf } | _ { skip_to_dot lexbuf } and skip_to_dot_or_brace = parse | '.' space* nl { true } | eof | '.' space+ { false } | "(*" { comment_level := 1; ignore (skipped_comment lexbuf); skip_to_dot_or_brace lexbuf } | "}" space* nl { true } | "}" { false } | space* { skip_to_dot_or_brace lexbuf } | _ { skip_to_dot lexbuf } and body_bol = parse | space+ { Output.indentation (fst (count_spaces (lexeme lexbuf))); body lexbuf } | _ { backtrack lexbuf; Output.indentation 0; body lexbuf } and body = parse | nl {Tokens.flush_sublexer(); Output.line_break(); Lexing.new_line lexbuf; body_bol lexbuf} | nl+ space* "]]" space* nl { Tokens.flush_sublexer(); if not !formatted then begin let s = lexeme lexbuf in let nlsp,s = remove_newline s in let _,isp = count_spaces s in let loc = lexeme_start lexbuf + nlsp + isp in Output.sublexer ']' loc; Output.sublexer ']' (loc+1); Tokens.flush_sublexer(); body lexbuf end else begin Output.paragraph (); true end } | "]]" space* nl { Tokens.flush_sublexer(); if not !formatted then begin let loc = lexeme_start lexbuf in Output.sublexer ']' loc; Output.sublexer ']' (loc+1); Tokens.flush_sublexer(); Output.line_break(); body lexbuf end else begin Output.paragraph (); true end } | eof { Tokens.flush_sublexer(); false } | '.' space* nl | '.' space* eof { Tokens.flush_sublexer(); Output.char '.'; Output.line_break(); if not !formatted then true else body_bol lexbuf } | '.' space* nl "]]" space* nl { Tokens.flush_sublexer(); Output.char '.'; if not !formatted then begin eprintf "Error: stray ]] at %d\n" (lexeme_start lexbuf); flush stderr; exit 1 end else begin Output.paragraph (); true end } | '.' space+ { Tokens.flush_sublexer(); Output.char '.'; Output.char ' '; if not !formatted then false else body lexbuf } | "(**" space_nl { Tokens.flush_sublexer(); Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then body_bol lexbuf else body lexbuf } | "(*" { Tokens.flush_sublexer(); comment_level := 1; let eol = if parse_comments () then begin Output.start_comment (); comment lexbuf end else begin let eol = skipped_comment lexbuf in if eol then Output.line_break(); eol end in if eol then body_bol lexbuf else body lexbuf } | "where" { Tokens.flush_sublexer(); Output.ident (lexeme lexbuf) None; start_notation_string lexbuf } | identifier { Tokens.flush_sublexer(); Output.ident (lexeme lexbuf) (Some (lexeme_start lexbuf)); body lexbuf } | ".." { Tokens.flush_sublexer(); Output.char '.'; Output.char '.'; body lexbuf } | '"' { Tokens.flush_sublexer(); Output.char '"'; string lexbuf; body lexbuf } | space { Tokens.flush_sublexer(); Output.char (lexeme_char lexbuf 0); body lexbuf } | _ { let c = lexeme_char lexbuf 0 in Output.sublexer c (lexeme_start lexbuf); body lexbuf } and start_notation_string = parse | space { Tokens.flush_sublexer(); Output.char (lexeme_char lexbuf 0); start_notation_string lexbuf } | '"' (* a true notation *) { Output.sublexer '"' (lexeme_start lexbuf); notation_string lexbuf; body lexbuf } | _ (* an abbreviation *) { backtrack lexbuf; body lexbuf } and notation_string = parse | "\"\"" { Output.char '"'; Output.char '"'; (* Unlikely! *) notation_string lexbuf } | '"' { Tokens.flush_sublexer(); Output.char '"' } | _ { let c = lexeme_char lexbuf 0 in Output.sublexer c (lexeme_start lexbuf); notation_string lexbuf } and string = parse | "\"\"" { Output.char '"'; Output.char '"'; string lexbuf } | '"' { Output.char '"' } | _ { let c = lexeme_char lexbuf 0 in Output.char c; string lexbuf } and skip_hide = parse | eof | end_hide { () } | _ { skip_hide lexbuf } (*s Reading token pretty-print *) and printing_token_body = parse | "*)" nl? | eof { let s = Buffer.contents token_buffer in Buffer.clear token_buffer; s } | _ { Buffer.add_string token_buffer (lexeme lexbuf); printing_token_body lexbuf } (*s These handle inference rules, parsing the body segments of things enclosed in [[[ ]]] brackets *) and inf_rules indents = parse | space* nl (* blank line, before or between definitions *) { inf_rules indents lexbuf } | "]]]" nl (* end of the inference rules block *) { match indents with | Some ls -> doc_list_bol ls lexbuf | None -> doc_bol lexbuf } | _ { backtrack lexbuf; (* anything else must be the first line in a rule *) inf_rules_assumptions indents [] lexbuf} (* The inference rule parsing just collects the inference rule and then calls the output function once, instead of doing things incrementally like the rest of the lexer. If only there were a real parsing phase... *) and inf_rules_assumptions indents assumptions = parse | space* "---" '-'* [^ '\n']* nl (* hit the horizontal line *) { let line = lexeme lexbuf in let (spaces,_) = count_spaces line in let dashes_and_name = cut_head_tail_spaces (String.sub line 0 (String.length line - 1)) in let ldn = String.length dashes_and_name in let (dashes,name) = try (let i = String.index dashes_and_name ' ' in let d = String.sub dashes_and_name 0 i in let n = cut_head_tail_spaces (String.sub dashes_and_name (i+1) (ldn-i-1)) in (d, Some n)) with _ -> (dashes_and_name, None) in inf_rules_conclusion indents (List.rev assumptions) (spaces, dashes, name) [] lexbuf } | [^ '\n']* nl (* if it's not the horizontal line, it's an assumption *) { let line = lexeme lexbuf in let (spaces,_) = count_spaces line in let assumption = cut_head_tail_spaces (String.sub line 0 (String.length line - 1)) in inf_rules_assumptions indents ((spaces,assumption)::assumptions) lexbuf } (*s The conclusion is required to come immediately after the horizontal bar. It is allowed to contain multiple lines of text, like the assumptions. The conclusion ends when we spot a blank line or a ']]]'. *) and inf_rules_conclusion indents assumptions middle conclusions = parse | space* nl | space* "]]]" nl (* end of conclusions. *) { backtrack lexbuf; Output.inf_rule assumptions middle (List.rev conclusions); inf_rules indents lexbuf } | space* [^ '\n']+ nl (* this is a line in the conclusion *) { let line = lexeme lexbuf in let (spaces,_) = count_spaces line in let conc = cut_head_tail_spaces (String.sub line 0 (String.length line - 1)) in inf_rules_conclusion indents assumptions middle ((spaces,conc) :: conclusions) lexbuf } (*s A small scanner to support the chapter subtitle feature *) and st_start m = parse | "(*" "*"+ space+ "*" space+ { st_modname m lexbuf } | _ { None } and st_modname m = parse | identifier space* ":" space* { if subtitle m (lexeme lexbuf) then st_subtitle lexbuf else None } | _ { None } and st_subtitle = parse | [^ '\n']* '\n' { let st = lexeme lexbuf in let i = try Str.search_forward (Str.regexp "\\**)") st 0 with Not_found -> (eprintf "unterminated comment at beginning of file\n"; exit 1) in Some (cut_head_tail_spaces (String.sub st 0 i)) } | _ { None } (*s Applying the scanners to files *) { let coq_file f m = reset (); let c = open_in f in let lb = from_channel c in (Index.current_library := m; Output.initialize (); Output.start_module (); Output.start_coq (); coq_bol lb; Output.end_coq (); close_in c) let detect_subtitle f m = let c = open_in f in let lb = from_channel c in let sub = st_start m lb in close_in c; sub } coq-8.6/tools/coqdoc/coqdoc.sty0000644000175000017500000001256613022274260016112 0ustar mdenesmdenes % This is coqdoc.sty, by Jean-Christophe Filliâtre % This LaTeX package is used by coqdoc (http://www.lri.fr/~filliatr/coqdoc) % % You can modify the following macros to customize the appearance % of the document. \NeedsTeXFormat{LaTeX2e} \ProvidesPackage{coqdoc}[2002/02/11] % % Headings % \usepackage{fancyhdr} % \newcommand{\coqdocleftpageheader}{\thepage\ -- \today} % \newcommand{\coqdocrightpageheader}{\today\ -- \thepage} % \pagestyle{fancyplain} % %BEGIN LATEX % \headsep 8mm % \renewcommand{\plainheadrulewidth}{0.4pt} % \renewcommand{\plainfootrulewidth}{0pt} % \lhead[\coqdocleftpageheader]{\leftmark} % \rhead[\leftmark]{\coqdocrightpageheader} % \cfoot{} % %END LATEX % Hevea puts to much space with \medskip and \bigskip %HEVEA\renewcommand{\medskip}{} %HEVEA\renewcommand{\bigskip}{} %HEVEA\newcommand{\lnot}{\coqwkw{not}} %HEVEA\newcommand{\lor}{\coqwkw{or}} %HEVEA\newcommand{\land}{\&} % own name \newcommand{\coqdoc}{\textsf{coqdoc}} % pretty underscores (the package fontenc causes ugly underscores) %BEGIN LATEX \def\_{\kern.08em\vbox{\hrule width.35em height.6pt}\kern.08em} %END LATEX % macro for typesetting keywords \newcommand{\coqdockw}[1]{\texttt{#1}} % macro for typesetting variable identifiers \newcommand{\coqdocvar}[1]{\textit{#1}} % macro for typesetting constant identifiers \newcommand{\coqdoccst}[1]{\textsf{#1}} % macro for typesetting module identifiers \newcommand{\coqdocmod}[1]{\textsc{\textsf{#1}}} % macro for typesetting module constant identifiers (e.g. Parameters in % module types) \newcommand{\coqdocax}[1]{\textsl{\textsf{#1}}} % macro for typesetting inductive type identifiers \newcommand{\coqdocind}[1]{\textbf{\textsf{#1}}} % macro for typesetting constructor identifiers \newcommand{\coqdocconstr}[1]{\textsf{#1}} % macro for typesetting tactic identifiers \newcommand{\coqdoctac}[1]{\texttt{#1}} % These are the real macros used by coqdoc, their typesetting is % based on the above macros by default. \newcommand{\coqdoclibrary}[1]{\coqdoccst{#1}} \newcommand{\coqdocinductive}[1]{\coqdocind{#1}} \newcommand{\coqdocdefinition}[1]{\coqdoccst{#1}} \newcommand{\coqdocvariable}[1]{\coqdocvar{#1}} \newcommand{\coqdocconstructor}[1]{\coqdocconstr{#1}} \newcommand{\coqdoclemma}[1]{\coqdoccst{#1}} \newcommand{\coqdocclass}[1]{\coqdocind{#1}} \newcommand{\coqdocinstance}[1]{\coqdoccst{#1}} \newcommand{\coqdocmethod}[1]{\coqdoccst{#1}} \newcommand{\coqdocabbreviation}[1]{\coqdoccst{#1}} \newcommand{\coqdocrecord}[1]{\coqdocind{#1}} \newcommand{\coqdocprojection}[1]{\coqdoccst{#1}} \newcommand{\coqdocnotation}[1]{\coqdockw{#1}} \newcommand{\coqdocsection}[1]{\coqdoccst{#1}} \newcommand{\coqdocaxiom}[1]{\coqdocax{#1}} \newcommand{\coqdocmodule}[1]{\coqdocmod{#1}} % Environment encompassing code fragments % !!! CAUTION: This environment may have empty contents \newenvironment{coqdoccode}{}{} % Environment for comments \newenvironment{coqdoccomment}{\tt(*}{*)} % newline and indentation %BEGIN LATEX % Base indentation length \newlength{\coqdocbaseindent} \setlength{\coqdocbaseindent}{0em} % Beginning of a line without any Coq indentation \newcommand{\coqdocnoindent}{\noindent\kern\coqdocbaseindent} % Beginning of a line with a given Coq indentation \newcommand{\coqdocindent}[1]{\noindent\kern\coqdocbaseindent\noindent\kern#1} % End-of-the-line \newcommand{\coqdoceol}{\hspace*{\fill}\setlength\parskip{0pt}\par} % Empty lines (in code only) \newcommand{\coqdocemptyline}{\vskip 0.4em plus 0.1em minus 0.1em} \usepackage{ifpdf} \ifpdf \RequirePackage{hyperref} \hypersetup{raiselinks=true,colorlinks=true,linkcolor=black} % To do indexing, use something like: % \usepackage{multind} % \newcommand{\coqdef}[3]{\hypertarget{coq:#1}{\index{coq}{#1@#2|hyperpage}#3}} \newcommand{\coqdef}[3]{\phantomsection\hypertarget{coq:#1}{#3}} \newcommand{\coqref}[2]{\hyperlink{coq:#1}{#2}} \newcommand{\coqexternalref}[3]{\href{#1.html\##2}{#3}} \newcommand{\identref}[2]{\hyperlink{coq:#1}{\textsf {#2}}} \newcommand{\coqlibrary}[3]{\cleardoublepage\phantomsection \hypertarget{coq:#1}{\chapter{#2\texorpdfstring{\coqdoccst}{}{#3}}}} \else \newcommand{\coqdef}[3]{#3} \newcommand{\coqref}[2]{#2} \newcommand{\coqexternalref}[3]{#3} \newcommand{\texorpdfstring}[2]{#1} \newcommand{\identref}[2]{\textsf{#2}} \newcommand{\coqlibrary}[3]{\cleardoublepage\chapter{#2\coqdoccst{#3}}} \fi \usepackage{xr} \newif\if@coqdoccolors \@coqdoccolorsfalse \DeclareOption{color}{\@coqdoccolorstrue} \ProcessOptions \if@coqdoccolors \RequirePackage{xcolor} \definecolor{varpurple}{rgb}{0.4,0,0.4} \definecolor{constrmaroon}{rgb}{0.6,0,0} \definecolor{defgreen}{rgb}{0,0.4,0} \definecolor{indblue}{rgb}{0,0,0.8} \definecolor{kwred}{rgb}{0.8,0.1,0.1} \def\coqdocvarcolor{varpurple} \def\coqdockwcolor{kwred} \def\coqdoccstcolor{defgreen} \def\coqdocindcolor{indblue} \def\coqdocconstrcolor{constrmaroon} \def\coqdocmodcolor{defgreen} \def\coqdocaxcolor{varpurple} \def\coqdoctaccolor{black} \def\coqdockw#1{{\color{\coqdockwcolor}{\texttt{#1}}}} \def\coqdocvar#1{{\color{\coqdocvarcolor}{\textit{#1}}}} \def\coqdoccst#1{{\color{\coqdoccstcolor}{\textrm{#1}}}} \def\coqdocind#1{{\color{\coqdocindcolor}{\textsf{#1}}}} \def\coqdocconstr#1{{\color{\coqdocconstrcolor}{\textsf{#1}}}} \def\coqdocmod#1{{{\color{\coqdocmodcolor}{\textsc{\textsf{#1}}}}}} \def\coqdocax#1{{{\color{\coqdocaxcolor}{\textsl{\textrm{#1}}}}}} \def\coqdoctac#1{{\color{\coqdoctaccolor}{\texttt{#1}}}} \fi \endinput coq-8.6/tools/coqdoc/index.ml0000644000175000017500000002437713022274260015545 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "<>" then if id <> "<>" then sp ^ "." ^ id else sp else if id <> "<>" then id else "" let add_def loc1 loc2 ty sp id = let fullid = full_ident sp id in let def = Def (fullid, ty) in for loc = loc1 to loc2 do Hashtbl.add reftable (!current_library, loc) def done; Hashtbl.add deftable !current_library (fullid, ty); Hashtbl.add byidtable id (!current_library, fullid, ty) let add_ref m loc m' sp id ty = let fullid = full_ident sp id in if Hashtbl.mem reftable (m, loc) then () else Hashtbl.add reftable (m, loc) (Ref (m', fullid, ty)); let idx = if id = "<>" then m' else id in if Hashtbl.mem byidtable idx then () else Hashtbl.add byidtable idx (m', fullid, ty) let find m l = Hashtbl.find reftable (m, l) let find_string m s = let (m,s,t) = Hashtbl.find byidtable s in Ref (m,s,t) (* Coq modules *) let split_sp s = try let i = String.rindex s '.' in String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1) with Not_found -> "", s let modules = Hashtbl.create 97 let local_modules = Hashtbl.create 97 let add_module m = let _,id = split_sp m in Hashtbl.add modules id m; Hashtbl.add local_modules m () type module_kind = Local | External of string | Unknown let external_libraries = ref [] let add_external_library logicalpath url = external_libraries := (logicalpath,url) :: !external_libraries let find_external_library logicalpath = let rec aux = function | [] -> raise Not_found | (l,u)::rest -> if String.length logicalpath > String.length l && String.sub logicalpath 0 (String.length l + 1) = l ^"." then u else aux rest in aux !external_libraries let init_coqlib_library () = add_external_library "Coq" !coqlib let find_module m = if Hashtbl.mem local_modules m then Local else try External (Filename.concat (find_external_library m) m) with Not_found -> Unknown (* Building indexes *) type 'a index = { idx_name : string; idx_entries : (char * (string * 'a) list) list; idx_size : int } let map f i = { i with idx_entries = List.map (fun (c,l) -> (c, List.map (fun (s,x) -> (s,f s x)) l)) i.idx_entries } let compare_entries (s1,_) (s2,_) = Alpha.compare_string s1 s2 let sort_entries el = let t = Hashtbl.create 97 in List.iter (fun c -> Hashtbl.add t c []) ['A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M'; 'N'; 'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z'; '_'; '*']; List.iter (fun ((s,_) as e) -> let c = Alpha.norm_char s.[0] in let c,l = try c,Hashtbl.find t c with Not_found -> '*',Hashtbl.find t '*' in Hashtbl.replace t c (e :: l)) el; let res = ref [] in Hashtbl.iter (fun c l -> res := (c, List.sort compare_entries l) :: !res) t; List.sort (fun (c1,_) (c2,_) -> Alpha.compare_char c1 c2) !res let display_letter c = if c = '*' then "other" else String.make 1 c let type_name = function | Library -> let ln = !lib_name in if ln <> "" then String.lowercase ln else "library" | Module -> "module" | Definition -> "definition" | Inductive -> "inductive" | Constructor -> "constructor" | Lemma -> "lemma" | Record -> "record" | Projection -> "projection" | Instance -> "instance" | Class -> "class" | Method -> "method" | Variable -> "variable" | Axiom -> "axiom" | TacticDefinition -> "tactic" | Abbreviation -> "abbreviation" | Notation -> "notation" | Section -> "section" let prepare_entry s = function | Notation -> (* We decode the encoding done in Dumpglob.cook_notation of coqtop *) (* Encoded notations have the form section:sc:x_'++'_x where: *) (* - the section, if any, ends with a "." *) (* - the scope can be empty *) (* - tokens are separated with "_" *) (* - non-terminal symbols are conventionally represented by "x" *) (* - terminals are enclosed within simple quotes *) (* - existing simple quotes (that necessarily are parts of *) (* terminals) are doubled *) (* (as a consequence, when a terminal contains "_" or "x", these *) (* necessarily appear enclosed within non-doubled simple quotes) *) (* - non-printable characters < 32 are left encoded so that they *) (* are human-readable in index files *) (* Example: "x ' %x _% y %'x %'_' z" is encoded as *) (* "x_''''_'%x'_'_%'_x_'%''x'_'%''_'''_x" *) let err () = eprintf "Invalid notation in globalization file\n"; exit 1 in let h = try String.index_from s 0 ':' with _ -> err () in let i = try String.index_from s (h+1) ':' with _ -> err () in let sc = String.sub s (h+1) (i-h-1) in let ntn = String.make (String.length s - i) ' ' in let k = ref 0 in let j = ref (i+1) in let quoted = ref false in let l = String.length s - 1 in while !j <= l do if not !quoted then begin (match s.[!j] with | '_' -> ntn.[!k] <- ' '; incr k | 'x' -> ntn.[!k] <- '_'; incr k | '\'' -> quoted := true | _ -> assert false) end else if s.[!j] = '\'' then if (!j = l || s.[!j+1] = '_') then quoted := false else (incr j; ntn.[!k] <- s.[!j]; incr k) else begin ntn.[!k] <- s.[!j]; incr k end; incr j done; let ntn = String.sub ntn 0 !k in if sc = "" then ntn else ntn ^ " (" ^ sc ^ ")" | _ -> s let all_entries () = let gl = ref [] in let add_g s m t = gl := (s,(m,t)) :: !gl in let bt = Hashtbl.create 11 in let add_bt t s m = let l = try Hashtbl.find bt t with Not_found -> [] in Hashtbl.replace bt t ((s,m) :: l) in let classify m (s,t) = (add_g s m t; add_bt t s m) in Hashtbl.iter classify deftable; Hashtbl.iter (fun id m -> add_g id m Library; add_bt Library id m) modules; { idx_name = "global"; idx_entries = sort_entries !gl; idx_size = List.length !gl }, Hashtbl.fold (fun t e l -> (t, { idx_name = type_name t; idx_entries = sort_entries e; idx_size = List.length e }) :: l) bt [] let type_of_string = function | "def" | "coe" | "subclass" | "canonstruc" | "fix" | "cofix" | "ex" | "scheme" -> Definition | "prf" | "thm" -> Lemma | "ind" | "variant" | "coind" -> Inductive | "constr" -> Constructor | "indrec" | "rec" | "corec" -> Record | "proj" -> Projection | "class" -> Class | "meth" -> Method | "inst" -> Instance | "var" -> Variable | "defax" | "prfax" | "ax" -> Axiom | "syndef" -> Abbreviation | "not" -> Notation | "lib" -> Library | "mod" | "modtype" -> Module | "tac" -> TacticDefinition | "sec" -> Section | s -> invalid_arg ("type_of_string:" ^ s) let ill_formed_glob_file f = eprintf "Warning: ill-formed file %s (links will not be available)\n" f let outdated_glob_file f = eprintf "Warning: %s not consistent with corresponding .v file (links will not be available)\n" f let correct_file vfile f c = let s = input_line c in if String.length s < 7 || String.sub s 0 7 <> "DIGEST " then (ill_formed_glob_file f; false) else let s = String.sub s 7 (String.length s - 7) in match vfile, s with | None, "NO" -> true | Some _, "NO" -> ill_formed_glob_file f; false | None, _ -> ill_formed_glob_file f; false | Some vfile, s -> s = Digest.to_hex (Digest.file vfile) || (outdated_glob_file f; false) let read_glob vfile f = let c = open_in f in if correct_file vfile f c then let cur_mod = ref "" in try while true do let s = input_line c in let n = String.length s in if n > 0 then begin match s.[0] with | 'F' -> cur_mod := String.sub s 1 (n - 1); current_library := !cur_mod | 'R' -> (try Scanf.sscanf s "R%d:%d %s %s %s %s" (fun loc1 loc2 lib_dp sp id ty -> for loc=loc1 to loc2 do add_ref !cur_mod loc lib_dp sp id (type_of_string ty); (* Also add an entry for each module mentioned in [lib_dp], * to use in interpolation. *) ignore (List.fold_right (fun thisPiece priorPieces -> let newPieces = match priorPieces with | "" -> thisPiece | _ -> thisPiece ^ "." ^ priorPieces in add_ref !cur_mod loc "" "" newPieces Library; newPieces) (Str.split (Str.regexp_string ".") lib_dp) "") done) with _ -> ()) | _ -> try Scanf.sscanf s "%s %d:%d %s %s" (fun ty loc1 loc2 sp id -> add_def loc1 loc2 (type_of_string ty) sp id) with Scanf.Scan_failure _ -> () end done; assert false with End_of_file -> close_in c coq-8.6/tools/coqdoc/main.ml0000644000175000017500000005050513022274260015352 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* on 9 & 10 Mar 2004: * - handling of absolute filenames (function coq_module) * - coq_module: chop ./// (arbitrary amount of slashes), not only "./" * - function chop_prefix not useful anymore. Deleted. * - correct typo in usage message: "-R" -> "--R" * - shorten the definition of make_path * This notice is made to comply with section 2.a of the GPLv2. * It may be removed or abbreviated as far as I am concerned. *) open Cdglobals open Printf (*s \textbf{Usage.} Printed on error output. *) let usage () = prerr_endline ""; prerr_endline "Usage: coqdoc "; prerr_endline " --html produce a HTML document (default)"; prerr_endline " --latex produce a LaTeX document"; prerr_endline " --texmacs produce a TeXmacs document"; prerr_endline " --raw produce a text document"; prerr_endline " --dvi output the DVI"; prerr_endline " --ps output the PostScript"; prerr_endline " --pdf output the Pdf"; prerr_endline " --stdout write output to stdout"; prerr_endline " -o write output in file "; prerr_endline " -d

output files into directory "; prerr_endline " -g (gallina) skip proofs"; prerr_endline " -s (short) no titles for files"; prerr_endline " -l light mode (only defs and statements)"; prerr_endline " -t give a title to the document"; prerr_endline " --body-only suppress LaTeX/HTML header and trailer"; prerr_endline " --with-header prepend as html reader"; prerr_endline " --with-footer append as html footer"; prerr_endline " --no-index do not output the index"; prerr_endline " --multi-index index split in multiple files"; prerr_endline " --index set index name (default is index)"; prerr_endline " --toc output a table of contents"; prerr_endline " --vernac consider as a .v file"; prerr_endline " --tex consider as a .tex file"; prerr_endline " -p insert in LaTeX preamble"; prerr_endline " --files-from read file names to process in "; prerr_endline " --glob-from read globalization information from "; prerr_endline " --no-glob don't use any globalization information (no links will be inserted at identifiers)"; prerr_endline " --quiet quiet mode (default)"; prerr_endline " --verbose verbose mode"; prerr_endline " --no-externals no links to Coq standard library"; prerr_endline " --external set URL for external library d"; prerr_endline " --coqlib set URL for Coq standard library"; prerr_endline (" (default is " ^ Coq_config.wwwstdlib ^ ")"); prerr_endline " --boot run in boot mode"; prerr_endline " --coqlib_path set the path where Coq files are installed"; prerr_endline " -R map physical dir to Coq dir"; prerr_endline " -Q map physical dir to Coq dir"; prerr_endline " --latin1 set ISO-8859-1 mode"; prerr_endline " --utf8 set UTF-8 mode"; prerr_endline " --charset set HTML charset"; prerr_endline " --inputenc set LaTeX input encoding"; prerr_endline " --interpolate try to typeset identifiers in comments using definitions in the same module"; prerr_endline " --parse-comments parse regular comments"; prerr_endline " --plain-comments consider comments as non-literate text"; prerr_endline " --toc-depth don't include TOC entries for sections below level "; prerr_endline " --no-lib-name don't display \"Library\" before library names in the toc"; prerr_endline " --lib-name call top level toc entries instead of \"Library\""; prerr_endline " --lib-subtitles first line comments of the form (** * ModuleName : text *) will be interpreted as subtitles"; prerr_endline " --inline-notmono use a proportional width font for inline code (possibly with a different color)"; prerr_endline ""; exit 1 let obsolete s = eprintf "Warning: option %s is now obsolete; please update your scripts\n" s (*s \textbf{Banner.} Always printed. Notice that it is printed on error output, so that when the output of [coqdoc] is redirected this header is not (unless both standard and error outputs are redirected, of course). *) let banner () = eprintf "This is coqdoc version %s, compiled on %s\n" Coq_config.version Coq_config.compile_date; flush stderr let target_full_name f = match !Cdglobals.target_language with | HTML -> f ^ ".html" | Raw -> f ^ ".txt" | _ -> f ^ ".tex" (*s \textbf{Separation of files.} Files given on the command line are separated according to their type, which is determined by their suffix. Coq files have suffixe \verb!.v! or \verb!.g! and \LaTeX\ files have suffix \verb!.tex!. *) let check_if_file_exists f = if not (Sys.file_exists f) then begin eprintf "coqdoc: %s: no such file\n" f; exit 1 end (* [paths] maps a physical path to a name *) let paths = ref [] let add_path dir name = let p = normalize_path dir in paths := (p,name) :: !paths (* turn A/B/C into A.B.C *) let rec name_of_path p name dirname suffix = if p = dirname then String.concat "." (if name = "" then suffix else (name::suffix)) else let subdir = Filename.dirname dirname in if subdir = dirname then raise Not_found else name_of_path p name subdir (Filename.basename dirname::suffix) let coq_module filename = let bfname = Filename.chop_extension filename in let dirname, fname = normalize_filename bfname in let rec change_prefix = function (* Follow coqc: if in scope of -R, substitute logical name *) (* otherwise, keep only base name *) | [] -> fname | (p, name) :: rem -> try name_of_path p name dirname [fname] with Not_found -> change_prefix rem in change_prefix !paths let what_file f = check_if_file_exists f; if Filename.check_suffix f ".v" || Filename.check_suffix f ".g" then Vernac_file (f, coq_module f) else if Filename.check_suffix f ".tex" then Latex_file f else (eprintf "\ncoqdoc: don't know what to do with %s\n" f; exit 1) (*s \textbf{Reading file names from a file.} * File names may be given * in a file instead of being given on the command * line. [(files_from_file f)] returns the list of file names contained * in the file named [f]. These file names must be separated by spaces, * tabulations or newlines. *) let files_from_file f = let files_from_channel ch = let buf = Buffer.create 80 in let l = ref [] in try while true do match input_char ch with | ' ' | '\t' | '\n' -> if Buffer.length buf > 0 then l := (Buffer.contents buf) :: !l; Buffer.clear buf | c -> Buffer.add_char buf c done; [] with End_of_file -> List.rev !l in try check_if_file_exists f; let ch = open_in f in let l = files_from_channel ch in close_in ch;l with Sys_error s -> begin eprintf "coqdoc: cannot read from file %s (%s)\n" f s; exit 1 end (*s \textbf{Parsing of the command line.} *) let dvi = ref false let ps = ref false let pdf = ref false let parse () = let files = ref [] in let add_file f = files := f :: !files in let rec parse_rec = function | [] -> () | ("-nopreamble" | "--nopreamble" | "--no-preamble" | "-bodyonly" | "--bodyonly" | "--body-only") :: rem -> header_trailer := false; parse_rec rem | ("-with-header" | "--with-header") :: f ::rem -> header_trailer := true; header_file_spec := true; header_file := f; parse_rec rem | ("-with-header" | "--with-header") :: [] -> usage () | ("-with-footer" | "--with-footer") :: f ::rem -> header_trailer := true; footer_file_spec := true; footer_file := f; parse_rec rem | ("-with-footer" | "--with-footer") :: [] -> usage () | ("-p" | "--preamble") :: s :: rem -> Output.push_in_preamble s; parse_rec rem | ("-p" | "--preamble") :: [] -> usage () | ("-noindex" | "--noindex" | "--no-index") :: rem -> index := false; parse_rec rem | ("-multi-index" | "--multi-index") :: rem -> multi_index := true; parse_rec rem | ("-index" | "--index") :: s :: rem -> Cdglobals.index_name := s; parse_rec rem | ("-index" | "--index") :: [] -> usage () | ("-toc" | "--toc" | "--table-of-contents") :: rem -> toc := true; parse_rec rem | ("-stdout" | "--stdout") :: rem -> out_to := StdOut; parse_rec rem | ("-o" | "--output") :: f :: rem -> out_to := File (Filename.basename f); output_dir := Filename.dirname f; parse_rec rem | ("-o" | "--output") :: [] -> usage () | ("-d" | "--directory") :: dir :: rem -> output_dir := dir; parse_rec rem | ("-d" | "--directory") :: [] -> usage () | ("-s" | "--short") :: rem -> short := true; parse_rec rem | ("-l" | "-light" | "--light") :: rem -> gallina := true; light := true; parse_rec rem | ("-g" | "-gallina" | "--gallina") :: rem -> gallina := true; parse_rec rem | ("-t" | "-title" | "--title") :: s :: rem -> title := s; parse_rec rem | ("-t" | "-title" | "--title") :: [] -> usage () | ("-latex" | "--latex") :: rem -> Cdglobals.target_language := LaTeX; parse_rec rem | ("-pdf" | "--pdf") :: rem -> Cdglobals.target_language := LaTeX; pdf := true; parse_rec rem | ("-dvi" | "--dvi") :: rem -> Cdglobals.target_language := LaTeX; dvi := true; parse_rec rem | ("-ps" | "--ps") :: rem -> Cdglobals.target_language := LaTeX; ps := true; parse_rec rem | ("-html" | "--html") :: rem -> Cdglobals.target_language := HTML; parse_rec rem | ("-texmacs" | "--texmacs") :: rem -> Cdglobals.target_language := TeXmacs; parse_rec rem | ("-raw" | "--raw") :: rem -> Cdglobals.target_language := Raw; parse_rec rem | ("-charset" | "--charset") :: s :: rem -> Cdglobals.charset := s; parse_rec rem | ("-charset" | "--charset") :: [] -> usage () | ("-inputenc" | "--inputenc") :: s :: rem -> Cdglobals.inputenc := s; parse_rec rem | ("-inputenc" | "--inputenc") :: [] -> usage () | ("-raw-comments" | "--raw-comments") :: rem -> Cdglobals.raw_comments := true; parse_rec rem | ("-parse-comments" | "--parse-comments") :: rem -> Cdglobals.parse_comments := true; parse_rec rem | ("-plain-comments" | "--plain-comments") :: rem -> Cdglobals.plain_comments := true; parse_rec rem | ("-interpolate" | "--interpolate") :: rem -> Cdglobals.interpolate := true; parse_rec rem | ("-toc-depth" | "--toc-depth") :: [] -> usage () | ("-toc-depth" | "--toc-depth") :: ds :: rem -> let d = try int_of_string ds with Failure _ -> (eprintf "--toc-depth must be followed by an integer\n"; exit 1) in Cdglobals.toc_depth := Some d; parse_rec rem | ("-no-lib-name" | "--no-lib-name") :: rem -> Cdglobals.lib_name := ""; parse_rec rem | ("-lib-name" | "--lib-name") :: ds :: rem -> Cdglobals.lib_name := ds; parse_rec rem | ("-lib-subtitles" | "--lib-subtitles") :: rem -> Cdglobals.lib_subtitles := true; parse_rec rem | ("-inline-notmono" | "--inline-notmono") :: rem -> Cdglobals.inline_notmono := true; parse_rec rem | ("-latin1" | "--latin1") :: rem -> Cdglobals.set_latin1 (); parse_rec rem | ("-utf8" | "--utf8") :: rem -> Cdglobals.set_utf8 (); parse_rec rem | ("-q" | "-quiet" | "--quiet") :: rem -> quiet := true; parse_rec rem | ("-v" | "-verbose" | "--verbose") :: rem -> quiet := false; parse_rec rem | ("-h" | "-help" | "-?" | "--help") :: rem -> banner (); usage () | ("-V" | "-version" | "--version") :: _ -> banner (); exit 0 | ("-vernac-file" | "--vernac-file") :: f :: rem -> check_if_file_exists f; add_file (Vernac_file (f, coq_module f)); parse_rec rem | ("-vernac-file" | "--vernac-file") :: [] -> usage () | ("-tex-file" | "--tex-file") :: f :: rem -> add_file (Latex_file f); parse_rec rem | ("-tex-file" | "--tex-file") :: [] -> usage () | ("-files" | "--files" | "--files-from") :: f :: rem -> List.iter (fun f -> add_file (what_file f)) (files_from_file f); parse_rec rem | ("-files" | "--files") :: [] -> usage () | "-R" :: path :: log :: rem -> add_path path log; parse_rec rem | "-R" :: ([] | [_]) -> usage () | "-Q" :: path :: log :: rem -> add_path path log; parse_rec rem | "-Q" :: ([] | [_]) -> usage () | ("-glob-from" | "--glob-from") :: f :: rem -> glob_source := GlobFile f; parse_rec rem | ("-glob-from" | "--glob-from") :: [] -> usage () | ("-no-glob" | "--no-glob") :: rem -> glob_source := NoGlob; parse_rec rem | ("--no-externals" | "-no-externals" | "-noexternals") :: rem -> Cdglobals.externals := false; parse_rec rem | ("--external" | "-external") :: u :: logicalpath :: rem -> Index.add_external_library logicalpath u; parse_rec rem | ("--coqlib" | "-coqlib") :: u :: rem -> Cdglobals.coqlib := u; parse_rec rem | ("--coqlib" | "-coqlib") :: [] -> usage () | ("--boot" | "-boot") :: rem -> Cdglobals.coqlib_path := normalize_path ( Filename.concat (Filename.dirname Sys.executable_name) Filename.parent_dir_name ); parse_rec rem | ("--coqlib_path" | "-coqlib_path") :: d :: rem -> Cdglobals.coqlib_path := d; parse_rec rem | ("--coqlib_path" | "-coqlib_path") :: [] -> usage () | f :: rem -> add_file (what_file f); parse_rec rem in parse_rec (List.tl (Array.to_list Sys.argv)); List.rev !files (*s The following function produces the output. The default output is the \LaTeX\ document: in that case, we just call [Web.produce_document]. If option \verb!-dvi!, \verb!-ps! or \verb!-html! is invoked, then we make calls to \verb!latex! or \verb!dvips! or \verb!pdflatex! accordingly. *) let locally dir f x = let cwd = Sys.getcwd () in try Sys.chdir dir; let y = f x in Sys.chdir cwd; y with e -> Sys.chdir cwd; raise e let clean_temp_files basefile = let remove f = try Sys.remove f with _ -> () in remove (basefile ^ ".tex"); remove (basefile ^ ".log"); remove (basefile ^ ".aux"); remove (basefile ^ ".toc"); remove (basefile ^ ".dvi"); remove (basefile ^ ".ps"); remove (basefile ^ ".pdf"); remove (basefile ^ ".haux"); remove (basefile ^ ".html") let clean_and_exit file res = clean_temp_files file; exit res let cat file = let c = open_in file in try while true do print_char (input_char c) done with End_of_file -> close_in c let copy src dst = let cin = open_in src in try let cout = open_out dst in try while true do Pervasives.output_char cout (input_char cin) done with End_of_file -> close_out cout; close_in cin with Sys_error e -> eprintf "%s\n" e; exit 1 (*s Functions for generating output files *) let gen_one_file l = let file = function | Vernac_file (f,m) -> let sub = if !lib_subtitles then Cpretty.detect_subtitle f m else None in Output.set_module m sub; Cpretty.coq_file f m | Latex_file _ -> () in if (!header_trailer) then Output.header (); if !toc then Output.make_toc (); List.iter file l; if !index then Output.make_index(); if (!header_trailer) then Output.trailer () let gen_mult_files l = let file = function | Vernac_file (f,m) -> let sub = if !lib_subtitles then Cpretty.detect_subtitle f m else None in let hf = target_full_name m in Output.set_module m sub; open_out_file hf; if (!header_trailer) then Output.header (); Cpretty.coq_file f m; if (!header_trailer) then Output.trailer (); close_out_file() | Latex_file _ -> () in List.iter file l; if (!index && !target_language=HTML) then begin if (!multi_index) then Output.make_multi_index (); open_out_file (!index_name^".html"); page_title := (if !title <> "" then !title else "Index"); if (!header_trailer) then Output.header (); Output.make_index (); if (!header_trailer) then Output.trailer (); close_out_file() end; if (!toc && !target_language=HTML) then begin open_out_file "toc.html"; page_title := (if !title <> "" then !title else "Table of contents"); if (!header_trailer) then Output.header (); if !title <> "" then printf "

%s

\n" !title; Output.make_toc (); if (!header_trailer) then Output.trailer (); close_out_file() end (* NB: for latex and texmacs, a separated toc or index is meaningless... *) let read_glob_file vfile f = try Index.read_glob vfile f with Sys_error s -> eprintf "Warning: %s (links will not be available)\n" s let read_glob_file_of = function | Vernac_file (f,_) -> read_glob_file (Some f) (Filename.chop_extension f ^ ".glob") | Latex_file _ -> () let index_module = function | Vernac_file (f,m) -> Index.add_module m | Latex_file _ -> () let copy_style_file file = let src = List.fold_left Filename.concat !Cdglobals.coqlib_path ["tools";"coqdoc";file] in let dst = coqdoc_out file in if Sys.file_exists src then copy src dst else eprintf "Warning: file %s does not exist\n" src let produce_document l = if !target_language=HTML then copy_style_file "coqdoc.css"; if !target_language=LaTeX then copy_style_file "coqdoc.sty"; (match !Cdglobals.glob_source with | NoGlob -> () | DotGlob -> List.iter read_glob_file_of l | GlobFile f -> read_glob_file None f); List.iter index_module l; match !out_to with | StdOut -> Cdglobals.out_channel := stdout; gen_one_file l | File f -> open_out_file f; gen_one_file l; close_out_file() | MultFiles -> gen_mult_files l let produce_output fl = if not (!dvi || !ps || !pdf) then produce_document fl else begin let texfile = Filename.temp_file "coqdoc" ".tex" in let basefile = Filename.chop_suffix texfile ".tex" in let final_out_to = !out_to in out_to := File texfile; output_dir := (Filename.dirname texfile); produce_document fl; let latexexe = if !pdf then "pdflatex" else "latex" in let latexcmd = let file = Filename.basename texfile in let file = if !quiet then sprintf "'\\nonstopmode\\input{%s}'" file else file in sprintf "%s %s && %s %s 1>&2 %s" latexexe file latexexe file (if !quiet then "> /dev/null" else "") in let res = locally (Filename.dirname texfile) Sys.command latexcmd in if res <> 0 then begin eprintf "Couldn't run LaTeX successfully\n"; clean_and_exit basefile res end; let dvifile = basefile ^ ".dvi" in if !dvi then begin match final_out_to with | MultFiles | StdOut -> cat dvifile | File f -> copy dvifile f end; let pdffile = basefile ^ ".pdf" in if !pdf then begin match final_out_to with | MultFiles | StdOut -> cat pdffile | File f -> copy pdffile f end; if !ps then begin let psfile = basefile ^ ".ps" in let command = sprintf "dvips %s -o %s %s" dvifile psfile (if !quiet then "> /dev/null 2>&1" else "") in let res = Sys.command command in if res <> 0 then begin eprintf "Couldn't run dvips successfully\n"; clean_and_exit basefile res end; match final_out_to with | MultFiles | StdOut -> cat psfile | File f -> copy psfile f end; clean_temp_files basefile end (*s \textbf{Main program.} Print the banner, parse the command line, read the files and then call [produce_document] from module [Web]. *) let _ = let files = parse () in Index.init_coqlib_library (); if not !quiet then banner (); if files <> [] then produce_output files coq-8.6/tools/coqdoc/cdglobals.ml0000644000175000017500000000712013022274260016353 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "" && Filename.is_relative f then if not (Sys.file_exists !output_dir) then (Printf.eprintf "No such directory: %s\n" !output_dir; exit 1) else !output_dir / f else f let open_out_file f = out_channel := try open_out (coqdoc_out f) with Sys_error s -> Printf.eprintf "%s\n" s; exit 1 let close_out_file () = close_out !out_channel type glob_source_t = | NoGlob | DotGlob | GlobFile of string let glob_source = ref DotGlob (*s Manipulations of paths and path aliases *) let normalize_path p = (* We use the Unix subsystem to normalize a physical path (relative or absolute) and get rid of symbolic links, relative links (like ./ or ../ in the middle of the path; it's tricky but it works... *) (* Rq: Sys.getcwd () returns paths without '/' at the end *) let orig = Sys.getcwd () in Sys.chdir p; let res = Sys.getcwd () in Sys.chdir orig; res let normalize_filename f = let basename = Filename.basename f in let dirname = Filename.dirname f in normalize_path dirname, basename (** A weaker analog of the function in Envars *) let guess_coqlib () = let file = "theories/Init/Prelude.vo" in match Coq_config.coqlib with | Some coqlib when Sys.file_exists (coqlib / file) -> coqlib | Some _ | None -> let coqbin = normalize_path (Filename.dirname Sys.executable_name) in let prefix = Filename.dirname coqbin in let rpath = if Coq_config.local then [] else if Coq_config.arch_is_win32 then ["lib"] else ["lib/coq"] in let coqlib = List.fold_left (/) prefix rpath in if Sys.file_exists (coqlib / file) then coqlib else prefix let header_trailer = ref true let header_file = ref "" let header_file_spec = ref false let footer_file = ref "" let footer_file_spec = ref false let quiet = ref true let light = ref false let gallina = ref false let short = ref false let index = ref true let multi_index = ref false let index_name = ref "index" let toc = ref false let page_title = ref "" let title = ref "" let externals = ref true let coqlib = ref Coq_config.wwwstdlib let coqlib_path = ref (guess_coqlib ()) let raw_comments = ref false let parse_comments = ref false let plain_comments = ref false let toc_depth = (ref None : int option ref) let lib_name = ref "Library" let lib_subtitles = ref false let interpolate = ref false let inline_notmono = ref false let charset = ref "iso-8859-1" let inputenc = ref "" let latin1 = ref false let utf8 = ref false let set_latin1 () = charset := "iso-8859-1"; inputenc := "latin1"; latin1 := true let set_utf8 () = charset := "utf-8"; inputenc := "utf8x"; utf8 := true (* Parsing options *) type coq_module = string type file = | Vernac_file of string * coq_module | Latex_file of string coq-8.6/tools/coqdoc/output.ml0000644000175000017500000012252013022274260015763 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Hashtbl.add h key ()) l; function s -> try Hashtbl.find h s; true with Not_found -> false let is_keyword = build_table [ "About"; "AddPath"; "Axiom"; "Abort"; "Chapter"; "Check"; "Coercion"; "Compute"; "CoFixpoint"; "CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example"; "Export"; "Fact"; "Fix"; "Fixpoint"; "Function"; "Generalizable"; "Global"; "Grammar"; "Guarded"; "Goal"; "Hint"; "Debug"; "On"; "Hypothesis"; "Hypotheses"; "Resolve"; "Unfold"; "Immediate"; "Extern"; "Constructors"; "Rewrite"; "Implicit"; "Import"; "Inductive"; "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac"; "Module"; "Module Type"; "Declare Module"; "Include"; "Mutual"; "Parameter"; "Parameters"; "Print"; "Printing"; "All"; "Proof"; "Proof with"; "Qed"; "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; "Assumptions"; "Axioms"; "Universes"; "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; "Search"; "SearchAbout"; "SearchHead"; "SearchPattern"; "SearchRewrite"; "Set"; "Types"; "Undo"; "Unset"; "Variable"; "Variables"; "Context"; "Notation"; "Reserved Notation"; "Tactic Notation"; "Delimit"; "Bind"; "Open"; "Scope"; "Inline"; "Implicit Arguments"; "Add"; "Strict"; "Typeclasses"; "Instance"; "Global Instance"; "Class"; "Instantiation"; "subgoal"; "subgoals"; "vm_compute"; "Opaque"; "Transparent"; "Time"; "Extraction"; "Extract"; "Variant"; (* Program *) "Program Definition"; "Program Example"; "Program Fixpoint"; "Program Lemma"; "Obligation"; "Obligations"; "Solve"; "using"; "Next Obligation"; "Next"; "Program Instance"; "Equations"; "Equations_nocomp"; (*i (* coq terms *) *) "forall"; "match"; "as"; "in"; "return"; "with"; "end"; "let"; "fun"; "if"; "then"; "else"; "Prop"; "Set"; "Type"; ":="; "where"; "struct"; "wf"; "measure"; "fix"; "cofix"; (* Ltac *) "before"; "after"; "constr"; "ltac"; "goal"; "context"; "beta"; "delta"; "iota"; "zeta"; "lazymatch"; (* Notations *) "level"; "associativity"; "no" ] let is_tactic = build_table [ "intro"; "intros"; "apply"; "rewrite"; "refine"; "case"; "clear"; "injection"; "elimtype"; "progress"; "setoid_rewrite"; "left"; "right"; "constructor"; "econstructor"; "decide equality"; "abstract"; "exists"; "cbv"; "simple destruct"; "info"; "fourier"; "field"; "specialize"; "evar"; "solve"; "instanciate"; "quote"; "eexact"; "autorewrite"; "destruct"; "destruction"; "destruct_call"; "dependent"; "elim"; "extensionality"; "f_equal"; "generalize"; "generalize_eqs"; "generalize_eqs_vars"; "induction"; "rename"; "move"; "omega"; "set"; "assert"; "do"; "repeat"; "cut"; "assumption"; "exact"; "split"; "subst"; "try"; "discriminate"; "simpl"; "unfold"; "red"; "compute"; "at"; "in"; "by"; "reflexivity"; "symmetry"; "transitivity"; "replace"; "setoid_replace"; "inversion"; "inversion_clear"; "pattern"; "intuition"; "congruence"; "fail"; "fresh"; "trivial"; "tauto"; "firstorder"; "ring"; "clapply"; "program_simpl"; "program_simplify"; "eapply"; "auto"; "eauto"; "change"; "fold"; "hnf"; "lazy"; "simple"; "eexists"; "debug"; "idtac"; "first"; "type of"; "pose"; "eval"; "instantiate"; "until" ] (*s Current Coq module *) let current_module : (string * string option) ref = ref ("",None) let get_module withsub = let (m,sub) = !current_module in if withsub then match sub with | None -> m | Some sub -> m ^ ": " ^ sub else m let set_module m sub = current_module := (m,sub); page_title := get_module true (*s Common to both LaTeX and HTML *) let item_level = ref 0 let in_doc = ref false (*s Customized and predefined pretty-print *) let initialize_texmacs () = let ensuremath x = sprintf ">" x in List.fold_right (fun (s,t) tt -> Tokens.ttree_add tt s t) [ "*", ensuremath "times"; "->", ensuremath "rightarrow"; "<-", ensuremath "leftarrow"; "<->", ensuremath "leftrightarrow"; "=>", ensuremath "Rightarrow"; "<=", ensuremath "le"; ">=", ensuremath "ge"; "<>", ensuremath "noteq"; "~", ensuremath "lnot"; "/\\", ensuremath "land"; "\\/", ensuremath "lor"; "|-", ensuremath "vdash" ] Tokens.empty_ttree let token_tree_texmacs = ref (initialize_texmacs ()) let token_tree_latex = ref Tokens.empty_ttree let token_tree_html = ref Tokens.empty_ttree let initialize_tex_html () = let if_utf8 = if !Cdglobals.utf8 then fun x -> Some x else fun _ -> None in let (tree_latex, tree_html) = List.fold_right (fun (s,l,l') (tt,tt') -> (Tokens.ttree_add tt s l, match l' with None -> tt' | Some l' -> Tokens.ttree_add tt' s l')) [ "*" , "\\ensuremath{\\times}", if_utf8 "×"; "|", "\\ensuremath{|}", None; "->", "\\ensuremath{\\rightarrow}", if_utf8 "→"; "->~", "\\ensuremath{\\rightarrow\\lnot}", None; "->~~", "\\ensuremath{\\rightarrow\\lnot\\lnot}", None; "<-", "\\ensuremath{\\leftarrow}", None; "<->", "\\ensuremath{\\leftrightarrow}", if_utf8 "↔"; "=>", "\\ensuremath{\\Rightarrow}", if_utf8 "⇒"; "<=", "\\ensuremath{\\le}", if_utf8 "≤"; ">=", "\\ensuremath{\\ge}", if_utf8 "≥"; "<>", "\\ensuremath{\\not=}", if_utf8 "≠"; "~", "\\ensuremath{\\lnot}", if_utf8 "¬"; "/\\", "\\ensuremath{\\land}", if_utf8 "∧"; "\\/", "\\ensuremath{\\lor}", if_utf8 "∨"; "|-", "\\ensuremath{\\vdash}", None; "forall", "\\ensuremath{\\forall}", if_utf8 "∀"; "exists", "\\ensuremath{\\exists}", if_utf8 "∃"; "Π", "\\ensuremath{\\Pi}", if_utf8 "Π"; "λ", "\\ensuremath{\\lambda}", if_utf8 "λ"; (* "fun", "\\ensuremath{\\lambda}" ? *) ] (Tokens.empty_ttree,Tokens.empty_ttree) in token_tree_latex := tree_latex; token_tree_html := tree_html let add_printing_token s (t1,t2) = (match t1 with None -> () | Some t1 -> token_tree_latex := Tokens.ttree_add !token_tree_latex s t1); (match t2 with None -> () | Some t2 -> token_tree_html := Tokens.ttree_add !token_tree_html s t2) let remove_printing_token s = token_tree_latex := Tokens.ttree_remove !token_tree_latex s; token_tree_html := Tokens.ttree_remove !token_tree_html s (*s Table of contents *) type toc_entry = | Toc_library of string * string option | Toc_section of int * (unit -> unit) * string let (toc_q : toc_entry Queue.t) = Queue.create () let add_toc_entry e = Queue.add e toc_q let new_label = let r = ref 0 in fun () -> incr r; "lab" ^ string_of_int !r (*s LaTeX output *) module Latex = struct let in_title = ref false (*s Latex preamble *) let (preamble : string Queue.t) = Queue.create () let push_in_preamble s = Queue.add s preamble let utf8x_extra_support () = printf "\n"; printf "%%Warning: tipa declares many non-standard macros used by utf8x to\n"; printf "%%interpret utf8 characters but extra packages might have to be added\n"; printf "%%such as \"textgreek\" for Greek letters not already in tipa\n"; printf "%%or \"stmaryrd\" for mathematical symbols.\n"; printf "%%Utf8 codes missing a LaTeX interpretation can be defined by using\n"; printf "%%\\DeclareUnicodeCharacter{code}{interpretation}.\n"; printf "%%Use coqdoc's option -p to add new packages or declarations.\n"; printf "\\usepackage{tipa}\n"; printf "\n" let header () = if !header_trailer then begin printf "\\documentclass[12pt]{report}\n"; if !inputenc != "" then printf "\\usepackage[%s]{inputenc}\n" !inputenc; if !inputenc = "utf8x" then utf8x_extra_support (); printf "\\usepackage[T1]{fontenc}\n"; printf "\\usepackage{fullpage}\n"; printf "\\usepackage{coqdoc}\n"; printf "\\usepackage{amsmath,amssymb}\n"; printf "\\usepackage{url}\n"; (match !toc_depth with | None -> () | Some n -> printf "\\setcounter{tocdepth}{%i}\n" n); Queue.iter (fun s -> printf "%s\n" s) preamble; printf "\\begin{document}\n" end; output_string "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n"; output_string "%% This file has been automatically generated with the command\n"; output_string "%% "; Array.iter (fun s -> printf "%s " s) Sys.argv; printf "\n"; output_string "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n" let trailer () = if !header_trailer then begin printf "\\end{document}\n" end (*s Latex low-level translation *) let nbsp () = output_char '~' let char c = match c with | '\\' -> printf "\\symbol{92}" | '$' | '#' | '%' | '&' | '{' | '}' | '_' -> output_char '\\'; output_char c | '^' | '~' -> output_char '\\'; output_char c; printf "{}" | _ -> output_char c let label_char c = match c with | '_' -> output_char ' ' | '\\' | '$' | '#' | '%' | '&' | '{' | '}' | '^' | '~' -> printf "x%X" (Char.code c) | _ -> if c >= '\x80' then printf "x%X" (Char.code c) else output_char c let label_ident s = for i = 0 to String.length s - 1 do label_char s.[i] done let latex_char = output_char let latex_string = output_string let html_char _ = () let html_string _ = () (*s Latex char escaping *) let escaped = let buff = Buffer.create 5 in fun s -> Buffer.clear buff; for i = 0 to String.length s - 1 do match s.[i] with | '\\' -> Buffer.add_string buff "\\symbol{92}" | '$' | '#' | '%' | '&' | '{' | '}' | '_' as c -> Buffer.add_char buff '\\'; Buffer.add_char buff c | '^' | '~' as c -> Buffer.add_char buff '\\'; Buffer.add_char buff c; Buffer.add_string buff "{}" | '\'' -> if i < String.length s - 1 && s.[i+1] = '\'' then begin Buffer.add_char buff '\''; Buffer.add_char buff '{'; Buffer.add_char buff '}' end else Buffer.add_char buff '\'' | c -> Buffer.add_char buff c done; Buffer.contents buff (*s Latex reference and symbol translation *) let start_module () = let ln = !lib_name in if not !short then begin printf "\\coqlibrary{"; label_ident (get_module false); printf "}{"; if ln <> "" then printf "%s " ln; printf "}{%s}\n\n" (escaped (get_module true)) end let start_latex_math () = output_char '$' let stop_latex_math () = output_char '$' let start_quote () = output_char '`'; output_char '`' let stop_quote () = output_char '\''; output_char '\'' let start_verbatim inline = if inline then printf "\\texttt{" else printf "\\begin{verbatim}" let stop_verbatim inline = if inline then printf "}" else printf "\\end{verbatim}\n" let url addr name = printf "%s\\footnote{\\url{%s}}" (match name with | None -> "" | Some n -> n) addr let indentation n = if n == 0 then printf "\\coqdocnoindent\n" else let space = 0.5 *. (float n) in printf "\\coqdocindent{%2.2fem}\n" space let ident_ref m fid typ s = let id = if fid <> "" then (m ^ "." ^ fid) else m in match find_module m with | Local -> if typ = Variable then printf "\\coqdoc%s{%s}" (type_name typ) s else (printf "\\coqref{"; label_ident id; printf "}{\\coqdoc%s{%s}}" (type_name typ) s) | External m when !externals -> printf "\\coqexternalref{"; label_ident fid; printf "}{%s}{\\coqdoc%s{%s}}" (escaped m) (type_name typ) s | External _ | Unknown -> printf "\\coqdoc%s{%s}" (type_name typ) s let defref m id ty s = if ty <> Notation then (printf "\\coqdef{"; label_ident (m ^ "." ^ id); printf "}{%s}{\\coqdoc%s{%s}}" s (type_name ty) s) else (* Glob file still not able to say the exact extent of the definition *) (* so we currently renounce to highlight the notation location *) (printf "\\coqdef{"; label_ident (m ^ "." ^ id); printf "}{%s}{%s}" s s) let reference s = function | Def (fullid,typ) -> defref (get_module false) fullid typ s | Ref (m,fullid,typ) -> ident_ref m fullid typ s (*s The sublexer buffers symbol characters and attached uninterpreted ident and try to apply special translation such as, predefined, translation "->" to "\ensuremath{\rightarrow}" or, virtually, a user-level translation from "=_h" to "\ensuremath{=_{h}}" *) let output_sublexer_string doescape issymbchar tag s = let s = if doescape then escaped s else s in match tag with | Some ref -> reference s ref | None -> if issymbchar then output_string s else printf "\\coqdocvar{%s}" s let last_was_in = ref false let sublexer c loc = if c = '*' && !last_was_in then begin Tokens.flush_sublexer (); output_char '*' end else begin let tag = try Some (Index.find (get_module false) loc) with Not_found -> None in Tokens.output_tagged_symbol_char tag c end; last_was_in := false let sublexer_in_doc c = if c = '*' && !last_was_in then begin Tokens.flush_sublexer (); output_char '*' end else Tokens.output_tagged_symbol_char None c; last_was_in := false let initialize () = initialize_tex_html (); Tokens.token_tree := token_tree_latex; Tokens.outfun := output_sublexer_string (*s Interpreting ident with fallback on sublexer if unknown ident *) let translate s = match Tokens.translate s with Some s -> s | None -> escaped s let keyword s loc = printf "\\coqdockw{%s}" (translate s) let ident s loc = last_was_in := s = "in"; try match loc with | None -> raise Not_found | Some loc -> let tag = Index.find (get_module false) loc in reference (translate s) tag with Not_found -> if is_tactic s then printf "\\coqdoctac{%s}" (translate s) else if is_keyword s then printf "\\coqdockw{%s}" (translate s) else if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) then try let tag = Index.find_string (get_module false) s in reference (translate s) tag with _ -> Tokens.output_tagged_ident_string s else Tokens.output_tagged_ident_string s let ident s l = if !in_title then ( printf "\\texorpdfstring{\\protect"; ident s l; printf "}{%s}" (translate s)) else ident s l (*s Translating structure *) let proofbox () = printf "\\ensuremath{\\Box}" let rec reach_item_level n = if !item_level < n then begin printf "\n\\begin{itemize}\n\\item "; incr item_level; reach_item_level n end else if !item_level > n then begin printf "\n\\end{itemize}\n"; decr item_level; reach_item_level n end let item n = let old_level = !item_level in reach_item_level n; if n <= old_level then printf "\n\\item " let stop_item () = reach_item_level 0 let start_doc () = in_doc := true let end_doc () = in_doc := false; stop_item () (* This is broken if we are in math mode, but coqdoc currently isn't tracking that *) let start_emph () = printf "\\textit{" let stop_emph () = printf "}" let start_comment () = printf "\\begin{coqdoccomment}\n" let end_comment () = printf "\\end{coqdoccomment}\n" let start_coq () = printf "\\begin{coqdoccode}\n" let end_coq () = printf "\\end{coqdoccode}\n" let start_code () = end_doc (); start_coq () let end_code () = end_coq (); start_doc () let section_kind = function | 1 -> "\\section{" | 2 -> "\\subsection{" | 3 -> "\\subsubsection{" | 4 -> "\\paragraph{" | _ -> assert false let section lev f = stop_item (); output_string (section_kind lev); in_title := true; f (); in_title := false; printf "}\n\n" let rule () = printf "\\par\n\\noindent\\hrulefill\\par\n\\noindent{}" let paragraph () = printf "\n\n" let line_break () = printf "\\coqdoceol\n" let empty_line_of_code () = printf "\\coqdocemptyline\n" let start_inline_coq_block () = line_break (); empty_line_of_code () let end_inline_coq_block () = empty_line_of_code () let start_inline_coq () = () let end_inline_coq () = () let make_multi_index () = () let make_index () = () let make_toc () = printf "\\tableofcontents\n" end (*s HTML output *) module Html = struct let header () = if !header_trailer then if !header_file_spec then let cin = Pervasives.open_in !header_file in try while true do let s = Pervasives.input_line cin in printf "%s\n" s done with End_of_file -> Pervasives.close_in cin else begin printf "\n"; printf "\n\n"; printf "\n" !charset; printf "\n"; printf "%s\n\n\n" !page_title; printf "\n\n\n\n\n" end let start_module () = let ln = !lib_name in if not !short then begin let (m,sub) = !current_module in add_toc_entry (Toc_library (m,sub)); if ln = "" then printf "

%s

\n\n" (get_module true) else printf "

%s %s

\n\n" ln (get_module true) end let indentation n = for _i = 1 to n do printf " " done let line_break () = printf "
\n" let empty_line_of_code () = printf "\n
\n" let nbsp () = printf " " let char = function | '<' -> printf "<" | '>' -> printf ">" | '&' -> printf "&" | c -> output_char c let escaped = let buff = Buffer.create 5 in fun s -> Buffer.clear buff; for i = 0 to String.length s - 1 do match s.[i] with | '<' -> Buffer.add_string buff "<" | '>' -> Buffer.add_string buff ">" | '&' -> Buffer.add_string buff "&" | '\"' -> Buffer.add_string buff """ | c -> Buffer.add_char buff c done; Buffer.contents buff let sanitize_name s = let rec loop esc i = if i < 0 then if esc then escaped s else s else match s.[i] with | 'a'..'z' | 'A'..'Z' | '0'..'9' | '.' | '_' -> loop esc (i-1) | '<' | '>' | '&' | '\'' | '\"' -> loop true (i-1) | _ -> (* This name contains complex characters: this is probably a notation string, we simply hash it. *) Digest.to_hex (Digest.string s) in loop false (String.length s - 1) let latex_char _ = () let latex_string _ = () let html_char = output_char let html_string = output_string let start_latex_math () = () let stop_latex_math () = () let start_quote () = char '"' let stop_quote () = start_quote () let start_verbatim inline = if inline then printf "" else printf "
"

  let stop_verbatim inline = 
    if inline then printf "" 
    else printf "
\n" let url addr name = printf "%s" addr (match name with | Some n -> n | None -> addr) let ident_ref m fid typ s = match find_module m with | Local -> printf "" m (sanitize_name fid); printf "%s" typ s | External m when !externals -> printf "" m (sanitize_name fid); printf "%s" typ s | External _ | Unknown -> printf "%s" typ s let reference s r = match r with | Def (fullid,ty) -> printf "" (sanitize_name fullid); printf "%s" (type_name ty) s | Ref (m,fullid,ty) -> ident_ref m fullid (type_name ty) s let output_sublexer_string doescape issymbchar tag s = let s = if doescape then escaped s else s in match tag with | Some ref -> reference s ref | None -> if issymbchar then output_string s else printf "%s" s let sublexer c loc = let tag = try Some (Index.find (get_module false) loc) with Not_found -> None in Tokens.output_tagged_symbol_char tag c let sublexer_in_doc c = Tokens.output_tagged_symbol_char None c let initialize () = initialize_tex_html(); Tokens.token_tree := token_tree_html; Tokens.outfun := output_sublexer_string let translate s = match Tokens.translate s with Some s -> s | None -> escaped s let keyword s loc = printf "%s" (translate s) let ident s loc = if is_keyword s then begin printf "%s" (translate s) end else begin try match loc with | None -> raise Not_found | Some loc -> reference (translate s) (Index.find (get_module false) loc) with Not_found -> if is_tactic s then printf "%s" (translate s) else if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) then try reference (translate s) (Index.find_string (get_module false) s) with _ -> Tokens.output_tagged_ident_string s else Tokens.output_tagged_ident_string s end let proofbox () = printf "☐" let rec reach_item_level n = if !item_level < n then begin printf "
    \n
  • "; incr item_level; reach_item_level n end else if !item_level > n then begin printf "\n
    • \n
\n"; decr item_level; reach_item_level n end let item n = let old_level = !item_level in reach_item_level n; if n <= old_level then printf "\n\n
  • " let stop_item () = reach_item_level 0 let start_coq () = if not !raw_comments then printf "
    \n" let end_coq () = if not !raw_comments then printf "
    \n" let start_doc () = in_doc := true; if not !raw_comments then printf "\n
    \n" let end_doc () = in_doc := false; stop_item (); if not !raw_comments then printf "\n
    \n" let start_emph () = printf "" let stop_emph () = printf "" let start_comment () = printf "(*" let end_comment () = printf "*)" let start_code () = end_doc (); start_coq () let end_code () = end_coq (); start_doc () let start_inline_coq () = if !inline_notmono then printf "" else printf "" let end_inline_coq () = printf "" let start_inline_coq_block () = line_break (); start_inline_coq () let end_inline_coq_block () = end_inline_coq () let paragraph () = printf "\n
    \n\n" (* inference rules *) let inf_rule assumptions (_,_,midnm) conclusions = (* this first function replaces any occurance of 3 or more spaces in a row with " "s. We do this to the assumptions so that people can put multiple rules on a line with nice formatting *) let replace_spaces str = let rec copy a n = match n with 0 -> [] | n -> (a :: copy a (n - 1)) in let results = Str.full_split (Str.regexp "[' '][' '][' ']+") str in let strs = List.map (fun r -> match r with | Str.Text s -> [s] | Str.Delim s -> copy " " (String.length s)) results in String.concat "" (List.concat strs) in let start_assumption line = (printf "\n"; printf " %s\n" (replace_spaces line)) in let end_assumption () = (printf " \n"; printf "\n") in let rec print_assumptions hyps = match hyps with | [] -> start_assumption "  " | [(_,hyp)] -> start_assumption hyp | ((_,hyp) :: hyps') -> (start_assumption hyp; end_assumption (); print_assumptions hyps') in printf "
    \n"; print_assumptions assumptions; printf " " | Some s -> printf " %s  \n " s); printf "\n"; printf "\n"; printf " \n"; printf "\n"; print_assumptions conclusions; end_assumption (); printf "
    \n"; (match midnm with | None -> printf "  \n
    " let section lev f = let lab = new_label () in let r = sprintf "%s.html#%s" (get_module false) lab in (match !toc_depth with | None -> add_toc_entry (Toc_section (lev, f, r)) | Some n -> if lev <= n then add_toc_entry (Toc_section (lev, f, r)) else ()); stop_item (); printf "" lab lev; f (); printf "\n" lev let rule () = printf "
    \n" (* make a HTML index from a list of triples (name,text,link) *) let index_ref i c = let idxc = sprintf "%s_%c" i.idx_name c in !index_name ^ (if !multi_index then "_" ^ idxc ^ ".html" else ".html#" ^ idxc) let letter_index category idx (c,l) = if l <> [] then begin let cat = if category && idx <> "global" then "(" ^ idx ^ ")" else "" in printf "

    %s %s

    \n" idx c (display_letter c) cat; List.iter (fun (id,(text,link,t)) -> let id' = prepare_entry id t in printf "%s %s
    \n" link id' text) l; printf "

    " end let all_letters i = List.iter (letter_index false i.idx_name) i.idx_entries (* Construction d'une liste des index (1 index global, puis 1 index par catégorie) *) let format_global_index = Index.map (fun s (m,t) -> if t = Library then let ln = !lib_name in if ln <> "" then "[" ^ String.lowercase ln ^ "]", m ^ ".html", t else "[library]", m ^ ".html", t else sprintf "[%s, in %s]" (type_name t) m m , sprintf "%s.html#%s" m (sanitize_name s), t) let format_bytype_index = function | Library, idx -> Index.map (fun id m -> "", m ^ ".html", Library) idx | (t,idx) -> Index.map (fun s m -> let text = sprintf "[in %s]" m m in (text, sprintf "%s.html#%s" m (sanitize_name s), t)) idx (* Impression de la table d'index *) let print_index_table_item i = printf "\n%s Index\n" (String.capitalize i.idx_name); List.iter (fun (c,l) -> if l <> [] then printf "%s\n" (index_ref i c) (display_letter c) else printf "%s\n" (display_letter c)) i.idx_entries; let n = i.idx_size in printf "(%d %s)\n" n (if n > 1 then "entries" else "entry"); printf "\n" let print_index_table idxl = printf "\n"; List.iter print_index_table_item idxl; printf "
    \n" let make_one_multi_index prt_tbl i = (* Attn: make_one_multi_index crée un nouveau fichier... *) let idx = i.idx_name in let one_letter ((c,l) as cl) = open_out_file (sprintf "%s_%s_%c.html" !index_name idx c); if (!header_trailer) then header (); prt_tbl (); printf "
    "; letter_index true idx cl; if List.length l > 30 then begin printf "
    "; prt_tbl () end; if (!header_trailer) then trailer (); close_out_file () in List.iter one_letter i.idx_entries let make_multi_index () = let all_index = let glob,bt = Index.all_entries () in (format_global_index glob) :: (List.map format_bytype_index bt) in let print_table () = print_index_table all_index in List.iter (make_one_multi_index print_table) all_index let make_index () = let all_index = let glob,bt = Index.all_entries () in (format_global_index glob) :: (List.map format_bytype_index bt) in let print_table () = print_index_table all_index in let print_one_index i = if i.idx_size > 0 then begin printf "
    \n

    %s Index

    \n" (String.capitalize i.idx_name); all_letters i end in set_module "Index" None; if !title <> "" then printf "

    %s

    \n" !title; print_table (); if not (!multi_index) then begin List.iter print_one_index all_index; printf "
    "; print_table () end let make_toc () = let ln = !lib_name in let make_toc_entry = function | Toc_library (m,sub) -> stop_item (); let ms = match sub with | None -> m | Some s -> m ^ ": " ^ s in if ln = "" then printf "

    %s

    \n" m ms else printf "

    %s %s

    \n" m ln ms | Toc_section (n, f, r) -> item n; printf "" r; f (); printf "\n" in printf "
    \n"; Queue.iter make_toc_entry toc_q; stop_item (); printf "
    \n" end (*s TeXmacs-aware output *) module TeXmacs = struct (*s Latex preamble *) let (_ : string Queue.t) = in_doc := false; Queue.create () let header () = output_string "(*i This file has been automatically generated with the command \n"; output_string " "; Array.iter (fun s -> printf "%s " s) Sys.argv; printf " *)\n" let trailer () = () let nbsp () = output_char ' ' let char_true c = match c with | '\\' -> printf "\\\\" | '<' -> printf "\\<" | '|' -> printf "\\|" | '>' -> printf "\\>" | _ -> output_char c let char c = if !in_doc then char_true c else output_char c let latex_char = char_true let latex_string = String.iter latex_char let html_char _ = () let html_string _ = () let raw_ident s = for i = 0 to String.length s - 1 do char s.[i] done let start_module () = () let start_latex_math () = printf "' let start_verbatim inline = in_doc := true; printf "<\\verbatim>" let stop_verbatim inline = in_doc := false; printf "" let url addr name = printf "%s<\\footnote><\\url>%s" addr (match name with | None -> "" | Some n -> n) let start_quote () = output_char '`'; output_char '`' let stop_quote () = output_char '\''; output_char '\'' let indentation n = () let keyword s = printf "" let ident_true s = if is_keyword s then keyword s else raw_ident s let keyword s loc = keyword s let ident s _ = if !in_doc then ident_true s else raw_ident s let output_sublexer_string doescape issymbchar tag s = if doescape then raw_ident s else output_string s let sublexer c l = if !in_doc then Tokens.output_tagged_symbol_char None c else char c let sublexer_in_doc c = char c let initialize () = Tokens.token_tree := token_tree_texmacs; Tokens.outfun := output_sublexer_string let proofbox () = printf "QED" let rec reach_item_level n = if !item_level < n then begin printf "\n<\\itemize>\n"; incr item_level; reach_item_level n end else if !item_level > n then begin printf "\n"; decr item_level; reach_item_level n end let item n = let old_level = !item_level in reach_item_level n; if n <= old_level then printf "\n\n" let stop_item () = reach_item_level 0 let start_doc () = in_doc := true; printf "(** texmacs: " let end_doc () = stop_item (); in_doc := false; printf " *)" let start_coq () = () let end_coq () = () let start_emph () = printf "" let start_comment () = () let end_comment () = () let start_code () = in_doc := true; printf "<\\code>\n" let end_code () = in_doc := false; printf "\n" let section_kind = function | 1 -> "section" | 2 -> "subsection" | 3 -> "subsubsection" | 4 -> "paragraph" | _ -> assert false let section lev f = stop_item (); printf "<"; output_string (section_kind lev); printf "|"; f (); printf ">\n\n" let rule () = printf "\n\n" let paragraph () = printf "\n\n" let line_break () = printf "\n" let empty_line_of_code () = printf "\n" let start_inline_coq () = printf "" let start_inline_coq_block () = line_break (); start_inline_coq () let end_inline_coq_block () = end_inline_coq () let make_multi_index () = () let make_index () = () let make_toc () = () end (*s Raw output *) module Raw = struct let header () = () let trailer () = () let nbsp () = output_char ' ' let char = output_char let latex_char = output_char let latex_string = output_string let html_char _ = () let html_string _ = () let raw_ident s = for i = 0 to String.length s - 1 do char s.[i] done let start_module () = () let start_latex_math () = () let stop_latex_math () = () let start_verbatim inline = () let stop_verbatim inline = () let url addr name = match name with | Some n -> printf "%s (%s)" n addr | None -> printf "%s" addr let start_quote () = printf "\"" let stop_quote () = printf "\"" let indentation n = for _i = 1 to n do printf " " done let keyword s loc = raw_ident s let ident s loc = raw_ident s let sublexer c l = char c let sublexer_in_doc c = char c let initialize () = Tokens.token_tree := ref Tokens.empty_ttree; Tokens.outfun := (fun _ _ _ _ -> failwith "Useless") let proofbox () = printf "[]" let item n = printf "- " let stop_item () = () let reach_item_level _ = () let start_doc () = printf "(** " let end_doc () = printf " *)\n" let start_emph () = printf "_" let stop_emph () = printf "_" let start_comment () = printf "(*" let end_comment () = printf "*)" let start_coq () = () let end_coq () = () let start_code () = end_doc (); start_coq () let end_code () = end_coq (); start_doc () let section_kind = function | 1 -> "* " | 2 -> "** " | 3 -> "*** " | 4 -> "**** " | _ -> assert false let section lev f = output_string (section_kind lev); f () let rule () = () let paragraph () = printf "\n\n" let line_break () = printf "\n" let empty_line_of_code () = printf "\n" let start_inline_coq () = () let end_inline_coq () = () let start_inline_coq_block () = line_break (); start_inline_coq () let end_inline_coq_block () = end_inline_coq () let make_multi_index () = () let make_index () = () let make_toc () = () end (*s Generic output *) let select f1 f2 f3 f4 x = match !target_language with LaTeX -> f1 x | HTML -> f2 x | TeXmacs -> f3 x | Raw -> f4 x let push_in_preamble = Latex.push_in_preamble let header = select Latex.header Html.header TeXmacs.header Raw.header let trailer = select Latex.trailer Html.trailer TeXmacs.trailer Raw.trailer let start_module = select Latex.start_module Html.start_module TeXmacs.start_module Raw.start_module let start_doc = select Latex.start_doc Html.start_doc TeXmacs.start_doc Raw.start_doc let end_doc = select Latex.end_doc Html.end_doc TeXmacs.end_doc Raw.end_doc let start_comment = select Latex.start_comment Html.start_comment TeXmacs.start_comment Raw.start_comment let end_comment = select Latex.end_comment Html.end_comment TeXmacs.end_comment Raw.end_comment let start_coq = select Latex.start_coq Html.start_coq TeXmacs.start_coq Raw.start_coq let end_coq = select Latex.end_coq Html.end_coq TeXmacs.end_coq Raw.end_coq let start_code = select Latex.start_code Html.start_code TeXmacs.start_code Raw.start_code let end_code = select Latex.end_code Html.end_code TeXmacs.end_code Raw.end_code let start_inline_coq = select Latex.start_inline_coq Html.start_inline_coq TeXmacs.start_inline_coq Raw.start_inline_coq let end_inline_coq = select Latex.end_inline_coq Html.end_inline_coq TeXmacs.end_inline_coq Raw.end_inline_coq let start_inline_coq_block = select Latex.start_inline_coq_block Html.start_inline_coq_block TeXmacs.start_inline_coq_block Raw.start_inline_coq_block let end_inline_coq_block = select Latex.end_inline_coq_block Html.end_inline_coq_block TeXmacs.end_inline_coq_block Raw.end_inline_coq_block let indentation = select Latex.indentation Html.indentation TeXmacs.indentation Raw.indentation let paragraph = select Latex.paragraph Html.paragraph TeXmacs.paragraph Raw.paragraph let line_break = select Latex.line_break Html.line_break TeXmacs.line_break Raw.line_break let empty_line_of_code = select Latex.empty_line_of_code Html.empty_line_of_code TeXmacs.empty_line_of_code Raw.empty_line_of_code let section = select Latex.section Html.section TeXmacs.section Raw.section let item = select Latex.item Html.item TeXmacs.item Raw.item let stop_item = select Latex.stop_item Html.stop_item TeXmacs.stop_item Raw.stop_item let reach_item_level = select Latex.reach_item_level Html.reach_item_level TeXmacs.reach_item_level Raw.reach_item_level let rule = select Latex.rule Html.rule TeXmacs.rule Raw.rule let nbsp = select Latex.nbsp Html.nbsp TeXmacs.nbsp Raw.nbsp let char = select Latex.char Html.char TeXmacs.char Raw.char let keyword = select Latex.keyword Html.keyword TeXmacs.keyword Raw.keyword let ident = select Latex.ident Html.ident TeXmacs.ident Raw.ident let sublexer = select Latex.sublexer Html.sublexer TeXmacs.sublexer Raw.sublexer let sublexer_in_doc = select Latex.sublexer_in_doc Html.sublexer_in_doc TeXmacs.sublexer_in_doc Raw.sublexer_in_doc let initialize = select Latex.initialize Html.initialize TeXmacs.initialize Raw.initialize let proofbox = select Latex.proofbox Html.proofbox TeXmacs.proofbox Raw.proofbox let latex_char = select Latex.latex_char Html.latex_char TeXmacs.latex_char Raw.latex_char let latex_string = select Latex.latex_string Html.latex_string TeXmacs.latex_string Raw.latex_string let html_char = select Latex.html_char Html.html_char TeXmacs.html_char Raw.html_char let html_string = select Latex.html_string Html.html_string TeXmacs.html_string Raw.html_string let start_emph = select Latex.start_emph Html.start_emph TeXmacs.start_emph Raw.start_emph let stop_emph = select Latex.stop_emph Html.stop_emph TeXmacs.stop_emph Raw.stop_emph let start_latex_math = select Latex.start_latex_math Html.start_latex_math TeXmacs.start_latex_math Raw.start_latex_math let stop_latex_math = select Latex.stop_latex_math Html.stop_latex_math TeXmacs.stop_latex_math Raw.stop_latex_math let start_verbatim = select Latex.start_verbatim Html.start_verbatim TeXmacs.start_verbatim Raw.start_verbatim let stop_verbatim = select Latex.stop_verbatim Html.stop_verbatim TeXmacs.stop_verbatim Raw.stop_verbatim let verbatim_char inline = select (if inline then Latex.char else output_char) Html.char TeXmacs.char Raw.char let hard_verbatim_char = output_char let url = select Latex.url Html.url TeXmacs.url Raw.url let start_quote = select Latex.start_quote Html.start_quote TeXmacs.start_quote Raw.start_quote let stop_quote = select Latex.stop_quote Html.stop_quote TeXmacs.stop_quote Raw.stop_quote let inf_rule_dumb assumptions (midsp,midln,midnm) conclusions = start_verbatim false; let dumb_line = function (sp,ln) -> (String.iter char ((String.make sp ' ') ^ ln); char '\n') in (List.iter dumb_line assumptions; dumb_line (midsp, midln ^ (match midnm with | Some s -> " " ^ s | None -> "")); List.iter dumb_line conclusions); stop_verbatim false let inf_rule = select inf_rule_dumb Html.inf_rule inf_rule_dumb inf_rule_dumb let make_multi_index = select Latex.make_multi_index Html.make_multi_index TeXmacs.make_multi_index Raw.make_multi_index let make_index = select Latex.make_index Html.make_index TeXmacs.make_index Raw.make_index let make_toc = select Latex.make_toc Html.make_toc TeXmacs.make_toc Raw.make_toc coq-8.6/tools/coqdoc/cpretty.mli0000644000175000017500000000121213022274260016260 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Cdglobals.coq_module -> unit val detect_subtitle : string -> Cdglobals.coq_module -> string option coq-8.6/tools/coqdoc/style.css0000644000175000017500000000201313022274260015735 0ustar mdenesmdenesa:visited {color : #416DFF; text-decoration : none; } a:link {color : #416DFF; text-decoration : none; font-weight : bold} a:hover {color : Red; text-decoration : underline; } a:active {color : Red; text-decoration : underline; } .keyword { font-weight : bold ; color : Red } .keywordsign { color : #C04600 } .superscript { font-size : 4 } .subscript { font-size : 4 } .comment { color : Green } .constructor { color : Blue } .string { color : Maroon } .warning { color : Red ; font-weight : bold } .info { margin-left : 3em; margin-right : 3em } .title1 { font-size : 20pt ; background-color : #416DFF } .title2 { font-size : 20pt ; background-color : #418DFF } .title3 { font-size : 20pt ; background-color : #41ADFF } .title4 { font-size : 20pt ; background-color : #41CDFF } .title5 { font-size : 20pt ; background-color : #41EDFF } .title6 { font-size : 20pt ; background-color : #41FFFF } body { background-color : White } tr { background-color : White } # .doc { background-color :#aaeeff } .doc { background-color :#66ff66 } coq-8.6/tools/coqdoc/alpha.ml0000644000175000017500000000303013022274260015502 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'A' | '\199' -> 'C' | '\200'..'\203' -> 'E' | '\204'..'\207' -> 'I' | '\209' -> 'N' | '\210'..'\214' -> 'O' | '\217'..'\220' -> 'U' | '\221' -> 'Y' | c -> c let norm_char_utf8 c = Char.uppercase c let norm_char c = if !utf8 then norm_char_utf8 c else if !latin1 then norm_char_latin1 c else Char.uppercase c let norm_string s = let u = String.copy s in for i = 0 to String.length s - 1 do u.[i] <- norm_char s.[i] done; u let compare_char c1 c2 = match norm_char c1, norm_char c2 with | ('A'..'Z' as c1), ('A'..'Z' as c2) -> compare c1 c2 | 'A'..'Z', _ -> -1 | _, 'A'..'Z' -> 1 | '_', _ -> -1 | _, '_' -> 1 | c1, c2 -> compare c1 c2 let compare_string s1 s2 = let n1 = String.length s1 in let n2 = String.length s2 in let rec cmp i = if i == n1 || i == n2 then n1 - n2 else let c = compare_char s1.[i] s2.[i] in if c == 0 then cmp (succ i) else c in cmp 0 coq-8.6/tools/coqdoc/coqdoc.css0000644000175000017500000001356513022274260016063 0ustar mdenesmdenesbody { padding: 0px 0px; margin: 0px 0px; background-color: white } #page { display: block; padding: 0px; margin: 0px; padding-bottom: 10px; } #header { display: block; position: relative; padding: 0; margin: 0; vertical-align: middle; border-bottom-style: solid; border-width: thin } #header h1 { padding: 0; margin: 0;} /* Contents */ #main{ display: block; padding: 10px; font-family: sans-serif; font-size: 100%; line-height: 100% } #main h1 { line-height: 95% } /* allow for multi-line headers */ #main a.idref:visited {color : #416DFF; text-decoration : none; } #main a.idref:link {color : #416DFF; text-decoration : none; } #main a.idref:hover {text-decoration : none; } #main a.idref:active {text-decoration : none; } #main a.modref:visited {color : #416DFF; text-decoration : none; } #main a.modref:link {color : #416DFF; text-decoration : none; } #main a.modref:hover {text-decoration : none; } #main a.modref:active {text-decoration : none; } #main .keyword { color : #cf1d1d } #main { color: black } .section { background-color: rgb(60%,60%,100%); padding-top: 13px; padding-bottom: 13px; padding-left: 3px; margin-top: 5px; margin-bottom: 5px; font-size : 175% } h2.section { background-color: rgb(80%,80%,100%); padding-left: 3px; padding-top: 12px; padding-bottom: 10px; font-size : 130% } h3.section { background-color: rgb(90%,90%,100%); padding-left: 3px; padding-top: 7px; padding-bottom: 7px; font-size : 115% } h4.section { /* background-color: rgb(80%,80%,80%); max-width: 20em; padding-left: 5px; padding-top: 5px; padding-bottom: 5px; */ background-color: white; padding-left: 0px; padding-top: 0px; padding-bottom: 0px; font-size : 100%; font-weight : bold; text-decoration : underline; } #main .doc { margin: 0px; font-family: sans-serif; font-size: 100%; line-height: 125%; max-width: 40em; color: black; padding: 10px; background-color: #90bdff } .inlinecode { display: inline; /* font-size: 125%; */ color: #666666; font-family: monospace } .doc .inlinecode { display: inline; font-size: 120%; color: rgb(30%,30%,70%); font-family: monospace } .doc .inlinecode .id { color: rgb(30%,30%,70%); } .inlinecodenm { display: inline; color: #444444; } .doc .code { display: inline; font-size: 120%; color: rgb(30%,30%,70%); font-family: monospace } .comment { display: inline; font-family: monospace; color: rgb(50%,50%,80%); } .code { display: block; /* padding-left: 15px; */ font-size: 110%; font-family: monospace; } table.infrule { border: 0px; margin-left: 50px; margin-top: 10px; margin-bottom: 10px; } td.infrule { font-family: monospace; text-align: center; /* color: rgb(35%,35%,70%); */ padding: 0px; line-height: 100%; } tr.infrulemiddle hr { margin: 1px 0 1px 0; } .infrulenamecol { color: rgb(60%,60%,60%); font-size: 80%; padding-left: 1em; padding-bottom: 0.1em } /* Pied de page */ #footer { font-size: 65%; font-family: sans-serif; } /* Identifiers: ) */ .id { display: inline; } .id[title="constructor"] { color: rgb(60%,0%,0%); } .id[title="var"] { color: rgb(40%,0%,40%); } .id[title="variable"] { color: rgb(40%,0%,40%); } .id[title="definition"] { color: rgb(0%,40%,0%); } .id[title="abbreviation"] { color: rgb(0%,40%,0%); } .id[title="lemma"] { color: rgb(0%,40%,0%); } .id[title="instance"] { color: rgb(0%,40%,0%); } .id[title="projection"] { color: rgb(0%,40%,0%); } .id[title="method"] { color: rgb(0%,40%,0%); } .id[title="inductive"] { color: rgb(0%,0%,80%); } .id[title="record"] { color: rgb(0%,0%,80%); } .id[title="class"] { color: rgb(0%,0%,80%); } .id[title="keyword"] { color : #cf1d1d; /* color: black; */ } /* Deprecated rules using the 'type' attribute of (not xhtml valid) */ .id[type="constructor"] { color: rgb(60%,0%,0%); } .id[type="var"] { color: rgb(40%,0%,40%); } .id[type="variable"] { color: rgb(40%,0%,40%); } .id[type="definition"] { color: rgb(0%,40%,0%); } .id[type="abbreviation"] { color: rgb(0%,40%,0%); } .id[type="lemma"] { color: rgb(0%,40%,0%); } .id[type="instance"] { color: rgb(0%,40%,0%); } .id[type="projection"] { color: rgb(0%,40%,0%); } .id[type="method"] { color: rgb(0%,40%,0%); } .id[type="inductive"] { color: rgb(0%,0%,80%); } .id[type="record"] { color: rgb(0%,0%,80%); } .id[type="class"] { color: rgb(0%,0%,80%); } .id[type="keyword"] { color : #cf1d1d; /* color: black; */ } .inlinecode .id { color: rgb(0%,0%,0%); } /* TOC */ #toc h2 { padding: 10px; background-color: rgb(60%,60%,100%); } #toc li { padding-bottom: 8px; } /* Index */ #index { margin: 0; padding: 0; width: 100%; } #index #frontispiece { margin: 1em auto; padding: 1em; width: 60%; } .booktitle { font-size : 140% } .authors { font-size : 90%; line-height: 115%; } .moreauthors { font-size : 60% } #index #entrance { text-align: center; } #index #entrance .spacer { margin: 0 30px 0 30px; } #index #footer { position: absolute; bottom: 0; } .paragraph { height: 0.75em; } ul.doclist { margin-top: 0em; margin-bottom: 0em; } coq-8.6/tools/coqdoc/tokens.mli0000644000175000017500000000616013022274260016100 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string -> string -> ttree (* Remove a translation from a dictionary: returns an equal dictionary if the word not present *) val ttree_remove : ttree -> string -> ttree (* Translate a string *) val translate : string -> string option (* Sublexer automaton *) (* The sublexer buffers the chars it receives; if after some time, it recognizes that a sequence of chars has a translation in the current dictionary, it replaces the buffer by the translation *) (* Received chars can come with a "tag" (usually made from informations from the globalization file). A sequence of chars can be considered a word only, if all chars have the same "tag". Rules for cutting words are the following: - in a sequence like "**" where * is in the dictionary but not **, "**" is not translated; otherwise said, to be translated, a sequence must not be surrounded by other symbol-like chars - in a sequence like "<>_h*", where <>_h is in the dictionary, the translation is done because the switch from a letter to a symbol char is an acceptable cutting point - in a sequence like "<>_ha", where <>_h is in the dictionary, the translation is not done because it is considered that h and a are not separable (however, if h and a have different tags, and h has the same tags as <, > and _, the translation happens) - in a sequence like "<>_ha", where <> but not <>_h is in the dictionary, the translation is done for <> and _ha is considered independently because the switch from a symbol char to a letter is considered to be an acceptable cutting point - the longest-word rule applies: if both <> and <>_h are in the dictionary, "<>_h" is one word and gets translated *) (* Warning: do not output anything on output channel inbetween a call to [output_tagged_*] and [flush_sublexer]!! *) type out_function = bool (* needs escape *) -> bool (* it is a symbol, not a pure ident *) -> Index.index_entry option (* the index type of the token if any *) -> string -> unit (* This must be initialized before calling the sublexer *) val token_tree : ttree ref ref val outfun : out_function ref (* Process an ident part that might be a symbol part *) val output_tagged_ident_string : string -> unit (* Process a non-ident char (possibly equipped with a tag) *) val output_tagged_symbol_char : Index.index_entry option -> char -> unit (* Flush the buffered content of the lexer using [outfun] *) val flush_sublexer : unit -> unit coq-8.6/tools/coqdoc/index.mli0000644000175000017500000000363713022274260015712 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string type index_entry = | Def of string * entry_type | Ref of coq_module * string * entry_type (* Find what symbol coqtop said is located at loc in the source file *) val find : coq_module -> loc -> index_entry (* Find what data is referred to by some string in some coq module *) val find_string : coq_module -> string -> index_entry val add_module : coq_module -> unit type module_kind = Local | External of coq_module | Unknown val find_module : coq_module -> module_kind val init_coqlib_library : unit -> unit val add_external_library : string -> coq_module -> unit (*s Read globalizations from a file (produced by coqc -dump-glob) *) val read_glob : Digest.t option -> string -> unit (*s Indexes *) type 'a index = { idx_name : string; idx_entries : (char * (string * 'a) list) list; idx_size : int } val current_library : string ref val display_letter : char -> string val prepare_entry : string -> entry_type -> string val all_entries : unit -> (coq_module * entry_type) index * (entry_type * coq_module index) list val map : (string -> 'a -> 'b) -> 'a index -> 'b index coq-8.6/tools/coqdoc/output.mli0000644000175000017500000000612013022274260016131 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val add_printing_token : string -> string option * string option -> unit val remove_printing_token : string -> unit val set_module : coq_module -> string option -> unit val get_module : bool -> string val header : unit -> unit val trailer : unit -> unit val push_in_preamble : string -> unit val start_module : unit -> unit val start_doc : unit -> unit val end_doc : unit -> unit val start_emph : unit -> unit val stop_emph : unit -> unit val start_comment : unit -> unit val end_comment : unit -> unit val start_coq : unit -> unit val end_coq : unit -> unit val start_code : unit -> unit val end_code : unit -> unit val start_inline_coq : unit -> unit val end_inline_coq : unit -> unit val start_inline_coq_block : unit -> unit val end_inline_coq_block : unit -> unit val indentation : int -> unit val line_break : unit -> unit val paragraph : unit -> unit val empty_line_of_code : unit -> unit val section : int -> (unit -> unit) -> unit val item : int -> unit val stop_item : unit -> unit val reach_item_level : int -> unit val rule : unit -> unit val nbsp : unit -> unit val char : char -> unit val keyword : string -> loc -> unit val ident : string -> loc option -> unit val sublexer : char -> loc -> unit val sublexer_in_doc : char -> unit val initialize : unit -> unit val proofbox : unit -> unit val latex_char : char -> unit val latex_string : string -> unit val html_char : char -> unit val html_string : string -> unit val verbatim_char : bool -> char -> unit val hard_verbatim_char : char -> unit val start_latex_math : unit -> unit val stop_latex_math : unit -> unit val start_verbatim : bool -> unit val stop_verbatim : bool -> unit val start_quote : unit -> unit val stop_quote : unit -> unit val url : string -> string option -> unit (* this outputs an inference rule in one go. You pass it the list of assumptions, then the middle line info, then the conclusion (which is allowed to span multiple lines). In each case, the int is the number of spaces before the start of the line's text and the string is the text of the line with the leading trailing space trimmed. For the middle rule, you can also optionally provide a name. We need the space info so that in modes where we aren't doing something smart we can just format the rule verbatim like the user did *) val inf_rule : (int * string) list -> (int * string * (string option)) -> (int * string) list -> unit val make_multi_index : unit -> unit val make_index : unit -> unit val make_toc : unit -> unit coq-8.6/tools/coqdoc/tokens.ml0000644000175000017500000001311313022274260015723 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* None with | Some tt' -> CharMap.add c (insert tt' (i + 1)) (CharMap.remove c tt.branch) | None -> let tt' = {node = None; branch = CharMap.empty} in CharMap.add c (insert tt' (i + 1)) tt.branch in { node = tt.node; branch = br } in insert ttree 0 (* Removes a string from a dictionary: returns an equal dictionary if the word not present. *) let ttree_remove ttree str = let rec remove tt i = if i == String.length str then {node = None; branch = tt.branch} else let c = str.[i] in let br = match try Some (CharMap.find c tt.branch) with Not_found -> None with | Some tt' -> CharMap.add c (remove tt' (i + 1)) (CharMap.remove c tt.branch) | None -> tt.branch in { node = tt.node; branch = br } in remove ttree 0 let ttree_descend ttree c = CharMap.find c ttree.branch let ttree_find ttree str = let rec proc_rec tt i = if i == String.length str then tt else proc_rec (CharMap.find str.[i] tt.branch) (i+1) in proc_rec ttree 0 (*s Parameters of the translation automaton *) type out_function = bool -> bool -> Index.index_entry option -> string -> unit let token_tree = ref (ref empty_ttree) let outfun = ref (fun _ _ _ _ -> failwith "outfun not initialized") (*s Translation automaton *) let buff = Buffer.create 4 let flush_buffer was_symbolchar tag tok = let hastr = String.length tok <> 0 in if hastr then !outfun false was_symbolchar tag tok; if Buffer.length buff <> 0 then !outfun true (if hastr then not was_symbolchar else was_symbolchar) tag (Buffer.contents buff); Buffer.clear buff type sublexer_state = | Neutral | Buffering of bool * Index.index_entry option * string * ttree let translation_state = ref Neutral let buffer_char is_symbolchar ctag c = let rec aux = function | Neutral -> restart_buffering () | Buffering (was_symbolchar,tag,translated,tt) -> if tag <> ctag then (* A strong tag comes from Coq; if different Coq tags *) (* hence, we don't try to see the chars as part of a single token *) let translated = match tt.node with | Some tok -> Buffer.clear buff; tok | None -> translated in flush_buffer was_symbolchar tag translated; restart_buffering () else begin (* If we change the category of characters (symbol vs ident) *) (* we accept this as a possible token cut point and remember the *) (* translated token up to that point *) let translated = if is_symbolchar <> was_symbolchar then match tt.node with | Some tok -> Buffer.clear buff; tok | None -> translated else translated in (* We try to make a significant token from the current *) (* buffer and the new character *) try let tt = ttree_descend tt c in Buffer.add_char buff c; Buffering (is_symbolchar,ctag,translated,tt) with Not_found -> (* No existing translation for the given set of chars *) if is_symbolchar <> was_symbolchar then (* If we changed the category of character read, we accept it *) (* as a possible cut point and restart looking for a translation *) (flush_buffer was_symbolchar tag translated; restart_buffering ()) else (* If we did not change the category of character read, we do *) (* not want to cut arbitrarily in the middle of the sequence of *) (* symbol characters or identifier characters *) (Buffer.add_char buff c; Buffering (is_symbolchar,tag,translated,empty_ttree)) end and restart_buffering () = let tt = try ttree_descend !(!token_tree) c with Not_found -> empty_ttree in Buffer.add_char buff c; Buffering (is_symbolchar,ctag,"",tt) in translation_state := aux !translation_state let output_tagged_ident_string s = for i = 0 to String.length s - 1 do buffer_char false None s.[i] done let output_tagged_symbol_char tag c = buffer_char true tag c let flush_sublexer () = match !translation_state with | Neutral -> () | Buffering (was_symbolchar,tag,translated,tt) -> let translated = match tt.node with | Some tok -> Buffer.clear buff; tok | None -> translated in flush_buffer was_symbolchar tag translated; translation_state := Neutral (* Translation not using the automaton *) let translate s = try (ttree_find !(!token_tree) s).node with Not_found -> None coq-8.6/tools/coqdoc/alpha.mli0000644000175000017500000000133513022274260015661 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* char -> int val compare_string : string -> string -> int (* Alphabetic normalization. *) val norm_char : char -> char val norm_string : string -> string coq-8.6/tools/ocamllibdep.mll0000644000175000017500000001645213022274260015610 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Buffer.clear s'; for i = 0 to String.length s - 1 do let c = s.[i] in if c = ' ' || c = '#' || c = ':' (* separators and comments *) || c = '%' (* pattern *) || c = '?' || c = '[' || c = ']' || c = '*' (* expansion in filenames *) || i=0 && c = '~' && (String.length s = 1 || s.[1] = '/' || 'A' <= s.[1] && s.[1] <= 'Z' || 'a' <= s.[1] && s.[1] <= 'z') (* homedir expansion *) then begin let j = ref (i-1) in while !j >= 0 && s.[!j] = '\\' do Buffer.add_char s' '\\'; decr j (* escape all preceding '\' *) done; Buffer.add_char s' '\\'; end; if c = '$' then Buffer.add_char s' '$'; Buffer.add_char s' c done; Buffer.contents s' (* Filename.concat but always with a '/' *) let is_dir_sep s i = match Sys.os_type with | "Unix" -> s.[i] = '/' | "Cygwin" | "Win32" -> let c = s.[i] in c = '/' || c = '\\' || c = ':' | _ -> assert false let (//) dirname filename = let l = String.length dirname in if l = 0 || is_dir_sep dirname (l-1) then dirname ^ filename else dirname ^ "/" ^ filename (** [get_extension f l] checks whether [f] has one of the extensions listed in [l]. It returns [f] without its extension, alongside with the extension. When no extension match, [(f,"")] is returned *) let rec get_extension f = function | [] -> (f, "") | s :: _ when Filename.check_suffix f s -> (Filename.chop_suffix f s, s) | _ :: l -> get_extension f l let file_name s = function | None -> s | Some "." -> s | Some d -> d // s type dir = string option let add_directory add_file phys_dir = Array.iter (fun f -> (* we avoid all files starting by '.' *) if f.[0] <> '.' then let phys_f = if phys_dir = "." then f else phys_dir//f in match try (stat phys_f).st_kind with _ -> S_BLK with | S_REG -> add_file phys_dir f | _ -> ()) (Sys.readdir phys_dir) let error_cannot_parse s (i,j) = Printf.eprintf "File \"%s\", characters %i-%i: Syntax error\n" s i j; exit 1 let warning_ml_clash x s suff s' suff' = if suff = suff' then eprintf "*** Warning: %s%s already found in %s (discarding %s%s)\n" x suff (match s with None -> "." | Some d -> d) ((match s' with None -> "." | Some d -> d) // x) suff let mkknown () = let h = (Hashtbl.create 19 : (string, dir * string) Hashtbl.t) in let add x s suff = try let s',suff' = Hashtbl.find h x in warning_ml_clash x s' suff' s suff with Not_found -> Hashtbl.add h x (s,suff) and search x = try Some (fst (Hashtbl.find h x)) with Not_found -> None in add, search let add_ml_known, search_ml_known = mkknown () let add_mlpack_known, search_mlpack_known = mkknown () let mllibAccu = ref ([] : (string * dir) list) let mlpackAccu = ref ([] : (string * dir) list) let add_caml_known phys_dir f = let basename,suff = get_extension f [".ml";".ml4";".mlpack"] in match suff with | ".ml"|".ml4" -> add_ml_known basename (Some phys_dir) suff | ".mlpack" -> add_mlpack_known basename (Some phys_dir) suff | _ -> () let add_caml_dir phys_dir = handle_unix_error (add_directory add_caml_known) phys_dir let traite_fichier_modules md ext = try let chan = open_in (md ^ ext) in let list = mllib_list (Lexing.from_channel chan) in List.fold_left (fun acc str -> match search_mlpack_known str with | Some mldir -> (file_name str mldir) :: acc | None -> match search_ml_known str with | Some mldir -> (file_name str mldir) :: acc | None -> acc) [] (List.rev list) with | Sys_error _ -> [] | Syntax_error (i,j) -> error_cannot_parse (md^ext) (i,j) let addQueue q v = q := v :: !q let treat_file old_name = let name = Filename.basename old_name in let dirname = Some (Filename.dirname old_name) in match get_extension name [".mllib";".mlpack"] with | (base,".mllib") -> addQueue mllibAccu (base,dirname) | (base,".mlpack") -> addQueue mlpackAccu (base,dirname) | _ -> () let mllib_dependencies () = List.iter (fun (name,dirname) -> let fullname = file_name name dirname in let deps = traite_fichier_modules fullname ".mllib" in let sdeps = String.concat " " deps in let efullname = escape fullname in printf "%s_MLLIB_DEPENDENCIES:=%s\n" efullname sdeps; printf "%s.cma:$(addsuffix .cmo,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname; printf "%s.cmxa:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname; flush Pervasives.stdout) (List.rev !mllibAccu) let mlpack_dependencies () = List.iter (fun (name,dirname) -> let fullname = file_name name dirname in let modname = String.capitalize name in let deps = traite_fichier_modules fullname ".mlpack" in let sdeps = String.concat " " deps in let efullname = escape fullname in printf "%s_MLPACK_DEPENDENCIES:=%s\n" efullname sdeps; List.iter (fun d -> printf "%s_FORPACK:= -for-pack %s\n" d modname) deps; printf "%s.cmo:$(addsuffix .cmo,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname; printf "%s.cmx:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname; flush Pervasives.stdout) (List.rev !mlpackAccu) let rec parse = function | "-I" :: r :: ll -> (* To solve conflict (e.g. same filename in kernel and checker) we allow to state an explicit order *) add_caml_dir r; parse ll | f :: ll -> treat_file f; parse ll | [] -> () let main () = if Array.length Sys.argv < 2 then exit 1; parse (List.tl (Array.to_list Sys.argv)); mllib_dependencies (); mlpack_dependencies () let _ = Printexc.catch main () } coq-8.6/tools/coq_tex.ml0000644000175000017500000002342513022274260014621 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (* a dummy command, just in case the last line was a comment *) output_string chan_out "Set Printing Width 78.\n"; close_in chan_in; close_out chan_out (* Second pass: insert the answers of Coq from [coq_output] into the * TeX file [texfile]. The result goes in file [result]. *) let tex_escaped s = let delims = Str.regexp "[_{}&%#$\\^~ <>'`]" in let adapt_delim = function | "{" | "}" | "&" | "%" | "#" | "$" as c -> "\\"^c | "_" -> "{\\char`\\_}" | "\\" -> "{\\char'134}" | "^" -> "{\\char'136}" | "~" -> "{\\char'176}" | " " -> "~" | "<" -> "{<}" | ">" -> "{>}" | "'" -> "{\\textquotesingle}" | "`" -> "\\`{}" | _ -> assert false in let adapt = function | Str.Text s -> s | Str.Delim s -> adapt_delim s in String.concat "" (List.map adapt (Str.full_split delims s)) let encapsule sl c_out s = if sl then Printf.fprintf c_out "\\texttt{\\textit{%s}}\\\\\n" (tex_escaped s) else Printf.fprintf c_out "\\texttt{%s}\\\\\n" (tex_escaped s) let print_block c_out bl = List.iter (fun s -> if s="" then () else encapsule !slanted c_out s) bl let insert texfile coq_output result = let c_tex = open_in texfile in let c_coq = open_in coq_output in let c_out = open_out result in (* read lines until a prompt is found (starting from the second line), purge prompts on the first line and return their number *) let last_read = ref (input_line c_coq) in let read_output () = let first = !last_read in let nb = ref 0 in (* remove the leading prompts *) let rec skip_prompts pos = if Str.string_match any_prompt first pos then let () = incr nb in skip_prompts (Str.match_end ()) else pos in let first = let start = skip_prompts 0 in String.sub first start (String.length first - start) in (* read and return the following lines until a prompt is found *) let rec read_lines () = let s = input_line c_coq in if Str.string_match any_prompt s 0 then begin last_read := s; [] end else s :: read_lines () in (first :: read_lines (), !nb) in let unhandled_output = ref None in let read_output () = match !unhandled_output with | Some some -> unhandled_output := None; some | None -> read_output () in (* we are inside a \begin{coq_...} ... \end{coq_...} block * show_... tell what kind of block it is *) let rec inside show_answers show_questions not_first discarded = let s = input_line c_tex in if s = "" then inside show_answers show_questions not_first (discarded + 1) else if not (Str.string_match end_coq s 0) then begin let (bl,n) = read_output () in assert (n > discarded); let n = n - discarded in if not_first then output_string c_out "\\medskip\n"; if !verbose then Printf.printf "Coq < %s\n" s; if show_questions then encapsule false c_out ("Coq < " ^ s); let rec read_lines k = if k = 0 then [] else let s = input_line c_tex in if Str.string_match end_coq s 0 then [] else s :: read_lines (k - 1) in let al = read_lines (n - 1) in if !verbose then List.iter (Printf.printf " %s\n") al; if show_questions then List.iter (fun s -> encapsule false c_out (" " ^ s)) al; let la = n - 1 - List.length al in if la <> 0 then (* this happens when the block ends with a comment; the output is for the command at the beginning of the next block *) unhandled_output := Some (bl, la) else begin if !verbose then List.iter print_endline bl; if show_answers then print_block c_out bl; inside show_answers show_questions (show_answers || show_questions) 0 end end else if discarded > 0 then begin (* this happens when the block ends with an empty line *) let (bl,n) = read_output () in assert (n > discarded); unhandled_output := Some (bl, n - discarded) end in (* we are outside of a \begin{coq_...} ... \end{coq_...} block *) let rec outside just_after = let start_block () = if !small then output_string c_out "\\begin{small}\n"; output_string c_out "\\begin{flushleft}\n"; if !hrule then output_string c_out "\\hrulefill\\\\\n" in let end_block () = if !hrule then output_string c_out "\\hrulefill\\\\\n"; output_string c_out "\\end{flushleft}\n"; if !small then output_string c_out "\\end{small}\n" in let s = input_line c_tex in if Str.string_match begin_coq s 0 then begin let kind = Str.matched_group 1 s in if kind = "eval" then begin if just_after then end_block (); inside false false false 0; outside false end else begin let show_answers = kind <> "example*" in let show_questions = kind <> "example#" in if not just_after then start_block (); inside show_answers show_questions just_after 0; outside true end end else begin if just_after then end_block (); output_string c_out (s ^ "\n"); outside false end in try let _ = read_output () in (* to skip the Coq banner *) let _ = read_output () in (* to skip the Coq answer to Set Printing Width *) outside false with End_of_file -> begin close_in c_tex; close_in c_coq; close_out c_out end (* Process of one TeX file *) let rm f = try Sys.remove f with _ -> () let one_file texfile = let inputv = Filename.temp_file "coq_tex" ".v" in let coq_output = Filename.temp_file "coq_tex" ".coq_output"in let result = if !output_specified then !output else if Filename.check_suffix texfile ".tex" then (Filename.chop_suffix texfile ".tex") ^ ".v.tex" else texfile ^ ".v.tex" in try (* 1. extract Coq phrases *) extract texfile inputv; (* 2. run Coq on input *) let _ = Sys.command (Printf.sprintf "%s < %s > %s 2>&1" !image inputv coq_output) in (* 3. insert Coq output into original file *) insert texfile coq_output result; (* 4. clean up *) rm inputv; rm coq_output with reraise -> begin rm inputv; rm coq_output; raise reraise end (* Parsing of the command line, check of the Coq command and process * of all the files in the command line, one by one *) let files = ref [] let parse_cl () = Arg.parse [ "-o", Arg.String (fun s -> output_specified := true; output := s), "output-file Specify the resulting LaTeX file"; "-n", Arg.Int (fun n -> linelen := n), "line-width Set the line width"; "-image", Arg.String (fun s -> image := s), "coq-image Use coq-image as Coq command"; "-w", Arg.Set cut_at_blanks, " Try to cut lines at blanks"; "-v", Arg.Set verbose, " Verbose mode (show Coq answers on stdout)"; "-sl", Arg.Set slanted, " Coq answers in slanted font (only with LaTeX2e)"; "-hrule", Arg.Set hrule, " Coq parts are written between 2 horizontal lines"; "-small", Arg.Set small, " Coq parts are written in small font"; "-boot", Arg.Set boot, " Launch coqtop with the -boot option" ] (fun s -> files := s :: !files) "coq-tex [options] file ..." let find_coqtop () = let prog = Sys.executable_name in try let size = String.length prog in let i = Str.search_backward (Str.regexp_string "coq-tex") prog (size-7) in (String.sub prog 0 i)^"coqtop"^(String.sub prog (i+7) (size-i-7)) with Not_found -> begin Printf.printf "Warning: preprocessing with default image \"coqtop\"\n"; "coqtop" end let _ = parse_cl (); if !image = "" then image := Filename.quote (find_coqtop ()); if !boot then image := !image ^ " -boot"; if Sys.command (!image ^ " -batch -silent") <> 0 then begin Printf.printf "Error: "; let _ = Sys.command (!image ^ " -batch") in exit 1 end else begin (*Printf.printf "Your version of coqtop seems OK\n";*) flush stdout end; List.iter one_file (List.rev !files) coq-8.6/tools/coqworkmgr.ml0000644000175000017500000001550313022274260015350 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* s, string_of_inet_addr host ^":"^ string_of_int port | _ -> assert false module Queue : sig type t val is_empty : t -> bool val push : int * party -> t -> unit val pop : t -> int * party val create : unit -> t end = struct type t = (int * party) list ref let create () = ref [] let is_empty q = !q = [] let rec split acc = function | [] -> List.rev acc, [] | (_, { priority = Flags.Low }) :: _ as l -> List.rev acc, l | x :: xs -> split (x :: acc) xs let push (_,{ priority } as item) q = if priority = Flags.Low then q := !q @ [item] else let high, low = split [] !q in q := high @ (item :: low) let pop q = match !q with x :: xs -> q := xs; x | _ -> assert false end let read_fd fd s ~off ~len = let rec loop () = try Unix.read fd s off len with Unix.Unix_error(Unix.EAGAIN,_,_) -> loop () in loop () let really_read_fd fd s off len = let i = ref 0 in while !i < len do let off = off + !i in let len = len - !i in let r = read_fd fd s ~off ~len in if r = 0 then raise End_of_file; i := !i + r done let raw_input_line fd = try let b = Buffer.create 80 in let s = String.make 1 '\000' in while s <> "\n" do really_read_fd fd s 0 1; if s <> "\n" && s <> "\r" then Buffer.add_string b s; done; Buffer.contents b with Unix.Unix_error _ -> raise End_of_file let accept s = let cs, _ = Unix.accept s in let cout = Unix.out_channel_of_descr cs in set_binary_mode_out cout true; match parse_request (raw_input_line cs) with | Hello p -> { sock=cs; cout; tokens=0; priority=p } | _ -> (try Unix.close cs with _ -> ()); raise End_of_file let parse s = () let parties = ref [] let max_tokens = ref 2 let cur_tokens = ref 0 let queue = Queue.create () let rec allocate n party = let extra = min n (!max_tokens - !cur_tokens) in cur_tokens := !cur_tokens + extra; party.tokens <- party.tokens + extra; answer party (Tokens extra) and de_allocate n party = let back = min party.tokens n in party.tokens <- party.tokens - back; cur_tokens := min (!cur_tokens - back) !max_tokens; eventually_dequeue () and eventually_dequeue () = if Queue.is_empty queue || !cur_tokens >= !max_tokens then () else let req, party = Queue.pop queue in if List.exists (fun { sock } -> sock = party.sock) !parties then allocate req party else eventually_dequeue () let chat s = let party = try List.find (fun { sock } -> sock = s) !parties with Not_found -> Printf.eprintf "Internal error"; exit 1 in try match parse_request (raw_input_line party.sock) with | Get n -> if !cur_tokens < !max_tokens then allocate n party else Queue.push (n,party) queue | TryGet n -> if !cur_tokens < !max_tokens then allocate n party else answer party Noluck | GiveBack n -> de_allocate n party | Ping -> answer party (Pong (!cur_tokens,!max_tokens,Unix.getpid ())); raise End_of_file | Hello _ -> raise End_of_file with Failure _ | ParseError | Sys_error _ | End_of_file -> (try Unix.close party.sock with _ -> ()); parties := List.filter (fun { sock } -> sock <> s) !parties; de_allocate party.tokens party; eventually_dequeue () let check_alive s = match CoqworkmgrApi.connect s with | Some s -> let cout = Unix.out_channel_of_descr s in set_binary_mode_out cout true; output_string cout (print_request (Hello Flags.Low)); flush cout; output_string cout (print_request Ping); flush cout; begin match Unix.select [s] [] [] 1.0 with | [s],_,_ -> let cin = Unix.in_channel_of_descr s in set_binary_mode_in cin true; begin match parse_response (input_line cin) with | Pong (n,m,pid) -> n, m, pid | _ -> raise Not_found end | _ -> raise Not_found end | _ -> raise Not_found let main () = let args = [ "-j",Arg.Set_int max_tokens, "max number of concurrent jobs"; "-d",Arg.Set debug, "do not detach (debug)"] in let usage = "Prints on stdout an env variable assignement to be picked up by coq\n"^ "instances in order to limit the maximum number of concurrent workers.\n"^ "The default value is 2.\n"^ "Usage:" in Arg.parse args (fun extra -> Arg.usage args ("Unexpected argument "^extra^".\n"^usage)) usage; try let sock = Sys.getenv "COQWORKMGR_SOCK" in if !debug then Printf.eprintf "Contacting %s\n%!" sock; let cur, max, pid = check_alive sock in Printf.printf "COQWORKMGR_SOCK=%s\n%!" sock; Printf.eprintf "coqworkmgr already up and running (pid=%d, socket=%s, j=%d/%d)\n%!" pid sock cur max; exit 0 with Not_found | Failure _ | Invalid_argument _ | Unix.Unix_error _ -> if !debug then Printf.eprintf "No running instance. Starting a new one\n%!"; let master, str = mk_socket_channel () in if not !debug then begin let pid = Unix.fork () in if pid <> 0 then begin Printf.printf "COQWORKMGR_SOCK=%s\n%!" str; exit 0 end else begin ignore(Unix.setsid ()); Unix.close Unix.stdin; Unix.close Unix.stdout; end; end else begin Printf.printf "COQWORKMGR_SOCK=%s\n%!" str; end; Sys.catch_break true; try while true do if !debug then Printf.eprintf "Status: #parties=%d tokens=%d/%d \n%!" (List.length !parties) !cur_tokens !max_tokens; let socks = master :: List.map (fun { sock } -> sock) !parties in let r, _, _ = Unix.select socks [] [] (-1.0) in List.iter (fun s -> if s = master then begin try parties := accept master :: !parties with _ -> () end else chat s) r done; exit 0 with Sys.Break -> if !parties <> [] then begin Printf.eprintf "Some coq processes still need me\n%!"; exit 1; end else exit 0 let () = main () coq-8.6/tools/coqwc.mll0000644000175000017500000002152713022274260014450 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* printf " %s" f | _ -> ()); if !percentage then begin let s = sl + pl + dl in let p = if s > 0 then 100 * dl / s else 0 in printf " (%d%%)" p end; print_newline () let print_file fo = print_line !slines !plines !dlines fo let print_totals () = print_line !tslines !tplines !tdlines (Some "total") (*i*)}(*i*) (*s Shortcuts for regular expressions. The [rcs] regular expression is used to skip the CVS infos possibly contained in some comments, in order not to consider it as documentation. *) let space = [' ' '\t' '\r'] let character = "'" ([^ '\\' '\''] | '\\' (['\\' '\'' 'n' 't' 'b' 'r'] | ['0'-'9'] ['0'-'9'] ['0'-'9'])) "'" let rcs_keyword = "Author" | "Date" | "Header" | "Id" | "Name" | "Locker" | "Log" | "RCSfile" | "Revision" | "Source" | "State" let rcs = "\036" rcs_keyword [^ '$']* "\036" let stars = "(*" '*'* "*)" let dot = '.' (' ' | '\t' | '\n' | '\r' | eof) let proof_start = "Theorem" | "Lemma" | "Fact" | "Remark" | "Goal" | "Correctness" | "Obligation" | "Next" let def_start = "Definition" | "Fixpoint" | "Instance" let proof_end = ("Save" | "Qed" | "Defined" | "Abort" | "Admitted") [^'.']* '.' (*s [spec] scans the specification. *) rule spec = parse | "(*" { comment lexbuf; spec lexbuf } | '"' { let n = string lexbuf in slines := !slines + n; seen_spec := true; spec lexbuf } | '\n' { newline (); spec lexbuf } | space+ | stars { spec lexbuf } | proof_start { seen_spec := true; spec_to_dot lexbuf; proof lexbuf } | def_start { seen_spec := true; definition lexbuf } | character | _ { seen_spec := true; spec lexbuf } | eof { () } (*s [spec_to_dot] scans a spec until a dot is reached and returns. *) and spec_to_dot = parse | "(*" { comment lexbuf; spec_to_dot lexbuf } | '"' { let n = string lexbuf in slines := !slines + n; seen_spec := true; spec_to_dot lexbuf } | '\n' { newline (); spec_to_dot lexbuf } | dot { () } | space+ | stars { spec_to_dot lexbuf } | character | _ { seen_spec := true; spec_to_dot lexbuf } | eof { () } (*s [definition] scans a definition; passes to [proof] if the body is absent, and to [spec] otherwise *) and definition = parse | "(*" { comment lexbuf; definition lexbuf } | '"' { let n = string lexbuf in slines := !slines + n; seen_spec := true; definition lexbuf } | '\n' { newline (); definition lexbuf } | ":=" { seen_spec := true; spec lexbuf } | dot { proof lexbuf } | space+ | stars { definition lexbuf } | character | _ { seen_spec := true; definition lexbuf } | eof { () } (*s Scans a proof, then returns to [spec]. *) and proof = parse | "(*" { comment lexbuf; proof lexbuf } | '"' { let n = string lexbuf in plines := !plines + n; seen_proof := true; proof lexbuf } | space+ | stars { proof lexbuf } | '\n' { newline (); proof lexbuf } | "Proof" space* '.' | "Proof" space+ "with" | "Proof" space+ "using" { seen_proof := true; proof lexbuf } | "Proof" space { proof_term lexbuf } | proof_end { seen_proof := true; spec lexbuf } | character | _ { seen_proof := true; proof lexbuf } | eof { () } and proof_term = parse | "(*" { comment lexbuf; proof_term lexbuf } | '"' { let n = string lexbuf in plines := !plines + n; seen_proof := true; proof_term lexbuf } | space+ | stars { proof_term lexbuf } | '\n' { newline (); proof_term lexbuf } | dot { spec lexbuf } | character | _ { seen_proof := true; proof_term lexbuf } | eof { () } (*s Scans a comment. *) and comment = parse | "(*" { comment lexbuf; comment lexbuf } | "*)" { () } | '"' { let n = string lexbuf in dlines := !dlines + n; seen_comment := true; comment lexbuf } | '\n' { newline (); comment lexbuf } | space+ | stars { comment lexbuf } | character | _ { seen_comment := true; comment lexbuf } | eof { () } (*s The entry [string] reads a string until its end and returns the number of newlines it contains. *) and string = parse | '"' { 0 } | '\\' ('\\' | 'n' | '"') { string lexbuf } | '\n' { succ (string lexbuf) } | _ { string lexbuf } | eof { 0 } (*s The following entry [read_header] is used to skip the possible header at the beggining of files (unless option \texttt{-e} is specified). It stops whenever it encounters an empty line or any character outside a comment. In this last case, it correctly resets the lexer position on that character (decreasing [lex_curr_pos] by 1). *) and read_header = parse | "(*" { skip_comment lexbuf; skip_until_nl lexbuf; read_header lexbuf } | "\n" { () } | space+ { read_header lexbuf } | _ { lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - 1 } | eof { () } and skip_comment = parse | "*)" { () } | "(*" { skip_comment lexbuf; skip_comment lexbuf } | _ { skip_comment lexbuf } | eof { () } and skip_until_nl = parse | '\n' { () } | _ { skip_until_nl lexbuf } | eof { () } (*i*){(*i*) (*s Processing files and channels. *) let process_channel ch = let lb = Lexing.from_channel ch in reset_counters (); if !skip_header then read_header lb; spec lb let process_file f = try let ch = open_in f in process_channel ch; close_in ch; print_file (Some f); update_totals () with | Sys_error "Is a directory" -> flush stdout; eprintf "coqwc: %s: Is a directory\n" f; flush stderr | Sys_error s -> flush stdout; eprintf "coqwc: %s\n" s; flush stderr (*s Parsing of the command line. *) let usage () = prerr_endline "usage: coqwc [options] [files]"; prerr_endline "Options are:"; prerr_endline " -p print percentage of comments"; prerr_endline " -s print only the spec size"; prerr_endline " -r print only the proof size"; prerr_endline " -e (everything) do not skip headers"; exit 1 let rec parse = function | [] -> [] | ("-h" | "-?" | "-help" | "--help") :: _ -> usage () | ("-s" | "--spec-only") :: args -> proof_only := false; spec_only := true; parse args | ("-r" | "--proof-only") :: args -> spec_only := false; proof_only := true; parse args | ("-p" | "--percentage") :: args -> percentage := true; parse args | ("-e" | "--header") :: args -> skip_header := false; parse args | f :: args -> f :: (parse args) (*s Main program. *) let _ = let files = parse (List.tl (Array.to_list Sys.argv)) in if not (!spec_only || !proof_only) then printf " spec proof comments\n"; match files with | [] -> process_channel stdin; print_file None | [f] -> process_file f | _ -> List.iter process_file files; print_totals () (*i*)}(*i*) coq-8.6/tools/coq_makefile.ml0000644000175000017500000011634213022274260015577 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* print x | x :: l -> print x; print sep; print_list sep l | [] -> () let rec print_prefix_list sep = function | x :: l -> print sep; print x; print_prefix_list sep l | [] -> () let section s = let l = String.length s in let print_com s = print "#"; print s; print "#\n" in print_com (String.make (l+2) '#'); print_com (String.make (l+2) ' '); print "# "; print s; print " #\n"; print_com (String.make (l+2) ' '); print_com (String.make (l+2) '#'); print "\n" (* These are the Coq library directories that are used for * plugin development *) let lib_dirs = ["kernel"; "lib"; "library"; "parsing"; "pretyping"; "interp"; "printing"; "intf"; "proofs"; "tactics"; "tools"; "ltacprof"; "toplevel"; "stm"; "grammar"; "config"; "ltac"; "engine"] let usage () = output_string stderr "Usage summary: coq_makefile .... [file.v] ... [file.ml[i4]?] ... [file.ml{lib,pack}] ... [any] ... [-extra[-phony] result dependencies command] ... [-I dir] ... [-R physicalpath logicalpath] ... [-Q physicalpath logicalpath] ... [VARIABLE = value] ... [-arg opt] ... [-opt|-byte] [-no-install] [-f file] [-o file] [-h] [--help] [file.v]: Coq file to be compiled [file.ml[i4]?]: Objective Caml file to be compiled [file.ml{lib,pack}]: ocamlbuild file that describes a Objective Caml library/module [any] : subdirectory that should be \"made\" and has a Makefile itself to do so. Very fragile and discouraged. [-extra result dependencies command]: add target \"result\" with command \"command\" and dependencies \"dependencies\". If \"result\" is not generic (do not contains a %), \"result\" is built by _make all_ and deleted by _make clean_. [-extra-phony result dependencies command]: add a PHONY target \"result\" with command \"command\" and dependencies \"dependencies\". Note that _-extra-phony foo bar \"\"_ is a regular way to add the target \"bar\" as as a dependencies of an already defined target \"foo\". [-I dir]: look for Objective Caml dependencies in \"dir\" [-R physicalpath logicalpath]: look for Coq dependencies resursively starting from \"physicalpath\". The logical path associated to the physical path is \"logicalpath\". [-Q physicalpath logicalpath]: look for Coq dependencies starting from \"physicalpath\". The logical path associated to the physical path is \"logicalpath\". [VARIABLE = value]: Add the variable definition \"VARIABLE=value\" [-byte]: compile with byte-code version of coq [-opt]: compile with native-code version of coq [-arg opt]: send option \"opt\" to coqc [-install opt]: where opt is \"user\" to force install into user directory, \"none\" to build a makefile with no install target or \"global\" to force install in $COQLIB directory [-f file]: take the contents of file as arguments [-o file]: output should go in file file Output file outside the current directory is forbidden. [-h]: print this usage summary [--help]: equivalent to [-h]\n"; exit 1 let is_genrule r = (* generic rule (like bar%foo: ...) *) let genrule = Str.regexp("%") in Str.string_match genrule r 0 let string_prefix a b = let rec aux i = try if a.[i] = b.[i] then aux (i+1) else i with Invalid_argument _ -> i in String.sub a 0 (aux 0) let is_prefix dir1 dir2 = let l1 = String.length dir1 in let l2 = String.length dir2 in let sep = Filename.dir_sep in if dir1 = dir2 then true else if l1 + String.length sep <= l2 then let dir1' = String.sub dir2 0 l1 in let sep' = String.sub dir2 l1 (String.length sep) in dir1' = dir1 && sep' = sep else false let physical_dir_of_logical_dir ldir = let le = String.length ldir - 1 in let pdir = if le >= 0 && ldir.[le] = '.' then String.sub ldir 0 (le - 1) else String.copy ldir in for i = 0 to le - 1 do if pdir.[i] = '.' then pdir.[i] <- '/'; done; pdir let standard opt = print "byte:\n"; print "\t$(MAKE) all \"OPT:=-byte\"\n\n"; print "opt:\n"; if not opt then print "\t@echo \"WARNING: opt is disabled\"\n"; print "\t$(MAKE) all \"OPT:="; print (if opt then "-opt" else "-byte"); print "\"\n\n" let classify_files_by_root var files (inc_ml,inc_i,inc_r) = if List.exists (fun (pdir,_,_) -> pdir = ".") inc_r || List.exists (fun (pdir,_,_) -> pdir = ".") inc_i then () else let absdir_of_files =List.rev_map (fun x -> CUnix.canonical_path_name (Filename.dirname x)) files in (* files in scope of a -I option (assuming they are no overlapping) *) if List.exists (fun (_,a) -> List.mem a absdir_of_files) inc_ml then begin printf "%sINC=" var; List.iter (fun (pdir,absdir) -> if List.mem absdir absdir_of_files then printf "$(filter $(wildcard %s/*),$(%s)) " pdir var) inc_ml; printf "\n"; end; (* Files in the scope of a -R option (assuming they are disjoint) *) List.iteri (fun i (pdir,_,abspdir) -> if List.exists (is_prefix abspdir) absdir_of_files then printf "%s%d=$(patsubst %s/%%,%%,$(filter %s/%%,$(%s)))\n" var i pdir pdir var) (inc_i@inc_r) let vars_to_put_by_root var_x_files_l (inc_ml,inc_i,inc_r) = let var_x_absdirs_l = List.rev_map (fun (v,l) -> (v,List.rev_map (fun x -> CUnix.canonical_path_name (Filename.dirname x)) l)) var_x_files_l in let var_filter f g = List.fold_left (fun acc (var,dirs) -> if f dirs then (g var)::acc else acc) [] var_x_absdirs_l in (* All files caught by a -R . option (assuming it is the only one) *) match inc_i@inc_r with |[(".",t,_)] -> (None,[".",physical_dir_of_logical_dir t,List.rev_map fst var_x_files_l]) |l -> try let out = List.assoc "." (List.rev_map (fun (p,l,_) -> (p,l)) l) in let () = prerr_string "Warning: install rule assumes that -R/-Q . _ is the only -R/-Q option\n" in (None,[".",physical_dir_of_logical_dir out,List.rev_map fst var_x_files_l]) with Not_found -> (* vars for -Q options *) let varq = var_filter (fun l -> List.exists (fun (_,a) -> List.mem a l) inc_ml) (fun x -> x) in (* (physical dir, physical dir of logical path,vars) for -R options (assuming physical dirs are disjoint) *) let other = if l = [] then [".","$(INSTALLDEFAULTROOT)",[]] else Util.List.fold_left_i (fun i out (pdir,ldir,abspdir) -> let vars_r = var_filter (List.exists (is_prefix abspdir)) (fun x -> x^string_of_int i) in let pdir' = physical_dir_of_logical_dir ldir in (pdir,pdir',vars_r)::out) 0 [] l in (Some varq, other) let install_include_by_root perms = let install_dir for_i (pdir,pdir',vars) = let b = vars <> [] in if b then begin printf "\tcd \"%s\" && for i in " pdir; print_list " " (List.rev_map (Format.sprintf "$(%s)") vars); print "; do \\\n"; printf "\t install -d \"`dirname \"$(DSTROOT)\"$(COQLIBINSTALL)/%s/$$i`\"; \\\n" pdir'; printf "\t install -m %s $$i \"$(DSTROOT)\"$(COQLIBINSTALL)/%s/$$i; \\\n" perms pdir'; printf "\tdone\n"; end; for_i b pdir' in let install_i = function |[] -> fun _ _ -> () |l -> fun b d -> if not b then printf "\tinstall -d \"$(DSTROOT)\"$(COQLIBINSTALL)/%s; \\\n" d; print "\tfor i in "; print_list " " (List.rev_map (Format.sprintf "$(%sINC)") l); print "; do \\\n"; printf "\t install -m %s $$i \"$(DSTROOT)\"$(COQLIBINSTALL)/%s/`basename $$i`; \\\n" perms d; printf "\tdone\n" in function |None,l -> List.iter (install_dir (fun _ _ -> ())) l |Some v_i,l -> List.iter (install_dir (install_i v_i)) l let uninstall_by_root = let uninstall_dir for_i (pdir,pdir',vars) = printf "\tprintf 'cd \"$${DSTROOT}\"$(COQLIBINSTALL)/%s" pdir'; if vars <> [] then begin print " && rm -f "; print_list " " (List.rev_map (Format.sprintf "$(%s)") vars); end; for_i (); print " && find . -type d -and -empty -delete\\n"; print "cd \"$${DSTROOT}\"$(COQLIBINSTALL) && "; printf "find \"%s\" -maxdepth 0 -and -empty -exec rmdir -p \\{\\} \\;\\n' >> \"$@\"\n" pdir' in let uninstall_i = function |[] -> () |l -> print " && \\\\\\nfor i in "; print_list " " (List.rev_map (Format.sprintf "$(%sINC)") l); print "; do rm -f \"`basename \"$$i\"`\"; done" in function |None,l -> List.iter (uninstall_dir (fun _ -> ())) l |Some v_i,l -> List.iter (uninstall_dir (fun () -> uninstall_i v_i)) l let where_put_doc = function |_,[],[] -> "$(INSTALLDEFAULTROOT)"; |_,((_,lp,_)::q as inc_i),[] -> let pr = List.fold_left (fun a (_,b,_) -> string_prefix a b) lp q in if (pr <> "") && ((List.exists (fun(_,b,_) -> b = pr) inc_i) || pr.[String.length pr - 1] = '.') then physical_dir_of_logical_dir pr else let () = prerr_string "Warning: -Q options don't have a correct common prefix, install-doc will put anything in $INSTALLDEFAULTROOT\n" in "$(INSTALLDEFAULTROOT)" |_,inc_i,((_,lp,_)::q as inc_r) -> let pr = List.fold_left (fun a (_,b,_) -> string_prefix a b) lp q in let pr = List.fold_left (fun a (_,b,_) -> string_prefix a b) pr inc_i in if (pr <> "") && ((List.exists (fun(_,b,_) -> b = pr) inc_r) || (List.exists (fun(_,b,_) -> b = pr) inc_i) || pr.[String.length pr - 1] = '.') then physical_dir_of_logical_dir pr else let () = prerr_string "Warning: -R/-Q options don't have a correct common prefix, install-doc will put anything in $INSTALLDEFAULTROOT\n" in "$(INSTALLDEFAULTROOT)" let install (vfiles,(mlis,ml4s,mls,mllibs,mlpacks),_,sds) inc = function |Project_file.NoInstall -> () |is_install -> let not_empty = function |[] -> false |_::_ -> true in let cmos = List.rev_append mlpacks (List.rev_append mls ml4s) in let cmis = List.rev_append mlis cmos in let cmxss = List.rev_append cmos mllibs in let where_what_cmxs = vars_to_put_by_root [("CMXSFILES",cmxss)] inc in let where_what_oth = vars_to_put_by_root [("VOFILES",vfiles);("VFILES",vfiles); ("GLOBFILES",vfiles);("NATIVEFILES",vfiles); ("CMOFILES",cmos);("CMIFILES",cmis);("CMAFILES",mllibs)] inc in let doc_dir = where_put_doc inc in if is_install = Project_file.UnspecInstall then begin print "userinstall:\n\t+$(MAKE) USERINSTALL=true install\n\n" end; if not_empty cmxss then begin print "install-natdynlink:\n"; install_include_by_root "0755" where_what_cmxs; print "\n"; end; if not_empty cmxss then begin print "install-toploop: $(MLLIBFILES:.mllib=.cmxs)\n"; printf "\t install -d \"$(DSTROOT)\"$(COQTOPINSTALL)/\n"; printf "\t install -m 0755 $? \"$(DSTROOT)\"$(COQTOPINSTALL)/\n"; print "\n"; end; print "install:"; if not_empty cmxss then begin print "$(if $(HASNATDYNLINK_OR_EMPTY),install-natdynlink)"; end; print "\n"; install_include_by_root "0644" where_what_oth; List.iter (fun x -> printf "\t+cd %s && $(MAKE) DSTROOT=\"$(DSTROOT)\" INSTALLDEFAULTROOT=\"$(INSTALLDEFAULTROOT)/%s\" install\n" x x) sds; print "\n"; let install_one_kind kind dir = printf "\tinstall -d \"$(DSTROOT)\"$(COQDOCINSTALL)/%s/%s\n" dir kind; printf "\tfor i in %s/*; do \\\n" kind; printf "\t install -m 0644 $$i \"$(DSTROOT)\"$(COQDOCINSTALL)/%s/$$i;\\\n" dir; print "\tdone\n" in print "install-doc:\n"; if not_empty vfiles then install_one_kind "html" doc_dir; if not_empty mlis then install_one_kind "mlihtml" doc_dir; print "\n"; let uninstall_one_kind kind dir = printf "\tprintf 'cd \"$${DSTROOT}\"$(COQDOCINSTALL)/%s \\\\\\n' >> \"$@\"\n" dir; printf "\tprintf '&& rm -f $(shell find \"%s\" -maxdepth 1 -and -type f -print)\\n' >> \"$@\"\n" kind; print "\tprintf 'cd \"$${DSTROOT}\"$(COQDOCINSTALL) && "; printf "find %s/%s -maxdepth 0 -and -empty -exec rmdir -p \\{\\} \\;\\n' >> \"$@\"\n" dir kind in printf "uninstall_me.sh: %s\n" !makefile_name; print "\techo '#!/bin/sh' > $@\n"; if not_empty cmxss then uninstall_by_root where_what_cmxs; uninstall_by_root where_what_oth; if not_empty vfiles then uninstall_one_kind "html" doc_dir; if not_empty mlis then uninstall_one_kind "mlihtml" doc_dir; print "\tchmod +x $@\n"; print "\n"; print "uninstall: uninstall_me.sh\n"; print "\tsh $<\n\n" let make_makefile sds = if !make_name <> "" then begin printf "%s: %s\n" !makefile_name !make_name; print "\tmv -f $@ $@.bak\n"; print "\t\"$(COQBIN)coq_makefile\" -f $< -o $@\n\n"; List.iter (fun x -> print "\t+cd "; print x; print " && $(MAKE) Makefile\n") sds; print "\n"; end let clean sds sps = print "clean::\n"; if !some_mlfile || !some_mlifile || !some_ml4file || !some_mllibfile || !some_mlpackfile then begin print "\trm -f $(ALLCMOFILES) $(CMIFILES) $(CMAFILES)\n"; print "\trm -f $(ALLCMOFILES:.cmo=.cmx) $(CMXAFILES) $(CMXSFILES) $(ALLCMOFILES:.cmo=.o) $(CMXAFILES:.cmxa=.a)\n"; print "\trm -f $(addsuffix .d,$(MLFILES) $(MLIFILES) $(ML4FILES) $(MLLIBFILES) $(MLPACKFILES))\n"; end; if !some_vfile then begin print "\trm -f $(OBJFILES) $(OBJFILES:.o=.native) $(NATIVEFILES)\n"; print "\tfind . -name .coq-native -type d -empty -delete\n"; print "\trm -f $(VOFILES) $(VOFILES:.vo=.vio) $(GFILES) $(VFILES:.v=.v.d) $(VFILES:=.beautified) $(VFILES:=.old)\n" end; print "\trm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) all-mli.tex\n"; print "\t- rm -rf html mlihtml uninstall_me.sh\n"; List.iter (fun (file,_,is_phony,_) -> if not (is_phony || is_genrule file) then (print "\t- rm -rf "; print file; print "\n")) sps; List.iter (fun x -> print "\t+cd "; print x; print " && $(MAKE) clean\n") sds; print "\n"; let () = if !some_vfile then let () = print "cleanall:: clean\n" in print "\trm -f $(patsubst %.v,.%.aux,$(VFILES))\n\n" in print "archclean::\n"; print "\trm -f *.cmx *.o\n"; List.iter (fun x -> print "\t+cd "; print x; print " && $(MAKE) archclean\n") sds; print "\n"; print "printenv:\n\t@\"$(COQBIN)coqtop\" -config\n"; print "\t@echo 'OCAMLFIND =\t$(OCAMLFIND)'\n\t@echo 'PP =\t$(PP)'\n\t@echo 'COQFLAGS =\t$(COQFLAGS)'\n"; print "\t@echo 'COQLIBINSTALL =\t$(COQLIBINSTALL)'\n\t@echo 'COQDOCINSTALL =\t$(COQDOCINSTALL)'\n\n" let header_includes () = () let implicit () = section "Implicit rules."; let mli_rules () = print "$(MLIFILES:.mli=.cmi): %.cmi: %.mli\n"; print "\t$(SHOW)'CAMLC -c $<'\n"; print "\t$(HIDE)$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; print "$(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli\n"; print "\t$(SHOW)'CAMLDEP $<'\n"; print "\t$(HIDE)$(CAMLDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in let ml4_rules () = print "$(ML4FILES:.ml4=.cmo): %.cmo: %.ml4\n"; print "\t$(SHOW)'CAMLC -pp -c $<'\n"; print "\t$(HIDE)$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(ML4FILES:.ml4=.cmx)): %.cmx: %.ml4\n"; print "\t$(SHOW)'CAMLOPT -pp -c $<'\n"; print "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; print "$(addsuffix .d,$(ML4FILES)): %.ml4.d: %.ml4\n"; print "\t$(SHOW)'CAMLDEP -pp $<'\n"; print "\t$(HIDE)$(CAMLDEP) $(OCAMLLIBS) $(PP) -impl \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in let ml_rules () = print "$(MLFILES:.ml=.cmo): %.cmo: %.ml\n"; print "\t$(SHOW)'CAMLC -c $<'\n"; print "\t$(HIDE)$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(MLFILES:.ml=.cmx)): %.cmx: %.ml\n"; print "\t$(SHOW)'CAMLOPT -c $<'\n"; print "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; print "$(addsuffix .d,$(MLFILES)): %.ml.d: %.ml\n"; print "\t$(SHOW)'CAMLDEP $<'\n"; print "\t$(HIDE)$(CAMLDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in let cmxs_rules () = (* order is important here when there is foo.ml and foo.mllib *) print "$(filter-out $(MLLIBFILES:.mllib=.cmxs),$(MLFILES:.ml=.cmxs) $(ML4FILES:.ml4=.cmxs) $(MLPACKFILES:.mlpack=.cmxs)): %.cmxs: %.cmx\n"; print "\t$(SHOW)'CAMLOPT -shared -o $@'\n"; print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $<\n\n"; print "$(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa\n"; print "\t$(SHOW)'CAMLOPT -shared -o $@'\n"; print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -linkall -shared -o $@ $<\n\n" in let mllib_rules () = print "$(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib\n"; print "\t$(SHOW)'CAMLC -a -o $@'\n"; print "\t$(HIDE)$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n"; print "$(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib\n"; print "\t$(SHOW)'CAMLOPT -a -o $@'\n"; print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n"; print "$(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib\n"; print "\t$(SHOW)'COQDEP $<'\n"; print "\t$(HIDE)$(COQDEP) $(OCAMLLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in let mlpack_rules () = print "$(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack\n"; print "\t$(SHOW)'CAMLC -pack -o $@'\n"; print "\t$(HIDE)$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n"; print "$(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack\n"; print "\t$(SHOW)'CAMLOPT -pack -o $@'\n"; print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n"; print "$(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack\n"; print "\t$(SHOW)'COQDEP $<'\n"; print "\t$(HIDE)$(COQDEP) $(OCAMLLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in let v_rules () = print "$(VOFILES): %.vo: %.v\n"; print "\t$(SHOW)COQC $<\n"; print "\t$(HIDE)$(COQC) $(COQDEBUG) $(COQFLAGS) $<\n\n"; print "$(GLOBFILES): %.glob: %.v\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $<\n\n"; print "$(VFILES:.v=.vio): %.vio: %.v\n\t$(COQC) -quick $(COQDEBUG) $(COQFLAGS) $<\n\n"; print "$(GFILES): %.g: %.v\n\t$(GALLINA) $<\n\n"; print "$(VFILES:.v=.tex): %.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@\n\n"; print "$(HTMLFILES): %.html: %.v %.glob\n\t$(COQDOC) $(COQDOCFLAGS) -html $< -o $@\n\n"; print "$(VFILES:.v=.g.tex): %.g.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@\n\n"; print "$(GHTMLFILES): %.g.html: %.v %.glob\n\t$(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@\n\n"; print "$(addsuffix .d,$(VFILES)): %.v.d: %.v\n"; print "\t$(SHOW)'COQDEP $<'\n"; print "\t$(HIDE)$(COQDEP) $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"; print "$(addsuffix .beautified,$(VFILES)): %.v.beautified:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $*.v\n\n" in if !some_mlifile then mli_rules (); if !some_ml4file then ml4_rules (); if !some_mlfile then ml_rules (); if !some_mlfile || !some_ml4file then cmxs_rules (); if !some_mllibfile then mllib_rules (); if !some_mlpackfile then mlpack_rules (); if !some_vfile then v_rules () let variables is_install opt (args,defs) = let var_aux (v,def) = print v; print "="; print def; print "\n" in section "Variables definitions."; List.iter var_aux defs; print "\n"; if not opt then print "override OPT:=-byte\n" else print "OPT?=\n"; begin match args with |[] -> () |h::t -> print "OTHERFLAGS="; print h; List.iter (fun s -> print " ";print s) t; print "\n"; end; (* Coq executables and relative variables *) if !some_vfile || !some_mlpackfile || !some_mllibfile then print "COQDEP?=\"$(COQBIN)coqdep\" -c\n"; if !some_vfile then begin print "COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)\n"; print "COQCHKFLAGS?=-silent -o\n"; print "COQDOCFLAGS?=-interpolate -utf8\n"; print "COQC?=$(TIMER) \"$(COQBIN)coqc\"\n"; print "GALLINA?=\"$(COQBIN)gallina\"\n"; print "COQDOC?=\"$(COQBIN)coqdoc\"\n"; print "COQCHK?=\"$(COQBIN)coqchk\"\n"; print "COQMKTOP?=\"$(COQBIN)coqmktop\"\n\n"; end; (* Caml executables and relative variables *) if !some_ml4file || !some_mlfile || !some_mlifile then begin print "COQSRCLIBS?=" ; List.iter (fun c -> print "-I \"$(COQLIB)"; print c ; print "\" \\\n") lib_dirs ; List.iter (fun c -> print " \\ -I \"$(COQLIB)/"; print c; print "\"") Coq_config.plugins_dirs; print "\n"; print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n\n"; print "CAMLC?=$(OCAMLFIND) ocamlc -c -rectypes -thread\n"; print "CAMLOPTC?=$(OCAMLFIND) opt -c -rectypes -thread\n"; print "CAMLLINK?=$(OCAMLFIND) ocamlc -rectypes -thread\n"; print "CAMLOPTLINK?=$(OCAMLFIND) opt -rectypes -thread\n"; print "CAMLDEP?=$(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack\n"; print "CAMLLIB?=$(shell $(OCAMLFIND) printconf stdlib)\n"; print "GRAMMARS?=grammar.cma\n"; print "ifeq ($(CAMLP4),camlp5) CAMLP4EXTEND=pa_extend.cmo q_MLast.cmo pa_macro.cmo else CAMLP4EXTEND= endif\n"; print "PP?=-pp '$(CAMLP4O) -I $(CAMLLIB) -I $(COQLIB)/grammar compat5.cmo \\ $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl'\n\n"; end; match is_install with | Project_file.NoInstall -> () | Project_file.UnspecInstall -> section "Install Paths."; print "ifdef USERINSTALL\n"; print "XDG_DATA_HOME?=\"$(HOME)/.local/share\"\n"; print "COQLIBINSTALL=$(XDG_DATA_HOME)/coq\n"; print "COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq\n"; print "else\n"; print "COQLIBINSTALL=\"${COQLIB}user-contrib\"\n"; print "COQDOCINSTALL=\"${DOCDIR}user-contrib\"\n"; print "COQTOPINSTALL=\"${COQLIB}toploop\"\n"; print "endif\n\n" | Project_file.TraditionalInstall -> section "Install Paths."; print "COQLIBINSTALL=\"${COQLIB}user-contrib\"\n"; print "COQDOCINSTALL=\"${DOCDIR}user-contrib\"\n"; print "COQTOPINSTALL=\"${COQLIB}toploop\"\n"; print "\n" | Project_file.UserInstall -> section "Install Paths."; print "XDG_DATA_HOME?=\"$(HOME)/.local/share\"\n"; print "COQLIBINSTALL=$(XDG_DATA_HOME)/coq\n"; print "COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq\n"; print "COQTOPINSTALL=$(XDG_DATA_HOME)/coq/toploop\n"; print "\n" let parameters () = print ".DEFAULT_GOAL := all\n\n"; print "# This Makefile may take arguments passed as environment variables:\n"; print "# COQBIN to specify the directory where Coq binaries resides;\n"; print "# TIMECMD set a command to log .v compilation time;\n"; print "# TIMED if non empty, use the default time command as TIMECMD;\n"; print "# ZDEBUG/COQDEBUG to specify debug flags for ocamlc&ocamlopt/coqc;\n"; print "# DSTROOT to specify a prefix to install path.\n"; print "# VERBOSE to disable the short display of compilation rules.\n\n"; print "VERBOSE?=\n"; print "SHOW := $(if $(VERBOSE),@true \"\",@echo \"\")\n"; print "HIDE := $(if $(VERBOSE),,@)\n\n"; print "# Here is a hack to make $(eval $(shell works:\n"; print "define donewline\n\n\nendef\n"; print "includecmdwithout@ = $(eval $(subst @,$(donewline),$(shell { $(1) | tr -d '\\r' | tr '\\n' '@'; })))\n"; print "$(call includecmdwithout@,$(COQBIN)coqtop -config)\n\n"; print "TIMED?=\nTIMECMD?=\nSTDTIME?=/usr/bin/time -f \"$* (user: %U mem: %M ko)\"\n"; print "TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD))\n\n"; print "vo_to_obj = $(addsuffix .o,\\\n"; print " $(filter-out Warning: Error:,\\\n"; print " $(shell $(COQBIN)coqtop -q -noinit -batch -quiet -print-mod-uid $(1))))\n\n" let include_dirs (inc_ml,inc_q,inc_r) = let parse_ml_includes l = List.map (fun (x,_) -> "-I \"" ^ x ^ "\"") l in let includes = List.map (fun (p,l,_) -> let l' = if l = "" then "\"\"" else l in " \"" ^ p ^ "\" " ^ l' ^"") in let str_ml = parse_ml_includes inc_ml in section "Libraries definitions."; if !some_ml4file || !some_mlfile || !some_mlifile then begin print "OCAMLLIBS?="; print_list "\\\n " str_ml; print "\n"; end; if !some_vfile || !some_mllibfile || !some_mlpackfile then begin print "COQLIBS?="; print_prefix_list "\\\n -Q" (includes inc_q); print_prefix_list "\\\n -R" (includes inc_r); print_prefix_list "\\\n " str_ml; print "\n"; end; if !some_vfile then begin print "COQCHKLIBS?="; print_prefix_list "\\\n -R" (includes inc_q); print_prefix_list "\\\n -R" (includes inc_r); print "\n"; print "COQDOCLIBS?="; print_prefix_list "\\\n -R" (includes inc_q); print_prefix_list "\\\n -R" (includes inc_r); print "\n"; end; print "\n" let double_colon = ["clean"; "cleanall"; "archclean"] let custom sps = let pr_path (file,dependencies,is_phony,com) = print file; print (if List.mem file double_colon then ":: " else ": "); print dependencies; print "\n"; if com <> "" then (print "\t"; print com; print "\n"); print "\n" in if sps <> [] then section "Custom targets."; List.iter pr_path sps let subdirs sds = let pr_subdir s = print s; print ":\n\t+cd \""; print s; print "\" && $(MAKE) all\n\n" in if sds <> [] then let () = Format.eprintf "@[Warning: Targets for subdirectories are very fragile.@ " in let () = Format.eprintf "For example,@ nothing is done to handle dependencies@ with them.@]@." in section "Subdirectories."; List.iter pr_subdir sds let forpacks l = let () = if l <> [] then section "Ad-hoc implicit rules for mlpack." in List.iter (fun it -> let h = Filename.chop_extension it in let pk = String.capitalize (Filename.basename h) in printf "$(addsuffix .cmx,$(filter $(basename $(MLFILES)),$(%s_MLPACK_DEPENDENCIES))): %%.cmx: %%.ml\n" h; printf "\t$(SHOW)'CAMLOPT -c -for-pack %s $<'\n" pk; printf "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $<\n\n" pk; printf "$(addsuffix .cmx,$(filter $(basename $(ML4FILES)),$(%s_MLPACK_DEPENDENCIES))): %%.cmx: %%.ml4\n" h; printf "\t$(SHOW)'CAMLOPT -c -pp -for-pack %s $<'\n" pk; printf "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $(PP) -impl $<\n\n" pk ) l let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other_targets inc = let decl_var var = function |[] -> () |l -> printf "%s:=" var; print_list "\\\n " l; print "\n\n"; print "ifneq ($(filter-out archclean clean cleanall printenv,$(MAKECMDGOALS)),)\n"; printf "-include $(addsuffix .d,$(%s))\n" var; print "else\nifeq ($(MAKECMDGOALS),)\n"; printf "-include $(addsuffix .d,$(%s))\n" var; print "endif\nendif\n\n"; printf ".SECONDARY: $(addsuffix .d,$(%s))\n\n" var in section "Files dispatching."; decl_var "VFILES" vfiles; begin match vfiles with |[] -> () |l -> print "VO=vo\n"; print "VOFILES:=$(VFILES:.v=.$(VO))\n"; classify_files_by_root "VOFILES" l inc; print "GLOBFILES:=$(VFILES:.v=.glob)\n"; print "GFILES:=$(VFILES:.v=.g)\n"; print "HTMLFILES:=$(VFILES:.v=.html)\n"; print "GHTMLFILES:=$(VFILES:.v=.g.html)\n"; print "OBJFILES=$(call vo_to_obj,$(VOFILES))\n"; print "ALLNATIVEFILES=$(OBJFILES:.o=.cmi) $(OBJFILES:.o=.cmo) $(OBJFILES:.o=.cmx) $(OBJFILES:.o=.cmxs)\n"; print "NATIVEFILES=$(foreach f, $(ALLNATIVEFILES), $(wildcard $f))\n"; classify_files_by_root "NATIVEFILES" l inc end; decl_var "ML4FILES" ml4files; decl_var "MLFILES" mlfiles; decl_var "MLPACKFILES" mlpackfiles; decl_var "MLLIBFILES" mllibfiles; decl_var "MLIFILES" mlifiles; let mlsfiles = match ml4files,mlfiles,mlpackfiles with |[],[],[] -> [] |[],[],_ -> Printf.eprintf "Mlpack cannot work without ml[4]?"; [] |[],ml,[] -> print "ALLCMOFILES:=$(MLFILES:.ml=.cmo)\n"; ml |ml4,[],[] -> print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo)\n"; ml4 |ml4,ml,[] -> print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo) $(MLFILES:.ml=.cmo)\n"; List.rev_append ml ml4 |[],ml,mlpack -> print "ALLCMOFILES:=$(MLFILES:.ml=.cmo) $(MLPACKFILES:.mlpack=.cmo)\n"; List.rev_append mlpack ml |ml4,[],mlpack -> print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo) $(MLPACKFILES:.mlpack=.cmo)\n"; List.rev_append mlpack ml4 |ml4,ml,mlpack -> print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo) $(MLFILES:.ml=.cmo) $(MLPACKFILES:.mlpack=.cmo)\n"; List.rev_append mlpack (List.rev_append ml ml4) in begin match mlsfiles with |[] -> () |l -> print "CMOFILES=$(filter-out $(addsuffix .cmo,$(foreach lib,$(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES) $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(ALLCMOFILES))\n"; classify_files_by_root "CMOFILES" l inc; print "CMXFILES=$(CMOFILES:.cmo=.cmx)\n"; print "OFILES=$(CMXFILES:.cmx=.o)\n"; end; begin match mllibfiles with |[] -> () |l -> print "CMAFILES:=$(MLLIBFILES:.mllib=.cma)\n"; classify_files_by_root "CMAFILES" l inc; print "CMXAFILES:=$(CMAFILES:.cma=.cmxa)\n"; end; begin match mlifiles,mlsfiles with |[],[] -> () |l,[] -> print "CMIFILES:=$(MLIFILES:.mli=.cmi)\n"; classify_files_by_root "CMIFILES" l inc; |[],l -> print "CMIFILES=$(ALLCMOFILES:.cmo=.cmi)\n"; classify_files_by_root "CMIFILES" l inc; |l1,l2 -> print "CMIFILES=$(sort $(ALLCMOFILES:.cmo=.cmi) $(MLIFILES:.mli=.cmi))\n"; classify_files_by_root "CMIFILES" (l1@l2) inc; end; begin match mllibfiles,mlsfiles with |[],[] -> () |l,[] -> print "CMXSFILES:=$(CMXAFILES:.cmxa=.cmxs)\n"; classify_files_by_root "CMXSFILES" l inc; |[],l -> print "CMXSFILES=$(CMXFILES:.cmx=.cmxs)\n"; classify_files_by_root "CMXSFILES" l inc; |l1,l2 -> print "CMXSFILES=$(CMXFILES:.cmx=.cmxs) $(CMXAFILES:.cmxa=.cmxs)\n"; classify_files_by_root "CMXSFILES" (l1@l2) inc; end; print "ifeq '$(HASNATDYNLINK)' 'true'\n"; print "HASNATDYNLINK_OR_EMPTY := yes\n"; print "else\n"; print "HASNATDYNLINK_OR_EMPTY :=\n"; print "endif\n\n"; section "Definition of the toplevel targets."; print "all: "; if !some_vfile then print "$(VOFILES) "; if !some_mlfile || !some_ml4file || !some_mlpackfile then print "$(CMOFILES) "; if !some_mllibfile then print "$(CMAFILES) "; if !some_mlfile || !some_ml4file || !some_mllibfile || !some_mlpackfile then print "$(if $(HASNATDYNLINK_OR_EMPTY),$(CMXSFILES)) "; print_list "\\\n " other_targets; print "\n\n"; if !some_mlifile then begin print "mlihtml: $(MLIFILES:.mli=.cmi)\n"; print "\t mkdir $@ || rm -rf $@/*\n"; print "\t$(OCAMLFIND) ocamldoc -html -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; print "all-mli.tex: $(MLIFILES:.mli=.cmi)\n"; print "\t$(OCAMLFIND) ocamldoc -latex -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; end; if !some_vfile then begin print "quick: $(VOFILES:.vo=.vio)\n\n"; print "vio2vo:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio)\n"; print "checkproofs:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio)\n"; print "gallina: $(GFILES)\n\n"; print "html: $(GLOBFILES) $(VFILES)\n"; print "\t- mkdir -p html\n"; print "\t$(COQDOC) -toc $(COQDOCFLAGS) -html $(COQDOCLIBS) -d html $(VFILES)\n\n"; print "gallinahtml: $(GLOBFILES) $(VFILES)\n"; print "\t- mkdir -p html\n"; print "\t$(COQDOC) -toc $(COQDOCFLAGS) -html -g $(COQDOCLIBS) -d html $(VFILES)\n\n"; print "all.ps: $(VFILES)\n"; print "\t$(COQDOC) -toc $(COQDOCFLAGS) -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; print "all-gal.ps: $(VFILES)\n"; print "\t$(COQDOC) -toc $(COQDOCFLAGS) -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; print "all.pdf: $(VFILES)\n"; print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; print "all-gal.pdf: $(VFILES)\n"; print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; print "validate: $(VOFILES)\n"; print "\t$(COQCHK) $(COQCHKFLAGS) $(COQCHKLIBS) $(notdir $(^:.vo=))\n\n"; print "beautify: $(VFILES:=.beautified)\n"; print "\tfor file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done\n"; print "\t@echo \'Do not do \"make clean\" until you are sure that everything went well!\'\n"; print "\t@echo \'If there were a problem, execute \"for file in $$(find . -name \\*.v.old -print); do mv $${file} $${file%.old}; done\" in your shell/'\n\n" end let all_target (vfiles, (_,_,_,_,mlpackfiles as mlfiles), sps, sds) inc = let other_targets = CList.map_filter (fun (n,_,is_phony,_) -> if not (is_phony || is_genrule n) then Some n else None) sps @ sds in main_targets vfiles mlfiles other_targets inc; print ".PHONY: "; print_list " " ("all" :: "archclean" :: "beautify" :: "byte" :: "clean" :: "cleanall" :: "gallina" :: "gallinahtml" :: "html" :: "install" :: "install-doc" :: "install-natdynlink" :: "install-toploop" :: "opt" :: "printenv" :: "quick" :: "uninstall" :: "userinstall" :: "validate" :: "vio2vo" :: (sds@(CList.map_filter (fun (n,_,is_phony,_) -> if is_phony then Some n else None) sps))); print "\n\n"; custom sps; subdirs sds; forpacks mlpackfiles let banner () = print (Printf.sprintf "############################################################################# ## v # The Coq Proof Assistant ## ## print x; print " ") l let command_line args = print "#\n# This Makefile was generated by the command line :\n"; print "# coq_makefile "; print_list args; print "\n#\n\n" let ensure_root_dir (vfiles,(mlis,ml4s,mls,mllibs,mlpacks),_,_) inc = let (ml_inc,i_inc,r_inc) = inc in let here = Sys.getcwd () in let not_tops = List.for_all (fun s -> s <> Filename.basename s) in if List.exists (fun (_,_,x) -> x = here) i_inc || List.exists (fun (_,_,x) -> is_prefix x here) r_inc || (not_tops vfiles && not_tops mlis && not_tops ml4s && not_tops mls && not_tops mllibs && not_tops mlpacks) then inc else ((".",here)::ml_inc,i_inc,(".","Top",here)::r_inc) let warn_install_at_root_directory (vfiles,(mlis,ml4s,mls,mllibs,mlpacks),_,_) inc = let (inc_ml,inc_i,inc_r) = inc in let inc_top = List.filter (fun (_,ldir,_) -> ldir = "") (inc_r@inc_i) in let inc_top_p = List.map (fun (p,_,_) -> p) inc_top in let files = vfiles @ mlis @ ml4s @ mls @ mllibs @ mlpacks in if List.exists (fun f -> List.mem (Filename.dirname f) inc_top_p) files then Printf.eprintf "Warning: install target will copy files at the first level of the coq contributions installation directory; option -R or -Q %sis recommended\n" (if inc_top = [] then "" else "with non trivial logical root ") let check_overlapping_include (_,inc_i,inc_r) = let pwd = Sys.getcwd () in let aux = function | [] -> () | (pdir,_,abspdir)::l -> if not (is_prefix pwd abspdir) then Printf.eprintf "Warning: in option -R/-Q, %s is not a subdirectory of the current directory\n" pdir; List.iter (fun (pdir',_,abspdir') -> if is_prefix abspdir abspdir' || is_prefix abspdir' abspdir then Printf.eprintf "Warning: in options -R/-Q, %s and %s overlap\n" pdir pdir') l; in aux (inc_i@inc_r) (* Generate a .merlin file that references the standard library and * any -I included paths. *) let merlin targets (ml_inc,_,_) = print ".merlin:\n"; print "\t@echo 'FLG -rectypes' > .merlin\n" ; List.iter (fun c -> printf "\t@echo \"B $(COQLIB)%s\" >> .merlin\n" c) lib_dirs ; List.iter (fun (_,c) -> printf "\t@echo \"B %s\" >> .merlin\n" c; printf "\t@echo \"S %s\" >> .merlin\n" c) ml_inc; print "\n" let do_makefile args = let has_file var = function |[] -> var := false |_::_ -> var := true in let (project_file,makefile,is_install,opt),l = try Project_file.process_cmd_line Filename.current_dir_name (None,None,Project_file.UnspecInstall,true) [] args with Project_file.Parsing_error -> usage () in let (v_f,(mli_f,ml4_f,ml_f,mllib_f,mlpack_f),sps,sds as targets), inc, defs = Project_file.split_arguments l in let () = match project_file with |None -> () |Some f -> make_name := f in let () = match makefile with |None -> () |Some f -> makefile_name := f; output_channel := open_out f in has_file some_vfile v_f; has_file some_mlifile mli_f; has_file some_mlfile ml_f; has_file some_ml4file ml4_f; has_file some_mllibfile mllib_f; has_file some_mlpackfile mlpack_f; let check_dep f = if Filename.check_suffix f ".v" then some_vfile := true else if (Filename.check_suffix f ".mli") then some_mlifile := true else if (Filename.check_suffix f ".ml4") then some_ml4file := true else if (Filename.check_suffix f ".ml") then some_mlfile := true else if (Filename.check_suffix f ".mllib") then some_mllibfile := true else if (Filename.check_suffix f ".mlpack") then some_mlpackfile := true in List.iter (fun (_,dependencies,_,_) -> List.iter check_dep (Str.split (Str.regexp "[ \t]+") dependencies)) sps; let inc = ensure_root_dir targets inc in if is_install <> Project_file.NoInstall then begin warn_install_at_root_directory targets inc; end; check_overlapping_include inc; banner (); header_includes (); warning (); command_line args; parameters (); include_dirs inc; variables is_install opt defs; all_target targets inc; section "Special targets."; standard opt; install targets inc is_install; merlin targets inc; clean sds sps; make_makefile sds; implicit (); warning (); if not (makefile = None) then close_out !output_channel; exit 0 let _ = let args = if Array.length Sys.argv = 1 then usage (); List.tl (Array.to_list Sys.argv) in do_makefile args coq-8.6/tools/update-require0000755000175000017500000000425413022274260015506 0ustar mdenesmdenes#!/bin/sh # This script fully qualifies all the 'Require' statements of the given # targets (or the current directory if none). # # It assumes that all the prerequisites are already installed. The # install location is found using the COQLIB, COQC, COQBIN variables if # set, 'coqc' otherwise. # # Option --exclude can be used to ignore a given user contribution. In # particular, it can be used to ignore the current set of files if it # happens to be already installed. # # Option --stdlib can be used to also qualify the files from the standard # library. if test ! "$COQLIB"; then if test ${COQBIN##*/}; then COQBIN=$COQBIN/; fi if test ! "$COQC"; then COQC=`which ${COQBIN}coqc`; fi COQLIB=`"$COQC" -where` fi stdlib=no exclude="" scan_dir () { (cd $1 ; find $3 -name '*.vo' | sed -e "s,^./,$2,;s,\([^./]*\)/,\1.,g;s,\([^.]*\).vo,\1,") } scan_all_dir () { if test $stdlib = yes; then scan_dir "$COQLIB/theories" "Coq." scan_dir "$COQLIB/plugins" "Coq." fi scan_dir "$COQLIB/user-contrib" "" "$exclude" } create_script () { echo "BEGIN {" scan_all_dir | while read file ; do echo $file | sed -e "s,\(.*\)[.]\([^.]*\), t[\"\2\"] = \"\1.\2\"," done cat <&2 exit 1;; *) dir="$dir $1";; esac shift done script=`tempfile` create_script > $script find $dir -name '*.v' | while read file; do mv $file $file.bak awk -f $script $file.bak > $file done coq-8.6/tools/beautify-archive0000755000175000017500000000405613022274260016001 0ustar mdenesmdenes#!/bin/sh #This script compiles and beautifies an archive, check the correctness #of beautified files, then replace the original files by the #beautified ones, keeping a copy of original files in $OLDARCHIVE. #The script assumes: #- that the archive provides a Makefile built by coq_makefile, #- that coqc is in the path or that variables COQTOP and COQBIN are set. OLDARCHIVE=old_files NEWARCHIVE=beautify_files BEAUTIFYSUFFIX=.beautified if [ -e $OLDARCHIVE ]; then echo "Warning: $OLDARCHIVE directory found, the files are maybe already beautified"; sleep 5; fi echo ---- Producing beautified files in the beautification directory ------- if [ -e $NEWARCHIVE ]; then rm -r $NEWARCHIVE; fi if [ -e /tmp/$OLDARCHIVE.$$ ]; then rm -r /tmp/$OLDARCHIVE.$$; fi cp -pr . /tmp/$OLDARCHIVE.$$ cp -pr /tmp/$OLDARCHIVE.$$ $NEWARCHIVE cd $NEWARCHIVE rm description || true make clean make COQFLAGS='-beautify -q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)' || \ { echo ---- Failed to beautify; exit 1; } echo -------- Upgrading files in the beautification directory -------------- beaufiles=`find . -name \*.v$BEAUTIFYSUFFIX` for i in $beaufiles; do j=`dirname $i`/`basename $i .v$BEAUTIFYSUFFIX`.v echo Upgrading $j in the beautification directory if [ $i -nt $j ]; then mv -f $i $j; fi done echo ---- Recompiling beautified files in the beautification directory ----- make clean make || { echo ---- Failed to recompile; exit 1; } echo ----- Saving old files in directory $OLDARCHIVE ------------------------- /bin/rm -r ../$OLDARCHIVE mv /tmp/$OLDARCHIVE.$$ ../$OLDARCHIVE echo Saving $OLDARCHIVE files done echo --------- Upgrading files in current directory ------------------------ vfiles=`find . -name \*.v` cd .. for i in $vfiles; do echo Upgrading $i in current directory if [ $NEWARCHIVE/$i -nt $i ]; then mv -f $NEWARCHIVE/$i $i; fi done echo -------- Beautification completed ------------------------------------- echo Old files are in directory '"'$OLDARCHIVE'"' echo New files are in current directory echo You can now remove the beautification directory '"'$NEWARCHIVE'"' coq-8.6/Makefile.build0000644000175000017500000005532113022274260014223 0ustar mdenesmdenes####################################################################### # v # The Coq Proof Assistant / The Coq Development Team # # timings.csv TIMED ?= # When $(TIMED) is set, the time command used by default is $(STDTIME) # (see below), unless the following variable is non-empty. For instance, # it could be set to "'/usr/bin/time -p'". TIMECMD ?= # Non-empty skips the update of all dependency .d files: NO_RECALC_DEPS ?= # Non-empty runs the checker on all produced .vo files: VALIDATE ?= # Is "-xml" when building XML library: COQ_XML ?= ########################################################################### # Default starting rule ########################################################################### # build the different subsystems: world: coq coqide documentation revision coq: coqlib coqbinaries tools printers .PHONY: world coq ########################################################################### # Includes ########################################################################### # This list of ml files used to be in the main Makefile, we moved it here # to avoid exhausting the variable env in Win32 MLFILES := $(MLSTATICFILES) $(GENMLFILES) $(ML4FILES:.ml4=.ml) include Makefile.common include Makefile.doc ## provides the 'documentation' rule include Makefile.checker include Makefile.ide ## provides the 'coqide' rule include Makefile.install include Makefile.dev ## provides the 'printers' and 'revision' rules # This include below will lauch the build of all .d. # The - at front is for disabling warnings about currently missing ones. # For creating the missing .d, make will recursively build things like # coqdep_boot (for the .v.d files) or grammar.cma (for .ml4 -> .ml -> .ml.d). DEPENDENCIES := \ $(addsuffix .d, $(MLFILES) $(MLIFILES) $(MLLIBFILES) $(CFILES) $(VFILES)) -include $(DEPENDENCIES) # All dependency includes must be declared secondary, otherwise make will # delete them if it decided to build them by dependency instead of because # of include, and they will then be automatically deleted, leading to an # infinite loop. .SECONDARY: $(DEPENDENCIES) $(GENFILES) $(ML4FILES:.ml4=.ml) ########################################################################### # Compilation options ########################################################################### # Default timing command STDTIME=/usr/bin/time -f "$* (user: %U mem: %M ko)" TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) # NB: do not use a variable named TIME, since this variable controls # the output format of the unix command time. For instance: # TIME="%C (%U user, %S sys, %e total, %M maxres)" COQOPTS=$(COQ_XML) $(NATIVECOMPUTE) BOOTCOQC=$(TIMER) $(COQTOPEXE) -boot $(COQOPTS) -compile LOCALINCLUDES=$(addprefix -I , $(SRCDIRS) ) MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB) OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) BYTEFLAGS=-thread $(CAMLDEBUG) $(USERFLAGS) OPTFLAGS=-thread $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) DEPFLAGS= $(LOCALINCLUDES) -I ide -I ide/utils # On MacOS, the binaries are signed, except our private ones ifeq ($(shell which codesign > /dev/null 2>&1 && echo $(ARCH)),Darwin) LINKMETADATA=$(if $(filter $(PRIVATEBINARIES),$@),,-ccopt "-sectcreate __TEXT __info_plist config/Info-$(notdir $@).plist") CODESIGN=$(if $(filter $(PRIVATEBINARIES),$@),true,codesign -s -) else LINKMETADATA= CODESIGN=true endif # Best OCaml compiler, used in a generic way ifeq ($(BEST),opt) OPT:=opt BESTOBJ:=.cmx BESTLIB:=.cmxa BESTDYN:=.cmxs else OPT:= BESTOBJ:=.cmo BESTLIB:=.cma BESTDYN:=.cma endif define bestobj $(patsubst %.cma,%$(BESTLIB),$(patsubst %.cmo,%$(BESTOBJ),$(1))) endef define bestocaml $(if $(OPT),\ $(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) $(LINKMETADATA) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@ && $(CODESIGN) $@,\ $(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ $(1) $(addsuffix .cma,$(2)) $^) endef # Camlp4 / Camlp5 settings CAMLP4DEPS:=grammar/compat5.cmo grammar/grammar.cma ifeq ($(CAMLP4),camlp5) CAMLP4USE=pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION) else CAMLP4USE=-D$(CAMLVERSION) endif PR_O := $(if $(READABLE_ML4),pr_o.cmo,pr_dump.cmo) SYSMOD:=str unix dynlink threads SYSCMA:=$(addsuffix .cma,$(SYSMOD)) SYSCMXA:=$(addsuffix .cmxa,$(SYSMOD)) # We do not repeat the dependencies already in SYSMOD here ifeq ($(CAMLP4),camlp5) P4CMA:=gramlib.cma else P4CMA:=camlp4lib.cma endif ########################################################################### # Infrastructure for the rest of the Makefile ########################################################################### # The SHOW and HIDE variables control whether make will echo complete commands # or only abbreviated versions. # Quiet mode is ON by default except if VERBOSE=1 option is given to make SHOW := $(if $(VERBOSE),@true "",@echo "") HIDE := $(if $(VERBOSE),,@) define order-only-template ifeq "order-only" "$(1)" ORDER_ONLY_SEP:=| endif endef $(foreach f,$(.FEATURES),$(eval $(call order-only-template,$(f)))) ifndef ORDER_ONLY_SEP $(error This Makefile needs GNU Make 3.81 or later (that is a version that supports the order-only dependency feature without major bugs.)) endif VO_TOOLS_DEP := $(COQTOPEXE) ifdef COQ_XML VO_TOOLS_DEP += $(COQDOC) endif ifdef VALIDATE VO_TOOLS_DEP += $(CHICKEN) endif D_DEPEND_BEFORE_SRC := $(if $(NO_RECALC_DEPS),|,) D_DEPEND_AFTER_SRC := $(if $(NO_RECALC_DEPS),,|) ## When a rule redirects stdout of a command to the target file : cmd > $@ ## then the target file will be created even if cmd has failed. ## Hence relaunching make will go further, as make thinks the target has been ## done ok. To avoid this, we use the following macro: TOTARGET = > "$@" || (RV=$$?; rm -f "$@"; exit $${RV}) ########################################################################### # Compilation of .c files ########################################################################### CINCLUDES= -I $(CAMLHLIB) # NB: We used to do a ranlib after ocamlmklib, but it seems that # ocamlmklib is already doing it $(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN) cd $(dir $(LIBCOQRUN)) && \ $(OCAMLFIND) ocamlmklib -oc $(COQRUN) $(foreach u,$(BYTERUN),$(notdir $(u))) kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h sed -n -e '/^ /s/ \([A-Z]\)/ \&\&coq_lbl_\1/gp' \ -e '/^}/q' $< $(TOTARGET) kernel/copcodes.ml: kernel/byterun/coq_instruct.h sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' $< | \ awk -f kernel/make-opcodes $(TOTARGET) %.o: %.c $(SHOW)'OCAMLC $<' $(HIDE)cd $(dir $<) && $(OCAMLC) -ccopt "$(CFLAGS)" -c $(notdir $<) %_stubs.c.d: $(D_DEPEND_BEFORE_SRC) %_stubs.c $(D_DEPEND_AFTER_SRC) $(SHOW)'CCDEP $<' $(HIDE)echo "$@ $(@:.c.d=.o): $(@:.c.d=.c)" > $@ %.c.d: $(D_DEPEND_BEFORE_SRC) %.c $(D_DEPEND_AFTER_SRC) $(GENHFILES) $(SHOW)'CCDEP $<' $(HIDE)$(OCAMLC) -ccopt "-MM -MQ $@ -MQ $(<:.c=.o) -isystem $(CAMLHLIB)" $< $(TOTARGET) ########################################################################### ### Special rules (Camlp5 / Camlp4) ########################################################################### # Special rule for the compatibility-with-camlp5 extension for camlp4 # # - grammar/compat5.cmo changes 'GEXTEND' into 'EXTEND'. Safe, always loaded # - grammar/compat5b.cmo changes 'EXTEND' into 'EXTEND Gram'. Interact badly with # syntax such that 'VERNAC EXTEND', we only load it in grammar/ ifeq ($(CAMLP4),camlp4) grammar/compat5.cmo: grammar/compat5.mlp $(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) -I $(MYCAMLP4LIB) -impl' -impl $< grammar/compat5b.cmo: grammar/compat5b.mlp $(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) -I $(MYCAMLP4LIB) -impl' -impl $< else grammar/compat5.cmo: grammar/compat5.ml $(OCAMLC) -c $< endif ########################################################################### # grammar/grammar.cma ########################################################################### ## In this part, we compile grammar/grammar.cma ## without relying on .d dependency files, for bootstraping the creation ## and inclusion of these .d files ## Explicit dependencies for grammar stuff GRAMBASEDEPS := grammar/gramCompat.cmo grammar/q_util.cmi GRAMCMO := grammar/gramCompat.cmo grammar/q_util.cmo \ grammar/argextend.cmo grammar/tacextend.cmo grammar/vernacextend.cmo grammar/q_util.cmi : grammar/gramCompat.cmo grammar/argextend.cmo : $(GRAMBASEDEPS) grammar/q_util.cmo : $(GRAMBASEDEPS) grammar/tacextend.cmo : $(GRAMBASEDEPS) grammar/argextend.cmo grammar/vernacextend.cmo : $(GRAMBASEDEPS) grammar/tacextend.cmo \ grammar/argextend.cmo ## Ocaml compiler with the right options and -I for grammar GRAMC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) $(CAMLDEBUG) $(USERFLAGS) \ -I $(MYCAMLP4LIB) -I grammar ## Specific rules for grammar.cma grammar/grammar.cma : $(GRAMCMO) $(SHOW)'Testing $@' @touch grammar/test.mlp $(HIDE)$(GRAMC) -pp '$(CAMLP4O) -I $(MYCAMLP4LIB) $^ -impl' -impl grammar/test.mlp -o grammar/test @rm -f grammar/test.* grammar/test $(SHOW)'OCAMLC -a $@' $(HIDE)$(GRAMC) $^ -linkall -a -o $@ ## Support of Camlp5 and Camlp5 ifeq ($(CAMLP4),camlp4) COMPATCMO:=grammar/compat5.cmo grammar/compat5b.cmo GRAMP4USE:=$(COMPATCMO) -D$(CAMLVERSION) GRAMPP:=$(CAMLP4O) -I $(MYCAMLP4LIB) $(GRAMP4USE) $(CAMLP4COMPAT) -impl else COMPATCMO:= GRAMP4USE:=$(COMPATCMO) pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION) GRAMPP:=$(CAMLP4O) -I $(MYCAMLP4LIB) $(GRAMP4USE) $(CAMLP4COMPAT) -impl endif ## Rules for standard .mlp and .mli files in grammar/ grammar/%.cmo: grammar/%.mlp | $(COMPATCMO) $(SHOW)'OCAMLC -c -pp $<' $(HIDE)$(GRAMC) -c -pp '$(GRAMPP)' -impl $< grammar/%.cmi: grammar/%.mli $(SHOW)'OCAMLC -c $<' $(HIDE)$(GRAMC) -c $< ########################################################################### # Main targets (coqmktop, coqtop.opt, coqtop.byte) ########################################################################### .PHONY: coqbinaries coqbinaries: $(COQMKTOP) $(COQTOPEXE) $(COQTOPBYTE) \ $(CHICKEN) $(CHICKENBYTE) $(CSDPCERT) $(FAKEIDE) ifeq ($(BEST),opt) $(COQTOPEXE): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(TOPLOOPCMA:.cma=.cmxs) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(COQMKTOP) -boot -opt $(OPTFLAGS) $(LINKMETADATA) -o $@ $(STRIP) $@ $(CODESIGN) $@ else $(COQTOPEXE): $(COQTOPBYTE) cp $< $@ endif $(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(TOPLOOPCMA) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -o $@ # coqmktop COQMKTOPCMO:=lib/clib.cma lib/cErrors.cmo tools/tolink.cmo tools/coqmktop.cmo $(COQMKTOP): $(call bestobj, $(COQMKTOPCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) tools/tolink.ml: Makefile.build Makefile.common $(SHOW)"ECHO... >" $@ $(HIDE)echo "let copts = \"-cclib -lcoqrun\"" > $@ $(HIDE)echo "let core_libs = \""$(LINKCMO)"\"" >> $@ $(HIDE)echo "let core_objs = \""$(OBJSMOD)"\"" >> $@ # coqc COQCCMO:=lib/clib.cma lib/cErrors.cmo toplevel/usage.cmo tools/coqc.cmo $(COQC): $(call bestobj, $(COQCCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) ########################################################################### # other tools ########################################################################### .PHONY: tools tools: $(TOOLS) $(OCAMLLIBDEP) $(COQDEPBOOT) # coqdep_boot : a basic version of coqdep, with almost no dependencies. # We state these dependencies here explicitly, since some .ml.d files # may still be missing or not taken in account yet by make when coqdep_boot # is being built. COQDEPBOOTSRC := lib/minisys.cmo \ tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep_boot.cmo tools/coqdep_lexer.cmo : tools/coqdep_lexer.cmi tools/coqdep_lexer.cmx : tools/coqdep_lexer.cmi tools/coqdep_common.cmo : lib/minisys.cmo tools/coqdep_lexer.cmi tools/coqdep_common.cmi tools/coqdep_common.cmx : lib/minisys.cmx tools/coqdep_lexer.cmx tools/coqdep_common.cmi tools/coqdep_boot.cmo : tools/coqdep_common.cmi tools/coqdep_boot.cmx : tools/coqdep_common.cmx $(COQDEPBOOT): $(call bestobj, $(COQDEPBOOTSRC)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I tools, unix) $(OCAMLLIBDEP): $(call bestobj, tools/ocamllibdep.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I tools, unix) # The full coqdep (unused by this build, but distributed by make install) COQDEPCMO:=lib/clib.cma lib/cErrors.cmo lib/cWarnings.cmo lib/minisys.cmo \ lib/system.cmo tools/coqdep_lexer.cmo tools/coqdep_common.cmo \ tools/coqdep.cmo $(COQDEP): $(call bestobj, $(COQDEPCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) $(GALLINA): $(call bestobj, tools/gallina_lexer.cmo tools/gallina.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,) COQMAKEFILECMO:=lib/clib.cma ide/project_file.cmo tools/coq_makefile.cmo $(COQMAKEFILE): $(call bestobj,$(COQMAKEFILECMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,str unix threads) $(COQTEX): $(call bestobj, tools/coq_tex.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,str) $(COQWC): $(call bestobj, tools/coqwc.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,) COQDOCCMO:=lib/clib.cma $(addprefix tools/coqdoc/, \ cdglobals.cmo alpha.cmo index.cmo tokens.cmo output.cmo cpretty.cmo main.cmo ) $(COQDOC): $(call bestobj, $(COQDOCCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,str unix) $(COQWORKMGR): $(call bestobj, lib/clib.cma stm/coqworkmgrApi.cmo tools/coqworkmgr.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,, $(SYSMOD)) # fake_ide : for debugging or test-suite purpose, a fake ide simulating # a connection to coqtop -ideslave FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo ide/document.cmo \ ide/serialize.cmo ide/xml_lexer.cmo ide/xml_parser.cmo ide/xml_printer.cmo \ ide/xmlprotocol.cmo tools/fake_ide.cmo $(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOPLOOPCMA:.cma=$(BESTDYN)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,-I ide,str unix threads) # votour: a small vo explorer (based on the checker) bin/votour: $(call bestobj, lib/cObj.cmo checker/analyze.cmo checker/values.cmo checker/votour.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I checker,) ########################################################################### # Csdp to micromega special targets ########################################################################### CSDPCERTCMO:=lib/clib.cma $(addprefix plugins/micromega/, \ mutils.cmo micromega.cmo \ sos_types.cmo sos_lib.cmo sos.cmo csdpcert.cmo ) $(CSDPCERT): $(call bestobj, $(CSDPCERTCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,nums unix) ########################################################################### # tests ########################################################################### .PHONY: validate check test-suite $(ALLSTDLIB).v VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m validate: $(CHICKEN) | $(ALLVO) $(SHOW)'COQCHK ' $(HIDE)$(CHICKEN) -boot $(VALIDOPTS) $(ALLMODS) $(ALLSTDLIB).v: $(SHOW)'MAKE $(notdir $@)' $(HIDE)echo "Require $(ALLMODS)." > $@ MAKE_TSOPTS=-C test-suite -s VERBOSE=$(VERBOSE) check: validate test-suite test-suite: world $(ALLSTDLIB).v $(MAKE) $(MAKE_TSOPTS) clean $(MAKE) $(MAKE_TSOPTS) all $(MAKE) $(MAKE_TSOPTS) report ########################################################################### # Default rules for compiling ML code ########################################################################### # Target for libraries .cma and .cmxa # The dependency over the .mllib is somewhat artificial, since # ocamlc -a won't use this file, hence the $(filter-out ...) below. # But this ensures that the .cm(x)a is rebuilt when needed, # (especially when removing a module in the .mllib). # We used to have a "order-only" dependency over .mllib.d here, # but the -include mechanism should already ensure that we have # up-to-date dependencies. %.cma: %.mllib $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) %.cmxa: %.mllib $(SHOW)'OCAMLOPT -a -o $@' $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -a -o $@ $(filter-out %.mllib, $^) # For plugin packs # Note: both ocamlc -pack and ocamlopt -pack will create the same .cmi, and there's # apparently no way to avoid that (no -intf-suffix hack as below). # We at least ensure that these two commands won't run at the same time, by a fake # dependency from the packed .cmx to the packed .cmo. %.cmo: %.mlpack $(SHOW)'OCAMLC -pack -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -pack -o $@ $(filter-out %.mlpack, $^) %.cmx: %.mlpack %.cmo $(SHOW)'OCAMLOPT -pack -o $@' $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -pack -o $@ $(filter-out %.mlpack %.cmo, $^) COND_BYTEFLAGS= \ $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) $(BYTEFLAGS) COND_OPTFLAGS= \ $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) $(OPTFLAGS) %.cmi: %.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< %.cmo: %.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< ## NB: for the moment ocamlopt erases and recreates .cmi if there's no .mli around. ## This can lead to nasty things with make -j. To avoid that: ## 1) We make .cmx always depend on .cmi ## 2) This .cmi will be created from the .mli, or trigger the compilation of the ## .cmo if there's no .mli (see rule below about MLWITHOUTMLI) ## 3) We tell ocamlopt to use the .cmi as the interface source file. With this ## hack, everything goes as if there is a .mli, and the .cmi is preserved ## and the .cmx is checked with respect to this .cmi HACKMLI = $(if $(wildcard $= 3.12) OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack %.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(GENFILES) $(SHOW)'OCAMLDEP $<' $(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" $(TOTARGET) %.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(GENFILES) $(SHOW)'OCAMLDEP $<' $(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" $(TOTARGET) %.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) $(SHOW)'OCAMLLIBDEP $<' $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(TOTARGET) %.mlpack.d: $(D_DEPEND_BEFORE_SRC) %.mlpack $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) $(SHOW)'OCAMLLIBDEP $<' $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(TOTARGET) ########################################################################### # Compilation of .v files ########################################################################### # NB: for make world, no need to mention explicitly the .cmxs of the plugins, # since they are all mentioned in at least one Declare ML Module in some .v coqlib: theories plugins theories: $(THEORIESVO) plugins: $(PLUGINSVO) .PHONY: coqlib theories plugins # One of the .v files is macro-generated theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml $(OCAML) $< $(TOTARGET) # The .vo files in Init are built with the -noinit option theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) $(SHOW)'COQC $(COQ_XML) -noinit $<' $(HIDE)rm -f theories/Init/$*.glob $(HIDE)$(BOOTCOQC) $< $(COQ_XML) -noinit -R theories Coq # The general rule for building .vo files : %.vo %.glob: %.v theories/Init/Prelude.vo $(VO_TOOLS_DEP) $(SHOW)'COQC $<' $(HIDE)rm -f $*.glob $(HIDE)$(BOOTCOQC) $< ifdef VALIDATE $(SHOW)'COQCHK $(call vo_to_mod,$@)' $(HIDE)$(CHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \ || ( RV=$$?; rm -f "$@"; exit $${RV} ) endif # Dependencies of .v files %.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENVFILES) $(SHOW)'COQDEP $<' $(HIDE)$(COQDEPBOOT) -boot $(DEPNATDYN) "$<" $(TOTARGET) ########################################################################### # To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles Makefile $(wildcard Makefile.*) config/Makefile : ; # Final catch-all rule. # Usually, 'make' would display such an error itself. # But if the target has some declared dependencies (e.g. in a .d) # but no building rule, 'make' succeeds silently (see bug #4812). %: @echo "Error: no rule to make target $@ (or missing .PHONY)" && false # For emacs: # Local Variables: # mode: makefile # End: coq-8.6/.gitattributes0000644000175000017500000000017513022274260014355 0ustar mdenesmdenes.dir-locals.el export-ignore .gitattributes export-ignore .gitignore export-ignore .mailmap export-ignore TODO export-ignore coq-8.6/ltac/0000755000175000017500000000000013022274260012402 5ustar mdenesmdenescoq-8.6/ltac/tactic_option.ml0000644000175000017500000000365213022274260015601 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* obj = declare_object { (default_object name) with cache_function = cache; load_function = (fun _ -> load); open_function = (fun _ -> load); classify_function = (fun (local, tac) -> if local then Dispose else Substitute (local, tac)); subst_function = subst} in let put local tac = set_default_tactic local tac; Lib.add_anonymous_leaf (input (local, tac)) in let get () = !locality, Tacinterp.eval_tactic !default_tactic in let print () = Pptactic.pr_glob_tactic (Global.env ()) !default_tactic_expr ++ (if !locality then str" (locally defined)" else str" (globally defined)") in put, get, print coq-8.6/ltac/g_class.ml40000644000175000017500000000743413022274260014443 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let gr = Smartlocate.global_with_alias r in let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in Classes.set_typeclass_transparency ev false b) cl VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF | [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ set_transparency cl true ] END VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings CLASSIFIED AS SIDEFF | [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ set_transparency cl false ] END open Genarg let pr_debug _prc _prlc _prt b = if b then Pp.str "debug" else Pp.mt() ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug | [ "debug" ] -> [ true ] | [ ] -> [ false ] END let pr_search_strategy _prc _prlc _prt = function | Some Dfs -> Pp.str "dfs" | Some Bfs -> Pp.str "bfs" | None -> Pp.mt () ARGUMENT EXTEND eauto_search_strategy PRINTED BY pr_search_strategy | [ "(bfs)" ] -> [ Some Bfs ] | [ "(dfs)" ] -> [ Some Dfs ] | [ ] -> [ None ] END (* true = All transparent, false = Opaque if possible *) VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> [ set_typeclasses_debug d; Option.iter set_typeclasses_strategy s; set_typeclasses_depth depth ] END (** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *) TACTIC EXTEND typeclasses_eauto | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] -> [ typeclasses_eauto ~strategy:Bfs ~depth:d l ] | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> [ typeclasses_eauto ~depth:d l ] | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> [ typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] ] END TACTIC EXTEND head_of_constr [ "head_of_constr" ident(h) constr(c) ] -> [ head_of_constr h c ] END TACTIC EXTEND not_evar [ "not_evar" constr(ty) ] -> [ not_evar ty ] END TACTIC EXTEND is_ground [ "is_ground" constr(ty) ] -> [ Proofview.V82.tactic (is_ground ty) ] END TACTIC EXTEND autoapply [ "autoapply" constr(c) "using" preident(i) ] -> [ Proofview.V82.tactic (autoapply c i) ] END (** TODO: DEPRECATE *) (* A progress test that allows to see if the evars have changed *) open Term open Proofview.Goal open Proofview.Notations let rec eq_constr_mod_evars x y = match kind_of_term x, kind_of_term y with | Evar (e1, l1), Evar (e2, l2) when not (Evar.equal e1 e2) -> true | _, _ -> compare_constr eq_constr_mod_evars x y let progress_evars t = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let check = Proofview.Goal.nf_enter { enter = begin fun gl' -> let newconcl = Proofview.Goal.concl gl' in if eq_constr_mod_evars concl newconcl then Tacticals.New.tclFAIL 0 (Pp.str"No progress made (modulo evars)") else Proofview.tclUNIT () end } in t <*> check end } TACTIC EXTEND progress_evars [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ] END coq-8.6/ltac/tacenv.mli0000644000175000017500000000534013022274260014367 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* alias_tactic -> unit (** Register a tactic alias. *) val interp_alias : alias -> alias_tactic (** Recover the the body of an alias. Raises an anomaly if it does not exist. *) val check_alias : alias -> bool (** Returns [true] if an alias is defined, false otherwise. *) (** {5 Coq tactic definitions} *) val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit (** Register a new Ltac with the given name and body. The first boolean indicates whether this is done from ML side, rather than Coq side. If the second boolean flag is set to true, then this is a local definition. It also puts the Ltac name in the nametab, so that it can be used unqualified. *) val redefine_ltac : bool -> KerName.t -> glob_tactic_expr -> unit (** Replace a Ltac with the given name and body. If the boolean flag is set to true, then this is a local redefinition. *) val interp_ltac : KerName.t -> glob_tactic_expr (** Find a user-defined tactic by name. Raise [Not_found] if it is absent. *) val is_ltac_for_ml_tactic : KerName.t -> bool (** Whether the tactic is defined from ML-side *) type ltac_entry = { tac_for_ml : bool; (** Whether the tactic is defined from ML-side *) tac_body : glob_tactic_expr; (** The current body of the tactic *) tac_redef : ModPath.t list; (** List of modules redefining the tactic in reverse chronological order *) } val ltac_entries : unit -> ltac_entry KNmap.t (** Low-level access to all Ltac entries currently defined. *) (** {5 ML tactic extensions} *) type ml_tactic = Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic (** Type of external tactics, used by [TacML]. *) val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic array -> unit (** Register an external tactic. *) val interp_ml_tactic : ml_tactic_entry -> ml_tactic (** Get the named tactic. Raises a user error if it does not exist. *) coq-8.6/ltac/tacinterp.ml0000644000175000017500000024321413022274260014733 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* a typed_abstract_argument_type -> bool = fun v wit -> let Val.Dyn (t, _) = v in let t' = match val_tag wit with | Val.Base t' -> t' | _ -> assert false (** not used in this module *) in match Val.eq t t' with | None -> false | Some Refl -> true let prj : type a. a Val.typ -> Val.t -> a option = fun t v -> let Val.Dyn (t', x) = v in match Val.eq t t' with | None -> None | Some Refl -> Some x let in_list tag v = let tag = match tag with Val.Base tag -> tag | _ -> assert false in Val.Dyn (Val.typ_list, List.map (fun x -> Val.Dyn (tag, x)) v) let in_gen wit v = let t = match val_tag wit with | Val.Base t -> t | _ -> assert false (** not used in this module *) in Val.Dyn (t, v) let out_gen wit v = let t = match val_tag wit with | Val.Base t -> t | _ -> assert false (** not used in this module *) in match prj t v with None -> assert false | Some x -> x let val_tag wit = val_tag (topwit wit) let pr_argument_type arg = let Val.Dyn (tag, _) = arg in Val.pr tag let safe_msgnl s = Proofview.NonLogical.catch (Proofview.NonLogical.print_debug (s++fnl())) (fun _ -> Proofview.NonLogical.print_warning (str "bug in the debugger: an exception is raised while printing debug information"++fnl())) type value = Val.t (** Abstract application, to print ltac functions *) type appl = | UnnamedAppl (** For generic applications: nothing is printed *) | GlbAppl of (Names.kernel_name * Val.t list) list (** For calls to global constants, some may alias other. *) let push_appl appl args = match appl with | UnnamedAppl -> UnnamedAppl | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l) let pr_generic arg = let Val.Dyn (tag, _) = arg in str"<" ++ Val.pr tag ++ str ":(" ++ Pptactic.pr_value Pptactic.ltop arg ++ str ")>" let pr_appl h vs = Pptactic.pr_ltac_constant h ++ spc () ++ Pp.prlist_with_sep spc pr_generic vs let rec name_with_list appl t = match appl with | [] -> t | (h,vs)::l -> Proofview.Trace.name_tactic (fun () -> pr_appl h vs) (name_with_list l t) let name_if_glob appl t = match appl with | UnnamedAppl -> t | GlbAppl l -> name_with_list l t let combine_appl appl1 appl2 = match appl1,appl2 with | UnnamedAppl,a | a,UnnamedAppl -> a | GlbAppl l1 , GlbAppl l2 -> GlbAppl (l2@l1) (* Values for interpretation *) type tacvalue = | VFun of appl*ltac_trace * value Id.Map.t * Id.t option list * glob_tactic_expr | VRec of value Id.Map.t ref * glob_tactic_expr let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = let wit = Genarg.create_arg "tacvalue" in let () = register_val0 wit None in wit let of_tacvalue v = in_gen (topwit wit_tacvalue) v let to_tacvalue v = out_gen (topwit wit_tacvalue) v (** More naming applications *) let name_vfun appl vle = let vle = Value.normalize vle in if has_type vle (topwit wit_tacvalue) then match to_tacvalue vle with | VFun (appl0,trace,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,lfun,vars,t)) | _ -> vle else vle module TacStore = Geninterp.TacStore let f_avoid_ids : Id.t list TacStore.field = TacStore.field () (* ids inherited from the call context (needed to get fresh ids) *) let f_debug : debug_info TacStore.field = TacStore.field () let f_trace : ltac_trace TacStore.field = TacStore.field () (* Signature for interpretation: val_interp and interpretation functions *) type interp_sign = Geninterp.interp_sign = { lfun : value Id.Map.t; extra : TacStore.t } let extract_trace ist = match TacStore.get ist.extra f_trace with | None -> [] | Some l -> l module Value = struct include Taccoerce.Value let of_closure ist tac = let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in of_tacvalue closure let cast_error wit v = let pr_v = Pptactic.pr_value Pptactic.ltop v in let Val.Dyn (tag, _) = v in let tag = Val.pr tag in errorlabstrm "" (str "Type error: value " ++ pr_v ++ str " is a " ++ tag ++ str " while type " ++ Val.pr wit ++ str " was expected.") let unbox wit v ans = match ans with | None -> cast_error wit v | Some x -> x let rec prj : type a. a Val.tag -> Val.t -> a = fun tag v -> match tag with | Val.List tag -> List.map (fun v -> prj tag v) (unbox Val.typ_list v (to_list v)) | Val.Opt tag -> Option.map (fun v -> prj tag v) (unbox Val.typ_opt v (to_option v)) | Val.Pair (tag1, tag2) -> let (x, y) = unbox Val.typ_pair v (to_pair v) in (prj tag1 x, prj tag2 y) | Val.Base t -> let Val.Dyn (t', x) = v in match Val.eq t t' with | None -> cast_error t v | Some Refl -> x let rec tag_of_arg : type a b c. (a, b, c) genarg_type -> c Val.tag = fun wit -> match wit with | ExtraArg _ -> val_tag wit | ListArg t -> Val.List (tag_of_arg t) | OptArg t -> Val.Opt (tag_of_arg t) | PairArg (t1, t2) -> Val.Pair (tag_of_arg t1, tag_of_arg t2) let val_cast arg v = prj (tag_of_arg arg) v let cast (Topwit wit) v = val_cast wit v end let print_top_val env v = Pptactic.pr_value Pptactic.ltop v let dloc = Loc.ghost let catching_error call_trace fail (e, info) = let inner_trace = Option.default [] (Exninfo.get info ltac_trace_info) in if List.is_empty call_trace && List.is_empty inner_trace then fail (e, info) else begin assert (CErrors.noncritical e); (* preserved invariant *) let new_trace = inner_trace @ call_trace in let located_exc = (e, Exninfo.add info ltac_trace_info new_trace) in fail located_exc end let catch_error call_trace f x = try f x with e when CErrors.noncritical e -> let e = CErrors.push e in catching_error call_trace iraise e let catch_error_tac call_trace tac = Proofview.tclORELSE tac (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) let curr_debug ist = match TacStore.get ist.extra f_debug with | None -> DebugOff | Some level -> level (** TODO: unify printing of generic Ltac values in case of coercion failure. *) (* Displays a value *) let pr_value env v = let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then str "a tactic" else if has_type v (topwit wit_constr_context) then let c = out_gen (topwit wit_constr_context) v in match env with | Some (env,sigma) -> pr_lconstr_env env sigma c | _ -> str "a term" else if has_type v (topwit wit_constr) then let c = out_gen (topwit wit_constr) v in match env with | Some (env,sigma) -> pr_lconstr_env env sigma c | _ -> str "a term" else if has_type v (topwit wit_constr_under_binders) then let c = out_gen (topwit wit_constr_under_binders) v in match env with | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c | _ -> str "a term" else str "a value of type" ++ spc () ++ pr_argument_type v let pr_closure env ist body = let pp_body = Pptactic.pr_glob_tactic env body in let pr_sep () = fnl () in let pr_iarg (id, arg) = let arg = pr_argument_type arg in hov 0 (pr_id id ++ spc () ++ str ":" ++ spc () ++ arg) in let pp_iargs = v 0 (prlist_with_sep pr_sep pr_iarg (Id.Map.bindings ist)) in pp_body ++ fnl() ++ str "in environment " ++ fnl() ++ pp_iargs let pr_inspect env expr result = let pp_expr = Pptactic.pr_glob_tactic env expr in let pp_result = if has_type result (topwit wit_tacvalue) then match to_tacvalue result with | VFun (_,_, ist, ul, b) -> let body = if List.is_empty ul then b else (TacFun (ul, b)) in str "a closure with body " ++ fnl() ++ pr_closure env ist body | VRec (ist, body) -> str "a recursive closure" ++ fnl () ++ pr_closure env !ist body else let pp_type = pr_argument_type result in str "an object of type" ++ spc () ++ pp_type in pp_expr ++ fnl() ++ str "this is " ++ pp_result (* Transforms an id into a constr if possible, or fails with Not_found *) let constr_of_id env id = Term.mkVar (let _ = Environ.lookup_named id env in id) (** Generic arguments : table of interpretation functions *) (* Some of the code further down depends on the fact that push_trace does not modify sigma (the evar map) *) let push_trace call ist = match TacStore.get ist.extra f_trace with | None -> Proofview.tclUNIT [call] | Some trace -> Proofview.tclUNIT (call :: trace) let propagate_trace ist loc id v = let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then let tacv = to_tacvalue v in match tacv with | VFun (appl,_,lfun,it,b) -> let t = if List.is_empty it then b else TacFun (it,b) in push_trace(loc,LtacVarCall (id,t)) ist >>= fun trace -> let ans = VFun (appl,trace,lfun,it,b) in Proofview.tclUNIT (of_tacvalue ans) | _ -> Proofview.tclUNIT v else Proofview.tclUNIT v let append_trace trace v = let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then match to_tacvalue v with | VFun (appl,trace',lfun,it,b) -> of_tacvalue (VFun (appl,trace'@trace,lfun,it,b)) | _ -> v else v (* Dynamically check that an argument is a tactic *) let coerce_to_tactic loc id v = let v = Value.normalize v in let fail () = user_err_loc (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") in let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then let tacv = to_tacvalue v in match tacv with | VFun _ -> v | _ -> fail () else fail () let intro_pattern_of_ident id = (Loc.ghost, IntroNaming (IntroIdentifier id)) let value_of_ident id = in_gen (topwit wit_intro_pattern) (intro_pattern_of_ident id) let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 let extend_values_with_bindings (ln,lm) lfun = let of_cub c = match c with | [], c -> Value.of_constr c | _ -> in_gen (topwit wit_constr_under_binders) c in (* For compatibility, bound variables are visible only if no other binding of the same name exists *) let accu = Id.Map.map value_of_ident ln in let accu = lfun +++ accu in Id.Map.fold (fun id c accu -> Id.Map.add id (of_cub c) accu) lm accu (***************************************************************************) (* Evaluation/interpretation *) let is_variable env id = Id.List.mem id (ids_of_named_context (Environ.named_context env)) (* Debug reference *) let debug = ref DebugOff (* Sets the debugger mode *) let set_debug pos = debug := pos (* Gives the state of debug *) let get_debug () = !debug let debugging_step ist pp = match curr_debug ist with | DebugOn lev -> safe_msgnl (str "Level " ++ int lev ++ str": " ++ pp () ++ fnl()) | _ -> Proofview.NonLogical.return () let debugging_exception_step ist signal_anomaly e pp = let explain_exc = if signal_anomaly then explain_logic_error else explain_logic_error_no_anomaly in debugging_step ist (fun () -> pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) let error_ltac_variable loc id env v s = user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ strbrk "which cannot be coerced to " ++ str s ++ str".") (* Raise Not_found if not in interpretation sign *) let try_interp_ltac_var coerce ist env (loc,id) = let v = Id.Map.find id ist.lfun in try coerce v with CannotCoerceTo s -> error_ltac_variable loc id env v s let interp_ltac_var coerce ist env locid = try try_interp_ltac_var coerce ist env locid with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time") let interp_ident ist env sigma id = try try_interp_ltac_var (coerce_var_to_ident false env) ist (Some (env,sigma)) (dloc,id) with Not_found -> id let pf_interp_ident id gl = interp_ident id (pf_env gl) (project gl) (* Interprets an optional identifier, bound or fresh *) let interp_name ist env sigma = function | Anonymous -> Anonymous | Name id -> Name (interp_ident ist env sigma id) let interp_intro_pattern_var loc ist env sigma id = try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some (env,sigma)) (loc,id) with Not_found -> IntroNaming (IntroIdentifier id) let interp_intro_pattern_naming_var loc ist env sigma id = try try_interp_ltac_var (coerce_to_intro_pattern_naming env) ist (Some (env,sigma)) (loc,id) with Not_found -> IntroIdentifier id let interp_int ist locid = try try_interp_ltac_var coerce_to_int ist None locid with Not_found -> user_err_loc(fst locid,"interp_int", str "Unbound variable " ++ pr_id (snd locid) ++ str".") let interp_int_or_var ist = function | ArgVar locid -> interp_int ist locid | ArgArg n -> n let interp_int_or_var_as_list ist = function | ArgVar (_,id as locid) -> (try coerce_to_int_or_var_list (Id.Map.find id ist.lfun) with Not_found | CannotCoerceTo _ -> [ArgArg (interp_int ist locid)]) | ArgArg n as x -> [x] let interp_int_or_var_list ist l = List.flatten (List.map (interp_int_or_var_as_list ist) l) (* Interprets a bound variable (especially an existing hypothesis) *) let interp_hyp ist env sigma (loc,id as locid) = (* Look first in lfun for a value coercible to a variable *) try try_interp_ltac_var (coerce_to_hyp env) ist (Some (env,sigma)) locid with Not_found -> (* Then look if bound in the proof context at calling time *) if is_variable env id then id else Loc.raise loc (Logic.RefinerError (Logic.NoSuchHyp id)) let interp_hyp_list_as_list ist env sigma (loc,id as x) = try coerce_to_hyp_list env (Id.Map.find id ist.lfun) with Not_found | CannotCoerceTo _ -> [interp_hyp ist env sigma x] let interp_hyp_list ist env sigma l = List.flatten (List.map (interp_hyp_list_as_list ist env sigma) l) let interp_move_location ist env sigma = function | MoveAfter id -> MoveAfter (interp_hyp ist env sigma id) | MoveBefore id -> MoveBefore (interp_hyp ist env sigma id) | MoveFirst -> MoveFirst | MoveLast -> MoveLast let interp_reference ist env sigma = function | ArgArg (_,r) -> r | ArgVar (loc, id) -> try try_interp_ltac_var (coerce_to_reference env) ist (Some (env,sigma)) (loc, id) with Not_found -> try VarRef (get_id (Environ.lookup_named id env)) with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) let try_interp_evaluable env (loc, id) = let v = Environ.lookup_named id env in match v with | LocalDef _ -> EvalVarRef id | _ -> error_not_evaluable (VarRef id) let interp_evaluable ist env sigma = function | ArgArg (r,Some (loc,id)) -> (* Maybe [id] has been introduced by Intro-like tactics *) begin try try_interp_evaluable env (loc, id) with Not_found -> match r with | EvalConstRef _ -> r | _ -> error_global_not_found_loc loc (qualid_of_ident id) end | ArgArg (r,None) -> r | ArgVar (loc, id) -> try try_interp_ltac_var (coerce_to_evaluable_ref env) ist (Some (env,sigma)) (loc, id) with Not_found -> try try_interp_evaluable env (loc, id) with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) (* Interprets an hypothesis name *) let interp_occurrences ist occs = Locusops.occurrences_map (interp_int_or_var_list ist) occs let interp_hyp_location ist env sigma ((occs,id),hl) = ((interp_occurrences ist occs,interp_hyp ist env sigma id),hl) let interp_hyp_location_list_as_list ist env sigma ((occs,id),hl as x) = match occs,hl with | AllOccurrences,InHyp -> List.map (fun id -> ((AllOccurrences,id),InHyp)) (interp_hyp_list_as_list ist env sigma id) | _,_ -> [interp_hyp_location ist env sigma x] let interp_hyp_location_list ist env sigma l = List.flatten (List.map (interp_hyp_location_list_as_list ist env sigma) l) let interp_clause ist env sigma { onhyps=ol; concl_occs=occs } : clause = { onhyps=Option.map (interp_hyp_location_list ist env sigma) ol; concl_occs=interp_occurrences ist occs } (* Interpretation of constructions *) (* Extract the constr list from lfun *) let extract_ltac_constr_values ist env = let fold id v accu = try let c = coerce_to_constr env v in Id.Map.add id c accu with CannotCoerceTo _ -> accu in Id.Map.fold fold ist.lfun Id.Map.empty (** ppedrot: I have changed the semantics here. Before this patch, closure was implemented as a list and a variable could be bound several times with different types, resulting in its possible appearance on both sides. This could barely be defined as a feature... *) (* Extract the identifier list from lfun: join all branches (what to do else?)*) let rec intropattern_ids (loc,pat) = match pat with | IntroNaming (IntroIdentifier id) -> [id] | IntroAction (IntroOrAndPattern (IntroAndPattern l)) -> List.flatten (List.map intropattern_ids l) | IntroAction (IntroOrAndPattern (IntroOrPattern ll)) -> List.flatten (List.map intropattern_ids (List.flatten ll)) | IntroAction (IntroInjection l) -> List.flatten (List.map intropattern_ids l) | IntroAction (IntroApplyOn (c,pat)) -> intropattern_ids pat | IntroNaming (IntroAnonymous | IntroFresh _) | IntroAction (IntroWildcard | IntroRewrite _) | IntroForthcoming _ -> [] let extract_ids ids lfun = let fold id v accu = let v = Value.normalize v in if has_type v (topwit wit_intro_pattern) then let (_, ipat) = out_gen (topwit wit_intro_pattern) v in if Id.List.mem id ids then accu else accu @ intropattern_ids (dloc, ipat) else accu in Id.Map.fold fold lfun [] let default_fresh_id = Id.of_string "H" let interp_fresh_id ist env sigma l = let extract_ident ist env sigma id = try try_interp_ltac_var (coerce_to_ident_not_fresh sigma env) ist (Some (env,sigma)) (dloc,id) with Not_found -> id in let ids = List.map_filter (function ArgVar (_, id) -> Some id | _ -> None) l in let avoid = match TacStore.get ist.extra f_avoid_ids with | None -> [] | Some l -> l in let avoid = (extract_ids ids ist.lfun) @ avoid in let id = if List.is_empty l then default_fresh_id else let s = String.concat "" (List.map (function | ArgArg s -> s | ArgVar (_,id) -> Id.to_string (extract_ident ist env sigma id)) l) in let s = if CLexer.is_keyword s then s^"0" else s in Id.of_string s in Tactics.fresh_id_in_env avoid id env (* Extract the uconstr list from lfun *) let extract_ltac_constr_context ist env = let open Glob_term in let add_uconstr id env v map = try Id.Map.add id (coerce_to_uconstr env v) map with CannotCoerceTo _ -> map in let add_constr id env v map = try Id.Map.add id (coerce_to_constr env v) map with CannotCoerceTo _ -> map in let add_ident id env v map = try Id.Map.add id (coerce_var_to_ident false env v) map with CannotCoerceTo _ -> map in let fold id v {idents;typed;untyped} = let idents = add_ident id env v idents in let typed = add_constr id env v typed in let untyped = add_uconstr id env v untyped in { idents ; typed ; untyped } in let empty = { idents = Id.Map.empty ;typed = Id.Map.empty ; untyped = Id.Map.empty } in Id.Map.fold fold ist.lfun empty (** Significantly simpler than [interp_constr], to interpret an untyped constr, it suffices to adjoin a closure environment. *) let interp_uconstr ist env = function | (term,None) -> { closure = extract_ltac_constr_context ist env ; term } | (_,Some ce) -> let ( {typed ; untyped } as closure) = extract_ltac_constr_context ist env in let ltacvars = { Constrintern.ltac_vars = Id.(Set.union (Map.domain typed) (Map.domain untyped)); ltac_bound = Id.Map.domain ist.lfun; } in { closure ; term = intern_gen WithoutTypeConstraint ~ltacvars env ce } let interp_gen kind ist allow_patvar flags env sigma (c,ce) = let constrvars = extract_ltac_constr_context ist env in let vars = { Pretyping.ltac_constrs = constrvars.typed; Pretyping.ltac_uconstrs = constrvars.untyped; Pretyping.ltac_idents = constrvars.idents; Pretyping.ltac_genargs = ist.lfun; } in let c = match ce with | None -> c (* If at toplevel (ce<>None), the error can be due to an incorrect context at globalization time: we retype with the now known intros/lettac/inversion hypothesis names *) | Some c -> let constr_context = Id.Set.union (Id.Map.domain constrvars.typed) (Id.Set.union (Id.Map.domain constrvars.untyped) (Id.Map.domain constrvars.idents)) in let ltacvars = { ltac_vars = constr_context; ltac_bound = Id.Map.domain ist.lfun; } in let kind_for_intern = match kind with OfType _ -> WithoutTypeConstraint | _ -> kind in intern_gen kind_for_intern ~allow_patvar ~ltacvars env c in (* Jason Gross: To avoid unnecessary modifications to tacinterp, as suggested by Arnaud Spiwack, we run push_trace immediately. We do this with the kludge of an empty proofview, and rely on the invariant that running the tactic returned by push_trace does not modify sigma. *) let (_, dummy_proofview) = Proofview.init sigma [] in let (trace,_,_,_) = Proofview.apply env (push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist) dummy_proofview in let (evd,c) = catch_error trace (understand_ltac flags env sigma vars kind) c in (* spiwack: to avoid unnecessary modifications of tacinterp, as this function already use effect, I call [run] hoping it doesn't mess up with any assumption. *) Proofview.NonLogical.run (db_constr (curr_debug ist) env c); (evd,c) let constr_flags = { use_typeclasses = true; solve_unification_constraints = true; use_hook = Some solve_by_implicit_tactic; fail_evar = true; expand_evars = true } (* Interprets a constr; expects evars to be solved *) let interp_constr_gen kind ist env sigma c = interp_gen kind ist false constr_flags env sigma c let interp_constr = interp_constr_gen WithoutTypeConstraint let interp_type = interp_constr_gen IsType let open_constr_use_classes_flags = { use_typeclasses = true; solve_unification_constraints = true; use_hook = Some solve_by_implicit_tactic; fail_evar = false; expand_evars = true } let open_constr_no_classes_flags = { use_typeclasses = false; solve_unification_constraints = true; use_hook = Some solve_by_implicit_tactic; fail_evar = false; expand_evars = true } let pure_open_constr_flags = { use_typeclasses = false; solve_unification_constraints = true; use_hook = None; fail_evar = false; expand_evars = false } (* Interprets an open constr *) let interp_open_constr ?(expected_type=WithoutTypeConstraint) ist = let flags = if expected_type == WithoutTypeConstraint then open_constr_no_classes_flags else open_constr_use_classes_flags in interp_gen expected_type ist false flags let interp_pure_open_constr ist = interp_gen WithoutTypeConstraint ist false pure_open_constr_flags let interp_typed_pattern ist env sigma (_,c,_) = let sigma, c = interp_gen WithoutTypeConstraint ist true pure_open_constr_flags env sigma c in pattern_of_constr env sigma c (* Interprets a constr expression *) let pf_interp_constr ist gl = interp_constr ist (pf_env gl) (project gl) let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = let try_expand_ltac_var sigma x = try match dest_fun x with | GVar (_,id), _ -> let v = Id.Map.find id ist.lfun in sigma, List.map inj_fun (coerce_to_constr_list env v) | _ -> raise Not_found with CannotCoerceTo _ | Not_found -> (* dest_fun, List.assoc may raise Not_found *) let sigma, c = interp_fun ist env sigma x in sigma, [c] in let sigma, l = List.fold_map try_expand_ltac_var sigma l in sigma, List.flatten l let interp_constr_list ist env sigma c = interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_constr ist env sigma c let interp_open_constr_list = interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr (* Interprets a type expression *) let pf_interp_type ist env sigma = interp_type ist env sigma (* Interprets a reduction expression *) let interp_unfold ist env sigma (occs,qid) = (interp_occurrences ist occs,interp_evaluable ist env sigma qid) let interp_flag ist env sigma red = { red with rConst = List.map (interp_evaluable ist env sigma) red.rConst } let interp_constr_with_occurrences ist env sigma (occs,c) = let (sigma,c_interp) = interp_constr ist env sigma c in sigma , (interp_occurrences ist occs, c_interp) let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = let p = match a with | Inl (ArgVar (loc,id)) -> (* This is the encoding of an ltac var supposed to be bound prioritary to an evaluable reference and otherwise to a constr (it is an encoding to satisfy the "union" type given to Simpl) *) let coerce_eval_ref_or_constr x = try Inl (coerce_to_evaluable_ref env x) with CannotCoerceTo _ -> let c = coerce_to_closed_constr env x in Inr (pattern_of_constr env sigma c) in (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id) with Not_found -> error_global_not_found_loc loc (qualid_of_ident id)) | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) | Inr c -> Inr (interp_typed_pattern ist env sigma c) in interp_occurrences ist occs, p let interp_constr_with_occurrences_and_name_as_list = interp_constr_in_compound_list (fun c -> ((AllOccurrences,c),Anonymous)) (function ((occs,c),Anonymous) when occs == AllOccurrences -> c | _ -> raise Not_found) (fun ist env sigma (occ_c,na) -> let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma occ_c in sigma, (c_interp, interp_name ist env sigma na)) let interp_red_expr ist env sigma = function | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env sigma) l) | Fold l -> let (sigma,l_interp) = interp_constr_list ist env sigma l in sigma , Fold l_interp | Cbv f -> sigma , Cbv (interp_flag ist env sigma f) | Cbn f -> sigma , Cbn (interp_flag ist env sigma f) | Lazy f -> sigma , Lazy (interp_flag ist env sigma f) | Pattern l -> let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> interp_constr_with_occurrences ist env sigma c) l sigma in sigma , Pattern l_interp | Simpl (f,o) -> sigma , Simpl (interp_flag ist env sigma f, Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) | CbvVm o -> sigma , CbvVm (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) | CbvNative o -> sigma , CbvNative (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) | (Red _ | Hnf | ExtraRedExpr _ as r) -> sigma , r let interp_may_eval f ist env sigma = function | ConstrEval (r,c) -> let (sigma,redexp) = interp_red_expr ist env sigma r in let (sigma,c_interp) = f ist env sigma c in let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (c, sigma, _) = redfun.Reductionops.e_redfun env sigma c_interp in (Sigma.to_evar_map sigma, c) | ConstrContext ((loc,s),c) -> (try let (sigma,ic) = f ist env sigma c in let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in let evdref = ref sigma in let c = subst_meta [Constr_matching.special_meta,ic] ctxt in let c = Typing.e_solve_evars env evdref c in !evdref , c with | Not_found -> user_err_loc (loc, "interp_may_eval", str "Unbound context identifier" ++ pr_id s ++ str".")) | ConstrTypeOf c -> let (sigma,c_interp) = f ist env sigma c in Typing.type_of ~refresh:true env sigma c_interp | ConstrTerm c -> try f ist env sigma c with reraise -> let reraise = CErrors.push reraise in (* spiwack: to avoid unnecessary modifications of tacinterp, as this function already use effect, I call [run] hoping it doesn't mess up with any assumption. *) Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> str"interpretation of term " ++ pr_glob_constr_env env (fst c))); iraise reraise (* Interprets a constr expression possibly to first evaluate *) let interp_constr_may_eval ist env sigma c = let (sigma,csr) = try interp_may_eval interp_constr ist env sigma c with reraise -> let reraise = CErrors.push reraise in (* spiwack: to avoid unnecessary modifications of tacinterp, as this function already use effect, I call [run] hoping it doesn't mess up with any assumption. *) Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> str"evaluation of term")); iraise reraise in begin (* spiwack: to avoid unnecessary modifications of tacinterp, as this function already use effect, I call [run] hoping it doesn't mess up with any assumption. *) Proofview.NonLogical.run (db_constr (curr_debug ist) env csr); sigma , csr end (** TODO: should use dedicated printers *) let rec message_of_value v = let v = Value.normalize v in let open Ftactic in if has_type v (topwit wit_tacvalue) then Ftactic.return (str "") else if has_type v (topwit wit_constr) then let v = out_gen (topwit wit_constr) v in Ftactic.nf_enter {enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) v) end } else if has_type v (topwit wit_constr_under_binders) then let c = out_gen (topwit wit_constr_under_binders) v in Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_under_binders_env (pf_env gl) (project gl) c) end } else if has_type v (topwit wit_unit) then Ftactic.return (str "()") else if has_type v (topwit wit_int) then Ftactic.return (int (out_gen (topwit wit_int) v)) else if has_type v (topwit wit_intro_pattern) then let p = out_gen (topwit wit_intro_pattern) v in let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project gl) c) p) end } else if has_type v (topwit wit_constr_context) then let c = out_gen (topwit wit_constr_context) v in Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) c) end } else if has_type v (topwit wit_uconstr) then let c = out_gen (topwit wit_uconstr) v in Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_closed_glob_env (pf_env gl) (project gl) c) end } else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_id id) end } else match Value.to_list v with | Some l -> Ftactic.List.map message_of_value l >>= fun l -> Ftactic.return (prlist_with_sep spc (fun x -> x) l) | None -> let tag = pr_argument_type v in Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *) let interp_message_token ist = function | MsgString s -> Ftactic.return (str s) | MsgInt n -> Ftactic.return (int n) | MsgIdent (loc,id) -> let v = try Some (Id.Map.find id ist.lfun) with Not_found -> None in match v with | None -> Ftactic.lift (Tacticals.New.tclZEROMSG (pr_id id ++ str" not found.")) | Some v -> message_of_value v let interp_message ist l = let open Ftactic in Ftactic.List.map (interp_message_token ist) l >>= fun l -> Ftactic.return (prlist_with_sep spc (fun x -> x) l) let rec interp_intro_pattern ist env sigma = function | loc, IntroAction pat -> let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in sigma, (loc, IntroAction pat) | loc, IntroNaming (IntroIdentifier id) -> sigma, (loc, interp_intro_pattern_var loc ist env sigma id) | loc, IntroNaming pat -> sigma, (loc, IntroNaming (interp_intro_pattern_naming loc ist env sigma pat)) | loc, IntroForthcoming _ as x -> sigma, x and interp_intro_pattern_naming loc ist env sigma = function | IntroFresh id -> IntroFresh (interp_ident ist env sigma id) | IntroIdentifier id -> interp_intro_pattern_naming_var loc ist env sigma id | IntroAnonymous as x -> x and interp_intro_pattern_action ist env sigma = function | IntroOrAndPattern l -> let (sigma,l) = interp_or_and_intro_pattern ist env sigma l in sigma, IntroOrAndPattern l | IntroInjection l -> let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in sigma, IntroInjection l | IntroApplyOn (c,ipat) -> let c = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = interp_open_constr ist env sigma c in Sigma.Unsafe.of_pair (c, sigma) } in let sigma,ipat = interp_intro_pattern ist env sigma ipat in sigma, IntroApplyOn (c,ipat) | IntroWildcard | IntroRewrite _ as x -> sigma, x and interp_or_and_intro_pattern ist env sigma = function | IntroAndPattern l -> let sigma, l = List.fold_map (interp_intro_pattern ist env) sigma l in sigma, IntroAndPattern l | IntroOrPattern ll -> let sigma, ll = List.fold_map (interp_intro_pattern_list_as_list ist env) sigma ll in sigma, IntroOrPattern ll and interp_intro_pattern_list_as_list ist env sigma = function | [loc,IntroNaming (IntroIdentifier id)] as l -> (try sigma, coerce_to_intro_pattern_list loc env (Id.Map.find id ist.lfun) with Not_found | CannotCoerceTo _ -> List.fold_map (interp_intro_pattern ist env) sigma l) | l -> List.fold_map (interp_intro_pattern ist env) sigma l let interp_intro_pattern_naming_option ist env sigma = function | None -> None | Some (loc,pat) -> Some (loc, interp_intro_pattern_naming loc ist env sigma pat) let interp_or_and_intro_pattern_option ist env sigma = function | None -> sigma, None | Some (ArgVar (loc,id)) -> (match coerce_to_intro_pattern env (Id.Map.find id ist.lfun) with | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l) | _ -> raise (CannotCoerceTo "a disjunctive/conjunctive introduction pattern")) | Some (ArgArg (loc,l)) -> let sigma,l = interp_or_and_intro_pattern ist env sigma l in sigma, Some (loc,l) let interp_intro_pattern_option ist env sigma = function | None -> sigma, None | Some ipat -> let sigma, ipat = interp_intro_pattern ist env sigma ipat in sigma, Some ipat let interp_in_hyp_as ist env sigma (id,ipat) = let sigma, ipat = interp_intro_pattern_option ist env sigma ipat in sigma,(interp_hyp ist env sigma id,ipat) let interp_quantified_hypothesis ist = function | AnonHyp n -> AnonHyp n | NamedHyp id -> try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id) with Not_found -> NamedHyp id let interp_binding_name ist = function | AnonHyp n -> AnonHyp n | NamedHyp id -> (* If a name is bound, it has to be a quantified hypothesis *) (* user has to use other names for variables if these ones clash with *) (* a name intented to be used as a (non-variable) identifier *) try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id) with Not_found -> NamedHyp id let interp_declared_or_quantified_hypothesis ist env sigma = function | AnonHyp n -> AnonHyp n | NamedHyp id -> try try_interp_ltac_var (coerce_to_decl_or_quant_hyp env) ist (Some (env,sigma)) (dloc,id) with Not_found -> NamedHyp id let interp_binding ist env sigma (loc,b,c) = let sigma, c = interp_open_constr ist env sigma c in sigma, (loc,interp_binding_name ist b,c) let interp_bindings ist env sigma = function | NoBindings -> sigma, NoBindings | ImplicitBindings l -> let sigma, l = interp_open_constr_list ist env sigma l in sigma, ImplicitBindings l | ExplicitBindings l -> let sigma, l = List.fold_map (interp_binding ist env) sigma l in sigma, ExplicitBindings l let interp_constr_with_bindings ist env sigma (c,bl) = let sigma, bl = interp_bindings ist env sigma bl in let sigma, c = interp_open_constr ist env sigma c in sigma, (c,bl) let interp_open_constr_with_bindings ist env sigma (c,bl) = let sigma, bl = interp_bindings ist env sigma bl in let sigma, c = interp_open_constr ist env sigma c in sigma, (c, bl) let loc_of_bindings = function | NoBindings -> Loc.ghost | ImplicitBindings l -> loc_of_glob_constr (fst (List.last l)) | ExplicitBindings l -> pi1 (List.last l) let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) = let loc1 = loc_of_glob_constr c in let loc2 = loc_of_bindings bl in let loc = if Loc.is_ghost loc2 then loc1 else Loc.merge loc1 loc2 in let f = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = interp_open_constr_with_bindings ist env sigma cb in Sigma.Unsafe.of_pair (c, sigma) } in (loc,f) let interp_destruction_arg ist gl arg = match arg with | keep,ElimOnConstr c -> keep,ElimOnConstr { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = interp_constr_with_bindings ist env sigma c in Sigma.Unsafe.of_pair (c, sigma) } | keep,ElimOnAnonHyp n as x -> x | keep,ElimOnIdent (loc,id) -> let error () = user_err_loc (loc, "", strbrk "Cannot coerce " ++ pr_id id ++ strbrk " neither to a quantified hypothesis nor to a term.") in let try_cast_id id' = if Tactics.is_quantified_hypothesis id' gl then keep,ElimOnIdent (loc,id') else (keep, ElimOnConstr { delayed = begin fun env sigma -> try Sigma.here (constr_of_id env id', NoBindings) sigma with Not_found -> user_err_loc (loc, "interp_destruction_arg", pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.") end }) in try (** FIXME: should be moved to taccoerce *) let v = Id.Map.find id ist.lfun in let v = Value.normalize v in if has_type v (topwit wit_intro_pattern) then let v = out_gen (topwit wit_intro_pattern) v in match v with | _, IntroNaming (IntroIdentifier id) -> try_cast_id id | _ -> error () else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in try_cast_id id else if has_type v (topwit wit_int) then keep,ElimOnAnonHyp (out_gen (topwit wit_int) v) else match Value.to_constr v with | None -> error () | Some c -> keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) } with Not_found -> (* We were in non strict (interactive) mode *) if Tactics.is_quantified_hypothesis id gl then keep,ElimOnIdent (loc,id) else let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in let f = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma,c) = interp_open_constr ist env sigma c in Sigma.Unsafe.of_pair ((c,NoBindings), sigma) } in keep,ElimOnConstr f (* Associates variables with values and gives the remaining variables and values *) let head_with_value (lvar,lval) = let rec head_with_value_rec lacc = function | ([],[]) -> (lacc,[],[]) | (vr::tvr,ve::tve) -> (match vr with | None -> head_with_value_rec lacc (tvr,tve) | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve)) | (vr,[]) -> (lacc,vr,[]) | ([],ve) -> (lacc,[],ve) in head_with_value_rec [] (lvar,lval) (** [interp_context ctxt] interprets a context (as in {!Matching.matching_result}) into a context value of Ltac. *) let interp_context ctxt = in_gen (topwit wit_constr_context) ctxt (* Reads a pattern by substituting vars of lfun *) let use_types = false let eval_pattern lfun ist env sigma (bvars,(glob,_),pat as c) = if use_types then (bvars,interp_typed_pattern ist env sigma c) else (bvars,instantiate_pattern env sigma lfun pat) let read_pattern lfun ist env sigma = function | Subterm (b,ido,c) -> Subterm (b,ido,eval_pattern lfun ist env sigma c) | Term c -> Term (eval_pattern lfun ist env sigma c) (* Reads the hypotheses of a Match Context rule *) let cons_and_check_name id l = if Id.List.mem id l then user_err_loc (dloc,"read_match_goal_hyps", str "Hypothesis pattern-matching variable " ++ pr_id id ++ str " used twice in the same pattern.") else id::l let rec read_match_goal_hyps lfun ist env sigma lidh = function | (Hyp ((loc,na) as locna,mp))::tl -> let lidh' = name_fold cons_and_check_name na lidh in Hyp (locna,read_pattern lfun ist env sigma mp):: (read_match_goal_hyps lfun ist env sigma lidh' tl) | (Def ((loc,na) as locna,mv,mp))::tl -> let lidh' = name_fold cons_and_check_name na lidh in Def (locna,read_pattern lfun ist env sigma mv, read_pattern lfun ist env sigma mp):: (read_match_goal_hyps lfun ist env sigma lidh' tl) | [] -> [] (* Reads the rules of a Match Context or a Match *) let rec read_match_rule lfun ist env sigma = function | (All tc)::tl -> (All tc)::(read_match_rule lfun ist env sigma tl) | (Pat (rl,mp,tc))::tl -> Pat (read_match_goal_hyps lfun ist env sigma [] rl, read_pattern lfun ist env sigma mp,tc) :: read_match_rule lfun ist env sigma tl | [] -> [] let warn_deprecated_info = CWarnings.create ~name:"deprecated-info-tactical" ~category:"deprecated" (fun () -> strbrk "The general \"info\" tactic is currently not working." ++ spc()++ strbrk "There is an \"Info\" command to replace it." ++fnl () ++ strbrk "Some specific verbose tactics may also exist, such as info_eauto.") (* Interprets an l-tac expression into a value *) let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftactic.t = (* The name [appl] of applied top-level Ltac names is ignored in [value_interp]. It is installed in the second step by a call to [name_vfun], because it gives more opportunities to detect a [VFun]. Otherwise a [Ltac t := let x := .. in tac] would never register its name since it is syntactically a let, not a function. *) let value_interp ist = match tac with | TacFun (it, body) -> Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, it, body))) | TacLetIn (true,l,u) -> interp_letrec ist l u | TacLetIn (false,l,u) -> interp_letin ist l u | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr | TacArg (loc,a) -> interp_tacarg ist a | t -> (** Delayed evaluation *) Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t))) in let open Ftactic in Control.check_for_interrupt (); match curr_debug ist with | DebugOn lev -> let eval v = let ist = { ist with extra = TacStore.set ist.extra f_debug v } in value_interp ist >>= fun v -> return (name_vfun appl v) in Tactic_debug.debug_prompt lev tac eval | _ -> value_interp ist >>= fun v -> return (name_vfun appl v) and eval_tactic ist tac : unit Proofview.tactic = match tac with | TacAtom (loc,t) -> let call = LtacAtomCall t in push_trace(loc,call) ist >>= fun trace -> Profile_ltac.do_profile "eval_tactic:2" trace (catch_error_tac trace (interp_atomic ist t)) | TacFun _ | TacLetIn _ -> assert false | TacMatchGoal _ | TacMatch _ -> assert false | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) []) | TacId s -> let msgnl = let open Ftactic in interp_message ist s >>= fun msg -> return (hov 0 msg , hov 0 msg) in let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print_info msgnl)) in let log (msg,_) = Proofview.Trace.log (fun () -> msg) in let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in Ftactic.run msgnl begin fun msgnl -> print msgnl <*> log msgnl <*> break end | TacFail (g,n,s) -> let msg = interp_message ist s in let tac l = Tacticals.New.tclFAIL (interp_int_or_var ist n) l in let tac = match g with | TacLocal -> fun l -> Proofview.tclINDEPENDENT (tac l) | TacGlobal -> tac in Ftactic.run msg tac | TacProgress tac -> Tacticals.New.tclPROGRESS (interp_tactic ist tac) | TacShowHyps tac -> Proofview.V82.tactic begin tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac)) end | TacAbstract (tac,ido) -> Proofview.Goal.nf_enter { enter = begin fun gl -> Tactics.tclABSTRACT (Option.map (pf_interp_ident ist gl) ido) (interp_tactic ist tac) end } | TacThen (t1,t) -> Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) | TacDispatch tl -> Proofview.tclDISPATCH (List.map (interp_tactic ist) tl) | TacExtendTac (tf,t,tl) -> Proofview.tclEXTEND (Array.map_to_list (interp_tactic ist) tf) (interp_tactic ist t) (Array.map_to_list (interp_tactic ist) tl) | TacThens (t1,tl) -> Tacticals.New.tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl) | TacThens3parts (t1,tf,t,tl) -> Tacticals.New.tclTHENS3PARTS (interp_tactic ist t1) (Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl) | TacDo (n,tac) -> Tacticals.New.tclDO (interp_int_or_var ist n) (interp_tactic ist tac) | TacTimeout (n,tac) -> Tacticals.New.tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac) | TacTime (s,tac) -> Tacticals.New.tclTIME s (interp_tactic ist tac) | TacTry tac -> Tacticals.New.tclTRY (interp_tactic ist tac) | TacRepeat tac -> Tacticals.New.tclREPEAT (interp_tactic ist tac) | TacOr (tac1,tac2) -> Tacticals.New.tclOR (interp_tactic ist tac1) (interp_tactic ist tac2) | TacOnce tac -> Tacticals.New.tclONCE (interp_tactic ist tac) | TacExactlyOnce tac -> Tacticals.New.tclEXACTLY_ONCE (interp_tactic ist tac) | TacIfThenCatch (t,tt,te) -> Tacticals.New.tclIFCATCH (interp_tactic ist t) (fun () -> interp_tactic ist tt) (fun () -> interp_tactic ist te) | TacOrelse (tac1,tac2) -> Tacticals.New.tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2) | TacFirst l -> Tacticals.New.tclFIRST (List.map (interp_tactic ist) l) | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l) | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac) | TacArg a -> interp_tactic ist (TacArg a) | TacInfo tac -> warn_deprecated_info (); eval_tactic ist tac | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) (* For extensions *) | TacAlias (loc,s,l) -> let (ids, body) = Tacenv.interp_alias s in let (>>=) = Ftactic.bind in let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in let tac l = let addvar x v accu = Id.Map.add x v accu in let lfun = List.fold_right2 addvar ids l ist.lfun in Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace -> let ist = { lfun = lfun; extra = TacStore.set ist.extra f_trace trace; } in val_interp ist body >>= fun v -> Ftactic.lift (tactic_of_value ist v) in let tac = Ftactic.with_env interp_vars >>= fun (env, lr) -> let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in Proofview.Trace.name_tactic name (tac lr) (* spiwack: this use of name_tactic is not robust to a change of implementation of [Ftactic]. In such a situation, some more elaborate solution will have to be used. *) in let tac = let len1 = List.length ids in let len2 = List.length l in if len1 = len2 then tac else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \ expected " ++ int len1 ++ str ", found " ++ int len2) in Ftactic.run tac (fun () -> Proofview.tclUNIT ()) | TacML (loc,opn,l) -> push_trace (loc,LtacMLCall tac) ist >>= fun trace -> let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in let tac = Tacenv.interp_ml_tactic opn in let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in let tac args = let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) in Ftactic.run args tac and force_vrec ist v : Val.t Ftactic.t = let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then let v = to_tacvalue v in match v with | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} body | v -> Ftactic.return (of_tacvalue v) else Ftactic.return v and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = match r with | ArgVar (loc,id) -> let v = try Id.Map.find id ist.lfun with Not_found -> in_gen (topwit wit_var) id in let open Ftactic in force_vrec ist v >>= begin fun v -> Ftactic.lift (propagate_trace ist loc id v) >>= fun v -> if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v end | ArgArg (loc,r) -> let ids = extract_ids [] ist.lfun in let loc_info = ((if Loc.is_ghost loc' then loc else loc'),LtacNameCall r) in let extra = TacStore.set ist.extra f_avoid_ids ids in push_trace loc_info ist >>= fun trace -> let extra = TacStore.set extra f_trace trace in let ist = { lfun = Id.Map.empty; extra = extra; } in let appl = GlbAppl[r,[]] in val_interp ~appl ist (Tacenv.interp_ltac r) and interp_tacarg ist arg : Val.t Ftactic.t = match arg with | TacGeneric arg -> interp_genarg ist arg | Reference r -> interp_ltac_reference dloc false ist r | ConstrMayEval c -> Ftactic.s_enter { s_enter = begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) end } | TacCall (loc,r,[]) -> interp_ltac_reference loc true ist r | TacCall (loc,f,l) -> let (>>=) = Ftactic.bind in interp_ltac_reference loc true ist f >>= fun fv -> Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> interp_app loc ist fv largs | TacFreshId l -> Ftactic.enter { enter = begin fun gl -> let id = interp_fresh_id ist (pf_env gl) (project gl) l in Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id))) end } | TacPretype c -> Ftactic.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let c = interp_uconstr ist env c in let Sigma (c, sigma, p) = (type_uconstr ist c).delayed env sigma in Sigma (Ftactic.return (Value.of_constr c), sigma, p) end } | TacNumgoals -> Ftactic.lift begin let open Proofview.Notations in Proofview.numgoals >>= fun i -> Proofview.tclUNIT (Value.of_int i) end | Tacexp t -> val_interp ist t (* Interprets an application node *) and interp_app loc ist fv largs : Val.t Ftactic.t = let (>>=) = Ftactic.bind in let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in let fv = Value.normalize fv in if has_type fv (topwit wit_tacvalue) then match to_tacvalue fv with (* if var=[] and body has been delayed by val_interp, then body is not a tactic that expects arguments. Otherwise Ltac goes into an infinite loop (val_interp puts a VFun back on body, and then interp_app is called again...) *) | (VFun(appl,trace,olfun,(_::_ as var),body) |VFun(appl,trace,olfun,([] as var), (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) -> let (extfun,lvar,lval)=head_with_value (var,largs) in let fold accu (id, v) = Id.Map.add id v accu in let newlfun = List.fold_left fold olfun extfun in if List.is_empty lvar then begin Proofview.tclORELSE begin let ist = { lfun = newlfun; extra = TacStore.set ist.extra f_trace []; } in catch_error_tac trace (val_interp ist body) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) end begin fun (e, info) -> Proofview.tclLIFT (debugging_exception_step ist false e (fun () -> str "evaluation")) <*> Proofview.tclZERO ~info e end end >>= fun v -> (* No errors happened, we propagate the trace *) let v = append_trace trace v in Proofview.tclLIFT begin debugging_step ist (fun () -> str"evaluation returns"++fnl()++pr_value None v) end <*> if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval else Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body))) | _ -> fail else fail (* Gives the tactic corresponding to the tactic value *) and tactic_of_value ist vle = let vle = Value.normalize vle in if has_type vle (topwit wit_tacvalue) then match to_tacvalue vle with | VFun (appl,trace,lfun,[],t) -> let ist = { lfun = lfun; extra = TacStore.set ist.extra f_trace []; } in let tac = name_if_glob appl (eval_tactic ist t) in Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac) | (VFun _|VRec _) -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") else if has_type vle (topwit wit_tactic) then let tac = out_gen (topwit wit_tactic) vle in tactic_of_value ist tac else Tacticals.New.tclZEROMSG (str "Expression does not evaluate to a tactic.") (* Interprets the clauses of a recursive LetIn *) and interp_letrec ist llc u = Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *) let lref = ref ist.lfun in let fold accu ((_, id), b) = let v = of_tacvalue (VRec (lref, TacArg (dloc, b))) in Id.Map.add id v accu in let lfun = List.fold_left fold ist.lfun llc in let () = lref := lfun in let ist = { ist with lfun } in val_interp ist u (* Interprets the clauses of a LetIn *) and interp_letin ist llc u = let rec fold lfun = function | [] -> let ist = { ist with lfun } in val_interp ist u | ((_, id), body) :: defs -> Ftactic.bind (interp_tacarg ist body) (fun v -> fold (Id.Map.add id v lfun) defs) in fold ist.lfun llc (** [interp_match_success lz ist succ] interprets a single matching success (of type {!Tactic_matching.t}). *) and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = let (>>=) = Ftactic.bind in let lctxt = Id.Map.map interp_context context in let hyp_subst = Id.Map.map Value.of_constr terms in let lfun = extend_values_with_bindings subst (lctxt +++ hyp_subst +++ ist.lfun) in let ist = { ist with lfun } in val_interp ist lhs >>= fun v -> if has_type v (topwit wit_tacvalue) then match to_tacvalue v with | VFun (appl,trace,lfun,[],t) -> let ist = { lfun = lfun; extra = TacStore.set ist.extra f_trace trace; } in let tac = eval_tactic ist t in let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy)) | _ -> Ftactic.return v else Ftactic.return v (** [interp_match_successes lz ist s] interprets the stream of matching of successes [s]. If [lz] is set to true, then only the first success is considered, otherwise further successes are tried if the left-hand side fails. *) and interp_match_successes lz ist s = let general = let break (e, info) = match e with | FailError (0, _) -> None | FailError (n, s) -> Some (FailError (pred n, s), info) | _ -> None in Proofview.tclBREAK break s >>= fun ans -> interp_match_success ist ans in match lz with | General -> general | Select -> begin (** Only keep the first matching result, we don't backtrack on it *) let s = Proofview.tclONCE s in s >>= fun ans -> interp_match_success ist ans end | Once -> (** Once a tactic has succeeded, do not backtrack anymore *) Proofview.tclONCE general (* Interprets the Match expressions *) and interp_match ist lz constr lmr = let (>>=) = Ftactic.bind in begin Proofview.tclORELSE (interp_ltac_constr ist constr) begin function | (e, info) -> Proofview.tclLIFT (debugging_exception_step ist true e (fun () -> str "evaluation of the matched expression")) <*> Proofview.tclZERO ~info e end end >>= fun constr -> Ftactic.enter { enter = begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr) end } (* Interprets the Match Context expressions *) and interp_match_goal ist lz lr lmr = Ftactic.nf_enter { enter = begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let hyps = Proofview.Goal.hyps gl in let hyps = if lr then List.rev hyps else hyps in let concl = Proofview.Goal.concl gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr) end } (* Interprets extended tactic generic arguments *) and interp_genarg ist x : Val.t Ftactic.t = let open Ftactic.Notations in (** Ad-hoc handling of some types. *) let tag = genarg_tag x in if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then interp_genarg_var_list ist x else if argument_type_eq tag (unquote (topwit (wit_list wit_constr))) then interp_genarg_constr_list ist x else let GenArg (Glbwit wit, x) = x in match wit with | ListArg wit -> let map x = interp_genarg ist (Genarg.in_gen (glbwit wit) x) in Ftactic.List.map map x >>= fun l -> Ftactic.return (Val.Dyn (Val.typ_list, l)) | OptArg wit -> begin match x with | None -> Ftactic.return (Val.Dyn (Val.typ_opt, None)) | Some x -> interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> Ftactic.return (Val.Dyn (Val.typ_opt, Some x)) end | PairArg (wit1, wit2) -> let (p, q) = x in interp_genarg ist (Genarg.in_gen (glbwit wit1) p) >>= fun p -> interp_genarg ist (Genarg.in_gen (glbwit wit2) q) >>= fun q -> Ftactic.return (Val.Dyn (Val.typ_pair, (p, q))) | ExtraArg s -> Geninterp.interp wit ist x (** returns [true] for genargs which have the same meaning independently of goals. *) and interp_genarg_constr_list ist x = Ftactic.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in let (sigma,lc) = interp_constr_list ist env sigma lc in let lc = in_list (val_tag wit_constr) lc in Sigma.Unsafe.of_pair (Ftactic.return lc, sigma) end } and interp_genarg_var_list ist x = Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in let lc = interp_hyp_list ist env sigma lc in let lc = in_list (val_tag wit_var) lc in Ftactic.return lc end } (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist e : constr Ftactic.t = let (>>=) = Ftactic.bind in begin Proofview.tclORELSE (val_interp ist e) begin function (err, info) -> match err with | Not_found -> Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in Proofview.tclLIFT begin debugging_step ist (fun () -> str "evaluation failed for" ++ fnl() ++ Pptactic.pr_glob_tactic env e) end <*> Proofview.tclZERO Not_found end } | err -> Proofview.tclZERO ~info err end end >>= fun result -> Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let result = Value.normalize result in try let cresult = coerce_to_closed_constr env result in Proofview.tclLIFT begin debugging_step ist (fun () -> Pptactic.pr_glob_tactic env e ++ fnl() ++ str " has value " ++ fnl() ++ pr_constr_env env sigma cresult) end <*> Ftactic.return cresult with CannotCoerceTo _ -> let env = Proofview.Goal.env gl in Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++ str "offending expression: " ++ fnl() ++ pr_inspect env e result) end } (* Interprets tactic expressions : returns a "tactic" *) and interp_tactic ist tac : unit Proofview.tactic = Ftactic.run (val_interp ist tac) (fun v -> tactic_of_value ist v) (* Provides a "name" for the trace to atomic tactics *) and name_atomic ?env tacexpr tac : unit Proofview.tactic = begin match env with | Some e -> Proofview.tclUNIT e | None -> Proofview.tclENV end >>= fun env -> let name () = Pptactic.pr_atomic_tactic env tacexpr in Proofview.Trace.name_tactic name tac (* Interprets a primitive tactic *) and interp_atomic ist tac : unit Proofview.tactic = match tac with (* Basic tactics *) | TacIntroPattern (ev,l) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in Tacticals.New.tclWITHHOLES ev (name_atomic ~env (TacIntroPattern (ev,l)) (* spiwack: print uninterpreted, not sure if it is the expected behaviour. *) (Tactics.intro_patterns ev l')) sigma end } | TacApply (a,ev,cb,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let l = List.map (fun (k,c) -> let loc, f = interp_open_constr_with_bindings_loc ist c in (k,(loc,f))) cb in let sigma,tac = match cl with | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l | Some cl -> let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in sigma, Tactics.apply_delayed_in a ev id l cl in Tacticals.New.tclWITHHOLES ev tac sigma end } end | TacElim (ev,(keep,cb),cbo) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let sigma, cb = interp_constr_with_bindings ist env sigma cb in let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in let named_tac = let tac = Tactics.elim ev keep cb cbo in name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac in Tacticals.New.tclWITHHOLES ev named_tac sigma end } | TacCase (ev,(keep,cb)) -> Proofview.Goal.enter { enter = begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let sigma, cb = interp_constr_with_bindings ist env sigma cb in let named_tac = let tac = Tactics.general_case_analysis ev keep cb in name_atomic ~env (TacCase(ev,(keep,cb))) tac in Tacticals.New.tclWITHHOLES ev named_tac sigma end } | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = let (sigma,c_interp) = pf_interp_type ist env sigma c in sigma , (interp_ident ist env sigma id,n,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in let tac = Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0 in Sigma.Unsafe.of_pair (tac, sigma) end } end | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = pf_env gl in let f sigma (id,c) = let (sigma,c_interp) = pf_interp_type ist env sigma c in sigma , (interp_ident ist env sigma id,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in let tac = Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0 in Sigma.Unsafe.of_pair (tac, sigma) end } end | TacAssert (b,t,ipat,c) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let (sigma,c) = (if Option.is_empty t then interp_constr else interp_type) ist env sigma c in let sigma, ipat' = interp_intro_pattern_option ist env sigma ipat in let tac = Option.map (Option.map (interp_tactic ist)) t in Tacticals.New.tclWITHHOLES false (name_atomic ~env (TacAssert(b,Option.map (Option.map ignore) t,ipat,c)) (Tactics.forward b tac ipat' c)) sigma end } | TacGeneralize cl -> Proofview.Goal.enter { enter = begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in Tacticals.New.tclWITHHOLES false (name_atomic ~env (TacGeneralize cl) (Tactics.generalize_gen cl)) sigma end } | TacLetTac (na,c,clp,b,eqpat) -> Proofview.V82.nf_evar_goals <*> Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let clp = interp_clause ist env sigma clp in let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in if Locusops.is_nowhere clp then (* We try to fully-typecheck the term *) let (sigma,c_interp) = pf_interp_constr ist gl c in let let_tac b na c cl eqpat = let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in let with_eq = if b then None else Some (true,id) in Tactics.letin_tac with_eq na c None cl in let na = interp_name ist env sigma na in Tacticals.New.tclWITHHOLES false (name_atomic ~env (TacLetTac(na,c_interp,clp,b,eqpat)) (let_tac b na c_interp clp eqpat)) sigma else (* We try to keep the pattern structure as much as possible *) let let_pat_tac b na c cl eqpat = let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in let with_eq = if b then None else Some (true,id) in Tactics.letin_pat_tac with_eq na c cl in let (sigma',c) = interp_pure_open_constr ist env sigma c in name_atomic ~env (TacLetTac(na,c,clp,b,eqpat)) (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*) (let_pat_tac b (interp_name ist env sigma na) ((sigma,sigma'),c) clp eqpat) sigma') end } (* Derived basic tactics *) | TacInductionDestruct (isrec,ev,(l,el)) -> (* spiwack: some unknown part of destruct needs the goal to be prenormalised. *) Proofview.V82.nf_evar_goals <*> Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let sigma,l = List.fold_map begin fun sigma (c,(ipato,ipats),cls) -> (* TODO: move sigma as a side-effect *) (* spiwack: the [*p] variants are for printing *) let cp = c in let c = interp_destruction_arg ist gl c in let ipato = interp_intro_pattern_naming_option ist env sigma ipato in let ipatsp = ipats in let sigma,ipats = interp_or_and_intro_pattern_option ist env sigma ipats in let cls = Option.map (interp_clause ist env sigma) cls in sigma,((c,(ipato,ipats),cls),(cp,(ipato,ipatsp),cls)) end sigma l in let l,lp = List.split l in let sigma,el = Option.fold_map (interp_constr_with_bindings ist env) sigma el in let tac = name_atomic ~env (TacInductionDestruct(isrec,ev,(lp,el))) (Tactics.induction_destruct isrec ev (l,el)) in Sigma.Unsafe.of_pair (tac, sigma) end } (* Conversion *) | TacReduce (r,cl) -> Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in Sigma.Unsafe.of_pair (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl), sigma) end } | TacChange (None,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin Proofview.V82.nf_evar_goals <*> Proofview.Goal.nf_enter { enter = begin fun gl -> let is_onhyps = match cl.onhyps with | None | Some [] -> true | _ -> false in let is_onconcl = match cl.concl_occs with | AllOccurrences | NoOccurrences -> true | _ -> false in let c_interp patvars = { Sigma.run = begin fun sigma -> let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in let sigma = Sigma.to_evar_map sigma in let ist = { ist with lfun = lfun' } in let (sigma, c) = if is_onhyps && is_onconcl then interp_type ist (pf_env gl) sigma c else interp_constr ist (pf_env gl) sigma c in Sigma.Unsafe.of_pair (c, sigma) end } in Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) end } end | TacChange (Some op,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin Proofview.V82.nf_evar_goals <*> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let op = interp_typed_pattern ist env sigma op in let to_catch = function Not_found -> true | e -> CErrors.is_anomaly e in let c_interp patvars = { Sigma.run = begin fun sigma -> let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in let ist = { ist with lfun = lfun' } in try let sigma = Sigma.to_evar_map sigma in let (sigma, c) = interp_constr ist env sigma c in Sigma.Unsafe.of_pair (c, sigma) with e when to_catch e (* Hack *) -> errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") end } in Tactics.change (Some op) c_interp (interp_clause ist env sigma cl) end } end (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> Proofview.Goal.enter { enter = begin fun gl -> let l' = List.map (fun (b,m,(keep,c)) -> let f = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in Sigma.Unsafe.of_pair (c, sigma) } in (b,m,keep,f)) l in let env = Proofview.Goal.env gl in let sigma = project gl in let cl = interp_clause ist env sigma cl in name_atomic ~env (TacRewrite (ev,l,cl,Option.map ignore by)) (Equality.general_multi_rewrite ev l' cl (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by), Equality.Naive) by)) end } | TacInversion (DepInversion (k,c,ids),hyp) -> Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let (sigma,c_interp) = match c with | None -> sigma , None | Some c -> let (sigma,c_interp) = pf_interp_constr ist gl c in sigma , Some c_interp in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let sigma,ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in Tacticals.New.tclWITHHOLES false (name_atomic ~env (TacInversion(DepInversion(k,c_interp,ids),dqhyps)) (Inv.dinv k c_interp ids_interp dqhyps)) sigma end } | TacInversion (NonDepInversion (k,idl,ids),hyp) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let hyps = interp_hyp_list ist env sigma idl in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in Tacticals.New.tclWITHHOLES false (name_atomic ~env (TacInversion (NonDepInversion (k,hyps,ids),dqhyps)) (Inv.inv_clause k ids_interp hyps dqhyps)) sigma end } | TacInversion (InversionUsing (c,idl),hyp) -> Proofview.Goal.s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let (sigma,c_interp) = interp_constr ist env sigma c in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let hyps = interp_hyp_list ist env sigma idl in let tac = name_atomic ~env (TacInversion (InversionUsing (c_interp,hyps),dqhyps)) (Leminv.lemInv_clause dqhyps c_interp hyps) in Sigma.Unsafe.of_pair (tac, sigma) end } (* Initial call for interpretation *) let default_ist () = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in { lfun = Id.Map.empty; extra = extra } let eval_tactic t = Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *) Proofview.tclLIFT db_initialize <*> interp_tactic (default_ist ()) t let eval_tactic_ist ist t = Proofview.tclLIFT db_initialize <*> interp_tactic ist t (* globalization + interpretation *) let interp_tac_gen lfun avoid_ids debug t = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let extra = TacStore.set TacStore.empty f_debug debug in let extra = TacStore.set extra f_avoid_ids avoid_ids in let ist = { lfun = lfun; extra = extra } in let ltacvars = Id.Map.domain lfun in interp_tactic ist (intern_pure_tactic { ltacvars; genv = env } t) end } let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t let _ = Proof_global.set_interp_tac interp (* Used to hide interpretation for pretty-print, now just launch tactics *) (* [global] means that [t] should be internalized outside of goals. *) let hide_interp global t ot = let hide_interp env = let ist = { ltacvars = Id.Set.empty; genv = env } in let te = intern_pure_tactic ist t in let t = eval_tactic te in match ot with | None -> t | Some t' -> Tacticals.New.tclTHEN t t' in if global then Proofview.tclENV >>= fun env -> hide_interp env else Proofview.Goal.enter { enter = begin fun gl -> hide_interp (Proofview.Goal.env gl) end } (***************************************************************************) (** Register standard arguments *) let register_interp0 wit f = let open Ftactic.Notations in let interp ist v = f ist v >>= fun v -> Ftactic.return (Val.inject (val_tag wit) v) in Geninterp.register_interp0 wit interp let def_intern ist x = (ist, x) let def_subst _ x = x let def_interp ist x = Ftactic.return x let declare_uniform t = Genintern.register_intern0 t def_intern; Genintern.register_subst0 t def_subst; register_interp0 t def_interp let () = declare_uniform wit_unit let () = declare_uniform wit_int let () = declare_uniform wit_bool let () = declare_uniform wit_string let () = declare_uniform wit_pre_ident let lift f = (); fun ist x -> Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in Ftactic.return (f ist env sigma x) end } let lifts f = (); fun ist x -> Ftactic.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let (sigma, v) = f ist env sigma x in Sigma.Unsafe.of_pair (Ftactic.return v, sigma) end } let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma -> let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in Sigma.Unsafe.of_pair (bl, sigma) } let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in Sigma.Unsafe.of_pair (c, sigma) } let interp_destruction_arg' ist c = Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (interp_destruction_arg ist gl c) end } let () = register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); register_interp0 wit_ref (lift interp_reference); register_interp0 wit_ident (lift interp_ident); register_interp0 wit_var (lift interp_hyp); register_interp0 wit_intro_pattern (lifts interp_intro_pattern); register_interp0 wit_clause_dft_concl (lift interp_clause); register_interp0 wit_constr (lifts interp_constr); register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v); register_interp0 wit_red_expr (lifts interp_red_expr); register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); register_interp0 wit_open_constr (lifts interp_open_constr); register_interp0 wit_bindings interp_bindings'; register_interp0 wit_constr_with_bindings interp_constr_with_bindings'; register_interp0 wit_destruction_arg interp_destruction_arg'; () let () = let interp ist tac = Ftactic.return (Value.of_closure ist tac) in register_interp0 wit_tactic interp let () = let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in register_interp0 wit_ltac interp let () = register_interp0 wit_uconstr (fun ist c -> Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) c) end }) (***************************************************************************) (* Other entry points *) let val_interp ist tac k = Ftactic.run (val_interp ist tac) k let interp_ltac_constr ist c k = Ftactic.run (interp_ltac_constr ist c) k let interp_redexp env sigma r = let ist = default_ist () in let gist = { fully_empty_glob_sign with genv = env; } in interp_red_expr ist env sigma (intern_red_expr gist r) (***************************************************************************) (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = let eval ty env sigma lfun arg = let ist = { lfun = lfun; extra = TacStore.empty; } in if Genarg.has_type arg (glbwit wit_tactic) then let tac = Genarg.out_gen (glbwit wit_tactic) arg in let tac = interp_tactic ist tac in Pfedit.refine_by_tactic env sigma ty tac else failwith "not a tactic" in Hook.set Pretyping.genarg_interp_hook eval (** Used in tactic extension **) let dummy_id = Id.of_string "_" let lift_constr_tac_to_ml_tac vars tac = let tac _ ist = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let map = function | None -> None | Some id -> let c = Id.Map.find id ist.lfun in try Some (coerce_to_closed_constr env c) with CannotCoerceTo ty -> error_ltac_variable Loc.ghost dummy_id (Some (env,sigma)) c ty in let args = List.map_filter map vars in tac args ist end } in tac let vernac_debug b = set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) let _ = let open Goptions in declare_bool_option { optsync = false; optdepr = false; optname = "Ltac debug"; optkey = ["Ltac";"Debug"]; optread = (fun () -> get_debug () != Tactic_debug.DebugOff); optwrite = vernac_debug } let _ = let open Goptions in declare_bool_option { optsync = false; optdepr = false; optname = "Ltac debug"; optkey = ["Debug";"Ltac"]; optread = (fun () -> get_debug () != Tactic_debug.DebugOff); optwrite = vernac_debug } let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp coq-8.6/ltac/evar_tactics.mli0000644000175000017500000000156313022274260015561 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Tacinterp.interp_sign * Glob_term.glob_constr -> (Id.t * hyp_location_flag, unit) location -> unit Proofview.tactic val instantiate_tac_by_name : Id.t -> Tacinterp.interp_sign * Glob_term.glob_constr -> unit Proofview.tactic val let_evar : Name.t -> Term.types -> unit Proofview.tactic coq-8.6/ltac/tauto.mli0000644000175000017500000000000013022274260014227 0ustar mdenesmdenescoq-8.6/ltac/tacentries.mli0000644000175000017500000000526213022274260015253 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Vernacexpr.tacdef_body list -> unit (** Adds new Ltac definitions to the environment. *) (** {5 Tactic Notations} *) type 'a grammar_tactic_prod_item_expr = 'a Pptactic.grammar_tactic_prod_item_expr = | TacTerm of string | TacNonTerm of Loc.t * 'a * Names.Id.t type raw_argument = string * string option (** An argument type as provided in Tactic notations, i.e. a string like "ne_foo_list_opt" together with a separator that only makes sense in the "_sep" cases. *) type argument = Genarg.ArgT.any Extend.user_symbol (** A fully resolved argument type given as an AST with generic arguments on the leaves. *) val add_tactic_notation : locality_flag -> int -> raw_argument grammar_tactic_prod_item_expr list -> raw_tactic_expr -> unit (** [add_tactic_notation local level prods expr] adds a tactic notation in the environment at level [level] with locality [local] made of the grammar productions [prods] and returning the body [expr] *) val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type -> unit (** Register an argument under a given entry name for tactic notations. When translating [raw_argument] into [argument], atomic names will be first looked up according to names registered through this function and fallback to finding an argument by name (as in {!Genarg}) if there is none matching. *) val add_ml_tactic_notation : ml_tactic_name -> argument grammar_tactic_prod_item_expr list list -> unit (** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND ML-side macro. *) (** {5 Tactic Quotations} *) val create_ltac_quotation : string -> ('grm Loc.located -> raw_tactic_arg) -> ('grm Pcoq.Gram.entry * int option) -> unit (** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is, Ltac grammar now accepts arguments of the form ["name" ":" "(" ")"], and generates an argument using [f] on the entry parsed by [e]. *) (** {5 Queries} *) val print_ltacs : unit -> unit (** Display the list of ltac definitions currently available. *) coq-8.6/ltac/g_obligations.ml40000644000175000017500000001207213022274260015642 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* snd (get_default_tactic ()) end in Obligations.default_tactic := tac (* We define new entries for programs, with the use of this module * Subtac. These entries are named Subtac. *) module Gram = Pcoq.Gram module Tactic = Pcoq.Tactic open Pcoq let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Specif.sig")) type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = Genarg.create_arg "withtac" let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) GEXTEND Gram GLOBAL: withtac; withtac: [ [ "with"; t = Tactic.tactic -> Some t | -> None ] ] ; Constr.closed_binder: [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in [LocalRawAssum ([id], default_binder_kind, typ)] ] ]; END open Obligations let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl | [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> [ obligation (num, Some name, Some t) tac ] | [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> [ obligation (num, Some name, None) tac ] | [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> [ obligation (num, None, Some t) tac ] | [ "Obligation" integer(num) withtac(tac) ] -> [ obligation (num, None, None) tac ] | [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> [ next_obligation (Some name) tac ] | [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ] END VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF | [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] | [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] END VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF | [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] | [ "Solve" "Obligations" "with" tactic(t) ] -> [ try_solve_obligations None (Some (Tacinterp.interp t)) ] | [ "Solve" "Obligations" ] -> [ try_solve_obligations None None ] END VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF | [ "Solve" "All" "Obligations" "with" tactic(t) ] -> [ solve_all_obligations (Some (Tacinterp.interp t)) ] | [ "Solve" "All" "Obligations" ] -> [ solve_all_obligations None ] END VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF | [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] | [ "Admit" "Obligations" ] -> [ admit_obligations None ] END VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF | [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ set_default_tactic (Locality.make_section_locality (Locality.LocalityFixme.consume ())) (Tacintern.glob_tactic t) ] END open Pp VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY | [ "Show" "Obligation" "Tactic" ] -> [ Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] END VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY | [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ] | [ "Obligations" ] -> [ show_obligations None ] END VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY | [ "Preterm" "of" ident(name) ] -> [ Feedback.msg_info (show_term (Some name)) ] | [ "Preterm" ] -> [ Feedback.msg_info (show_term None) ] END open Pp (* Declare a printer for the content of Program tactics *) let () = let printer _ _ _ = function | None -> mt () | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac in (* should not happen *) let dummy _ _ _ expr = assert false in Pptactic.declare_extra_genarg_pprule wit_withtac printer dummy dummy coq-8.6/ltac/profile_ltac.ml0000644000175000017500000003431413022274260015404 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* strbrk "Ltac Profiler cannot yet handle backtracking \ into multi-success tactics; profiling results may be wildly inaccurate.") let warn_encountered_multi_success_backtracking () = if !encountered_multi_success_backtracking then warn_profile_backtracking () let encounter_multi_success_backtracking () = if not !encountered_multi_success_backtracking then begin encountered_multi_success_backtracking := true; warn_encountered_multi_success_backtracking () end (* *************** tree data structure for profiling ****************** *) type treenode = { name : M.key; total : float; local : float; ncalls : int; max_total : float; children : treenode M.t } let empty_treenode name = { name; total = 0.0; local = 0.0; ncalls = 0; max_total = 0.0; children = M.empty; } let root = "root" module Local = Summary.Local let stack = Local.ref ~name:"LtacProf-stack" [empty_treenode root] let reset_profile_tmp () = Local.(stack := [empty_treenode root]); encountered_multi_success_backtracking := false (* ************** XML Serialization ********************* *) let rec of_ltacprof_tactic (name, t) = assert (String.equal name t.name); let open Xml_datatype in let total = string_of_float t.total in let local = string_of_float t.local in let ncalls = string_of_int t.ncalls in let max_total = string_of_float t.max_total in let children = List.map of_ltacprof_tactic (M.bindings t.children) in Element ("ltacprof_tactic", [ ("name", name); ("total",total); ("local",local); ("ncalls",ncalls); ("max_total",max_total)], children) let of_ltacprof_results t = let open Xml_datatype in assert(String.equal t.name root); let children = List.map of_ltacprof_tactic (M.bindings t.children) in Element ("ltacprof", [("total_time", string_of_float t.total)], children) let rec to_ltacprof_tactic m xml = let open Xml_datatype in match xml with | Element ("ltacprof_tactic", [("name", name); ("total",total); ("local",local); ("ncalls",ncalls); ("max_total",max_total)], xs) -> let node = { name; total = float_of_string total; local = float_of_string local; ncalls = int_of_string ncalls; max_total = float_of_string max_total; children = List.fold_left to_ltacprof_tactic M.empty xs; } in M.add name node m | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof_tactic XML") let to_ltacprof_results xml = let open Xml_datatype in match xml with | Element ("ltacprof", [("total_time", t)], xs) -> { name = root; total = float_of_string t; ncalls = 0; max_total = 0.0; local = 0.0; children = List.fold_left to_ltacprof_tactic M.empty xs } | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof XML") let feedback_results results = Feedback.(feedback (Custom (Loc.dummy_loc, "ltacprof_results", of_ltacprof_results results))) (* ************** pretty printing ************************************* *) let format_sec x = (Printf.sprintf "%.3fs" x) let format_ratio x = (Printf.sprintf "%.1f%%" (100. *. x)) let padl n s = ws (max 0 (n - utf8_length s)) ++ str s let padr n s = str s ++ ws (max 0 (n - utf8_length s)) let padr_with c n s = let ulength = utf8_length s in str (utf8_sub s 0 n) ++ str (String.make (max 0 (n - ulength)) c) let rec list_iter_is_last f = function | [] -> [] | [x] -> [f true x] | x :: xs -> f false x :: list_iter_is_last f xs let header = str " tactic local total calls max " ++ fnl () ++ str "────────────────────────────────────────┴──────┴──────┴───────┴─────────┘" ++ fnl () let rec print_node ~filter all_total indent prefix (s, e) = h 0 ( padr_with '-' 40 (prefix ^ s ^ " ") ++ padl 7 (format_ratio (e.local /. all_total)) ++ padl 7 (format_ratio (e.total /. all_total)) ++ padl 8 (string_of_int e.ncalls) ++ padl 10 (format_sec (e.max_total)) ) ++ fnl () ++ print_table ~filter all_total indent false e.children and print_table ~filter all_total indent first_level table = let fold _ n l = let s, total = n.name, n.total in if filter s total then (s, n) :: l else l in let ls = M.fold fold table [] in match ls with | [s, n] when not first_level -> v 0 (print_node ~filter all_total indent (indent ^ "└") (s, n)) | _ -> let ls = List.sort (fun (_, { total = s1 }) (_, { total = s2}) -> compare s2 s1) ls in let iter is_last = let sep0 = if first_level then "" else if is_last then " " else " │" in let sep1 = if first_level then "─" else if is_last then " └─" else " ├─" in print_node ~filter all_total (indent ^ sep0) (indent ^ sep1) in prlist (fun pr -> pr) (list_iter_is_last iter ls) let to_string ~filter ?(cutoff=0.0) node = let tree = node.children in let all_total = M.fold (fun _ { total } a -> total +. a) node.children 0.0 in let flat_tree = let global = ref M.empty in let find_tactic tname l = try M.find tname !global with Not_found -> let e = empty_treenode tname in global := M.add tname e !global; e in let add_tactic tname stats = global := M.add tname stats !global in let sum_stats add_total { name; total = t1; local = l1; ncalls = n1; max_total = m1 } { total = t2; local = l2; ncalls = n2; max_total = m2 } = { name; total = if add_total then t1 +. t2 else t1; local = l1 +. l2; ncalls = n1 + n2; max_total = if add_total then max m1 m2 else m1; children = M.empty; } in let rec cumulate table = let iter _ ({ name; children } as statistics) = if filter name then begin let stats' = find_tactic name global in add_tactic name (sum_stats true stats' statistics); end; cumulate children in M.iter iter table in cumulate tree; !global in warn_encountered_multi_success_backtracking (); let filter s n = filter s && (all_total <= 0.0 || n /. all_total >= cutoff /. 100.0) in let msg = h 0 (str "total time: " ++ padl 11 (format_sec (all_total))) ++ fnl () ++ fnl () ++ header ++ print_table ~filter all_total "" true flat_tree ++ fnl () ++ header ++ print_table ~filter all_total "" true tree in msg (* ******************** profiling code ************************************** *) let get_child name node = try M.find name node.children with Not_found -> empty_treenode name let time () = let times = Unix.times () in times.Unix.tms_utime +. times.Unix.tms_stime let string_of_call ck = let s = string_of_ppcmds (match ck with | Tacexpr.LtacNotationCall s -> Pptactic.pr_alias_key s | Tacexpr.LtacNameCall cst -> Pptactic.pr_ltac_constant cst | Tacexpr.LtacVarCall (id, t) -> Nameops.pr_id id | Tacexpr.LtacAtomCall te -> (Pptactic.pr_glob_tactic (Global.env ()) (Tacexpr.TacAtom (Loc.ghost, te))) | Tacexpr.LtacConstrInterp (c, _) -> pr_glob_constr_env (Global.env ()) c | Tacexpr.LtacMLCall te -> (Pptactic.pr_glob_tactic (Global.env ()) te) ) in for i = 0 to String.length s - 1 do if s.[i] = '\n' then s.[i] <- ' ' done; let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in CString.strip s let rec merge_sub_tree name tree acc = try let t = M.find name acc in let t = { name; total = t.total +. tree.total; ncalls = t.ncalls + tree.ncalls; local = t.local +. tree.local; max_total = max t.max_total tree.max_total; children = M.fold merge_sub_tree tree.children t.children; } in M.add name t acc with Not_found -> M.add name tree acc let merge_roots ?(disjoint=true) t1 t2 = assert(String.equal t1.name t2.name); { name = t1.name; ncalls = t1.ncalls + t2.ncalls; local = if disjoint then t1.local +. t2.local else t1.local; total = if disjoint then t1.total +. t2.total else t1.total; max_total = if disjoint then max t1.max_total t2.max_total else t1.max_total; children = M.fold merge_sub_tree t2.children t1.children } let rec find_in_stack what acc = function | [] -> None | { name } as x :: rest when String.equal name what -> Some(acc, x, rest) | { name } as x :: rest -> find_in_stack what (x :: acc) rest let exit_tactic start_time c = let diff = time () -. start_time in match Local.(!stack) with | [] | [_] -> (* oops, our stack is invalid *) encounter_multi_success_backtracking (); reset_profile_tmp () | node :: (parent :: rest as full_stack) -> let name = string_of_call c in if not (String.equal name node.name) then (* oops, our stack is invalid *) encounter_multi_success_backtracking (); let node = { node with total = node.total +. diff; local = node.local +. diff; ncalls = node.ncalls + 1; max_total = max node.max_total diff; } in (* updating the stack *) let parent = match find_in_stack node.name [] full_stack with | None -> (* no rec-call, we graft the subtree *) let parent = { parent with local = parent.local -. diff; children = M.add node.name node parent.children } in Local.(stack := parent :: rest); parent | Some(to_update, self, rest) -> (* we coalesce the rec-call and update the lower stack *) let self = merge_roots ~disjoint:false self node in let updated_stack = List.fold_left (fun s x -> (try M.find x.name (List.hd s).children with Not_found -> x) :: s) (self :: rest) to_update in Local.(stack := updated_stack); List.hd Local.(!stack) in (* Calls are over, we reset the stack and send back data *) if rest == [] && get_profiling () then begin assert(String.equal root parent.name); reset_profile_tmp (); feedback_results parent end let tclFINALLY tac (finally : unit Proofview.tactic) = let open Proofview.Notations in Proofview.tclIFCATCH tac (fun v -> finally <*> Proofview.tclUNIT v) (fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn) let do_profile s call_trace tac = let open Proofview.Notations in Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> if !is_profiling then match call_trace, Local.(!stack) with | (_, c) :: _, parent :: rest -> let name = string_of_call c in let node = get_child name parent in Local.(stack := node :: parent :: rest); Some (time ()) | _ :: _, [] -> assert false | _ -> None else None)) >>= function | Some start_time -> tclFINALLY tac (Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> (match call_trace with | (_, c) :: _ -> exit_tactic start_time c | [] -> ())))) | None -> tac (* ************** Accumulation of data from workers ************************* *) let get_local_profiling_results () = List.hd Local.(!stack) module SM = Map.Make(Stateid.Self) let data = ref SM.empty let _ = Feedback.(add_feeder (function | { id = State s; contents = Custom (_, "ltacprof_results", xml) } -> let results = to_ltacprof_results xml in let other_results = (* Multi success can cause this *) try SM.find s !data with Not_found -> empty_treenode root in data := SM.add s (merge_roots results other_results) !data | _ -> ())) let reset_profile () = reset_profile_tmp (); data := SM.empty (* ******************** *) let print_results_filter ~cutoff ~filter = let valid id _ = Stm.state_of_id id <> `Expired in data := SM.filter valid !data; let results = SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in let results = merge_roots results Local.(CList.last !stack) in Feedback.msg_notice (to_string ~cutoff ~filter results) ;; let print_results ~cutoff = print_results_filter ~cutoff ~filter:(fun _ -> true) let print_results_tactic tactic = print_results_filter ~cutoff:!Flags.profile_ltac_cutoff ~filter:(fun s -> String.(equal tactic (sub (s ^ ".") 0 (min (1+length s) (length tactic))))) let do_print_results_at_close () = if get_profiling () then print_results ~cutoff:!Flags.profile_ltac_cutoff let _ = Declaremods.append_end_library_hook do_print_results_at_close let _ = let open Goptions in declare_bool_option { optsync = true; optdepr = false; optname = "Ltac Profiling"; optkey = ["Ltac"; "Profiling"]; optread = get_profiling; optwrite = set_profiling } coq-8.6/ltac/tauto.ml0000644000175000017500000002245113022274260014074 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* c | None -> failwith "tauto: anomaly" (** Parametrization of tauto *) type tauto_flags = { (* Whether conjunction and disjunction are restricted to binary connectives *) binary_mode : bool; (* Whether compatibility for buggy detection of binary connective is on *) binary_mode_bugged_detection : bool; (* Whether conjunction and disjunction are restricted to the connectives *) (* having the structure of "and" and "or" (up to the choice of sorts) in *) (* contravariant position in an hypothesis *) strict_in_contravariant_hyp : bool; (* Whether conjunction and disjunction are restricted to the connectives *) (* having the structure of "and" and "or" (up to the choice of sorts) in *) (* an hypothesis and in the conclusion *) strict_in_hyp_and_ccl : bool; (* Whether unit type includes equality types *) strict_unit : bool; } let tag_tauto_flags : tauto_flags Val.typ = Val.create "tauto_flags" let assoc_flags ist : tauto_flags = let Val.Dyn (tag, v) = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in match Val.eq tag tag_tauto_flags with | None -> assert false | Some Refl -> v (* Whether inner not are unfolded *) let negation_unfolding = ref true (* Whether inner iff are unfolded *) let iff_unfolding = ref false let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 open Goptions let _ = declare_bool_option { optsync = true; optdepr = false; optname = "unfolding of not in intuition"; optkey = ["Intuition";"Negation";"Unfolding"]; optread = (fun () -> !negation_unfolding); optwrite = (:=) negation_unfolding } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "unfolding of iff in intuition"; optkey = ["Intuition";"Iff";"Unfolding"]; optread = (fun () -> !iff_unfolding); optwrite = (:=) iff_unfolding } (** Base tactics *) let loc = Loc.ghost let idtac = Proofview.tclUNIT () let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ())) let intro = Tactics.intro let assert_ ?by c = let tac = match by with | None -> None | Some tac -> Some (Some tac) in Proofview.tclINDEPENDENT (Tactics.forward true tac None c) let apply c = Tactics.apply c let clear id = Tactics.clear [id] let assumption = Tactics.assumption let split = Tactics.split_with_bindings false [Misctypes.NoBindings] (** Test *) let is_empty _ ist = if is_empty_type (assoc_var "X1" ist) then idtac else fail (* Strictly speaking, this exceeds the propositional fragment as it matches also equality types (and solves them if a reflexivity) *) let is_unit_or_eq _ ist = let flags = assoc_flags ist in let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in if test (assoc_var "X1" ist) then idtac else fail let bugged_is_binary t = isApp t && let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind (ind,u) -> let (mib,mip) = Global.lookup_inductive ind in Int.equal mib.Declarations.mind_nparams 2 | _ -> false (** Dealing with conjunction *) let is_conj _ ist = let flags = assoc_flags ist in let ind = assoc_var "X1" ist in if (not flags.binary_mode_bugged_detection || bugged_is_binary ind) && is_conjunction ~strict:flags.strict_in_hyp_and_ccl ~onlybinary:flags.binary_mode ind then idtac else fail let flatten_contravariant_conj _ ist = let flags = assoc_flags ist in let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in let hyp = assoc_var "id" ist in match match_with_conjunction ~strict:flags.strict_in_contravariant_hyp ~onlybinary:flags.binary_mode typ with | Some (_,args) -> let newtyp = List.fold_right mkArrow args c in let intros = tclMAP (fun _ -> intro) args in let by = tclTHENLIST [intros; apply hyp; split; assumption] in tclTHENLIST [assert_ ~by newtyp; clear (destVar hyp)] | _ -> fail (** Dealing with disjunction *) let is_disj _ ist = let flags = assoc_flags ist in let t = assoc_var "X1" ist in if (not flags.binary_mode_bugged_detection || bugged_is_binary t) && is_disjunction ~strict:flags.strict_in_hyp_and_ccl ~onlybinary:flags.binary_mode t then idtac else fail let flatten_contravariant_disj _ ist = let flags = assoc_flags ist in let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in let hyp = assoc_var "id" ist in match match_with_disjunction ~strict:flags.strict_in_contravariant_hyp ~onlybinary:flags.binary_mode typ with | Some (_,args) -> let map i arg = let typ = mkArrow arg c in let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings in let by = tclTHENLIST [intro; apply hyp; ci; assumption] in assert_ ~by typ in let tacs = List.mapi map args in let tac0 = clear (destVar hyp) in tclTHEN (tclTHENLIST tacs) tac0 | _ -> fail let make_unfold name = let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in let const = Constant.make2 (MPfile dir) (Label.make name) in (Locus.AllOccurrences, ArgArg (EvalConstRef const, None)) let u_iff = make_unfold "iff" let u_not = make_unfold "not" let reduction_not_iff _ ist = let make_reduce c = TacAtom (loc, TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in let tac = match !negation_unfolding, unfold_iff () with | true, true -> make_reduce [u_not; u_iff] | true, false -> make_reduce [u_not] | false, true -> make_reduce [u_iff] | false, false -> TacId [] in eval_tactic_ist ist tac let coq_nnpp_path = let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP") let apply_nnpp _ ist = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> try let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in apply nnpp with Not_found -> tclFAIL 0 (Pp.mt ()) end (* This is the uniform mode dealing with ->, not, iff and types isomorphic to /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. For the moment not and iff are still always unfolded. *) let tauto_uniform_unit_flags = { binary_mode = true; binary_mode_bugged_detection = false; strict_in_contravariant_hyp = true; strict_in_hyp_and_ccl = true; strict_unit = false } (* This is the compatibility mode (not used) *) let tauto_legacy_flags = { binary_mode = true; binary_mode_bugged_detection = true; strict_in_contravariant_hyp = true; strict_in_hyp_and_ccl = false; strict_unit = false } (* This is the improved mode *) let tauto_power_flags = { binary_mode = false; (* support n-ary connectives *) binary_mode_bugged_detection = false; strict_in_contravariant_hyp = false; (* supports non-regular connectives *) strict_in_hyp_and_ccl = false; strict_unit = false } let with_flags flags _ ist = let f = (loc, Id.of_string "f") in let x = (loc, Id.of_string "x") in let arg = Val.Dyn (tag_tauto_flags, flags) in let ist = { ist with lfun = Id.Map.add (snd x) arg ist.lfun } in eval_tactic_ist ist (TacArg (loc, TacCall (loc, ArgVar f, [Reference (ArgVar x)]))) let register_tauto_tactic tac name0 args = let ids = List.map (fun id -> Id.of_string id) args in let ids = List.map (fun id -> Some id) ids in let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in let entry = { mltac_name = name; mltac_index = 0 } in let () = Tacenv.register_ml_tactic name [| tac |] in let tac = TacFun (ids, TacML (loc, entry, [])) in let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in Mltop.declare_cache_obj obj tauto_plugin let () = register_tauto_tactic is_empty "is_empty" ["tauto_flags"; "X1"] let () = register_tauto_tactic is_unit_or_eq "is_unit_or_eq" ["tauto_flags"; "X1"] let () = register_tauto_tactic is_disj "is_disj" ["tauto_flags"; "X1"] let () = register_tauto_tactic is_conj "is_conj" ["tauto_flags"; "X1"] let () = register_tauto_tactic flatten_contravariant_disj "flatten_contravariant_disj" ["tauto_flags"; "X1"; "X2"; "id"] let () = register_tauto_tactic flatten_contravariant_conj "flatten_contravariant_conj" ["tauto_flags"; "X1"; "X2"; "id"] let () = register_tauto_tactic apply_nnpp "apply_nnpp" [] let () = register_tauto_tactic reduction_not_iff "reduction_not_iff" [] let () = register_tauto_tactic (with_flags tauto_uniform_unit_flags) "with_uniform_flags" ["f"] let () = register_tauto_tactic (with_flags tauto_power_flags) "with_power_flags" ["f"] coq-8.6/ltac/profile_ltac_tactics.ml40000644000175000017500000000270213022274260017176 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* set_profiling b)) TACTIC EXTEND start_ltac_profiling | [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ] END TACTIC EXTEND stop_profiling | [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ] END VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF [ "Reset" "Ltac" "Profile" ] -> [ reset_profile() ] END VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY | [ "Show" "Ltac" "Profile" ] -> [ print_results ~cutoff:!Flags.profile_ltac_cutoff ] | [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> [ print_results ~cutoff:(float_of_int n) ] END VERNAC COMMAND EXTEND ShowLtacProfileTactic CLASSIFIED AS QUERY [ "Show" "Ltac" "Profile" string(s) ] -> [ print_results_tactic s ] END coq-8.6/ltac/tacintern.mli0000644000175000017500000000373413022274260015103 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* glob_sign (** same as [fully_empty_glob_sign], but with [Global.env()] as environment *) (** Main globalization functions *) val glob_tactic : raw_tactic_expr -> glob_tactic_expr val glob_tactic_env : Id.t list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr (** Low-level variants *) val intern_pure_tactic : glob_sign -> raw_tactic_expr -> glob_tactic_expr val intern_tactic_or_tacarg : glob_sign -> raw_tactic_expr -> Tacexpr.glob_tactic_expr val intern_constr : glob_sign -> constr_expr -> glob_constr_and_expr val intern_constr_with_bindings : glob_sign -> constr_expr * constr_expr bindings -> glob_constr_and_expr * glob_constr_and_expr bindings val intern_hyp : glob_sign -> Id.t Loc.located -> Id.t Loc.located (** Adds a globalization function for extra generic arguments *) val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument (** printing *) val print_ltac : Libnames.qualid -> std_ppcmds (** Reduction expressions *) val intern_red_expr : glob_sign -> raw_red_expr -> glob_red_expr val dump_glob_red_expr : raw_red_expr -> unit (* Hooks *) val strict_check : bool ref coq-8.6/ltac/taccoerce.mli0000644000175000017500000000606513022274260015044 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t (** Eliminated the leading dynamic type casts. *) val of_constr : constr -> t val to_constr : t -> constr option val of_uconstr : Glob_term.closed_glob_constr -> t val to_uconstr : t -> Glob_term.closed_glob_constr option val of_int : int -> t val to_int : t -> int option val to_list : t -> t list option val to_option : t -> t option option val to_pair : t -> (t * t) option end (** {5 Coercion functions} *) val coerce_to_constr_context : Value.t -> constr val coerce_var_to_ident : bool -> Environ.env -> Value.t -> Id.t val coerce_to_ident_not_fresh : Evd.evar_map -> Environ.env -> Value.t -> Id.t val coerce_to_intro_pattern : Environ.env -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr val coerce_to_intro_pattern_naming : Environ.env -> Value.t -> intro_pattern_naming_expr val coerce_to_hint_base : Value.t -> string val coerce_to_int : Value.t -> int val coerce_to_constr : Environ.env -> Value.t -> constr_under_binders val coerce_to_uconstr : Environ.env -> Value.t -> Glob_term.closed_glob_constr val coerce_to_closed_constr : Environ.env -> Value.t -> constr val coerce_to_evaluable_ref : Environ.env -> Value.t -> evaluable_global_reference val coerce_to_constr_list : Environ.env -> Value.t -> constr list val coerce_to_intro_pattern_list : Loc.t -> Environ.env -> Value.t -> Tacexpr.intro_patterns val coerce_to_hyp : Environ.env -> Value.t -> Id.t val coerce_to_hyp_list : Environ.env -> Value.t -> Id.t list val coerce_to_reference : Environ.env -> Value.t -> Globnames.global_reference val coerce_to_quantified_hypothesis : Value.t -> quantified_hypothesis val coerce_to_decl_or_quant_hyp : Environ.env -> Value.t -> quantified_hypothesis val coerce_to_int_or_var_list : Value.t -> int or_var list (** {5 Missing generic arguments} *) val wit_constr_context : (Empty.t, Empty.t, constr) genarg_type val wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) genarg_type coq-8.6/ltac/g_auto.ml40000644000175000017500000001571613022274260014310 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ Eauto.e_assumption ] END TACTIC EXTEND eexact | [ "eexact" constr(c) ] -> [ Eauto.e_give_exact c ] END let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases ARGUMENT EXTEND hintbases TYPED AS preident_list_opt PRINTED BY pr_hintbases | [ "with" "*" ] -> [ None ] | [ "with" ne_preident_list(l) ] -> [ Some l ] | [ ] -> [ Some [] ] END let eval_uconstrs ist cs = let flags = { Pretyping.use_typeclasses = false; solve_unification_constraints = true; use_hook = Some Pfedit.solve_by_implicit_tactic; fail_evar = false; expand_evars = true } in List.map (fun c -> Pretyping.type_uconstr ~flags ist c) cs let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr c) let pr_auto_using _ _ _ = Pptactic.pr_auto_using Printer.pr_closed_glob ARGUMENT EXTEND auto_using TYPED AS uconstr_list PRINTED BY pr_auto_using RAW_TYPED AS uconstr_list RAW_PRINTED BY pr_auto_using_raw GLOB_TYPED AS uconstr_list GLOB_PRINTED BY pr_auto_using_glob | [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ] | [ ] -> [ [] ] END (** Auto *) TACTIC EXTEND trivial | [ "trivial" auto_using(lems) hintbases(db) ] -> [ Auto.h_trivial (eval_uconstrs ist lems) db ] END TACTIC EXTEND info_trivial | [ "info_trivial" auto_using(lems) hintbases(db) ] -> [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ] END TACTIC EXTEND debug_trivial | [ "debug" "trivial" auto_using(lems) hintbases(db) ] -> [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ] END TACTIC EXTEND auto | [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> [ Auto.h_auto n (eval_uconstrs ist lems) db ] END TACTIC EXTEND info_auto | [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ] END TACTIC EXTEND debug_auto | [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ] END (** Eauto *) TACTIC EXTEND prolog | [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> [ Eauto.prolog_tac (eval_uconstrs ist l) n ] END let make_depth n = snd (Eauto.make_dimension n None) TACTIC EXTEND eauto | [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> [ Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] END TACTIC EXTEND new_eauto | [ "new" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> [ match db with | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l ] END TACTIC EXTEND debug_eauto | [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> [ Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] END TACTIC EXTEND info_eauto | [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> [ Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] END TACTIC EXTEND dfs_eauto | [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> [ Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db ] END TACTIC EXTEND autounfold | [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> [ Eauto.autounfold_tac db cl ] END TACTIC EXTEND autounfold_one | [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) ] | [ "autounfold_one" hintbases(db) ] -> [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] END TACTIC EXTEND autounfoldify | [ "autounfoldify" constr(x) ] -> [ let db = match Term.kind_of_term x with | Term.Const (c,_) -> Names.Label.to_string (Names.con_label c) | _ -> assert false in Eauto.autounfold ["core";db] Locusops.onConcl ] END TACTIC EXTEND unify | ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ] | ["unify" constr(x) constr(y) "with" preident(base) ] -> [ let table = try Some (Hints.searchtable_map base) with Not_found -> None in match table with | None -> let msg = str "Hint table " ++ str base ++ str " not found" in Tacticals.New.tclZEROMSG msg | Some t -> let state = Hints.Hint_db.transparent_state t in Tactics.unify ~state x y ] END TACTIC EXTEND convert_concl_no_check | ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ] END let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_reference let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global let glob_hints_path_atom ist = Hints.glob_hints_path_atom ARGUMENT EXTEND hints_path_atom PRINTED BY pr_hints_path_atom GLOBALIZED BY glob_hints_path_atom RAW_PRINTED BY pr_pre_hints_path_atom GLOB_PRINTED BY pr_hints_path_atom | [ ne_global_list(g) ] -> [ Hints.PathHints g ] | [ "_" ] -> [ Hints.PathAny ] END let pr_hints_path prc prx pry c = Hints.pp_hints_path c let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_reference c let glob_hints_path ist = Hints.glob_hints_path ARGUMENT EXTEND hints_path PRINTED BY pr_hints_path GLOBALIZED BY glob_hints_path RAW_PRINTED BY pr_pre_hints_path GLOB_PRINTED BY pr_hints_path | [ "(" hints_path(p) ")" ] -> [ p ] | [ hints_path(p) "*" ] -> [ Hints.PathStar p ] | [ "emp" ] -> [ Hints.PathEmpty ] | [ "eps" ] -> [ Hints.PathEpsilon ] | [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ] | [ hints_path_atom(a) ] -> [ Hints.PathAtom a ] | [ hints_path(p) hints_path(q) ] -> [ Hints.PathSeq (p, q) ] END ARGUMENT EXTEND opthints TYPED AS preident_list_opt PRINTED BY pr_hintbases | [ ":" ne_preident_list(l) ] -> [ Some l ] | [ ] -> [ None ] END VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF | [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ())) (match dbnames with None -> ["core"] | Some l -> l) entry ] END coq-8.6/ltac/extratactics.ml40000644000175000017500000011074013022274260015521 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* replace_in_clause_maybe_by c1 c2 cl (Option.map (Tacinterp.tactic_of_value ist) tac)) let replace_term ist dir_opt c cl = with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) let clause = Pcoq.Tactic.clause_dft_concl TACTIC EXTEND replace ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] -> [ replace_in_clause_maybe_by ist c1 c2 cl tac ] END TACTIC EXTEND replace_term_left [ "replace" "->" uconstr(c) clause(cl) ] -> [ replace_term ist (Some true) c cl ] END TACTIC EXTEND replace_term_right [ "replace" "<-" uconstr(c) clause(cl) ] -> [ replace_term ist (Some false) c cl ] END TACTIC EXTEND replace_term [ "replace" uconstr(c) clause(cl) ] -> [ replace_term ist None c cl ] END let induction_arg_of_quantified_hyp = function | AnonHyp n -> None,ElimOnAnonHyp n | NamedHyp id -> None,ElimOnIdent (Loc.ghost,id) (* Versions *_main must come first!! so that "1" is interpreted as a ElimOnAnonHyp and not as a "constr", and "id" is interpreted as a ElimOnIdent and not as "constr" *) let mytclWithHoles tac with_evars c = Proofview.Goal.enter { enter = begin fun gl -> let env = Tacmach.New.pf_env gl in let sigma = Tacmach.New.project gl in let sigma',c = Tactics.force_destruction_arg with_evars env sigma c in Tacticals.New.tclWITHHOLES with_evars (tac with_evars (Some c)) sigma' end } let elimOnConstrWithHoles tac with_evars c = Tacticals.New.tclDELAYEDWITHHOLES with_evars c (fun c -> tac with_evars (Some (None,ElimOnConstr c))) TACTIC EXTEND simplify_eq [ "simplify_eq" ] -> [ dEq false None ] | [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq false c ] END TACTIC EXTEND esimplify_eq | [ "esimplify_eq" ] -> [ dEq true None ] | [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq true c ] END let discr_main c = elimOnConstrWithHoles discr_tac false c TACTIC EXTEND discriminate | [ "discriminate" ] -> [ discr_tac false None ] | [ "discriminate" destruction_arg(c) ] -> [ mytclWithHoles discr_tac false c ] END TACTIC EXTEND ediscriminate | [ "ediscriminate" ] -> [ discr_tac true None ] | [ "ediscriminate" destruction_arg(c) ] -> [ mytclWithHoles discr_tac true c ] END let discrHyp id = Proofview.tclEVARMAP >>= fun sigma -> discr_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } let injection_main with_evars c = elimOnConstrWithHoles (injClause None) with_evars c TACTIC EXTEND injection | [ "injection" ] -> [ injClause None false None ] | [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) false c ] END TACTIC EXTEND einjection | [ "einjection" ] -> [ injClause None true None ] | [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) true c ] END TACTIC EXTEND injection_as | [ "injection" "as" intropattern_list(ipat)] -> [ injClause (Some ipat) false None ] | [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] -> [ mytclWithHoles (injClause (Some ipat)) false c ] END TACTIC EXTEND einjection_as | [ "einjection" "as" intropattern_list(ipat)] -> [ injClause (Some ipat) true None ] | [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] -> [ mytclWithHoles (injClause (Some ipat)) true c ] END TACTIC EXTEND simple_injection | [ "simple" "injection" ] -> [ simpleInjClause false None ] | [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles simpleInjClause false c ] END let injHyp id = Proofview.tclEVARMAP >>= fun sigma -> injection_main false { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } TACTIC EXTEND dependent_rewrite | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] | [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ] -> [ rewriteInHyp b c id ] END (** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to "replace u with t" or "enough (t=u) as <-" and "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *) TACTIC EXTEND cut_rewrite | [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] | [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] -> [ cutRewriteInHyp b eqn id ] END (**********************************************************************) (* Decompose *) TACTIC EXTEND decompose_sum | [ "decompose" "sum" constr(c) ] -> [ Elim.h_decompose_or c ] END TACTIC EXTEND decompose_record | [ "decompose" "record" constr(c) ] -> [ Elim.h_decompose_and c ] END (**********************************************************************) (* Contradiction *) open Contradiction TACTIC EXTEND absurd [ "absurd" constr(c) ] -> [ absurd c ] END let onSomeWithHoles tac = function | None -> tac None | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c)) TACTIC EXTEND contradiction [ "contradiction" constr_with_bindings_opt(c) ] -> [ onSomeWithHoles contradiction c ] END (**********************************************************************) (* AutoRewrite *) open Autorewrite let pr_orient _prc _prlc _prt = function | true -> Pp.mt () | false -> Pp.str " <-" let pr_orient_string _prc _prlc _prt (orient, s) = pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string | [ orient(r) preident(i) ] -> [ r, i ] END TACTIC EXTEND autorewrite | [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] -> [ auto_multi_rewrite l ( cl) ] | [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> [ auto_multi_rewrite_with (Tacinterp.tactic_of_value ist t) l cl ] END TACTIC EXTEND autorewrite_star | [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] -> [ auto_multi_rewrite ~conds:AllMatches l cl ] | [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl ] END (**********************************************************************) (* Rewrite star *) let rewrite_star ist clause orient occs c (tac : Geninterp.Val.t option) = let tac' = Option.map (fun t -> Tacinterp.tactic_of_value ist t, FirstSolved) tac in with_delayed_uconstr ist c (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) TACTIC EXTEND rewrite_star | [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] | [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] | [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] -> [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ] | [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> [ rewrite_star ist None o (occurrences_of occ) c tac ] | [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] -> [ rewrite_star ist None o Locus.AllOccurrences c tac ] END (**********************************************************************) (* Hint Rewrite *) let add_rewrite_hint bases ort t lcsr = let env = Global.env() in let sigma = Evd.from_env env in let poly = Flags.use_polymorphic_flag () in let f ce = let c, ctx = Constrintern.interp_constr env sigma ce in let ctx = let ctx = UState.context_set ctx in if poly then ctx else (** This is a global universe context that shouldn't be refreshed at every use of the hint, declare it globally. *) (Declare.declare_universe_context false ctx; Univ.ContextSet.empty) in Constrexpr_ops.constr_loc ce, (c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t in let eqs = List.map f lcsr in let add_hints base = add_rew_rules base eqs in List.iter add_hints bases let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY classify_hint [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> [ add_rewrite_hint bl o None l ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ":" preident_list(bl) ] -> [ add_rewrite_hint bl o (Some t) l ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> [ add_rewrite_hint ["core"] o None l ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> [ add_rewrite_hint ["core"] o (Some t) l ] END (**********************************************************************) (* Hint Resolve *) open Term open Vars open Coqlib let project_hint pri l2r r = let gr = Smartlocate.global_with_alias r in let env = Global.env() in let sigma = Evd.from_env env in let sigma, c = Evd.fresh_global env sigma gr in let t = Retyping.get_type_of env sigma c in let t = Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in let sign,ccl = decompose_prod_assum t in let (a,b) = match snd (decompose_app ccl) with | [a;b] -> (a,b) | _ -> assert false in let p = if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in let c = Reductionops.whd_beta Evd.empty (mkApp (c, Context.Rel.to_extended_vect 0 sign)) in let c = it_mkLambda_or_LetIn (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in let id = Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) in let ctx = Evd.universe_context_set sigma in let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) let add_hints_iff l2r lc n bl = Hints.add_hints true bl (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc)) VERNAC COMMAND EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ":" preident_list(bl) ] -> [ add_hints_iff true lc n bl ] | [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] -> [ add_hints_iff true lc n ["core"] ] END VERNAC COMMAND EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ":" preident_list(bl) ] -> [ add_hints_iff false lc n bl ] | [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] -> [ add_hints_iff false lc n ["core"] ] END (**********************************************************************) (* Refine *) let constr_flags = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = true; Pretyping.use_hook = Some Pfedit.solve_by_implicit_tactic; Pretyping.fail_evar = false; Pretyping.expand_evars = true } let refine_tac ist simple with_classes c = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let flags = { constr_flags with Pretyping.use_typeclasses = with_classes } in let expected_type = Pretyping.OfType concl in let c = Pretyping.type_uconstr ~flags ~expected_type ist c in let update = { run = fun sigma -> c.delayed env sigma } in let refine = Refine.refine ~unsafe:true update in if simple then refine else refine <*> Tactics.New.reduce_after_refine <*> Proofview.shelve_unifiable end } TACTIC EXTEND refine | [ "refine" uconstr(c) ] -> [ refine_tac ist false true c ] END TACTIC EXTEND simple_refine | [ "simple" "refine" uconstr(c) ] -> [ refine_tac ist true true c ] END TACTIC EXTEND notcs_refine | [ "notypeclasses" "refine" uconstr(c) ] -> [ refine_tac ist false false c ] END TACTIC EXTEND notcs_simple_refine | [ "simple" "notypeclasses" "refine" uconstr(c) ] -> [ refine_tac ist true false c ] END (* Solve unification constraints using heuristics or fail if any remain *) TACTIC EXTEND solve_constraints [ "solve_constraints" ] -> [ Refine.solve_constraints ] END (**********************************************************************) (* Inversion lemmas (Leminv) *) open Inv open Leminv let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater VERNAC ARGUMENT EXTEND sort | [ "Set" ] -> [ GSet ] | [ "Prop" ] -> [ GProp ] | [ "Type" ] -> [ GType [] ] END VERNAC COMMAND EXTEND DeriveInversionClear | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] => [ seff na ] -> [ add_inversion_lemma_exn na c s false inv_clear_tac ] | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ] -> [ add_inversion_lemma_exn na c GProp false inv_clear_tac ] END open Term VERNAC COMMAND EXTEND DeriveInversion | [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] => [ seff na ] -> [ add_inversion_lemma_exn na c s false inv_tac ] | [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ] -> [ add_inversion_lemma_exn na c GProp false inv_tac ] END VERNAC COMMAND EXTEND DeriveDependentInversion | [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] => [ seff na ] -> [ add_inversion_lemma_exn na c s true dinv_tac ] END VERNAC COMMAND EXTEND DeriveDependentInversionClear | [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] => [ seff na ] -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ] END (**********************************************************************) (* Subst *) TACTIC EXTEND subst | [ "subst" ne_var_list(l) ] -> [ subst l ] | [ "subst" ] -> [ subst_all () ] END let simple_subst_tactic_flags = { only_leibniz = true; rewrite_dependent_proof = false } TACTIC EXTEND simple_subst | [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags () ] END open Evar_tactics (**********************************************************************) (* Evar creation *) (* TODO: add support for some test similar to g_constr.name_colon so that expressions like "evar (list A)" do not raise a syntax error *) TACTIC EXTEND evar [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ] | [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ] END TACTIC EXTEND instantiate [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] -> [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ] | [ "instantiate" "(" integer(i) ":=" lglob(c) ")" hloc(hl) ] -> [ Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals ] | [ "instantiate" ] -> [ Proofview.V82.nf_evar_goals ] END (**********************************************************************) (** Nijmegen "step" tactic for setoid rewriting *) open Tactics open Glob_term open Libobject open Lib (* Registered lemmas are expected to be of the form x R y -> y == z -> x R z (in the right table) x R y -> x == z -> z R y (in the left table) *) let transitivity_right_table = Summary.ref [] ~name:"transitivity-steps-r" let transitivity_left_table = Summary.ref [] ~name:"transitivity-steps-l" (* [step] tries to apply a rewriting lemma; then apply [tac] intended to complete to proof of the last hypothesis (assumed to state an equality) *) let step left x tac = let l = List.map (fun lem -> Tacticals.New.tclTHENLAST (apply_with_bindings (lem, ImplicitBindings [x])) tac) !(if left then transitivity_left_table else transitivity_right_table) in Tacticals.New.tclFIRST l (* Main function to push lemmas in persistent environment *) let cache_transitivity_lemma (_,(left,lem)) = if left then transitivity_left_table := lem :: !transitivity_left_table else transitivity_right_table := lem :: !transitivity_right_table let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) let inTransitivity : bool * constr -> obj = declare_object {(default_object "TRANSITIVITY-STEPS") with cache_function = cache_transitivity_lemma; open_function = (fun i o -> if Int.equal i 1 then cache_transitivity_lemma o); subst_function = subst_transitivity_lemma; classify_function = (fun o -> Substitute o) } (* Main entry points *) let add_transitivity_lemma left lem = let env = Global.env () in let sigma = Evd.from_env env in let lem',ctx (*FIXME*) = Constrintern.interp_constr env sigma lem in add_anonymous_leaf (inTransitivity (left,lem')) (* Vernacular syntax *) TACTIC EXTEND stepl | ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.tactic_of_value ist tac) ] | ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ] END TACTIC EXTEND stepr | ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.tactic_of_value ist tac) ] | ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ] END VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF | [ "Declare" "Left" "Step" constr(t) ] -> [ add_transitivity_lemma true t ] END VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF | [ "Declare" "Right" "Step" constr(t) ] -> [ add_transitivity_lemma false t ] END let cache_implicit_tactic (_,tac) = match tac with | Some tac -> Pfedit.declare_implicit_tactic (Tacinterp.eval_tactic tac) | None -> Pfedit.clear_implicit_tactic () let subst_implicit_tactic (subst,tac) = Option.map (Tacsubst.subst_tactic subst) tac let inImplicitTactic : glob_tactic_expr option -> obj = declare_object {(default_object "IMPLICIT-TACTIC") with open_function = (fun i o -> if Int.equal i 1 then cache_implicit_tactic o); cache_function = cache_implicit_tactic; subst_function = subst_implicit_tactic; classify_function = (fun o -> Dispose)} let declare_implicit_tactic tac = Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac))) let clear_implicit_tactic () = Lib.add_anonymous_leaf (inImplicitTactic None) VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF | [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> [ declare_implicit_tactic tac ] | [ "Clear" "Implicit" "Tactic" ] -> [ clear_implicit_tactic () ] END (**********************************************************************) (*spiwack : Vernac commands for retroknowledge *) VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> [ let tc,ctx = Constrintern.interp_constr (Global.env ()) Evd.empty c in let tb,ctx(*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty b in Global.register f tc tb ] END (**********************************************************************) (* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as defined by Conor McBride *) TACTIC EXTEND generalize_eqs | ["generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false id ] END TACTIC EXTEND dep_generalize_eqs | ["dependent" "generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false ~force_dep:true id ] END TACTIC EXTEND generalize_eqs_vars | ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~generalize_vars:true id ] END TACTIC EXTEND dep_generalize_eqs_vars | ["dependent" "generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~force_dep:true ~generalize_vars:true id ] END (** Tactic to automatically simplify hypotheses of the form [Π Δ, x_i = t_i -> T] where [t_i] is closed w.r.t. Δ. Such hypotheses are automatically generated during dependent induction. For internal use. *) TACTIC EXTEND specialize_eqs [ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ] END (**********************************************************************) (* A tactic that considers a given occurrence of [c] in [t] and *) (* abstract the minimal set of all the occurrences of [c] so that the *) (* abstraction [fun x -> t[x/c]] is well-typed *) (* *) (* Contributed by Chung-Kil Hur (Winter 2009) *) (**********************************************************************) let subst_var_with_hole occ tid t = let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in let locref = ref 0 in let rec substrec = function | GVar (_,id) as x -> if Id.equal id tid then (decr occref; if Int.equal !occref 0 then x else (incr locref; GHole (Loc.make_loc (!locref,0), Evar_kinds.QuestionMark(Evar_kinds.Define true), Misctypes.IntroAnonymous, None))) else x | c -> map_glob_constr_left_to_right substrec c in let t' = substrec t in if !occref > 0 then Find_subterm.error_invalid_occurrence [occ] else t' let subst_hole_with_term occ tc t = let locref = ref 0 in let occref = ref occ in let rec substrec = function | GHole (_,Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s) -> decr occref; if Int.equal !occref 0 then tc else (incr locref; GHole (Loc.make_loc (!locref,0), Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s)) | c -> map_glob_constr_left_to_right substrec c in substrec t open Tacmach let hResolve id c occ t = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let sigma = Sigma.to_evar_map sigma in let env = Termops.clear_named_body id (Proofview.Goal.env gl) in let concl = Proofview.Goal.concl gl in let env_ids = Termops.ids_of_context env in let c_raw = Detyping.detype true env_ids env sigma c in let t_raw = Detyping.detype true env_ids env sigma t in let rec resolve_hole t_hole = try Pretyping.understand env sigma t_hole with | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e -> let (e, info) = CErrors.push e in let loc = match Loc.get_loc info with None -> Loc.ghost | Some loc -> loc in resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole) in let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in let sigma = Evd.merge_universe_context sigma ctx in let t_constr_type = Retyping.get_type_of env sigma t_constr in let tac = (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl))) in Sigma.Unsafe.of_pair (tac, sigma) end } let hResolve_auto id c t = let rec resolve_auto n = try hResolve id c n t with | UserError _ as e -> raise e | e when CErrors.noncritical e -> resolve_auto (n+1) in resolve_auto 1 TACTIC EXTEND hresolve_core | [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ] | [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] END (** hget_evar *) let hget_evar n = Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let evl = evar_list concl in if List.length evl < n then error "Not enough uninstantiated existential variables."; if n <= 0 then error "Incorrect existential variable index."; let ev = List.nth evl (n-1) in let ev_type = existential_type sigma ev in change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl)) end } TACTIC EXTEND hget_evar | [ "hget_evar" int_or_var(n) ] -> [ hget_evar n ] END (**********************************************************************) (**********************************************************************) (* A tactic that reduces one match t with ... by doing destruct t. *) (* if t is not a variable, the tactic does *) (* case_eq t;intros ... heq;rewrite heq in *|-. (but heq itself is *) (* preserved). *) (* Contributed by Julien Forest and Pierre Courtieu (july 2010) *) (**********************************************************************) exception Found of unit Proofview.tactic let rewrite_except h = Proofview.Goal.nf_enter { enter = begin fun gl -> let hyps = Tacmach.New.pf_ids_of_hyps gl in Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false)) hyps end } let refl_equal = let coq_base_constant s = Coqlib.gen_constant_in_modules "RecursiveDefinition" (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in function () -> (coq_base_constant "eq_refl") (* This is simply an implementation of the case_eq tactic. this code should be replaced by a call to the tactic but I don't know how to call it before it is defined. *) let mkCaseEq a : unit Proofview.tactic = Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g a) gl in Tacticals.New.tclTHENLIST [Tactics.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]; Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in (** FIXME: this looks really wrong. Does anybody really use this tactic? *) let Sigma (c, _, _) = (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a]).Reductionops.e_redfun env (Sigma.Unsafe.of_evar_map Evd.empty) concl in change_concl c end }; simplest_case a] end } let case_eq_intros_rewrite x = Proofview.Goal.nf_enter { enter = begin fun gl -> let n = nb_prod (Proofview.Goal.concl gl) in (* Pp.msgnl (Printer.pr_lconstr x); *) Tacticals.New.tclTHENLIST [ mkCaseEq x; Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let hyps = Tacmach.New.pf_ids_of_hyps gl in let n' = nb_prod concl in let h = Tacmach.New.of_old (fun g -> fresh_id hyps (Id.of_string "heq") g) gl in Tacticals.New.tclTHENLIST [ Tacticals.New.tclDO (n'-n-1) intro; introduction h; rewrite_except h] end } ] end } let rec find_a_destructable_match t = let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in let cl = [cl, (None, None), None], None in let dest = TacAtom (Loc.ghost, TacInductionDestruct(false, false, cl)) in match kind_of_term t with | Case (_,_,x,_) when closed0 x -> if isVar x then (* TODO check there is no rel n. *) raise (Found (Tacinterp.eval_tactic dest)) else (* let _ = Pp.msgnl (Printer.pr_lconstr x) in *) raise (Found (case_eq_intros_rewrite x)) | _ -> iter_constr find_a_destructable_match t let destauto t = try find_a_destructable_match t; Tacticals.New.tclZEROMSG (str "No destructable match found") with Found tac -> tac let destauto_in id = Proofview.Goal.nf_enter { enter = begin fun gl -> let ctype = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g (mkVar id)) gl in (* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) (* Pp.msgnl (Printer.pr_lconstr (ctype)); *) destauto ctype end } TACTIC EXTEND destauto | [ "destauto" ] -> [ Proofview.Goal.nf_enter { enter = begin fun gl -> destauto (Proofview.Goal.concl gl) end } ] | [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] END (* ********************************************************************* *) let eq_constr x y = Proofview.Goal.enter { enter = begin fun gl -> let evd = Tacmach.New.project gl in if Evarutil.eq_constr_univs_test evd evd x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") end } TACTIC EXTEND constr_eq | [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ] END TACTIC EXTEND constr_eq_nounivs | [ "constr_eq_nounivs" constr(x) constr(y) ] -> [ if eq_constr_nounivs x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] END TACTIC EXTEND is_evar | [ "is_evar" constr(x) ] -> [ Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma -> match Evarutil.kind_of_term_upto sigma x with | Evar _ -> Proofview.tclUNIT () | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar") end ] END let rec has_evar x = match kind_of_term x with | Evar _ -> true | Rel _ | Var _ | Meta _ | Sort _ | Const _ | Ind _ | Construct _ -> false | Cast (t1, _, t2) | Prod (_, t1, t2) | Lambda (_, t1, t2) -> has_evar t1 || has_evar t2 | LetIn (_, t1, t2, t3) -> has_evar t1 || has_evar t2 || has_evar t3 | App (t1, ts) -> has_evar t1 || has_evar_array ts | Case (_, t1, t2, ts) -> has_evar t1 || has_evar t2 || has_evar_array ts | Fix ((_, tr)) | CoFix ((_, tr)) -> has_evar_prec tr | Proj (p, c) -> has_evar c and has_evar_array x = Array.exists has_evar x and has_evar_prec (_, ts1, ts2) = Array.exists has_evar ts1 || Array.exists has_evar ts2 TACTIC EXTEND has_evar | [ "has_evar" constr(x) ] -> [ if has_evar x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars") ] END TACTIC EXTEND is_hyp | [ "is_var" constr(x) ] -> [ match kind_of_term x with | Var _ -> Proofview.tclUNIT () | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") ] END TACTIC EXTEND is_fix | [ "is_fix" constr(x) ] -> [ match kind_of_term x with | Fix _ -> Proofview.tclUNIT () | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") ] END;; TACTIC EXTEND is_cofix | [ "is_cofix" constr(x) ] -> [ match kind_of_term x with | CoFix _ -> Proofview.tclUNIT () | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ] END;; TACTIC EXTEND is_ind | [ "is_ind" constr(x) ] -> [ match kind_of_term x with | Ind _ -> Proofview.tclUNIT () | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") ] END;; TACTIC EXTEND is_constructor | [ "is_constructor" constr(x) ] -> [ match kind_of_term x with | Construct _ -> Proofview.tclUNIT () | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") ] END;; TACTIC EXTEND is_proj | [ "is_proj" constr(x) ] -> [ match kind_of_term x with | Proj _ -> Proofview.tclUNIT () | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") ] END;; TACTIC EXTEND is_const | [ "is_const" constr(x) ] -> [ match kind_of_term x with | Const _ -> Proofview.tclUNIT () | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") ] END;; (* Command to grab the evars left unresolved at the end of a proof. *) (* spiwack: I put it in extratactics because it is somewhat tied with the semantics of the LCF-style tactics, hence with the classic tactic mode. *) VERNAC COMMAND EXTEND GrabEvars [ "Grab" "Existential" "Variables" ] => [ Vernac_classifier.classify_as_proofstep ] -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) ] END (* Shelves all the goals under focus. *) TACTIC EXTEND shelve | [ "shelve" ] -> [ Proofview.shelve ] END (* Shelves the unifiable goals under focus, i.e. the goals which appear in other goals under focus (the unfocused goals are not considered). *) TACTIC EXTEND shelve_unifiable | [ "shelve_unifiable" ] -> [ Proofview.shelve_unifiable ] END (* Unshelves the goal shelved by the tactic. *) TACTIC EXTEND unshelve | [ "unshelve" tactic1(t) ] -> [ Proofview.with_shelf (Tacinterp.tactic_of_value ist t) >>= fun (gls, ()) -> Proofview.Unsafe.tclGETGOALS >>= fun ogls -> Proofview.Unsafe.tclSETGOALS (gls @ ogls) ] END (* Command to add every unshelved variables to the focus *) VERNAC COMMAND EXTEND Unshelve [ "Unshelve" ] => [ Vernac_classifier.classify_as_proofstep ] -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) ] END (* Gives up on the goals under focus: the goals are considered solved, but the proof cannot be closed until the user goes back and solve these goals. *) TACTIC EXTEND give_up | [ "give_up" ] -> [ Proofview.give_up ] END (* cycles [n] goals *) TACTIC EXTEND cycle | [ "cycle" int_or_var(n) ] -> [ Proofview.cycle n ] END (* swaps goals number [i] and [j] *) TACTIC EXTEND swap | [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ] END (* reverses the list of focused goals *) TACTIC EXTEND revgoals | [ "revgoals" ] -> [ Proofview.revgoals ] END type cmp = | Eq | Lt | Le | Gt | Ge type 'i test = | Test of cmp * 'i * 'i let pr_cmp = function | Eq -> Pp.str"=" | Lt -> Pp.str"<" | Le -> Pp.str"<=" | Gt -> Pp.str">" | Ge -> Pp.str">=" let pr_cmp' _prc _prlc _prt = pr_cmp let pr_test_gen f (Test(c,x,y)) = Pp.(f x ++ pr_cmp c ++ f y) let pr_test = pr_test_gen (Pptactic.pr_or_var Pp.int) let pr_test' _prc _prlc _prt = pr_test let pr_itest = pr_test_gen Pp.int let pr_itest' _prc _prlc _prt = pr_itest ARGUMENT EXTEND comparison PRINTED BY pr_cmp' | [ "=" ] -> [ Eq ] | [ "<" ] -> [ Lt ] | [ "<=" ] -> [ Le ] | [ ">" ] -> [ Gt ] | [ ">=" ] -> [ Ge ] END let interp_test ist gls = function | Test (c,x,y) -> project gls , Test(c,Tacinterp.interp_int_or_var ist x,Tacinterp.interp_int_or_var ist y) ARGUMENT EXTEND test PRINTED BY pr_itest' INTERPRETED BY interp_test RAW_PRINTED BY pr_test' GLOB_PRINTED BY pr_test' | [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ] END let interp_cmp = function | Eq -> Int.equal | Lt -> ((<):int->int->bool) | Le -> ((<=):int->int->bool) | Gt -> ((>):int->int->bool) | Ge -> ((>=):int->int->bool) let run_test = function | Test(c,x,y) -> interp_cmp c x y let guard tst = if run_test tst then Proofview.tclUNIT () else let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in Tacticals.New.tclZEROMSG msg TACTIC EXTEND guard | [ "guard" test(tst) ] -> [ guard tst ] END let decompose l c = Proofview.Goal.enter { enter = begin fun gl -> let to_ind c = if isInd c then Univ.out_punivs (destInd c) else error "not an inductive type" in let l = List.map to_ind l in Elim.h_decompose l c end } TACTIC EXTEND decompose | [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ] END (** library/keys *) VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF | [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ let it c = snd (Constrintern.interp_open_constr (Global.env ()) Evd.empty c) in let k1 = Keys.constr_key (it c) in let k2 = Keys.constr_key (it c') in match k1, k2 with | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2 | _ -> () ] END VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY | [ "Print" "Equivalent" "Keys" ] -> [ Feedback.msg_info (Keys.pr_keys Printer.pr_global) ] END VERNAC COMMAND EXTEND OptimizeProof | [ "Optimize" "Proof" ] => [ Vernac_classifier.classify_as_proofstep ] -> [ Proof_global.compact_the_proof () ] | [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] -> [ Gc.compact () ] END coq-8.6/ltac/g_eqdecide.ml40000644000175000017500000000220613022274260015071 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ decideEqualityGoal ] END TACTIC EXTEND compare | [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] END coq-8.6/ltac/coretactics.ml40000644000175000017500000002172313022274260015330 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ Tactics.intros_reflexivity ] END TACTIC EXTEND exact [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] END TACTIC EXTEND assumption [ "assumption" ] -> [ Tactics.assumption ] END TACTIC EXTEND etransitivity [ "etransitivity" ] -> [ Tactics.intros_transitivity None ] END TACTIC EXTEND cut [ "cut" constr(c) ] -> [ Tactics.cut c ] END TACTIC EXTEND exact_no_check [ "exact_no_check" constr(c) ] -> [ Tactics.exact_no_check c ] END TACTIC EXTEND vm_cast_no_check [ "vm_cast_no_check" constr(c) ] -> [ Tactics.vm_cast_no_check c ] END TACTIC EXTEND native_cast_no_check [ "native_cast_no_check" constr(c) ] -> [ Tactics.native_cast_no_check c ] END TACTIC EXTEND casetype [ "casetype" constr(c) ] -> [ Tactics.case_type c ] END TACTIC EXTEND elimtype [ "elimtype" constr(c) ] -> [ Tactics.elim_type c ] END TACTIC EXTEND lapply [ "lapply" constr(c) ] -> [ Tactics.cut_and_apply c ] END TACTIC EXTEND transitivity [ "transitivity" constr(c) ] -> [ Tactics.intros_transitivity (Some c) ] END (** Left *) TACTIC EXTEND left [ "left" ] -> [ Tactics.left_with_bindings false NoBindings ] END TACTIC EXTEND eleft [ "eleft" ] -> [ Tactics.left_with_bindings true NoBindings ] END TACTIC EXTEND left_with [ "left" "with" bindings(bl) ] -> [ Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.left_with_bindings false bl) ] END TACTIC EXTEND eleft_with [ "eleft" "with" bindings(bl) ] -> [ Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.left_with_bindings true bl) ] END (** Right *) TACTIC EXTEND right [ "right" ] -> [ Tactics.right_with_bindings false NoBindings ] END TACTIC EXTEND eright [ "eright" ] -> [ Tactics.right_with_bindings true NoBindings ] END TACTIC EXTEND right_with [ "right" "with" bindings(bl) ] -> [ Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.right_with_bindings false bl) ] END TACTIC EXTEND eright_with [ "eright" "with" bindings(bl) ] -> [ Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.right_with_bindings true bl) ] END (** Constructor *) TACTIC EXTEND constructor [ "constructor" ] -> [ Tactics.any_constructor false None ] | [ "constructor" int_or_var(i) ] -> [ Tactics.constructor_tac false None i NoBindings ] | [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [ let tac bl = Tactics.constructor_tac false None i bl in Tacticals.New.tclDELAYEDWITHHOLES false bl tac ] END TACTIC EXTEND econstructor [ "econstructor" ] -> [ Tactics.any_constructor true None ] | [ "econstructor" int_or_var(i) ] -> [ Tactics.constructor_tac true None i NoBindings ] | [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [ let tac bl = Tactics.constructor_tac true None i bl in Tacticals.New.tclDELAYEDWITHHOLES true bl tac ] END (** Specialize *) TACTIC EXTEND specialize [ "specialize" constr_with_bindings(c) ] -> [ Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c None) ] | [ "specialize" constr_with_bindings(c) "as" intropattern(ipat) ] -> [ Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c (Some ipat)) ] END TACTIC EXTEND symmetry [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] END TACTIC EXTEND symmetry_in | [ "symmetry" "in" in_clause(cl) ] -> [ Tactics.intros_symmetry cl ] END (** Split *) let rec delayed_list = function | [] -> { Tacexpr.delayed = fun _ sigma -> Sigma.here [] sigma } | x :: l -> { Tacexpr.delayed = fun env sigma -> let Sigma (x, sigma, p) = x.Tacexpr.delayed env sigma in let Sigma (l, sigma, q) = (delayed_list l).Tacexpr.delayed env sigma in Sigma (x :: l, sigma, p +> q) } TACTIC EXTEND split [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ] END TACTIC EXTEND esplit [ "esplit" ] -> [ Tactics.split_with_bindings true [NoBindings] ] END TACTIC EXTEND split_with [ "split" "with" bindings(bl) ] -> [ Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.split_with_bindings false [bl]) ] END TACTIC EXTEND esplit_with [ "esplit" "with" bindings(bl) ] -> [ Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.split_with_bindings true [bl]) ] END TACTIC EXTEND exists [ "exists" ] -> [ Tactics.split_with_bindings false [NoBindings] ] | [ "exists" ne_bindings_list_sep(bll, ",") ] -> [ Tacticals.New.tclDELAYEDWITHHOLES false (delayed_list bll) (fun bll -> Tactics.split_with_bindings false bll) ] END TACTIC EXTEND eexists [ "eexists" ] -> [ Tactics.split_with_bindings true [NoBindings] ] | [ "eexists" ne_bindings_list_sep(bll, ",") ] -> [ Tacticals.New.tclDELAYEDWITHHOLES true (delayed_list bll) (fun bll -> Tactics.split_with_bindings true bll) ] END (** Intro *) TACTIC EXTEND intros_until [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ] END TACTIC EXTEND intro | [ "intro" ] -> [ Tactics.intro_move None MoveLast ] | [ "intro" ident(id) ] -> [ Tactics.intro_move (Some id) MoveLast ] | [ "intro" ident(id) "at" "top" ] -> [ Tactics.intro_move (Some id) MoveFirst ] | [ "intro" ident(id) "at" "bottom" ] -> [ Tactics.intro_move (Some id) MoveLast ] | [ "intro" ident(id) "after" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveAfter h) ] | [ "intro" ident(id) "before" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveBefore h) ] | [ "intro" "at" "top" ] -> [ Tactics.intro_move None MoveFirst ] | [ "intro" "at" "bottom" ] -> [ Tactics.intro_move None MoveLast ] | [ "intro" "after" hyp(h) ] -> [ Tactics.intro_move None (MoveAfter h) ] | [ "intro" "before" hyp(h) ] -> [ Tactics.intro_move None (MoveBefore h) ] END (** Move *) TACTIC EXTEND move [ "move" hyp(id) "at" "top" ] -> [ Tactics.move_hyp id MoveFirst ] | [ "move" hyp(id) "at" "bottom" ] -> [ Tactics.move_hyp id MoveLast ] | [ "move" hyp(id) "after" hyp(h) ] -> [ Tactics.move_hyp id (MoveAfter h) ] | [ "move" hyp(id) "before" hyp(h) ] -> [ Tactics.move_hyp id (MoveBefore h) ] END (** Rename *) TACTIC EXTEND rename | [ "rename" ne_rename_list_sep(ids, ",") ] -> [ Tactics.rename_hyp ids ] END (** Revert *) TACTIC EXTEND revert [ "revert" ne_hyp_list(hl) ] -> [ Tactics.revert hl ] END (** Simple induction / destruct *) TACTIC EXTEND simple_induction [ "simple" "induction" quantified_hypothesis(h) ] -> [ Tactics.simple_induct h ] END TACTIC EXTEND simple_destruct [ "simple" "destruct" quantified_hypothesis(h) ] -> [ Tactics.simple_destruct h ] END (** Double induction *) TACTIC EXTEND double_induction [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] -> [ Elim.h_double_induction h1 h2 ] END (* Admit *) TACTIC EXTEND admit [ "admit" ] -> [ Proofview.give_up ] END (* Fix *) TACTIC EXTEND fix [ "fix" natural(n) ] -> [ Tactics.fix None n ] | [ "fix" ident(id) natural(n) ] -> [ Tactics.fix (Some id) n ] END (* Cofix *) TACTIC EXTEND cofix [ "cofix" ] -> [ Tactics.cofix None ] | [ "cofix" ident(id) ] -> [ Tactics.cofix (Some id) ] END (* Clear *) TACTIC EXTEND clear [ "clear" hyp_list(ids) ] -> [ if List.is_empty ids then Tactics.keep [] else Tactics.clear ids ] | [ "clear" "-" ne_hyp_list(ids) ] -> [ Tactics.keep ids ] END (* Clearbody *) TACTIC EXTEND clearbody [ "clearbody" ne_hyp_list(ids) ] -> [ Tactics.clear_body ids ] END (* Generalize dependent *) TACTIC EXTEND generalize_dependent [ "generalize" "dependent" constr(c) ] -> [ Tactics.generalize_dep c ] END (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) open Tacexpr let initial_atomic () = let dloc = Loc.ghost in let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in let iter (s, t) = let body = TacAtom (dloc, t) in Tacenv.register_ltac false false (Id.of_string s) body in let () = List.iter iter [ "red", TacReduce(Red false,nocl); "hnf", TacReduce(Hnf,nocl); "simpl", TacReduce(Simpl (Redops.all_flags,None),nocl); "compute", TacReduce(Cbv Redops.all_flags,nocl); "intros", TacIntroPattern (false,[]); ] in let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in List.iter iter [ "idtac",TacId []; "fail", TacFail(TacLocal,ArgArg 0,[]); "fresh", TacArg(dloc,TacFreshId []) ] let () = Mltop.declare_cache_obj initial_atomic "coretactics" coq-8.6/ltac/taccoerce.ml0000644000175000017500000002615313022274260014673 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t | _ -> assert false let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> let Val.Dyn (t, _) = v in match Val.eq t (val_tag wit) with | None -> false | Some Refl -> true let prj : type a. a Val.typ -> Val.t -> a option = fun t v -> let Val.Dyn (t', x) = v in match Val.eq t t' with | None -> None | Some Refl -> Some x let in_gen wit v = Val.Dyn (val_tag wit, v) let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x module Value = struct type t = Val.t let normalize v = v let of_constr c = in_gen (topwit wit_constr) c let to_constr v = let v = normalize v in if has_type v (topwit wit_constr) then let c = out_gen (topwit wit_constr) v in Some c else if has_type v (topwit wit_constr_under_binders) then let vars, c = out_gen (topwit wit_constr_under_binders) v in match vars with [] -> Some c | _ -> None else None let of_uconstr c = in_gen (topwit wit_uconstr) c let to_uconstr v = let v = normalize v in if has_type v (topwit wit_uconstr) then Some (out_gen (topwit wit_uconstr) v) else None let of_int i = in_gen (topwit wit_int) i let to_int v = let v = normalize v in if has_type v (topwit wit_int) then Some (out_gen (topwit wit_int) v) else None let to_list v = prj Val.typ_list v let to_option v = prj Val.typ_opt v let to_pair v = prj Val.typ_pair v end let is_variable env id = Id.List.mem id (Termops.ids_of_named_context (Environ.named_context env)) (* Transforms an id into a constr if possible, or fails with Not_found *) let constr_of_id env id = Term.mkVar (let _ = Environ.lookup_named id env in id) (* Gives the constr corresponding to a Constr_context tactic_arg *) let coerce_to_constr_context v = let v = Value.normalize v in if has_type v (topwit wit_constr_context) then out_gen (topwit wit_constr_context) v else raise (CannotCoerceTo "a term context") (* Interprets an identifier which must be fresh *) let coerce_var_to_ident fresh env v = let v = Value.normalize v in let fail () = raise (CannotCoerceTo "a fresh identifier") in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with | _, IntroNaming (IntroIdentifier id) -> id | _ -> fail () else if has_type v (topwit wit_var) then out_gen (topwit wit_var) v else match Value.to_constr v with | None -> fail () | Some c -> (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *) if isVar c && not (fresh && is_variable env (destVar c)) then destVar c else fail () (* Interprets, if possible, a constr to an identifier which may not be fresh but suitable to be given to the fresh tactic. Works for vars, constants, inductive, constructors and sorts. *) let coerce_to_ident_not_fresh g env v = let id_of_name = function | Names.Anonymous -> Id.of_string "x" | Names.Name x -> x in let v = Value.normalize v in let fail () = raise (CannotCoerceTo "an identifier") in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with | _, IntroNaming (IntroIdentifier id) -> id | _ -> fail () else if has_type v (topwit wit_var) then out_gen (topwit wit_var) v else match Value.to_constr v with | None -> fail () | Some c -> match Constr.kind c with | Var id -> id | Meta m -> id_of_name (Evd.meta_name g m) | Evar (kn,_) -> begin match Evd.evar_ident kn g with | None -> fail () | Some id -> id end | Const (cst,_) -> Label.to_id (Constant.label cst) | Construct (cstr,_) -> let ref = Globnames.ConstructRef cstr in let basename = Nametab.basename_of_global ref in basename | Ind (ind,_) -> let ref = Globnames.IndRef ind in let basename = Nametab.basename_of_global ref in basename | Sort s -> begin match s with | Prop _ -> Label.to_id (Label.make "Prop") | Type _ -> Label.to_id (Label.make "Type") end | _ -> fail() let coerce_to_intro_pattern env v = let v = Value.normalize v in if has_type v (topwit wit_intro_pattern) then snd (out_gen (topwit wit_intro_pattern) v) else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in IntroNaming (IntroIdentifier id) else match Value.to_constr v with | Some c when isVar c -> (* This happens e.g. in definitions like "Tac H = clear H; intro H" *) (* but also in "destruct H as (H,H')" *) IntroNaming (IntroIdentifier (destVar c)) | _ -> raise (CannotCoerceTo "an introduction pattern") let coerce_to_intro_pattern_naming env v = match coerce_to_intro_pattern env v with | IntroNaming pat -> pat | _ -> raise (CannotCoerceTo "a naming introduction pattern") let coerce_to_hint_base v = let v = Value.normalize v in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with | _, IntroNaming (IntroIdentifier id) -> Id.to_string id | _ -> raise (CannotCoerceTo "a hint base name") else raise (CannotCoerceTo "a hint base name") let coerce_to_int v = let v = Value.normalize v in if has_type v (topwit wit_int) then out_gen (topwit wit_int) v else raise (CannotCoerceTo "an integer") let coerce_to_constr env v = let v = Value.normalize v in let fail () = raise (CannotCoerceTo "a term") in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with | _, IntroNaming (IntroIdentifier id) -> (try ([], constr_of_id env id) with Not_found -> fail ()) | _ -> fail () else if has_type v (topwit wit_constr) then let c = out_gen (topwit wit_constr) v in ([], c) else if has_type v (topwit wit_constr_under_binders) then out_gen (topwit wit_constr_under_binders) v else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in (try [], constr_of_id env id with Not_found -> fail ()) else fail () let coerce_to_uconstr env v = let v = Value.normalize v in if has_type v (topwit wit_uconstr) then out_gen (topwit wit_uconstr) v else raise (CannotCoerceTo "an untyped term") let coerce_to_closed_constr env v = let ids,c = coerce_to_constr env v in let () = if not (List.is_empty ids) then raise (CannotCoerceTo "a term") in c let coerce_to_evaluable_ref env v = let fail () = raise (CannotCoerceTo "an evaluable reference") in let v = Value.normalize v in let ev = if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with | _, IntroNaming (IntroIdentifier id) when is_variable env id -> EvalVarRef id | _ -> fail () else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in if Id.List.mem id (Termops.ids_of_context env) then EvalVarRef id else fail () else if has_type v (topwit wit_ref) then let open Globnames in let r = out_gen (topwit wit_ref) v in match r with | VarRef var -> EvalVarRef var | ConstRef c -> EvalConstRef c | IndRef _ | ConstructRef _ -> fail () else match Value.to_constr v with | Some c when isConst c -> EvalConstRef (Univ.out_punivs (destConst c)) | Some c when isVar c -> EvalVarRef (destVar c) | _ -> fail () in if Tacred.is_evaluable env ev then ev else fail () let coerce_to_constr_list env v = let v = Value.to_list v in match v with | Some l -> let map v = coerce_to_closed_constr env v in List.map map l | None -> raise (CannotCoerceTo "a term list") let coerce_to_intro_pattern_list loc env v = match Value.to_list v with | None -> raise (CannotCoerceTo "an intro pattern list") | Some l -> let map v = (loc, coerce_to_intro_pattern env v) in List.map map l let coerce_to_hyp env v = let fail () = raise (CannotCoerceTo "a variable") in let v = Value.normalize v in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with | _, IntroNaming (IntroIdentifier id) when is_variable env id -> id | _ -> fail () else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in if is_variable env id then id else fail () else match Value.to_constr v with | Some c when isVar c -> destVar c | _ -> fail () let coerce_to_hyp_list env v = let v = Value.to_list v in match v with | Some l -> let map n = coerce_to_hyp env n in List.map map l | None -> raise (CannotCoerceTo "a variable list") (* Interprets a qualified name *) let coerce_to_reference env v = let v = Value.normalize v in match Value.to_constr v with | Some c -> begin try Globnames.global_of_constr c with Not_found -> raise (CannotCoerceTo "a reference") end | None -> raise (CannotCoerceTo "a reference") (* Quantified named or numbered hypothesis or hypothesis in context *) (* (as in Inversion) *) let coerce_to_quantified_hypothesis v = let v = Value.normalize v in if has_type v (topwit wit_intro_pattern) then let v = out_gen (topwit wit_intro_pattern) v in match v with | _, IntroNaming (IntroIdentifier id) -> NamedHyp id | _ -> raise (CannotCoerceTo "a quantified hypothesis") else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in NamedHyp id else if has_type v (topwit wit_int) then AnonHyp (out_gen (topwit wit_int) v) else match Value.to_constr v with | Some c when isVar c -> NamedHyp (destVar c) | _ -> raise (CannotCoerceTo "a quantified hypothesis") (* Quantified named or numbered hypothesis or hypothesis in context *) (* (as in Inversion) *) let coerce_to_decl_or_quant_hyp env v = let v = Value.normalize v in if has_type v (topwit wit_int) then AnonHyp (out_gen (topwit wit_int) v) else try coerce_to_quantified_hypothesis v with CannotCoerceTo _ -> raise (CannotCoerceTo "a declared or quantified hypothesis") let coerce_to_int_or_var_list v = match Value.to_list v with | None -> raise (CannotCoerceTo "an int list") | Some l -> let map n = ArgArg (coerce_to_int n) in List.map map l coq-8.6/ltac/profile_ltac.mli0000644000175000017500000000350413022274260015552 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ('a * Tacexpr.ltac_call_kind) list -> 'b Proofview.tactic -> 'b Proofview.tactic val set_profiling : bool -> unit (* Cut off results < than specified cutoff *) val print_results : cutoff:float -> unit val print_results_tactic : string -> unit val reset_profile : unit -> unit val do_print_results_at_close : unit -> unit (* The collected statistics for a tactic. The timing data is collected over all * instances of a given tactic from its parent. E.g. if tactic 'aaa' calls * 'foo' twice, then 'aaa' will contain just one entry for 'foo' with the * statistics of the two invocations combined, and also combined over all * invocations of 'aaa'. * total: time spent running this tactic and its subtactics (seconds) * local: time spent running this tactic, minus its subtactics (seconds) * ncalls: the number of invocations of this tactic that have been made * max_total: the greatest running time of a single invocation (seconds) *) type treenode = { name : CString.Map.key; total : float; local : float; ncalls : int; max_total : float; children : treenode CString.Map.t } (* Returns the profiling results known by the current process *) val get_local_profiling_results : unit -> treenode val feedback_results : treenode -> unit coq-8.6/ltac/tacinterp.mli0000644000175000017500000001046613022274260015105 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t val to_constr : t -> constr option val of_int : int -> t val to_int : t -> int option val to_list : t -> t list option val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t val cast : 'a typed_abstract_argument_type -> Geninterp.Val.t -> 'a end (** Values for interpretation *) type value = Value.t module TacStore : Store.S with type t = Geninterp.TacStore.t and type 'a field = 'a Geninterp.TacStore.field (** Signature for interpretation: val\_interp and interpretation functions *) type interp_sign = Geninterp.interp_sign = { lfun : value Id.Map.t; extra : TacStore.t } val f_avoid_ids : Id.t list TacStore.field val f_debug : debug_info TacStore.field val extract_ltac_constr_values : interp_sign -> Environ.env -> Pattern.constr_under_binders Id.Map.t (** Given an interpretation signature, extract all values which are coercible to a [constr]. *) (** Sets the debugger mode *) val set_debug : debug_info -> unit (** Gives the state of debug *) val get_debug : unit -> debug_info (** Adds an interpretation function for extra generic arguments *) val interp_genarg : interp_sign -> glob_generic_argument -> Value.t Ftactic.t (** Interprets any expression *) val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic (** Interprets an expression that evaluates to a constr *) val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic (** Interprets redexp arguments *) val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr (** Interprets tactic expressions *) val interp_hyp : interp_sign -> Environ.env -> Evd.evar_map -> Id.t Loc.located -> Id.t val interp_constr_gen : Pretyping.typing_constraint -> interp_sign -> Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Evd.evar_map * constr val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> glob_constr_and_expr bindings -> Evd.evar_map * constr bindings val interp_open_constr_with_bindings : interp_sign -> Environ.env -> Evd.evar_map -> glob_constr_and_expr with_bindings -> Evd.evar_map * constr with_bindings (** Initial call for interpretation *) val eval_tactic : glob_tactic_expr -> unit Proofview.tactic val eval_tactic_ist : interp_sign -> glob_tactic_expr -> unit Proofview.tactic (** Same as [eval_tactic], but with the provided [interp_sign]. *) val tactic_of_value : interp_sign -> Value.t -> unit Proofview.tactic (** Globalization + interpretation *) val interp_tac_gen : value Id.Map.t -> Id.t list -> debug_info -> raw_tactic_expr -> unit Proofview.tactic val interp : raw_tactic_expr -> unit Proofview.tactic (** Hides interpretation for pretty-print *) val hide_interp : bool -> raw_tactic_expr -> unit Proofview.tactic option -> unit Proofview.tactic (** Internals that can be useful for syntax extensions. *) val interp_ltac_var : (value -> 'a) -> interp_sign -> (Environ.env * Evd.evar_map) option -> Id.t Loc.located -> 'a val interp_int : interp_sign -> Id.t Loc.located -> int val interp_int_or_var : interp_sign -> int or_var -> int val error_ltac_variable : Loc.t -> Id.t -> (Environ.env * Evd.evar_map) option -> value -> string -> 'a (** Transforms a constr-expecting tactic into a tactic finding its arguments in the Ltac environment according to the given names. *) val lift_constr_tac_to_ml_tac : Id.t option list -> (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic val default_ist : unit -> Geninterp.interp_sign (** Empty ist with debug set on the current value. *) coq-8.6/ltac/extratactics.mli0000644000175000017500000000145213022274260015605 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit Proofview.tactic val injHyp : Names.Id.t -> unit Proofview.tactic (* val refine_tac : Evd.open_constr -> unit Proofview.tactic *) val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tacexpr.delayed_open option -> unit Proofview.tactic coq-8.6/ltac/ltac.mllib0000644000175000017500000000035513022274260014351 0ustar mdenesmdenesTaccoerce Tacsubst Tacenv Tactic_debug Tacintern Tacentries Profile_ltac Tacinterp Evar_tactics Tactic_option Extraargs G_obligations Coretactics Extratactics Profile_ltac_tactics G_auto G_class Rewrite G_rewrite Tauto G_eqdecide G_ltac coq-8.6/ltac/tactic_debug.ml0000644000175000017500000003424513022274260015361 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Printer.pr_constr_pattern p) rl (* This module intends to be a beginning of debugger for tactic expressions. Currently, it is quite simple and we can hope to have, in the future, a more complete panel of commands dedicated to a proof assistant framework *) (* Debug information *) type debug_info = | DebugOn of int | DebugOff (* An exception handler *) let explain_logic_error e = CErrors.print (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))) let explain_logic_error_no_anomaly e = CErrors.print_no_report (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))) let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) (* Prints the goal *) let db_pr_goal gl = let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let penv = print_named_context env in let pc = print_constr_env env concl in str" " ++ hv 0 (penv ++ fnl () ++ str "============================" ++ fnl () ++ str" " ++ pc) ++ fnl () let db_pr_goal = Proofview.Goal.nf_enter { enter = begin fun gl -> let pg = db_pr_goal gl in Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) end } (* Prints the commands *) let help () = msg_tac_debug (str "Commands: = Continue" ++ fnl() ++ str " h/? = Help" ++ fnl() ++ str " r = Run times" ++ fnl() ++ str " r = Run up to next idtac " ++ fnl() ++ str " s = Skip" ++ fnl() ++ str " x = Exit") (* Prints the goal and the command to be executed *) let goal_com tac = Proofview.tclTHEN db_pr_goal (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ prtac tac))) (* [run (new_ref _)] gives us a ref shared among [NonLogical.t] expressions. It avoids parametrizing everything over a reference. *) let skipped = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) let skip = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) let breakpoint = Proofview.NonLogical.run (Proofview.NonLogical.ref None) let rec drop_spaces inst i = if String.length inst > i && inst.[i] == ' ' then drop_spaces inst (i+1) else i let possibly_unquote s = if String.length s >= 2 && s.[0] == '"' && s.[String.length s - 1] == '"' then String.sub s 1 (String.length s - 2) else s (* (Re-)initialize debugger *) let db_initialize = let open Proofview.NonLogical in (skip:=0) >> (skipped:=0) >> (breakpoint:=None) let int_of_string s = try Proofview.NonLogical.return (int_of_string s) with e -> Proofview.NonLogical.raise e let string_get s i = try Proofview.NonLogical.return (String.get s i) with e -> Proofview.NonLogical.raise e (* Gives the number of steps or next breakpoint of a run command *) let run_com inst = let open Proofview.NonLogical in string_get inst 0 >>= fun first_char -> if first_char ='r' then let i = drop_spaces inst 1 in if String.length inst > i then let s = String.sub inst i (String.length inst - i) in if inst.[0] >= '0' && inst.[0] <= '9' then int_of_string s >>= fun num -> (if num<0 then invalid_arg "run_com" else return ()) >> (skip:=num) >> (skipped:=0) else breakpoint:=Some (possibly_unquote s) else invalid_arg "run_com" else invalid_arg "run_com" (* Prints the run counter *) let run ini = let open Proofview.NonLogical in if not ini then begin Proofview.NonLogical.print_notice (str"\b\r\b\r") >> !skipped >>= fun skipped -> msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl()) end >> !skipped >>= fun x -> skipped := x+1 else return () (* Prints the prompt *) let rec prompt level = (* spiwack: avoid overriding by the open below *) let runtrue = run true in begin let open Proofview.NonLogical in Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in Proofview.NonLogical.catch Proofview.NonLogical.read_line begin function (e, info) -> match e with | End_of_file -> exit | e -> raise ~info e end >>= fun inst -> match inst with | "" -> return (DebugOn (level+1)) | "s" -> return (DebugOff) | "x" -> Proofview.NonLogical.print_char '\b' >> exit | "h"| "?" -> begin help () >> prompt level end | _ -> Proofview.NonLogical.catch (run_com inst >> runtrue >> return (DebugOn (level+1))) begin function (e, info) -> match e with | Failure _ | Invalid_argument _ -> prompt level | e -> raise ~info e end end (* Prints the state and waits for an instruction *) (* spiwack: the only reason why we need to take the continuation [f] as an argument rather than returning the new level directly seems to be that [f] is wrapped in with "explain_logic_error". I don't think it serves any purpose in the current design, so we could just drop that. *) let debug_prompt lev tac f = (* spiwack: avoid overriding by the open below *) let runfalse = run false in let open Proofview.NonLogical in let (>=) = Proofview.tclBIND in (* What to print and to do next *) let newlevel = Proofview.tclLIFT !skip >= fun initial_skip -> if Int.equal initial_skip 0 then Proofview.tclLIFT !breakpoint >= fun breakpoint -> if Option.is_empty breakpoint then Proofview.tclTHEN (goal_com tac) (Proofview.tclLIFT (prompt lev)) else Proofview.tclLIFT(runfalse >> return (DebugOn (lev+1))) else Proofview.tclLIFT begin (!skip >>= fun s -> skip:=s-1) >> runfalse >> !skip >>= fun new_skip -> (if Int.equal new_skip 0 then skipped:=0 else return ()) >> return (DebugOn (lev+1)) end in newlevel >= fun newlevel -> (* What to execute *) Proofview.tclOR (f newlevel) begin fun (reraise, info) -> Proofview.tclTHEN (Proofview.tclLIFT begin (skip:=0) >> (skipped:=0) >> if Logic.catchable_exception reraise then msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ explain_logic_error reraise) else return () end) (Proofview.tclZERO ~info reraise) end let is_debug db = let open Proofview.NonLogical in !breakpoint >>= fun breakpoint -> match db, breakpoint with | DebugOff, _ -> return false | _, Some _ -> return false | _ -> !skip >>= fun skip -> return (Int.equal skip 0) (* Prints a constr *) let db_constr debug env c = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then msg_tac_debug (str "Evaluated term: " ++ print_constr_env env c) else return () (* Prints the pattern rule *) let db_pattern_rule debug num r = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then begin msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++ str "|" ++ spc () ++ prmatchrl r) end else return () (* Prints the hypothesis pattern identifier if it exists *) let hyp_bound = function | Anonymous -> str " (unbound)" | Name id -> str " (bound to " ++ pr_id id ++ str ")" (* Prints a matched hypothesis *) let db_matched_hyp debug env (id,_,c) ido = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then msg_tac_debug (str "Hypothesis " ++ pr_id id ++ hyp_bound ido ++ str " has been matched: " ++ print_constr_env env c) else return () (* Prints the matched conclusion *) let db_matched_concl debug env c = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env c) else return () (* Prints a success message when the goal has been matched *) let db_mc_pattern_success debug = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then msg_tac_debug (str "The goal has been successfully matched!" ++ fnl() ++ str "Let us execute the right-hand side part..." ++ fnl()) else return () (* Prints a failure message for an hypothesis pattern *) let db_hyp_pattern_failure debug env sigma (na,hyp) = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++ str " cannot match: " ++ prmatchpatt env sigma hyp) else return () (* Prints a matching failure message for a rule *) let db_matching_failure debug = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then msg_tac_debug (str "This rule has failed due to matching errors!" ++ fnl() ++ str "Let us try the next one...") else return () (* Prints an evaluation failure message for a rule *) let db_eval_failure debug s = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then let s = str "message \"" ++ s ++ str "\"" in msg_tac_debug (str "This rule has failed due to \"Fail\" tactic (" ++ s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...") else return () (* Prints a logic failure message for a rule *) let db_logic_failure debug err = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then begin msg_tac_debug (explain_logic_error err) >> msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++ str "Let us try the next one...") end else return () let is_breakpoint brkname s = match brkname, s with | Some s, MsgString s'::_ -> String.equal s s' | _ -> false let db_breakpoint debug s = let open Proofview.NonLogical in !breakpoint >>= fun opt_breakpoint -> match debug with | DebugOn lev when not (CList.is_empty s) && is_breakpoint opt_breakpoint s -> breakpoint:=None | _ -> return () (** Extrating traces *) let is_defined_ltac trace = let rec aux = function | (_, Tacexpr.LtacNameCall f) :: _ -> not (Tacenv.is_ltac_for_ml_tactic f) | (_, Tacexpr.LtacNotationCall f) :: _ -> true | (_, Tacexpr.LtacAtomCall _) :: _ -> false | _ :: tail -> aux tail | [] -> false in aux (List.rev trace) let explain_ltac_call_trace last trace loc = let calls = last :: List.rev_map snd trace in let pr_call ck = match ck with | Tacexpr.LtacNotationCall kn -> quote (Pptactic.pr_alias_key kn) | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) | Tacexpr.LtacMLCall t -> quote (Pptactic.pr_glob_tactic (Global.env()) t) | Tacexpr.LtacVarCall (id,t) -> quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" | Tacexpr.LtacAtomCall te -> quote (Pptactic.pr_glob_tactic (Global.env()) (Tacexpr.TacAtom (Loc.ghost,te))) | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> quote (Printer.pr_glob_constr_env (Global.env()) c) ++ (if not (Id.Map.is_empty vars) then strbrk " (with " ++ prlist_with_sep pr_comma (fun (id,c) -> pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) (List.rev (Id.Map.bindings vars)) ++ str ")" else mt()) in match calls with | [] -> mt () | [a] -> hov 0 (str "Ltac call to " ++ pr_call a ++ str " failed.") | _ -> let kind_of_last_call = match List.last calls with | Tacexpr.LtacConstrInterp _ -> ", last term evaluation failed." | _ -> ", last call failed." in hov 0 (str "In nested Ltac calls to " ++ pr_enum pr_call calls ++ strbrk kind_of_last_call) let skip_extensions trace = let rec aux = function | (_,Tacexpr.LtacNameCall f as tac) :: _ when Tacenv.is_ltac_for_ml_tactic f -> [tac] | (_,Tacexpr.LtacNotationCall _ as tac) :: (_,Tacexpr.LtacMLCall _) :: _ -> (* Case of an ML defined tactic with entry of the form <<"foo" args>> *) (* see tacextend.mlp *) [tac] | (_,Tacexpr.LtacMLCall _ as tac) :: _ -> [tac] | t :: tail -> t :: aux tail | [] -> [] in List.rev (aux (List.rev trace)) let finer_loc loc1 loc2 = Loc.merge loc1 loc2 = loc2 let extract_ltac_trace trace eloc = let trace = skip_extensions trace in let (loc,c),tail = List.sep_last trace in if is_defined_ltac trace then (* We entered a user-defined tactic, we display the trace with location of the call *) let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in Some msg, if finer_loc eloc loc then eloc else loc else (* We entered a primitive tactic, we don't display trace but report on the finest location *) let best_loc = (* trace is with innermost call coming first *) let rec aux best_loc = function | (loc,_)::tail -> if Loc.is_ghost best_loc || not (Loc.is_ghost loc) && finer_loc loc best_loc then aux loc tail else aux best_loc tail | [] -> best_loc in aux eloc trace in None, best_loc let get_ltac_trace (_, info) = let ltac_trace = Exninfo.get info ltac_trace_info in let loc = Option.default Loc.ghost (Loc.get_loc info) in match ltac_trace with | None -> None | Some trace -> Some (extract_ltac_trace trace loc) let () = ExplainErr.register_additional_error_info get_ltac_trace coq-8.6/ltac/extraargs.ml40000644000175000017500000003073313022274260015026 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* " let pr_orient _prc _prlc _prt = function | true -> Pp.mt () | false -> Pp.str " <-" ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient | [ "->" ] -> [ true ] | [ "<-" ] -> [ false ] | [ ] -> [ true ] END let pr_int _ _ _ i = Pp.int i let _natural = Pcoq.Prim.natural ARGUMENT EXTEND natural TYPED AS int PRINTED BY pr_int | [ _natural(i) ] -> [ i ] END let pr_orient = pr_orient () () () let pr_int_list = Pp.pr_sequence Pp.int let pr_int_list_full _prc _prlc _prt l = pr_int_list l let pr_occurrences _prc _prlc _prt l = match l with | ArgArg x -> pr_int_list x | ArgVar (loc, id) -> Nameops.pr_id id let occurrences_of = function | [] -> NoOccurrences | n::_ as nl when n < 0 -> AllOccurrencesBut (List.map abs nl) | nl -> if List.exists (fun n -> n < 0) nl then CErrors.error "Illegal negative occurrence number."; OnlyOccurrences nl let coerce_to_int v = match Value.to_int v with | None -> raise (CannotCoerceTo "an integer") | Some n -> n let int_list_of_VList v = match Value.to_list v with | Some l -> List.map (fun n -> coerce_to_int n) l | _ -> raise (CannotCoerceTo "an integer") let interp_occs ist gl l = match l with | ArgArg x -> x | ArgVar (_,id as locid) -> (try int_list_of_VList (Id.Map.find id ist.lfun) with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) let interp_occs ist gl l = Tacmach.project gl , interp_occs ist gl l let glob_occs ist l = l let subst_occs evm l = l ARGUMENT EXTEND occurrences TYPED AS int list PRINTED BY pr_int_list_full INTERPRETED BY interp_occs GLOBALIZED BY glob_occs SUBSTITUTED BY subst_occs RAW_PRINTED BY pr_occurrences GLOB_PRINTED BY pr_occurrences | [ ne_integer_list(l) ] -> [ ArgArg l ] | [ var(id) ] -> [ ArgVar id ] END let pr_occurrences = pr_occurrences () () () let pr_gen prc _prlc _prtac c = prc c let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) let glob_glob = Tacintern.intern_constr let pr_lconstr _ prc _ c = prc c let subst_glob = Tacsubst.subst_glob_constr_and_expr ARGUMENT EXTEND glob PRINTED BY pr_globc INTERPRETED BY interp_glob GLOBALIZED BY glob_glob SUBSTITUTED BY subst_glob RAW_PRINTED BY pr_gen GLOB_PRINTED BY pr_gen [ constr(c) ] -> [ c ] END let l_constr = Pcoq.Constr.lconstr ARGUMENT EXTEND lconstr TYPED AS constr PRINTED BY pr_lconstr [ l_constr(c) ] -> [ c ] END ARGUMENT EXTEND lglob TYPED AS glob PRINTED BY pr_globc INTERPRETED BY interp_glob GLOBALIZED BY glob_glob SUBSTITUTED BY subst_glob RAW_PRINTED BY pr_gen GLOB_PRINTED BY pr_gen [ lconstr(c) ] -> [ c ] END let interp_casted_constr ist gl c = interp_constr_gen (Pretyping.OfType (pf_concl gl)) ist (pf_env gl) (project gl) c ARGUMENT EXTEND casted_constr TYPED AS constr PRINTED BY pr_gen INTERPRETED BY interp_casted_constr [ constr(c) ] -> [ c ] END type 'id gen_place= ('id * hyp_location_flag,unit) location type loc_place = Id.t Loc.located gen_place type place = Id.t gen_place let pr_gen_place pr_id = function ConclLocation () -> Pp.mt () | HypLocation (id,InHyp) -> str "in " ++ pr_id id | HypLocation (id,InHypTypeOnly) -> str "in (Type of " ++ pr_id id ++ str ")" | HypLocation (id,InHypValueOnly) -> str "in (Value of " ++ pr_id id ++ str ")" let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id) let pr_place _ _ _ = pr_gen_place Nameops.pr_id let pr_hloc = pr_loc_place () () () let intern_place ist = function ConclLocation () -> ConclLocation () | HypLocation (id,hl) -> HypLocation (Tacintern.intern_hyp ist id,hl) let interp_place ist env sigma = function ConclLocation () -> ConclLocation () | HypLocation (id,hl) -> HypLocation (Tacinterp.interp_hyp ist env sigma id,hl) let interp_place ist gl p = Tacmach.project gl , interp_place ist (Tacmach.pf_env gl) (Tacmach.project gl) p let subst_place subst pl = pl ARGUMENT EXTEND hloc PRINTED BY pr_place INTERPRETED BY interp_place GLOBALIZED BY intern_place SUBSTITUTED BY subst_place RAW_PRINTED BY pr_loc_place GLOB_PRINTED BY pr_loc_place [ ] -> [ ConclLocation () ] | [ "in" "|-" "*" ] -> [ ConclLocation () ] | [ "in" ident(id) ] -> [ HypLocation ((Loc.ghost,id),InHyp) ] | [ "in" "(" "Type" "of" ident(id) ")" ] -> [ HypLocation ((Loc.ghost,id),InHypTypeOnly) ] | [ "in" "(" "Value" "of" ident(id) ")" ] -> [ HypLocation ((Loc.ghost,id),InHypValueOnly) ] END let pr_rename _ _ _ (n, m) = Nameops.pr_id n ++ str " into " ++ Nameops.pr_id m ARGUMENT EXTEND rename TYPED AS ident * ident PRINTED BY pr_rename | [ ident(n) "into" ident(m) ] -> [ (n, m) ] END (* Julien: Mise en commun des differentes version de replace with in by *) let pr_by_arg_tac _prc _prlc prtac opt_c = match opt_c with | None -> mt () | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t) ARGUMENT EXTEND by_arg_tac TYPED AS tactic_opt PRINTED BY pr_by_arg_tac | [ "by" tactic3(c) ] -> [ Some c ] | [ ] -> [ None ] END let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl let in_clause' = Pcoq.Tactic.in_clause ARGUMENT EXTEND in_clause TYPED AS clause_dft_concl PRINTED BY pr_in_top_clause RAW_TYPED AS clause_dft_concl RAW_PRINTED BY pr_in_clause GLOB_TYPED AS clause_dft_concl GLOB_PRINTED BY pr_in_clause | [ in_clause'(cl) ] -> [ cl ] END (* spiwack: the print functions are incomplete, but I don't know what they are used for *) let pr_r_nat_field natf = str "nat " ++ match natf with | Retroknowledge.NatType -> str "type" | Retroknowledge.NatPlus -> str "plus" | Retroknowledge.NatTimes -> str "times" let pr_r_n_field nf = str "binary N " ++ match nf with | Retroknowledge.NPositive -> str "positive" | Retroknowledge.NType -> str "type" | Retroknowledge.NTwice -> str "twice" | Retroknowledge.NTwicePlusOne -> str "twice plus one" | Retroknowledge.NPhi -> str "phi" | Retroknowledge.NPhiInv -> str "phi inv" | Retroknowledge.NPlus -> str "plus" | Retroknowledge.NTimes -> str "times" let pr_r_int31_field i31f = str "int31 " ++ match i31f with | Retroknowledge.Int31Bits -> str "bits" | Retroknowledge.Int31Type -> str "type" | Retroknowledge.Int31Twice -> str "twice" | Retroknowledge.Int31TwicePlusOne -> str "twice plus one" | Retroknowledge.Int31Phi -> str "phi" | Retroknowledge.Int31PhiInv -> str "phi inv" | Retroknowledge.Int31Plus -> str "plus" | Retroknowledge.Int31Times -> str "times" | Retroknowledge.Int31Constructor -> assert false | Retroknowledge.Int31PlusC -> str "plusc" | Retroknowledge.Int31PlusCarryC -> str "pluscarryc" | Retroknowledge.Int31Minus -> str "minus" | Retroknowledge.Int31MinusC -> str "minusc" | Retroknowledge.Int31MinusCarryC -> str "minuscarryc" | Retroknowledge.Int31TimesC -> str "timesc" | Retroknowledge.Int31Div21 -> str "div21" | Retroknowledge.Int31Div -> str "div" | Retroknowledge.Int31Diveucl -> str "diveucl" | Retroknowledge.Int31AddMulDiv -> str "addmuldiv" | Retroknowledge.Int31Compare -> str "compare" | Retroknowledge.Int31Head0 -> str "head0" | Retroknowledge.Int31Tail0 -> str "tail0" | Retroknowledge.Int31Lor -> str "lor" | Retroknowledge.Int31Land -> str "land" | Retroknowledge.Int31Lxor -> str "lxor" let pr_retroknowledge_field f = match f with (* | Retroknowledge.KEq -> str "equality" | Retroknowledge.KNat natf -> pr_r_nat_field () () () natf | Retroknowledge.KN nf -> pr_r_n_field () () () nf *) | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field i31f) ++ spc () ++ str "in " ++ qs group VERNAC ARGUMENT EXTEND retroknowledge_nat PRINTED BY pr_r_nat_field | [ "nat" "type" ] -> [ Retroknowledge.NatType ] | [ "nat" "plus" ] -> [ Retroknowledge.NatPlus ] | [ "nat" "times" ] -> [ Retroknowledge.NatTimes ] END VERNAC ARGUMENT EXTEND retroknowledge_binary_n PRINTED BY pr_r_n_field | [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ] | [ "binary" "N" "type" ] -> [ Retroknowledge.NType ] | [ "binary" "N" "twice" ] -> [ Retroknowledge.NTwice ] | [ "binary" "N" "twice" "plus" "one" ] -> [ Retroknowledge.NTwicePlusOne ] | [ "binary" "N" "phi" ] -> [ Retroknowledge.NPhi ] | [ "binary" "N" "phi" "inv" ] -> [ Retroknowledge.NPhiInv ] | [ "binary" "N" "plus" ] -> [ Retroknowledge.NPlus ] | [ "binary" "N" "times" ] -> [ Retroknowledge.NTimes ] END VERNAC ARGUMENT EXTEND retroknowledge_int31 PRINTED BY pr_r_int31_field | [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ] | [ "int31" "type" ] -> [ Retroknowledge.Int31Type ] | [ "int31" "twice" ] -> [ Retroknowledge.Int31Twice ] | [ "int31" "twice" "plus" "one" ] -> [ Retroknowledge.Int31TwicePlusOne ] | [ "int31" "phi" ] -> [ Retroknowledge.Int31Phi ] | [ "int31" "phi" "inv" ] -> [ Retroknowledge.Int31PhiInv ] | [ "int31" "plus" ] -> [ Retroknowledge.Int31Plus ] | [ "int31" "plusc" ] -> [ Retroknowledge.Int31PlusC ] | [ "int31" "pluscarryc" ] -> [ Retroknowledge.Int31PlusCarryC ] | [ "int31" "minus" ] -> [ Retroknowledge.Int31Minus ] | [ "int31" "minusc" ] -> [ Retroknowledge.Int31MinusC ] | [ "int31" "minuscarryc" ] -> [ Retroknowledge.Int31MinusCarryC ] | [ "int31" "times" ] -> [ Retroknowledge.Int31Times ] | [ "int31" "timesc" ] -> [ Retroknowledge.Int31TimesC ] | [ "int31" "div21" ] -> [ Retroknowledge.Int31Div21 ] | [ "int31" "div" ] -> [ Retroknowledge.Int31Div ] | [ "int31" "diveucl" ] -> [ Retroknowledge.Int31Diveucl ] | [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ] | [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ] | [ "int31" "head0" ] -> [ Retroknowledge.Int31Head0 ] | [ "int31" "tail0" ] -> [ Retroknowledge.Int31Tail0 ] | [ "int31" "lor" ] -> [ Retroknowledge.Int31Lor ] | [ "int31" "land" ] -> [ Retroknowledge.Int31Land ] | [ "int31" "lxor" ] -> [ Retroknowledge.Int31Lxor ] END VERNAC ARGUMENT EXTEND retroknowledge_field PRINTED BY pr_retroknowledge_field (*| [ "equality" ] -> [ Retroknowledge.KEq ] | [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ] | [ retroknowledge_binary_n (n)] -> [ Retroknowledge.KN n ]*) | [ retroknowledge_int31 (i) "in" string(g)] -> [ Retroknowledge.KInt31(g,i) ] END coq-8.6/ltac/tacintern.ml0000644000175000017500000007455513022274260014743 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Anonymous | Name id -> Name (intern_ident l ist id) let strict_check = ref false let adjust_loc loc = if !strict_check then dloc else loc (* Globalize a name which must be bound -- actually just check it is bound *) let intern_hyp ist (loc,id as locid) = if not !strict_check then locid else if find_ident id ist then (dloc,id) else Pretype_errors.error_var_not_found_loc loc id let intern_or_var f ist = function | ArgVar locid -> ArgVar (intern_hyp ist locid) | ArgArg x -> ArgArg (f x) let intern_int_or_var = intern_or_var (fun (n : int) -> n) let intern_string_or_var = intern_or_var (fun (s : string) -> s) let intern_global_reference ist = function | Ident (loc,id) when find_var id ist -> ArgVar (loc,id) | r -> let loc,_ as lqid = qualid_of_reference r in try ArgArg (loc,locate_global_with_alias lqid) with Not_found -> error_global_not_found_loc lqid let intern_ltac_variable ist = function | Ident (loc,id) -> if find_var id ist then (* A local variable of any type *) ArgVar (loc,id) else raise Not_found | _ -> raise Not_found let intern_constr_reference strict ist = function | Ident (_,id) as r when not strict && find_hyp id ist -> GVar (dloc,id), Some (CRef (r,None)) | Ident (_,id) as r when find_var id ist -> GVar (dloc,id), if strict then None else Some (CRef (r,None)) | r -> let loc,_ as lqid = qualid_of_reference r in GRef (loc,locate_global_with_alias lqid,None), if strict then None else Some (CRef (r,None)) let intern_move_location ist = function | MoveAfter id -> MoveAfter (intern_hyp ist id) | MoveBefore id -> MoveBefore (intern_hyp ist id) | MoveFirst -> MoveFirst | MoveLast -> MoveLast (* Internalize an isolated reference in position of tactic *) let intern_isolated_global_tactic_reference r = let (loc,qid) = qualid_of_reference r in TacCall (loc,ArgArg (loc,locate_tactic qid),[]) let intern_isolated_tactic_reference strict ist r = (* An ltac reference *) try Reference (intern_ltac_variable ist r) with Not_found -> (* A global tactic *) try intern_isolated_global_tactic_reference r with Not_found -> (* Tolerance for compatibility, allow not to use "constr:" *) try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) with Not_found -> (* Reference not found *) error_global_not_found_loc (qualid_of_reference r) (* Internalize an applied tactic reference *) let intern_applied_global_tactic_reference r = let (loc,qid) = qualid_of_reference r in ArgArg (loc,locate_tactic qid) let intern_applied_tactic_reference ist r = (* An ltac reference *) try intern_ltac_variable ist r with Not_found -> (* A global tactic *) try intern_applied_global_tactic_reference r with Not_found -> (* Reference not found *) error_global_not_found_loc (qualid_of_reference r) (* Intern a reference parsed in a non-tactic entry *) let intern_non_tactic_reference strict ist r = (* An ltac reference *) try Reference (intern_ltac_variable ist r) with Not_found -> (* A constr reference *) try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) with Not_found -> (* Tolerance for compatibility, allow not to use "ltac:" *) try intern_isolated_global_tactic_reference r with Not_found -> (* By convention, use IntroIdentifier for unbound ident, when not in a def *) match r with | Ident (loc,id) when not strict -> let ipat = in_gen (glbwit wit_intro_pattern) (loc, IntroNaming (IntroIdentifier id)) in TacGeneric ipat | _ -> (* Reference not found *) error_global_not_found_loc (qualid_of_reference r) let intern_message_token ist = function | (MsgString _ | MsgInt _ as x) -> x | MsgIdent id -> MsgIdent (intern_hyp ist id) let intern_message ist = List.map (intern_message_token ist) let intern_quantified_hypothesis ist = function | AnonHyp n -> AnonHyp n | NamedHyp id -> (* Uncomment to disallow "intros until n" in ltac when n is not bound *) NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*)) let intern_binding_name ist x = (* We use identifier both for variables and binding names *) (* Todo: consider the body of the lemma to which the binding refer and if a term w/o ltac vars, check the name is indeed quantified *) x let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env} c = let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in let ltacvars = { Constrintern.ltac_vars = lfun; ltac_bound = Id.Set.empty; } in let c' = warn (Constrintern.intern_gen scope ~allow_patvar ~ltacvars env) c in (c',if !strict_check then None else Some c) let intern_constr = intern_constr_gen false false let intern_type = intern_constr_gen false true (* Globalize bindings *) let intern_binding ist (loc,b,c) = (loc,intern_binding_name ist b,intern_constr ist c) let intern_bindings ist = function | NoBindings -> NoBindings | ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l) | ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l) let intern_constr_with_bindings ist (c,bl) = (intern_constr ist c, intern_bindings ist bl) let intern_constr_with_bindings_arg ist (clear,c) = (clear,intern_constr_with_bindings ist c) let rec intern_intro_pattern lf ist = function | loc, IntroNaming pat -> loc, IntroNaming (intern_intro_pattern_naming lf ist pat) | loc, IntroAction pat -> loc, IntroAction (intern_intro_pattern_action lf ist pat) | loc, IntroForthcoming _ as x -> x and intern_intro_pattern_naming lf ist = function | IntroIdentifier id -> IntroIdentifier (intern_ident lf ist id) | IntroFresh id -> IntroFresh (intern_ident lf ist id) | IntroAnonymous as x -> x and intern_intro_pattern_action lf ist = function | IntroOrAndPattern l -> IntroOrAndPattern (intern_or_and_intro_pattern lf ist l) | IntroInjection l -> IntroInjection (List.map (intern_intro_pattern lf ist) l) | IntroWildcard | IntroRewrite _ as x -> x | IntroApplyOn (c,pat) -> IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat) and intern_or_and_intro_pattern lf ist = function | IntroAndPattern l -> IntroAndPattern (List.map (intern_intro_pattern lf ist) l) | IntroOrPattern ll -> IntroOrPattern (List.map (List.map (intern_intro_pattern lf ist)) ll) let intern_or_and_intro_pattern_loc lf ist = function | ArgVar (_,id) as x -> if find_var id ist then x else error "Disjunctive/conjunctive introduction pattern expected." | ArgArg (loc,l) -> ArgArg (loc,intern_or_and_intro_pattern lf ist l) let intern_intro_pattern_naming_loc lf ist (loc,pat) = (loc,intern_intro_pattern_naming lf ist pat) (* TODO: catch ltac vars *) let intern_destruction_arg ist = function | clear,ElimOnConstr c -> clear,ElimOnConstr (intern_constr_with_bindings ist c) | clear,ElimOnAnonHyp n as x -> x | clear,ElimOnIdent (loc,id) -> if !strict_check then (* If in a defined tactic, no intros-until *) match intern_constr ist (CRef (Ident (dloc,id), None)) with | GVar (loc,id),_ -> clear,ElimOnIdent (loc,id) | c -> clear,ElimOnConstr (c,NoBindings) else clear,ElimOnIdent (loc,id) let short_name = function | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id) | _ -> None let intern_evaluable_global_reference ist r = let lqid = qualid_of_reference r in try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true lqid) with Not_found -> match r with | Ident (loc,id) when not !strict_check -> EvalVarRef id | _ -> error_global_not_found_loc lqid let intern_evaluable_reference_or_by_notation ist = function | AN r -> intern_evaluable_global_reference ist r | ByNotation (loc,ntn,sc) -> evaluable_of_global_reference ist.genv (Notation.interp_notation_as_global_reference loc (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) (* Globalize a reduction expression *) let intern_evaluable ist = function | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id) | AN (Ident (loc,id)) when not !strict_check && find_hyp id ist -> ArgArg (EvalVarRef id, Some (loc,id)) | r -> let e = intern_evaluable_reference_or_by_notation ist r in let na = short_name r in ArgArg (e,na) let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid) let intern_flag ist red = { red with rConst = List.map (intern_evaluable ist) red.rConst } let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c) let intern_constr_pattern ist ~as_type ~ltacvars pc = let ltacvars = { Constrintern.ltac_vars = ltacvars; ltac_bound = Id.Set.empty; } in let metas,pat = Constrintern.intern_constr_pattern ist.genv ~as_type ~ltacvars pc in let (glob,_ as c) = intern_constr_gen true false ist pc in let bound_names = Glob_ops.bound_glob_vars glob in metas,(bound_names,c,pat) let dummy_pat = PRel 0 let intern_typed_pattern ist p = (* we cannot ensure in non strict mode that the pattern is closed *) (* keeping a constr_expr copy is too complicated and we want anyway to *) (* type it, so we remember the pattern as a glob_constr only *) let (glob,_ as c) = intern_constr_gen true false ist p in let bound_names = Glob_ops.bound_glob_vars glob in (bound_names,c,dummy_pat) let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = let interp_ref r = try Inl (intern_evaluable ist r) with e when Logic.catchable_exception e -> (* Compatibility. In practice, this means that the code above is useless. Still the idea of having either an evaluable ref or a pattern seems interesting, with "head" reduction in case of an evaluable ref, and "strong" reduction in the subterm matched when a pattern *) let loc = loc_of_smart_reference r in let r = match r with | AN r -> r | _ -> Qualid (loc,qualid_of_path (path_of_global (smart_global r))) in let sign = { Constrintern.ltac_vars = ist.ltacvars; Constrintern.ltac_bound = Id.Set.empty } in let c = Constrintern.interp_reference sign r in match c with | GRef (_,r,None) -> Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) | GVar (_,id) -> let r = evaluable_of_global_reference ist.genv (VarRef id) in Inl (ArgArg (r,None)) | _ -> let bound_names = Glob_ops.bound_glob_vars c in Inr (bound_names,(c,None),dummy_pat) in (l, match p with | Inl r -> interp_ref r | Inr (CAppExpl(_,(None,r,None),[])) -> (* We interpret similarly @ref and ref *) interp_ref (AN r) | Inr c -> Inr (intern_typed_pattern ist c)) (* This seems fairly hacky, but it's the first way I've found to get proper globalization of [unfold]. --adamc *) let dump_glob_red_expr = function | Unfold occs -> List.iter (fun (_, r) -> try Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) (Smartlocate.smart_global r) with e when CErrors.noncritical e -> ()) occs | Cbv grf | Lazy grf -> List.iter (fun r -> try Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) (Smartlocate.smart_global r) with e when CErrors.noncritical e -> ()) grf.rConst | _ -> () let intern_red_expr ist = function | Unfold l -> Unfold (List.map (intern_unfold ist) l) | Fold l -> Fold (List.map (intern_constr ist) l) | Cbv f -> Cbv (intern_flag ist f) | Cbn f -> Cbn (intern_flag ist f) | Lazy f -> Lazy (intern_flag ist f) | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l) | Simpl (f,o) -> Simpl (intern_flag ist f, Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) | CbvVm o -> CbvVm (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r let intern_in_hyp_as ist lf (id,ipat) = (intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) let intern_hyp_list ist = List.map (intern_hyp ist) let intern_inversion_strength lf ist = function | NonDepInversion (k,idl,ids) -> NonDepInversion (k,intern_hyp_list ist idl, Option.map (intern_or_and_intro_pattern_loc lf ist) ids) | DepInversion (k,copt,ids) -> DepInversion (k, Option.map (intern_constr ist) copt, Option.map (intern_or_and_intro_pattern_loc lf ist) ids) | InversionUsing (c,idl) -> InversionUsing (intern_constr ist c, intern_hyp_list ist idl) (* Interprets an hypothesis name *) let intern_hyp_location ist ((occs,id),hl) = ((Locusops.occurrences_map (List.map (intern_int_or_var ist)) occs, intern_hyp ist id), hl) (* Reads a pattern *) let intern_pattern ist ?(as_type=false) ltacvars = function | Subterm (b,ido,pc) -> let (metas,pc) = intern_constr_pattern ist ~as_type:false ~ltacvars pc in ido, metas, Subterm (b,ido,pc) | Term pc -> let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in None, metas, Term pc let intern_constr_may_eval ist = function | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c) | ConstrContext (locid,c) -> ConstrContext (intern_hyp ist locid,intern_constr ist c) | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c) | ConstrTerm c -> ConstrTerm (intern_constr ist c) let name_cons accu = function | Anonymous -> accu | Name id -> Id.Set.add id accu let opt_cons accu = function | None -> accu | Some id -> Id.Set.add id accu (* Reads the hypotheses of a "match goal" rule *) let rec intern_match_goal_hyps ist ?(as_type=false) lfun = function | (Hyp ((_,na) as locna,mp))::tl -> let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in let lfun' = name_cons (opt_cons lfun ido) na in lfun', metas1@metas2, Hyp (locna,pat)::hyps | (Def ((_,na) as locna,mv,mp))::tl -> let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in let lfun, metas3, hyps = intern_match_goal_hyps ist ~as_type lfun tl in let lfun' = name_cons (opt_cons (opt_cons lfun ido) ido') na in lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps | [] -> lfun, [], [] (* Utilities *) let extract_let_names lrc = let fold accu ((loc, name), _) = if Id.Set.mem name accu then user_err_loc (loc, "glob_tactic", str "This variable is bound several times.") else Id.Set.add name accu in List.fold_left fold Id.Set.empty lrc let clause_app f = function { onhyps=None; concl_occs=nl } -> { onhyps=None; concl_occs=nl } | { onhyps=Some l; concl_occs=nl } -> { onhyps=Some(List.map f l); concl_occs=nl} (* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *) let rec intern_atomic lf ist x = match (x:raw_atomic_tactic_expr) with (* Basic tactics *) | TacIntroPattern (ev,l) -> TacIntroPattern (ev,List.map (intern_intro_pattern lf ist) l) | TacApply (a,ev,cb,inhyp) -> TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb, Option.map (intern_in_hyp_as ist lf) inhyp) | TacElim (ev,cb,cbo) -> TacElim (ev,intern_constr_with_bindings_arg ist cb, Option.map (intern_constr_with_bindings ist) cbo) | TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings_arg ist cb) | TacMutualFix (id,n,l) -> let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in TacMutualFix (intern_ident lf ist id, n, List.map f l) | TacMutualCofix (id,l) -> let f (id,c) = (intern_ident lf ist id,intern_type ist c) in TacMutualCofix (intern_ident lf ist id, List.map f l) | TacAssert (b,otac,ipat,c) -> TacAssert (b,Option.map (Option.map (intern_pure_tactic ist)) otac, Option.map (intern_intro_pattern lf ist) ipat, intern_constr_gen false (not (Option.is_empty otac)) ist c) | TacGeneralize cl -> TacGeneralize (List.map (fun (c,na) -> intern_constr_with_occurrences ist c, intern_name lf ist na) cl) | TacLetTac (na,c,cls,b,eqpat) -> let na = intern_name lf ist na in TacLetTac (na,intern_constr ist c, (clause_app (intern_hyp_location ist) cls),b, (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat)) (* Derived basic tactics *) | TacInductionDestruct (ev,isrec,(l,el)) -> TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) -> (intern_destruction_arg ist c, (Option.map (intern_intro_pattern_naming_loc lf ist) ipato, Option.map (intern_or_and_intro_pattern_loc lf ist) ipats), Option.map (clause_app (intern_hyp_location ist)) cls)) l, Option.map (intern_constr_with_bindings ist) el)) (* Conversion *) | TacReduce (r,cl) -> dump_glob_red_expr r; TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl) | TacChange (None,c,cl) -> let is_onhyps = match cl.onhyps with | None | Some [] -> true | _ -> false in let is_onconcl = match cl.concl_occs with | AllOccurrences | NoOccurrences -> true | _ -> false in TacChange (None, (if is_onhyps && is_onconcl then intern_type ist c else intern_constr ist c), clause_app (intern_hyp_location ist) cl) | TacChange (Some p,c,cl) -> TacChange (Some (intern_typed_pattern ist p),intern_constr ist c, clause_app (intern_hyp_location ist) cl) (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> TacRewrite (ev, List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings_arg ist c)) l, clause_app (intern_hyp_location ist) cl, Option.map (intern_pure_tactic ist) by) | TacInversion (inv,hyp) -> TacInversion (intern_inversion_strength lf ist inv, intern_quantified_hypothesis ist hyp) and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac) and intern_tactic_seq onlytac ist = function | TacAtom (loc,t) -> let lf = ref ist.ltacvars in let t = intern_atomic lf ist t in !lf, TacAtom (adjust_loc loc, t) | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun) | TacLetIn (isrec,l,u) -> let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in let ist' = { ist with ltacvars } in let l = List.map (fun (n,b) -> (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u) | TacMatchGoal (lz,lr,lmr) -> ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist ~as_type:true lmr) | TacMatch (lz,c,lmr) -> ist.ltacvars, TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr) | TacId l -> ist.ltacvars, TacId (intern_message ist l) | TacFail (g,n,l) -> ist.ltacvars, TacFail (g,intern_int_or_var ist n,intern_message ist l) | TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac) | TacShowHyps tac -> ist.ltacvars, TacShowHyps (intern_pure_tactic ist tac) | TacAbstract (tac,s) -> ist.ltacvars, TacAbstract (intern_pure_tactic ist tac,s) | TacThen (t1,t2) -> let lfun', t1 = intern_tactic_seq onlytac ist t1 in let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in lfun'', TacThen (t1,t2) | TacDispatch tl -> ist.ltacvars , TacDispatch (List.map (intern_pure_tactic ist) tl) | TacExtendTac (tf,t,tl) -> ist.ltacvars , TacExtendTac (Array.map (intern_pure_tactic ist) tf, intern_pure_tactic ist t, Array.map (intern_pure_tactic ist) tl) | TacThens3parts (t1,tf,t2,tl) -> let lfun', t1 = intern_tactic_seq onlytac ist t1 in let ist' = { ist with ltacvars = lfun' } in (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) lfun', TacThens3parts (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2, Array.map (intern_pure_tactic ist') tl) | TacThens (t,tl) -> let lfun', t = intern_tactic_seq true ist t in let ist' = { ist with ltacvars = lfun' } in (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) lfun', TacThens (t, List.map (intern_pure_tactic ist') tl) | TacDo (n,tac) -> ist.ltacvars, TacDo (intern_int_or_var ist n,intern_pure_tactic ist tac) | TacTry tac -> ist.ltacvars, TacTry (intern_pure_tactic ist tac) | TacInfo tac -> ist.ltacvars, TacInfo (intern_pure_tactic ist tac) | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_pure_tactic ist tac) | TacTimeout (n,tac) -> ist.ltacvars, TacTimeout (intern_int_or_var ist n,intern_tactic onlytac ist tac) | TacTime (s,tac) -> ist.ltacvars, TacTime (s,intern_tactic onlytac ist tac) | TacOr (tac1,tac2) -> ist.ltacvars, TacOr (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2) | TacOnce tac -> ist.ltacvars, TacOnce (intern_pure_tactic ist tac) | TacExactlyOnce tac -> ist.ltacvars, TacExactlyOnce (intern_pure_tactic ist tac) | TacIfThenCatch (tac,tact,tace) -> ist.ltacvars, TacIfThenCatch ( intern_pure_tactic ist tac, intern_pure_tactic ist tact, intern_pure_tactic ist tace) | TacOrelse (tac1,tac2) -> ist.ltacvars, TacOrelse (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2) | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l) | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l) | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac) | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a | TacSelect (sel, tac) -> ist.ltacvars, TacSelect (sel, intern_pure_tactic ist tac) (* For extensions *) | TacAlias (loc,s,l) -> let l = List.map (intern_tacarg !strict_check false ist) l in ist.ltacvars, TacAlias (loc,s,l) | TacML (loc,opn,l) -> let _ignore = Tacenv.interp_ml_tactic opn in ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_tacarg !strict_check false ist) l) and intern_tactic_as_arg loc onlytac ist a = match intern_tacarg !strict_check onlytac ist a with | TacCall _ | Reference _ | TacGeneric _ as a -> TacArg (loc,a) | Tacexp a -> a | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> if onlytac then error_tactic_expected loc else TacArg (loc,a) and intern_tactic_or_tacarg ist = intern_tactic false ist and intern_pure_tactic ist = intern_tactic true ist and intern_tactic_fun ist (var,body) = let lfun = List.fold_left opt_cons ist.ltacvars var in (var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body) and intern_tacarg strict onlytac ist = function | Reference r -> intern_non_tactic_reference strict ist r | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f | TacCall (loc,f,l) -> TacCall (loc, intern_applied_tactic_reference ist f, List.map (intern_tacarg !strict_check false ist) l) | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x) | TacPretype c -> TacPretype (intern_constr ist c) | TacNumgoals -> TacNumgoals | Tacexp t -> Tacexp (intern_tactic onlytac ist t) | TacGeneric arg -> let arg = intern_genarg ist arg in TacGeneric arg (* Reads the rules of a Match Context or a Match *) and intern_match_rule onlytac ist ?(as_type=false) = function | (All tc)::tl -> All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist ~as_type tl) | (Pat (rl,mp,tc))::tl -> let {ltacvars=lfun; genv=env} = ist in let lfun',metas1,hyps = intern_match_goal_hyps ist ~as_type lfun rl in let ido,metas2,pat = intern_pattern ist ~as_type lfun mp in let fold accu x = Id.Set.add x accu in let ltacvars = List.fold_left fold (opt_cons lfun' ido) metas1 in let ltacvars = List.fold_left fold ltacvars metas2 in let ist' = { ist with ltacvars } in Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist ~as_type tl) | [] -> [] and intern_genarg ist (GenArg (Rawwit wit, x)) = match wit with | ListArg wit -> let map x = let ans = intern_genarg ist (in_gen (rawwit wit) x) in out_gen (glbwit wit) ans in in_gen (glbwit (wit_list wit)) (List.map map x) | OptArg wit -> let ans = match x with | None -> in_gen (glbwit (wit_opt wit)) None | Some x -> let s = out_gen (glbwit wit) (intern_genarg ist (in_gen (rawwit wit) x)) in in_gen (glbwit (wit_opt wit)) (Some s) in ans | PairArg (wit1, wit2) -> let p, q = x in let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in in_gen (glbwit (wit_pair wit1 wit2)) (p, q) | ExtraArg s -> snd (Genintern.generic_intern ist (in_gen (rawwit wit) x)) (** Other entry points *) let glob_tactic x = Flags.with_option strict_check (intern_pure_tactic (make_empty_glob_sign ())) x let glob_tactic_env l env x = let ltacvars = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in Flags.with_option strict_check (intern_pure_tactic { ltacvars; genv = env }) x let split_ltac_fun = function | TacFun (l,t) -> (l,t) | t -> ([],t) let pr_ltac_fun_arg = function | None -> spc () ++ str "_" | Some id -> spc () ++ pr_id id let print_ltac id = try let kn = Nametab.locate_tactic id in let entries = Tacenv.ltac_entries () in let tac = KNmap.find kn entries in let filter mp = try Some (Nametab.shortest_qualid_of_module mp) with Not_found -> None in let mods = List.map_filter filter tac.Tacenv.tac_redef in let redefined = match mods with | [] -> mt () | mods -> let redef = prlist_with_sep fnl pr_qualid mods in fnl () ++ str "Redefined by:" ++ fnl () ++ redef in let l,t = split_ltac_fun tac.Tacenv.tac_body in hv 2 ( hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++ prlist pr_ltac_fun_arg l ++ spc () ++ str ":=") ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined with Not_found -> errorlabstrm "print_ltac" (pr_qualid id ++ spc() ++ str "is not a user defined tactic.") (** Registering *) let lift intern = (); fun ist x -> (ist, intern ist x) let () = let intern_intro_pattern ist pat = let lf = ref Id.Set.empty in let ans = intern_intro_pattern lf ist pat in let ist = { ist with ltacvars = !lf } in (ist, ans) in Genintern.register_intern0 wit_intro_pattern intern_intro_pattern let () = let intern_clause ist cl = let ans = clause_app (intern_hyp_location ist) cl in (ist, ans) in Genintern.register_intern0 wit_clause_dft_concl intern_clause let intern_ident' ist id = let lf = ref Id.Set.empty in (ist, intern_ident lf ist id) let () = Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); Genintern.register_intern0 wit_ref (lift intern_global_reference); Genintern.register_intern0 wit_ident intern_ident'; Genintern.register_intern0 wit_var (lift intern_hyp); Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); Genintern.register_intern0 wit_ltac (lift intern_tactic_or_tacarg); Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c)); Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)); Genintern.register_intern0 wit_open_constr (fun ist c -> (ist,intern_constr ist c)); Genintern.register_intern0 wit_red_expr (lift intern_red_expr); Genintern.register_intern0 wit_bindings (lift intern_bindings); Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings); Genintern.register_intern0 wit_destruction_arg (lift intern_destruction_arg); () (***************************************************************************) (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = let f l = let ltacvars = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in Flags.with_option strict_check (intern_pure_tactic { (make_empty_glob_sign()) with ltacvars }) in Hook.set Hints.extern_intern_tac f coq-8.6/ltac/rewrite.mli0000644000175000017500000000672113022274260014574 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* strategy val map_strategy : ('a -> 'b) -> ('c -> 'd) -> ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast val pr_strategy : ('a -> Pp.std_ppcmds) -> ('b -> Pp.std_ppcmds) -> ('a, 'b) strategy_ast -> Pp.std_ppcmds (** Entry point for user-level "rewrite_strat" *) val cl_rewrite_clause_strat : strategy -> Id.t option -> unit Proofview.tactic (** Entry point for user-level "setoid_rewrite" *) val cl_rewrite_clause : interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) -> bool -> Locus.occurrences -> Id.t option -> unit Proofview.tactic val is_applied_rewrite_relation : env -> evar_map -> Context.Rel.t -> constr -> types option val declare_relation : ?binders:local_binder list -> constr_expr -> constr_expr -> Id.t -> constr_expr option -> constr_expr option -> constr_expr option -> unit val add_setoid : bool -> local_binder list -> constr_expr -> constr_expr -> constr_expr -> Id.t -> unit val add_morphism_infer : bool -> constr_expr -> Id.t -> unit val add_morphism : bool -> local_binder list -> constr_expr -> constr_expr -> Id.t -> unit val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr val get_symmetric_proof : env -> evar_map -> constr -> constr -> evar_map * constr val get_transitive_proof : env -> evar_map -> constr -> constr -> evar_map * constr val default_morphism : (types * constr option) option list * (types * types option) option -> constr -> constr * constr val setoid_symmetry : unit Proofview.tactic val setoid_symmetry_in : Id.t -> unit Proofview.tactic val setoid_reflexivity : unit Proofview.tactic val setoid_transitivity : constr option -> unit Proofview.tactic val apply_strategy : strategy -> Environ.env -> Names.Id.t list -> Term.constr -> bool * Term.constr -> evars -> rewrite_result coq-8.6/ltac/tactic_option.mli0000644000175000017500000000142613022274260015747 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string -> (* put *) (locality_flag -> glob_tactic_expr -> unit) * (* get *) (unit -> locality_flag * unit Proofview.tactic) * (* print *) (unit -> Pp.std_ppcmds) coq-8.6/ltac/extraargs.mli0000644000175000017500000000477213022274260015117 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Pp.std_ppcmds val wit_rename : (Id.t * Id.t) Genarg.uniform_genarg_type val occurrences : (int list or_var) Pcoq.Gram.entry val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type val pr_occurrences : int list or_var -> Pp.std_ppcmds val occurrences_of : int list -> Locus.occurrences val wit_natural : int Genarg.uniform_genarg_type val wit_glob : (constr_expr, Tacexpr.glob_constr_and_expr, Tacinterp.interp_sign * glob_constr) Genarg.genarg_type val wit_lglob : (constr_expr, Tacexpr.glob_constr_and_expr, Tacinterp.interp_sign * glob_constr) Genarg.genarg_type val wit_lconstr : (constr_expr, Tacexpr.glob_constr_and_expr, Constr.t) Genarg.genarg_type val wit_casted_constr : (constr_expr, Tacexpr.glob_constr_and_expr, Constr.t) Genarg.genarg_type val glob : constr_expr Pcoq.Gram.entry val lglob : constr_expr Pcoq.Gram.entry type 'id gen_place= ('id * Locus.hyp_location_flag,unit) location type loc_place = Id.t Loc.located gen_place type place = Id.t gen_place val wit_hloc : (loc_place, loc_place, place) Genarg.genarg_type val hloc : loc_place Pcoq.Gram.entry val pr_hloc : loc_place -> Pp.std_ppcmds val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry val wit_by_arg_tac : (raw_tactic_expr option, glob_tactic_expr option, Geninterp.Val.t option) Genarg.genarg_type val pr_by_arg_tac : (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) -> raw_tactic_expr option -> Pp.std_ppcmds (** Spiwack: Primitive for retroknowledge registration *) val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type val wit_in_clause : (Id.t Loc.located Locus.clause_expr, Id.t Loc.located Locus.clause_expr, Id.t Locus.clause_expr) Genarg.genarg_type coq-8.6/ltac/rewrite.ml0000644000175000017500000024314613022274260014427 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* anomaly (str "Global reference " ++ str s ++ str " not found in generalized rewriting") let find_reference dir s = let gr = lazy (try_find_global_reference dir s) in fun () -> Lazy.force gr type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) let find_global dir s = let gr = lazy (try_find_global_reference dir s) in fun (evd,cstrs) -> let sigma = Sigma.Unsafe.of_evar_map evd in let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force gr) in let evd = Sigma.to_evar_map sigma in (evd, cstrs), c (** Utility for dealing with polymorphic applications *) (** Global constants. *) let coq_eq_ref = find_reference ["Init"; "Logic"] "eq" let coq_eq = find_global ["Init"; "Logic"] "eq" let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" let coq_all = find_global ["Init"; "Logic"] "all" let impl = find_global ["Program"; "Basics"] "impl" (** Bookkeeping which evars are constraints so that we can remove them at the end of the tactic. *) let goalevars evars = fst evars let cstrevars evars = snd evars let new_cstr_evar (evd,cstrs) env t = let s = Typeclasses.set_resolvable Evd.Store.empty false in let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (t, evd', _) = Evarutil.new_evar ~store:s env evd t in let evd' = Sigma.to_evar_map evd' in let ev, _ = destEvar t in (evd', Evar.Set.add ev cstrs), t (** Building or looking up instances. *) let e_new_cstr_evar env evars t = let evd', t = new_cstr_evar !evars env t in evars := evd'; t (** Building or looking up instances. *) let extends_undefined evars evars' = let f ev evi found = found || not (Evd.mem evars ev) in fold_undefined f evars' false let app_poly_check env evars f args = let (evars, cstrs), fc = f evars in let evdref = ref evars in let t = Typing.e_solve_evars env evdref (mkApp (fc, args)) in (!evdref, cstrs), t let app_poly_nocheck env evars f args = let evars, fc = f evars in evars, mkApp (fc, args) let app_poly_sort b = if b then app_poly_nocheck else app_poly_check let find_class_proof proof_type proof_method env evars carrier relation = try let evars, goal = app_poly_check env evars proof_type [| carrier ; relation |] in let evars', c = Typeclasses.resolve_one_typeclass env (goalevars evars) goal in if extends_undefined (goalevars evars) evars' then raise Not_found else app_poly_check env (evars',cstrevars evars) proof_method [| carrier; relation; c |] with e when Logic.catchable_exception e -> raise Not_found (** Utility functions *) module GlobalBindings (M : sig val relation_classes : string list val morphisms : string list val relation : string list * string val app_poly : env -> evars -> (evars -> evars * constr) -> constr array -> evars * constr val arrow : evars -> evars * constr end) = struct open M open Context.Rel.Declaration let relation : evars -> evars * constr = find_global (fst relation) (snd relation) let reflexive_type = find_global relation_classes "Reflexive" let reflexive_proof = find_global relation_classes "reflexivity" let symmetric_type = find_global relation_classes "Symmetric" let symmetric_proof = find_global relation_classes "symmetry" let transitive_type = find_global relation_classes "Transitive" let transitive_proof = find_global relation_classes "transitivity" let forall_relation = find_global morphisms "forall_relation" let pointwise_relation = find_global morphisms "pointwise_relation" let forall_relation_ref = find_reference morphisms "forall_relation" let pointwise_relation_ref = find_reference morphisms "pointwise_relation" let respectful = find_global morphisms "respectful" let respectful_ref = find_reference morphisms "respectful" let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation" let coq_forall = find_global morphisms "forall_def" let subrelation = find_global relation_classes "subrelation" let do_subrelation = find_global morphisms "do_subrelation" let apply_subrelation = find_global morphisms "apply_subrelation" let rewrite_relation_class = find_global relation_classes "RewriteRelation" let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper")) let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy")) let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) let proper_type = let l = lazy (Lazy.force proper_class).cl_impl in fun (evd,cstrs) -> let sigma = Sigma.Unsafe.of_evar_map evd in let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in let evd = Sigma.to_evar_map sigma in (evd, cstrs), c let proper_proxy_type = let l = lazy (Lazy.force proper_proxy_class).cl_impl in fun (evd,cstrs) -> let sigma = Sigma.Unsafe.of_evar_map evd in let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in let evd = Sigma.to_evar_map sigma in (evd, cstrs), c let proper_proof env evars carrier relation x = let evars, goal = app_poly env evars proper_proxy_type [| carrier ; relation; x |] in new_cstr_evar evars env goal let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env let get_transitive_proof env = find_class_proof transitive_type transitive_proof env let mk_relation env evd a = app_poly env evd relation [| a |] (** Build an infered signature from constraints on the arguments and expected output relation *) let build_signature evars env m (cstrs : (types * types option) option list) (finalcstr : (types * types option) option) = let mk_relty evars newenv ty obj = match obj with | None | Some (_, None) -> let evars, relty = mk_relation env evars ty in if closed0 ty then let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in new_cstr_evar evars env' relty else new_cstr_evar evars newenv relty | Some (x, Some rel) -> evars, rel in let rec aux env evars ty l = let t = Reductionops.whd_all env (goalevars evars) ty in match kind_of_term t, l with | Prod (na, ty, b), obj :: cstrs -> let b = Reductionops.nf_betaiota (goalevars evars) b in if noccurn 1 b (* non-dependent product *) then let ty = Reductionops.nf_betaiota (goalevars evars) ty in let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in let evars, relty = mk_relty evars env ty obj in let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs else let (evars, b, arg, cstrs) = aux (Environ.push_rel (LocalAssum (na, ty)) env) evars b cstrs in let ty = Reductionops.nf_betaiota (goalevars evars) ty in let pred = mkLambda (na, ty, b) in let liftarg = mkLambda (na, ty, arg) in let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs else error "build_signature: no constraint can apply on a dependent argument" | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") | _, [] -> (match finalcstr with | None | Some (_, None) -> let t = Reductionops.nf_betaiota (fst evars) ty in let evars, rel = mk_relty evars env t None in evars, t, rel, [t, Some rel] | Some (t, Some rel) -> evars, t, rel, [t, Some rel]) in aux env evars m cstrs (** Folding/unfolding of the tactic constants. *) let unfold_impl t = match kind_of_term t with | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> mkProd (Anonymous, a, lift 1 b) | _ -> assert false let unfold_all t = match kind_of_term t with | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> (match kind_of_term b with | Lambda (n, ty, b) -> mkProd (n, ty, b) | _ -> assert false) | _ -> assert false let unfold_forall t = match kind_of_term t with | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> (match kind_of_term b with | Lambda (n, ty, b) -> mkProd (n, ty, b) | _ -> assert false) | _ -> assert false let arrow_morphism env evd ta tb a b = let ap = is_Prop ta and bp = is_Prop tb in if ap && bp then app_poly env evd impl [| a; b |], unfold_impl else if ap then (* Domain in Prop, CoDomain in Type *) (app_poly env evd arrow [| a; b |]), unfold_impl (* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *) else if bp then (* Dummy forall *) (app_poly env evd coq_all [| a; mkLambda (Anonymous, a, lift 1 b) |]), unfold_forall else (* None in Prop, use arrow *) (app_poly env evd arrow [| a; b |]), unfold_impl let rec decomp_pointwise n c = if Int.equal n 0 then c else match kind_of_term c with | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> decomp_pointwise (pred n) relb | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1])) | _ -> invalid_arg "decomp_pointwise" let rec apply_pointwise rel = function | arg :: args -> (match kind_of_term rel with | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> apply_pointwise relb args | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args | _ -> invalid_arg "apply_pointwise") | [] -> rel let pointwise_or_dep_relation env evd n t car rel = if noccurn 1 car && noccurn 1 rel then app_poly env evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |] else app_poly env evd forall_relation [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |] let lift_cstr env evars (args : constr list) c ty cstr = let start evars env car = match cstr with | None | Some (_, None) -> let evars, rel = mk_relation env evars car in new_cstr_evar evars env rel | Some (ty, Some rel) -> evars, rel in let rec aux evars env prod n = if Int.equal n 0 then start evars env prod else match kind_of_term (Reduction.whd_all env prod) with | Prod (na, ty, b) -> if noccurn 1 b then let b' = lift (-1) b in let evars, rb = aux evars env b' (pred n) in app_poly env evars pointwise_relation [| ty; b'; rb |] else let evars, rb = aux evars (Environ.push_rel (LocalAssum (na, ty)) env) b (pred n) in app_poly env evars forall_relation [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] | _ -> raise Not_found in let rec find env c ty = function | [] -> None | arg :: args -> try let evars, found = aux evars env ty (succ (List.length args)) in Some (evars, found, c, ty, arg :: args) with Not_found -> let ty = whd_all env ty in find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args in find env c ty args let unlift_cstr env sigma = function | None -> None | Some codom -> Some (decomp_pointwise 1 codom) (** Looking up declared rewrite relations (instances of [RewriteRelation]) *) let is_applied_rewrite_relation env sigma rels t = match kind_of_term t with | App (c, args) when Array.length args >= 2 -> let head = if isApp c then fst (destApp c) else c in if Globnames.is_global (coq_eq_ref ()) head then None else (try let params, args = Array.chop (Array.length args - 2) args in let env' = Environ.push_rel_context rels env in let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma ((evar, _), evars, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in let evars = Sigma.to_evar_map evars in let evars, inst = app_poly env (evars,Evar.Set.empty) rewrite_relation_class [| evar; mkApp (c, params) |] in let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in Some (it_mkProd_or_LetIn t rels) with e when CErrors.noncritical e -> None) | _ -> None end (* let my_type_of env evars c = Typing.e_type_of env evars c *) (* let mytypeofkey = Profile.declare_profile "my_type_of";; *) (* let my_type_of = Profile.profile3 mytypeofkey my_type_of *) let type_app_poly env env evd f args = let evars, c = app_poly_nocheck env evd f args in let evd', t = Typing.type_of env (goalevars evars) c in (evd', cstrevars evars), c module PropGlobal = struct module Consts = struct let relation_classes = ["Classes"; "RelationClasses"] let morphisms = ["Classes"; "Morphisms"] let relation = ["Relations";"Relation_Definitions"], "relation" let app_poly = app_poly_nocheck let arrow = find_global ["Program"; "Basics"] "arrow" let coq_inverse = find_global ["Program"; "Basics"] "flip" end module G = GlobalBindings(Consts) include G include Consts let inverse env evd car rel = type_app_poly env env evd coq_inverse [| car ; car; mkProp; rel |] (* app_poly env evd coq_inverse [| car ; car; mkProp; rel |] *) end module TypeGlobal = struct module Consts = struct let relation_classes = ["Classes"; "CRelationClasses"] let morphisms = ["Classes"; "CMorphisms"] let relation = relation_classes, "crelation" let app_poly = app_poly_check let arrow = find_global ["Classes"; "CRelationClasses"] "arrow" let coq_inverse = find_global ["Classes"; "CRelationClasses"] "flip" end module G = GlobalBindings(Consts) include G include Consts let inverse env (evd,cstrs) car rel = let sigma = Sigma.Unsafe.of_evar_map evd in let Sigma (sort, sigma, _) = Evarutil.new_Type ~rigid:Evd.univ_flexible env sigma in let evd = Sigma.to_evar_map sigma in app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] end let sort_of_rel env evm rel = Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel) let is_applied_rewrite_relation = PropGlobal.is_applied_rewrite_relation (* let _ = *) (* Hook.set Equality.is_applied_rewrite_relation is_applied_rewrite_relation *) let split_head = function hd :: tl -> hd, tl | [] -> assert(false) let eq_pb (ty, env, x, y as pb) (ty', env', x', y' as pb') = pb == pb' || (ty == ty' && Constr.equal x x' && Constr.equal y y') let problem_inclusion x y = List.for_all (fun pb -> List.exists (fun pb' -> eq_pb pb pb') y) x let evd_convertible env evd x y = try (* Unfortunately, the_conv_x might say they are unifiable even if some unsolvable constraints remain, so we check that this unification does not introduce any new problem. *) let _, pbs = Evd.extract_all_conv_pbs evd in let evd' = Evarconv.the_conv_x env x y evd in let _, pbs' = Evd.extract_all_conv_pbs evd' in if evd' == evd || problem_inclusion pbs' pbs then Some evd' else None with e when CErrors.noncritical e -> None let convertible env evd x y = Reductionops.is_conv_leq env evd x y type hypinfo = { prf : constr; car : constr; rel : constr; sort : bool; (* true = Prop; false = Type *) c1 : constr; c2 : constr; holes : Clenv.hole list; } let get_symmetric_proof b = if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof let error_no_relation () = error "Cannot find a relation to rewrite." let rec decompose_app_rel env evd t = (** Head normalize for compatibility with the old meta mechanism *) let t = Reductionops.whd_betaiota evd t in match kind_of_term t with | App (f, [||]) -> assert false | App (f, [|arg|]) -> let (f', argl, argr) = decompose_app_rel env evd arg in let ty = Typing.unsafe_type_of env evd argl in let f'' = mkLambda (Name default_dependent_ident, ty, mkLambda (Name (Id.of_string "y"), lift 1 ty, mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) in (f'', argl, argr) | App (f, args) -> let len = Array.length args in let fargs = Array.sub args 0 (Array.length args - 2) in let rel = mkApp (f, fargs) in rel, args.(len - 2), args.(len - 1) | _ -> error_no_relation () let decompose_app_rel env evd t = let (rel, t1, t2) = decompose_app_rel env evd t in let ty = Retyping.get_type_of env evd rel in let () = if not (Reduction.is_arity env ty) then error_no_relation () in (rel, t1, t2) let decompose_applied_relation env sigma (c,l) = let open Context.Rel.Declaration in let ctype = Retyping.get_type_of env sigma c in let find_rel ty = let sigma, cl = Clenv.make_evar_clause env sigma ty in let sigma = Clenv.solve_evar_clause env sigma true cl l in let { Clenv.cl_holes = holes; Clenv.cl_concl = t } = cl in let (equiv, c1, c2) = decompose_app_rel env sigma t in let ty1 = Retyping.get_type_of env sigma c1 in let ty2 = Retyping.get_type_of env sigma c2 in match evd_convertible env sigma ty1 ty2 with | None -> None | Some sigma -> let sort = sort_of_rel env sigma equiv in let args = Array.map_of_list (fun h -> h.Clenv.hole_evar) holes in let value = mkApp (c, args) in Some (sigma, { prf=value; car=ty1; rel = equiv; sort = Sorts.is_prop sort; c1=c1; c2=c2; holes }) in match find_rel ctype with | Some c -> c | None -> let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with | Some c -> c | None -> error "Cannot find an homogeneous relation to rewrite." let rewrite_db = "rewrite" let conv_transparent_state = (Id.Pred.empty, Cpred.full) let _ = Hints.add_hints_init (fun () -> Hints.create_hint_db false rewrite_db conv_transparent_state true) let rewrite_transparent_state () = Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db) let rewrite_core_unif_flags = { Unification.modulo_conv_on_closed_terms = None; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.use_evars_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; Unification.modulo_delta_types = full_transparent_state; Unification.check_applied_meta_types = true; Unification.use_pattern_unification = true; Unification.use_meta_bound_pattern_unification = true; Unification.frozen_evars = Evar.Set.empty; Unification.restrict_conv_on_strict_subterms = false; Unification.modulo_betaiota = false; Unification.modulo_eta = true; } (* Flags used for the setoid variant of "rewrite" and for the strategies "hints"/"old_hints"/"terms" of "rewrite_strat", and for solving pre-existing evars in "rewrite" (see unify_abs) *) let rewrite_unif_flags = let flags = rewrite_core_unif_flags in { Unification.core_unify_flags = flags; Unification.merge_unify_flags = flags; Unification.subterm_unify_flags = flags; Unification.allow_K_in_toplevel_higher_order_unification = true; Unification.resolve_evars = true } let rewrite_core_conv_unif_flags = { rewrite_core_unif_flags with Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; Unification.modulo_delta_types = conv_transparent_state; Unification.modulo_betaiota = true } (* Fallback flags for the setoid variant of "rewrite" *) let rewrite_conv_unif_flags = let flags = rewrite_core_conv_unif_flags in { Unification.core_unify_flags = flags; Unification.merge_unify_flags = flags; Unification.subterm_unify_flags = flags; Unification.allow_K_in_toplevel_higher_order_unification = true; Unification.resolve_evars = true } (* Flags for "setoid_rewrite c"/"rewrite_strat -> c" *) let general_rewrite_unif_flags () = let ts = rewrite_transparent_state () in let core_flags = { rewrite_core_unif_flags with Unification.modulo_conv_on_closed_terms = Some ts; Unification.use_evars_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = ts; Unification.modulo_delta_types = full_transparent_state; Unification.modulo_betaiota = true } in { Unification.core_unify_flags = core_flags; Unification.merge_unify_flags = core_flags; Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = empty_transparent_state }; Unification.allow_K_in_toplevel_higher_order_unification = true; Unification.resolve_evars = true } let refresh_hypinfo env sigma (is, cb) = let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma cb in let sigma, hypinfo = decompose_applied_relation env sigma cbl in let { c1; c2; car; rel; prf; sort; holes } = hypinfo in sigma, (car, rel, prf, c1, c2, holes, sort) (** FIXME: write this in the new monad interface *) let solve_remaining_by env sigma holes by = match by with | None -> sigma | Some tac -> let map h = if h.Clenv.hole_deps then None else let (evk, _) = destEvar (h.Clenv.hole_evar) in Some evk in (** Only solve independent holes *) let indep = List.map_filter map holes in let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in let solve_tac = match tac with | Genarg.GenArg (Genarg.Glbwit tag, tac) -> Ftactic.run (Geninterp.interp tag ist tac) (fun _ -> Proofview.tclUNIT ()) in let solve_tac = tclCOMPLETE solve_tac in let solve sigma evk = let evi = try Some (Evd.find_undefined sigma evk) with Not_found -> None in match evi with | None -> sigma (** Evar should not be defined, but just in case *) | Some evi -> let env = Environ.reset_with_named_context evi.evar_hyps env in let ty = evi.evar_concl in let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in Evd.define evk c sigma in List.fold_left solve sigma indep let no_constraints cstrs = fun ev _ -> not (Evar.Set.mem ev cstrs) let all_constraints cstrs = fun ev _ -> Evar.Set.mem ev cstrs let poly_inverse sort = if sort then PropGlobal.inverse else TypeGlobal.inverse type rewrite_proof = | RewPrf of constr * constr (** A Relation (R : rew_car -> rew_car -> Prop) and a proof of R rew_from rew_to *) | RewCast of cast_kind (** A proof of convertibility (with casts) *) type rewrite_result_info = { rew_car : constr ; (** A type *) rew_from : constr ; (** A term of type rew_car *) rew_to : constr ; (** A term of type rew_car *) rew_prf : rewrite_proof ; (** A proof of rew_from == rew_to *) rew_evars : evars; } type rewrite_result = | Fail | Identity | Success of rewrite_result_info type 'a strategy_input = { state : 'a ; (* a parameter: for instance, a state *) env : Environ.env ; unfresh : Id.t list ; (* Unfresh names *) term1 : constr ; ty1 : types ; (* first term and its type (convertible to rew_from) *) cstr : (bool (* prop *) * constr option) ; evars : evars } type 'a pure_strategy = { strategy : 'a strategy_input -> 'a * rewrite_result (* the updated state and the "result" *) } type strategy = unit pure_strategy let symmetry env sort rew = let { rew_evars = evars; rew_car = car; } = rew in let (rew_evars, rew_prf) = match rew.rew_prf with | RewCast _ -> (rew.rew_evars, rew.rew_prf) | RewPrf (rel, prf) -> try let evars, symprf = get_symmetric_proof sort env evars car rel in let prf = mkApp (symprf, [| rew.rew_from ; rew.rew_to ; prf |]) in (evars, RewPrf (rel, prf)) with Not_found -> let evars, rel = poly_inverse sort env evars car rel in (evars, RewPrf (rel, prf)) in { rew with rew_from = rew.rew_to; rew_to = rew.rew_from; rew_prf; rew_evars; } (* Matching/unifying the rewriting rule against [t] *) let unify_eqn (car, rel, prf, c1, c2, holes, sort) l2r flags env (sigma, cstrs) by t = try let left = if l2r then c1 else c2 in let sigma = Unification.w_unify ~flags env sigma CONV left t in let sigma = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs) ~fail:true env sigma in let evd = solve_remaining_by env sigma holes by in let nf c = Evarutil.nf_evar evd (Reductionops.nf_meta evd c) in let c1 = nf c1 and c2 = nf c2 and rew_car = nf car and rel = nf rel and prf = nf prf in let ty1 = Retyping.get_type_of env evd c1 in let ty2 = Retyping.get_type_of env evd c2 in let () = if not (convertible env evd ty2 ty1) then raise Reduction.NotConvertible in let rew_evars = evd, cstrs in let rew_prf = RewPrf (rel, prf) in let rew = { rew_evars; rew_prf; rew_car; rew_from = c1; rew_to = c2; } in let rew = if l2r then rew else symmetry env sort rew in Some rew with | e when Class_tactics.catchable e -> None | Reduction.NotConvertible -> None let unify_abs (car, rel, prf, c1, c2) l2r sort env (sigma, cstrs) t = try let left = if l2r then c1 else c2 in (* The pattern is already instantiated, so the next w_unify is basically an eq_constr, except when preexisting evars occur in either the lemma or the goal, in which case the eq_constr also solved this evars *) let sigma = Unification.w_unify ~flags:rewrite_unif_flags env sigma CONV left t in let rew_evars = sigma, cstrs in let rew_prf = RewPrf (rel, prf) in let rew = { rew_car = car; rew_from = c1; rew_to = c2; rew_prf; rew_evars; } in let rew = if l2r then rew else symmetry env sort rew in Some rew with | e when Class_tactics.catchable e -> None | Reduction.NotConvertible -> None type rewrite_flags = { under_lambdas : bool; on_morphisms : bool } let default_flags = { under_lambdas = true; on_morphisms = true; } let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None let make_eq () = (*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) let make_eq_refl () = (*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) let get_rew_prf r = match r.rew_prf with | RewPrf (rel, prf) -> rel, prf | RewCast c -> let rel = mkApp (make_eq (), [| r.rew_car |]) in rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]), c, mkApp (rel, [| r.rew_from; r.rew_to |])) let poly_subrelation sort = if sort then PropGlobal.subrelation else TypeGlobal.subrelation let resolve_subrelation env avoid car rel sort prf rel' res = if eq_constr rel rel' then res else let evars, app = app_poly_check env res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in let evars, subrel = new_cstr_evar evars env app in let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in { res with rew_prf = RewPrf (rel', appsub); rew_evars = evars } let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars = let evars, morph_instance, proj, sigargs, m', args, args' = let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with | Some i -> i | None -> invalid_arg "resolve_morphism" in let morphargs, morphobjs = Array.chop first args in let morphargs', morphobjs' = Array.chop first args' in let appm = mkApp(m, morphargs) in let appmtype = Typing.unsafe_type_of env (goalevars evars) appm in let cstrs = List.map (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) (Array.to_list morphobjs') in (* Desired signature *) let evars, appmtype', signature, sigargs = if b then PropGlobal.build_signature evars env appmtype cstrs cstr else TypeGlobal.build_signature evars env appmtype cstrs cstr in (* Actual signature found *) let cl_args = [| appmtype' ; signature ; appm |] in let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type) cl_args in let env' = let dosub, appsub = if b then PropGlobal.do_subrelation, PropGlobal.apply_subrelation else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation in Environ.push_named (LocalDef (Id.of_string "do_subrelation", snd (app_poly_sort b env evars dosub [||]), snd (app_poly_nocheck env evars appsub [||]))) env in let evars, morph = new_cstr_evar evars env' app in evars, morph, morph, sigargs, appm, morphobjs, morphobjs' in let projargs, subst, evars, respars, typeargs = Array.fold_left2 (fun (acc, subst, evars, sigargs, typeargs') x y -> let (carrier, relation), sigargs = split_head sigargs in match relation with | Some relation -> let carrier = substl subst carrier and relation = substl subst relation in (match y with | None -> let evars, proof = (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) env evars carrier relation x in [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' | Some r -> [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs') | None -> if not (Option.is_empty y) then error "Cannot rewrite inside dependent arguments of a function"; x :: acc, x :: subst, evars, sigargs, x :: typeargs') ([], [], evars, sigargs, []) args args' in let proof = applistc proj (List.rev projargs) in let newt = applistc m' (List.rev typeargs) in match respars with [ a, Some r ] -> evars, proof, substl subst a, substl subst r, oldt, fnewt newt | _ -> assert(false) let apply_constraint env avoid car rel prf cstr res = match snd cstr with | None -> res | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res let coerce env avoid cstr res = let rel, prf = get_rew_prf res in apply_constraint env avoid res.rew_car rel prf cstr res let apply_rule unify loccs : int pure_strategy = let (nowhere_except_in,occs) = convert_occs loccs in let is_occ occ = if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in { strategy = fun { state = occ ; env ; unfresh ; term1 = t ; ty1 = ty ; cstr ; evars } -> let unif = if isEvar t then None else unify env evars t in match unif with | None -> (occ, Fail) | Some rew -> let occ = succ occ in if not (is_occ occ) then (occ, Fail) else if eq_constr t rew.rew_to then (occ, Identity) else let res = { rew with rew_car = ty } in let rel, prf = get_rew_prf res in let res = Success (apply_constraint env unfresh rew.rew_car rel prf cstr res) in (occ, res) } let apply_lemma l2r flags oc by loccs : strategy = { strategy = fun ({ state = () ; env ; term1 = t ; evars = (sigma, cstrs) } as input) -> let sigma, c = oc sigma in let sigma, hypinfo = decompose_applied_relation env sigma c in let { c1; c2; car; rel; prf; sort; holes } = hypinfo in let rew = (car, rel, prf, c1, c2, holes, sort) in let evars = (sigma, cstrs) in let unify env evars t = let rew = unify_eqn rew l2r flags env evars by t in match rew with | None -> None | Some rew -> Some rew in let _, res = (apply_rule unify loccs).strategy { input with state = 0 ; evars } in (), res } let e_app_poly env evars f args = let evars', c = app_poly_nocheck env !evars f args in evars := evars'; c let make_leibniz_proof env c ty r = let evars = ref r.rew_evars in let prf = match r.rew_prf with | RewPrf (rel, prf) -> let rel = e_app_poly env evars coq_eq [| ty |] in let prf = e_app_poly env evars coq_f_equal [| r.rew_car; ty; mkLambda (Anonymous, r.rew_car, c); r.rew_from; r.rew_to; prf |] in RewPrf (rel, prf) | RewCast k -> r.rew_prf in { rew_car = ty; rew_evars = !evars; rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf } let reset_env env = let env' = Global.env_of_context (Environ.named_context_val env) in Environ.push_rel_context (Environ.rel_context env) env' let fold_match ?(force=false) env sigma c = let (ci, p, c, brs) = destCase c in let cty = Retyping.get_type_of env sigma c in let dep, pred, exists, (sk,eff) = let env', ctx, body = let ctx, pred = decompose_lam_assum p in let env' = Environ.push_rel_context ctx env in env', ctx, pred in let sortp = Retyping.get_sort_family_of env' sigma body in let sortc = Retyping.get_sort_family_of env sigma cty in let dep = not (noccurn 1 body) in let pred = if dep then p else it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx) in let sk = if sortp == InProp then if sortc == InProp then if dep then case_dep_scheme_kind_from_prop else case_scheme_kind_from_prop else ( if dep then case_dep_scheme_kind_from_type_in_prop else case_scheme_kind_from_type) else ((* sortc <> InProp by typing *) if dep then case_dep_scheme_kind_from_type else case_scheme_kind_from_type) in let exists = Ind_tables.check_scheme sk ci.ci_ind in if exists || force then dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind else raise Not_found in let app = let ind, args = Inductive.find_rectype env cty in let pars, args = List.chop ci.ci_npar args in let meths = List.map (fun br -> br) (Array.to_list brs) in applist (mkConst sk, pars @ [pred] @ meths @ args @ [c]) in sk, (if exists then env else reset_env env), app, eff let unfold_match env sigma sk app = match kind_of_term app with | App (f', args) when eq_constant (fst (destConst f')) sk -> let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in Reductionops.whd_beta sigma (mkApp (v, args)) | _ -> app let is_rew_cast = function RewCast _ -> true | _ -> false let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let rec aux { state ; env ; unfresh ; term1 = t ; ty1 = ty ; cstr = (prop, cstr) ; evars } = let cstr' = Option.map (fun c -> (ty, Some c)) cstr in match kind_of_term t with | App (m, args) -> let rewrite_args state success = let state, (args', evars', progress) = Array.fold_left (fun (state, (acc, evars, progress)) arg -> if not (Option.is_empty progress) && not all then state, (None :: acc, evars, progress) else let argty = Retyping.get_type_of env (goalevars evars) arg in let state, res = s.strategy { state ; env ; unfresh ; term1 = arg ; ty1 = argty ; cstr = (prop,None) ; evars } in let res' = match res with | Identity -> let progress = if Option.is_empty progress then Some false else progress in (None :: acc, evars, progress) | Success r -> (Some r :: acc, r.rew_evars, Some true) | Fail -> (None :: acc, evars, progress) in state, res') (state, ([], evars, success)) args in let res = match progress with | None -> Fail | Some false -> Identity | Some true -> let args' = Array.of_list (List.rev args') in if Array.exists (function | None -> false | Some r -> not (is_rew_cast r.rew_prf)) args' then let evars', prf, car, rel, c1, c2 = resolve_morphism env unfresh t m args args' (prop, cstr') evars' in let res = { rew_car = ty; rew_from = c1; rew_to = c2; rew_prf = RewPrf (rel, prf); rew_evars = evars' } in Success res else let args' = Array.map2 (fun aorig anew -> match anew with None -> aorig | Some r -> r.rew_to) args args' in let res = { rew_car = ty; rew_from = t; rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast; rew_evars = evars' } in Success res in state, res in if flags.on_morphisms then let mty = Retyping.get_type_of env (goalevars evars) m in let evars, cstr', m, mty, argsl, args = let argsl = Array.to_list args in let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in match lift env evars argsl m mty None with | Some (evars, cstr', m, mty, args) -> evars, Some cstr', m, mty, args, Array.of_list args | None -> evars, None, m, mty, argsl, args in let state, m' = s.strategy { state ; env ; unfresh ; term1 = m ; ty1 = mty ; cstr = (prop, cstr') ; evars } in match m' with | Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *) | Identity -> rewrite_args state (Some false) | Success r -> (* We rewrote the function and get a proof of pointwise rel for the arguments. We just apply it. *) let prf = match r.rew_prf with | RewPrf (rel, prf) -> let app = if prop then PropGlobal.apply_pointwise else TypeGlobal.apply_pointwise in RewPrf (app rel argsl, mkApp (prf, args)) | x -> x in let res = { rew_car = Reductionops.hnf_prod_appvect env (goalevars evars) r.rew_car args; rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); rew_prf = prf; rew_evars = r.rew_evars } in let res = match prf with | RewPrf (rel, prf) -> Success (apply_constraint env unfresh res.rew_car rel prf (prop,cstr) res) | _ -> Success res in state, res else rewrite_args state None | Prod (n, x, b) when noccurn 1 b -> let b = subst1 mkProp b in let tx = Retyping.get_type_of env (goalevars evars) x and tb = Retyping.get_type_of env (goalevars evars) b in let arr = if prop then PropGlobal.arrow_morphism else TypeGlobal.arrow_morphism in let (evars', mor), unfold = arr env evars tx tb x b in let state, res = aux { state ; env ; unfresh ; term1 = mor ; ty1 = ty ; cstr = (prop,cstr) ; evars = evars' } in let res = match res with | Success r -> Success { r with rew_to = unfold r.rew_to } | Fail | Identity -> res in state, res (* if x' = None && flags.under_lambdas then *) (* let lam = mkLambda (n, x, b) in *) (* let lam', occ = aux env lam occ None in *) (* let res = *) (* match lam' with *) (* | None -> None *) (* | Some (prf, (car, rel, c1, c2)) -> *) (* Some (resolve_morphism env sigma t *) (* ~fnewt:unfold_all *) (* (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *) (* cstr evars) *) (* in res, occ *) (* else *) | Prod (n, dom, codom) -> let lam = mkLambda (n, dom, codom) in let (evars', app), unfold = if eq_constr ty mkProp then (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all else let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in (app_poly_sort prop env evars forall [| dom; lam |]), TypeGlobal.unfold_forall in let state, res = aux { state ; env ; unfresh ; term1 = app ; ty1 = ty ; cstr = (prop,cstr) ; evars = evars' } in let res = match res with | Success r -> Success { r with rew_to = unfold r.rew_to } | Fail | Identity -> res in state, res (* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this. B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing dependent relations and using projections to get them out. *) (* | Lambda (n, t, b) when flags.under_lambdas -> *) (* let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *) (* let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *) (* let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *) (* let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *) (* let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *) (* let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *) (* (match b' with *) (* | Some (Some r) -> *) (* let prf = match r.rew_prf with *) (* | RewPrf (rel, prf) -> *) (* let rel = pointwise_or_dep_relation n' t r.rew_car rel in *) (* let prf = mkLambda (n', t, prf) in *) (* RewPrf (rel, prf) *) (* | x -> x *) (* in *) (* Some (Some { r with *) (* rew_prf = prf; *) (* rew_car = mkProd (n, t, r.rew_car); *) (* rew_from = mkLambda(n, t, r.rew_from); *) (* rew_to = mkLambda (n, t, r.rew_to) }) *) (* | _ -> b') *) | Lambda (n, t, b) when flags.under_lambdas -> let n' = name_app (fun id -> Tactics.fresh_id_in_env unfresh id env) n in let open Context.Rel.Declaration in let env' = Environ.push_rel (LocalAssum (n', t)) env in let bty = Retyping.get_type_of env' (goalevars evars) b in let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in let state, b' = s.strategy { state ; env = env' ; unfresh ; term1 = b ; ty1 = bty ; cstr = (prop, unlift env evars cstr) ; evars } in let res = match b' with | Success r -> let r = match r.rew_prf with | RewPrf (rel, prf) -> let point = if prop then PropGlobal.pointwise_or_dep_relation else TypeGlobal.pointwise_or_dep_relation in let evars, rel = point env r.rew_evars n' t r.rew_car rel in let prf = mkLambda (n', t, prf) in { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } | x -> r in Success { r with rew_car = mkProd (n, t, r.rew_car); rew_from = mkLambda(n, t, r.rew_from); rew_to = mkLambda (n, t, r.rew_to) } | Fail | Identity -> b' in state, res | Case (ci, p, c, brs) -> let cty = Retyping.get_type_of env (goalevars evars) c in let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in let cstr' = Some eqty in let state, c' = s.strategy { state ; env ; unfresh ; term1 = c ; ty1 = cty ; cstr = (prop, cstr') ; evars = evars' } in let state, res = match c' with | Success r -> let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in let res = make_leibniz_proof env case ty r in state, Success (coerce env unfresh (prop,cstr) res) | Fail | Identity -> if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then let evars', eqty = app_poly_sort prop env evars coq_eq [| ty |] in let cstr = Some eqty in let state, found, brs' = Array.fold_left (fun (state, found, acc) br -> if not (Option.is_empty found) then (state, found, fun x -> lift 1 br :: acc x) else let state, res = s.strategy { state ; env ; unfresh ; term1 = br ; ty1 = ty ; cstr = (prop,cstr) ; evars } in match res with | Success r -> (state, Some r, fun x -> mkRel 1 :: acc x) | Fail | Identity -> (state, None, fun x -> lift 1 br :: acc x)) (state, None, fun x -> []) brs in match found with | Some r -> let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in state, Success (make_leibniz_proof env ctxc ty r) | None -> state, c' else match try Some (fold_match env (goalevars evars) t) with Not_found -> None with | None -> state, c' | Some (cst, _, t', eff (*FIXME*)) -> let state, res = aux { state ; env ; unfresh ; term1 = t' ; ty1 = ty ; cstr = (prop,cstr) ; evars } in let res = match res with | Success prf -> Success { prf with rew_from = t; rew_to = unfold_match env (goalevars evars) cst prf.rew_to } | x' -> c' in state, res in let res = match res with | Success r -> let rel, prf = get_rew_prf r in Success (apply_constraint env unfresh r.rew_car rel prf (prop,cstr) r) | Fail | Identity -> res in state, res | _ -> state, Fail in { strategy = aux } let all_subterms = subterm true default_flags let one_subterm = subterm false default_flags (** Requires transitivity of the rewrite step, if not a reduction. Not tail-recursive. *) let transitivity state env unfresh prop (res : rewrite_result_info) (next : 'a pure_strategy) : 'a * rewrite_result = let state, nextres = next.strategy { state ; env ; unfresh ; term1 = res.rew_to ; ty1 = res.rew_car ; cstr = (prop, get_opt_rew_rel res.rew_prf) ; evars = res.rew_evars } in let res = match nextres with | Fail -> Fail | Identity -> Success res | Success res' -> match res.rew_prf with | RewCast c -> Success { res' with rew_from = res.rew_from } | RewPrf (rew_rel, rew_prf) -> match res'.rew_prf with | RewCast _ -> Success { res with rew_to = res'.rew_to } | RewPrf (res'_rel, res'_prf) -> let trans = if prop then PropGlobal.transitive_type else TypeGlobal.transitive_type in let evars, prfty = app_poly_sort prop env res'.rew_evars trans [| res.rew_car; rew_rel |] in let evars, prf = new_cstr_evar evars env prfty in let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; rew_prf; res'_prf |]) in Success { res' with rew_from = res.rew_from; rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) } in state, res (** Rewriting strategies. Inspired by ELAN's rewriting strategies: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049 *) module Strategies = struct let fail : 'a pure_strategy = { strategy = fun { state } -> state, Fail } let id : 'a pure_strategy = { strategy = fun { state } -> state, Identity } let refl : 'a pure_strategy = { strategy = fun { state ; env ; term1 = t ; ty1 = ty ; cstr = (prop,cstr) ; evars } -> let evars, rel = match cstr with | None -> let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in let evars, rty = mkr env evars ty in new_cstr_evar evars env rty | Some r -> evars, r in let evars, proof = let proxy = if prop then PropGlobal.proper_proxy_type else TypeGlobal.proper_proxy_type in let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in new_cstr_evar evars env mty in let res = Success { rew_car = ty; rew_from = t; rew_to = t; rew_prf = RewPrf (rel, proof); rew_evars = evars } in state, res } let progress (s : 'a pure_strategy) : 'a pure_strategy = { strategy = fun input -> let state, res = s.strategy input in match res with | Fail -> state, Fail | Identity -> state, Fail | Success r -> state, Success r } let seq first snd : 'a pure_strategy = { strategy = fun ({ env ; unfresh ; cstr } as input) -> let state, res = first.strategy input in match res with | Fail -> state, Fail | Identity -> snd.strategy { input with state } | Success res -> transitivity state env unfresh (fst cstr) res snd } let choice fst snd : 'a pure_strategy = { strategy = fun input -> let state, res = fst.strategy input in match res with | Fail -> snd.strategy { input with state } | Identity | Success _ -> state, res } let try_ str : 'a pure_strategy = choice str id let check_interrupt str input = Control.check_for_interrupt (); str input let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy = let rec aux input = (f { strategy = fun input -> check_interrupt aux input }).strategy input in { strategy = aux } let any (s : 'a pure_strategy) : 'a pure_strategy = fix (fun any -> try_ (seq s any)) let repeat (s : 'a pure_strategy) : 'a pure_strategy = seq s (any s) let bu (s : 'a pure_strategy) : 'a pure_strategy = fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s')) let td (s : 'a pure_strategy) : 'a pure_strategy = fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s')) let innermost (s : 'a pure_strategy) : 'a pure_strategy = fix (fun ins -> choice (one_subterm ins) s) let outermost (s : 'a pure_strategy) : 'a pure_strategy = fix (fun out -> choice s (one_subterm out)) let lemmas cs : 'a pure_strategy = List.fold_left (fun tac (l,l2r,by) -> choice tac (apply_lemma l2r rewrite_unif_flags l by AllOccurrences)) fail cs let inj_open hint = (); fun sigma -> let ctx = Evd.evar_universe_context_of hint.Autorewrite.rew_ctx in let sigma = Evd.merge_universe_context sigma ctx in (sigma, (hint.Autorewrite.rew_lemma, NoBindings)) let old_hints (db : string) : 'a pure_strategy = let rules = Autorewrite.find_rewrites db in lemmas (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r, hint.Autorewrite.rew_tac)) rules) let hints (db : string) : 'a pure_strategy = { strategy = fun ({ term1 = t } as input) -> let rules = Autorewrite.find_matches db t in let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r, hint.Autorewrite.rew_tac) in let lems = List.map lemma rules in (lemmas lems).strategy input } let reduce (r : Redexpr.red_expr) : 'a pure_strategy = { strategy = fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } -> let rfn, ckind = Redexpr.reduction_of_red_expr env r in let sigma = Sigma.Unsafe.of_evar_map (goalevars evars) in let Sigma (t', sigma, _) = rfn.Reductionops.e_redfun env sigma t in let evars' = Sigma.to_evar_map sigma in if eq_constr t' t then state, Identity else state, Success { rew_car = ty; rew_from = t; rew_to = t'; rew_prf = RewCast ckind; rew_evars = evars', cstrevars evars } } let fold_glob c : 'a pure_strategy = { strategy = fun { state ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> (* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in let unfolded = try Tacred.try_red_product env sigma c with e when CErrors.noncritical e -> error "fold: the term is not unfoldable !" in try let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in let c' = Evarutil.nf_evar sigma c in state, Success { rew_car = ty; rew_from = t; rew_to = c'; rew_prf = RewCast DEFAULTcast; rew_evars = (sigma, snd evars) } with e when CErrors.noncritical e -> state, Fail } end (** The strategy for a single rewrite, dealing with occurrences. *) (** A dummy initial clauseenv to avoid generating initial evars before even finding a first application of the rewriting lemma, in setoid_rewrite mode *) let rewrite_with l2r flags c occs : strategy = { strategy = fun ({ state = () } as input) -> let unify env evars t = let (sigma, cstrs) = evars in let (sigma, rew) = refresh_hypinfo env sigma c in unify_eqn rew l2r flags env (sigma, cstrs) None t in let app = apply_rule unify occs in let strat = Strategies.fix (fun aux -> Strategies.choice app (subterm true default_flags aux)) in let _, res = strat.strategy { input with state = 0 } in ((), res) } let apply_strategy (s : strategy) env unfresh concl (prop, cstr) evars = let ty = Retyping.get_type_of env (goalevars evars) concl in let _, res = s.strategy { state = () ; env ; unfresh ; term1 = concl ; ty1 = ty ; cstr = (prop, Some cstr) ; evars } in res let solve_constraints env (evars,cstrs) = let filter = all_constraints cstrs in Typeclasses.resolve_typeclasses env ~filter ~split:false ~fail:true (Typeclasses.mark_resolvables ~filter evars) let nf_zeta = Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) exception RewriteFailure of Pp.std_ppcmds type result = (evar_map * constr option * types) option option let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = let evdref = ref sigma in let sort = Typing.e_sort_of env evdref concl in let evars = (!evdref, Evar.Set.empty) in let evars, cstr = let prop, (evars, arrow) = if is_prop_sort sort then true, app_poly_sort true env evars impl [||] else false, app_poly_sort false env evars TypeGlobal.arrow [||] in match is_hyp with | None -> let evars, t = poly_inverse prop env evars (mkSort sort) arrow in evars, (prop, t) | Some _ -> evars, (prop, arrow) in let eq = apply_strategy strat env avoid concl cstr evars in match eq with | Fail -> None | Identity -> Some None | Success res -> let (_, cstrs) = res.rew_evars in let evars' = solve_constraints env res.rew_evars in let newt = Evarutil.nf_evar evars' res.rew_to in let evars = (* Keep only original evars (potentially instantiated) and goal evars, the rest has been defined and substituted already. *) Evar.Set.fold (fun ev acc -> if not (Evd.is_defined acc ev) then errorlabstrm "rewrite" (str "Unsolved constraint remaining: " ++ spc () ++ Evd.pr_evar_info (Evd.find acc ev)) else Evd.remove acc ev) cstrs evars' in let res = match res.rew_prf with | RewCast c -> None | RewPrf (rel, p) -> let p = nf_zeta env evars' (Evarutil.nf_evar evars' p) in let term = match abs with | None -> p | Some (t, ty) -> let t = Evarutil.nf_evar evars' t in let ty = Evarutil.nf_evar evars' ty in mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) in let proof = match is_hyp with | None -> term | Some id -> mkApp (term, [| mkVar id |]) in Some proof in Some (Some (evars, res, newt)) (** Insert a declaration after the last declaration it depends on *) let rec insert_dependent env decl accu hyps = match hyps with | [] -> List.rev_append accu [decl] | ndecl :: rem -> if occur_var_in_decl env (get_id ndecl) decl then List.rev_append accu (decl :: hyps) else insert_dependent env decl (ndecl :: accu) rem let assert_replacing id newt tac = let prf = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let ctx = Environ.named_context env in let after, before = List.split_when (Id.equal id % get_id) ctx in let nc = match before with | [] -> assert false | d :: rem -> insert_dependent env (LocalAssum (get_id d, newt)) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in Refine.refine ~unsafe:false { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in let map d = let n = get_id d in if Id.equal n id then ev' else mkVar n in let (e, _) = destEvar ev in Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q) end } end } in Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) let newfail n s = Proofview.tclZERO (Refiner.FailError (n, lazy s)) let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in (** For compatibility *) let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in let beta = Tactics.reduct_in_concl (beta_red, DEFAULTcast) in let beta_hyp id = Tactics.reduct_in_hyp beta_red (id, InHyp) in let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") | Some None -> if progress then newfail 0 (str"Failed to progress") else Proofview.tclUNIT () | Some (Some res) -> let (undef, prf, newt) = res in let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in let gls = List.rev (Evd.fold_undefined fold undef []) in match clause, prf with | Some id, Some p -> let tac = tclTHENLIST [ Refine.refine ~unsafe:false { run = fun h -> Sigma.here p h }; Proofview.Unsafe.tclNEWGOALS gls; ] in Proofview.Unsafe.tclEVARS undef <*> tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) | Some id, None -> Proofview.Unsafe.tclEVARS undef <*> convert_hyp_no_check (LocalAssum (id, newt)) <*> beta_hyp id | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let make = { run = begin fun sigma -> let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in Sigma (mkApp (p, [| ev |]), sigma, q) end } in Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls end } | None, None -> Proofview.Unsafe.tclEVARS undef <*> convert_concl_no_check newt DEFAULTcast in Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = match clause with | None -> concl | Some id -> Environ.named_type id env in let env = match clause with | None -> env | Some id -> (** Only consider variables not depending on [id] *) let ctx = Environ.named_context env in let filter decl = not (occur_var_in_decl env id decl) in let nctx = List.filter filter ctx in Environ.reset_with_named_context (Environ.val_of_named_context nctx) env in try let res = cl_rewrite_clause_aux ?abs strat env [] sigma ty clause in let sigma = match origsigma with None -> sigma | Some sigma -> sigma in treat sigma res <*> (** For compatibility *) beta <*> Proofview.shelve_unifiable with | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) -> raise (RewriteFailure (Himsg.explain_pretype_error env evd e)) end } let tactic_init_setoid () = try init_setoid (); Proofview.tclUNIT () with e when CErrors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Setoid library not loaded") let cl_rewrite_clause_strat progress strat clause = tactic_init_setoid () <*> (if progress then Proofview.tclPROGRESS else fun x -> x) (Proofview.tclOR (cl_rewrite_clause_newtac ~progress strat clause) (fun (e, info) -> match e with | RewriteFailure e -> tclZEROMSG (str"setoid rewrite failed: " ++ e) | Refiner.FailError (n, pp) -> tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) | e -> Proofview.tclZERO ~info e)) (** Setoid rewriting when called with "setoid_rewrite" *) let cl_rewrite_clause l left2right occs clause = let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in cl_rewrite_clause_strat true strat clause (** Setoid rewriting when called with "rewrite_strat" *) let cl_rewrite_clause_strat strat clause = cl_rewrite_clause_strat false strat clause let apply_glob_constr c l2r occs = (); fun ({ state = () ; env = env } as input) -> let c sigma = let (sigma, c) = Pretyping.understand_tcc env sigma c in (sigma, (c, NoBindings)) in let flags = general_rewrite_unif_flags () in (apply_lemma l2r flags c None occs).strategy input let interp_glob_constr_list env = let make c = (); fun sigma -> let sigma, c = Pretyping.understand_tcc env sigma c in (sigma, (c, NoBindings)) in List.map (fun c -> make c, true, None) (* Syntax for rewriting with strategies *) type unary_strategy = Subterms | Subterm | Innermost | Outermost | Bottomup | Topdown | Progress | Try | Any | Repeat type binary_strategy = | Compose | Choice type ('constr,'redexpr) strategy_ast = | StratId | StratFail | StratRefl | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast | StratBinary of binary_strategy * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast | StratConstr of 'constr * bool | StratTerms of 'constr list | StratHints of bool * string | StratEval of 'redexpr | StratFold of 'constr let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function | StratId | StratFail | StratRefl as s -> s | StratUnary (s, str) -> StratUnary (s, map_strategy f g str) | StratBinary (s, str, str') -> StratBinary (s, map_strategy f g str, map_strategy f g str') | StratConstr (c, b) -> StratConstr (f c, b) | StratTerms l -> StratTerms (List.map f l) | StratHints (b, id) -> StratHints (b, id) | StratEval r -> StratEval (g r) | StratFold c -> StratFold (f c) let pr_ustrategy = function | Subterms -> str "subterms" | Subterm -> str "subterm" | Innermost -> str "innermost" | Outermost -> str "outermost" | Bottomup -> str "bottomup" | Topdown -> str "topdown" | Progress -> str "progress" | Try -> str "try" | Any -> str "any" | Repeat -> str "repeat" let paren p = str "(" ++ p ++ str ")" let rec pr_strategy prc prr = function | StratId -> str "id" | StratFail -> str "fail" | StratRefl -> str "refl" | StratUnary (s, str) -> pr_ustrategy s ++ spc () ++ paren (pr_strategy prc prr str) | StratBinary (Choice, str1, str2) -> str "choice" ++ spc () ++ paren (pr_strategy prc prr str1) ++ spc () ++ paren (pr_strategy prc prr str2) | StratBinary (Compose, str1, str2) -> pr_strategy prc prr str1 ++ str ";" ++ spc () ++ pr_strategy prc prr str2 | StratConstr (c, true) -> prc c | StratConstr (c, false) -> str "<-" ++ spc () ++ prc c | StratTerms cl -> str "terms" ++ spc () ++ pr_sequence prc cl | StratHints (old, id) -> let cmd = if old then "old_hints" else "hints" in str cmd ++ spc () ++ str id | StratEval r -> str "eval" ++ spc () ++ prr r | StratFold c -> str "fold" ++ spc () ++ prc c let rec strategy_of_ast = function | StratId -> Strategies.id | StratFail -> Strategies.fail | StratRefl -> Strategies.refl | StratUnary (f, s) -> let s' = strategy_of_ast s in let f' = match f with | Subterms -> all_subterms | Subterm -> one_subterm | Innermost -> Strategies.innermost | Outermost -> Strategies.outermost | Bottomup -> Strategies.bu | Topdown -> Strategies.td | Progress -> Strategies.progress | Try -> Strategies.try_ | Any -> Strategies.any | Repeat -> Strategies.repeat in f' s' | StratBinary (f, s, t) -> let s' = strategy_of_ast s in let t' = strategy_of_ast t in let f' = match f with | Compose -> Strategies.seq | Choice -> Strategies.choice in f' s' t' | StratConstr (c, b) -> { strategy = apply_glob_constr (fst c) b AllOccurrences } | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id | StratTerms l -> { strategy = (fun ({ state = () ; env } as input) -> let l' = interp_glob_constr_list env (List.map fst l) in (Strategies.lemmas l').strategy input) } | StratEval r -> { strategy = (fun ({ state = () ; env ; evars } as input) -> let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in (Strategies.reduce r_interp).strategy { input with evars = (sigma,cstrevars evars) }) } | StratFold c -> Strategies.fold_glob (fst c) (* By default the strategy for "rewrite_db" is top-down *) let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l) let declare_an_instance n s args = (((Loc.ghost,Name n),None), Explicit, CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None), args)) let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance global binders instance fields = new_instance (Flags.is_universe_polymorphism ()) binders instance (Some (true, CRecord (Loc.ghost,fields))) ~global ~generalize:false ~refine:false Hints.empty_hint_info let declare_instance_refl global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" in anew_instance global binders instance [(Ident (Loc.ghost,Id.of_string "reflexivity"),lemma)] let declare_instance_sym global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" in anew_instance global binders instance [(Ident (Loc.ghost,Id.of_string "symmetry"),lemma)] let declare_instance_trans global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" in anew_instance global binders instance [(Ident (Loc.ghost,Id.of_string "transitivity"),lemma)] let declare_relation ?(binders=[]) a aeq n refl symm trans = init_setoid (); let global = not (Locality.make_section_locality (Locality.LocalityFixme.consume ())) in let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" in ignore(anew_instance global binders instance []); match (refl,symm,trans) with (None, None, None) -> () | (Some lemma1, None, None) -> ignore (declare_instance_refl global binders a aeq n lemma1) | (None, Some lemma2, None) -> ignore (declare_instance_sym global binders a aeq n lemma2) | (None, None, Some lemma3) -> ignore (declare_instance_trans global binders a aeq n lemma3) | (Some lemma1, Some lemma2, None) -> ignore (declare_instance_refl global binders a aeq n lemma1); ignore (declare_instance_sym global binders a aeq n lemma2) | (Some lemma1, None, Some lemma3) -> let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in ignore( anew_instance global binders instance [(Ident (Loc.ghost,Id.of_string "PreOrder_Reflexive"), lemma1); (Ident (Loc.ghost,Id.of_string "PreOrder_Transitive"),lemma3)]) | (None, Some lemma2, Some lemma3) -> let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in ignore( anew_instance global binders instance [(Ident (Loc.ghost,Id.of_string "PER_Symmetric"), lemma2); (Ident (Loc.ghost,Id.of_string "PER_Transitive"),lemma3)]) | (Some lemma1, Some lemma2, Some lemma3) -> let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance global binders instance [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), lemma1); (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), lemma2); (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), lemma3)]) let cHole = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) let proper_projection r ty = let ctx, inst = decompose_prod_assum ty in let mor, args = destApp inst in let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in let app = mkApp (Lazy.force PropGlobal.proper_proj, Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx let declare_projection n instance_id r = let poly = Global.is_polymorphic r in let env = Global.env () in let sigma = Evd.from_env env in let sigma,c = Evd.fresh_global env sigma r in let ty = Retyping.get_type_of env sigma c in let term = proper_projection c ty in let sigma, typ = Typing.type_of env sigma term in let ctx, typ = decompose_prod_assum typ in let typ = let n = let rec aux t = match kind_of_term t with | App (f, [| a ; a' ; rel; rel' |]) when Globnames.is_global (PropGlobal.respectful_ref ()) f -> succ (aux rel') | _ -> 0 in let init = match kind_of_term typ with App (f, args) when Globnames.is_global (PropGlobal.respectful_ref ()) f -> mkApp (f, fst (Array.chop (Array.length args - 2) args)) | _ -> typ in aux init in let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ in it_mkProd_or_LetIn ccl ctx in let typ = it_mkProd_or_LetIn typ ctx in let pl, ctx = Evd.universe_context sigma in let cst = Declare.definition_entry ~types:typ ~poly ~univs:ctx term in ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) let build_morphism_signature env sigma m = let m,ctx = Constrintern.interp_constr env sigma m in let sigma = Evd.from_ctx ctx in let t = Typing.unsafe_type_of env sigma m in let cstrs = let rec aux t = match kind_of_term t with | Prod (na, a, b) -> None :: aux b | _ -> [] in aux t in let evars, t', sig_, cstrs = PropGlobal.build_signature (sigma, Evar.Set.empty) env t cstrs None in let evd = ref evars in let _ = List.iter (fun (ty, rel) -> Option.iter (fun rel -> let default = e_app_poly env evd PropGlobal.default_relation [| ty; rel |] in ignore(e_new_cstr_evar env evd default)) rel) cstrs in let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in let evd = solve_constraints env !evd in let evd = Evd.nf_constraints evd in let m = Evarutil.nf_evars_universes evd morph in Pretyping.check_evars env Evd.empty evd m; Evd.evar_universe_context evd, m let default_morphism sign m = let env = Global.env () in let sigma = Evd.from_env env in let t = Typing.unsafe_type_of env sigma m in let evars, _, sign, cstrs = PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign) in let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in let evars, mor = resolve_one_typeclass env (goalevars evars) morph in mor, proper_projection mor morph let add_setoid global binders a aeq t n = init_setoid (); let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance global binders instance [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) let make_tactic name = let open Tacexpr in let loc = Loc.ghost in let tacpath = Libnames.qualid_of_string name in let tacname = Qualid (loc, tacpath) in TacArg (loc, TacCall (loc, tacname, [])) let add_morphism_infer glob m n = init_setoid (); let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in let uctx, instance = build_morphism_signature env evd m in if Lib.is_modtype () then let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id (Entries.ParameterEntry (None,poly,(instance,Evd.evar_context_universe_context uctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in add_instance (Typeclasses.new_instance (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob poly (ConstRef cst)); declare_projection n instance_id (ConstRef cst) else let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in let hook _ = function | Globnames.ConstRef cst -> add_instance (Typeclasses.new_instance (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob poly (ConstRef cst)); declare_projection n instance_id (ConstRef cst) | _ -> assert false in let hook = Lemmas.mk_hook hook in Flags.silently (fun () -> Lemmas.start_proof instance_id kind (Evd.from_ctx uctx) instance hook; ignore (Pfedit.by (Tacinterp.interp tac))) () let add_morphism glob binders m s n = init_setoid (); let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = (((Loc.ghost,Name instance_id),None), Explicit, CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in ignore(new_instance ~global:glob poly binders instance (Some (true, CRecord (Loc.ghost,[]))) ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) (** Bind to "rewrite" too *) (** Taken from original setoid_replace, to emulate the old rewrite semantics where lemmas are first instantiated and then rewrite proceeds. *) let check_evar_map_of_evars_defs evd = let metas = Evd.meta_list evd in let check_freemetas_is_empty rebus = Evd.Metaset.iter (fun m -> if Evd.meta_defined evd m then () else raise (Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m]))) in List.iter (fun (_,binding) -> match binding with Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) -> check_freemetas_is_empty rebus freemetas | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_), {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) -> check_freemetas_is_empty rebus1 freemetas1 ; check_freemetas_is_empty rebus2 freemetas2 ) metas (* Find a subterm which matches the pattern to rewrite for "rewrite" *) let unification_rewrite l2r c1 c2 sigma prf car rel but env = let (sigma,c') = try (* ~flags:(false,true) to allow to mark occurrences that must not be rewritten simply by replacing them with let-defined definitions in the context *) Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env sigma ((if l2r then c1 else c2),but) with | ex when Pretype_errors.precatchable_exception ex -> (* ~flags:(true,true) to make Ring work (since it really exploits conversion) *) Unification.w_unify_to_subterm ~flags:rewrite_conv_unif_flags env sigma ((if l2r then c1 else c2),but) in let nf c = Evarutil.nf_evar sigma c in let c1 = if l2r then nf c' else nf c1 and c2 = if l2r then nf c2 else nf c' and car = nf car and rel = nf rel in check_evar_map_of_evars_defs sigma; let prf = nf prf in let prfty = nf (Retyping.get_type_of env sigma prf) in let sort = sort_of_rel env sigma but in let abs = prf, prfty in let prf = mkRel 1 in let res = (car, rel, prf, c1, c2) in abs, sigma, res, Sorts.is_prop sort let get_hyp gl (c,l) clause l2r = let evars = Tacmach.New.project gl in let env = Tacmach.New.pf_env gl in let sigma, hi = decompose_applied_relation env evars (c,l) in let but = match clause with | Some id -> Tacmach.New.pf_get_hyp_typ id gl | None -> Evarutil.nf_evar evars (Tacmach.New.pf_concl gl) in unification_rewrite l2r hi.c1 hi.c2 sigma hi.prf hi.car hi.rel but env let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } (* let rewriteclaustac_key = Profile.declare_profile "cl_rewrite_clause_tac";; *) (* let cl_rewrite_clause_tac = Profile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *) (** Setoid rewriting when called with "rewrite" *) let general_s_rewrite cl l2r occs (c,l) ~new_goals = Proofview.Goal.nf_enter { enter = begin fun gl -> let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in let unify env evars t = unify_abs res l2r sort env evars t in let app = apply_rule unify occs in let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in let substrat = Strategies.fix recstrat in let strat = { strategy = fun ({ state = () } as input) -> let _, res = substrat.strategy { input with state = 0 } in (), res } in let origsigma = Tacmach.New.project gl in tactic_init_setoid () <*> Proofview.tclOR (tclPROGRESS (tclTHEN (Proofview.Unsafe.tclEVARS evd) (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) (fun (e, info) -> match e with | RewriteFailure e -> tclFAIL 0 (str"setoid rewrite failed: " ++ e) | e -> Proofview.tclZERO ~info e) end } let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite (** [setoid_]{reflexivity,symmetry,transitivity} tactics *) let not_declared env ty rel = tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env Evd.empty rel ++ str" is not a declared " ++ str ty ++ str" relation. Maybe you need to require the Coq.Classes.RelationClasses library") let setoid_proof ty fn fallback = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in Proofview.tclORELSE begin try let rel, _, _ = decompose_app_rel env sigma concl in let open Context.Rel.Declaration in let (sigma, t) = Typing.type_of env sigma rel in let car = get_type (List.hd (fst (Reduction.dest_prod env t))) in (try init_relation_classes () with _ -> raise Not_found); fn env sigma car rel with e -> Proofview.tclZERO e end begin function | e -> Proofview.tclORELSE fallback begin function (e', info) -> match e' with | Hipattern.NoEquationFound -> begin match e with | (Not_found, _) -> let rel, _, _ = decompose_app_rel env sigma concl in not_declared env ty rel | (e, info) -> Proofview.tclZERO ~info e end | e' -> Proofview.tclZERO ~info e' end end end } let tac_open ((evm,_), c) tac = (tclTHEN (Proofview.Unsafe.tclEVARS evm) (tac c)) let poly_proof getp gett env evm car rel = if Sorts.is_prop (sort_of_rel env evm rel) then getp env (evm,Evar.Set.empty) car rel else gett env (evm,Evar.Set.empty) car rel let setoid_reflexivity = setoid_proof "reflexive" (fun env evm car rel -> tac_open (poly_proof PropGlobal.get_reflexive_proof TypeGlobal.get_reflexive_proof env evm car rel) (fun c -> tclCOMPLETE (apply c))) (reflexivity_red true) let setoid_symmetry = setoid_proof "symmetric" (fun env evm car rel -> tac_open (poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof env evm car rel) (fun c -> apply c)) (symmetry_red true) let setoid_transitivity c = setoid_proof "transitive" (fun env evm car rel -> tac_open (poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof env evm car rel) (fun proof -> match c with | None -> eapply proof | Some c -> apply_with_bindings (proof,ImplicitBindings [ c ]))) (transitivity_red true c) let setoid_symmetry_in id = Proofview.V82.tactic (fun gl -> let ctype = pf_unsafe_type_of gl (mkVar id) in let binders,concl = decompose_prod_assum ctype in let (equiv, args) = decompose_app concl in let rec split_last_two = function | [c1;c2] -> [],(c1, c2) | x::y::z -> let l,res = split_last_two (y::z) in x::l, res | _ -> error "Cannot find an equivalence relation to rewrite." in let others,(c1,c2) = split_last_two args in let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in let new_hyp' = mkApp (he, [| c2 ; c1 |]) in let new_hyp = it_mkProd_or_LetIn new_hyp' binders in Proofview.V82.of_tactic (tclTHENLAST (Tactics.assert_after_replacing id new_hyp) (tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ])) gl) let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity let get_lemma_proof f env evm x y = let (evm, _), c = f env (evm,Evar.Set.empty) x y in evm, c let get_reflexive_proof = get_lemma_proof PropGlobal.get_reflexive_proof let get_symmetric_proof = get_lemma_proof PropGlobal.get_symmetric_proof let get_transitive_proof = get_lemma_proof PropGlobal.get_transitive_proof coq-8.6/ltac/evar_tactics.ml0000644000175000017500000000611113022274260015402 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let sigma = gl.sigma in let evl = match ido with ConclLocation () -> evar_list (pf_concl gl) | HypLocation (id,hloc) -> let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in match hloc with InHyp -> (match decl with | LocalAssum (_,typ) -> evar_list typ | _ -> error "Please be more specific: in type or value?") | InHypTypeOnly -> evar_list (get_type decl) | InHypValueOnly -> (match decl with | LocalDef (_,body,_) -> evar_list body | _ -> error "Not a defined hypothesis.") in if List.length evl < n then error "Not enough uninstantiated existential variables."; if n <= 0 then error "Incorrect existential variable index."; let evk,_ = List.nth evl (n-1) in instantiate_evar evk c sigma gl end let instantiate_tac_by_name id c = Proofview.V82.tactic begin fun gl -> let sigma = gl.sigma in let evk = try Evd.evar_key id sigma with Not_found -> error "Unknown existential variable." in instantiate_evar evk c sigma gl end let let_evar name typ = let src = (Loc.ghost,Evar_kinds.GoalEvar) in Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let sigma = ref sigma in let _ = Typing.e_sort_of env sigma typ in let sigma = Sigma.Unsafe.of_evar_map !sigma in let id = match name with | Names.Anonymous -> let id = Namegen.id_of_name_using_hdchar env typ name in Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) | Names.Name id -> id in let Sigma (evar, sigma, p) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in let tac = (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) in Sigma (tac, sigma, p) end } coq-8.6/ltac/tacsubst.mli0000644000175000017500000000212413022274260014734 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* glob_tactic_expr -> glob_tactic_expr (** For generic arguments, we declare and store substitutions in a table *) val subst_genarg : substitution -> glob_generic_argument -> glob_generic_argument (** Misc *) val subst_glob_constr_and_expr : substitution -> glob_constr_and_expr -> glob_constr_and_expr val subst_glob_with_bindings : substitution -> glob_constr_and_expr with_bindings -> glob_constr_and_expr with_bindings coq-8.6/ltac/tacentries.ml0000644000175000017500000004237113022274260015104 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* entry_name (** Quite ad-hoc *) let get_tacentry n m = let check_lvl n = Int.equal m n && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) in if check_lvl n then EntryName (rawwit Constrarg.wit_tactic, Aself) else if check_lvl (n + 1) then EntryName (rawwit Constrarg.wit_tactic, Anext) else EntryName (rawwit Constrarg.wit_tactic, atactic n) let get_separator = function | None -> error "Missing separator." | Some sep -> sep let rec parse_user_entry s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then let entry = parse_user_entry (String.sub s 3 (l-8)) None in Ulist1 entry else if l > 12 && coincide s "ne_" 0 && coincide s "_list_sep" (l-9) then let entry = parse_user_entry (String.sub s 3 (l-12)) None in Ulist1sep (entry, get_separator sep) else if l > 5 && coincide s "_list" (l-5) then let entry = parse_user_entry (String.sub s 0 (l-5)) None in Ulist0 entry else if l > 9 && coincide s "_list_sep" (l-9) then let entry = parse_user_entry (String.sub s 0 (l-9)) None in Ulist0sep (entry, get_separator sep) else if l > 4 && coincide s "_opt" (l-4) then let entry = parse_user_entry (String.sub s 0 (l-4)) None in Uopt entry else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then let n = Char.code s.[6] - 48 in Uentryl ("tactic", n) else Uentry s let arg_list = function Rawwit t -> Rawwit (ListArg t) let arg_opt = function Rawwit t -> Rawwit (OptArg t) let interp_entry_name interp symb = let rec eval = function | Ulist1 e -> Ulist1 (eval e) | Ulist1sep (e, sep) -> Ulist1sep (eval e, sep) | Ulist0 e -> Ulist0 (eval e) | Ulist0sep (e, sep) -> Ulist0sep (eval e, sep) | Uopt e -> Uopt (eval e) | Uentry s -> Uentry (interp s None) | Uentryl (s, n) -> Uentryl (interp s (Some n), n) in eval symb (**********************************************************************) (** Grammar declaration for Tactic Notation (Coq level) *) let get_tactic_entry n = if Int.equal n 0 then Tactic.simple_tactic, None else if Int.equal n 5 then Tactic.binder_tactic, None else if 1<=n && n<5 then Tactic.tactic_expr, Some (Extend.Level (string_of_int n)) else error ("Invalid Tactic Notation level: "^(string_of_int n)^".") (**********************************************************************) (** State of the grammar extensions *) type tactic_grammar = { tacgram_level : int; tacgram_prods : Pptactic.grammar_terminals; } (* Declaration of the tactic grammar rule *) let head_is_ident tg = match tg.tacgram_prods with | TacTerm _ :: _ -> true | _ -> false let rec prod_item_of_symbol lev = function | Extend.Ulist1 s -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in EntryName (Rawwit (ListArg typ), Alist1 e) | Extend.Ulist0 s -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in EntryName (Rawwit (ListArg typ), Alist0 e) | Extend.Ulist1sep (s, sep) -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in EntryName (Rawwit (ListArg typ), Alist1sep (e, Atoken (CLexer.terminal sep))) | Extend.Ulist0sep (s, sep) -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in EntryName (Rawwit (ListArg typ), Alist0sep (e, Atoken (CLexer.terminal sep))) | Extend.Uopt s -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in EntryName (Rawwit (OptArg typ), Aopt e) | Extend.Uentry arg -> let ArgT.Any tag = arg in let wit = ExtraArg tag in EntryName (Rawwit wit, Extend.Aentry (genarg_grammar wit)) | Extend.Uentryl (s, n) -> let ArgT.Any tag = s in assert (coincide (ArgT.repr tag) "tactic" 0); get_tacentry n lev (** Tactic grammar extensions *) let add_tactic_entry (kn, ml, tg) state = let open Tacexpr in let entry, pos = get_tactic_entry tg.tacgram_level in let mkact loc l = let map arg = (** HACK to handle especially the tactic(...) entry *) let wit = Genarg.rawwit Constrarg.wit_tactic in if Genarg.has_type arg wit && not ml then Tacexp (Genarg.out_gen wit arg) else TacGeneric arg in let l = List.map map l in (TacAlias (loc,kn,l):raw_tactic_expr) in let () = if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then error "Notation for simple tactic must start with an identifier." in let map = function | TacTerm s -> GramTerminal s | TacNonTerm (loc, s, _) -> let EntryName (typ, e) = prod_item_of_symbol tg.tacgram_level s in GramNonTerminal (loc, typ, e) in let prods = List.map map tg.tacgram_prods in let rules = make_rule mkact prods in let r = ExtendRule (entry, None, (pos, [(None, None, [rules])])) in ([r], state) let tactic_grammar = create_grammar_command "TacticGrammar" add_tactic_entry let extend_tactic_grammar kn ml ntn = extend_grammar_command tactic_grammar (kn, ml, ntn) (**********************************************************************) (* Tactic Notation *) let entry_names = ref String.Map.empty let register_tactic_notation_entry name entry = let entry = match entry with | ExtraArg arg -> ArgT.Any arg | _ -> assert false in entry_names := String.Map.add name entry !entry_names let interp_prod_item = function | TacTerm s -> TacTerm s | TacNonTerm (loc, (nt, sep), id) -> let symbol = parse_user_entry nt sep in let interp s = function | None -> if String.Map.mem s !entry_names then String.Map.find s !entry_names else begin match ArgT.name s with | None -> error ("Unknown entry "^s^".") | Some arg -> arg end | Some n -> (** FIXME: do better someday *) assert (String.equal s "tactic"); begin match Constrarg.wit_tactic with | ExtraArg tag -> ArgT.Any tag | _ -> assert false end in let symbol = interp_entry_name interp symbol in TacNonTerm (loc, symbol, id) let make_fresh_key = let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in fun prods -> let cur = incr id; !id in let map = function | TacTerm s -> s | TacNonTerm _ -> "#" in let prods = String.concat "_" (List.map map prods) in (** We embed the hash of the kernel name in the label so that the identifier should be mostly unique. This ensures that including two modules together won't confuse the corresponding labels. *) let hash = (cur lxor (ModPath.hash (Lib.current_mp ()))) land 0x7FFFFFFF in let lbl = Id.of_string_soft (Printf.sprintf "%s_%08X" prods hash) in Lib.make_kn lbl type tactic_grammar_obj = { tacobj_key : KerName.t; tacobj_local : locality_flag; tacobj_tacgram : tactic_grammar; tacobj_body : Id.t list * Tacexpr.glob_tactic_expr; tacobj_forml : bool; } let pprule pa = { Pptactic.pptac_level = pa.tacgram_level; pptac_prods = pa.tacgram_prods; } let check_key key = if Tacenv.check_alias key then error "Conflicting tactic notations keys. This can happen when including \ twice the same module." let cache_tactic_notation (_, tobj) = let key = tobj.tacobj_key in let () = check_key key in Tacenv.register_alias key tobj.tacobj_body; extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram; Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram) let open_tactic_notation i (_, tobj) = let key = tobj.tacobj_key in if Int.equal i 1 && not tobj.tacobj_local then extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram let load_tactic_notation i (_, tobj) = let key = tobj.tacobj_key in let () = check_key key in (** Only add the printing and interpretation rules. *) Tacenv.register_alias key tobj.tacobj_body; Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram); if Int.equal i 1 && not tobj.tacobj_local then extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram let subst_tactic_notation (subst, tobj) = let (ids, body) = tobj.tacobj_body in { tobj with tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; tacobj_body = (ids, Tacsubst.subst_tactic subst body); } let classify_tactic_notation tacobj = Substitute tacobj let inTacticGrammar : tactic_grammar_obj -> obj = declare_object {(default_object "TacticGrammar") with open_function = open_tactic_notation; load_function = load_tactic_notation; cache_function = cache_tactic_notation; subst_function = subst_tactic_notation; classify_function = classify_tactic_notation} let cons_production_parameter = function | TacTerm _ -> None | TacNonTerm (_, _, id) -> Some id let add_glob_tactic_notation local n prods forml ids tac = let parule = { tacgram_level = n; tacgram_prods = prods; } in let tacobj = { tacobj_key = make_fresh_key prods; tacobj_local = local; tacobj_tacgram = parule; tacobj_body = (ids, tac); tacobj_forml = forml; } in Lib.add_anonymous_leaf (inTacticGrammar tacobj) let add_tactic_notation local n prods e = let ids = List.map_filter cons_production_parameter prods in let prods = List.map interp_prod_item prods in let tac = Tacintern.glob_tactic_env ids (Global.env()) e in add_glob_tactic_notation local n prods false ids tac (**********************************************************************) (* ML Tactic entries *) exception NonEmptyArgument (** ML tactic notations whose use can be restricted to an identifier are added as true Ltac entries. *) let extend_atomic_tactic name entries = let open Tacexpr in let map_prod prods = let (hd, rem) = match prods with | TacTerm s :: rem -> (s, rem) | _ -> assert false (** Not handled by the ML extension syntax *) in let empty_value = function | TacTerm s -> raise NonEmptyArgument | TacNonTerm (_, symb, _) -> let EntryName (typ, e) = prod_item_of_symbol 0 symb in let Genarg.Rawwit wit = typ in let inj x = TacArg (Loc.ghost, TacGeneric (Genarg.in_gen typ x)) in let default = epsilon_value inj e in match default with | None -> raise NonEmptyArgument | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def in try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None in let entries = List.map map_prod entries in let add_atomic i args = match args with | None -> () | Some (id, args) -> let args = List.map (fun a -> Tacexp a) args in let entry = { mltac_name = name; mltac_index = i } in let body = TacML (Loc.ghost, entry, args) in Tacenv.register_ltac false false (Names.Id.of_string id) body in List.iteri add_atomic entries let add_ml_tactic_notation name prods = let len = List.length prods in let iter i prods = let open Tacexpr in let get_id = function | TacTerm s -> None | TacNonTerm (_, _, id) -> Some id in let ids = List.map_filter get_id prods in let entry = { mltac_name = name; mltac_index = len - i - 1 } in let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in let tac = TacML (Loc.ghost, entry, List.map map ids) in add_glob_tactic_notation false 0 prods true ids tac in List.iteri iter (List.rev prods); extend_atomic_tactic name prods (**********************************************************************) (** Ltac quotations *) let ltac_quotations = ref String.Set.empty let create_ltac_quotation name cast (e, l) = let () = if String.Set.mem name !ltac_quotations then failwith ("Ltac quotation " ^ name ^ " already registered") in let () = ltac_quotations := String.Set.add name !ltac_quotations in let entry = match l with | None -> Aentry e | Some l -> Aentryl (e, l) in (* let level = Some "1" in *) let level = None in let assoc = None in let rule = Next (Next (Next (Next (Next (Stop, Atoken (CLexer.terminal name)), Atoken (CLexer.terminal ":")), Atoken (CLexer.terminal "(")), entry), Atoken (CLexer.terminal ")")) in let action _ v _ _ _ loc = cast (loc, v) in let gram = (level, assoc, [Rule (rule, action)]) in Pcoq.grammar_extend Tactic.tactic_arg None (None, [gram]) (** Command *) type tacdef_kind = | NewTac of Id.t | UpdateTac of Nametab.ltac_constant let is_defined_tac kn = try ignore (Tacenv.interp_ltac kn); true with Not_found -> false let warn_unusable_identifier = CWarnings.create ~name:"unusable-identifier" ~category:"parsing" (fun id -> strbrk "The Ltac name" ++ spc () ++ pr_id id ++ spc () ++ strbrk "may be unusable because of a conflict with a notation.") let register_ltac local tacl = let map tactic_body = match tactic_body with | TacticDefinition ((loc,id), body) -> let kn = Lib.make_kn id in let id_pp = pr_id id in let () = if is_defined_tac kn then CErrors.user_err_loc (loc, "", str "There is already an Ltac named " ++ id_pp ++ str".") in let is_shadowed = try match Pcoq.parse_string Pcoq.Tactic.tactic (Id.to_string id) with | Tacexpr.TacArg _ -> false | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) with e when CErrors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) in let () = if is_shadowed then warn_unusable_identifier id in NewTac id, body | TacticRedefinition (ident, body) -> let loc = loc_of_reference ident in let kn = try Nametab.locate_tactic (snd (qualid_of_reference ident)) with Not_found -> CErrors.user_err_loc (loc, "", str "There is no Ltac named " ++ pr_reference ident ++ str ".") in UpdateTac kn, body in let rfun = List.map map tacl in let recvars = let fold accu (op, _) = match op with | UpdateTac _ -> accu | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu in List.fold_left fold [] rfun in let ist = Tacintern.make_empty_glob_sign () in let map (name, body) = let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in (name, body) in let defs () = (** Register locally the tactic to handle recursivity. This function affects the whole environment, so that we transactify it afterwards. *) let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in let () = List.iter iter_rec recvars in List.map map rfun in let defs = Future.transactify defs () in let iter (def, tac) = match def with | NewTac id -> Tacenv.register_ltac false local id tac; Flags.if_verbose Feedback.msg_info (Nameops.pr_id id ++ str " is defined") | UpdateTac kn -> Tacenv.redefine_ltac local kn tac; let name = Nametab.shortest_qualid_of_tactic kn in Flags.if_verbose Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined") in List.iter iter defs (** Queries *) let print_ltacs () = let entries = KNmap.bindings (Tacenv.ltac_entries ()) in let sort (kn1, _) (kn2, _) = KerName.compare kn1 kn2 in let entries = List.sort sort entries in let map (kn, entry) = let qid = try Some (Nametab.shortest_qualid_of_tactic kn) with Not_found -> None in match qid with | None -> None | Some qid -> Some (qid, entry.Tacenv.tac_body) in let entries = List.map_filter map entries in let pr_entry (qid, body) = let (l, t) = match body with | Tacexpr.TacFun (l, t) -> (l, t) | _ -> ([], body) in let pr_ltac_fun_arg = function | None -> spc () ++ str "_" | Some id -> spc () ++ pr_id id in hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l) in Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) coq-8.6/ltac/tacenv.ml0000644000175000017500000001030413022274260014212 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* CErrors.anomaly (str "Unknown tactic alias: " ++ KerName.print key) let check_alias key = KNmap.mem key !alias_map (** ML tactic extensions (TacML) *) type ml_tactic = Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic module MLName = struct type t = ml_tactic_name let compare tac1 tac2 = let c = String.compare tac1.mltac_tactic tac2.mltac_tactic in if c = 0 then String.compare tac1.mltac_plugin tac2.mltac_plugin else c end module MLTacMap = Map.Make(MLName) let pr_tacname t = str t.mltac_plugin ++ str "::" ++ str t.mltac_tactic let tac_tab = ref MLTacMap.empty let register_ml_tactic ?(overwrite = false) s (t : ml_tactic array) = let () = if MLTacMap.mem s !tac_tab then if overwrite then tac_tab := MLTacMap.remove s !tac_tab else CErrors.anomaly (str "Cannot redeclare tactic " ++ pr_tacname s ++ str ".") in tac_tab := MLTacMap.add s t !tac_tab let interp_ml_tactic { mltac_name = s; mltac_index = i } = try let tacs = MLTacMap.find s !tac_tab in let () = if Array.length tacs <= i then raise Not_found in tacs.(i) with Not_found -> CErrors.errorlabstrm "" (str "The tactic " ++ pr_tacname s ++ str " is not installed.") (***************************************************************************) (* Tactic registration *) (* Summary and Object declaration *) open Nametab open Libobject type ltac_entry = { tac_for_ml : bool; tac_body : glob_tactic_expr; tac_redef : ModPath.t list; } let mactab = Summary.ref (KNmap.empty : ltac_entry KNmap.t) ~name:"tactic-definition" let ltac_entries () = !mactab let interp_ltac r = (KNmap.find r !mactab).tac_body let is_ltac_for_ml_tactic r = (KNmap.find r !mactab).tac_for_ml let add kn b t = let entry = { tac_for_ml = b; tac_body = t; tac_redef = [] } in mactab := KNmap.add kn entry !mactab let replace kn path t = let (path, _, _) = KerName.repr path in let entry _ e = { e with tac_body = t; tac_redef = path :: e.tac_redef } in mactab := KNmap.modify kn entry !mactab let load_md i ((sp, kn), (local, id, b, t)) = match id with | None -> let () = if not local then Nametab.push_tactic (Until i) sp kn in add kn b t | Some kn0 -> replace kn0 kn t let open_md i ((sp, kn), (local, id, b, t)) = match id with | None -> let () = if not local then Nametab.push_tactic (Exactly i) sp kn in add kn b t | Some kn0 -> replace kn0 kn t let cache_md ((sp, kn), (local, id ,b, t)) = match id with | None -> let () = Nametab.push_tactic (Until 1) sp kn in add kn b t | Some kn0 -> replace kn0 kn t let subst_kind subst id = match id with | None -> None | Some kn -> Some (Mod_subst.subst_kn subst kn) let subst_md (subst, (local, id, b, t)) = (local, subst_kind subst id, b, Tacsubst.subst_tactic subst t) let classify_md (local, _, _, _ as o) = Substitute o let inMD : bool * Nametab.ltac_constant option * bool * glob_tactic_expr -> obj = declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; open_function = open_md; subst_function = subst_md; classify_function = classify_md} let register_ltac for_ml local id tac = ignore (Lib.add_leaf id (inMD (local, None, for_ml, tac))) let redefine_ltac local kn tac = Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac)) coq-8.6/ltac/tacsubst.ml0000644000175000017500000003031213022274260014563 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* NoBindings | ImplicitBindings l -> ImplicitBindings (List.map (subst_glob_constr subst) l) | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l) let subst_glob_with_bindings subst (c,bl) = (subst_glob_constr subst c, subst_bindings subst bl) let subst_glob_with_bindings_arg subst (clear,c) = (clear,subst_glob_with_bindings subst c) let rec subst_intro_pattern subst = function | loc,IntroAction p -> loc, IntroAction (subst_intro_pattern_action subst p) | loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x and subst_intro_pattern_action subst = function | IntroApplyOn (t,pat) -> IntroApplyOn (subst_glob_constr subst t,subst_intro_pattern subst pat) | IntroOrAndPattern l -> IntroOrAndPattern (subst_intro_or_and_pattern subst l) | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l) | IntroWildcard | IntroRewrite _ as x -> x and subst_intro_or_and_pattern subst = function | IntroAndPattern l -> IntroAndPattern (List.map (subst_intro_pattern subst) l) | IntroOrPattern ll -> IntroOrPattern (List.map (List.map (subst_intro_pattern subst)) ll) let subst_destruction_arg subst = function | clear,ElimOnConstr c -> clear,ElimOnConstr (subst_glob_with_bindings subst c) | clear,ElimOnAnonHyp n as x -> x | clear,ElimOnIdent id as x -> x let subst_and_short_name f (c,n) = (* assert (n=None); *)(* since tacdef are strictly globalized *) (f c,None) let subst_or_var f = function | ArgVar _ as x -> x | ArgArg x -> ArgArg (f x) let dloc = Loc.ghost let subst_located f (_loc,id) = (dloc,f id) let subst_reference subst = subst_or_var (subst_located (subst_kn subst)) (*CSC: subst_global_reference is used "only" for RefArgType, that propagates to the syntactic non-terminals "global", used in commands such as Print. It is also used for non-evaluable references. *) open Pp open Printer let subst_global_reference subst = let subst_global ref = let ref',t' = subst_global subst ref in if not (eq_constr (Universes.constr_of_global ref') t') then Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ pr_global ref') ; ref' in subst_or_var (subst_located subst_global) let subst_evaluable subst = let subst_eval_ref = subst_evaluable_reference subst in subst_or_var (subst_and_short_name subst_eval_ref) let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) let subst_glob_constr_or_pattern subst (bvars,c,p) = (bvars,subst_glob_constr subst c,subst_pattern subst p) let subst_redexp subst = Miscops.map_red_expr_gen (subst_glob_constr subst) (subst_evaluable subst) (subst_glob_constr_or_pattern subst) let subst_raw_may_eval subst = function | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_glob_constr subst c) | ConstrContext (locid,c) -> ConstrContext (locid,subst_glob_constr subst c) | ConstrTypeOf c -> ConstrTypeOf (subst_glob_constr subst c) | ConstrTerm c -> ConstrTerm (subst_glob_constr subst c) let subst_match_pattern subst = function | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_glob_constr_or_pattern subst pc)) | Term pc -> Term (subst_glob_constr_or_pattern subst pc) let rec subst_match_goal_hyps subst = function | Hyp (locs,mp) :: tl -> Hyp (locs,subst_match_pattern subst mp) :: subst_match_goal_hyps subst tl | Def (locs,mv,mp) :: tl -> Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp) :: subst_match_goal_hyps subst tl | [] -> [] let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Basic tactics *) | TacIntroPattern (ev,l) -> TacIntroPattern (ev,List.map (subst_intro_pattern subst) l) | TacApply (a,ev,cb,cl) -> TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb,cl) | TacElim (ev,cb,cbo) -> TacElim (ev,subst_glob_with_bindings_arg subst cb, Option.map (subst_glob_with_bindings subst) cbo) | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings_arg subst cb) | TacMutualFix (id,n,l) -> TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l) | TacMutualCofix (id,l) -> TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l) | TacAssert (b,otac,na,c) -> TacAssert (b,Option.map (Option.map (subst_tactic subst)) otac,na, subst_glob_constr subst c) | TacGeneralize cl -> TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl) | TacLetTac (id,c,clp,b,eqpat) -> TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat) (* Derived basic tactics *) | TacInductionDestruct (isrec,ev,(l,el)) -> let l' = List.map (fun (c,ids,cls) -> subst_destruction_arg subst c, ids, cls) l in let el' = Option.map (subst_glob_with_bindings subst) el in TacInductionDestruct (isrec,ev,(l',el')) (* Conversion *) | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) | TacChange (op,c,cl) -> TacChange (Option.map (subst_glob_constr_or_pattern subst) op, subst_glob_constr subst c, cl) (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> TacRewrite (ev, List.map (fun (b,m,c) -> b,m,subst_glob_with_bindings_arg subst c) l, cl,Option.map (subst_tactic subst) by) | TacInversion (DepInversion (k,c,l),hyp) -> TacInversion (DepInversion (k,Option.map (subst_glob_constr subst) c,l),hyp) | TacInversion (NonDepInversion _,_) as x -> x | TacInversion (InversionUsing (c,cl),hyp) -> TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp) and subst_tactic subst (t:glob_tactic_expr) = match t with | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t) | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun) | TacLetIn (r,l,u) -> let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in TacLetIn (r,l,subst_tactic subst u) | TacMatchGoal (lz,lr,lmr) -> TacMatchGoal(lz,lr, subst_match_rule subst lmr) | TacMatch (lz,c,lmr) -> TacMatch (lz,subst_tactic subst c,subst_match_rule subst lmr) | TacId _ | TacFail _ as x -> x | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr) | TacShowHyps tac -> TacShowHyps (subst_tactic subst tac:glob_tactic_expr) | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s) | TacThen (t1,t2) -> TacThen (subst_tactic subst t1, subst_tactic subst t2) | TacDispatch tl -> TacDispatch (List.map (subst_tactic subst) tl) | TacExtendTac (tf,t,tl) -> TacExtendTac (Array.map (subst_tactic subst) tf, subst_tactic subst t, Array.map (subst_tactic subst) tl) | TacThens (t,tl) -> TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl) | TacThens3parts (t1,tf,t2,tl) -> TacThens3parts (subst_tactic subst t1,Array.map (subst_tactic subst) tf, subst_tactic subst t2,Array.map (subst_tactic subst) tl) | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac) | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac) | TacTime (s,tac) -> TacTime (s,subst_tactic subst tac) | TacTry tac -> TacTry (subst_tactic subst tac) | TacInfo tac -> TacInfo (subst_tactic subst tac) | TacRepeat tac -> TacRepeat (subst_tactic subst tac) | TacOr (tac1,tac2) -> TacOr (subst_tactic subst tac1,subst_tactic subst tac2) | TacOnce tac -> TacOnce (subst_tactic subst tac) | TacExactlyOnce tac -> TacExactlyOnce (subst_tactic subst tac) | TacIfThenCatch (tac,tact,tace) -> TacIfThenCatch ( subst_tactic subst tac, subst_tactic subst tact, subst_tactic subst tace) | TacOrelse (tac1,tac2) -> TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2) | TacFirst l -> TacFirst (List.map (subst_tactic subst) l) | TacSolve l -> TacSolve (List.map (subst_tactic subst) l) | TacComplete tac -> TacComplete (subst_tactic subst tac) | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a) | TacSelect (s, tac) -> TacSelect (s, subst_tactic subst tac) (* For extensions *) | TacAlias (_,s,l) -> let s = subst_kn subst s in TacAlias (dloc,s,List.map (subst_tacarg subst) l) | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_tacarg subst) l) and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) and subst_tacarg subst = function | Reference r -> Reference (subst_reference subst r) | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) | TacCall (_loc,f,l) -> TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l) | TacFreshId _ as x -> x | TacPretype c -> TacPretype (subst_glob_constr subst c) | TacNumgoals -> TacNumgoals | Tacexp t -> Tacexp (subst_tactic subst t) | TacGeneric arg -> TacGeneric (subst_genarg subst arg) (* Reads the rules of a Match Context or a Match *) and subst_match_rule subst = function | (All tc)::tl -> (All (subst_tactic subst tc))::(subst_match_rule subst tl) | (Pat (rl,mp,tc))::tl -> let hyps = subst_match_goal_hyps subst rl in let pat = subst_match_pattern subst mp in Pat (hyps,pat,subst_tactic subst tc) ::(subst_match_rule subst tl) | [] -> [] and subst_genarg subst (GenArg (Glbwit wit, x)) = match wit with | ListArg wit -> let map x = let ans = subst_genarg subst (in_gen (glbwit wit) x) in out_gen (glbwit wit) ans in in_gen (glbwit (wit_list wit)) (List.map map x) | OptArg wit -> let ans = match x with | None -> in_gen (glbwit (wit_opt wit)) None | Some x -> let s = out_gen (glbwit wit) (subst_genarg subst (in_gen (glbwit wit) x)) in in_gen (glbwit (wit_opt wit)) (Some s) in ans | PairArg (wit1, wit2) -> let p, q = x in let p = out_gen (glbwit wit1) (subst_genarg subst (in_gen (glbwit wit1) p)) in let q = out_gen (glbwit wit2) (subst_genarg subst (in_gen (glbwit wit2) q)) in in_gen (glbwit (wit_pair wit1 wit2)) (p, q) | ExtraArg s -> Genintern.generic_substitute subst (in_gen (glbwit wit) x) (** Registering *) let () = Genintern.register_subst0 wit_int_or_var (fun _ v -> v); Genintern.register_subst0 wit_ref subst_global_reference; Genintern.register_subst0 wit_ident (fun _ v -> v); Genintern.register_subst0 wit_var (fun _ v -> v); Genintern.register_subst0 wit_intro_pattern (fun _ v -> v); Genintern.register_subst0 wit_tactic subst_tactic; Genintern.register_subst0 wit_ltac subst_tactic; Genintern.register_subst0 wit_constr subst_glob_constr; Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v); Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c); Genintern.register_subst0 wit_open_constr (fun subst c -> subst_glob_constr subst c); Genintern.register_subst0 wit_red_expr subst_redexp; Genintern.register_subst0 wit_quant_hyp subst_declared_or_quantified_hypothesis; Genintern.register_subst0 wit_bindings subst_bindings; Genintern.register_subst0 wit_constr_with_bindings subst_glob_with_bindings; Genintern.register_subst0 wit_destruction_arg subst_destruction_arg; () coq-8.6/ltac/g_ltac.ml40000644000175000017500000004333613022274260014262 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* a | e -> Tacexp (e:raw_tactic_expr) let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat let genarg_of_uconstr c = in_gen (rawwit Constrarg.wit_uconstr) c let reference_to_id = function | Libnames.Ident (loc, id) -> (loc, id) | Libnames.Qualid (loc,_) -> CErrors.user_err_loc (loc, "", str "This expression should be a simple identifier.") let tactic_mode = Gram.entry_create "vernac:tactic_command" let new_entry name = let e = Gram.entry_create name in e let toplevel_selector = new_entry "vernac:toplevel_selector" let tacdef_body = new_entry "tactic:tacdef_body" (* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for proof editing and changes nothing else). Then sets it as the default proof mode. *) let _ = let mode = { Proof_global.name = "Classic"; set = (fun () -> set_command_entry tactic_mode); reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); } in Proof_global.register_proof_mode mode (* Hack to parse "[ id" without dropping [ *) let test_bracket_ident = Gram.Entry.of_parser "test_bracket_ident" (fun strm -> match get_tok (stream_nth 0 strm) with | KEYWORD "[" -> (match get_tok (stream_nth 1 strm) with | IDENT _ -> () | _ -> raise Stream.Failure) | _ -> raise Stream.Failure) (* Tactics grammar rules *) let warn_deprecated_appcontext = CWarnings.create ~name:"deprecated-appcontext" ~category:"deprecated" (fun () -> strbrk "appcontext is deprecated and will be removed " ++ strbrk "in a future version") GEXTEND Gram GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg tactic_mode constr_may_eval constr_eval toplevel_selector; tactic_then_last: [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) | -> [||] ] ] ; tactic_then_gen: [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last) | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l)) | ".."; l = tactic_then_last -> ([], Some (TacId [], l)) | ta = tactic_expr -> ([ta], None) | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last) | -> ([TacId []], None) ] ] ; tactic_then_locality: (* [true] for the local variant [TacThens] and [false] for [TacExtend] *) [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ] ; tactic_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; (first,tail) = tactic_then_gen; "]" -> match l , tail with | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) | 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 (*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) ] (*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) ] | "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" -> TacMatch (b,c,mrl) | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> TacFirst l | IDENT "solve" ; "["; l = LIST0 tactic_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(!@loc,a) | r = reference; la = LIST0 tactic_arg_compat -> TacArg(!@loc,TacCall (!@loc,r,la)) ] | "0" [ "("; a = tactic_expr; ")" -> a | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> begin match tail with | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) | None -> TacDispatch tf end | a = tactic_atom -> TacArg (!@loc,a) ] ] ; failkw: [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] ; (* binder_tactic: level 5 of tactic_expr *) binder_tactic: [ RIGHTA [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_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) | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] ; (* Tactic arguments to the right of an application *) tactic_arg_compat: [ [ a = tactic_arg -> a | c = Constr.constr -> (match c with CRef (r,None) -> Reference r | c -> ConstrMayEval (ConstrTerm c)) (* Unambiguous entries: tolerated w/o "ltac:" modifier *) | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; (* Can be used as argument and at toplevel in tactic expressions. *) tactic_arg: [ [ c = constr_eval -> ConstrMayEval c | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l | IDENT "type_term"; c=uconstr -> TacPretype c | IDENT "numgoals" -> TacNumgoals ] ] ; (* If a qualid is given, use its short name. TODO: have the shortest non ambiguous name where dots are replaced by "_"? Probably too verbose most of the time. *) fresh_id: [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) | qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (!@loc,id) ] ] ; constr_eval: [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> ConstrEval (rtc,c) | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> ConstrContext (id,c) | IDENT "type"; IDENT "of"; c = Constr.constr -> ConstrTypeOf c ] ] ; constr_may_eval: (* For extensions *) [ [ c = constr_eval -> c | c = Constr.constr -> ConstrTerm c ] ] ; tactic_atom: [ [ n = integer -> TacGeneric (genarg_of_int n) | r = reference -> TacCall (!@loc,r,[]) | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; match_key: [ [ "match" -> Once | "lazymatch" -> Select | "multimatch" -> General ] ] ; input_fun: [ [ "_" -> None | l = ident -> Some l ] ] ; let_clause: [ [ id = identref; ":="; te = tactic_expr -> (id, arg_of_expr te) | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> (id, arg_of_expr (TacFun(args,te))) ] ] ; match_pattern: [ [ IDENT "context"; oid = OPT Constr.ident; "["; pc = Constr.lconstr_pattern; "]" -> let mode = not (!Flags.tactic_context_compat) in Subterm (mode, oid, pc) | IDENT "appcontext"; oid = OPT Constr.ident; "["; pc = Constr.lconstr_pattern; "]" -> warn_deprecated_appcontext ~loc:!@loc (); Subterm (true,oid, pc) | pc = Constr.lconstr_pattern -> Term pc ] ] ; match_hyps: [ [ 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 -> let t, ty = match mpv with | Term t -> (match t with | CCast (loc, t, (CastConv ty | CastVM ty | CastNative ty)) -> Term t, Some (Term ty) | _ -> mpv, None) | _ -> mpv, None in Def (na, t, Option.default (Term (CHole (Loc.ghost, None, IntroAnonymous, None))) ty) ] ] ; 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 ] ] ; 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 ] ] ; match_list: [ [ mrl = LIST1 match_rule SEP "|" -> mrl | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] ; message_token: [ [ id = identref -> MsgIdent id | s = STRING -> MsgString s | n = integer -> MsgInt n ] ] ; ltac_def_kind: [ [ ":=" -> false | "::=" -> true ] ] ; (* Definitions for tactics *) tacdef_body: [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> if redef then Vernacexpr.TacticRedefinition (name, TacFun (it, body)) else let id = reference_to_id name in Vernacexpr.TacticDefinition (id, TacFun (it, body)) | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> if redef then Vernacexpr.TacticRedefinition (name, body) else let id = reference_to_id name in Vernacexpr.TacticDefinition (id, body) ] ] ; tactic: [ [ tac = tactic_expr -> tac ] ] ; range_selector: [ [ n = natural ; "-" ; m = natural -> (n, m) | n = natural -> (n, n) ] ] ; (* We unfold a range selectors list once so that we can make a special case * for a unique SelectNth selector. *) range_selector_or_nth: [ [ n = natural ; "-" ; m = natural; l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> SelectList ((n, m) :: Option.default [] l) | n = natural; l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ] ; selector_body: [ [ l = range_selector_or_nth -> l | test_bracket_ident; "["; id = ident; "]" -> SelectId id ] ] ; selector: [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ] ; toplevel_selector: [ [ sel = selector_body; ":" -> sel | IDENT "all"; ":" -> SelectAll ] ] ; tactic_mode: [ [ g = OPT toplevel_selector; tac = G_vernac.subgoal_command -> tac g ] ] ; END open Constrarg open Vernacexpr open Vernac_classifier open Goptions open Libnames let print_info_trace = ref None let _ = declare_int_option { optsync = true; optdepr = false; optname = "print info trace"; optkey = ["Info" ; "Level"]; optread = (fun () -> !print_info_trace); optwrite = fun n -> print_info_trace := n; } let vernac_solve n info tcom b = let status = Proof_global.with_current_proof (fun etac p -> let with_end_tac = if b then Some etac else None in let global = match n with SelectAll | SelectList _ -> true | _ -> false in let info = Option.append info !print_info_trace in let (p,status) = Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?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 let pr_range_selector (i, j) = if Int.equal i j then int i else int i ++ str "-" ++ int j let pr_ltac_selector = function | SelectNth i -> int i ++ str ":" | SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ str "]" ++ str ":" | SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" | SelectAll -> str "all" ++ str ":" VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector | [ toplevel_selector(s) ] -> [ s ] END let pr_ltac_info n = str "Info" ++ spc () ++ int n VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info | [ "Info" natural(n) ] -> [ n ] END let pr_ltac_use_default b = if b then (* Bug: a space is inserted before "..." *) str ".." else mt () VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default | [ "." ] -> [ false ] | [ "..." ] -> [ true ] END let is_anonymous_abstract = function | TacAbstract (_,None) -> true | TacSolve [TacAbstract (_,None)] -> true | _ -> false let rm_abstract = function | TacAbstract (t,_) -> t | TacSolve [TacAbstract (t,_)] -> TacSolve [t] | x -> x let is_explicit_terminator = function TacSolve _ -> true | _ -> false VERNAC tactic_mode EXTEND VernacSolve | [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => [ classify_as_proofstep ] -> [ let g = Option.default (Proof_global.get_default_goal_selector ()) g in vernac_solve g n t def ] | [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => [ let anon_abstracting_tac = is_anonymous_abstract t in let solving_tac = is_explicit_terminator t in let parallel = `Yes (solving_tac,anon_abstracting_tac) in let pbr = if solving_tac then Some "par" else None in VtProofStep{ parallel = parallel; proof_block_detection = pbr }, VtLater ] -> [ let t = rm_abstract t in vernac_solve SelectAll n t def ] END let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")" VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY pr_ltac_tactic_level | [ "(" "at" "level" natural(n) ")" ] -> [ n ] END VERNAC ARGUMENT EXTEND ltac_production_sep | [ "," string(sep) ] -> [ sep ] END let pr_ltac_production_item = function | Tacentries.TacTerm s -> quote (str s) | Tacentries.TacNonTerm (_, (arg, sep), id) -> let sep = match sep with | None -> mt () | Some sep -> str "," ++ spc () ++ quote (str sep) in str arg ++ str "(" ++ Nameops.pr_id id ++ sep ++ str ")" VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item | [ string(s) ] -> [ Tacentries.TacTerm s ] | [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> [ Tacentries.TacNonTerm (loc, (Names.Id.to_string nt, sep), p) ] END VERNAC COMMAND EXTEND VernacTacticNotation | [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => [ VtUnknown, VtNow ] -> [ let l = Locality.LocalityFixme.consume () in let n = Option.default 0 n in Tacentries.add_tactic_notation (Locality.make_module_locality l) n r e ] END VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY | [ "Print" "Ltac" reference(r) ] -> [ Feedback.msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] END let pr_ltac_ref = Libnames.pr_reference let pr_tacdef_body tacdef_body = let id, redef, body = match tacdef_body with | TacticDefinition ((_,id), body) -> Nameops.pr_id id, false, body | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body in let idl, body = match body with | Tacexpr.TacFun (idl,b) -> idl,b | _ -> [], body in id ++ prlist (function None -> str " _" | Some id -> spc () ++ Nameops.pr_id id) idl ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++ Pptactic.pr_raw_tactic body VERNAC ARGUMENT EXTEND ltac_tacdef_body PRINTED BY pr_tacdef_body | [ tacdef_body(t) ] -> [ t ] END VERNAC COMMAND EXTEND VernacDeclareTacticDefinition | [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ VtSideff (List.map (function | TacticDefinition ((_,r),_) -> r | TacticRedefinition (Ident (_,r),_) -> r | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater ] -> [ let lc = Locality.LocalityFixme.consume () in Tacentries.register_ltac (Locality.make_module_locality lc) l ] END VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY | [ "Print" "Ltac" "Signatures" ] -> [ Tacentries.print_ltacs () ] END coq-8.6/ltac/g_rewrite.ml40000644000175000017500000003046713022274260015021 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ bl ] END type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast let interp_strategy ist gl s = let sigma = project gl in sigma, strategy_of_ast s let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s let subst_strategy s str = str let pr_strategy _ _ _ (s : strategy) = Pp.str "" let pr_raw_strategy prc prlc _ (s : raw_strategy) = let prr = Pptactic.pr_red_expr (prc, prlc, Pptactic.pr_or_by_notation Libnames.pr_reference, prc) in Rewrite.pr_strategy prc prr s let pr_glob_strategy prc prlc _ (s : glob_strategy) = let prr = Pptactic.pr_red_expr (Ppconstr.pr_constr_expr, Ppconstr.pr_lconstr_expr, Pptactic.pr_or_by_notation Libnames.pr_reference, Ppconstr.pr_constr_expr) in Rewrite.pr_strategy prc prr s ARGUMENT EXTEND rewstrategy PRINTED BY pr_strategy INTERPRETED BY interp_strategy GLOBALIZED BY glob_strategy SUBSTITUTED BY subst_strategy RAW_PRINTED BY pr_raw_strategy GLOB_PRINTED BY pr_glob_strategy [ glob(c) ] -> [ StratConstr (c, true) ] | [ "<-" constr(c) ] -> [ StratConstr (c, false) ] | [ "subterms" rewstrategy(h) ] -> [ StratUnary (Subterms, h) ] | [ "subterm" rewstrategy(h) ] -> [ StratUnary (Subterm, h) ] | [ "innermost" rewstrategy(h) ] -> [ StratUnary(Innermost, h) ] | [ "outermost" rewstrategy(h) ] -> [ StratUnary(Outermost, h) ] | [ "bottomup" rewstrategy(h) ] -> [ StratUnary(Bottomup, h) ] | [ "topdown" rewstrategy(h) ] -> [ StratUnary(Topdown, h) ] | [ "id" ] -> [ StratId ] | [ "fail" ] -> [ StratFail ] | [ "refl" ] -> [ StratRefl ] | [ "progress" rewstrategy(h) ] -> [ StratUnary (Progress, h) ] | [ "try" rewstrategy(h) ] -> [ StratUnary (Try, h) ] | [ "any" rewstrategy(h) ] -> [ StratUnary (Any, h) ] | [ "repeat" rewstrategy(h) ] -> [ StratUnary (Repeat, h) ] | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary (Compose, h, h') ] | [ "(" rewstrategy(h) ")" ] -> [ h ] | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary (Choice, h, h') ] | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ] | [ "hints" preident(h) ] -> [ StratHints (false, h) ] | [ "terms" constr_list(h) ] -> [ StratTerms h ] | [ "eval" red_expr(r) ] -> [ StratEval r ] | [ "fold" constr(c) ] -> [ StratFold c ] END (* By default the strategy for "rewrite_db" is top-down *) let db_strat db = StratUnary (Topdown, StratHints (false, db)) let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) TACTIC EXTEND rewrite_strat | [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] | [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ] | [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ] | [ "rewrite_db" preident(db) ] -> [ cl_rewrite_clause_db db None ] END let clsubstitute o c = let is_tac id = match fst (fst (snd c)) with GVar (_, id') when Id.equal id' id -> true | _ -> false in Tacticals.onAllHypsAndConcl (fun cl -> match cl with | Some id when is_tac id -> tclIDTAC | _ -> Proofview.V82.of_tactic (cl_rewrite_clause c o AllOccurrences cl)) TACTIC EXTEND substitute | [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ Proofview.V82.tactic (clsubstitute o c) ] END (* Compatibility with old Setoids *) TACTIC EXTEND setoid_rewrite [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] -> [ cl_rewrite_clause c o AllOccurrences None ] | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o AllOccurrences (Some id) ] | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None ] | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] END VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ] | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> [ declare_relation a aeq n (Some lemma1) None None ] | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> [ declare_relation a aeq n None None None ] END VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation a aeq n None (Some lemma2) None ] | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ] END VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ] | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation a aeq n None None (Some lemma3) ] END type binders_argtype = local_binder list let wit_binders = (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) let () = let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in let printer _ _ _ _ = Pp.str "" in Pptactic.declare_extra_genarg_pprule wit_binders raw_printer printer printer open Pcoq GEXTEND Gram GLOBAL: binders; binders: [ [ b = Pcoq.Constr.binders -> b ] ]; END VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ] | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) None None ] | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None None None ] END VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None (Some lemma2) None ] | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ] END VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ] | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] END VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] a aeq t n ] | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders a aeq t n ] | [ "Add" "Morphism" constr(m) ":" ident(n) ] (* This command may or may not open a goal *) => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ] -> [ add_morphism_infer (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) m n ] | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] m s n ] | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders m s n ] END TACTIC EXTEND setoid_symmetry [ "setoid_symmetry" ] -> [ setoid_symmetry ] | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] END TACTIC EXTEND setoid_reflexivity [ "setoid_reflexivity" ] -> [ setoid_reflexivity ] END TACTIC EXTEND setoid_transitivity [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] | [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] END VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Feedback.msg_notice (Autorewrite.print_rewrite_hintdb s) ] END coq-8.6/ltac/tactic_debug.mli0000644000175000017500000000604413022274260015526 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* glob_tactic_expr -> (debug_info -> 'a Proofview.tactic) -> 'a Proofview.tactic (** Initializes debugger *) val db_initialize : unit Proofview.NonLogical.t (** Prints a constr *) val db_constr : debug_info -> env -> constr -> unit Proofview.NonLogical.t (** Prints the pattern rule *) val db_pattern_rule : debug_info -> int -> (Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t (** Prints a matched hypothesis *) val db_matched_hyp : debug_info -> env -> Id.t * constr option * constr -> Name.t -> unit Proofview.NonLogical.t (** Prints the matched conclusion *) val db_matched_concl : debug_info -> env -> constr -> unit Proofview.NonLogical.t (** Prints a success message when the goal has been matched *) val db_mc_pattern_success : debug_info -> unit Proofview.NonLogical.t (** Prints a failure message for an hypothesis pattern *) val db_hyp_pattern_failure : debug_info -> env -> evar_map -> Name.t * constr_pattern match_pattern -> unit Proofview.NonLogical.t (** Prints a matching failure message for a rule *) val db_matching_failure : debug_info -> unit Proofview.NonLogical.t (** Prints an evaluation failure message for a rule *) val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t (** An exception handler *) val explain_logic_error: exn -> Pp.std_ppcmds (** For use in the Ltac debugger: some exception that are usually consider anomalies are acceptable because they are caught later in the process that is being debugged. One should not require from users that they report these anomalies. *) val explain_logic_error_no_anomaly : exn -> Pp.std_ppcmds (** Prints a logic failure message for a rule *) val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t (** Prints a logic failure message for a rule *) val db_breakpoint : debug_info -> Id.t Loc.located message_token list -> unit Proofview.NonLogical.t val extract_ltac_trace : Tacexpr.ltac_trace -> Loc.t -> Pp.std_ppcmds option * Loc.t coq-8.6/COPYRIGHT0000644000175000017500000000135013022274260012751 0ustar mdenesmdenes The Coq proof assistant Copyright 1999-2016 The Coq development team, INRIA, CNRS, University Paris Sud, University Paris 7, Ecole Polytechnique. This product includes also software developed by Pierre Crégut, France Telecom R & D (plugins/omega and plugins/romega) Pierre Courtieu and Julien Forest, CNAM (plugins/funind) Claudio Sacerdoti Coen, HELM, University of Bologna, (plugins/xml) Pierre Corbineau, Radboud University, Nijmegen (declarative mode) John Harrison, University of Cambridge (csdp wrapper) Georges Gonthier, Microsoft Research - Inria Joint Centre (plugins/ssrmatching) The file CREDITS contains a list of contributors. The credits section in the Reference Manual details contributions. coq-8.6/Makefile.install0000644000175000017500000001216713022274260014573 0ustar mdenesmdenes####################################################################### # v # The Coq Proof Assistant / The Coq Development Team # # /dev/null install-latex: $(MKDIR) $(FULLCOQDOCDIR) $(INSTALLLIB) tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR) # -$(UPDATETEX) install-meta: META.coq $(INSTALLLIB) META.coq $(FULLCOQLIB)/META # For emacs: # Local Variables: # mode: makefile # End: coq-8.6/library/0000755000175000017500000000000013022274260013123 5ustar mdenesmdenescoq-8.6/library/nametab.mli0000644000175000017500000001507113022274260015241 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* full_user_name -> object_reference -> unit] Registers the [object_reference] to be referred to by the [full_user_name] (and its suffixes according to [visibility]). [full_user_name] can either be a [full_path] or a [DirPath.t]. } {- [exists : full_user_name -> bool] Is the [full_user_name] already atributed as an absolute user name of some object? } {- [locate : qualid -> object_reference] Finds the object referred to by [qualid] or raises [Not_found] } {- [full_name : qualid -> full_user_name] Finds the full user name referred to by [qualid] or raises [Not_found] } {- [shortest_qualid_of : object_reference -> user_name] The [user_name] can be for example the shortest non ambiguous [qualid] or the [full_user_name] or [Id.t]. Such a function can also have a local context argument.}} *) exception GlobalizationError of qualid (** Raises a globalization error *) val error_global_not_found_loc : Loc.t -> qualid -> 'a val error_global_not_found : qualid -> 'a (** {6 Register visibility of things } *) (** The visibility can be registered either - for all suffixes not shorter then a given int -- when the object is loaded inside a module -- or - for a precise suffix, when the module containing (the module containing ...) the object is opened (imported) *) type visibility = Until of int | Exactly of int val push : visibility -> full_path -> global_reference -> unit val push_modtype : visibility -> full_path -> module_path -> unit val push_dir : visibility -> DirPath.t -> global_dir_reference -> unit val push_syndef : visibility -> full_path -> syndef_name -> unit type ltac_constant = kernel_name val push_tactic : visibility -> full_path -> ltac_constant -> unit (** {6 The following functions perform globalization of qualified names } *) (** These functions globalize a (partially) qualified name or fail with [Not_found] *) val locate : qualid -> global_reference val locate_extended : qualid -> extended_global_reference val locate_constant : qualid -> constant val locate_syndef : qualid -> syndef_name val locate_modtype : qualid -> module_path val locate_dir : qualid -> global_dir_reference val locate_module : qualid -> module_path val locate_section : qualid -> DirPath.t val locate_tactic : qualid -> ltac_constant (** These functions globalize user-level references into global references, like [locate] and co, but raise a nice error message in case of failure *) val global : reference -> global_reference val global_inductive : reference -> inductive (** These functions locate all global references with a given suffix; if [qualid] is valid as such, it comes first in the list *) val locate_all : qualid -> global_reference list val locate_extended_all : qualid -> extended_global_reference list val locate_extended_all_tactic : qualid -> ltac_constant list val locate_extended_all_dir : qualid -> global_dir_reference list val locate_extended_all_modtype : qualid -> module_path list (** Mapping a full path to a global reference *) val global_of_path : full_path -> global_reference val extended_global_of_path : full_path -> extended_global_reference (** {6 These functions tell if the given absolute name is already taken } *) val exists_cci : full_path -> bool val exists_modtype : full_path -> bool val exists_dir : DirPath.t -> bool val exists_section : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) val exists_module : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) val exists_tactic : full_path -> bool (** deprecated synonym of [exists_dir] *) (** {6 These functions locate qualids into full user names } *) val full_name_cci : qualid -> full_path val full_name_modtype : qualid -> full_path val full_name_module : qualid -> DirPath.t (** {6 Reverse lookup } Finding user names corresponding to the given internal name *) (** Returns the full path bound to a global reference or syntactic definition, and the (full) dirpath associated to a module path *) val path_of_syndef : syndef_name -> full_path val path_of_global : global_reference -> full_path val dirpath_of_module : module_path -> DirPath.t val path_of_modtype : module_path -> full_path val path_of_tactic : ltac_constant -> full_path (** Returns in particular the dirpath or the basename of the full path associated to global reference *) val dirpath_of_global : global_reference -> DirPath.t val basename_of_global : global_reference -> Id.t (** Printing of global references using names as short as possible. @raise Not_found when the reference is not in the global tables. *) val pr_global_env : Id.Set.t -> global_reference -> std_ppcmds (** The [shortest_qualid] functions given an object with [user_name] Coq.A.B.x, try to find the shortest among x, B.x, A.B.x and Coq.A.B.x that denotes the same object. @raise Not_found for unknown objects. *) val shortest_qualid_of_global : Id.Set.t -> global_reference -> qualid val shortest_qualid_of_syndef : Id.Set.t -> syndef_name -> qualid val shortest_qualid_of_modtype : module_path -> qualid val shortest_qualid_of_module : module_path -> qualid val shortest_qualid_of_tactic : ltac_constant -> qualid (** Deprecated synonyms *) val extended_locate : qualid -> extended_global_reference (*= locate_extended *) val absolute_reference : full_path -> global_reference (** = global_of_path *) coq-8.6/library/keys.ml0000644000175000017500000001012713022274260014431 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 8 + RefOrdered.hash gr | KLam -> 0 | KLet -> 1 | KProd -> 2 | KSort -> 3 | KCase -> 4 | KFix -> 5 | KCoFix -> 6 | KRel -> 7 let compare gr1 gr2 = match gr1, gr2 with | KGlob gr1, KGlob gr2 -> RefOrdered.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 -> RefOrdered.equal gr1 gr2 | _, KGlob _ -> false | KGlob _, _ -> false | k, k' -> k == k' end module Keymap = HMap.Make(KeyOrdered) module Keyset = Keymap.Set (* Mapping structure for references to be considered equivalent *) let keys = Summary.ref Keymap.empty ~name:"Keys_decl" let add_kv k v m = try Keymap.modify k (fun k' vs -> Keyset.add v vs) m with Not_found -> Keymap.add k (Keyset.singleton v) m let add_keys k v = keys := add_kv k v (add_kv v k !keys) let equiv_keys k k' = k == k' || KeyOrdered.equal k k' || try Keyset.mem k' (Keymap.find k !keys) with Not_found -> false (** Registration of keys as an object *) let load_keys _ (_,(ref,ref')) = add_keys ref ref' let cache_keys o = load_keys 1 o let subst_key subst k = match k with | KGlob gr -> KGlob (subst_global_reference subst gr) | _ -> k let subst_keys (subst,(k,k')) = (subst_key subst k, subst_key subst k') let discharge_key = function | KGlob g when Lib.is_in_section g -> if isVarRef g then None else Some (KGlob (pop_global_reference g)) | x -> Some x let discharge_keys (_,(k,k')) = match discharge_key k, discharge_key k' with | Some x, Some y -> Some (x, y) | _ -> None let rebuild_keys (ref,ref') = (ref, ref') type key_obj = key * key let inKeys : key_obj -> obj = declare_object {(default_object "KEYS") with cache_function = cache_keys; load_function = load_keys; subst_function = subst_keys; classify_function = (fun x -> Substitute x); discharge_function = discharge_keys; rebuild_function = rebuild_keys } let declare_equiv_keys ref ref' = Lib.add_anonymous_leaf (inKeys (ref,ref')) let constr_key c = let open Globnames in try let rec aux k = match kind_of_term k with | Const (c, _) -> KGlob (ConstRef c) | Ind (i, u) -> KGlob (IndRef i) | Construct (c,u) -> KGlob (ConstructRef c) | Var id -> KGlob (VarRef id) | App (f, _) -> aux f | Proj (p, _) -> KGlob (ConstRef (Names.Projection.constant p)) | Cast (p, _, _) -> aux p | Lambda _ -> KLam | Prod _ -> KProd | Case _ -> KCase | Fix _ -> KFix | CoFix _ -> KCoFix | Rel _ -> KRel | Meta _ -> raise Not_found | Evar _ -> raise Not_found | Sort _ -> KSort | LetIn _ -> KLet in Some (aux c) with Not_found -> None open Pp let pr_key pr_global = function | KGlob gr -> pr_global gr | KLam -> str"Lambda" | KLet -> str"Let" | KProd -> str"Product" | KSort -> str"Sort" | KCase -> str"Case" | KFix -> str"Fix" | KCoFix -> str"CoFix" | KRel -> str"Rel" let pr_keyset pr_global v = prlist_with_sep spc (pr_key pr_global) (Keyset.elements v) let pr_mapping pr_global k v = pr_key pr_global k ++ str" <-> " ++ pr_keyset pr_global v let pr_keys pr_global = Keymap.fold (fun k v acc -> pr_mapping pr_global k v ++ fnl () ++ acc) !keys (mt()) coq-8.6/library/global.ml0000644000175000017500000002357113022274260014725 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Safe_typing.safe_environment val set_safe_env : Safe_typing.safe_environment -> unit val join_safe_environment : ?except:Future.UUIDSet.t -> unit -> unit val is_joined_environment : unit -> bool end = struct let global_env = ref Safe_typing.empty_environment let join_safe_environment ?except () = global_env := Safe_typing.join_safe_environment ?except !global_env let is_joined_environment () = Safe_typing.is_joined_environment !global_env let () = Summary.declare_summary global_env_summary_name { Summary.freeze_function = (function | `Yes -> join_safe_environment (); !global_env | `No -> !global_env | `Shallow -> !global_env); unfreeze_function = (fun fr -> global_env := fr); init_function = (fun () -> global_env := Safe_typing.empty_environment) } let assert_not_parsing () = if !Flags.we_are_parsing then CErrors.anomaly ( Pp.strbrk"The global environment cannot be accessed during parsing") let safe_env () = assert_not_parsing(); !global_env let set_safe_env e = global_env := e end let safe_env = GlobalSafeEnv.safe_env let join_safe_environment ?except () = GlobalSafeEnv.join_safe_environment ?except () let is_joined_environment = GlobalSafeEnv.is_joined_environment let env () = Safe_typing.env_of_safe_env (safe_env ()) let env_is_initial () = Safe_typing.is_initial (safe_env ()) (** Turn ops over the safe_environment state monad to ops on the global env *) let globalize0 f = GlobalSafeEnv.set_safe_env (f (safe_env ())) let globalize f = let res,env = f (safe_env ()) in GlobalSafeEnv.set_safe_env env; res let globalize_with_summary fs f = let res,env = f (safe_env ()) in Summary.unfreeze_summaries fs; GlobalSafeEnv.set_safe_env env; res (** [Safe_typing] operations, now operating on the global environment *) let i2l = Label.of_id let push_named_assum a = globalize0 (Safe_typing.push_named_assum a) let push_named_def d = globalize (Safe_typing.push_named_def d) let add_constraints c = globalize0 (Safe_typing.add_constraints c) let push_context_set b c = globalize0 (Safe_typing.push_context_set b c) let push_context b c = globalize0 (Safe_typing.push_context b c) let set_engagement c = globalize0 (Safe_typing.set_engagement c) let set_typing_flags c = globalize0 (Safe_typing.set_typing_flags c) let add_constant dir id d = globalize (Safe_typing.add_constant dir (i2l id) d) let add_mind dir id mie = globalize (Safe_typing.add_mind dir (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) let add_module id me inl = globalize (Safe_typing.add_module (i2l id) me inl) let add_include me ismod inl = globalize (Safe_typing.add_include me ismod inl) let start_module id = globalize (Safe_typing.start_module (i2l id)) let start_modtype id = globalize (Safe_typing.start_modtype (i2l id)) let end_module fs id mtyo = globalize_with_summary fs (Safe_typing.end_module (i2l id) mtyo) let end_modtype fs id = globalize_with_summary fs (Safe_typing.end_modtype (i2l id)) let add_module_parameter mbid mte inl = globalize (Safe_typing.add_module_parameter mbid mte inl) (** Queries on the global environment *) let universes () = universes (env()) let named_context () = named_context (env()) let named_context_val () = named_context_val (env()) let lookup_named id = lookup_named id (env()) let lookup_constant kn = lookup_constant kn (env()) let lookup_inductive ind = Inductive.lookup_mind_specif (env()) ind let lookup_pinductive (ind,_) = Inductive.lookup_mind_specif (env()) ind let lookup_mind kn = lookup_mind kn (env()) let lookup_module mp = lookup_module mp (env()) let lookup_modtype kn = lookup_modtype kn (env()) let exists_objlabel id = Safe_typing.exists_objlabel id (safe_env ()) let opaque_tables () = Environ.opaque_tables (env ()) let body_of_constant_body cb = Declareops.body_of_constant (opaque_tables ()) cb let body_of_constant cst = body_of_constant_body (lookup_constant cst) let constraints_of_constant_body cb = Declareops.constraints_of_constant (opaque_tables ()) cb let universes_of_constant_body cb = Declareops.universes_of_constant (opaque_tables ()) cb (** Operations on kernel names *) let constant_of_delta_kn kn = let resolver,resolver_param = Safe_typing.delta_of_senv (safe_env ()) in (* TODO : are resolver and resolver_param orthogonal ? the effect of resolver is lost if resolver_param isn't trivial at that spot. *) Mod_subst.constant_of_deltas_kn resolver_param resolver kn let mind_of_delta_kn kn = let resolver,resolver_param = Safe_typing.delta_of_senv (safe_env ()) in (* TODO idem *) Mod_subst.mind_of_deltas_kn resolver_param resolver kn (** Operations on libraries *) let start_library dir = globalize (Safe_typing.start_library dir) let export ?except s = Safe_typing.export ?except (safe_env ()) s let import c u d = globalize (Safe_typing.import c u d) (** Function to get an environment from the constants part of the global environment and a given context. *) let env_of_context hyps = reset_with_named_context hyps (env()) open Globnames (** Build a fresh instance for a given context, its associated substitution and the instantiated constraints. *) let type_of_global_unsafe r = let env = env() in match r with | VarRef id -> Environ.named_type id env | ConstRef c -> let cb = Environ.lookup_constant c env in let univs = Declareops.universes_of_polymorphic_constant (Environ.opaque_tables env) cb in let ty = Typeops.type_of_constant_type env cb.Declarations.const_type in Vars.subst_instance_constr (Univ.UContext.instance univs) ty | IndRef ind -> let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in let inst = if mib.Declarations.mind_polymorphic then Univ.UContext.instance mib.Declarations.mind_universes else Univ.Instance.empty in Inductive.type_of_inductive env (specif, inst) | ConstructRef cstr -> let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in let inst = Univ.UContext.instance mib.Declarations.mind_universes in Inductive.type_of_constructor (cstr,inst) specif let type_of_global_in_context env r = let open Declarations in match r with | VarRef id -> Environ.named_type id env, Univ.UContext.empty | ConstRef c -> let cb = Environ.lookup_constant c env in let univs = Declareops.universes_of_polymorphic_constant (Environ.opaque_tables env) cb in Typeops.type_of_constant_type env cb.Declarations.const_type, univs | IndRef ind -> let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in let univs = if mib.mind_polymorphic then Univ.instantiate_univ_context mib.mind_universes else Univ.UContext.empty in Inductive.type_of_inductive env (specif, Univ.UContext.instance univs), univs | ConstructRef cstr -> let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in let univs = if mib.mind_polymorphic then Univ.instantiate_univ_context mib.mind_universes else Univ.UContext.empty in let inst = Univ.UContext.instance univs in Inductive.type_of_constructor (cstr,inst) specif, univs let universes_of_global env r = let open Declarations in match r with | VarRef id -> Univ.UContext.empty | ConstRef c -> let cb = Environ.lookup_constant c env in Declareops.universes_of_polymorphic_constant (Environ.opaque_tables env) cb | IndRef ind -> let (mib, oib) = Inductive.lookup_mind_specif env ind in Univ.instantiate_univ_context mib.mind_universes | ConstructRef cstr -> let (mib,oib) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in Univ.instantiate_univ_context mib.mind_universes let universes_of_global gr = universes_of_global (env ()) gr let is_polymorphic r = let env = env() in match r with | VarRef id -> false | ConstRef c -> Environ.polymorphic_constant c env | IndRef ind -> Environ.polymorphic_ind ind env | ConstructRef cstr -> Environ.polymorphic_ind (inductive_of_constructor cstr) env let is_template_polymorphic r = let env = env() in match r with | VarRef id -> false | ConstRef c -> Environ.template_polymorphic_constant c env | IndRef ind -> Environ.template_polymorphic_ind ind env | ConstructRef cstr -> Environ.template_polymorphic_ind (inductive_of_constructor cstr) env let is_type_in_type r = let env = env() in match r with | VarRef id -> false | ConstRef c -> Environ.type_in_type_constant c env | IndRef ind -> Environ.type_in_type_ind ind env | ConstructRef cstr -> Environ.type_in_type_ind (inductive_of_constructor cstr) env let current_dirpath () = Safe_typing.current_dirpath (safe_env ()) let with_global f = let (a, ctx) = f (env ()) (current_dirpath ()) in push_context_set false ctx; a (* spiwack: register/unregister functions for retroknowledge *) let register field value by_clause = globalize0 (Safe_typing.register field value by_clause) let register_inline c = globalize0 (Safe_typing.register_inline c) let set_strategy k l = GlobalSafeEnv.set_safe_env (Safe_typing.set_strategy (safe_env ()) k l) coq-8.6/library/declare.ml0000644000175000017500000004721413022274260015064 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Global.push_context_set false ctx | Inr (id,(p,d,mk)) -> (* Constr raisonne sur les noms courts *) if variable_exists id then alreadydeclared (pr_id id ++ str " already exists"); let impl,opaq,poly,ctx = match d with (* Fails if not well-typed *) | SectionLocalAssum ((ty,ctx),poly,impl) -> let () = Global.push_named_assum ((id,ty,poly),ctx) in let impl = if impl then Implicit else Explicit in impl, true, poly, ctx | SectionLocalDef (de) -> let univs = Global.push_named_def (id,de) in Explicit, de.const_entry_opaque, de.const_entry_polymorphic, univs in Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); add_section_variable id impl poly ctx; Dischargedhypsmap.set_discharged_hyps sp []; add_variable_data id (p,opaq,ctx,poly,mk) let discharge_variable (_,o) = match o with | Inr (id,_) -> if variable_polymorphic id then None else Some (Inl (variable_context id)) | Inl _ -> Some o type variable_obj = (Univ.ContextSet.t, Id.t * variable_declaration) union let inVariable : variable_obj -> obj = declare_object { (default_object "VARIABLE") with cache_function = cache_variable; discharge_function = discharge_variable; classify_function = (fun _ -> Dispose) } (* for initial declaration *) let declare_variable id obj = let oname = add_leaf id (inVariable (Inr (id,obj))) in declare_var_implicits id; Notation.declare_ref_arguments_scope (VarRef id); Heads.declare_head (EvalVarRef id); if_xml (Hook.get f_xml_declare_variable) oname; oname (** Declaration of constants and parameters *) type constant_obj = { cst_decl : global_declaration; cst_hyps : Dischargedhypsmap.discharged_hyps; cst_kind : logical_kind; cst_locl : bool; mutable cst_exported : Safe_typing.exported_private_constant list; (* mutable: to avoid change the libobject API, since cache_function * does not return an updated object *) mutable cst_was_seff : bool } type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind (* At load-time, the segment starting from the module name to the discharge *) (* section (if Remark or Fact) is needed to access a construction *) let load_constant i ((sp,kn), obj) = if Nametab.exists_cci sp then alreadydeclared (pr_id (basename sp) ++ str " already exists"); let con = Global.constant_of_delta_kn kn in Nametab.push (Nametab.Until i) sp (ConstRef con); add_constant_kind con obj.cst_kind (* Opening means making the name without its module qualification available *) let open_constant i ((sp,kn), obj) = (** Never open a local definition *) if obj.cst_locl then () else let con = Global.constant_of_delta_kn kn in Nametab.push (Nametab.Exactly i) sp (ConstRef con); match (Global.lookup_constant con).const_body with | (Def _ | Undef _) -> () | OpaqueDef lc -> match Opaqueproof.get_constraints (Global.opaque_tables ()) lc with | Some f when Future.is_val f -> Global.push_context_set false (Future.force f) | _ -> () let exists_name id = variable_exists id || Global.exists_objlabel (Label.of_id id) let check_exists sp = let id = basename sp in if exists_name id then alreadydeclared (pr_id id ++ str " already exists") let cache_constant ((sp,kn), obj) = let id = basename sp in let _,dir,_ = repr_kn kn in let kn' = if obj.cst_was_seff then begin obj.cst_was_seff <- false; if Global.exists_objlabel (Label.of_id (basename sp)) then constant_of_kn kn else CErrors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp)) end else let () = check_exists sp in let kn', exported = Global.add_constant dir id obj.cst_decl in obj.cst_exported <- exported; kn' in assert (eq_constant kn' (constant_of_kn kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (constant_of_kn kn)); let cst = Global.lookup_constant kn' in add_section_constant cst.const_polymorphic kn' cst.const_hyps; Dischargedhypsmap.set_discharged_hyps sp obj.cst_hyps; add_constant_kind (constant_of_kn kn) obj.cst_kind let discharged_hyps kn sechyps = let (_,dir,_) = repr_kn kn in let args = Array.to_list (instance_from_variable_context sechyps) in List.rev_map (Libnames.make_path dir) args let discharge_constant ((sp, kn), obj) = let con = constant_of_kn kn in let from = Global.lookup_constant con in let modlist = replacement_context () in let hyps,subst,uctx = section_segment_of_constant con in let new_hyps = (discharged_hyps kn hyps) @ obj.cst_hyps in let abstract = (named_of_variable_context hyps, subst, uctx) in let new_decl = GlobalRecipe{ from; info = { Opaqueproof.modlist; abstract}} in Some { obj with cst_hyps = new_hyps; cst_decl = new_decl; } (* Hack to reduce the size of .vo: we keep only what load/open needs *) let dummy_constant_entry = ConstantEntry (false, ParameterEntry (None,false,(mkProp,Univ.UContext.empty),None)) let dummy_constant cst = { cst_decl = dummy_constant_entry; cst_hyps = []; cst_kind = cst.cst_kind; cst_locl = cst.cst_locl; cst_exported = []; cst_was_seff = cst.cst_was_seff; } let classify_constant cst = Substitute (dummy_constant cst) let (inConstant, outConstant : (constant_obj -> obj) * (obj -> constant_obj)) = declare_object_full { (default_object "CONSTANT") with cache_function = cache_constant; load_function = load_constant; open_function = open_constant; classify_function = classify_constant; subst_function = ident_subst_function; discharge_function = discharge_constant } let declare_scheme = ref (fun _ _ -> assert false) let set_declare_scheme f = declare_scheme := f let declare_constant_common id cst = let update_tables c = (* Printf.eprintf "tables: %s\n%!" (Names.Constant.to_string c); *) declare_constant_implicits c; Heads.declare_head (EvalConstRef c); Notation.declare_ref_arguments_scope (ConstRef c) in let o = inConstant cst in let _, kn as oname = add_leaf id o in List.iter (fun (c,ce,role) -> (* handling of private_constants just exported *) let o = inConstant { cst_decl = ConstantEntry (false, ce); cst_hyps = [] ; cst_kind = IsProof Theorem; cst_locl = false; cst_exported = []; cst_was_seff = true; } in let id = Label.to_id (pi3 (Constant.repr3 c)) in ignore(add_leaf id o); update_tables c; let () = if_xml (Hook.get f_xml_declare_constant) (InternalTacticRequest, c) in match role with | Safe_typing.Subproof -> () | Safe_typing.Schema (ind, kind) -> !declare_scheme kind [|ind,c|]) (outConstant o).cst_exported; pull_to_head oname; let c = Global.constant_of_delta_kn kn in update_tables c; c let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types ?(poly=false) ?(univs=Univ.UContext.empty) ?(eff=Safe_typing.empty_private_constants) body = { const_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), eff); const_entry_secctx = None; const_entry_type = types; const_entry_polymorphic = poly; const_entry_universes = univs; const_entry_opaque = opaque; const_entry_feedback = None; const_entry_inline_code = inline} let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = let export = (* We deal with side effects *) match cd with | DefinitionEntry de when export_seff || not de.const_entry_opaque || de.const_entry_polymorphic -> let bo = de.const_entry_body in let _, seff = Future.force bo in Safe_typing.empty_private_constants <> seff | _ -> false in let cst = { cst_decl = ConstantEntry (export,cd); cst_hyps = [] ; cst_kind = kind; cst_locl = local; cst_exported = []; cst_was_seff = false; } in let kn = declare_constant_common id cst in let () = if_xml (Hook.get f_xml_declare_constant) (internal, kn) in kn let declare_definition ?(internal=UserIndividualRequest) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) ?(poly=false) id ?types (body,ctx) = let cb = definition_entry ?types ~poly ~univs:(Univ.ContextSet.to_context ctx) ~opaque body in declare_constant ~internal ~local id (Entries.DefinitionEntry cb, Decl_kinds.IsDefinition kind) (** Declaration of inductive blocks *) let declare_inductive_argument_scopes kn mie = List.iteri (fun i {mind_entry_consnames=lc} -> Notation.declare_ref_arguments_scope (IndRef (kn,i)); for j=1 to List.length lc do Notation.declare_ref_arguments_scope (ConstructRef ((kn,i),j)); done) mie.mind_entry_inds let inductive_names sp kn mie = let (dp,_) = repr_path sp in let kn = Global.mind_of_delta_kn kn in let names, _ = List.fold_left (fun (names, n) ind -> let ind_p = (kn,n) in let names, _ = List.fold_left (fun (names, p) l -> let sp = Libnames.make_path dp l in ((sp, ConstructRef (ind_p,p)) :: names, p+1)) (names, 1) ind.mind_entry_consnames in let sp = Libnames.make_path dp ind.mind_entry_typename in ((sp, IndRef ind_p) :: names, n+1)) ([], 0) mie.mind_entry_inds in names let load_inductive i ((sp,kn),(_,mie)) = let names = inductive_names sp kn mie in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until i) sp ref ) names let open_inductive i ((sp,kn),(_,mie)) = let names = inductive_names sp kn mie in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Exactly i) sp ref) names let cache_inductive ((sp,kn),(dhyps,mie)) = let names = inductive_names sp kn mie in List.iter check_exists (List.map fst names); let id = basename sp in let _,dir,_ = repr_kn kn in let kn' = Global.add_mind dir id mie in assert (eq_mind kn' (mind_of_kn kn)); let mind = Global.lookup_mind kn' in add_section_kn mind.mind_polymorphic kn' mind.mind_hyps; Dischargedhypsmap.set_discharged_hyps sp dhyps; List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names let discharge_inductive ((sp,kn),(dhyps,mie)) = let mind = Global.mind_of_delta_kn kn in let mie = Global.lookup_mind mind in let repl = replacement_context () in let sechyps,usubst,uctx = section_segment_of_mutual_inductive mind in Some (discharged_hyps kn sechyps, Discharge.process_inductive (named_of_variable_context sechyps,uctx) repl mie) let dummy_one_inductive_entry mie = { mind_entry_typename = mie.mind_entry_typename; mind_entry_arity = mkProp; mind_entry_template = false; mind_entry_consnames = mie.mind_entry_consnames; mind_entry_lc = [] } (* Hack to reduce the size of .vo: we keep only what load/open needs *) let dummy_inductive_entry (_,m) = ([],{ mind_entry_params = []; mind_entry_record = None; mind_entry_finite = Decl_kinds.BiFinite; mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds; mind_entry_polymorphic = false; mind_entry_universes = Univ.UContext.empty; mind_entry_private = None; }) type inductive_obj = Dischargedhypsmap.discharged_hyps * mutual_inductive_entry let inInductive : inductive_obj -> obj = declare_object {(default_object "INDUCTIVE") with cache_function = cache_inductive; load_function = load_inductive; open_function = open_inductive; classify_function = (fun a -> Substitute (dummy_inductive_entry a)); subst_function = ident_subst_function; discharge_function = discharge_inductive } let declare_projections mind = let spec,_ = Inductive.lookup_mind_specif (Global.env ()) (mind,0) in match spec.mind_record with | Some (Some (_, kns, pjs)) -> Array.iteri (fun i kn -> let id = Label.to_id (Constant.label kn) in let entry = {proj_entry_ind = mind; proj_entry_arg = i} in let kn' = declare_constant id (ProjectionEntry entry, IsDefinition StructureComponent) in assert(eq_constant kn kn')) kns; true,true | Some None -> true,false | None -> false,false (* for initial declaration *) let declare_mind mie = let id = match mie.mind_entry_inds with | ind::_ -> ind.mind_entry_typename | [] -> anomaly (Pp.str "cannot declare an empty list of inductives") in let (sp,kn as oname) = add_leaf id (inInductive ([],mie)) in let mind = Global.mind_of_delta_kn kn in let isrecord,isprim = declare_projections mind in declare_mib_implicits mind; declare_inductive_argument_scopes mind mie; if_xml (Hook.get f_xml_declare_inductive) (isrecord,oname); oname, isprim (* Declaration messages *) let pr_rank i = pr_nth (i+1) let fixpoint_message indexes l = Flags.if_verbose Feedback.msg_info (match l with | [] -> anomaly (Pp.str "no recursive definition") | [id] -> pr_id id ++ str " is recursively defined" ++ (match indexes with | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)" | _ -> mt ()) | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++ spc () ++ str "are recursively defined" ++ match indexes with | Some a -> spc () ++ str "(decreasing respectively on " ++ prvect_with_sep pr_comma pr_rank a ++ str " arguments)" | None -> mt ())) let cofixpoint_message l = Flags.if_verbose Feedback.msg_info (match l with | [] -> anomaly (Pp.str "No corecursive definition.") | [id] -> pr_id id ++ str " is corecursively defined" | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++ spc () ++ str "are corecursively defined")) let recursive_message isfix i l = (if isfix then fixpoint_message i else cofixpoint_message) l let definition_message id = Flags.if_verbose Feedback.msg_info (pr_id id ++ str " is defined") let assumption_message id = (* Changing "assumed" to "declared", "assuming" referring more to the type of the object than to the name of the object (see discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) Flags.if_verbose Feedback.msg_info (pr_id id ++ str " is declared") (** Global universe names, in a different summary *) type universe_context_decl = polymorphic * Univ.universe_context_set let cache_universe_context (p, ctx) = Global.push_context_set p ctx; if p then Lib.add_section_context ctx let input_universe_context : universe_context_decl -> Libobject.obj = declare_object { (default_object "Global universe context state") with cache_function = (fun (na, pi) -> cache_universe_context pi); load_function = (fun _ (_, pi) -> cache_universe_context pi); discharge_function = (fun (_, (p, _ as x)) -> if p then None else Some x); classify_function = (fun a -> Keep a) } let declare_universe_context poly ctx = Lib.add_anonymous_leaf (input_universe_context (poly, ctx)) (* Discharged or not *) type universe_decl = polymorphic * (Id.t * Univ.universe_level) list let cache_universes (p, l) = let glob = Universes.global_universe_names () in let glob', ctx = List.fold_left (fun ((idl,lid),ctx) (id, lev) -> ((Idmap.add id (p, lev) idl, Univ.LMap.add lev id lid), Univ.ContextSet.add_universe lev ctx)) (glob, Univ.ContextSet.empty) l in cache_universe_context (p, ctx); Universes.set_global_universe_names glob' let input_universes : universe_decl -> Libobject.obj = declare_object { (default_object "Global universe name state") with cache_function = (fun (na, pi) -> cache_universes pi); load_function = (fun _ (_, pi) -> cache_universes pi); discharge_function = (fun (_, (p, _ as x)) -> if p then None else Some x); classify_function = (fun a -> Keep a) } let do_universe poly l = let in_section = Lib.sections_are_opened () in let () = if poly && not in_section then user_err_loc (Loc.ghost, "Constraint", str"Cannot declare polymorphic universes outside sections") in let l = List.map (fun (l, id) -> let lev = Universes.new_univ_level (Global.current_dirpath ()) in (id, lev)) l in Lib.add_anonymous_leaf (input_universes (poly, l)) type constraint_decl = polymorphic * Univ.constraints let cache_constraints (na, (p, c)) = let ctx = Univ.ContextSet.add_constraints c Univ.ContextSet.empty (* No declared universes here, just constraints *) in cache_universe_context (p,ctx) let discharge_constraints (_, (p, c as a)) = if p then None else Some a let input_constraints : constraint_decl -> Libobject.obj = let open Libobject in declare_object { (default_object "Global universe constraints") with cache_function = cache_constraints; load_function = (fun _ -> cache_constraints); discharge_function = discharge_constraints; classify_function = (fun a -> Keep a) } let do_constraint poly l = let open Misctypes in let u_of_id x = match x with | GProp -> Loc.dummy_loc, (false, Univ.Level.prop) | GSet -> Loc.dummy_loc, (false, Univ.Level.set) | GType None -> user_err_loc (Loc.dummy_loc, "Constraint", str "Cannot declare constraints on anonymous universes") | GType (Some (loc, id)) -> let id = Id.of_string id in let names, _ = Universes.global_universe_names () in try loc, Idmap.find id names with Not_found -> user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id) in let in_section = Lib.sections_are_opened () in let () = if poly && not in_section then user_err_loc (Loc.ghost, "Constraint", str"Cannot declare polymorphic constraints outside sections") in let check_poly loc p loc' p' = if poly then () else if p || p' then let loc = if p then loc else loc' in user_err_loc (loc, "Constraint", str "Cannot declare a global constraint on " ++ str "a polymorphic universe, use " ++ str "Polymorphic Constraint instead") in let constraints = List.fold_left (fun acc (l, d, r) -> let ploc, (p, lu) = u_of_id l and rloc, (p', ru) = u_of_id r in check_poly ploc p rloc p'; Univ.Constraint.add (lu, d, ru) acc) Univ.Constraint.empty l in Lib.add_anonymous_leaf (input_constraints (poly, constraints)) coq-8.6/library/dischargedhypsmap.ml0000644000175000017500000000152313022274260017155 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [] coq-8.6/library/lib.ml0000644000175000017500000005206613022274260014234 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* f i (make_oname prefix id, obj)) let load_objects i pr = iter_objects load_object i pr let open_objects i pr = iter_objects open_object i pr let subst_objects subst seg = let subst_one = fun (id,obj as node) -> let obj' = subst_object (subst,obj) in if obj' == obj then node else (id, obj') in List.smartmap subst_one seg (*let load_and_subst_objects i prefix subst seg = List.rev (List.fold_left (fun seg (id,obj as node) -> let obj' = subst_object (make_oname prefix id, subst, obj) in let node = if obj == obj' then node else (id, obj') in load_object i (make_oname prefix id, obj'); node :: seg) [] seg) *) let classify_segment seg = let rec clean ((substl,keepl,anticipl) as acc) = function | (_,CompilingLibrary _) :: _ | [] -> acc | ((sp,kn),Leaf o) :: stk -> let id = Names.Label.to_id (Names.label kn) in (match classify_object o with | Dispose -> clean acc stk | Keep o' -> clean (substl, (id,o')::keepl, anticipl) stk | Substitute o' -> clean ((id,o')::substl, keepl, anticipl) stk | Anticipate o' -> clean (substl, keepl, o'::anticipl) stk) | (_,ClosedSection _) :: stk -> clean acc stk (* LEM; TODO: Understand what this does and see if what I do is the correct thing for ClosedMod(ule|type) *) | (_,ClosedModule _) :: stk -> clean acc stk | (_,OpenedSection _) :: _ -> error "there are still opened sections" | (_,OpenedModule (ty,_,_,_)) :: _ -> errorlabstrm "Lib.classify_segment" (str "there are still opened " ++ str (module_kind ty) ++ str "s") | (_,FrozenState _) :: stk -> clean acc stk in clean ([],[],[]) (List.rev seg) let segment_of_objects prefix = List.map (fun (id,obj) -> (make_oname prefix id, Leaf obj)) (* We keep trace of operations in the stack [lib_stk]. [path_prefix] is the current path of sections, where sections are stored in ``correct'' order, the oldest coming first in the list. It may seems costly, but in practice there is not so many openings and closings of sections, but on the contrary there are many constructions of section paths based on the library path. *) let initial_prefix = default_library,(Names.initial_path,Names.DirPath.empty) let lib_stk = ref ([] : library_segment) let comp_name = ref None let library_dp () = match !comp_name with Some m -> m | None -> default_library (* [path_prefix] is a pair of absolute dirpath and a pair of current module path and relative section path *) let path_prefix = ref initial_prefix let cwd () = fst !path_prefix let current_prefix () = snd !path_prefix let current_mp () = fst (snd !path_prefix) let current_sections () = snd (snd !path_prefix) let sections_depth () = List.length (Names.DirPath.repr (current_sections ())) let sections_are_opened () = not (Names.DirPath.is_empty (current_sections ())) let cwd_except_section () = Libnames.pop_dirpath_n (sections_depth ()) (cwd ()) let current_dirpath sec = Libnames.drop_dirpath_prefix (library_dp ()) (if sec then cwd () else cwd_except_section ()) let make_path id = Libnames.make_path (cwd ()) id let make_path_except_section id = Libnames.make_path (cwd_except_section ()) id let make_kn id = let mp,dir = current_prefix () in Names.make_kn mp dir (Names.Label.of_id id) let make_oname id = Libnames.make_oname !path_prefix id let recalc_path_prefix () = let rec recalc = function | (sp, OpenedSection (dir,_)) :: _ -> dir | (sp, OpenedModule (_,_,dir,_)) :: _ -> dir | (sp, CompilingLibrary dir) :: _ -> dir | _::l -> recalc l | [] -> initial_prefix in path_prefix := recalc !lib_stk let pop_path_prefix () = let dir,(mp,sec) = !path_prefix in path_prefix := pop_dirpath dir, (mp, pop_dirpath sec) let find_entry_p p = let rec find = function | [] -> raise Not_found | ent::l -> if p ent then ent else find l in find !lib_stk let split_lib_gen test = let rec collect after equal = function | hd::before when test hd -> collect after (hd::equal) before | before -> after,equal,before in let rec findeq after = function | hd :: before -> if test hd then Some (collect after [hd] before) else (match hd with | (sp,ClosedModule seg) | (sp,ClosedSection seg) -> (match findeq after seg with | None -> findeq (hd::after) before | Some (sub_after,sub_equal,sub_before) -> Some (sub_after, sub_equal, (List.append sub_before before))) | _ -> findeq (hd::after) before) | [] -> None in match findeq [] !lib_stk with | None -> error "no such entry" | Some r -> r let eq_object_name (fp1, kn1) (fp2, kn2) = eq_full_path fp1 fp2 && Names.KerName.equal kn1 kn2 let split_lib sp = let is_sp (nsp, _) = eq_object_name sp nsp in split_lib_gen is_sp let split_lib_at_opening sp = let is_sp (nsp, obj) = match obj with | OpenedSection _ | OpenedModule _ | CompilingLibrary _ -> eq_object_name nsp sp | _ -> false in let a, s, b = split_lib_gen is_sp in match s with | [obj] -> (a, obj, b) | _ -> assert false (* Adding operations. *) let add_entry sp node = lib_stk := (sp,node) :: !lib_stk let pull_to_head oname = lib_stk := (oname,List.assoc oname !lib_stk) :: List.remove_assoc oname !lib_stk let anonymous_id = let n = ref 0 in fun () -> incr n; Names.Id.of_string ("_" ^ (string_of_int !n)) let add_anonymous_entry node = add_entry (make_oname (anonymous_id ())) node let add_leaf id obj = if Names.ModPath.equal (current_mp ()) Names.initial_path then error ("No session module started (use -top dir)"); let oname = make_oname id in cache_object (oname,obj); add_entry oname (Leaf obj); oname let add_discharged_leaf id obj = let oname = make_oname id in let newobj = rebuild_object obj in cache_object (oname,newobj); add_entry oname (Leaf newobj) let add_leaves id objs = let oname = make_oname id in let add_obj obj = add_entry oname (Leaf obj); load_object 1 (oname,obj) in List.iter add_obj objs; oname let add_anonymous_leaf ?(cache_first = true) obj = let id = anonymous_id () in let oname = make_oname id in if cache_first then begin cache_object (oname,obj); add_entry oname (Leaf obj) end else begin add_entry oname (Leaf obj); cache_object (oname,obj) end let add_frozen_state () = add_anonymous_entry (FrozenState (Summary.freeze_summaries ~marshallable:`No)) (* Modules. *) let is_opening_node = function | _,(OpenedSection _ | OpenedModule _) -> true | _ -> false let is_opening_node_or_lib = function | _,(CompilingLibrary _ | OpenedSection _ | OpenedModule _) -> true | _ -> false let current_mod_id () = try match find_entry_p is_opening_node_or_lib with | oname,OpenedModule (_,_,_,fs) -> basename (fst oname) | oname,CompilingLibrary _ -> basename (fst oname) | _ -> error "you are not in a module" with Not_found -> error "no opened modules" let start_mod is_type export id mp fs = let dir = add_dirpath_suffix (cwd ()) id in let prefix = dir,(mp,Names.DirPath.empty) in let exists = if is_type then Nametab.exists_cci (make_path id) else Nametab.exists_module dir in if exists then errorlabstrm "open_module" (pr_id id ++ str " already exists"); add_entry (make_oname id) (OpenedModule (is_type,export,prefix,fs)); path_prefix := prefix; prefix let start_module = start_mod false let start_modtype = start_mod true None let error_still_opened string oname = let id = basename (fst oname) in errorlabstrm "" (str "The " ++ str string ++ str " " ++ pr_id id ++ str " is still opened.") let end_mod is_type = let oname,fs = try match find_entry_p is_opening_node with | oname,OpenedModule (ty,_,_,fs) -> if ty == is_type then oname, fs else error_still_opened (module_kind ty) oname | oname,OpenedSection _ -> error_still_opened "section" oname | _ -> assert false with Not_found -> error "No opened modules." in let (after,mark,before) = split_lib_at_opening oname in lib_stk := before; add_entry oname (ClosedModule (List.rev (mark::after))); let prefix = !path_prefix in recalc_path_prefix (); (oname, prefix, fs, after) let end_module () = end_mod false let end_modtype () = end_mod true let contents () = !lib_stk let contents_after sp = let (after,_,_) = split_lib sp in after (* Modules. *) (* TODO: use check_for_module ? *) let start_compilation s mp = if !comp_name != None then error "compilation unit is already started"; if not (Names.DirPath.is_empty (current_sections ())) then error "some sections are already opened"; let prefix = s, (mp, Names.DirPath.empty) in let () = add_anonymous_entry (CompilingLibrary prefix) in comp_name := Some s; path_prefix := prefix let end_compilation_checks dir = let _ = try match snd (find_entry_p is_opening_node) with | OpenedSection _ -> error "There are some open sections." | OpenedModule (ty,_,_,_) -> errorlabstrm "Lib.end_compilation_checks" (str "There are some open " ++ str (module_kind ty) ++ str "s.") | _ -> assert false with Not_found -> () in let is_opening_lib = function _,CompilingLibrary _ -> true | _ -> false in let oname = try match find_entry_p is_opening_lib with | (oname, CompilingLibrary prefix) -> oname | _ -> assert false with Not_found -> anomaly (Pp.str "No module declared") in let _ = match !comp_name with | None -> anomaly (Pp.str "There should be a module name...") | Some m -> if not (Names.DirPath.equal m dir) then anomaly (str "The current open module has name" ++ spc () ++ pr_dirpath m ++ spc () ++ str "and not" ++ spc () ++ pr_dirpath m); in oname let end_compilation oname = let (after,mark,before) = split_lib_at_opening oname in comp_name := None; !path_prefix,after (* Returns true if we are inside an opened module or module type *) let is_module_gen which check = let test = function | _, OpenedModule (ty,_,_,_) -> which ty | _ -> false in try match find_entry_p test with | _, OpenedModule (ty,_,_,_) -> check ty | _ -> assert false with Not_found -> false let is_module_or_modtype () = is_module_gen (fun _ -> true) (fun _ -> true) let is_modtype () = is_module_gen (fun b -> b) (fun _ -> true) let is_modtype_strict () = is_module_gen (fun _ -> true) (fun b -> b) let is_module () = is_module_gen (fun b -> not b) (fun _ -> true) (* Returns the opening node of a given name *) let find_opening_node id = try let oname,entry = find_entry_p is_opening_node in let id' = basename (fst oname) in if not (Names.Id.equal id id') then errorlabstrm "Lib.find_opening_node" (str "Last block to end has name " ++ pr_id id' ++ str "."); entry with Not_found -> error "There is nothing to end." (* Discharge tables *) (* At each level of section, we remember - the list of variables in this section - the list of variables on which each constant depends in this section - the list of variables on which each inductive depends in this section - the list of substitution to do at section closing *) type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types type variable_context = variable_info list type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t type abstr_list = abstr_info Names.Cmap.t * abstr_info Names.Mindmap.t type secentry = | Variable of (Names.Id.t * Decl_kinds.binding_kind * Decl_kinds.polymorphic * Univ.universe_context_set) | Context of Univ.universe_context_set let sectab = Summary.ref ([] : (secentry list * Opaqueproof.work_list * abstr_list) list) ~name:"section-context" let add_section () = sectab := ([],(Names.Cmap.empty,Names.Mindmap.empty), (Names.Cmap.empty,Names.Mindmap.empty)) :: !sectab let check_same_poly p vars = let pred = function Context _ -> p = false | Variable (_, _, poly, _) -> p != poly in if List.exists pred vars then error "Cannot mix universe polymorphic and monomorphic declarations in sections." let add_section_variable id impl poly ctx = match !sectab with | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) | (vars,repl,abs)::sl -> List.iter (fun tab -> check_same_poly poly (pi1 tab)) !sectab; sectab := (Variable (id,impl,poly,ctx)::vars,repl,abs)::sl let add_section_context ctx = match !sectab with | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) | (vars,repl,abs)::sl -> check_same_poly true vars; sectab := (Context ctx :: vars,repl,abs)::sl let extract_hyps (secs,ohyps) = let open Context.Named.Declaration in let rec aux = function | (Variable (id,impl,poly,ctx)::idl, decl::hyps) when Names.Id.equal id (get_id decl) -> let (id',b,t) = to_tuple decl in let l, r = aux (idl,hyps) in (id',impl,b,t) :: l, if poly then Univ.ContextSet.union r ctx else r | (Variable (_,_,poly,ctx)::idl,hyps) -> let l, r = aux (idl,hyps) in l, if poly then Univ.ContextSet.union r ctx else r | (Context ctx :: idl, hyps) -> let l, r = aux (idl, hyps) in l, Univ.ContextSet.union r ctx | [], _ -> [],Univ.ContextSet.empty in aux (secs,ohyps) let instance_from_variable_context sign = let rec inst_rec = function | (id,b,None,_) :: sign -> id :: inst_rec sign | _ :: sign -> inst_rec sign | [] -> [] in Array.of_list (inst_rec sign) let named_of_variable_context ctx = let open Context.Named.Declaration in List.map (function id,_,None,t -> LocalAssum (id,t) | id,_,Some b,t -> LocalDef (id,b,t)) ctx let add_section_replacement f g poly hyps = match !sectab with | [] -> () | (vars,exps,abs)::sl -> let () = check_same_poly poly vars in let sechyps,ctx = extract_hyps (vars,hyps) in let ctx = Univ.ContextSet.to_context ctx in let subst, ctx = Univ.abstract_universes true ctx in let args = instance_from_variable_context (List.rev sechyps) in sectab := (vars,f (Univ.UContext.instance ctx,args) exps, g (sechyps,subst,ctx) abs)::sl let add_section_kn poly kn = let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in add_section_replacement f f poly let add_section_constant poly kn = let f x (l1,l2) = (Names.Cmap.add kn x l1,l2) in add_section_replacement f f poly let replacement_context () = pi2 (List.hd !sectab) let section_segment_of_constant con = Names.Cmap.find con (fst (pi3 (List.hd !sectab))) let section_segment_of_mutual_inductive kn = Names.Mindmap.find kn (snd (pi3 (List.hd !sectab))) let variable_section_segment_of_reference = function | ConstRef con -> pi1 (section_segment_of_constant con) | IndRef (kn,_) | ConstructRef ((kn,_),_) -> pi1 (section_segment_of_mutual_inductive kn) | _ -> [] let section_instance = function | VarRef id -> let eq = function | Variable (id',_,_,_) -> Names.id_eq id id' | Context _ -> false in if List.exists eq (pi1 (List.hd !sectab)) then Univ.Instance.empty, [||] else raise Not_found | ConstRef con -> Names.Cmap.find con (fst (pi2 (List.hd !sectab))) | IndRef (kn,_) | ConstructRef ((kn,_),_) -> Names.Mindmap.find kn (snd (pi2 (List.hd !sectab))) let is_in_section ref = try ignore (section_instance ref); true with Not_found -> false (*************) (* Sections. *) (* XML output hooks *) let (f_xml_open_section, xml_open_section) = Hook.make ~default:ignore () let (f_xml_close_section, xml_close_section) = Hook.make ~default:ignore () let open_section id = let olddir,(mp,oldsec) = !path_prefix in let dir = add_dirpath_suffix olddir id in let prefix = dir, (mp, add_dirpath_suffix oldsec id) in if Nametab.exists_section dir then errorlabstrm "open_section" (pr_id id ++ str " already exists."); let fs = Summary.freeze_summaries ~marshallable:`No in add_entry (make_oname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix); path_prefix := prefix; if !Flags.xml_export then Hook.get f_xml_open_section id; add_section () (* Restore lib_stk and summaries as before the section opening, and add a ClosedSection object. *) let discharge_item ((sp,_ as oname),e) = match e with | Leaf lobj -> Option.map (fun o -> (basename sp,o)) (discharge_object (oname,lobj)) | FrozenState _ -> None | ClosedSection _ | ClosedModule _ -> None | OpenedSection _ | OpenedModule _ | CompilingLibrary _ -> anomaly (Pp.str "discharge_item") let close_section () = let oname,fs = try match find_entry_p is_opening_node with | oname,OpenedSection (_,fs) -> oname,fs | _ -> assert false with Not_found -> error "No opened section." in let (secdecls,mark,before) = split_lib_at_opening oname in lib_stk := before; let full_olddir = fst !path_prefix in pop_path_prefix (); add_entry oname (ClosedSection (List.rev (mark::secdecls))); if !Flags.xml_export then Hook.get f_xml_close_section (basename (fst oname)); let newdecls = List.map discharge_item secdecls in Summary.unfreeze_summaries fs; List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls; Nametab.push_dir (Nametab.Until 1) full_olddir (DirClosedSection full_olddir) (* State and initialization. *) type frozen = Names.DirPath.t option * library_segment let freeze ~marshallable = match marshallable with | `Shallow -> (* TASSI: we should do something more sensible here *) let lib_stk = CList.map_filter (function | _, Leaf _ -> None | n, (CompilingLibrary _ as x) -> Some (n,x) | n, OpenedModule (it,e,op,_) -> Some(n,OpenedModule(it,e,op,Summary.empty_frozen)) | n, ClosedModule _ -> Some (n,ClosedModule []) | n, OpenedSection (op, _) -> Some(n,OpenedSection(op,Summary.empty_frozen)) | n, ClosedSection _ -> Some (n,ClosedSection []) | _, FrozenState _ -> None) !lib_stk in !comp_name, lib_stk | _ -> !comp_name, !lib_stk let unfreeze (mn,stk) = comp_name := mn; lib_stk := stk; recalc_path_prefix () let init () = unfreeze (None,[]); Summary.init_summaries (); add_frozen_state () (* Stores e.g. the keywords declared in g_*.ml4 *) (* Misc *) let mp_of_global = function |VarRef id -> current_mp () |ConstRef cst -> Names.con_modpath cst |IndRef ind -> Names.ind_modpath ind |ConstructRef constr -> Names.constr_modpath constr let rec dp_of_mp = function |Names.MPfile dp -> dp |Names.MPbound _ -> library_dp () |Names.MPdot (mp,_) -> dp_of_mp mp let rec split_modpath = function |Names.MPfile dp -> dp, [] |Names.MPbound mbid -> library_dp (), [Names.MBId.to_id mbid] |Names.MPdot (mp,l) -> let (dp,ids) = split_modpath mp in (dp, Names.Label.to_id l :: ids) let library_part = function |VarRef id -> library_dp () |ref -> dp_of_mp (mp_of_global ref) (************************) (* Discharging names *) let con_defined_in_sec kn = let _,dir,_ = Names.repr_con kn in not (Names.DirPath.is_empty dir) && Names.DirPath.equal (pop_dirpath dir) (current_sections ()) let defined_in_sec kn = let _,dir,_ = Names.repr_mind kn in not (Names.DirPath.is_empty dir) && Names.DirPath.equal (pop_dirpath dir) (current_sections ()) let discharge_global = function | ConstRef kn when con_defined_in_sec kn -> ConstRef (Globnames.pop_con kn) | IndRef (kn,i) when defined_in_sec kn -> IndRef (Globnames.pop_kn kn,i) | ConstructRef ((kn,i),j) when defined_in_sec kn -> ConstructRef ((Globnames.pop_kn kn,i),j) | r -> r let discharge_kn kn = if defined_in_sec kn then Globnames.pop_kn kn else kn let discharge_con cst = if con_defined_in_sec cst then Globnames.pop_con cst else cst let discharge_inductive (kn,i) = (discharge_kn kn,i) coq-8.6/library/nametab.ml0000644000175000017500000004050213022274260015065 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> bool val to_string : t -> string val repr : t -> Id.t * module_ident list end module type EqualityType = sig type t val equal : t -> t -> bool end (* A ['a t] is a map from [user_name] to ['a], with possible lookup by partially qualified names of type [qualid]. The mapping of partially qualified names to ['a] is determined by the [visibility] parameter of [push]. The [shortest_qualid] function given a user_name Coq.A.B.x, tries to find the shortest among x, B.x, A.B.x and Coq.A.B.x that denotes the same object. *) module type NAMETREE = sig type elt type t type user_name val empty : t val push : visibility -> user_name -> elt -> t -> t val locate : qualid -> t -> elt val find : user_name -> t -> elt val exists : user_name -> t -> bool val user_name : qualid -> t -> user_name val shortest_qualid : Id.Set.t -> user_name -> t -> qualid val find_prefixes : qualid -> t -> elt list end module Make (U : UserName) (E : EqualityType) : NAMETREE with type user_name = U.t and type elt = E.t = struct type elt = E.t (* A name became inaccessible, even with absolute qualification. Example: Module F (X : S). Module X. The argument X of the functor F is masked by the inner module X. *) let masking_absolute n = Flags.if_verbose Feedback.msg_info (str ("Trying to mask the absolute name \"" ^ U.to_string n ^ "\"!")) type user_name = U.t type path_status = Nothing | Relative of user_name * elt | Absolute of user_name * elt (* Dictionaries of short names *) type nametree = { path : path_status; map : nametree ModIdmap.t } let mktree p m = { path=p; map=m } let empty_tree = mktree Nothing ModIdmap.empty type t = nametree Id.Map.t let empty = Id.Map.empty (* [push_until] is used to register [Until vis] visibility and [push_exactly] to [Exactly vis] and [push_tree] chooses the right one*) let rec push_until uname o level tree = function | modid :: path -> let modify _ mc = push_until uname o (level-1) mc path in let map = try ModIdmap.modify modid modify tree.map with Not_found -> let ptab = modify () empty_tree in ModIdmap.add modid ptab tree.map in let this = if level <= 0 then match tree.path with | Absolute (n,_) -> (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) masking_absolute n; tree.path | Nothing | Relative _ -> Relative (uname,o) else tree.path in mktree this map | [] -> match tree.path with | Absolute (uname',o') -> if E.equal o' o then begin assert (U.equal uname uname'); tree (* we are putting the same thing for the second time :) *) end else (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) (* But ours is also absolute! This is an error! *) error ("Cannot mask the absolute name \"" ^ U.to_string uname' ^ "\"!") | Nothing | Relative _ -> mktree (Absolute (uname,o)) tree.map let rec push_exactly uname o level tree = function | [] -> anomaly (Pp.str "Prefix longer than path! Impossible!") | modid :: path -> if Int.equal level 0 then let this = match tree.path with | Absolute (n,_) -> (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) masking_absolute n; tree.path | Nothing | Relative _ -> Relative (uname,o) in mktree this tree.map else (* not right level *) let modify _ mc = push_exactly uname o (level-1) mc path in let map = try ModIdmap.modify modid modify tree.map with Not_found -> let ptab = modify () empty_tree in ModIdmap.add modid ptab tree.map in mktree tree.path map let push visibility uname o tab = let id,dir = U.repr uname in let modify _ ptab = match visibility with | Until i -> push_until uname o (i-1) ptab dir | Exactly i -> push_exactly uname o (i-1) ptab dir in try Id.Map.modify id modify tab with Not_found -> let ptab = modify () empty_tree in Id.Map.add id ptab tab let rec search tree = function | modid :: path -> search (ModIdmap.find modid tree.map) path | [] -> tree.path let find_node qid tab = let (dir,id) = repr_qualid qid in search (Id.Map.find id tab) (DirPath.repr dir) let locate qid tab = let o = match find_node qid tab with | Absolute (uname,o) | Relative (uname,o) -> o | Nothing -> raise Not_found in o let user_name qid tab = let uname = match find_node qid tab with | Absolute (uname,o) | Relative (uname,o) -> uname | Nothing -> raise Not_found in uname let find uname tab = let id,l = U.repr uname in match search (Id.Map.find id tab) l with Absolute (_,o) -> o | _ -> raise Not_found let exists uname tab = try let _ = find uname tab in true with Not_found -> false let shortest_qualid ctx uname tab = let id,dir = U.repr uname in let hidden = Id.Set.mem id ctx in let rec find_uname pos dir tree = let is_empty = match pos with [] -> true | _ -> false in match tree.path with | Absolute (u,_) | Relative (u,_) when U.equal u uname && not (is_empty && hidden) -> List.rev pos | _ -> match dir with [] -> raise Not_found | id::dir -> find_uname (id::pos) dir (ModIdmap.find id tree.map) in let ptab = Id.Map.find id tab in let found_dir = find_uname [] dir ptab in make_qualid (DirPath.make found_dir) id let push_node node l = match node with | Absolute (_,o) | Relative (_,o) when not (List.mem_f E.equal o l) -> o::l | _ -> l let rec flatten_idmap tab l = let f _ tree l = flatten_idmap tree.map (push_node tree.path l) in ModIdmap.fold f tab l let rec search_prefixes tree = function | modid :: path -> search_prefixes (ModIdmap.find modid tree.map) path | [] -> List.rev (flatten_idmap tree.map (push_node tree.path [])) let find_prefixes qid tab = try let (dir,id) = repr_qualid qid in search_prefixes (Id.Map.find id tab) (DirPath.repr dir) with Not_found -> [] end (* Global name tables *************************************************) module FullPath = struct type t = full_path let equal = eq_full_path let to_string = string_of_path let repr sp = let dir,id = repr_path sp in id, (DirPath.repr dir) end module ExtRefEqual = ExtRefOrdered module KnEqual = Names.KerName module MPEqual = Names.ModPath module ExtRefTab = Make(FullPath)(ExtRefEqual) module KnTab = Make(FullPath)(KnEqual) module MPTab = Make(FullPath)(MPEqual) type ccitab = ExtRefTab.t let the_ccitab = ref (ExtRefTab.empty : ccitab) type kntab = KnTab.t let the_tactictab = ref (KnTab.empty : kntab) type mptab = MPTab.t let the_modtypetab = ref (MPTab.empty : mptab) module DirPath' = struct include DirPath let repr dir = match DirPath.repr dir with | [] -> anomaly (Pp.str "Empty dirpath") | id :: l -> (id, l) end module GlobDir = struct type t = global_dir_reference let equal = eq_global_dir_reference end module DirTab = Make(DirPath')(GlobDir) (* If we have a (closed) module M having a submodule N, than N does not have the entry in [the_dirtab]. *) type dirtab = DirTab.t let the_dirtab = ref (DirTab.empty : dirtab) (* Reversed name tables ***************************************************) (* This table translates extended_global_references back to section paths *) module Globrevtab = HMap.Make(ExtRefOrdered) type globrevtab = full_path Globrevtab.t let the_globrevtab = ref (Globrevtab.empty : globrevtab) type mprevtab = DirPath.t MPmap.t let the_modrevtab = ref (MPmap.empty : mprevtab) type mptrevtab = full_path MPmap.t let the_modtyperevtab = ref (MPmap.empty : mptrevtab) type knrevtab = full_path KNmap.t let the_tacticrevtab = ref (KNmap.empty : knrevtab) (* Push functions *********************************************************) (* This is for permanent constructions (never discharged -- but with possibly limited visibility, i.e. Theorem, Lemma, Definition, Axiom, Parameter but also Remark and Fact) *) let push_xref visibility sp xref = match visibility with | Until _ -> the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; the_globrevtab := Globrevtab.add xref sp !the_globrevtab | _ -> begin if ExtRefTab.exists sp !the_ccitab then match ExtRefTab.find sp !the_ccitab with | TrueGlobal( ConstRef _) | TrueGlobal( IndRef _) | TrueGlobal( ConstructRef _) as xref -> the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; | _ -> the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; else the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; end let push_cci visibility sp ref = push_xref visibility sp (TrueGlobal ref) (* This is for Syntactic Definitions *) let push_syndef visibility sp kn = push_xref visibility sp (SynDef kn) let push = push_cci let push_modtype vis sp kn = the_modtypetab := MPTab.push vis sp kn !the_modtypetab; the_modtyperevtab := MPmap.add kn sp !the_modtyperevtab (* This is for tactic definition names *) let push_tactic vis sp kn = the_tactictab := KnTab.push vis sp kn !the_tactictab; the_tacticrevtab := KNmap.add kn sp !the_tacticrevtab (* This is to remember absolute Section/Module names and to avoid redundancy *) let push_dir vis dir dir_ref = the_dirtab := DirTab.push vis dir dir_ref !the_dirtab; match dir_ref with DirModule (_,(mp,_)) -> the_modrevtab := MPmap.add mp dir !the_modrevtab | _ -> () (* Locate functions *******************************************************) (* This should be used when syntactic definitions are allowed *) let locate_extended qid = ExtRefTab.locate qid !the_ccitab (* This should be used when no syntactic definitions is expected *) let locate qid = match locate_extended qid with | TrueGlobal ref -> ref | SynDef _ -> raise Not_found let full_name_cci qid = ExtRefTab.user_name qid !the_ccitab let locate_syndef qid = match locate_extended qid with | TrueGlobal _ -> raise Not_found | SynDef kn -> kn let locate_modtype qid = MPTab.locate qid !the_modtypetab let full_name_modtype qid = MPTab.user_name qid !the_modtypetab let locate_tactic qid = KnTab.locate qid !the_tactictab let locate_dir qid = DirTab.locate qid !the_dirtab let locate_module qid = match locate_dir qid with | DirModule (_,(mp,_)) -> mp | _ -> raise Not_found let full_name_module qid = match locate_dir qid with | DirModule (dir,_) -> dir | _ -> raise Not_found let locate_section qid = match locate_dir qid with | DirOpenSection (dir, _) | DirClosedSection dir -> dir | _ -> raise Not_found let locate_all qid = List.fold_right (fun a l -> match a with TrueGlobal a -> a::l | _ -> l) (ExtRefTab.find_prefixes qid !the_ccitab) [] let locate_extended_all qid = ExtRefTab.find_prefixes qid !the_ccitab let locate_extended_all_tactic qid = KnTab.find_prefixes qid !the_tactictab let locate_extended_all_dir qid = DirTab.find_prefixes qid !the_dirtab let locate_extended_all_modtype qid = MPTab.find_prefixes qid !the_modtypetab (* Derived functions *) let locate_constant qid = match locate_extended qid with | TrueGlobal (ConstRef kn) -> kn | _ -> raise Not_found let global_of_path sp = match ExtRefTab.find sp !the_ccitab with | TrueGlobal ref -> ref | _ -> raise Not_found let extended_global_of_path sp = ExtRefTab.find sp !the_ccitab let global r = let (loc,qid) = qualid_of_reference r in try match locate_extended qid with | TrueGlobal ref -> ref | SynDef _ -> user_err_loc (loc,"global", str "Unexpected reference to a notation: " ++ pr_qualid qid) with Not_found -> error_global_not_found_loc loc qid (* Exists functions ********************************************************) let exists_cci sp = ExtRefTab.exists sp !the_ccitab let exists_dir dir = DirTab.exists dir !the_dirtab let exists_section = exists_dir let exists_module = exists_dir let exists_modtype sp = MPTab.exists sp !the_modtypetab let exists_tactic kn = KnTab.exists kn !the_tactictab (* Reverse locate functions ***********************************************) let path_of_global ref = match ref with | VarRef id -> make_path DirPath.empty id | _ -> Globrevtab.find (TrueGlobal ref) !the_globrevtab let dirpath_of_global ref = fst (repr_path (path_of_global ref)) let basename_of_global ref = snd (repr_path (path_of_global ref)) let path_of_syndef kn = Globrevtab.find (SynDef kn) !the_globrevtab let dirpath_of_module mp = MPmap.find mp !the_modrevtab let path_of_tactic kn = KNmap.find kn !the_tacticrevtab let path_of_modtype mp = MPmap.find mp !the_modtyperevtab (* Shortest qualid functions **********************************************) let shortest_qualid_of_global ctx ref = match ref with | VarRef id -> make_qualid DirPath.empty id | _ -> let sp = Globrevtab.find (TrueGlobal ref) !the_globrevtab in ExtRefTab.shortest_qualid ctx sp !the_ccitab let shortest_qualid_of_syndef ctx kn = let sp = path_of_syndef kn in ExtRefTab.shortest_qualid ctx sp !the_ccitab let shortest_qualid_of_module mp = let dir = MPmap.find mp !the_modrevtab in DirTab.shortest_qualid Id.Set.empty dir !the_dirtab let shortest_qualid_of_modtype kn = let sp = MPmap.find kn !the_modtyperevtab in MPTab.shortest_qualid Id.Set.empty sp !the_modtypetab let shortest_qualid_of_tactic kn = let sp = KNmap.find kn !the_tacticrevtab in KnTab.shortest_qualid Id.Set.empty sp !the_tactictab let pr_global_env env ref = try pr_qualid (shortest_qualid_of_global env ref) with Not_found as e -> if !Flags.debug then Feedback.msg_debug (Pp.str "pr_global_env not found"); raise e let global_inductive r = match global r with | IndRef ind -> ind | ref -> user_err_loc (loc_of_reference r,"global_inductive", pr_reference r ++ spc () ++ str "is not an inductive type") (********************************************************************) (********************************************************************) (* Registration of tables as a global table and rollback *) type frozen = ccitab * dirtab * mptab * kntab * globrevtab * mprevtab * mptrevtab * knrevtab let freeze _ : frozen = !the_ccitab, !the_dirtab, !the_modtypetab, !the_tactictab, !the_globrevtab, !the_modrevtab, !the_modtyperevtab, !the_tacticrevtab let unfreeze (ccit,dirt,mtyt,tact,globr,modr,mtyr,tacr) = the_ccitab := ccit; the_dirtab := dirt; the_modtypetab := mtyt; the_tactictab := tact; the_globrevtab := globr; the_modrevtab := modr; the_modtyperevtab := mtyr; the_tacticrevtab := tacr let _ = Summary.declare_summary "names" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = Summary.nop } (* Deprecated synonyms *) let extended_locate = locate_extended let absolute_reference = global_of_path coq-8.6/library/globnames.mli0000644000175000017500000000721513022274260015602 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool val isConstRef : global_reference -> bool val isIndRef : global_reference -> bool val isConstructRef : global_reference -> bool val eq_gr : global_reference -> global_reference -> bool val canonical_gr : global_reference -> global_reference val destVarRef : global_reference -> variable val destConstRef : global_reference -> constant val destIndRef : global_reference -> inductive val destConstructRef : global_reference -> constructor val is_global : global_reference -> constr -> bool val subst_constructor : substitution -> constructor -> constructor * constr val subst_global : substitution -> global_reference -> global_reference * constr val subst_global_reference : substitution -> global_reference -> global_reference (** This constr is not safe to be typechecked, universe polymorphism is not handled here: just use for printing *) val printable_constr_of_global : global_reference -> constr (** Turn a construction denoting a global reference into a global reference; raise [Not_found] if not a global reference *) val global_of_constr : constr -> global_reference (** Obsolete synonyms for constr_of_global and global_of_constr *) val reference_of_constr : constr -> global_reference module RefOrdered : sig type t = global_reference val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int end module RefOrdered_env : sig type t = global_reference val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int end module Refset : CSig.SetS with type elt = global_reference module Refmap : Map.ExtS with type key = global_reference and module Set := Refset module Refset_env : CSig.SetS with type elt = global_reference module Refmap_env : Map.ExtS with type key = global_reference and module Set := Refset_env (** {6 Extended global references } *) type syndef_name = kernel_name type extended_global_reference = | TrueGlobal of global_reference | SynDef of syndef_name module ExtRefOrdered : sig type t = extended_global_reference val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int end type global_reference_or_constr = | IsGlobal of global_reference | IsConstr of constr (** {6 Temporary function to brutally form kernel names from section paths } *) val encode_mind : DirPath.t -> Id.t -> mutual_inductive val decode_mind : mutual_inductive -> DirPath.t * Id.t val encode_con : DirPath.t -> Id.t -> constant val decode_con : constant -> DirPath.t * Id.t (** {6 Popping one level of section in global names } *) val pop_con : constant -> constant val pop_kn : mutual_inductive-> mutual_inductive val pop_global_reference : global_reference -> global_reference coq-8.6/library/universes.ml0000644000175000017500000011653313022274260015511 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Level.pr l (** Local universe names of polymorphic references *) type universe_binders = (Id.t * Univ.universe_level) list let universe_binders_table = Summary.ref Refmap.empty ~name:"universe binders" let universe_binders_of_global ref = try let l = Refmap.find ref !universe_binders_table in l with Not_found -> [] let register_universe_binders ref l = universe_binders_table := Refmap.add ref l !universe_binders_table (* To disallow minimization to Set *) let set_minimization = ref true let is_set_minimization () = !set_minimization type universe_constraint_type = ULe | UEq | ULub type universe_constraint = universe * universe_constraint_type * universe module Constraints = struct module S = Set.Make( struct type t = universe_constraint let compare_type c c' = match c, c' with | ULe, ULe -> 0 | ULe, _ -> -1 | _, ULe -> 1 | UEq, UEq -> 0 | UEq, _ -> -1 | ULub, ULub -> 0 | ULub, _ -> 1 let compare (u,c,v) (u',c',v') = let i = compare_type c c' in if Int.equal i 0 then let i' = Universe.compare u u' in if Int.equal i' 0 then Universe.compare v v' else if c != ULe && Universe.compare u v' = 0 && Universe.compare v u' = 0 then 0 else i' else i end) include S let add (l,d,r as cst) s = if Universe.equal l r then s else add cst s let tr_dir = function | ULe -> Le | UEq -> Eq | ULub -> Eq let op_str = function ULe -> " <= " | UEq -> " = " | ULub -> " /\\ " let pr c = fold (fun (u1,op,u2) pp_std -> pp_std ++ Universe.pr u1 ++ str (op_str op) ++ Universe.pr u2 ++ fnl ()) c (str "") let equal x y = x == y || equal x y end type universe_constraints = Constraints.t type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option type 'a universe_constrained = 'a * universe_constraints type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints let enforce_eq_instances_univs strict x y c = let d = if strict then ULub else UEq in let ax = Instance.to_array x and ay = Instance.to_array y in if Array.length ax != Array.length ay then CErrors.anomaly (Pp.str "Invalid argument: enforce_eq_instances_univs called with" ++ Pp.str " instances of different lengths"); CArray.fold_right2 (fun x y -> Constraints.add (Universe.make x, d, Universe.make y)) ax ay c let subst_univs_universe_constraint fn (u,d,v) = let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in if Universe.equal u' v' then None else Some (u',d,v') let subst_univs_universe_constraints subst csts = Constraints.fold (fun c -> Option.fold_right Constraints.add (subst_univs_universe_constraint subst c)) csts Constraints.empty let to_constraints g s = let tr (x,d,y) acc = let add l d l' acc = Constraint.add (l,Constraints.tr_dir d,l') acc in match Universe.level x, d, Universe.level y with | Some l, (ULe | UEq | ULub), Some l' -> add l d l' acc | _, ULe, Some l' -> enforce_leq x y acc | _, ULub, _ -> acc | _, d, _ -> let f = if d == ULe then UGraph.check_leq else UGraph.check_eq in if f g x y then acc else raise (Invalid_argument "to_constraints: non-trivial algebraic constraint between universes") in Constraints.fold tr s Constraint.empty let eq_constr_univs_infer univs fold m n accu = if m == n then Some accu else let cstrs = ref accu in let eq_universes strict = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with | None -> false | Some accu -> cstrs := accu; true in let rec eq_constr' m n = m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in let res = Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in if res then Some !cstrs else None (** Variant of [eq_constr_univs_infer] taking kind-of-term functions, to expose subterms of [m] and [n], arguments. *) let eq_constr_univs_infer_with kind1 kind2 univs fold m n accu = (* spiwack: duplicates the code of [eq_constr_univs_infer] because I haven't find a way to factor the code without destroying pointer-equality optimisations in [eq_constr_univs_infer]. Pointer equality is not sufficient to ensure equality up to [kind1,kind2], because [kind1] and [kind2] may be different, typically evaluating [m] and [n] in different evar maps. *) let cstrs = ref accu in let eq_universes strict = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with | None -> false | Some accu -> cstrs := accu; true in let rec eq_constr' m n = Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' m n in let res = Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' m n in if res then Some !cstrs else None let leq_constr_univs_infer univs fold m n accu = if m == n then Some accu else let cstrs = ref accu in let eq_universes strict l l' = UGraph.check_eq_instances univs l l' in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with | None -> false | Some accu -> cstrs := accu; true in let leq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in match fold (Constraints.singleton (u1, ULe, u2)) !cstrs with | None -> false | Some accu -> cstrs := accu; true in let rec eq_constr' m n = m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in let rec compare_leq m n = Constr.compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n and leq_constr' m n = m == n || compare_leq m n in let res = compare_leq m n in if res then Some !cstrs else None let eq_constr_universes m n = if m == n then true, Constraints.empty else let cstrs = ref Constraints.empty in let eq_universes strict l l' = cstrs := enforce_eq_instances_univs strict l l' !cstrs; true in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else (cstrs := Constraints.add (Sorts.univ_of_sort s1, UEq, Sorts.univ_of_sort s2) !cstrs; true) in let rec eq_constr' m n = m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in let res = Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in res, !cstrs let leq_constr_universes m n = if m == n then true, Constraints.empty else let cstrs = ref Constraints.empty in let eq_universes strict l l' = cstrs := enforce_eq_instances_univs strict l l' !cstrs; true in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else (cstrs := Constraints.add (Sorts.univ_of_sort s1,UEq,Sorts.univ_of_sort s2) !cstrs; true) in let leq_sorts s1 s2 = if Sorts.equal s1 s2 then true else (cstrs := Constraints.add (Sorts.univ_of_sort s1,ULe,Sorts.univ_of_sort s2) !cstrs; true) in let rec eq_constr' m n = m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in let rec compare_leq m n = Constr.compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n and leq_constr' m n = m == n || compare_leq m n in let res = compare_leq m n in res, !cstrs let compare_head_gen_proj env equ eqs eqc' m n = match kind_of_term m, kind_of_term n with | Proj (p, c), App (f, args) | App (f, args), Proj (p, c) -> (match kind_of_term f with | Const (p', u) when eq_constant (Projection.constant p) p' -> let pb = Environ.lookup_projection p env in let npars = pb.Declarations.proj_npars in if Array.length args == npars + 1 then eqc' c args.(npars) else false | _ -> false) | _ -> Constr.compare_head_gen equ eqs eqc' m n let eq_constr_universes_proj env m n = if m == n then true, Constraints.empty else let cstrs = ref Constraints.empty in let eq_universes strict l l' = cstrs := enforce_eq_instances_univs strict l l' !cstrs; true in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else (cstrs := Constraints.add (Sorts.univ_of_sort s1, UEq, Sorts.univ_of_sort s2) !cstrs; true) in let rec eq_constr' m n = m == n || compare_head_gen_proj env eq_universes eq_sorts eq_constr' m n in let res = eq_constr' m n in res, !cstrs (* Generator of levels *) let new_univ_level, set_remote_new_univ_level = RemoteCounter.new_counter ~name:"Universes" 0 ~incr:((+) 1) ~build:(fun n -> Univ.Level.make (Global.current_dirpath ()) n) let new_univ_level _ = new_univ_level () (* Univ.Level.make db (new_univ_level ()) *) let fresh_level () = new_univ_level (Global.current_dirpath ()) (* TODO: remove *) let new_univ dp = Univ.Universe.make (new_univ_level dp) let new_Type dp = mkType (new_univ dp) let new_Type_sort dp = Type (new_univ dp) let fresh_universe_instance ctx = Instance.subst_fn (fun _ -> new_univ_level (Global.current_dirpath ())) (UContext.instance ctx) let fresh_instance_from_context ctx = let inst = fresh_universe_instance ctx in let constraints = instantiate_univ_constraints inst ctx in inst, constraints let fresh_instance ctx = let ctx' = ref LSet.empty in let inst = Instance.subst_fn (fun v -> let u = new_univ_level (Global.current_dirpath ()) in ctx' := LSet.add u !ctx'; u) (UContext.instance ctx) in !ctx', inst let existing_instance ctx inst = let () = let a1 = Instance.to_array inst and a2 = Instance.to_array (UContext.instance ctx) in let len1 = Array.length a1 and len2 = Array.length a2 in if not (len1 == len2) then CErrors.errorlabstrm "Universes" (str "Polymorphic constant expected " ++ int len2 ++ str" levels but was given " ++ int len1) else () in LSet.empty, inst let fresh_instance_from ctx inst = let ctx', inst = match inst with | Some inst -> existing_instance ctx inst | None -> fresh_instance ctx in let constraints = instantiate_univ_constraints inst ctx in inst, (ctx', constraints) let unsafe_instance_from ctx = (Univ.UContext.instance ctx, ctx) (** Fresh universe polymorphic construction *) let fresh_constant_instance env c inst = let cb = lookup_constant c env in if cb.Declarations.const_polymorphic then let inst, ctx = fresh_instance_from (Declareops.universes_of_constant (Environ.opaque_tables env) cb) inst in ((c, inst), ctx) else ((c,Instance.empty), ContextSet.empty) let fresh_inductive_instance env ind inst = let mib, mip = Inductive.lookup_mind_specif env ind in if mib.Declarations.mind_polymorphic then let inst, ctx = fresh_instance_from mib.Declarations.mind_universes inst in ((ind,inst), ctx) else ((ind,Instance.empty), ContextSet.empty) let fresh_constructor_instance env (ind,i) inst = let mib, mip = Inductive.lookup_mind_specif env ind in if mib.Declarations.mind_polymorphic then let inst, ctx = fresh_instance_from mib.Declarations.mind_universes inst in (((ind,i),inst), ctx) else (((ind,i),Instance.empty), ContextSet.empty) let unsafe_constant_instance env c = let cb = lookup_constant c env in if cb.Declarations.const_polymorphic then let inst, ctx = unsafe_instance_from (Declareops.universes_of_constant (Environ.opaque_tables env) cb) in ((c, inst), ctx) else ((c,Instance.empty), UContext.empty) let unsafe_inductive_instance env ind = let mib, mip = Inductive.lookup_mind_specif env ind in if mib.Declarations.mind_polymorphic then let inst, ctx = unsafe_instance_from mib.Declarations.mind_universes in ((ind,inst), ctx) else ((ind,Instance.empty), UContext.empty) let unsafe_constructor_instance env (ind,i) = let mib, mip = Inductive.lookup_mind_specif env ind in if mib.Declarations.mind_polymorphic then let inst, ctx = unsafe_instance_from mib.Declarations.mind_universes in (((ind,i),inst), ctx) else (((ind,i),Instance.empty), UContext.empty) open Globnames let fresh_global_instance ?names env gr = match gr with | VarRef id -> mkVar id, ContextSet.empty | ConstRef sp -> let c, ctx = fresh_constant_instance env sp names in mkConstU c, ctx | ConstructRef sp -> let c, ctx = fresh_constructor_instance env sp names in mkConstructU c, ctx | IndRef sp -> let c, ctx = fresh_inductive_instance env sp names in mkIndU c, ctx let fresh_constant_instance env sp = fresh_constant_instance env sp None let fresh_inductive_instance env sp = fresh_inductive_instance env sp None let fresh_constructor_instance env sp = fresh_constructor_instance env sp None let unsafe_global_instance env gr = match gr with | VarRef id -> mkVar id, UContext.empty | ConstRef sp -> let c, ctx = unsafe_constant_instance env sp in mkConstU c, ctx | ConstructRef sp -> let c, ctx = unsafe_constructor_instance env sp in mkConstructU c, ctx | IndRef sp -> let c, ctx = unsafe_inductive_instance env sp in mkIndU c, ctx let constr_of_global gr = let c, ctx = fresh_global_instance (Global.env ()) gr in if not (Univ.ContextSet.is_empty ctx) then if Univ.LSet.is_empty (Univ.ContextSet.levels ctx) then (* Should be an error as we might forget constraints, allow for now to make firstorder work with "using" clauses *) c else raise (Invalid_argument ("constr_of_global: globalization of polymorphic reference " ^ Pp.string_of_ppcmds (Nametab.pr_global_env Id.Set.empty gr) ^ " would forget universes.")) else c let constr_of_reference = constr_of_global let unsafe_constr_of_global gr = unsafe_global_instance (Global.env ()) gr let constr_of_global_univ (gr,u) = match gr with | VarRef id -> mkVar id | ConstRef sp -> mkConstU (sp,u) | ConstructRef sp -> mkConstructU (sp,u) | IndRef sp -> mkIndU (sp,u) let fresh_global_or_constr_instance env = function | IsConstr c -> c, ContextSet.empty | IsGlobal gr -> fresh_global_instance env gr let global_of_constr c = match kind_of_term c with | Const (c, u) -> ConstRef c, u | Ind (i, u) -> IndRef i, u | Construct (c, u) -> ConstructRef c, u | Var id -> VarRef id, Instance.empty | _ -> raise Not_found let global_app_of_constr c = match kind_of_term c with | Const (c, u) -> (ConstRef c, u), None | Ind (i, u) -> (IndRef i, u), None | Construct (c, u) -> (ConstructRef c, u), None | Var id -> (VarRef id, Instance.empty), None | Proj (p, c) -> (ConstRef (Projection.constant p), Instance.empty), Some c | _ -> raise Not_found open Declarations let type_of_reference env r = match r with | VarRef id -> Environ.named_type id env, ContextSet.empty | ConstRef c -> let cb = Environ.lookup_constant c env in let ty = Typeops.type_of_constant_type env cb.const_type in if cb.const_polymorphic then let inst, ctx = fresh_instance_from (Declareops.universes_of_constant (Environ.opaque_tables env) cb) None in Vars.subst_instance_constr inst ty, ctx else ty, ContextSet.empty | IndRef ind -> let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in if mib.mind_polymorphic then let inst, ctx = fresh_instance_from mib.mind_universes None in let ty = Inductive.type_of_inductive env (specif, inst) in ty, ctx else let ty = Inductive.type_of_inductive env (specif, Univ.Instance.empty) in ty, ContextSet.empty | ConstructRef cstr -> let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in if mib.mind_polymorphic then let inst, ctx = fresh_instance_from mib.mind_universes None in Inductive.type_of_constructor (cstr,inst) specif, ctx else Inductive.type_of_constructor (cstr,Instance.empty) specif, ContextSet.empty let type_of_global t = type_of_reference (Global.env ()) t let unsafe_type_of_reference env r = match r with | VarRef id -> Environ.named_type id env | ConstRef c -> let cb = Environ.lookup_constant c env in Typeops.type_of_constant_type env cb.const_type | IndRef ind -> let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in let (_, inst), _ = unsafe_inductive_instance env ind in Inductive.type_of_inductive env (specif, inst) | ConstructRef (ind, _ as cstr) -> let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in let (_, inst), _ = unsafe_inductive_instance env ind in Inductive.type_of_constructor (cstr,inst) specif let unsafe_type_of_global t = unsafe_type_of_reference (Global.env ()) t let fresh_sort_in_family env = function | InProp -> prop_sort, ContextSet.empty | InSet -> set_sort, ContextSet.empty | InType -> let u = fresh_level () in Type (Univ.Universe.make u), ContextSet.singleton u let new_sort_in_family sf = fst (fresh_sort_in_family (Global.env ()) sf) let extend_context (a, ctx) (ctx') = (a, ContextSet.union ctx ctx') let new_global_univ () = let u = fresh_level () in (Univ.Universe.make u, ContextSet.singleton u) (** Simplification *) module LevelUnionFind = Unionfind.Make (Univ.LSet) (Univ.LMap) let add_list_map u t map = try let l = LMap.find u map in LMap.update u (t :: l) map with Not_found -> LMap.add u [t] map module UF = LevelUnionFind (** Precondition: flexible <= ctx *) let choose_canonical ctx flexible algs s = let global = LSet.diff s ctx in let flexible, rigid = LSet.partition flexible (LSet.inter s ctx) in (** If there is a global universe in the set, choose it *) if not (LSet.is_empty global) then let canon = LSet.choose global in canon, (LSet.remove canon global, rigid, flexible) else (** No global in the equivalence class, choose a rigid one *) if not (LSet.is_empty rigid) then let canon = LSet.choose rigid in canon, (global, LSet.remove canon rigid, flexible) else (** There are only flexible universes in the equivalence class, choose a non-algebraic. *) let algs, nonalgs = LSet.partition (fun x -> LSet.mem x algs) flexible in if not (LSet.is_empty nonalgs) then let canon = LSet.choose nonalgs in canon, (global, rigid, LSet.remove canon flexible) else let canon = LSet.choose algs in canon, (global, rigid, LSet.remove canon flexible) let subst_univs_fn_puniverses lsubst (c, u as cu) = let u' = Instance.subst_fn lsubst u in if u' == u then cu else (c, u') let nf_evars_and_universes_opt_subst f subst = let subst = fun l -> match LMap.find l subst with None -> raise Not_found | Some l' -> l' in let lsubst = Univ.level_subst_of subst in let rec aux c = match kind_of_term c with | Evar (evk, args) -> let args = Array.map aux args in (match try f (evk, args) with Not_found -> None with | None -> c | Some c -> aux c) | Const pu -> let pu' = subst_univs_fn_puniverses lsubst pu in if pu' == pu then c else mkConstU pu' | Ind pu -> let pu' = subst_univs_fn_puniverses lsubst pu in if pu' == pu then c else mkIndU pu' | Construct pu -> let pu' = subst_univs_fn_puniverses lsubst pu in if pu' == pu then c else mkConstructU pu' | Sort (Type u) -> let u' = Univ.subst_univs_universe subst u in if u' == u then c else mkSort (sort_of_univ u') | _ -> map_constr aux c in aux let fresh_universe_context_set_instance ctx = if ContextSet.is_empty ctx then LMap.empty, ctx else let (univs, cst) = ContextSet.levels ctx, ContextSet.constraints ctx in let univs',subst = LSet.fold (fun u (univs',subst) -> let u' = fresh_level () in (LSet.add u' univs', LMap.add u u' subst)) univs (LSet.empty, LMap.empty) in let cst' = subst_univs_level_constraints subst cst in subst, (univs', cst') let normalize_univ_variable ~find ~update = let rec aux cur = let b = find cur in let b' = subst_univs_universe aux b in if Universe.equal b' b then b else update cur b' in aux let normalize_univ_variable_opt_subst ectx = let find l = match Univ.LMap.find l !ectx with | Some b -> b | None -> raise Not_found in let update l b = assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true); try ectx := Univ.LMap.add l (Some b) !ectx; b with Not_found -> assert false in normalize_univ_variable ~find ~update let normalize_univ_variable_subst subst = let find l = Univ.LMap.find l !subst in let update l b = assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true); try subst := Univ.LMap.update l b !subst; b with Not_found -> assert false in normalize_univ_variable ~find ~update let normalize_universe_opt_subst subst = let normlevel = normalize_univ_variable_opt_subst subst in subst_univs_universe normlevel let normalize_universe_subst subst = let normlevel = normalize_univ_variable_subst subst in subst_univs_universe normlevel let normalize_opt_subst ctx = let ectx = ref ctx in let normalize = normalize_univ_variable_opt_subst ectx in let () = Univ.LMap.iter (fun u v -> if Option.is_empty v then () else try ignore(normalize u) with Not_found -> assert(false)) ctx in !ectx type universe_opt_subst = universe option universe_map let make_opt_subst s = fun x -> (match Univ.LMap.find x s with | Some u -> u | None -> raise Not_found) let subst_opt_univs_constr s = let f = make_opt_subst s in Vars.subst_univs_fn_constr f let normalize_univ_variables ctx = let ctx = normalize_opt_subst ctx in let undef, def, subst = Univ.LMap.fold (fun u v (undef, def, subst) -> match v with | None -> (Univ.LSet.add u undef, def, subst) | Some b -> (undef, Univ.LSet.add u def, Univ.LMap.add u b subst)) ctx (Univ.LSet.empty, Univ.LSet.empty, Univ.LMap.empty) in ctx, undef, def, subst let pr_universe_body = function | None -> mt () | Some v -> str" := " ++ Univ.Universe.pr v let pr_universe_opt_subst = Univ.LMap.pr pr_universe_body let compare_constraint_type d d' = match d, d' with | Eq, Eq -> 0 | Eq, _ -> -1 | _, Eq -> 1 | Le, Le -> 0 | Le, _ -> -1 | _, Le -> 1 | Lt, Lt -> 0 type lowermap = constraint_type LMap.t let lower_union = let merge k a b = match a, b with | Some _, None -> a | None, Some _ -> b | None, None -> None | Some l, Some r -> if compare_constraint_type l r >= 0 then a else b in LMap.merge merge let lower_add l c m = try let c' = LMap.find l m in if compare_constraint_type c c' > 0 then LMap.add l c m else m with Not_found -> LMap.add l c m let lower_of_list l = List.fold_left (fun acc (d,l) -> LMap.add l d acc) LMap.empty l exception Found of Level.t * lowermap let find_inst insts v = try LMap.iter (fun k (enf,alg,v',lower) -> if not alg && enf && Universe.equal v' v then raise (Found (k, lower))) insts; raise Not_found with Found (f,l) -> (f,l) let compute_lbound left = (** The universe variable was not fixed yet. Compute its level using its lower bound. *) let sup l lbound = match lbound with | None -> Some l | Some l' -> Some (Universe.sup l l') in List.fold_left (fun lbound (d, l) -> if d == Le (* l <= ?u *) then sup l lbound else (* l < ?u *) (assert (d == Lt); if not (Universe.level l == None) then sup (Universe.super l) lbound else None)) None left let instantiate_with_lbound u lbound lower alg enforce (ctx, us, algs, insts, cstrs) = if enforce then let inst = Universe.make u in let cstrs' = enforce_leq lbound inst cstrs in (ctx, us, LSet.remove u algs, LMap.add u (enforce,alg,lbound,lower) insts, cstrs'), (enforce, alg, inst, lower) else (* Actually instantiate *) (Univ.LSet.remove u ctx, Univ.LMap.add u (Some lbound) us, algs, LMap.add u (enforce,alg,lbound,lower) insts, cstrs), (enforce, alg, lbound, lower) type constraints_map = (Univ.constraint_type * Univ.LMap.key) list Univ.LMap.t let pr_constraints_map cmap = LMap.fold (fun l cstrs acc -> Level.pr l ++ str " => " ++ prlist_with_sep spc (fun (d,r) -> pr_constraint_type d ++ Level.pr r) cstrs ++ fnl () ++ acc) cmap (mt ()) let remove_alg l (ctx, us, algs, insts, cstrs) = (ctx, us, LSet.remove l algs, insts, cstrs) let remove_lower u lower = let levels = Universe.levels u in LSet.fold (fun l acc -> LMap.remove l acc) levels lower let minimize_univ_variables ctx us algs left right cstrs = let left, lbounds = Univ.LMap.fold (fun r lower (left, lbounds as acc) -> if Univ.LMap.mem r us || not (Univ.LSet.mem r ctx) then acc else (* Fixed universe, just compute its glb for sharing *) let lbounds' = match compute_lbound (List.map (fun (d,l) -> d, Universe.make l) lower) with | None -> lbounds | Some lbound -> LMap.add r (true, false, lbound, lower_of_list lower) lbounds in (Univ.LMap.remove r left, lbounds')) left (left, Univ.LMap.empty) in let rec instance (ctx', us, algs, insts, cstrs as acc) u = let acc, left, lower = try let l = LMap.find u left in let acc, left, newlow, lower = List.fold_left (fun (acc, left', newlow, lower') (d, l) -> let acc', (enf,alg,l',lower) = aux acc l in let l' = if enf then Universe.make l else l' in acc', (d, l') :: left', lower_add l d newlow, lower_union lower lower') (acc, [], LMap.empty, LMap.empty) l in let not_lower (d,l) = (* We're checking if (d,l) is already implied by the lower constraints on some level u. If it represents l < u (d is Lt or d is Le and i > 0, the i < 0 case is impossible due to invariants of Univ), and the lower constraints only have l <= u then it is not implied. *) Univ.Universe.exists (fun (l,i) -> let d = if i == 0 then d else match d with | Le -> Lt | d -> d in try let d' = LMap.find l lower in (* If d is stronger than the already implied lower * constraints we must keep it. *) compare_constraint_type d d' > 0 with Not_found -> (** No constraint existing on l *) true) l in let left = List.uniquize (List.filter not_lower left) in (acc, left, LMap.union newlow lower) with Not_found -> acc, [], LMap.empty and right = try Some (LMap.find u right) with Not_found -> None in let instantiate_lbound lbound = let alg = LSet.mem u algs in if alg then (* u is algebraic: we instantiate it with its lower bound, if any, or enforce the constraints if it is bounded from the top. *) let lower = remove_lower lbound lower in instantiate_with_lbound u lbound lower true false acc else (* u is non algebraic *) match Universe.level lbound with | Some l -> (* The lowerbound is directly a level *) (* u is not algebraic but has no upper bounds, we instantiate it with its lower bound if it is a different level, otherwise we keep it. *) let lower = LMap.remove l lower in if not (Level.equal l u) then (* Should check that u does not have upper constraints that are not already in right *) let acc' = remove_alg l acc in instantiate_with_lbound u lbound lower false false acc' else acc, (true, false, lbound, lower) | None -> try (* Another universe represents the same lower bound, we can share them with no harm. *) let can, lower = find_inst insts lbound in let lower = LMap.remove can lower in instantiate_with_lbound u (Universe.make can) lower false false acc with Not_found -> (* We set u as the canonical universe representing lbound *) instantiate_with_lbound u lbound lower false true acc in let acc' acc = match right with | None -> acc | Some cstrs -> let dangling = List.filter (fun (d, r) -> not (LMap.mem r us)) cstrs in if List.is_empty dangling then acc else let ((ctx', us, algs, insts, cstrs), (enf,_,inst,lower as b)) = acc in let cstrs' = List.fold_left (fun cstrs (d, r) -> if d == Univ.Le then enforce_leq inst (Universe.make r) cstrs else try let lev = Option.get (Universe.level inst) in Constraint.add (lev, d, r) cstrs with Option.IsNone -> failwith "") cstrs dangling in (ctx', us, algs, insts, cstrs'), b in if not (LSet.mem u ctx) then acc' (acc, (true, false, Universe.make u, lower)) else let lbound = compute_lbound left in match lbound with | None -> (* Nothing to do *) acc' (acc, (true, false, Universe.make u, lower)) | Some lbound -> try acc' (instantiate_lbound lbound) with Failure _ -> acc' (acc, (true, false, Universe.make u, lower)) and aux (ctx', us, algs, seen, cstrs as acc) u = try acc, LMap.find u seen with Not_found -> instance acc u in LMap.fold (fun u v (ctx', us, algs, seen, cstrs as acc) -> if v == None then fst (aux acc u) else LSet.remove u ctx', us, LSet.remove u algs, seen, cstrs) us (ctx, us, algs, lbounds, cstrs) let normalize_context_set ctx us algs = let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in let uf = UF.create () in (** Keep the Prop/Set <= i constraints separate for minimization *) let smallles, csts = Constraint.fold (fun (l,d,r as cstr) (smallles, noneqs) -> if d == Le then if Univ.Level.is_small l then if is_set_minimization () && LSet.mem r ctx then (Constraint.add cstr smallles, noneqs) else (smallles, noneqs) else if Level.is_small r then if Level.is_prop r then raise (Univ.UniverseInconsistency (Le,Universe.make l,Universe.make r,None)) else (smallles, Constraint.add (l,Eq,r) noneqs) else (smallles, Constraint.add cstr noneqs) else (smallles, Constraint.add cstr noneqs)) csts (Constraint.empty, Constraint.empty) in let csts = (* We first put constraints in a normal-form: all self-loops are collapsed to equalities. *) let g = Univ.LSet.fold (fun v g -> UGraph.add_universe v false g) ctx UGraph.empty_universes in let g = Univ.Constraint.fold (fun (l, d, r) g -> let g = if not (Level.is_small l || LSet.mem l ctx) then try UGraph.add_universe l false g with UGraph.AlreadyDeclared -> g else g in let g = if not (Level.is_small r || LSet.mem r ctx) then try UGraph.add_universe r false g with UGraph.AlreadyDeclared -> g else g in g) csts g in let g = Univ.Constraint.fold UGraph.enforce_constraint csts g in UGraph.constraints_of_universes g in let noneqs = Constraint.fold (fun (l,d,r as cstr) noneqs -> if d == Eq then (UF.union l r uf; noneqs) else (* We ignore the trivial Prop/Set <= i constraints. *) if d == Le && Univ.Level.is_small l then noneqs else if Univ.Level.is_prop l && d == Lt && Univ.Level.is_set r then noneqs else Constraint.add cstr noneqs) csts Constraint.empty in let noneqs = Constraint.union noneqs smallles in let partition = UF.partition uf in let flex x = LMap.mem x us in let ctx, subst, us, eqs = List.fold_left (fun (ctx, subst, us, cstrs) s -> let canon, (global, rigid, flexible) = choose_canonical ctx flex algs s in (* Add equalities for globals which can't be merged anymore. *) let cstrs = LSet.fold (fun g cst -> Constraint.add (canon, Univ.Eq, g) cst) global cstrs in (* Also add equalities for rigid variables *) let cstrs = LSet.fold (fun g cst -> Constraint.add (canon, Univ.Eq, g) cst) rigid cstrs in let subst = LSet.fold (fun f -> LMap.add f canon) rigid subst in let subst = LSet.fold (fun f -> LMap.add f canon) flexible subst in let canonu = Some (Universe.make canon) in let us = LSet.fold (fun f -> LMap.add f canonu) flexible us in (LSet.diff ctx flexible, subst, us, cstrs)) (ctx, LMap.empty, us, Constraint.empty) partition in (* Noneqs is now in canonical form w.r.t. equality constraints, and contains only inequality constraints. *) let noneqs = subst_univs_level_constraints subst noneqs in (* Compute the left and right set of flexible variables, constraints mentionning other variables remain in noneqs. *) let noneqs, ucstrsl, ucstrsr = Constraint.fold (fun (l,d,r as cstr) (noneq, ucstrsl, ucstrsr) -> let lus = LMap.mem l us and rus = LMap.mem r us in let ucstrsl' = if lus then add_list_map l (d, r) ucstrsl else ucstrsl and ucstrsr' = add_list_map r (d, l) ucstrsr in let noneqs = if lus || rus then noneq else Constraint.add cstr noneq in (noneqs, ucstrsl', ucstrsr')) noneqs (Constraint.empty, LMap.empty, LMap.empty) in (* Now we construct the instantiation of each variable. *) let ctx', us, algs, inst, noneqs = minimize_univ_variables ctx us algs ucstrsr ucstrsl noneqs in let us = normalize_opt_subst us in (us, algs), (ctx', Constraint.union noneqs eqs) (* let normalize_conkey = Profile.declare_profile "normalize_context_set" *) (* let normalize_context_set a b c = Profile.profile3 normalize_conkey normalize_context_set a b c *) let universes_of_constr c = let rec aux s c = match kind_of_term c with | Const (_, u) | Ind (_, u) | Construct (_, u) -> LSet.fold LSet.add (Instance.levels u) s | Sort u when not (Sorts.is_small u) -> let u = univ_of_sort u in LSet.fold LSet.add (Universe.levels u) s | _ -> fold_constr aux s c in aux LSet.empty c let restrict_universe_context (univs,csts) s = (* Universes that are not necessary to typecheck the term. E.g. univs introduced by tactics and not used in the proof term. *) let diff = LSet.diff univs s in let rec aux diff candid univs ness = let (diff', candid', univs', ness') = Constraint.fold (fun (l, d, r as c) (diff, candid, univs, csts) -> if not (LSet.mem l diff) then (LSet.remove r diff, candid, univs, Constraint.add c csts) else if not (LSet.mem r diff) then (LSet.remove l diff, candid, univs, Constraint.add c csts) else (diff, Constraint.add c candid, univs, csts)) candid (diff, Constraint.empty, univs, ness) in if ness' == ness then (LSet.diff univs diff', ness) else aux diff' candid' univs' ness' in aux diff csts univs Constraint.empty let simplify_universe_context (univs,csts) = let uf = UF.create () in let noneqs = Constraint.fold (fun (l,d,r) noneqs -> if d == Eq && (LSet.mem l univs || LSet.mem r univs) then (UF.union l r uf; noneqs) else Constraint.add (l,d,r) noneqs) csts Constraint.empty in let partition = UF.partition uf in let flex x = LSet.mem x univs in let subst, univs', csts' = List.fold_left (fun (subst, univs, cstrs) s -> let canon, (global, rigid, flexible) = choose_canonical univs flex LSet.empty s in (* Add equalities for globals which can't be merged anymore. *) let cstrs = LSet.fold (fun g cst -> Constraint.add (canon, Univ.Eq, g) cst) (LSet.union global rigid) cstrs in let subst = LSet.fold (fun f -> LMap.add f canon) flexible subst in (subst, LSet.diff univs flexible, cstrs)) (LMap.empty, univs, noneqs) partition in (* Noneqs is now in canonical form w.r.t. equality constraints, and contains only inequality constraints. *) let csts' = subst_univs_level_constraints subst csts' in (univs', csts'), subst let is_trivial_leq (l,d,r) = Univ.Level.is_prop l && (d == Univ.Le || (d == Univ.Lt && Univ.Level.is_set r)) (* Prop < i <-> Set+1 <= i <-> Set < i *) let translate_cstr (l,d,r as cstr) = if Level.equal Level.prop l && d == Univ.Lt && not (Level.equal Level.set r) then (Level.set, d, r) else cstr let refresh_constraints univs (ctx, cstrs) = let cstrs', univs' = Univ.Constraint.fold (fun c (cstrs', univs as acc) -> let c = translate_cstr c in if is_trivial_leq c then acc else (Univ.Constraint.add c cstrs', UGraph.enforce_constraint c univs)) cstrs (Univ.Constraint.empty, univs) in ((ctx, cstrs'), univs') (**********************************************************************) (* Tools for sort-polymorphic inductive types *) (* Miscellaneous functions to remove or test local univ assumed to occur only in the le constraints *) (* Solve a system of universe constraint of the form u_s11, ..., u_s1p1, w1 <= u1 ... u_sn1, ..., u_snpn, wn <= un where - the ui (1 <= i <= n) are universe variables, - the sjk select subsets of the ui for each equations, - the wi are arbitrary complex universes that do not mention the ui. *) let is_direct_sort_constraint s v = match s with | Some u -> univ_level_mem u v | None -> false let solve_constraints_system levels level_bounds level_min = let open Univ in let levels = Array.mapi (fun i o -> match o with | Some u -> (match Universe.level u with | Some u -> Some u | _ -> level_bounds.(i) <- Universe.sup level_bounds.(i) u; None) | None -> None) levels in let v = Array.copy level_bounds in let nind = Array.length v in let clos = Array.map (fun _ -> Int.Set.empty) levels in (* First compute the transitive closure of the levels dependencies *) for i=0 to nind-1 do for j=0 to nind-1 do if not (Int.equal i j) && is_direct_sort_constraint levels.(j) v.(i) then clos.(i) <- Int.Set.add j clos.(i); done; done; let rec closure () = let continue = ref false in Array.iteri (fun i deps -> let deps' = Int.Set.fold (fun j acc -> Int.Set.union acc clos.(j)) deps deps in if Int.Set.equal deps deps' then () else (clos.(i) <- deps'; continue := true)) clos; if !continue then closure () else () in closure (); for i=0 to nind-1 do for j=0 to nind-1 do if not (Int.equal i j) && Int.Set.mem j clos.(i) then (v.(i) <- Universe.sup v.(i) level_bounds.(j)); done; done; v coq-8.6/library/doc.tex0000644000175000017500000000100013022274260014401 0ustar mdenesmdenes \newpage \section*{The Coq library} \ocwsection \label{library} This chapter describes the \Coq\ library, which is made of two parts: \begin{itemize} \item a general mechanism to keep a trace of all operations and of the state of the system, with backtrack capabilities; \item a global environment for the CCI, with functions to export and import compiled modules. \end{itemize} The modules of the library are organized as follows. \bigskip \begin{center}\epsfig{file=library.dep.ps}\end{center} coq-8.6/library/globnames.ml0000644000175000017500000002025613022274260015431 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | _ -> false let isConstRef = function ConstRef _ -> true | _ -> false let isIndRef = function IndRef _ -> true | _ -> false let isConstructRef = function ConstructRef _ -> true | _ -> false let eq_gr gr1 gr2 = gr1 == gr2 || match gr1,gr2 with | ConstRef con1, ConstRef con2 -> eq_constant con1 con2 | IndRef kn1, IndRef kn2 -> eq_ind kn1 kn2 | ConstructRef kn1, ConstructRef kn2 -> eq_constructor kn1 kn2 | VarRef v1, VarRef v2 -> Id.equal v1 v2 | _ -> false let destVarRef = function VarRef ind -> ind | _ -> failwith "destVarRef" let destConstRef = function ConstRef ind -> ind | _ -> failwith "destConstRef" let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef" let destConstructRef = function ConstructRef ind -> ind | _ -> failwith "destConstructRef" let subst_constructor subst (ind,j as ref) = let ind' = subst_ind subst ind in if ind==ind' then ref, mkConstruct ref else (ind',j), mkConstruct (ind',j) let subst_global_reference subst ref = match ref with | VarRef var -> ref | ConstRef kn -> let kn' = subst_constant subst kn in if kn==kn' then ref else ConstRef kn' | IndRef ind -> let ind' = subst_ind subst ind in if ind==ind' then ref else IndRef ind' | ConstructRef ((kn,i),j as c) -> let c',t = subst_constructor subst c in if c'==c then ref else ConstructRef c' let subst_global subst ref = match ref with | VarRef var -> ref, mkVar var | ConstRef kn -> let kn',t = subst_con_kn subst kn in if kn==kn' then ref, mkConst kn else ConstRef kn', t | IndRef ind -> let ind' = subst_ind subst ind in if ind==ind' then ref, mkInd ind else IndRef ind', mkInd ind' | ConstructRef ((kn,i),j as c) -> let c',t = subst_constructor subst c in if c'==c then ref,t else ConstructRef c', t let canonical_gr = function | ConstRef con -> ConstRef(constant_of_kn(canonical_con con)) | IndRef (kn,i) -> IndRef(mind_of_kn(canonical_mind kn),i) | ConstructRef ((kn,i),j )-> ConstructRef((mind_of_kn(canonical_mind kn),i),j) | VarRef id -> VarRef id let global_of_constr c = match kind_of_term c with | Const (sp,u) -> ConstRef sp | Ind (ind_sp,u) -> IndRef ind_sp | Construct (cstr_cp,u) -> ConstructRef cstr_cp | Var id -> VarRef id | _ -> raise Not_found let is_global c t = match c, kind_of_term t with | ConstRef c, Const (c', _) -> eq_constant c c' | IndRef i, Ind (i', _) -> eq_ind i i' | ConstructRef i, Construct (i', _) -> eq_constructor i i' | VarRef id, Var id' -> id_eq id id' | _ -> false let printable_constr_of_global = function | VarRef id -> mkVar id | ConstRef sp -> mkConst sp | ConstructRef sp -> mkConstruct sp | IndRef sp -> mkInd sp let reference_of_constr = global_of_constr let global_eq_gen eq_cst eq_ind eq_cons x y = x == y || match x, y with | ConstRef cx, ConstRef cy -> eq_cst cx cy | IndRef indx, IndRef indy -> eq_ind indx indy | ConstructRef consx, ConstructRef consy -> eq_cons consx consy | VarRef v1, VarRef v2 -> Id.equal v1 v2 | (VarRef _ | ConstRef _ | IndRef _ | ConstructRef _), _ -> false let global_ord_gen ord_cst ord_ind ord_cons x y = if x == y then 0 else match x, y with | VarRef v1, VarRef v2 -> Id.compare v1 v2 | VarRef _, _ -> -1 | _, VarRef _ -> 1 | ConstRef cx, ConstRef cy -> ord_cst cx cy | ConstRef _, _ -> -1 | _, ConstRef _ -> 1 | IndRef indx, IndRef indy -> ord_ind indx indy | IndRef _, _ -> -1 | _ , IndRef _ -> 1 | ConstructRef consx, ConstructRef consy -> ord_cons consx consy let global_hash_gen hash_cst hash_ind hash_cons gr = let open Hashset.Combine in match gr with | ConstRef c -> combinesmall 1 (hash_cst c) | IndRef i -> combinesmall 2 (hash_ind i) | ConstructRef c -> combinesmall 3 (hash_cons c) | VarRef id -> combinesmall 4 (Id.hash id) (* By default, [global_reference] are ordered on their canonical part *) module RefOrdered = struct open Constant.CanOrd type t = global_reference let compare gr1 gr2 = global_ord_gen compare ind_ord constructor_ord gr1 gr2 let equal gr1 gr2 = global_eq_gen equal eq_ind eq_constructor gr1 gr2 let hash gr = global_hash_gen hash ind_hash constructor_hash gr end module RefOrdered_env = struct open Constant.UserOrd type t = global_reference let compare gr1 gr2 = global_ord_gen compare ind_user_ord constructor_user_ord gr1 gr2 let equal gr1 gr2 = global_eq_gen equal eq_user_ind eq_user_constructor gr1 gr2 let hash gr = global_hash_gen hash ind_user_hash constructor_user_hash gr end module Refmap = HMap.Make(RefOrdered) module Refset = Refmap.Set (* Alternative sets and maps indexed by the user part of the kernel names *) module Refmap_env = HMap.Make(RefOrdered_env) module Refset_env = Refmap_env.Set (* Extended global references *) type syndef_name = kernel_name type extended_global_reference = | TrueGlobal of global_reference | SynDef of syndef_name (* We order [extended_global_reference] via their user part (cf. pretty printer) *) module ExtRefOrdered = struct type t = extended_global_reference let equal x y = x == y || match x, y with | TrueGlobal rx, TrueGlobal ry -> RefOrdered_env.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 -> RefOrdered_env.compare rx ry | SynDef knx, SynDef kny -> kn_ord knx kny | TrueGlobal _, SynDef _ -> -1 | SynDef _, TrueGlobal _ -> 1 open Hashset.Combine let hash = function | TrueGlobal gr -> combinesmall 1 (RefOrdered_env.hash gr) | SynDef kn -> combinesmall 2 (KerName.hash kn) end type global_reference_or_constr = | IsGlobal of global_reference | IsConstr of constr (** {6 Temporary function to brutally form kernel names from section paths } *) let encode_mind dir id = MutInd.make2 (MPfile dir) (Label.of_id id) let encode_con dir id = Constant.make2 (MPfile dir) (Label.of_id id) let check_empty_section dp = if not (DirPath.is_empty dp) then anomaly (Pp.str "Section part should be empty!") let decode_mind kn = let rec dir_of_mp = function | MPfile dir -> DirPath.repr dir | MPbound mbid -> let _,_,dp = MBId.repr mbid in let id = MBId.to_id mbid in id::(DirPath.repr dp) | MPdot(mp,l) -> (Label.to_id l)::(dir_of_mp mp) in let mp,sec_dir,l = repr_mind kn in check_empty_section sec_dir; (DirPath.make (dir_of_mp mp)),Label.to_id l let decode_con kn = let mp,sec_dir,l = repr_con kn in check_empty_section sec_dir; match mp with | MPfile dir -> (dir,Label.to_id l) | _ -> anomaly (Pp.str "MPfile expected!") (** Popping one level of section in global names. These functions are meant to be used during discharge: user and canonical kernel names must be equal. *) let pop_con con = let (mp,dir,l) = repr_con con in Names.make_con mp (pop_dirpath dir) l let pop_kn kn = let (mp,dir,l) = repr_mind kn in Names.make_mind mp (pop_dirpath dir) l let pop_global_reference = function | ConstRef con -> ConstRef (pop_con con) | IndRef (kn,i) -> IndRef (pop_kn kn,i) | ConstructRef ((kn,i),j) -> ConstructRef ((pop_kn kn,i),j) | VarRef id -> anomaly (Pp.str "VarRef not poppable") coq-8.6/library/dischargedhypsmap.mli0000644000175000017500000000146513022274260017333 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* discharged_hyps -> unit val get_discharged_hyps : full_path -> discharged_hyps coq-8.6/library/states.mli0000644000175000017500000000307513022274260015136 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val extern_state : string -> unit type state val freeze : marshallable:Summary.marshallable -> state val unfreeze : state -> unit val summary_of_state : state -> Summary.frozen val replace_summary : state -> Summary.frozen -> state (** {6 Rollback } *) (** [with_state_protection f x] applies [f] to [x] and restores the state of the whole system as it was before applying [f] *) val with_state_protection : ('a -> 'b) -> 'a -> 'b (** [with_state_protection_on_exception f x] applies [f] to [x] and restores the state of the whole system as it was before applying [f] only if an exception is raised. Unlike [with_state_protection] it also takes into account the proof state *) val with_state_protection_on_exception : ('a -> 'b) -> 'a -> 'b coq-8.6/library/library.mli0000644000175000017500000000673013022274260015300 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool option -> unit (** {6 Start the compilation of a library } *) (** Segments of a library *) type seg_sum type seg_lib type seg_univ = (* cst, all_cst, finished? *) Univ.universe_context_set Future.computation array * Univ.universe_context_set * bool type seg_discharge = Opaqueproof.cooking_info list array type seg_proofs = Term.constr Future.computation array (** Open a module (or a library); if the boolean is true then it's also an export otherwise just a simple import *) val import_module : bool -> qualid located list -> unit (** Start the compilation of a file as a library. The first argument must be output file, and the returned path is the associated absolute logical path of the library. *) val start_library : CUnix.physical_path -> DirPath.t (** End the compilation of a library and save it to a ".vo" file *) val save_library_to : ?todo:(((Future.UUID.t,'document) Stateid.request * bool) list * 'counters) -> DirPath.t -> string -> Opaqueproof.opaquetab -> unit val load_library_todo : string -> string * seg_sum * seg_lib * seg_univ * seg_discharge * 'tasks * seg_proofs val save_library_raw : string -> seg_sum -> seg_lib -> seg_univ -> seg_proofs -> unit (** {6 Interrogate the status of libraries } *) (** - Tell if a library is loaded or opened *) val library_is_loaded : DirPath.t -> bool val library_is_opened : DirPath.t -> bool (** - Tell which libraries are loaded or imported *) val loaded_libraries : unit -> DirPath.t list val opened_libraries : unit -> DirPath.t list (** - Return the full filename of a loaded library. *) val library_full_filename : DirPath.t -> string (** - Overwrite the filename of all libraries (used when restoring a state) *) val overwrite_library_filenames : string -> unit (** {6 Hook for the xml exportation of libraries } *) val xml_require : (DirPath.t -> unit) Hook.t (** {6 Locate a library in the load paths } *) exception LibUnmappedDir exception LibNotFound type library_location = LibLoaded | LibInPath val locate_qualified_library : ?root:DirPath.t -> ?warn:bool -> qualid -> library_location * DirPath.t * CUnix.physical_path (** Locates a library by implicit name. @raise LibUnmappedDir if the library is not in the path @raise LibNotFound if there is no corresponding file in the path *) (** {6 Native compiler. } *) val native_name_from_filename : string -> string coq-8.6/library/decls.ml0000644000175000017500000000461313022274260014553 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let id = get_id d in let d = if variable_opacity id then LocalAssum (id, get_type d) else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val let last_section_hyps dir = Context.Named.fold_outside (fun d sec_ids -> let id = get_id d in try if DirPath.equal dir (variable_path id) then id::sec_ids else sec_ids with Not_found -> sec_ids) (Environ.named_context (Global.env())) ~init:[] coq-8.6/library/loadpath.mli0000644000175000017500000000421113022274260015420 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* CUnix.physical_path (** Get the physical path (filesystem location) of a loadpath. *) val logical : t -> DirPath.t (** Get the logical path (Coq module hierarchy) of a loadpath. *) val get_load_paths : unit -> t list (** Get the current loadpath association. *) val add_load_path : CUnix.physical_path -> DirPath.t -> implicit:bool -> unit (** [add_load_path phys log type] adds the binding [phys := log] to the current loadpaths. *) val remove_load_path : CUnix.physical_path -> unit (** Remove the current logical path binding associated to a given physical path, if any. *) val find_load_path : CUnix.physical_path -> t (** Get the binding associated to a physical path. Raises [Not_found] if there is none. *) val is_in_load_paths : CUnix.physical_path -> bool (** Whether a physical path is currently bound. *) val expand_path : ?root:DirPath.t -> DirPath.t -> (CUnix.physical_path * DirPath.t) list (** Given a relative logical path, associate the list of absolute physical and logical paths which are possible matches of it. *) val filter_path : (DirPath.t -> bool) -> (CUnix.physical_path * DirPath.t) list (** As {!expand_path} but uses a filter function instead, and ignores the implicit status of loadpaths. *) val locate_file : string -> string (** Locate a file among the registered paths. Do not use this function, as it does not respect the visibility of paths. *) coq-8.6/library/global.mli0000644000175000017500000001450713022274260015075 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Safe_typing.safe_environment val env : unit -> Environ.env val env_is_initial : unit -> bool val universes : unit -> UGraph.t val named_context_val : unit -> Environ.named_context_val val named_context : unit -> Context.Named.t (** {6 Enriching the global environment } *) (** Changing the (im)predicativity of the system *) val set_engagement : Declarations.engagement -> unit val set_typing_flags : Declarations.typing_flags -> unit (** Variables, Local definitions, constants, inductive types *) val push_named_assum : (Id.t * Constr.types * bool) Univ.in_universe_context_set -> unit val push_named_def : (Id.t * Safe_typing.private_constants Entries.definition_entry) -> Univ.universe_context_set val add_constant : DirPath.t -> Id.t -> Safe_typing.global_declaration -> constant * Safe_typing.exported_private_constant list val add_mind : DirPath.t -> Id.t -> Entries.mutual_inductive_entry -> mutual_inductive (** Extra universe constraints *) val add_constraints : Univ.constraints -> unit val push_context : bool -> Univ.universe_context -> unit val push_context_set : bool -> Univ.universe_context_set -> unit (** Non-interactive modules and module types *) val add_module : Id.t -> Entries.module_entry -> Declarations.inline -> module_path * Mod_subst.delta_resolver val add_modtype : Id.t -> Entries.module_type_entry -> Declarations.inline -> module_path val add_include : Entries.module_struct_entry -> bool -> Declarations.inline -> Mod_subst.delta_resolver (** Interactive modules and module types *) val start_module : Id.t -> module_path val start_modtype : Id.t -> module_path val end_module : Summary.frozen -> Id.t -> (Entries.module_struct_entry * Declarations.inline) option -> module_path * MBId.t list * Mod_subst.delta_resolver val end_modtype : Summary.frozen -> Id.t -> module_path * MBId.t list val add_module_parameter : MBId.t -> Entries.module_struct_entry -> Declarations.inline -> Mod_subst.delta_resolver (** {6 Queries in the global environment } *) val lookup_named : variable -> Context.Named.Declaration.t val lookup_constant : constant -> Declarations.constant_body val lookup_inductive : inductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body val lookup_pinductive : Constr.pinductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body val lookup_mind : mutual_inductive -> Declarations.mutual_inductive_body val lookup_module : module_path -> Declarations.module_body val lookup_modtype : module_path -> Declarations.module_type_body val exists_objlabel : Label.t -> bool val constant_of_delta_kn : kernel_name -> constant val mind_of_delta_kn : kernel_name -> mutual_inductive val opaque_tables : unit -> Opaqueproof.opaquetab val body_of_constant : constant -> Term.constr option val body_of_constant_body : Declarations.constant_body -> Term.constr option val constraints_of_constant_body : Declarations.constant_body -> Univ.constraints val universes_of_constant_body : Declarations.constant_body -> Univ.universe_context (** {6 Compiled libraries } *) val start_library : DirPath.t -> module_path val export : ?except:Future.UUIDSet.t -> DirPath.t -> module_path * Safe_typing.compiled_library * Safe_typing.native_library val import : Safe_typing.compiled_library -> Univ.universe_context_set -> Safe_typing.vodigest -> module_path (** {6 Misc } *) (** Function to get an environment from the constants part of the global * environment and a given context. *) val env_of_context : Environ.named_context_val -> Environ.env val join_safe_environment : ?except:Future.UUIDSet.t -> unit -> unit val is_joined_environment : unit -> bool val is_polymorphic : Globnames.global_reference -> bool val is_template_polymorphic : Globnames.global_reference -> bool val is_type_in_type : Globnames.global_reference -> bool val type_of_global_in_context : Environ.env -> Globnames.global_reference -> Constr.types Univ.in_universe_context (** Returns the type of the constant in its global or local universe context. The type should not be used without pushing it's universe context in the environmnent of usage. For non-universe-polymorphic constants, it does not matter. *) val type_of_global_unsafe : Globnames.global_reference -> Constr.types (** Returns the type of the constant, forgetting its universe context if it is polymorphic, use with care: for polymorphic constants, the type cannot be used to produce a term used by the kernel. For safe handling of polymorphic global references, one should look at a particular instantiation of the reference, in some particular universe context (part of an [env] or [evar_map]), see e.g. [type_of_constant_in]. If you want to create a fresh instance of the reference and get its type look at [Evd.fresh_global] or [Evarutil.new_global] and [Retyping.get_type_of]. *) (** Returns the universe context of the global reference (whatever its polymorphic status is). *) val universes_of_global : Globnames.global_reference -> Univ.universe_context (** {6 Retroknowledge } *) val register : Retroknowledge.field -> Term.constr -> Term.constr -> unit val register_inline : constant -> unit (** {6 Oracle } *) val set_strategy : Names.constant Names.tableKey -> Conv_oracle.level -> unit (* Modifies the global state, registering new universes *) val current_dirpath : unit -> Names.dir_path val with_global : (Environ.env -> Names.dir_path -> 'a Univ.in_universe_context_set) -> 'a val global_env_summary_name : string coq-8.6/library/impargs.ml0000644000175000017500000006305713022274260015132 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let reraise = CErrors.push reraise in let () = implicit_args := oflags in iraise reraise let set_maximality imps b = (* Force maximal insertion on ending implicits (compatibility) *) let is_set x = match x with None -> false | _ -> true in b || List.for_all is_set imps (*s Computation of implicit arguments *) (* We remember various information about why an argument is inferable as implicit - [DepRigid] means that the implicit argument can be found by unification along a rigid path (we do not print the arguments of this kind if there is enough arguments to infer them) - [DepFlex] means that the implicit argument can be found by unification along a collapsable path only (e.g. as x in (P x) where P is another argument) (we do (defensively) print the arguments of this kind) - [DepFlexAndRigid] means that the least argument from which the implicit argument can be inferred is following a collapsable path but there is a greater argument from where the implicit argument is inferable following a rigid path (useful to know how to print a partial application) - [Manual] means the argument has been explicitly set as implicit. We also consider arguments inferable from the conclusion but it is operational only if [conclusion_matters] is true. *) type argument_position = | Conclusion | Hyp of int let argument_position_eq p1 p2 = match p1, p2 with | Conclusion, Conclusion -> true | Hyp h1, Hyp h2 -> Int.equal h1 h2 | _ -> false let explicitation_eq ex1 ex2 = match ex1, ex2 with | ExplByPos (i1, id1), ExplByPos (i2, id2) -> Int.equal i1 i2 && Option.equal Id.equal id1 id2 | ExplByName id1, ExplByName id2 -> Id.equal id1 id2 | _ -> false type implicit_explanation = | DepRigid of argument_position | DepFlex of argument_position | DepFlexAndRigid of (*flex*) argument_position * (*rig*) argument_position | Manual let argument_less = function | Hyp n, Hyp n' -> n true | Conclusion, _ -> false let update pos rig (na,st) = let e = if rig then match st with | None -> DepRigid pos | Some (DepRigid n as x) -> if argument_less (pos,n) then DepRigid pos else x | Some (DepFlexAndRigid (fpos,rpos) as x) -> if argument_less (pos,fpos) || argument_position_eq pos fpos then DepRigid pos else if argument_less (pos,rpos) then DepFlexAndRigid (fpos,pos) else x | Some (DepFlex fpos) -> if argument_less (pos,fpos) || argument_position_eq pos fpos then DepRigid pos else DepFlexAndRigid (fpos,pos) | Some Manual -> assert false else match st with | None -> DepFlex pos | Some (DepRigid rpos as x) -> if argument_less (pos,rpos) then DepFlexAndRigid (pos,rpos) else x | Some (DepFlexAndRigid (fpos,rpos) as x) -> if argument_less (pos,fpos) then DepFlexAndRigid (pos,rpos) else x | Some (DepFlex fpos as x) -> if argument_less (pos,fpos) then DepFlex pos else x | Some Manual -> assert false in na, Some e (* modified is_rigid_reference with a truncated env *) let is_flexible_reference env bound depth f = let open Context.Named.Declaration in match kind_of_term f with | Rel n when n >= bound+depth -> (* inductive type *) false | Rel n when n >= depth -> (* previous argument *) true | Rel n -> (* since local definitions have been expanded *) false | Const (kn,_) -> let cb = Environ.lookup_constant kn env in (match cb.const_body with Def _ -> true | _ -> false) | Var id -> Environ.lookup_named id env |> is_local_def | Ind _ | Construct _ -> false | _ -> true let push_lift d (e,n) = (push_rel d e,n+1) let is_reversible_pattern bound depth f l = isRel f && let n = destRel f in (n < bound+depth) && (n >= depth) && Array.for_all (fun c -> isRel c && destRel c < depth) l && Array.distinct l (* Precondition: rels in env are for inductive types only *) let add_free_rels_until strict strongly_strict revpat bound env m pos acc = let rec frec rig (env,depth as ed) c = let hd = if strict then whd_all env c else c in let c = if strongly_strict then hd else c in match kind_of_term hd with | Rel n when (n < bound+depth) && (n >= depth) -> let i = bound + depth - n - 1 in acc.(i) <- update pos rig acc.(i) | App (f,l) when revpat && is_reversible_pattern bound depth f l -> let i = bound + depth - destRel f - 1 in acc.(i) <- update pos rig acc.(i) | App (f,_) when rig && is_flexible_reference env bound depth f -> if strict then () else iter_constr_with_full_binders push_lift (frec false) ed c | Proj (p,c) when rig -> if strict then () else iter_constr_with_full_binders push_lift (frec false) ed c | Case _ when rig -> if strict then () else iter_constr_with_full_binders push_lift (frec false) ed c | Evar _ -> () | _ -> iter_constr_with_full_binders push_lift (frec rig) ed c in let () = if not (Vars.noccur_between 1 bound m) then frec true (env,1) m in acc let rec is_rigid_head t = match kind_of_term t with | Rel _ | Evar _ -> false | Ind _ | Const _ | Var _ | Sort _ -> true | Case (_,_,f,_) -> is_rigid_head f | Proj (p,c) -> true | App (f,args) -> (match kind_of_term f with | Fix ((fi,i),_) -> is_rigid_head (args.(fi.(i))) | _ -> is_rigid_head f) | Lambda _ | LetIn _ | Construct _ | CoFix _ | Fix _ | Prod _ | Meta _ | Cast _ -> assert false (* calcule la liste des arguments implicites *) let find_displayed_name_in all avoid na (_,b as envnames_b) = let flag = RenamingElsewhereFor envnames_b in if all then compute_and_force_displayed_name_in flag avoid na b else compute_displayed_name_in flag avoid na b let compute_implicits_gen strict strongly_strict revpat contextual all env t = let rigid = ref true in let open Context.Rel.Declaration in let rec aux env avoid n names t = let t = whd_all env t in match kind_of_term t with | Prod (na,a,b) -> let na',avoid' = find_displayed_name_in all avoid na (names,b) in add_free_rels_until strict strongly_strict revpat n env a (Hyp (n+1)) (aux (push_rel (LocalAssum (na',a)) env) avoid' (n+1) (na'::names) b) | _ -> rigid := is_rigid_head t; let names = List.rev names in let v = Array.map (fun na -> na,None) (Array.of_list names) in if contextual then add_free_rels_until strict strongly_strict revpat n env t Conclusion v else v in match kind_of_term (whd_all env t) with | Prod (na,a,b) -> let na',avoid = find_displayed_name_in all [] na ([],b) in let v = aux (push_rel (LocalAssum (na',a)) env) avoid 1 [na'] b in !rigid, Array.to_list v | _ -> true, [] let compute_implicits_flags env f all t = compute_implicits_gen (f.strict || f.strongly_strict) f.strongly_strict f.reversible_pattern f.contextual all env t let compute_auto_implicits env flags enriching t = if enriching then compute_implicits_flags env flags true t else compute_implicits_gen false false false true true env t let compute_implicits_names env t = let _, impls = compute_implicits_gen false false false false true env t in List.map fst impls (* Extra information about implicit arguments *) type maximal_insertion = bool (* true = maximal contextual insertion *) type force_inference = bool (* true = always infer, never turn into evar/subgoal *) type implicit_status = (* None = Not implicit *) (Id.t * implicit_explanation * (maximal_insertion * force_inference)) option type implicit_side_condition = DefaultImpArgs | LessArgsThan of int type implicits_list = implicit_side_condition * implicit_status list let is_status_implicit = function | None -> false | _ -> true let name_of_implicit = function | None -> anomaly (Pp.str "Not an implicit argument") | Some (id,_,_) -> id let maximal_insertion_of = function | Some (_,_,(b,_)) -> b | None -> anomaly (Pp.str "Not an implicit argument") let force_inference_of = function | Some (_, _, (_, b)) -> b | None -> anomaly (Pp.str "Not an implicit argument") (* [in_ctx] means we know the expected type, [n] is the index of the argument *) let is_inferable_implicit in_ctx n = function | None -> false | Some (_,DepRigid (Hyp p),_) -> in_ctx || n >= p | Some (_,DepFlex (Hyp p),_) -> false | Some (_,DepFlexAndRigid (_,Hyp q),_) -> in_ctx || n >= q | Some (_,DepRigid Conclusion,_) -> in_ctx | Some (_,DepFlex Conclusion,_) -> false | Some (_,DepFlexAndRigid (_,Conclusion),_) -> in_ctx | Some (_,Manual,_) -> true let positions_of_implicits (_,impls) = let rec aux n = function [] -> [] | Some _ :: l -> n :: aux (n+1) l | None :: l -> aux (n+1) l in aux 1 impls (* Manage user-given implicit arguments *) let rec prepare_implicits f = function | [] -> [] | (Anonymous, Some _)::_ -> anomaly (Pp.str "Unnamed implicit") | (Name id, Some imp)::imps -> let imps' = prepare_implicits f imps in Some (id,imp,(set_maximality imps' f.maximal,true)) :: imps' | _::imps -> None :: prepare_implicits f imps let set_implicit id imp insmax = (id,(match imp with None -> Manual | Some imp -> imp),insmax) let rec assoc_by_pos k = function (ExplByPos (k', x), b) :: tl when Int.equal k k' -> (x,b), tl | hd :: tl -> let (x, tl) = assoc_by_pos k tl in x, hd :: tl | [] -> raise Not_found let check_correct_manual_implicits autoimps l = List.iter (function | ExplByName id,(b,fi,forced) -> if not forced then errorlabstrm "" (str "Wrong or non-dependent implicit argument name: " ++ pr_id id ++ str ".") | ExplByPos (i,_id),_t -> if i<1 || i>List.length autoimps then errorlabstrm "" (str "Bad implicit argument number: " ++ int i ++ str ".") else errorlabstrm "" (str "Cannot set implicit argument number " ++ int i ++ str ": it has no name.")) l let set_manual_implicits env flags enriching autoimps l = let try_forced k l = try let (id, (b, fi, fo)), l' = assoc_by_pos k l in if fo then let id = match id with Some id -> id | None -> Id.of_string ("arg_" ^ string_of_int k) in l', Some (id,Manual,(b,fi)) else l, None with Not_found -> l, None in if not (List.distinct l) then error ("Some parameters are referred more than once."); (* Compare with automatic implicits to recover printing data and names *) let rec merge k l = function | (Name id,imp)::imps -> let l',imp,m = try let eq = explicitation_eq in let (b, fi, fo) = List.assoc_f eq (ExplByName id) l in List.remove_assoc_f eq (ExplByName id) l, (Some Manual), (Some (b, fi)) with Not_found -> try let (id, (b, fi, fo)), l' = assoc_by_pos k l in l', (Some Manual), (Some (b,fi)) with Not_found -> let m = match enriching, imp with | true, Some _ -> Some (flags.maximal, true) | _ -> None in l, imp, m in let imps' = merge (k+1) l' imps in let m = Option.map (fun (b,f) -> (* match imp with Some Manual -> (b,f) *) (* | _ -> *)set_maximality imps' b, f) m in Option.map (set_implicit id imp) m :: imps' | (Anonymous,imp)::imps -> let l', forced = try_forced k l in forced :: merge (k+1) l' imps | [] when begin match l with [] -> true | _ -> false end -> [] | [] -> check_correct_manual_implicits autoimps l; [] in merge 1 l autoimps let compute_semi_auto_implicits env f manual t = match manual with | [] -> if not f.auto then [DefaultImpArgs, []] else let _,l = compute_implicits_flags env f false t in [DefaultImpArgs, prepare_implicits f l] | _ -> let _,autoimpls = compute_auto_implicits env f f.auto t in [DefaultImpArgs, set_manual_implicits env f f.auto autoimpls manual] (*s Constants. *) let compute_constant_implicits flags manual cst = let env = Global.env () in let cb = Environ.lookup_constant cst env in let ty = Typeops.type_of_constant_type env cb.const_type in let impls = compute_semi_auto_implicits env flags manual ty in impls (*s Inductives and constructors. Their implicit arguments are stored in an array, indexed by the inductive number, of pairs $(i,v)$ where $i$ are the implicit arguments of the inductive and $v$ the array of implicit arguments of the constructors. *) let compute_mib_implicits flags manual kn = let env = Global.env () in let mib = lookup_mind kn env in let ar = Array.to_list (Array.mapi (* No need to lift, arities contain no de Bruijn *) (fun i mip -> (** No need to care about constraints here *) Context.Rel.Declaration.LocalAssum (Name mip.mind_typename, Global.type_of_global_unsafe (IndRef (kn,i)))) mib.mind_packets) in let env_ar = push_rel_context ar env in let imps_one_inductive i mip = let ind = (kn,i) in let ar = Global.type_of_global_unsafe (IndRef ind) in ((IndRef ind,compute_semi_auto_implicits env flags manual ar), Array.mapi (fun j c -> (ConstructRef (ind,j+1),compute_semi_auto_implicits env_ar flags manual c)) mip.mind_nf_lc) in Array.mapi imps_one_inductive mib.mind_packets let compute_all_mib_implicits flags manual kn = let imps = compute_mib_implicits flags manual kn in List.flatten (Array.map_to_list (fun (ind,cstrs) -> ind::Array.to_list cstrs) imps) (*s Variables. *) let compute_var_implicits flags manual id = let env = Global.env () in let open Context.Named.Declaration in compute_semi_auto_implicits env flags manual (get_type (lookup_named id env)) (* Implicits of a global reference. *) let compute_global_implicits flags manual = function | VarRef id -> compute_var_implicits flags manual id | ConstRef kn -> compute_constant_implicits flags manual kn | IndRef (kn,i) -> let ((_,imps),_) = (compute_mib_implicits flags manual kn).(i) in imps | ConstructRef ((kn,i),j) -> let (_,cimps) = (compute_mib_implicits flags manual kn).(i) in snd cimps.(j-1) (* Merge a manual explicitation with an implicit_status list *) let merge_impls (cond,oldimpls) (_,newimpls) = let oldimpls,usersuffiximpls = List.chop (List.length newimpls) oldimpls in cond, (List.map2 (fun orig ni -> match orig with | Some (_, Manual, _) -> orig | _ -> ni) oldimpls newimpls)@usersuffiximpls (* Caching implicits *) type implicit_interactive_request = | ImplAuto | ImplManual of int type implicit_discharge_request = | ImplLocal | ImplConstant of constant * implicits_flags | ImplMutualInductive of mutual_inductive * implicits_flags | ImplInteractive of global_reference * implicits_flags * implicit_interactive_request let implicits_table = Summary.ref Refmap.empty ~name:"implicits" let implicits_of_global ref = try let l = Refmap.find ref !implicits_table in try let rename_l = Arguments_renaming.arguments_names ref in let rec rename implicits names = match implicits, names with | [], _ -> [] | _, [] -> implicits | Some (_, x,y) :: implicits, Name id :: names -> Some (id, x,y) :: rename implicits names | imp :: implicits, _ :: names -> imp :: rename implicits names in List.map (fun (t, il) -> t, rename il rename_l) l with Not_found -> l with Not_found -> [DefaultImpArgs,[]] let cache_implicits_decl (ref,imps) = implicits_table := Refmap.add ref imps !implicits_table let load_implicits _ (_,(_,l)) = List.iter cache_implicits_decl l let cache_implicits o = load_implicits 1 o let subst_implicits_decl subst (r,imps as o) = let r' = fst (subst_global subst r) in if r==r' then o else (r',imps) let subst_implicits (subst,(req,l)) = (ImplLocal,List.smartmap (subst_implicits_decl subst) l) let impls_of_context ctx = let map (id, impl, _, _) = match impl with | Implicit -> Some (id, Manual, (true, true)) | _ -> None in let is_set (_, _, b, _) = match b with | None -> true | Some _ -> false in List.rev_map map (List.filter is_set ctx) let adjust_side_condition p = function | LessArgsThan n -> LessArgsThan (n+p) | DefaultImpArgs -> DefaultImpArgs let add_section_impls vars extra_impls (cond,impls) = let p = List.length vars - List.length extra_impls in adjust_side_condition p cond, extra_impls @ impls let discharge_implicits (_,(req,l)) = match req with | ImplLocal -> None | ImplInteractive (ref,flags,exp) -> (try let vars = variable_section_segment_of_reference ref in let ref' = if isVarRef ref then ref else pop_global_reference ref in let extra_impls = impls_of_context vars in let l' = [ref', List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in Some (ImplInteractive (ref',flags,exp),l') with Not_found -> (* ref not defined in this section *) Some (req,l)) | ImplConstant (con,flags) -> (try let con' = pop_con con in let vars,_,_ = section_segment_of_constant con in let extra_impls = impls_of_context vars in let newimpls = List.map (add_section_impls vars extra_impls) (snd (List.hd l)) in let l' = [ConstRef con',newimpls] in Some (ImplConstant (con',flags),l') with Not_found -> (* con not defined in this section *) Some (req,l)) | ImplMutualInductive (kn,flags) -> (try let l' = List.map (fun (gr, l) -> let vars = variable_section_segment_of_reference gr in let extra_impls = impls_of_context vars in ((if isVarRef gr then gr else pop_global_reference gr), List.map (add_section_impls vars extra_impls) l)) l in Some (ImplMutualInductive (pop_kn kn,flags),l') with Not_found -> (* ref not defined in this section *) Some (req,l)) let rebuild_implicits (req,l) = match req with | ImplLocal -> assert false | ImplConstant (con,flags) -> let oldimpls = snd (List.hd l) in let newimpls = compute_constant_implicits flags [] con in req, [ConstRef con, List.map2 merge_impls oldimpls newimpls] | ImplMutualInductive (kn,flags) -> let newimpls = compute_all_mib_implicits flags [] kn in let rec aux olds news = match olds, news with | (_, oldimpls) :: old, (gr, newimpls) :: tl -> (gr, List.map2 merge_impls oldimpls newimpls) :: aux old tl | [], [] -> [] | _, _ -> assert false in req, aux l newimpls | ImplInteractive (ref,flags,o) -> (if isVarRef ref && is_in_section ref then ImplLocal else req), match o with | ImplAuto -> let oldimpls = snd (List.hd l) in let newimpls = compute_global_implicits flags [] ref in [ref,List.map2 merge_impls oldimpls newimpls] | ImplManual userimplsize -> let oldimpls = snd (List.hd l) in if flags.auto then let newimpls = List.hd (compute_global_implicits flags [] ref) in let p = List.length (snd newimpls) - userimplsize in let newimpls = on_snd (List.firstn p) newimpls in [ref,List.map (fun o -> merge_impls o newimpls) oldimpls] else [ref,oldimpls] let classify_implicits (req,_ as obj) = match req with | ImplLocal -> Dispose | _ -> Substitute obj type implicits_obj = implicit_discharge_request * (global_reference * implicits_list list) list let inImplicits : implicits_obj -> obj = declare_object {(default_object "IMPLICITS") with cache_function = cache_implicits; load_function = load_implicits; subst_function = subst_implicits; classify_function = classify_implicits; discharge_function = discharge_implicits; rebuild_function = rebuild_implicits } let is_local local ref = local || isVarRef ref && is_in_section ref let declare_implicits_gen req flags ref = let imps = compute_global_implicits flags [] ref in add_anonymous_leaf (inImplicits (req,[ref,imps])) let declare_implicits local ref = let flags = { !implicit_args with auto = true } in let req = if is_local local ref then ImplLocal else ImplInteractive(ref,flags,ImplAuto) in declare_implicits_gen req flags ref let declare_var_implicits id = let flags = !implicit_args in declare_implicits_gen ImplLocal flags (VarRef id) let declare_constant_implicits con = let flags = !implicit_args in declare_implicits_gen (ImplConstant (con,flags)) flags (ConstRef con) let declare_mib_implicits kn = let flags = !implicit_args in let imps = Array.map_to_list (fun (ind,cstrs) -> ind::(Array.to_list cstrs)) (compute_mib_implicits flags [] kn) in add_anonymous_leaf (inImplicits (ImplMutualInductive (kn,flags),List.flatten imps)) (* Declare manual implicits *) type manual_explicitation = Constrexpr.explicitation * (bool * bool * bool) type manual_implicits = manual_explicitation list let compute_implicits_with_manual env typ enriching l = let _,autoimpls = compute_auto_implicits env !implicit_args enriching typ in set_manual_implicits env !implicit_args enriching autoimpls l let check_inclusion l = (* Check strict inclusion *) let rec aux = function | n1::(n2::_ as nl) -> if n1 <= n2 then error "Sequences of implicit arguments must be of different lengths."; aux nl | _ -> () in aux (List.map (fun (imps,_) -> List.length imps) l) let check_rigidity isrigid = if not isrigid then errorlabstrm "" (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") let projection_implicits env p impls = let pb = Environ.lookup_projection p env in CList.skipn_at_least pb.Declarations.proj_npars impls let declare_manual_implicits local ref ?enriching l = let flags = !implicit_args in let env = Global.env () in let t = Global.type_of_global_unsafe ref in let enriching = Option.default flags.auto enriching in let isrigid,autoimpls = compute_auto_implicits env flags enriching t in let l' = match l with | [] -> assert false | [l] -> [DefaultImpArgs, set_manual_implicits env flags enriching autoimpls l] | _ -> check_rigidity isrigid; let l = List.map (fun imps -> (imps,List.length imps)) l in let l = List.sort (fun (_,n1) (_,n2) -> n2 - n1) l in check_inclusion l; let nargs = List.length autoimpls in List.map (fun (imps,n) -> (LessArgsThan (nargs-n), set_manual_implicits env flags enriching autoimpls imps)) l in let req = if is_local local ref then ImplLocal else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) in add_anonymous_leaf (inImplicits (req,[ref,l'])) let maybe_declare_manual_implicits local ref ?enriching l = match l with | [] -> () | _ -> declare_manual_implicits local ref ?enriching [l] let extract_impargs_data impls = let rec aux p = function | (DefaultImpArgs, imps)::_ -> [None,imps] | (LessArgsThan n, imps)::l -> (Some (p,n),imps) :: aux (n+1) l | [] -> [] in aux 0 impls let lift_implicits n = List.map (fun x -> match fst x with ExplByPos (k, id) -> ExplByPos (k + n, id), snd x | _ -> x) let make_implicits_list l = [DefaultImpArgs, l] let rec drop_first_implicits p l = if Int.equal p 0 then l else match l with | _,[] as x -> x | DefaultImpArgs,imp::impls -> drop_first_implicits (p-1) (DefaultImpArgs,impls) | LessArgsThan n,imp::impls -> let n = if is_status_implicit imp then n-1 else n in drop_first_implicits (p-1) (LessArgsThan n,impls) let rec select_impargs_size n = function | [] -> [] (* Tolerance for (DefaultImpArgs,[]) *) | [_, impls] | (DefaultImpArgs, impls)::_ -> impls | (LessArgsThan p, impls)::l -> if n <= p then impls else select_impargs_size n l let select_stronger_impargs = function | [] -> [] (* Tolerance for (DefaultImpArgs,[]) *) | (_,impls)::_ -> impls coq-8.6/library/heads.ml0000644000175000017500000001437013022274260014546 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* phi(x))] where [g] is [fun f => g O] does not launch the evaluation of [phi(0)] and the head of [h] is declared unknown). *) type rigid_head_kind = | RigidParameter of constant (* a Const without body *) | RigidVar of variable (* a Var without body *) | RigidType (* an inductive, a product or a sort *) type head_approximation = | RigidHead of rigid_head_kind | ConstructorHead | FlexibleHead of int * int * int * bool (* [true] if a surrounding case *) | NotImmediatelyComputableHead (** Registration as global tables and rollback. *) module Evalreford = struct type t = evaluable_global_reference let compare gr1 gr2 = match gr1, gr2 with | EvalVarRef id1, EvalVarRef id2 -> Id.compare id1 id2 | EvalVarRef _, EvalConstRef _ -> -1 | EvalConstRef c1, EvalConstRef c2 -> Constant.CanOrd.compare c1 c2 | EvalConstRef _, EvalVarRef _ -> 1 end module Evalrefmap = Map.Make (Evalreford) let head_map = Summary.ref Evalrefmap.empty ~name:"Head_decl" let variable_head id = Evalrefmap.find (EvalVarRef id) !head_map let constant_head cst = Evalrefmap.find (EvalConstRef cst) !head_map let kind_of_head env t = let rec aux k l t b = match kind_of_term (Reduction.whd_betaiotazeta env t) with | Rel n when n > k -> NotImmediatelyComputableHead | Rel n -> FlexibleHead (k,k+1-n,List.length l,b) | Var id -> (try on_subterm k l b (variable_head id) with Not_found -> (* a goal variable *) match lookup_named id env with | LocalDef (_,c,_) -> aux k l c b | LocalAssum _ -> NotImmediatelyComputableHead) | Const (cst,_) -> (try on_subterm k l b (constant_head cst) with Not_found -> CErrors.anomaly Pp.(str "constant not found in kind_of_head: " ++ str (Names.Constant.to_string cst))) | Construct _ | CoFix _ -> if b then NotImmediatelyComputableHead else ConstructorHead | Sort _ | Ind _ | Prod _ -> RigidHead RigidType | Cast (c,_,_) -> aux k l c b | Lambda (_,_,c) -> begin match l with | [] -> let () = assert (not b) in aux (k + 1) [] c b | h :: l -> aux k l (subst1 h c) b end | LetIn _ -> assert false | Meta _ | Evar _ -> NotImmediatelyComputableHead | App (c,al) -> aux k (Array.to_list al @ l) c b | Proj (p,c) -> (try on_subterm k (c :: l) b (constant_head (Projection.constant p)) with Not_found -> assert false) | Case (_,_,c,_) -> aux k [] c true | Fix ((i,j),_) -> let n = i.(j) in try aux k [] (List.nth l n) true with Failure _ -> FlexibleHead (k + n + 1, k + n + 1, 0, true) and on_subterm k l with_case = function | FlexibleHead (n,i,q,with_subcase) -> let m = List.length l in let k',rest,a = if n > m then (* eta-expansion *) let a = if i <= m then (* we pick the head in the existing arguments *) lift (n-m) (List.nth l (i-1)) else (* we pick the head in the added arguments *) mkRel (n-i+1) in k+n-m,[],a else (* enough arguments to [cst] *) k,List.skipn n l,List.nth l (i-1) in let l' = List.make q (mkMeta 0) @ rest in aux k' l' a (with_subcase || with_case) | ConstructorHead when with_case -> NotImmediatelyComputableHead | x -> x in aux 0 [] t false (* FIXME: maybe change interface here *) let compute_head = function | EvalConstRef cst -> let env = Global.env() in let cb = Environ.lookup_constant cst env in let is_Def = function Declarations.Def _ -> true | _ -> false in let body = if cb.Declarations.const_proj = None && is_Def cb.Declarations.const_body then Declareops.body_of_constant (Environ.opaque_tables env) cb else None in (match body with | None -> RigidHead (RigidParameter cst) | Some c -> kind_of_head env c) | EvalVarRef id -> (match Global.lookup_named id with | LocalDef (_,c,_) when not (Decls.variable_opacity id) -> kind_of_head (Global.env()) c | _ -> RigidHead (RigidVar id)) let is_rigid env t = match kind_of_head env t with | RigidHead _ | ConstructorHead -> true | _ -> false (** Registration of heads as an object *) let load_head _ (_,(ref,(k:head_approximation))) = head_map := Evalrefmap.add ref k !head_map let cache_head o = load_head 1 o let subst_head_approximation subst = function | RigidHead (RigidParameter cst) as k -> let cst,c = subst_con_kn subst cst in if isConst c && eq_constant (fst (destConst c)) cst then (* A change of the prefix of the constant *) k else (* A substitution of the constant by a functor argument *) kind_of_head (Global.env()) c | x -> x let subst_head (subst,(ref,k)) = (subst_evaluable_reference subst ref, subst_head_approximation subst k) let discharge_head (_,(ref,k)) = match ref with | EvalConstRef cst -> Some (EvalConstRef (pop_con cst), k) | EvalVarRef id -> None let rebuild_head (ref,k) = (ref, compute_head ref) type head_obj = evaluable_global_reference * head_approximation let inHead : head_obj -> obj = declare_object {(default_object "HEAD") with cache_function = cache_head; load_function = load_head; subst_function = subst_head; classify_function = (fun x -> Substitute x); discharge_function = discharge_head; rebuild_function = rebuild_head } let declare_head c = let hd = compute_head c in add_anonymous_leaf (inHead (c,hd)) coq-8.6/library/states.ml0000644000175000017500000000253313022274260014763 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let reraise = CErrors.push reraise in (unfreeze st; iraise reraise) let with_state_protection_on_exception = Future.transactify coq-8.6/library/summary.mli0000644000175000017500000000715013022274260015326 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a; unfreeze_function : 'a -> unit; init_function : unit -> unit } (** For tables registered during the launch of coqtop, the [init_function] will be run only once, during an [init_summaries] done at the end of coqtop initialization. For tables registered later (for instance during a plugin dynlink), [init_function] is used when unfreezing an earlier frozen state that doesn't contain any value for this table. Beware: for tables registered dynamically after the initialization of Coq, their init functions may not be run immediately. It is hence the responsability of plugins to initialize themselves properly. *) val declare_summary : string -> 'a summary_declaration -> unit (** All-in-one reference declaration + summary registration. It behaves just as OCaml's standard [ref] function, except that a [declare_summary] is done, with [name] as string. The [init_function] restores the reference to its initial value. The [freeze_function] can be overridden *) val ref : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref (* As [ref] but the value is local to a process, i.e. not sent to, say, proof * workers. It is useful to implement a local cache for example. *) module Local : sig type 'a local_ref val ref : ?freeze:('a -> 'a) -> name:string -> 'a -> 'a local_ref val (:=) : 'a local_ref -> 'a -> unit val (!) : 'a local_ref -> 'a end (** Special name for the summary of ML modules. This summary entry is special because its unfreeze may load ML code and hence add summary entries. Thus is has to be recognizable, and handled appropriately *) val ml_modules : string (** For global tables registered statically before the end of coqtop launch, the following empty [init_function] could be used. *) val nop : unit -> unit (** The type [frozen] is a snapshot of the states of all the registered tables of the system. *) type frozen val empty_frozen : frozen val freeze_summaries : marshallable:marshallable -> frozen val unfreeze_summaries : frozen -> unit val init_summaries : unit -> unit (** The type [frozen_bits] is a snapshot of some of the registered tables *) type frozen_bits val freeze_summary : marshallable:marshallable -> ?complement:bool -> string list -> frozen_bits val unfreeze_summary : frozen_bits -> unit val surgery_summary : frozen -> frozen_bits -> frozen val project_summary : frozen -> ?complement:bool -> string list -> frozen_bits val pointer_equal : frozen_bits -> frozen_bits -> bool (** {6 Debug} *) val dump : unit -> (int * string) list coq-8.6/library/nameops.ml0000644000175000017500000001025713022274260015124 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* str "_" | Name id -> pr_id id (* Utilities *) let code_of_0 = Char.code '0' let code_of_9 = Char.code '9' let cut_ident skip_quote s = let s = Id.to_string s in let slen = String.length s in (* [n'] is the position of the first non nullary digit *) let rec numpart n n' = if Int.equal n 0 then (* ident made of _ and digits only [and ' if skip_quote]: don't cut it *) slen else let c = Char.code (String.get s (n-1)) in if Int.equal c code_of_0 && not (Int.equal n slen) then numpart (n-1) n' else if code_of_0 <= c && c <= code_of_9 then numpart (n-1) (n-1) else if skip_quote && (Int.equal c (Char.code '\'') || Int.equal c (Char.code '_')) then numpart (n-1) (n-1) else n' in numpart slen slen let repr_ident s = let numstart = cut_ident false s in let s = Id.to_string s in let slen = String.length s in if Int.equal numstart slen then (s, None) else (String.sub s 0 numstart, Some (int_of_string (String.sub s numstart (slen - numstart)))) let make_ident sa = function | Some n -> let c = Char.code (String.get sa (String.length sa -1)) in let s = if c < code_of_0 || c > code_of_9 then sa ^ (string_of_int n) else sa ^ "_" ^ (string_of_int n) in Id.of_string s | None -> Id.of_string (String.copy sa) let root_of_id id = let suffixstart = cut_ident true id in Id.of_string (String.sub (Id.to_string id) 0 suffixstart) (* Rem: semantics is a bit different, if an ident starts with toto00 then after successive renamings it comes to toto09, then it goes on with toto10 *) let lift_subscript id = let id = Id.to_string id in let len = String.length id in let rec add carrypos = let c = id.[carrypos] in if is_digit c then if Int.equal (Char.code c) (Char.code '9') then begin assert (carrypos>0); add (carrypos-1) end else begin let newid = String.copy id in String.fill newid (carrypos+1) (len-1-carrypos) '0'; newid.[carrypos] <- Char.chr (Char.code c + 1); newid end else begin let newid = id^"0" in if carrypos < len-1 then begin String.fill newid (carrypos+1) (len-1-carrypos) '0'; newid.[carrypos+1] <- '1' end; newid end in Id.of_string (add (len-1)) let has_subscript id = let id = Id.to_string id in is_digit (id.[String.length id - 1]) let forget_subscript id = let numstart = cut_ident false id in let newid = String.make (numstart+1) '0' in String.blit (Id.to_string id) 0 newid 0 numstart; (Id.of_string newid) let add_suffix id s = Id.of_string (Id.to_string id ^ s) let add_prefix s id = Id.of_string (s ^ Id.to_string id) let atompart_of_id id = fst (repr_ident id) (* Names *) let out_name = function | Name id -> id | Anonymous -> failwith "Nameops.out_name" let name_fold f na a = match na with | Name id -> f id a | Anonymous -> a let name_iter f na = name_fold (fun x () -> f x) na () let name_cons na l = match na with | Anonymous -> l | Name id -> id::l let name_app f = function | Name id -> Name (f id) | Anonymous -> Anonymous let name_fold_map f e = function | Name id -> let (e,id) = f e id in (e,Name id) | Anonymous -> e,Anonymous let name_max na1 na2 = match na1 with | Name _ -> na1 | Anonymous -> na2 let pr_lab l = Label.print l let default_library = Names.DirPath.initial (* = ["Top"] *) (*s Roots of the space of absolute names *) let coq_string = "Coq" let coq_root = Id.of_string coq_string let default_root_prefix = DirPath.empty (* Metavariables *) let pr_meta = Pp.int let string_of_meta = string_of_int coq-8.6/library/declare.mli0000644000175000017500000000765713022274260015244 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* variable_declaration -> object_name (** Declaration of global constructions i.e. Definition/Theorem/Axiom/Parameter/... *) type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind type internal_flag = | UserAutomaticRequest | InternalTacticRequest | UserIndividualRequest (* Defaut definition entries, transparent with no secctx or proj information *) val definition_entry : ?fix_exn:Future.fix_exn -> ?opaque:bool -> ?inline:bool -> ?types:types -> ?poly:polymorphic -> ?univs:Univ.universe_context -> ?eff:Safe_typing.private_constants -> constr -> Safe_typing.private_constants definition_entry (** [declare_constant id cd] declares a global declaration (constant/parameter) with name [id] in the current section; it returns the full path of the declaration internal specify if the constant has been created by the kernel or by the user, and in the former case, if its errors should be silent *) val declare_constant : ?internal:internal_flag -> ?local:bool -> Id.t -> ?export_seff:bool -> constant_declaration -> constant val declare_definition : ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind -> ?local:bool -> ?poly:polymorphic -> Id.t -> ?types:constr -> constr Univ.in_universe_context_set -> constant (** Since transparent constants' side effects are globally declared, we * need that *) val set_declare_scheme : (string -> (inductive * constant) array -> unit) -> unit (** [declare_mind me] declares a block of inductive types with their constructors in the current section; it returns the path of the whole block and a boolean indicating if it is a primitive record. *) val declare_mind : mutual_inductive_entry -> object_name * bool (** Hooks for XML output *) val xml_declare_variable : (object_name -> unit) Hook.t val xml_declare_constant : (internal_flag * constant -> unit) Hook.t val xml_declare_inductive : (bool * object_name -> unit) Hook.t (** Declaration messages *) val definition_message : Id.t -> unit val assumption_message : Id.t -> unit val fixpoint_message : int array option -> Id.t list -> unit val cofixpoint_message : Id.t list -> unit val recursive_message : bool (** true = fixpoint *) -> int array option -> Id.t list -> unit val exists_name : Id.t -> bool (** Global universe contexts, names and constraints *) val declare_universe_context : polymorphic -> Univ.universe_context_set -> unit val do_universe : polymorphic -> Id.t Loc.located list -> unit val do_constraint : polymorphic -> (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> unit coq-8.6/library/kindops.ml0000644000175000017500000000403713022274260015130 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* IsDefinition d | Proof s -> IsProof s let string_of_theorem_kind = function | Theorem -> "Theorem" | Lemma -> "Lemma" | Fact -> "Fact" | Remark -> "Remark" | Property -> "Property" | Proposition -> "Proposition" | Corollary -> "Corollary" let string_of_definition_kind def = let (locality, poly, kind) = def in let error () = CErrors.anomaly (Pp.str "Internal definition kind") in match kind with | Definition -> begin match locality with | Discharge -> "Let" | Local -> "Local Definition" | Global -> "Definition" end | Example -> begin match locality with | Discharge -> error () | Local -> "Local Example" | Global -> "Example" end | Coercion -> begin match locality with | Discharge -> error () | Local -> "Local Coercion" | Global -> "Coercion" end | SubClass -> begin match locality with | Discharge -> error () | Local -> "Local SubClass" | Global -> "SubClass" end | CanonicalStructure -> begin match locality with | Discharge -> error () | Local -> error () | Global -> "Canonical Structure" end | Instance -> begin match locality with | Discharge -> error () | Local -> "Instance" | Global -> "Global Instance" end | (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) -> CErrors.anomaly (Pp.str "Internal definition kind") coq-8.6/library/impargs.mli0000644000175000017500000001275513022274260015302 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val make_strict_implicit_args : bool -> unit val make_strongly_strict_implicit_args : bool -> unit val make_reversible_pattern_implicit_args : bool -> unit val make_contextual_implicit_args : bool -> unit val make_maximal_implicit_args : bool -> unit val is_implicit_args : unit -> bool val is_strict_implicit_args : unit -> bool val is_strongly_strict_implicit_args : unit -> bool val is_reversible_pattern_implicit_args : unit -> bool val is_contextual_implicit_args : unit -> bool val is_maximal_implicit_args : unit -> bool val with_implicit_protection : ('a -> 'b) -> 'a -> 'b (** {6 ... } *) (** An [implicits_list] is a list of positions telling which arguments of a reference can be automatically infered *) type argument_position = | Conclusion | Hyp of int (** We remember various information about why an argument is inferable as implicit *) type implicit_explanation = | DepRigid of argument_position (** means that the implicit argument can be found by unification along a rigid path (we do not print the arguments of this kind if there is enough arguments to infer them) *) | DepFlex of argument_position (** means that the implicit argument can be found by unification along a collapsable path only (e.g. as x in (P x) where P is another argument) (we do (defensively) print the arguments of this kind) *) | DepFlexAndRigid of (*flex*) argument_position * (*rig*) argument_position (** means that the least argument from which the implicit argument can be inferred is following a collapsable path but there is a greater argument from where the implicit argument is inferable following a rigid path (useful to know how to print a partial application) *) | Manual (** means the argument has been explicitly set as implicit. *) (** We also consider arguments inferable from the conclusion but it is operational only if [conclusion_matters] is true. *) type maximal_insertion = bool (** true = maximal contextual insertion *) type force_inference = bool (** true = always infer, never turn into evar/subgoal *) type implicit_status = (Id.t * implicit_explanation * (maximal_insertion * force_inference)) option (** [None] = Not implicit *) type implicit_side_condition type implicits_list = implicit_side_condition * implicit_status list val is_status_implicit : implicit_status -> bool val is_inferable_implicit : bool -> int -> implicit_status -> bool val name_of_implicit : implicit_status -> Id.t val maximal_insertion_of : implicit_status -> bool val force_inference_of : implicit_status -> bool val positions_of_implicits : implicits_list -> int list (** A [manual_explicitation] is a tuple of a positional or named explicitation with maximal insertion, force inference and force usage flags. Forcing usage makes the argument implicit even if the automatic inference considers it not inferable. *) type manual_explicitation = Constrexpr.explicitation * (maximal_insertion * force_inference * bool) type manual_implicits = manual_explicitation list val compute_implicits_with_manual : env -> types -> bool -> manual_implicits -> implicit_status list val compute_implicits_names : env -> types -> Name.t list (** {6 Computation of implicits (done using the global environment). } *) val declare_var_implicits : variable -> unit val declare_constant_implicits : constant -> unit val declare_mib_implicits : mutual_inductive -> unit val declare_implicits : bool -> global_reference -> unit (** [declare_manual_implicits local ref enriching l] Manual declaration of which arguments are expected implicit. If not set, we decide if it should enrich by automatically inferd implicits depending on the current state. Unsets implicits if [l] is empty. *) val declare_manual_implicits : bool -> global_reference -> ?enriching:bool -> manual_implicits list -> unit (** If the list is empty, do nothing, otherwise declare the implicits. *) val maybe_declare_manual_implicits : bool -> global_reference -> ?enriching:bool -> manual_implicits -> unit val implicits_of_global : global_reference -> implicits_list list val extract_impargs_data : implicits_list list -> ((int * int) option * implicit_status list) list val lift_implicits : int -> manual_implicits -> manual_implicits val make_implicits_list : implicit_status list -> implicits_list list val drop_first_implicits : int -> implicits_list -> implicits_list val projection_implicits : env -> projection -> implicit_status list -> implicit_status list val select_impargs_size : int -> implicits_list list -> implicit_status list val select_stronger_impargs : implicits_list list -> implicit_status list val explicitation_eq : Constrexpr.explicitation -> Constrexpr.explicitation -> bool (** Equality on [explicitation]. *) coq-8.6/library/library.mllib0000644000175000017500000000024213022274260015606 0ustar mdenesmdenesNameops Libnames Globnames Libobject Summary Nametab Global Universes Lib Declaremods Loadpath Library States Kindops Dischargedhypsmap Goptions Decls Heads Keys coq-8.6/library/nameops.mli0000644000175000017500000000370613022274260015276 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Pp.std_ppcmds val pr_name : Name.t -> Pp.std_ppcmds val make_ident : string -> int option -> Id.t val repr_ident : Id.t -> string * int option val atompart_of_id : Id.t -> string (** remove trailing digits *) val root_of_id : Id.t -> Id.t (** remove trailing digits, ' and _ *) val add_suffix : Id.t -> string -> Id.t val add_prefix : string -> Id.t -> Id.t val has_subscript : Id.t -> bool val lift_subscript : Id.t -> Id.t val forget_subscript : Id.t -> Id.t val out_name : Name.t -> Id.t (** [out_name] associates [id] to [Name id]. Raises [Failure "Nameops.out_name"] otherwise. *) val name_fold : (Id.t -> 'a -> 'a) -> Name.t -> 'a -> 'a val name_iter : (Id.t -> unit) -> Name.t -> unit val name_cons : Name.t -> Id.t list -> Id.t list val name_app : (Id.t -> Id.t) -> Name.t -> Name.t val name_fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t val name_max : Name.t -> Name.t -> Name.t val pr_lab : Label.t -> Pp.std_ppcmds (** some preset paths *) val default_library : DirPath.t (** This is the root of the standard library of Coq *) val coq_root : module_ident (** "Coq" *) val coq_string : string (** "Coq" *) (** This is the default root prefix for developments which doesn't mention a root *) val default_root_prefix : DirPath.t (** Metavariables *) val pr_meta : Term.metavariable -> Pp.std_ppcmds val string_of_meta : Term.metavariable -> string coq-8.6/library/libnames.ml0000644000175000017500000001506213022274260015253 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* DirPath.make l, id | _ -> failwith "split_dirpath" let pop_dirpath p = match DirPath.repr p with | _::l -> DirPath.make l | [] -> failwith "pop_dirpath" (* Pop the last n module idents *) let pop_dirpath_n n dir = DirPath.make (List.skipn n (DirPath.repr dir)) let is_dirpath_prefix_of d1 d2 = List.prefix_of Id.equal (List.rev (DirPath.repr d1)) (List.rev (DirPath.repr d2)) let is_dirpath_suffix_of dir1 dir2 = let dir1 = DirPath.repr dir1 in let dir2 = DirPath.repr dir2 in List.prefix_of Id.equal dir1 dir2 let chop_dirpath n d = let d1,d2 = List.chop n (List.rev (DirPath.repr d)) in DirPath.make (List.rev d1), DirPath.make (List.rev d2) let drop_dirpath_prefix d1 d2 = let d = List.drop_prefix Id.equal (List.rev (DirPath.repr d1)) (List.rev (DirPath.repr d2)) in DirPath.make (List.rev d) let append_dirpath d1 d2 = DirPath.make (DirPath.repr d2 @ DirPath.repr d1) let add_dirpath_prefix id d = DirPath.make (DirPath.repr d @ [id]) let add_dirpath_suffix p id = DirPath.make (id :: DirPath.repr p) (* parsing *) let parse_dir s = let len = String.length s in let rec decoupe_dirs dirs n = if Int.equal n len && n > 0 then error (s ^ " is an invalid path."); if n >= len then dirs else let pos = try String.index_from s n '.' with Not_found -> len in if Int.equal pos n then error (s ^ " is an invalid path."); let dir = String.sub s n (pos-n) in decoupe_dirs ((Id.of_string dir)::dirs) (pos+1) in decoupe_dirs [] 0 let dirpath_of_string s = let path = match s with | "" -> [] | _ -> parse_dir s in DirPath.make path let string_of_dirpath = Names.DirPath.to_string module Dirset = Set.Make(DirPath) module Dirmap = Map.Make(DirPath) (*s Section paths are absolute names *) type full_path = { dirpath : DirPath.t ; basename : Id.t } let dirpath sp = sp.dirpath let basename sp = sp.basename let make_path pa id = { dirpath = pa; basename = id } let repr_path { dirpath = pa; basename = id } = (pa,id) let eq_full_path p1 p2 = Id.equal p1.basename p2.basename && DirPath.equal p1.dirpath p2.dirpath (* parsing and printing of section paths *) let string_of_path sp = let (sl,id) = repr_path sp in match DirPath.repr sl with | [] -> Id.to_string id | _ -> (DirPath.to_string sl) ^ "." ^ (Id.to_string id) let sp_ord sp1 sp2 = let (p1,id1) = repr_path sp1 and (p2,id2) = repr_path sp2 in let p_bit = DirPath.compare p1 p2 in if Int.equal p_bit 0 then Id.compare id1 id2 else p_bit module SpOrdered = struct type t = full_path let compare = sp_ord end module Spmap = Map.Make(SpOrdered) let path_of_string s = try let dir, id = split_dirpath (dirpath_of_string s) in make_path dir id with | Invalid_argument _ -> invalid_arg "path_of_string" let pr_path sp = str (string_of_path sp) let restrict_path n sp = let dir, s = repr_path sp in let dir' = List.firstn n (DirPath.repr dir) in make_path (DirPath.make dir') s (*s qualified names *) type qualid = full_path let make_qualid = make_path let repr_qualid = repr_path let qualid_eq = eq_full_path let string_of_qualid = string_of_path let pr_qualid = pr_path let qualid_of_string = path_of_string let qualid_of_path sp = sp let qualid_of_ident id = make_qualid DirPath.empty id let qualid_of_dirpath dir = let (l,a) = split_dirpath dir in make_qualid l a type object_name = full_path * kernel_name type object_prefix = DirPath.t * (module_path * DirPath.t) let make_oname (dirpath,(mp,dir)) id = make_path dirpath id, make_kn mp dir (Label.of_id id) (* to this type are mapped DirPath.t's in the nametab *) type global_dir_reference = | DirOpenModule of object_prefix | DirOpenModtype of object_prefix | DirOpenSection of object_prefix | DirModule of object_prefix | DirClosedSection of DirPath.t (* this won't last long I hope! *) let eq_op (d1, (mp1, p1)) (d2, (mp2, p2)) = DirPath.equal d1 d2 && DirPath.equal p1 p2 && mp_eq mp1 mp2 let eq_global_dir_reference r1 r2 = match r1, r2 with | DirOpenModule op1, DirOpenModule op2 -> eq_op op1 op2 | DirOpenModtype op1, DirOpenModtype op2 -> eq_op op1 op2 | DirOpenSection op1, DirOpenSection op2 -> eq_op op1 op2 | DirModule op1, DirModule op2 -> eq_op op1 op2 | DirClosedSection dp1, DirClosedSection dp2 -> DirPath.equal dp1 dp2 | _ -> false type reference = | Qualid of qualid Loc.located | Ident of Id.t Loc.located let qualid_of_reference = function | Qualid (loc,qid) -> loc, qid | Ident (loc,id) -> loc, qualid_of_ident id let string_of_reference = function | Qualid (loc,qid) -> string_of_qualid qid | Ident (loc,id) -> Id.to_string id let pr_reference = function | Qualid (_,qid) -> pr_qualid qid | Ident (_,id) -> Id.print id let loc_of_reference = function | Qualid (loc,qid) -> loc | Ident (loc,id) -> loc let eq_reference r1 r2 = match r1, r2 with | Qualid (_, q1), Qualid (_, q2) -> qualid_eq q1 q2 | Ident (_, id1), Ident (_, id2) -> Id.equal id1 id2 | _ -> false let join_reference ns r = match ns , r with Qualid (_, q1), Qualid (loc, q2) -> let (dp1,id1) = repr_qualid q1 in let (dp2,id2) = repr_qualid q2 in Qualid (loc, make_qualid (append_dirpath (append_dirpath dp1 (dirpath_of_string (Names.Id.to_string id1))) dp2) id2) | Qualid (_, q1), Ident (loc, id2) -> let (dp1,id1) = repr_qualid q1 in Qualid (loc, make_qualid (append_dirpath dp1 (dirpath_of_string (Names.Id.to_string id1))) id2) | Ident (_, id1), Qualid (loc, q2) -> let (dp2,id2) = repr_qualid q2 in Qualid (loc, make_qualid (append_dirpath (dirpath_of_string (Names.Id.to_string id1)) dp2) id2) | Ident (_, id1), Ident (loc, id2) -> Qualid (loc, make_qualid (dirpath_of_string (Names.Id.to_string id1)) id2) (* Deprecated synonyms *) let make_short_qualid = qualid_of_ident let qualid_of_sp = qualid_of_path coq-8.6/library/loadpath.ml0000644000175000017500000000733313022274260015257 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* raise Not_found | [p] -> p | _ -> anomaly_too_many_paths phys_dir let is_in_load_paths phys_dir = let dir = CUnix.canonical_path_name phys_dir in let lp = get_load_paths () in let check_p p = String.equal dir p.path_physical in List.exists check_p lp let remove_load_path dir = let filter p = not (String.equal p.path_physical dir) in load_paths := List.filter filter !load_paths let warn_overriding_logical_loadpath = CWarnings.create ~name:"overriding-logical-loadpath" ~category:"loadpath" (fun (phys_path, old_path, coq_path) -> str phys_path ++ strbrk " was previously bound to " ++ pr_dirpath old_path ++ strbrk "; it is remapped to " ++ pr_dirpath coq_path) let add_load_path phys_path coq_path ~implicit = let phys_path = CUnix.canonical_path_name phys_path in let filter p = String.equal p.path_physical phys_path in let binding = { path_logical = coq_path; path_physical = phys_path; path_implicit = implicit; } in match List.filter filter !load_paths with | [] -> load_paths := binding :: !load_paths | [{ path_logical = old_path; path_implicit = old_implicit }] -> let replace = if DirPath.equal coq_path old_path then implicit <> old_implicit else let () = (* Do not warn when overriding the default "-I ." path *) if not (DirPath.equal old_path Nameops.default_root_prefix) then warn_overriding_logical_loadpath (phys_path, old_path, coq_path) in true in if replace then begin remove_load_path phys_path; load_paths := binding :: !load_paths; end | _ -> anomaly_too_many_paths phys_path let filter_path f = let rec aux = function | [] -> [] | p :: l -> if f p.path_logical then (p.path_physical, p.path_logical) :: aux l else aux l in aux !load_paths let expand_path ?root dir = let rec aux = function | [] -> [] | { path_physical = ph; path_logical = lg; path_implicit = implicit } :: l -> let success = match root with | None -> if implicit then is_dirpath_suffix_of dir lg else DirPath.equal dir lg | Some root -> is_dirpath_prefix_of root lg && is_dirpath_suffix_of dir (drop_dirpath_prefix root lg) in if success then (ph, lg) :: aux l else aux l in aux !load_paths let locate_file fname = let paths = List.map physical !load_paths in let _,longfname = System.find_file_in_path ~warn:(Flags.is_verbose()) paths fname in longfname coq-8.6/library/library.ml0000644000175000017500000007154013022274260015130 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* in_channel -> 'a delayed * Digest.t val fetch_delayed : 'a delayed -> 'a end = struct type 'a delayed = { del_file : string; del_off : int; del_digest : Digest.t; } let in_delayed f ch = let pos = pos_in ch in let _, digest = System.skip_in_segment f ch in ({ del_file = f; del_digest = digest; del_off = pos; }, digest) (** Fetching a table of opaque terms at position [pos] in file [f], expecting to find first a copy of [digest]. *) let fetch_delayed del = let { del_digest = digest; del_file = f; del_off = pos; } = del in try let ch = raw_intern_library f in let () = seek_in ch pos in let obj, _, digest' = System.marshal_in_segment f ch in let () = close_in ch in if not (String.equal digest digest') then raise (Faulty f); obj with e when CErrors.noncritical e -> raise (Faulty f) end open Delayed (************************************************************************) (*s Modules on disk contain the following informations (after the magic number, and before the digest). *) type compilation_unit_name = DirPath.t type library_disk = { md_compiled : Safe_typing.compiled_library; md_objects : Declaremods.library_objects; } type summary_disk = { md_name : compilation_unit_name; md_imports : compilation_unit_name array; md_deps : (compilation_unit_name * Safe_typing.vodigest) array; } (*s Modules loaded in memory contain the following informations. They are kept in the global table [libraries_table]. *) type library_t = { library_name : compilation_unit_name; library_data : library_disk delayed; library_deps : (compilation_unit_name * Safe_typing.vodigest) array; library_imports : compilation_unit_name array; library_digests : Safe_typing.vodigest; library_extra_univs : Univ.universe_context_set; } type library_summary = { libsum_name : compilation_unit_name; libsum_digests : Safe_typing.vodigest; libsum_imports : compilation_unit_name array; } module LibraryOrdered = DirPath module LibraryMap = Map.Make(LibraryOrdered) module LibraryFilenameMap = Map.Make(LibraryOrdered) (* This is a map from names to loaded libraries *) let libraries_table : library_summary LibraryMap.t ref = Summary.ref LibraryMap.empty ~name:"LIBRARY" (* This is the map of loaded libraries filename *) (* (not synchronized so as not to be caught in the states on disk) *) let libraries_filename_table = ref LibraryFilenameMap.empty (* These are the _ordered_ sets of loaded, imported and exported libraries *) let libraries_loaded_list = Summary.ref [] ~name:"LIBRARY-LOAD" let libraries_imports_list = Summary.ref [] ~name:"LIBRARY-IMPORT" let libraries_exports_list = Summary.ref [] ~name:"LIBRARY-EXPORT" (* various requests to the tables *) let find_library dir = LibraryMap.find dir !libraries_table let try_find_library dir = try find_library dir with Not_found -> errorlabstrm "Library.find_library" (str "Unknown library " ++ pr_dirpath dir) let register_library_filename dir f = (* Not synchronized: overwrite the previous binding if one existed *) (* from a previous play of the session *) libraries_filename_table := LibraryFilenameMap.add dir f !libraries_filename_table let library_full_filename dir = try LibraryFilenameMap.find dir !libraries_filename_table with Not_found -> "" let overwrite_library_filenames f = let f = if Filename.is_relative f then Filename.concat (Sys.getcwd ()) f else f in LibraryMap.iter (fun dir _ -> register_library_filename dir f) !libraries_table let library_is_loaded dir = try let _ = find_library dir in true with Not_found -> false let library_is_opened dir = List.exists (fun name -> DirPath.equal name dir) !libraries_imports_list let loaded_libraries () = !libraries_loaded_list let opened_libraries () = !libraries_imports_list (* If a library is loaded several time, then the first occurrence must be performed first, thus the libraries_loaded_list ... *) let register_loaded_library m = let libname = m.libsum_name in let link m = let dirname = Filename.dirname (library_full_filename libname) in let prefix = Nativecode.mod_uid_of_dirpath libname ^ "." in let f = prefix ^ "cmo" in let f = Dynlink.adapt_filename f in if not Coq_config.no_native_compiler then Nativelib.link_library ~prefix ~dirname ~basename:f in let rec aux = function | [] -> link m; [libname] | m'::_ as l when DirPath.equal m' libname -> l | m'::l' -> m' :: aux l' in libraries_loaded_list := aux !libraries_loaded_list; libraries_table := LibraryMap.add libname m !libraries_table (* ... while if a library is imported/exported several time, then only the last occurrence is really needed - though the imported list may differ from the exported list (consider the sequence Export A; Export B; Import A which results in A;B for exports but in B;A for imports) *) let rec remember_last_of_each l m = match l with | [] -> [m] | m'::l' when DirPath.equal m' m -> remember_last_of_each l' m | m'::l' -> m' :: remember_last_of_each l' m let register_open_library export m = libraries_imports_list := remember_last_of_each !libraries_imports_list m; if export then libraries_exports_list := remember_last_of_each !libraries_exports_list m (************************************************************************) (*s Opening libraries *) (* [open_library export explicit m] opens library [m] if not already opened _or_ if explicitly asked to be (re)opened *) let open_library export explicit_libs m = if (* Only libraries indirectly to open are not reopen *) (* Libraries explicitly mentionned by the user are always reopen *) List.exists (fun m' -> DirPath.equal m m') explicit_libs || not (library_is_opened m) then begin register_open_library export m; Declaremods.really_import_module (MPfile m) end else if export then libraries_exports_list := remember_last_of_each !libraries_exports_list m (* open_libraries recursively open a list of libraries but opens only once a library that is re-exported many times *) let open_libraries export modl = let to_open_list = List.fold_left (fun l m -> let subimport = Array.fold_left (fun l m -> remember_last_of_each l m) l m.libsum_imports in remember_last_of_each subimport m.libsum_name) [] modl in let explicit = List.map (fun m -> m.libsum_name) modl in List.iter (open_library export explicit) to_open_list (**********************************************************************) (* import and export of libraries - synchronous operations *) (* at the end similar to import and export of modules except that it *) (* is optimized: when importing several libraries at the same time *) (* which themselves indirectly imports the very same modules, these *) (* ones are imported only ones *) let open_import_library i (_,(modl,export)) = if Int.equal i 1 then (* even if the library is already imported, we re-import it *) (* if not (library_is_opened dir) then *) open_libraries export (List.map try_find_library modl) let cache_import_library obj = open_import_library 1 obj let subst_import_library (_,o) = o let classify_import_library (_,export as obj) = if export then Substitute obj else Dispose let in_import_library : DirPath.t list * bool -> obj = declare_object {(default_object "IMPORT LIBRARY") with cache_function = cache_import_library; open_function = open_import_library; subst_function = subst_import_library; classify_function = classify_import_library } (************************************************************************) (*s Locate absolute or partially qualified library names in the path *) exception LibUnmappedDir exception LibNotFound type library_location = LibLoaded | LibInPath let warn_several_object_files = CWarnings.create ~name:"several-object-files" ~category:"require" (fun (vi, vo) -> str"Loading" ++ spc () ++ str vi ++ strbrk " instead of " ++ str vo ++ strbrk " because it is more recent") let locate_absolute_library dir = (* Search in loadpath *) let pref, base = split_dirpath dir in let loadpath = Loadpath.filter_path (fun dir -> DirPath.equal dir pref) in let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in let loadpath = List.map fst loadpath in let find ext = try let name = Id.to_string base ^ ext in let _, file = System.where_in_path ~warn:false loadpath name in [file] with Not_found -> [] in match find ".vo" @ find ".vio" with | [] -> raise LibNotFound | [file] -> file | [vo;vi] when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> warn_several_object_files (vi, vo); vi | [vo;vi] -> vo | _ -> assert false let locate_qualified_library ?root ?(warn = true) qid = (* Search library in loadpath *) let dir, base = repr_qualid qid in let loadpath = Loadpath.expand_path ?root dir in let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in let find ext = try let name = Id.to_string base ^ ext in let lpath, file = System.where_in_path ~warn (List.map fst loadpath) name in [lpath, file] with Not_found -> [] in let lpath, file = match find ".vo" @ find ".vio" with | [] -> raise LibNotFound | [lpath, file] -> lpath, file | [lpath_vo, vo; lpath_vi, vi] when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> warn_several_object_files (vi, vo); lpath_vi, vi | [lpath_vo, vo; _ ] -> lpath_vo, vo | _ -> assert false in let dir = add_dirpath_suffix (String.List.assoc lpath loadpath) base in (* Look if loaded *) if library_is_loaded dir then (LibLoaded, dir,library_full_filename dir) (* Otherwise, look for it in the file system *) else (LibInPath, dir, file) let error_unmapped_dir qid = let prefix, _ = repr_qualid qid in errorlabstrm "load_absolute_library_from" (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++ str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ()) let error_lib_not_found qid = errorlabstrm "load_absolute_library_from" (str"Cannot find library " ++ pr_qualid qid ++ str" in loadpath") let try_locate_absolute_library dir = try locate_absolute_library dir with | LibUnmappedDir -> error_unmapped_dir (qualid_of_dirpath dir) | LibNotFound -> error_lib_not_found (qualid_of_dirpath dir) (************************************************************************) (** {6 Tables of opaque proof terms} *) (** We now store opaque proof terms apart from the rest of the environment. See the [Indirect] contructor in [Lazyconstr.lazy_constr]. This way, we can quickly load a first half of a .vo file without these opaque terms, and access them only when a specific command (e.g. Print or Print Assumptions) needs it. *) (** Delayed / available tables of opaque terms *) type 'a table_status = | ToFetch of 'a Future.computation array delayed | Fetched of 'a Future.computation array let opaque_tables = ref (LibraryMap.empty : (Term.constr table_status) LibraryMap.t) let univ_tables = ref (LibraryMap.empty : (Univ.universe_context_set table_status) LibraryMap.t) let add_opaque_table dp st = opaque_tables := LibraryMap.add dp st !opaque_tables let add_univ_table dp st = univ_tables := LibraryMap.add dp st !univ_tables let access_table what tables dp i = let t = match LibraryMap.find dp !tables with | Fetched t -> t | ToFetch f -> let dir_path = Names.DirPath.to_string dp in Flags.if_verbose Feedback.msg_info (str"Fetching " ++ str what++str" from disk for " ++ str dir_path); let t = try fetch_delayed f with Faulty f -> errorlabstrm "Library.access_table" (str "The file " ++ str f ++ str " (bound to " ++ str dir_path ++ str ") is inaccessible or corrupted,\ncannot load some " ++ str what ++ str " in it.\n") in tables := LibraryMap.add dp (Fetched t) !tables; t in assert (i < Array.length t); t.(i) let access_opaque_table dp i = let what = "opaque proofs" in access_table what opaque_tables dp i let access_univ_table dp i = try let what = "universe contexts of opaque proofs" in Some (access_table what univ_tables dp i) with Not_found -> None let () = Opaqueproof.set_indirect_opaque_accessor access_opaque_table; Opaqueproof.set_indirect_univ_accessor access_univ_table (************************************************************************) (* Internalise libraries *) type seg_sum = summary_disk type seg_lib = library_disk type seg_univ = (* true = vivo, false = vi *) Univ.universe_context_set Future.computation array * Univ.universe_context_set * bool type seg_discharge = Opaqueproof.cooking_info list array type seg_proofs = Term.constr Future.computation array let mk_library sd md digests univs = { library_name = sd.md_name; library_data = md; library_deps = sd.md_deps; library_imports = sd.md_imports; library_digests = digests; library_extra_univs = univs; } let mk_summary m = { libsum_name = m.library_name; libsum_imports = m.library_imports; libsum_digests = m.library_digests; } let intern_from_file f = let ch = raw_intern_library f in let (lsd : seg_sum), _, digest_lsd = System.marshal_in_segment f ch in let ((lmd : seg_lib delayed), digest_lmd) = in_delayed f ch in let (univs : seg_univ option), _, digest_u = System.marshal_in_segment f ch in let _ = System.skip_in_segment f ch in let _ = System.skip_in_segment f ch in let ((del_opaque : seg_proofs delayed),_) = in_delayed f ch in close_in ch; register_library_filename lsd.md_name f; add_opaque_table lsd.md_name (ToFetch del_opaque); let open Safe_typing in match univs with | None -> mk_library lsd lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty | Some (utab,uall,true) -> add_univ_table lsd.md_name (Fetched utab); mk_library lsd lmd (Dvivo (digest_lmd,digest_u)) uall | Some (utab,_,false) -> add_univ_table lsd.md_name (Fetched utab); mk_library lsd lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty module DPMap = Map.Make(DirPath) let rec intern_library (needed, contents) (dir, f) from = (* Look if in the current logical environment *) try (find_library dir).libsum_digests, (needed, contents) with Not_found -> (* Look if already listed and consequently its dependencies too *) try (DPMap.find dir contents).library_digests, (needed, contents) with Not_found -> Feedback.feedback(Feedback.FileDependency (from, DirPath.to_string dir)); (* [dir] is an absolute name which matches [f] which must be in loadpath *) let f = match f with Some f -> f | None -> try_locate_absolute_library dir in let m = intern_from_file f in if not (DirPath.equal dir m.library_name) then errorlabstrm "load_physical_library" (str "The file " ++ str f ++ str " contains library" ++ spc () ++ pr_dirpath m.library_name ++ spc () ++ str "and not library" ++ spc() ++ pr_dirpath dir); Feedback.feedback (Feedback.FileLoaded(DirPath.to_string dir, f)); m.library_digests, intern_library_deps (needed, contents) dir m f and intern_library_deps libs dir m from = let needed, contents = Array.fold_left (intern_mandatory_library dir from) libs m.library_deps in (dir :: needed, DPMap.add dir m contents ) and intern_mandatory_library caller from libs (dir,d) = let digest, libs = intern_library libs (dir, None) (Some from) in if not (Safe_typing.digest_match ~actual:digest ~required:d) then errorlabstrm "" (str "Compiled library " ++ pr_dirpath caller ++ str " (in file " ++ str from ++ str ") makes inconsistent assumptions \ over library " ++ pr_dirpath dir); libs let rec_intern_library libs (dir, f) = let _, libs = intern_library libs (dir, Some f) None in libs let native_name_from_filename f = let ch = raw_intern_library f in let (lmd : seg_sum), pos, digest_lmd = System.marshal_in_segment f ch in Nativecode.mod_uid_of_dirpath lmd.md_name (**********************************************************************) (*s [require_library] loads and possibly opens a library. This is a synchronized operation. It is performed as follows: preparation phase: (functions require_library* ) the library and its dependencies are read from to disk (using intern_* ) [they are read from disk to ensure that at section/module discharging time, the physical library referred to outside the section/module is the one that was used at type-checking time in the section/module] execution phase: (through add_leaf and cache_require) the library is loaded in the environment and Nametab, the objects are registered etc, using functions from Declaremods (via load_library, which recursively loads its dependencies) *) let register_library m = let l = fetch_delayed m.library_data in Declaremods.register_library m.library_name l.md_compiled l.md_objects m.library_digests m.library_extra_univs; register_loaded_library (mk_summary m) (* Follow the semantics of Anticipate object: - called at module or module type closing when a Require occurs in the module or module type - not called from a library (i.e. a module identified with a file) *) let load_require _ (_,(needed,modl,_)) = List.iter register_library needed let open_require i (_,(_,modl,export)) = Option.iter (fun exp -> open_libraries exp (List.map find_library modl)) export (* [needed] is the ordered list of libraries not already loaded *) let cache_require o = load_require 1 o; open_require 1 o let discharge_require (_,o) = Some o (* open_function is never called from here because an Anticipate object *) type require_obj = library_t list * DirPath.t list * bool option let in_require : require_obj -> obj = declare_object {(default_object "REQUIRE") with cache_function = cache_require; load_function = load_require; open_function = (fun _ _ -> assert false); discharge_function = discharge_require; classify_function = (fun o -> Anticipate o) } (* Require libraries, import them if [export <> None], mark them for export if [export = Some true] *) let (f_xml_require, xml_require) = Hook.make ~default:ignore () let warn_require_in_module = CWarnings.create ~name:"require-in-module" ~category:"deprecated" (fun () -> strbrk "Require inside a module is" ++ strbrk " deprecated and strongly discouraged. " ++ strbrk "You can Require a module at toplevel " ++ strbrk "and optionally Import it inside another one.") let require_library_from_dirpath modrefl export = let needed, contents = List.fold_left rec_intern_library ([], DPMap.empty) modrefl in let needed = List.rev_map (fun dir -> DPMap.find dir contents) needed in let modrefl = List.map fst modrefl in if Lib.is_module_or_modtype () then begin warn_require_in_module (); add_anonymous_leaf (in_require (needed,modrefl,None)); Option.iter (fun exp -> add_anonymous_leaf (in_import_library (modrefl,exp))) export end else add_anonymous_leaf (in_require (needed,modrefl,export)); if !Flags.xml_export then List.iter (Hook.get f_xml_require) modrefl; add_frozen_state () (* the function called by Vernacentries.vernac_import *) let safe_locate_module (loc,qid) = try Nametab.locate_module qid with Not_found -> user_err_loc (loc,"import_library", pr_qualid qid ++ str " is not a module") let import_module export modl = (* Optimization: libraries in a raw in the list are imported "globally". If there is non-library in the list; it breaks the optimization For instance: "Import Arith MyModule Zarith" will not be optimized (possibly resulting in redefinitions, but "Import MyModule Arith Zarith" and "Import Arith Zarith MyModule" will have the submodules imported by both Arith and ZArith imported only once *) let flush = function | [] -> () | modl -> add_anonymous_leaf (in_import_library (List.rev modl, export)) in let rec aux acc = function | (loc,dir as m) :: l -> let m,acc = try Nametab.locate_module dir, acc with Not_found-> flush acc; safe_locate_module m, [] in (match m with | MPfile dir -> aux (dir::acc) l | mp -> flush acc; try Declaremods.import_module export mp; aux [] l with Not_found -> user_err_loc (loc,"import_library", pr_qualid dir ++ str " is not a module")) | [] -> flush acc in aux [] modl (************************************************************************) (*s Initializing the compilation of a library. *) let check_coq_overwriting p id = let l = DirPath.repr p in let is_empty = match l with [] -> true | _ -> false in if not !Flags.boot && not is_empty && Id.equal (List.last l) coq_root then errorlabstrm "" (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ pr_id id ++ str "." ++ spc () ++ str "it starts with prefix \"Coq\" which is reserved for the Coq library.") (* Verifies that a string starts by a letter and do not contain others caracters than letters, digits, or `_` *) let check_module_name s = let msg c = strbrk "Invalid module name: " ++ str s ++ strbrk " character " ++ (if c = '\'' then str "\"'\"" else (str "'" ++ str (String.make 1 c) ++ str "'")) ++ strbrk " is not allowed in module names\n" in let err c = errorlabstrm "" (msg c) in match String.get s 0 with | 'a' .. 'z' | 'A' .. 'Z' -> for i = 1 to (String.length s)-1 do match String.get s i with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> () | c -> err c done | c -> err c let start_library fo = let ldir0 = try let lp = Loadpath.find_load_path (Filename.dirname fo) in Loadpath.logical lp with Not_found -> Nameops.default_root_prefix in let file = Filename.chop_extension (Filename.basename fo) in let id = Id.of_string file in check_module_name file; check_coq_overwriting ldir0 id; let ldir = add_dirpath_suffix ldir0 id in Declaremods.start_library ldir; ldir let load_library_todo f = let longf = Loadpath.locate_file (f^".v") in let f = longf^"io" in let ch = raw_intern_library f in let (s0 : seg_sum), _, _ = System.marshal_in_segment f ch in let (s1 : seg_lib), _, _ = System.marshal_in_segment f ch in let (s2 : seg_univ option), _, _ = System.marshal_in_segment f ch in let (s3 : seg_discharge option), _, _ = System.marshal_in_segment f ch in let tasks, _, _ = System.marshal_in_segment f ch in let (s5 : seg_proofs), _, _ = System.marshal_in_segment f ch in close_in ch; if tasks = None then errorlabstrm "restart" (str"not a .vio file"); if s2 = None then errorlabstrm "restart" (str"not a .vio file"); if s3 = None then errorlabstrm "restart" (str"not a .vio file"); if pi3 (Option.get s2) then errorlabstrm "restart" (str"not a .vio file"); longf, s0, s1, Option.get s2, Option.get s3, Option.get tasks, s5 (************************************************************************) (*s [save_library dir] ends library [dir] and save it to the disk. *) let current_deps () = let map name = let m = try_find_library name in (name, m.libsum_digests) in List.map map !libraries_loaded_list let current_reexports () = !libraries_exports_list let error_recursively_dependent_library dir = errorlabstrm "" (strbrk "Unable to use logical name " ++ pr_dirpath dir ++ strbrk " to save current library because" ++ strbrk " it already depends on a library of this name.") (* We now use two different digests in a .vo file. The first one only covers half of the file, without the opaque table. It is used for identifying this version of this library : this digest is the one leading to "inconsistent assumptions" messages. The other digest comes at the very end, and covers everything before it. This one is used for integrity check of the whole file when loading the opaque table. *) (* Security weakness: file might have been changed on disk between writing the content and computing the checksum... *) let save_library_to ?todo dir f otab = let except = match todo with | None -> assert(!Flags.compilation_mode = Flags.BuildVo); assert(Filename.check_suffix f ".vo"); Future.UUIDSet.empty | Some (l,_) -> assert(Filename.check_suffix f ".vio"); List.fold_left (fun e (r,_) -> Future.UUIDSet.add r.Stateid.uuid e) Future.UUIDSet.empty l in let cenv, seg, ast = Declaremods.end_library ~except dir in let opaque_table, univ_table, disch_table, f2t_map = Opaqueproof.dump otab in let tasks, utab, dtab = match todo with | None -> None, None, None | Some (tasks, rcbackup) -> let tasks = List.map Stateid.(fun (r,b) -> try { r with uuid = Future.UUIDMap.find r.uuid f2t_map }, b with Not_found -> assert b; { r with uuid = -1 }, b) tasks in Some (tasks,rcbackup), Some (univ_table,Univ.ContextSet.empty,false), Some disch_table in let except = Future.UUIDSet.fold (fun uuid acc -> try Int.Set.add (Future.UUIDMap.find uuid f2t_map) acc with Not_found -> acc) except Int.Set.empty in let is_done_or_todo i x = Future.is_val x || Int.Set.mem i except in Array.iteri (fun i x -> if not(is_done_or_todo i x) then CErrors.errorlabstrm "library" Pp.(str"Proof object "++int i++str" is not checked nor to be checked")) opaque_table; let sd = { md_name = dir; md_deps = Array.of_list (current_deps ()); md_imports = Array.of_list (current_reexports ()); } in let md = { md_compiled = cenv; md_objects = seg; } in if Array.exists (fun (d,_) -> DirPath.equal d dir) sd.md_deps then error_recursively_dependent_library dir; (* Open the vo file and write the magic number *) let f' = f in let ch = raw_extern_library f' in try (* Writing vo payload *) System.marshal_out_segment f' ch (sd : seg_sum); System.marshal_out_segment f' ch (md : seg_lib); System.marshal_out_segment f' ch (utab : seg_univ option); System.marshal_out_segment f' ch (dtab : seg_discharge option); System.marshal_out_segment f' ch (tasks : 'tasks option); System.marshal_out_segment f' ch (opaque_table : seg_proofs); close_out ch; (* Writing native code files *) if !Flags.native_compiler then let fn = Filename.dirname f'^"/"^Nativecode.mod_uid_of_dirpath dir in if not (Nativelib.compile_library dir ast fn) then error "Could not compile the library to native code." with reraise -> let reraise = CErrors.push reraise in let () = Feedback.msg_warning (str "Removed file " ++ str f') in let () = close_out ch in let () = Sys.remove f' in iraise reraise let save_library_raw f sum lib univs proofs = let f' = f^"o" in let ch = raw_extern_library f' in System.marshal_out_segment f' ch (sum : seg_sum); System.marshal_out_segment f' ch (lib : seg_lib); System.marshal_out_segment f' ch (Some univs : seg_univ option); System.marshal_out_segment f' ch (None : seg_discharge option); System.marshal_out_segment f' ch (None : 'tasks option); System.marshal_out_segment f' ch (proofs : seg_proofs); close_out ch module StringOrd = struct type t = string let compare = String.compare end module StringSet = Set.Make(StringOrd) let get_used_load_paths () = StringSet.elements (List.fold_left (fun acc m -> StringSet.add (Filename.dirname (library_full_filename m)) acc) StringSet.empty !libraries_loaded_list) let _ = Nativelib.get_load_paths := get_used_load_paths coq-8.6/library/keys.mli0000644000175000017500000000157713022274260014613 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* key -> unit (** Declare two keys as being equivalent. *) val equiv_keys : key -> key -> bool (** Check equivalence of keys. *) val constr_key : Term.constr -> key option (** Compute the head key of a term. *) val pr_keys : (global_reference -> Pp.std_ppcmds) -> Pp.std_ppcmds (** Pretty-print the mapping *) coq-8.6/library/lib.mli0000644000175000017500000001657613022274260014413 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Libnames.object_prefix -> lib_objects -> unit val load_objects : int -> Libnames.object_prefix -> lib_objects -> unit val subst_objects : Mod_subst.substitution -> lib_objects -> lib_objects (*val load_and_subst_objects : int -> Libnames.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects*) (** [classify_segment seg] verifies that there are no OpenedThings, clears ClosedSections and FrozenStates and divides Leafs according to their answers to the [classify_object] function in three groups: [Substitute], [Keep], [Anticipate] respectively. The order of each returned list is the same as in the input list. *) val classify_segment : library_segment -> lib_objects * lib_objects * Libobject.obj list (** [segment_of_objects prefix objs] forms a list of Leafs *) val segment_of_objects : Libnames.object_prefix -> lib_objects -> library_segment (** {6 ... } *) (** Adding operations (which call the [cache] method, and getting the current list of operations (most recent ones coming first). *) val add_leaf : Names.Id.t -> Libobject.obj -> Libnames.object_name val add_anonymous_leaf : ?cache_first:bool -> Libobject.obj -> unit val pull_to_head : Libnames.object_name -> unit (** this operation adds all objects with the same name and calls [load_object] for each of them *) val add_leaves : Names.Id.t -> Libobject.obj list -> Libnames.object_name val add_frozen_state : unit -> unit (** {6 ... } *) (** The function [contents] gives access to the current entire segment *) val contents : unit -> library_segment (** The function [contents_after] returns the current library segment, starting from a given section path. *) val contents_after : Libnames.object_name -> library_segment (** {6 Functions relative to current path } *) (** User-side names *) val cwd : unit -> Names.DirPath.t val cwd_except_section : unit -> Names.DirPath.t val current_dirpath : bool -> Names.DirPath.t (* false = except sections *) val make_path : Names.Id.t -> Libnames.full_path val make_path_except_section : Names.Id.t -> Libnames.full_path (** Kernel-side names *) val current_mp : unit -> Names.module_path val make_kn : Names.Id.t -> Names.kernel_name (** Are we inside an opened section *) val sections_are_opened : unit -> bool val sections_depth : unit -> int (** Are we inside an opened module type *) val is_module_or_modtype : unit -> bool val is_modtype : unit -> bool (* [is_modtype_strict] checks not only if we are in a module type, but if the latest module started is a module type. *) val is_modtype_strict : unit -> bool val is_module : unit -> bool val current_mod_id : unit -> Names.module_ident (** Returns the opening node of a given name *) val find_opening_node : Names.Id.t -> node (** {6 Modules and module types } *) val start_module : export -> Names.module_ident -> Names.module_path -> Summary.frozen -> Libnames.object_prefix val start_modtype : Names.module_ident -> Names.module_path -> Summary.frozen -> Libnames.object_prefix val end_module : unit -> Libnames.object_name * Libnames.object_prefix * Summary.frozen * library_segment val end_modtype : unit -> Libnames.object_name * Libnames.object_prefix * Summary.frozen * library_segment (** [Lib.add_frozen_state] must be called after each of the above functions *) (** {6 Compilation units } *) val start_compilation : Names.DirPath.t -> Names.module_path -> unit val end_compilation_checks : Names.DirPath.t -> Libnames.object_name val end_compilation : Libnames.object_name-> Libnames.object_prefix * library_segment (** The function [library_dp] returns the [DirPath.t] of the current compiling library (or [default_library]) *) val library_dp : unit -> Names.DirPath.t (** Extract the library part of a name even if in a section *) val dp_of_mp : Names.module_path -> Names.DirPath.t val split_modpath : Names.module_path -> Names.DirPath.t * Names.Id.t list val library_part : Globnames.global_reference -> Names.DirPath.t (** {6 Sections } *) val open_section : Names.Id.t -> unit val close_section : unit -> unit (** {6 We can get and set the state of the operations (used in [States]). } *) type frozen val freeze : marshallable:Summary.marshallable -> frozen val unfreeze : frozen -> unit val init : unit -> unit (** XML output hooks *) val xml_open_section : (Names.Id.t -> unit) Hook.t val xml_close_section : (Names.Id.t -> unit) Hook.t (** {6 Section management for discharge } *) type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types type variable_context = variable_info list type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t val instance_from_variable_context : variable_context -> Names.Id.t array val named_of_variable_context : variable_context -> Context.Named.t val section_segment_of_constant : Names.constant -> abstr_info val section_segment_of_mutual_inductive: Names.mutual_inductive -> abstr_info val variable_section_segment_of_reference : Globnames.global_reference -> variable_context val section_instance : Globnames.global_reference -> Univ.universe_instance * Names.Id.t array val is_in_section : Globnames.global_reference -> bool val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> Decl_kinds.polymorphic -> Univ.universe_context_set -> unit val add_section_context : Univ.universe_context_set -> unit val add_section_constant : Decl_kinds.polymorphic -> Names.constant -> Context.Named.t -> unit val add_section_kn : Decl_kinds.polymorphic -> Names.mutual_inductive -> Context.Named.t -> unit val replacement_context : unit -> Opaqueproof.work_list (** {6 Discharge: decrease the section level if in the current section } *) val discharge_kn : Names.mutual_inductive -> Names.mutual_inductive val discharge_con : Names.constant -> Names.constant val discharge_global : Globnames.global_reference -> Globnames.global_reference val discharge_inductive : Names.inductive -> Names.inductive coq-8.6/library/libobject.ml0000644000175000017500000001146713022274260015423 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit; load_function : int -> object_name * 'a -> unit; open_function : int -> object_name * 'a -> unit; classify_function : 'a -> 'a substitutivity; subst_function : Mod_subst.substitution * 'a -> 'a; discharge_function : object_name * 'a -> 'a option; rebuild_function : 'a -> 'a } let default_object s = { object_name = s; cache_function = (fun _ -> ()); load_function = (fun _ _ -> ()); open_function = (fun _ _ -> ()); subst_function = (fun _ -> CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!")); classify_function = (fun obj -> Keep obj); discharge_function = (fun _ -> None); rebuild_function = (fun x -> x)} (* The suggested object declaration is the following: declare_object { (default_object "MY OBJECT") with cache_function = fun (sp,a) -> Mytbl.add sp a} and the listed functions are only those which definitions actually differ from the default. This helps introducing new functions in objects. *) let ident_subst_function (_,a) = a type obj = Dyn.t (* persistent dynamic objects *) type dynamic_object_declaration = { dyn_cache_function : object_name * obj -> unit; dyn_load_function : int -> object_name * obj -> unit; dyn_open_function : int -> object_name * obj -> unit; dyn_subst_function : Mod_subst.substitution * obj -> obj; dyn_classify_function : obj -> obj substitutivity; dyn_discharge_function : object_name * obj -> obj option; dyn_rebuild_function : obj -> obj } let object_tag (Dyn.Dyn (t, _)) = Dyn.repr t let cache_tab = (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t) let declare_object_full odecl = let na = odecl.object_name in let (infun, outfun) = Dyn.Easy.make_dyn na in let cacher (oname,lobj) = odecl.cache_function (oname,outfun lobj) and loader i (oname,lobj) = odecl.load_function i (oname,outfun lobj) and opener i (oname,lobj) = odecl.open_function i (oname,outfun lobj) and substituter (sub,lobj) = infun (odecl.subst_function (sub,outfun lobj)) and classifier lobj = match odecl.classify_function (outfun lobj) with | Dispose -> Dispose | Substitute obj -> Substitute (infun obj) | Keep obj -> Keep (infun obj) | Anticipate (obj) -> Anticipate (infun obj) and discharge (oname,lobj) = Option.map infun (odecl.discharge_function (oname,outfun lobj)) and rebuild lobj = infun (odecl.rebuild_function (outfun lobj)) in Hashtbl.add cache_tab na { dyn_cache_function = cacher; dyn_load_function = loader; dyn_open_function = opener; dyn_subst_function = substituter; dyn_classify_function = classifier; dyn_discharge_function = discharge; dyn_rebuild_function = rebuild }; (infun,outfun) (* The "try .. with .. " allows for correct printing when calling declare_object a loading time. *) let declare_object odecl = try fst (declare_object_full odecl) with e -> CErrors.fatal_error (CErrors.print e) (CErrors.is_anomaly e) let declare_object_full odecl = try declare_object_full odecl with e -> CErrors.fatal_error (CErrors.print e) (CErrors.is_anomaly e) (* this function describes how the cache, load, open, and export functions are triggered. *) let apply_dyn_fun deflt f lobj = let tag = object_tag lobj in let dodecl = try Hashtbl.find cache_tab tag with Not_found -> assert false in f dodecl let cache_object ((_,lobj) as node) = apply_dyn_fun () (fun d -> d.dyn_cache_function node) lobj let load_object i ((_,lobj) as node) = apply_dyn_fun () (fun d -> d.dyn_load_function i node) lobj let open_object i ((_,lobj) as node) = apply_dyn_fun () (fun d -> d.dyn_open_function i node) lobj let subst_object ((_,lobj) as node) = apply_dyn_fun lobj (fun d -> d.dyn_subst_function node) lobj let classify_object lobj = apply_dyn_fun Dispose (fun d -> d.dyn_classify_function lobj) lobj let discharge_object ((_,lobj) as node) = apply_dyn_fun None (fun d -> d.dyn_discharge_function node) lobj let rebuild_object lobj = apply_dyn_fun lobj (fun d -> d.dyn_rebuild_function lobj) lobj let dump = Dyn.dump coq-8.6/library/universes.mli0000644000175000017500000002314513022274260015656 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool (** Universes *) (** Global universe name <-> level mapping *) type universe_names = (Decl_kinds.polymorphic * Univ.universe_level) Idmap.t * Id.t Univ.LMap.t val global_universe_names : unit -> universe_names val set_global_universe_names : universe_names -> unit val pr_with_global_universes : Level.t -> Pp.std_ppcmds (** Local universe name <-> level mapping *) type universe_binders = (Id.t * Univ.universe_level) list val register_universe_binders : Globnames.global_reference -> universe_binders -> unit val universe_binders_of_global : Globnames.global_reference -> universe_binders (** The global universe counter *) val set_remote_new_univ_level : universe_level RemoteCounter.installer (** Side-effecting functions creating new universe levels. *) val new_univ_level : Names.dir_path -> universe_level val new_univ : Names.dir_path -> universe val new_Type : Names.dir_path -> types val new_Type_sort : Names.dir_path -> sorts val new_global_univ : unit -> universe in_universe_context_set val new_sort_in_family : sorts_family -> sorts (** {6 Constraints for type inference} When doing conversion of universes, not only do we have =/<= constraints but also Lub constraints which correspond to unification of two levels which might not be necessary if unfolding is performed. *) type universe_constraint_type = ULe | UEq | ULub type universe_constraint = universe * universe_constraint_type * universe module Constraints : sig include Set.S with type elt = universe_constraint val pr : t -> Pp.std_ppcmds end type universe_constraints = Constraints.t type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option type 'a universe_constrained = 'a * universe_constraints type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints val subst_univs_universe_constraints : universe_subst_fn -> universe_constraints -> universe_constraints val enforce_eq_instances_univs : bool -> universe_instance universe_constraint_function val to_constraints : UGraph.t -> universe_constraints -> constraints (** [eq_constr_univs_infer u a b] is [true, c] if [a] equals [b] modulo alpha, casts, application grouping, the universe constraints in [u] and additional constraints [c]. *) val eq_constr_univs_infer : UGraph.t -> 'a constraint_accumulator -> constr -> constr -> 'a -> 'a option (** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of {!eq_constr_univs_infer} taking kind-of-term functions, to expose subterms of [m] and [n], arguments. *) val eq_constr_univs_infer_with : (constr -> (constr,types) kind_of_term) -> (constr -> (constr,types) kind_of_term) -> UGraph.t -> 'a constraint_accumulator -> constr -> constr -> 'a -> 'a option (** [leq_constr_univs u a b] is [true, c] if [a] is convertible to [b] modulo alpha, casts, application grouping, the universe constraints in [u] and additional constraints [c]. *) val leq_constr_univs_infer : UGraph.t -> 'a constraint_accumulator -> constr -> constr -> 'a -> 'a option (** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and the universe constraints in [c]. *) val eq_constr_universes : constr -> constr -> bool universe_constrained (** [leq_constr_universes a b] [true, c] if [a] is convertible to [b] modulo alpha, casts, application grouping and the universe constraints in [c]. *) val leq_constr_universes : constr -> constr -> bool universe_constrained (** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and the universe constraints in [c]. *) val eq_constr_universes_proj : env -> constr -> constr -> bool universe_constrained (** Build a fresh instance for a given context, its associated substitution and the instantiated constraints. *) val fresh_instance_from_context : universe_context -> universe_instance constrained val fresh_instance_from : universe_context -> universe_instance option -> universe_instance in_universe_context_set val fresh_sort_in_family : env -> sorts_family -> sorts in_universe_context_set val fresh_constant_instance : env -> constant -> pconstant in_universe_context_set val fresh_inductive_instance : env -> inductive -> pinductive in_universe_context_set val fresh_constructor_instance : env -> constructor -> pconstructor in_universe_context_set val fresh_global_instance : ?names:Univ.Instance.t -> env -> Globnames.global_reference -> constr in_universe_context_set val fresh_global_or_constr_instance : env -> Globnames.global_reference_or_constr -> constr in_universe_context_set (** Get fresh variables for the universe context. Useful to make tactics that manipulate constrs in universe contexts polymorphic. *) val fresh_universe_context_set_instance : universe_context_set -> universe_level_subst * universe_context_set (** Raises [Not_found] if not a global reference. *) val global_of_constr : constr -> Globnames.global_reference puniverses val global_app_of_constr : constr -> Globnames.global_reference puniverses * constr option val constr_of_global_univ : Globnames.global_reference puniverses -> constr val extend_context : 'a in_universe_context_set -> universe_context_set -> 'a in_universe_context_set (** Simplification and pruning of constraints: [normalize_context_set ctx us] - Instantiate the variables in [us] with their most precise universe levels respecting the constraints. - Normalizes the context [ctx] w.r.t. equality constraints, choosing a canonical universe in each equivalence class (a global one if there is one) and transitively saturate the constraints w.r.t to the equalities. *) module UF : Unionfind.PartitionSig with type elt = universe_level type universe_opt_subst = universe option universe_map val make_opt_subst : universe_opt_subst -> universe_subst_fn val subst_opt_univs_constr : universe_opt_subst -> constr -> constr val normalize_context_set : universe_context_set -> universe_opt_subst (* The defined and undefined variables *) -> universe_set (* univ variables that can be substituted by algebraics *) -> (universe_opt_subst * universe_set) in_universe_context_set val normalize_univ_variables : universe_opt_subst -> universe_opt_subst * universe_set * universe_set * universe_subst val normalize_univ_variable : find:(universe_level -> universe) -> update:(universe_level -> universe -> universe) -> universe_level -> universe val normalize_univ_variable_opt_subst : universe_opt_subst ref -> (universe_level -> universe) val normalize_univ_variable_subst : universe_subst ref -> (universe_level -> universe) val normalize_universe_opt_subst : universe_opt_subst ref -> (universe -> universe) val normalize_universe_subst : universe_subst ref -> (universe -> universe) (** Create a fresh global in the global environment, without side effects. BEWARE: this raises an ANOMALY on polymorphic constants/inductives: the constraints should be properly added to an evd. See Evd.fresh_global, Evarutil.new_global, and pf_constr_of_global for the proper way to get a fresh copy of a global reference. *) val constr_of_global : Globnames.global_reference -> constr (** ** DEPRECATED ** synonym of [constr_of_global] *) val constr_of_reference : Globnames.global_reference -> constr (** [unsafe_constr_of_global gr] turns [gr] into a constr, works on polymorphic references by taking the original universe instance that is not recorded anywhere. The constraints are forgotten as well. DO NOT USE in new code. *) val unsafe_constr_of_global : Globnames.global_reference -> constr in_universe_context (** Returns the type of the global reference, by creating a fresh instance of polymorphic references and computing their instantiated universe context. (side-effect on the universe counter, use with care). *) val type_of_global : Globnames.global_reference -> types in_universe_context_set (** [unsafe_type_of_global gr] returns [gr]'s type, works on polymorphic references by taking the original universe instance that is not recorded anywhere. The constraints are forgotten as well. USE with care. *) val unsafe_type_of_global : Globnames.global_reference -> types (** Full universes substitutions into terms *) val nf_evars_and_universes_opt_subst : (existential -> constr option) -> universe_opt_subst -> constr -> constr (** Shrink a universe context to a restricted set of variables *) val universes_of_constr : constr -> universe_set val restrict_universe_context : universe_context_set -> universe_set -> universe_context_set val simplify_universe_context : universe_context_set -> universe_context_set * universe_level_subst val refresh_constraints : UGraph.t -> universe_context_set -> universe_context_set * UGraph.t (** Pretty-printing *) val pr_universe_opt_subst : universe_opt_subst -> Pp.std_ppcmds (** {6 Support for old-style sort-polymorphism } *) val solve_constraints_system : universe option array -> universe array -> universe array -> universe array coq-8.6/library/declaremods.ml0000644000175000017500000010134413022274260015742 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* None | InlineAt i -> Some i | DefaultInline -> default_inline () (** {6 Substitutive objects} - The list of bound identifiers is nonempty only if the objects are owned by a functor - Then comes either the object segment itself (for interactive modules), or a compact way to store derived objects (path to a earlier module + subtitution). *) type algebraic_objects = | Objs of Lib.lib_objects | Ref of module_path * substitution type substitutive_objects = MBId.t list * algebraic_objects (** ModSubstObjs : a cache of module substitutive objects This table is common to modules and module types. - For a Module M:=N, the objects of N will be reloaded with M after substitution. - For a Module M:SIG:=..., the module M gets its objects from SIG Invariants: - A alias (i.e. a module path inside a Ref constructor) should never lead to another alias, but rather to a concrete Objs constructor. We will plug later a handler dealing with missing entries in the cache. Such missing entries may come from inner parts of module types, which aren't registered by the standard libobject machinery. *) module ModSubstObjs : sig val set : module_path -> substitutive_objects -> unit val get : module_path -> substitutive_objects val set_missing_handler : (module_path -> substitutive_objects) -> unit end = struct let table = Summary.ref (MPmap.empty : substitutive_objects MPmap.t) ~name:"MODULE-SUBSTOBJS" let missing_handler = ref (fun mp -> assert false) let set_missing_handler f = (missing_handler := f) let set mp objs = (table := MPmap.add mp objs !table) let get mp = try MPmap.find mp !table with Not_found -> !missing_handler mp end (** Some utilities about substitutive objects : substitution, expansion *) let sobjs_no_functor (mbids,_) = List.is_empty mbids let subst_aobjs sub = function | Objs o -> Objs (Lib.subst_objects sub o) | Ref (mp, sub0) -> Ref (mp, join sub0 sub) let subst_sobjs sub (mbids,aobjs) = (mbids, subst_aobjs sub aobjs) let expand_aobjs = function | Objs o -> o | Ref (mp, sub) -> match ModSubstObjs.get mp with | (_,Objs o) -> Lib.subst_objects sub o | _ -> assert false (* Invariant : any alias points to concrete objs *) let expand_sobjs (_,aobjs) = expand_aobjs aobjs (** {6 ModObjs : a cache of module objects} For each module, we also store a cache of "prefix", "substituted objects", "keep objects". This is used for instance to implement the "Import" command. substituted objects : roughly the objects above after the substitution - we need to keep them to call open_object when the module is opened (imported) keep objects : The list of non-substitutive objects - as above, for each of them we will call open_object when the module is opened (Some) Invariants: * If the module is a functor, it won't appear in this cache. * Module objects in substitutive_objects part have empty substituted objects. * Modules which where created with Module M:=mexpr or with Module M:SIG. ... End M. have the keep list empty. *) type module_objects = object_prefix * Lib.lib_objects * Lib.lib_objects module ModObjs : sig val set : module_path -> module_objects -> unit val get : module_path -> module_objects (* may raise Not_found *) val all : unit -> module_objects MPmap.t end = struct let table = Summary.ref (MPmap.empty : module_objects MPmap.t) ~name:"MODULE-OBJS" let set mp objs = (table := MPmap.add mp objs !table) let get mp = MPmap.find mp !table let all () = !table end (** {6 Name management} Auxiliary functions to transform full_path and kernel_name given by Lib into module_path and DirPath.t needed for modules *) let mp_of_kn kn = let mp,sec,l = repr_kn kn in assert (DirPath.is_empty sec); MPdot (mp,l) let dir_of_sp sp = let dir,id = repr_path sp in add_dirpath_suffix dir id (** {6 Declaration of module substitutive objects} *) (** These functions register the visibility of the module and iterates through its components. They are called by plenty of module functions *) let consistency_checks exists dir dirinfo = if exists then let globref = try Nametab.locate_dir (qualid_of_dirpath dir) with Not_found -> errorlabstrm "consistency_checks" (pr_dirpath dir ++ str " should already exist!") in assert (eq_global_dir_reference globref dirinfo) else if Nametab.exists_dir dir then errorlabstrm "consistency_checks" (pr_dirpath dir ++ str " already exists") let compute_visibility exists i = if exists then Nametab.Exactly i else Nametab.Until i (** Iterate some function [iter_objects] on all components of a module *) let do_module exists iter_objects i dir mp sobjs kobjs = let prefix = (dir,(mp,DirPath.empty)) in let dirinfo = DirModule prefix in consistency_checks exists dir dirinfo; Nametab.push_dir (compute_visibility exists i) dir dirinfo; ModSubstObjs.set mp sobjs; (* If we're not a functor, let's iter on the internal components *) if sobjs_no_functor sobjs then begin let objs = expand_sobjs sobjs in ModObjs.set mp (prefix,objs,kobjs); iter_objects (i+1) prefix objs; iter_objects (i+1) prefix kobjs end let do_module' exists iter_objects i ((sp,kn),sobjs) = do_module exists iter_objects i (dir_of_sp sp) (mp_of_kn kn) sobjs [] (** Nota: Interactive modules and module types cannot be recached! This used to be checked here via a flag along the substobjs. *) let cache_module = do_module' false Lib.load_objects 1 let load_module = do_module' false Lib.load_objects let open_module = do_module' true Lib.open_objects let subst_module (subst,sobjs) = subst_sobjs subst sobjs let classify_module sobjs = Substitute sobjs let (in_module : substitutive_objects -> obj), (out_module : obj -> substitutive_objects) = declare_object_full {(default_object "MODULE") with cache_function = cache_module; load_function = load_module; open_function = open_module; subst_function = subst_module; classify_function = classify_module } (** {6 Declaration of module keep objects} *) let cache_keep _ = anomaly (Pp.str "This module should not be cached!") let load_keep i ((sp,kn),kobjs) = (* Invariant : seg isn't empty *) let dir = dir_of_sp sp and mp = mp_of_kn kn in let prefix = (dir,(mp,DirPath.empty)) in let prefix',sobjs,kobjs0 = try ModObjs.get mp with Not_found -> assert false (* a substobjs should already be loaded *) in assert (eq_op prefix' prefix); assert (List.is_empty kobjs0); ModObjs.set mp (prefix,sobjs,kobjs); Lib.load_objects i prefix kobjs let open_keep i ((sp,kn),kobjs) = let dir = dir_of_sp sp and mp = mp_of_kn kn in let prefix = (dir,(mp,DirPath.empty)) in Lib.open_objects i prefix kobjs let in_modkeep : Lib.lib_objects -> obj = declare_object {(default_object "MODULE KEEP") with cache_function = cache_keep; load_function = load_keep; open_function = open_keep } (** {6 Declaration of module type substitutive objects} *) (** Nota: Interactive modules and module types cannot be recached! This used to be checked more properly here. *) let do_modtype i sp mp sobjs = if Nametab.exists_modtype sp then anomaly (pr_path sp ++ str " already exists"); Nametab.push_modtype (Nametab.Until i) sp mp; ModSubstObjs.set mp sobjs let cache_modtype ((sp,kn),sobjs) = do_modtype 1 sp (mp_of_kn kn) sobjs let load_modtype i ((sp,kn),sobjs) = do_modtype i sp (mp_of_kn kn) sobjs let subst_modtype (subst,sobjs) = subst_sobjs subst sobjs let classify_modtype sobjs = Substitute sobjs let open_modtype i ((sp,kn),_) = let mp = mp_of_kn kn in let mp' = try Nametab.locate_modtype (qualid_of_path sp) with Not_found -> anomaly (pr_path sp ++ str " should already exist!"); in assert (ModPath.equal mp mp'); Nametab.push_modtype (Nametab.Exactly i) sp mp let (in_modtype : substitutive_objects -> obj), (out_modtype : obj -> substitutive_objects) = declare_object_full {(default_object "MODULE TYPE") with cache_function = cache_modtype; open_function = open_modtype; load_function = load_modtype; subst_function = subst_modtype; classify_function = classify_modtype } (** {6 Declaration of substitutive objects for Include} *) let do_include do_load do_open i ((sp,kn),aobjs) = let dir = Libnames.dirpath sp in let mp = KerName.modpath kn in let prefix = (dir,(mp,DirPath.empty)) in let o = expand_aobjs aobjs in if do_load then Lib.load_objects i prefix o; if do_open then Lib.open_objects i prefix o let cache_include = do_include true true 1 let load_include = do_include true false let open_include = do_include false true let subst_include (subst,aobjs) = subst_aobjs subst aobjs let classify_include aobjs = Substitute aobjs let (in_include : algebraic_objects -> obj), (out_include : obj -> algebraic_objects) = declare_object_full {(default_object "INCLUDE") with cache_function = cache_include; load_function = load_include; open_function = open_include; subst_function = subst_include; classify_function = classify_include } (** {6 Handler for missing entries in ModSubstObjs} *) (** Since the inner of Module Types are not added by default to the ModSubstObjs table, we compensate this by explicit traversal of Module Types inner objects when needed. Quite a hack... *) let mp_id mp id = MPdot (mp, Label.of_id id) let rec register_mod_objs mp (id,obj) = match object_tag obj with | "MODULE" -> ModSubstObjs.set (mp_id mp id) (out_module obj) | "MODULE TYPE" -> ModSubstObjs.set (mp_id mp id) (out_modtype obj) | "INCLUDE" -> List.iter (register_mod_objs mp) (expand_aobjs (out_include obj)) | _ -> () let handle_missing_substobjs mp = match mp with | MPdot (mp',l) -> let objs = expand_sobjs (ModSubstObjs.get mp') in List.iter (register_mod_objs mp') objs; ModSubstObjs.get mp | _ -> assert false (* Only inner parts of module types should be missing *) let () = ModSubstObjs.set_missing_handler handle_missing_substobjs (** {6 From module expression to substitutive objects} *) (** Turn a chain of [MSEapply] into the head module_path and the list of module_path parameters (deepest param coming first). The left part of a [MSEapply] must be either [MSEident] or another [MSEapply]. *) let get_applications mexpr = let rec get params = function | MEident mp -> mp, params | MEapply (fexpr, mp) -> get (mp::params) fexpr | MEwith _ -> error "Non-atomic functor application." in get [] mexpr (** Create the substitution corresponding to some functor applications *) let rec compute_subst env mbids sign mp_l inl = match mbids,mp_l with | _,[] -> mbids,empty_subst | [],r -> error "Application of a functor with too few arguments." | mbid::mbids,mp::mp_l -> let farg_id, farg_b, fbody_b = Modops.destr_functor sign in let mb = Environ.lookup_module mp env in let mbid_left,subst = compute_subst env mbids fbody_b mp_l inl in let resolver = if Modops.is_functor mb.mod_type then empty_delta_resolver else Modops.inline_delta_resolver env inl mp farg_id farg_b mb.mod_delta in mbid_left,join (map_mbid mbid mp resolver) subst (** Create the objects of a "with Module" structure. *) let rec replace_module_object idl mp0 objs0 mp1 objs1 = match idl, objs0 with | _,[] -> [] | id::idl,(id',obj)::tail when Id.equal id id' -> assert (String.equal (object_tag obj) "MODULE"); let mp_id = MPdot(mp0, Label.of_id id) in let objs = match idl with | [] -> Lib.subst_objects (map_mp mp1 mp_id empty_delta_resolver) objs1 | _ -> let objs_id = expand_sobjs (out_module obj) in replace_module_object idl mp_id objs_id mp1 objs1 in (id, in_module ([], Objs objs))::tail | idl,lobj::tail -> lobj::replace_module_object idl mp0 tail mp1 objs1 let type_of_mod mp env = function |true -> (Environ.lookup_module mp env).mod_type |false -> (Environ.lookup_modtype mp env).mod_type let rec get_module_path = function |MEident mp -> mp |MEwith (me,_) -> get_module_path me |MEapply (me,_) -> get_module_path me (** Substitutive objects of a module expression (or module type) *) let rec get_module_sobjs is_mod env inl = function |MEident mp -> begin match ModSubstObjs.get mp with |(mbids,Objs _) when not (ModPath.is_bound mp) -> (mbids,Ref (mp, empty_subst)) (* we create an alias *) |sobjs -> sobjs end |MEwith (mty, WithDef _) -> get_module_sobjs is_mod env inl mty |MEwith (mty, WithMod (idl,mp1)) -> assert (not is_mod); let sobjs0 = get_module_sobjs is_mod env inl mty in assert (sobjs_no_functor sobjs0); (* For now, we expanse everything, to be safe *) let mp0 = get_module_path mty in let objs0 = expand_sobjs sobjs0 in let objs1 = expand_sobjs (ModSubstObjs.get mp1) in ([], Objs (replace_module_object idl mp0 objs0 mp1 objs1)) |MEapply _ as me -> let mp1, mp_l = get_applications me in let mbids, aobjs = get_module_sobjs is_mod env inl (MEident mp1) in let typ = type_of_mod mp1 env is_mod in let mbids_left,subst = compute_subst env mbids typ mp_l inl in (mbids_left, subst_aobjs subst aobjs) let get_functor_sobjs is_mod env inl (params,mexpr) = let (mbids, aobjs) = get_module_sobjs is_mod env inl mexpr in (List.map fst params @ mbids, aobjs) (** {6 Handling of module parameters} *) (** For printing modules, [process_module_binding] adds names of bound module (and its components) to Nametab. It also loads objects associated to it. *) let process_module_binding mbid me = let dir = DirPath.make [MBId.to_id mbid] in let mp = MPbound mbid in let sobjs = get_module_sobjs false (Global.env()) (default_inline ()) me in let subst = map_mp (get_module_path me) mp empty_delta_resolver in let sobjs = subst_sobjs subst sobjs in do_module false Lib.load_objects 1 dir mp sobjs [] (** Process a declaration of functor parameter(s) (Id1 .. Idn : Typ) i.e. possibly multiple names with the same module type. Global environment is updated on the fly. Objects in these parameters are also loaded. Output is accumulated on top of [acc] (in reverse order). *) let intern_arg interp_modast acc (idl,(typ,ann)) = let inl = inl2intopt ann in let lib_dir = Lib.library_dp() in let env = Global.env() in let mty,_ = interp_modast env ModType typ in let sobjs = get_module_sobjs false env inl mty in let mp0 = get_module_path mty in List.fold_left (fun acc (_,id) -> let dir = DirPath.make [id] in let mbid = MBId.make lib_dir id in let mp = MPbound mbid in let resolver = Global.add_module_parameter mbid mty inl in let sobjs = subst_sobjs (map_mp mp0 mp resolver) sobjs in do_module false Lib.load_objects 1 dir mp sobjs []; (mbid,mty,inl)::acc) acc idl (** Process a list of declarations of functor parameters (Id11 .. Id1n : Typ1)..(Idk1 .. Idkm : Typk) Global environment is updated on the fly. The calls to [interp_modast] should be interleaved with these env updates, otherwise some "with Definition" could be rejected. Returns a list of mbids and entries (in reversed order). This used to be a [List.concat (List.map ...)], but this should be more efficient and independent of [List.map] eval order. *) let intern_args interp_modast params = List.fold_left (intern_arg interp_modast) [] params (** {6 Auxiliary functions concerning subtyping checks} *) let check_sub mtb sub_mtb_l = (* The constraints are checked and forgot immediately : *) ignore (List.fold_right (fun sub_mtb env -> Environ.add_constraints (Subtyping.check_subtypes env mtb sub_mtb) env) sub_mtb_l (Global.env())) (** This function checks if the type calculated for the module [mp] is a subtype of all signatures in [sub_mtb_l]. Uses only the global environment. *) let check_subtypes mp sub_mtb_l = let mb = try Global.lookup_module mp with Not_found -> assert false in let mtb = Modops.module_type_of_module mb in check_sub mtb sub_mtb_l (** Same for module type [mp] *) let check_subtypes_mt mp sub_mtb_l = let mtb = try Global.lookup_modtype mp with Not_found -> assert false in check_sub mtb sub_mtb_l (** Create a params entry. In [args], the youngest module param now comes first. *) let mk_params_entry args = List.rev_map (fun (mbid,arg_t,_) -> (mbid,arg_t)) args (** Create a functor type struct. In [args], the youngest module param now comes first. *) let mk_funct_type env args seb0 = List.fold_left (fun seb (arg_id,arg_t,arg_inl) -> let mp = MPbound arg_id in let arg_t = Mod_typing.translate_modtype env mp arg_inl ([],arg_t) in MoreFunctor(arg_id,arg_t,seb)) seb0 args (** Prepare the module type list for check of subtypes *) let build_subtypes interp_modast env mp args mtys = List.map (fun (m,ann) -> let inl = inl2intopt ann in let mte,_ = interp_modast env ModType m in let mtb = Mod_typing.translate_modtype env mp inl ([],mte) in { mtb with mod_type = mk_funct_type env args mtb.mod_type }) mtys (** {6 Current module information} This information is stored by each [start_module] for use in a later [end_module]. *) type current_module_info = { cur_typ : (module_struct_entry * int option) option; (** type via ":" *) cur_typs : module_type_body list (** types via "<:" *) } let default_module_info = { cur_typ = None; cur_typs = [] } let openmod_info = Summary.ref default_module_info ~name:"MODULE-INFO" (** {6 Current module type information} This information is stored by each [start_modtype] for use in a later [end_modtype]. *) let openmodtype_info = Summary.ref ([] : module_type_body list) ~name:"MODTYPE-INFO" (** XML output hooks *) let (f_xml_declare_module, xml_declare_module) = Hook.make ~default:ignore () let (f_xml_start_module, xml_start_module) = Hook.make ~default:ignore () let (f_xml_end_module, xml_end_module) = Hook.make ~default:ignore () let (f_xml_declare_module_type, xml_declare_module_type) = Hook.make ~default:ignore () let (f_xml_start_module_type, xml_start_module_type) = Hook.make ~default:ignore () let (f_xml_end_module_type, xml_end_module_type) = Hook.make ~default:ignore () let if_xml f x = if !Flags.xml_export then f x else () (** {6 Modules : start, end, declare} *) module RawModOps = struct let start_module interp_modast export id args res fs = let mp = Global.start_module id in let arg_entries_r = intern_args interp_modast args in let env = Global.env () in let res_entry_o, subtyps = match res with | Enforce (res,ann) -> let inl = inl2intopt ann in let mte,_ = interp_modast env ModType res in (* We check immediately that mte is well-formed *) let _ = Mod_typing.translate_mse env None inl mte in Some (mte,inl), [] | Check resl -> None, build_subtypes interp_modast env mp arg_entries_r resl in openmod_info := { cur_typ = res_entry_o; cur_typs = subtyps }; let prefix = Lib.start_module export id mp fs in Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix); Lib.add_frozen_state (); if_xml (Hook.get f_xml_start_module) mp; mp let end_module () = let oldoname,oldprefix,fs,lib_stack = Lib.end_module () in let substitute, keep, special = Lib.classify_segment lib_stack in let m_info = !openmod_info in (* For sealed modules, we use the substitutive objects of their signatures *) let sobjs0, keep, special = match m_info.cur_typ with | None -> ([], Objs substitute), keep, special | Some (mty, inline) -> get_module_sobjs false (Global.env()) inline mty, [], [] in let id = basename (fst oldoname) in let mp,mbids,resolver = Global.end_module fs id m_info.cur_typ in let sobjs = let (ms,objs) = sobjs0 in (mbids@ms,objs) in check_subtypes mp m_info.cur_typs; (* We substitute objects if the module is sealed by a signature *) let sobjs = match m_info.cur_typ with | None -> sobjs | Some (mty, _) -> subst_sobjs (map_mp (get_module_path mty) mp resolver) sobjs in let node = in_module sobjs in (* We add the keep objects, if any, and if this isn't a functor *) let objects = match keep, mbids with | [], _ | _, _ :: _ -> special@[node] | _ -> special@[node;in_modkeep keep] in let newoname = Lib.add_leaves id objects in (* Name consistency check : start_ vs. end_module, kernel vs. library *) assert (eq_full_path (fst newoname) (fst oldoname)); assert (ModPath.equal (mp_of_kn (snd newoname)) mp); Lib.add_frozen_state () (* to prevent recaching *); if_xml (Hook.get f_xml_end_module) mp; mp let declare_module interp_modast id args res mexpr_o fs = (* We simulate the beginning of an interactive module, then we adds the module parameters to the global env. *) let mp = Global.start_module id in let arg_entries_r = intern_args interp_modast args in let params = mk_params_entry arg_entries_r in let env = Global.env () in let mty_entry_o, subs, inl_res = match res with | Enforce (mty,ann) -> let inl = inl2intopt ann in let mte, _ = interp_modast env ModType mty in (* We check immediately that mte is well-formed *) let _ = Mod_typing.translate_mse env None inl mte in Some mte, [], inl | Check mtys -> None, build_subtypes interp_modast env mp arg_entries_r mtys, default_inline () in let mexpr_entry_o, inl_expr = match mexpr_o with | None -> None, default_inline () | Some (mexpr,ann) -> Some (fst (interp_modast env Module mexpr)), inl2intopt ann in let entry = match mexpr_entry_o, mty_entry_o with | None, None -> assert false (* No body, no type ... *) | None, Some typ -> MType (params, typ) | Some body, otyp -> MExpr (params, body, otyp) in let sobjs, mp0 = match entry with | MType (_,mte) | MExpr (_,_,Some mte) -> get_functor_sobjs false env inl_res (params,mte), get_module_path mte | MExpr (_,me,None) -> get_functor_sobjs true env inl_expr (params,me), get_module_path me in (* Undo the simulated interactive building of the module and declare the module as a whole *) Summary.unfreeze_summaries fs; let inl = match inl_expr with | None -> None | _ -> inl_res in let mp_env,resolver = Global.add_module id entry inl in (* Name consistency check : kernel vs. library *) assert (ModPath.equal mp (mp_of_kn (Lib.make_kn id))); assert (ModPath.equal mp mp_env); check_subtypes mp subs; let sobjs = subst_sobjs (map_mp mp0 mp resolver) sobjs in ignore (Lib.add_leaf id (in_module sobjs)); if_xml (Hook.get f_xml_declare_module) mp; mp end (** {6 Module types : start, end, declare} *) module RawModTypeOps = struct let start_modtype interp_modast id args mtys fs = let mp = Global.start_modtype id in let arg_entries_r = intern_args interp_modast args in let env = Global.env () in let sub_mty_l = build_subtypes interp_modast env mp arg_entries_r mtys in openmodtype_info := sub_mty_l; let prefix = Lib.start_modtype id mp fs in Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModtype prefix); Lib.add_frozen_state (); if_xml (Hook.get f_xml_start_module_type) mp; mp let end_modtype () = let oldoname,prefix,fs,lib_stack = Lib.end_modtype () in let id = basename (fst oldoname) in let substitute, _, special = Lib.classify_segment lib_stack in let sub_mty_l = !openmodtype_info in let mp, mbids = Global.end_modtype fs id in let modtypeobjs = (mbids, Objs substitute) in check_subtypes_mt mp sub_mty_l; let oname = Lib.add_leaves id (special@[in_modtype modtypeobjs]) in (* Check name consistence : start_ vs. end_modtype, kernel vs. library *) assert (eq_full_path (fst oname) (fst oldoname)); assert (ModPath.equal (mp_of_kn (snd oname)) mp); Lib.add_frozen_state ()(* to prevent recaching *); if_xml (Hook.get f_xml_end_module_type) mp; mp let declare_modtype interp_modast id args mtys (mty,ann) fs = let inl = inl2intopt ann in (* We simulate the beginning of an interactive module, then we adds the module parameters to the global env. *) let mp = Global.start_modtype id in let arg_entries_r = intern_args interp_modast args in let params = mk_params_entry arg_entries_r in let env = Global.env () in let mte, _ = interp_modast env ModType mty in (* We check immediately that mte is well-formed *) let _ = Mod_typing.translate_mse env None inl mte in let entry = params, mte in let sub_mty_l = build_subtypes interp_modast env mp arg_entries_r mtys in let sobjs = get_functor_sobjs false env inl entry in let subst = map_mp (get_module_path (snd entry)) mp empty_delta_resolver in let sobjs = subst_sobjs subst sobjs in (* Undo the simulated interactive building of the module type and declare the module type as a whole *) Summary.unfreeze_summaries fs; (* We enrich the global environment *) let mp_env = Global.add_modtype id entry inl in (* Name consistency check : kernel vs. library *) assert (ModPath.equal mp_env mp); (* Subtyping checks *) check_subtypes_mt mp sub_mty_l; ignore (Lib.add_leaf id (in_modtype sobjs)); if_xml (Hook.get f_xml_declare_module_type) mp; mp end (** {6 Include} *) module RawIncludeOps = struct let rec include_subst env mp reso mbids sign inline = match mbids with | [] -> empty_subst | mbid::mbids -> let farg_id, farg_b, fbody_b = Modops.destr_functor sign in let subst = include_subst env mp reso mbids fbody_b inline in let mp_delta = Modops.inline_delta_resolver env inline mp farg_id farg_b reso in join (map_mbid mbid mp mp_delta) subst let rec decompose_functor mpl typ = match mpl, typ with | [], _ -> typ | _::mpl, MoreFunctor(_,_,str) -> decompose_functor mpl str | _ -> error "Application of a functor with too much arguments." exception NoIncludeSelf let type_of_incl env is_mod = function |MEident mp -> type_of_mod mp env is_mod |MEapply _ as me -> let mp0, mp_l = get_applications me in decompose_functor mp_l (type_of_mod mp0 env is_mod) |MEwith _ -> raise NoIncludeSelf let declare_one_include interp_modast (me_ast,annot) = let env = Global.env() in let me,kind = interp_modast env ModAny me_ast in let is_mod = (kind == Module) in let cur_mp = Lib.current_mp () in let inl = inl2intopt annot in let mbids,aobjs = get_module_sobjs is_mod env inl me in let subst_self = try if List.is_empty mbids then raise NoIncludeSelf; let typ = type_of_incl env is_mod me in let reso,_ = Safe_typing.delta_of_senv (Global.safe_env ()) in include_subst env cur_mp reso mbids typ inl with NoIncludeSelf -> empty_subst in let base_mp = get_module_path me in let resolver = Global.add_include me is_mod inl in let subst = join subst_self (map_mp base_mp cur_mp resolver) in let aobjs = subst_aobjs subst aobjs in ignore (Lib.add_leaf (Lib.current_mod_id ()) (in_include aobjs)) let declare_include interp me_asts = List.iter (declare_one_include interp) me_asts end (** {6 Module operations handling summary freeze/unfreeze} *) let protect_summaries f = let fs = Summary.freeze_summaries ~marshallable:`No in try f fs with reraise -> (* Something wrong: undo the whole process *) let reraise = CErrors.push reraise in let () = Summary.unfreeze_summaries fs in iraise reraise let start_module interp export id args res = protect_summaries (RawModOps.start_module interp export id args res) let end_module = RawModOps.end_module let declare_module interp id args mtys me_l = let declare_me fs = match me_l with | [] -> RawModOps.declare_module interp id args mtys None fs | [me] -> RawModOps.declare_module interp id args mtys (Some me) fs | me_l -> ignore (RawModOps.start_module interp None id args mtys fs); RawIncludeOps.declare_include interp me_l; RawModOps.end_module () in protect_summaries declare_me let start_modtype interp id args mtys = protect_summaries (RawModTypeOps.start_modtype interp id args mtys) let end_modtype = RawModTypeOps.end_modtype let declare_modtype interp id args mtys mty_l = let declare_mt fs = match mty_l with | [] -> assert false | [mty] -> RawModTypeOps.declare_modtype interp id args mtys mty fs | mty_l -> ignore (RawModTypeOps.start_modtype interp id args mtys fs); RawIncludeOps.declare_include interp mty_l; RawModTypeOps.end_modtype () in protect_summaries declare_mt let declare_include interp me_asts = protect_summaries (fun _ -> RawIncludeOps.declare_include interp me_asts) (** {6 Libraries} *) type library_name = DirPath.t (** A library object is made of some substitutive objects and some "keep" objects. *) type library_objects = Lib.lib_objects * Lib.lib_objects (** For the native compiler, we cache the library values *) let register_library dir cenv (objs:library_objects) digest univ = let mp = MPfile dir in let () = try (* Is this library already loaded ? *) ignore(Global.lookup_module mp); with Not_found -> (* If not, let's do it now ... *) let mp' = Global.import cenv univ digest in if not (ModPath.equal mp mp') then anomaly (Pp.str "Unexpected disk module name"); in let sobjs,keepobjs = objs in do_module false Lib.load_objects 1 dir mp ([],Objs sobjs) keepobjs let get_library_native_symbols dir = Safe_typing.get_library_native_symbols (Global.safe_env ()) dir let start_library dir = let mp = Global.start_library dir in openmod_info := default_module_info; Lib.start_compilation dir mp; Lib.add_frozen_state () let end_library_hook = ref ignore let append_end_library_hook f = let old_f = !end_library_hook in end_library_hook := fun () -> old_f(); f () let end_library ?except dir = !end_library_hook(); let oname = Lib.end_compilation_checks dir in let mp,cenv,ast = Global.export ?except dir in let prefix, lib_stack = Lib.end_compilation oname in assert (ModPath.equal mp (MPfile dir)); let substitute, keep, _ = Lib.classify_segment lib_stack in cenv,(substitute,keep),ast (** {6 Implementation of Import and Export commands} *) let really_import_module mp = (* May raise Not_found for unknown module and for functors *) let prefix,sobjs,keepobjs = ModObjs.get mp in Lib.open_objects 1 prefix sobjs; Lib.open_objects 1 prefix keepobjs let cache_import (_,(_,mp)) = really_import_module mp let open_import i obj = if Int.equal i 1 then cache_import obj let classify_import (export,_ as obj) = if export then Substitute obj else Dispose let subst_import (subst,(export,mp as obj)) = let mp' = subst_mp subst mp in if mp'==mp then obj else (export,mp') let in_import : bool * module_path -> obj = declare_object {(default_object "IMPORT MODULE") with cache_function = cache_import; open_function = open_import; subst_function = subst_import; classify_function = classify_import } let import_module export mp = Lib.add_anonymous_leaf (in_import (export,mp)) (** {6 Iterators} *) let iter_all_segments f = let rec apply_obj prefix (id,obj) = match object_tag obj with | "INCLUDE" -> let objs = expand_aobjs (out_include obj) in List.iter (apply_obj prefix) objs | _ -> f (make_oname prefix id) obj in let apply_mod_obj _ (prefix,substobjs,keepobjs) = List.iter (apply_obj prefix) substobjs; List.iter (apply_obj prefix) keepobjs in let apply_node = function | sp, Lib.Leaf o -> f sp o | _ -> () in MPmap.iter apply_mod_obj (ModObjs.all ()); List.iter apply_node (Lib.contents ()) (** {6 Some types used to shorten declaremods.mli} *) type 'modast module_interpretor = Environ.env -> Misctypes.module_kind -> 'modast -> Entries.module_struct_entry * Misctypes.module_kind type 'modast module_params = (Id.t Loc.located list * ('modast * inline)) list (** {6 Debug} *) let debug_print_modtab _ = let pr_seg = function | [] -> str "[]" | l -> str "[." ++ int (List.length l) ++ str ".]" in let pr_modinfo mp (prefix,substobjs,keepobjs) s = s ++ str (string_of_mp mp) ++ (spc ()) ++ (pr_seg (Lib.segment_of_objects prefix (substobjs@keepobjs))) in let modules = MPmap.fold pr_modinfo (ModObjs.all ()) (mt ()) in hov 0 modules coq-8.6/library/libnames.mli0000644000175000017500000001065013022274260015422 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Pp.std_ppcmds val dirpath_of_string : string -> DirPath.t val string_of_dirpath : DirPath.t -> string (** Pop the suffix of a [DirPath.t]. Raises a [Failure] for an empty path *) val pop_dirpath : DirPath.t -> DirPath.t (** Pop the suffix n times *) val pop_dirpath_n : int -> DirPath.t -> DirPath.t (** Immediate prefix and basename of a [DirPath.t]. May raise [Failure] *) val split_dirpath : DirPath.t -> DirPath.t * Id.t val add_dirpath_suffix : DirPath.t -> module_ident -> DirPath.t val add_dirpath_prefix : module_ident -> DirPath.t -> DirPath.t val chop_dirpath : int -> DirPath.t -> DirPath.t * DirPath.t val append_dirpath : DirPath.t -> DirPath.t -> DirPath.t val drop_dirpath_prefix : DirPath.t -> DirPath.t -> DirPath.t val is_dirpath_prefix_of : DirPath.t -> DirPath.t -> bool val is_dirpath_suffix_of : DirPath.t -> DirPath.t -> bool module Dirset : Set.S with type elt = DirPath.t module Dirmap : Map.ExtS with type key = DirPath.t and module Set := Dirset (** {6 Full paths are {e absolute} paths of declarations } *) type full_path val eq_full_path : full_path -> full_path -> bool (** Constructors of [full_path] *) val make_path : DirPath.t -> Id.t -> full_path (** Destructors of [full_path] *) val repr_path : full_path -> DirPath.t * Id.t val dirpath : full_path -> DirPath.t val basename : full_path -> Id.t (** Parsing and printing of section path as ["coq_root.module.id"] *) val path_of_string : string -> full_path val string_of_path : full_path -> string val pr_path : full_path -> std_ppcmds module Spmap : CSig.MapS with type key = full_path val restrict_path : int -> full_path -> full_path (** {6 ... } *) (** A [qualid] is a partially qualified ident; it includes fully qualified names (= absolute names) and all intermediate partial qualifications of absolute names, including single identifiers. The [qualid] are used to access the name table. *) type qualid val make_qualid : DirPath.t -> Id.t -> qualid val repr_qualid : qualid -> DirPath.t * Id.t val qualid_eq : qualid -> qualid -> bool val pr_qualid : qualid -> std_ppcmds val string_of_qualid : qualid -> string val qualid_of_string : string -> qualid (** Turns an absolute name, a dirpath, or an Id.t into a qualified name denoting the same name *) val qualid_of_path : full_path -> qualid val qualid_of_dirpath : DirPath.t -> qualid val qualid_of_ident : Id.t -> qualid (** Both names are passed to objects: a "semantic" [kernel_name], which can be substituted and a "syntactic" [full_path] which can be printed *) type object_name = full_path * kernel_name type object_prefix = DirPath.t * (module_path * DirPath.t) val eq_op : object_prefix -> object_prefix -> bool val make_oname : object_prefix -> Id.t -> object_name (** to this type are mapped [DirPath.t]'s in the nametab *) type global_dir_reference = | DirOpenModule of object_prefix | DirOpenModtype of object_prefix | DirOpenSection of object_prefix | DirModule of object_prefix | DirClosedSection of DirPath.t (** this won't last long I hope! *) val eq_global_dir_reference : global_dir_reference -> global_dir_reference -> bool (** {6 ... } *) (** A [reference] is the user-level notion of name. It denotes either a global name (referred either by a qualified name or by a single name) or a variable *) type reference = | Qualid of qualid located | Ident of Id.t located val eq_reference : reference -> reference -> bool val qualid_of_reference : reference -> qualid located val string_of_reference : reference -> string val pr_reference : reference -> std_ppcmds val loc_of_reference : reference -> Loc.t val join_reference : reference -> reference -> reference (** Deprecated synonyms *) val make_short_qualid : Id.t -> qualid (** = qualid_of_ident *) val qualid_of_sp : full_path -> qualid (** = qualid_of_path *) coq-8.6/library/goptions.ml0000644000175000017500000003300113022274260015314 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit method remove : 'a -> unit method mem : 'a -> unit method print : unit end module MakeTable = functor (A : sig type t type key val compare : t -> t -> int val table : (string * key table_of_A) list ref val encode : key -> t val subst : substitution -> t -> t val printer : t -> std_ppcmds val key : option_name val title : string val member_message : t -> bool -> std_ppcmds val synchronous : bool end) -> struct type option_mark = | GOadd | GOrmv let nick = nickname A.key let _ = if String.List.mem_assoc nick !A.table then error "Sorry, this table name is already used." module MySet = Set.Make (struct type t = A.t let compare = A.compare end) let t = if A.synchronous then Summary.ref MySet.empty ~name:nick else ref MySet.empty let (add_option,remove_option) = if A.synchronous then let cache_options (_,(f,p)) = match f with | GOadd -> t := MySet.add p !t | GOrmv -> t := MySet.remove p !t in let load_options i o = if Int.equal i 1 then cache_options o in let subst_options (subst,(f,p as obj)) = let p' = A.subst subst p in if p' == p then obj else (f,p') in let inGo : option_mark * A.t -> obj = Libobject.declare_object {(Libobject.default_object nick) with Libobject.load_function = load_options; Libobject.open_function = load_options; Libobject.cache_function = cache_options; Libobject.subst_function = subst_options; Libobject.classify_function = (fun x -> Substitute x)} in ((fun c -> Lib.add_anonymous_leaf (inGo (GOadd, c))), (fun c -> Lib.add_anonymous_leaf (inGo (GOrmv, c)))) else ((fun c -> t := MySet.add c !t), (fun c -> t := MySet.remove c !t)) let print_table table_name printer table = Feedback.msg_notice (str table_name ++ (hov 0 (if MySet.is_empty table then str " None" ++ fnl () else MySet.fold (fun a b -> spc () ++ printer a ++ b) table (mt ()) ++ str "." ++ fnl ()))) class table_of_A () = object method add x = add_option (A.encode x) method remove x = remove_option (A.encode x) method mem x = let y = A.encode x in let answer = MySet.mem y !t in Feedback.msg_info (A.member_message y answer) method print = print_table A.title A.printer !t end let _ = A.table := (nick,new table_of_A ())::!A.table let active c = MySet.mem c !t let elements () = MySet.elements !t end let string_table = ref [] let get_string_table k = String.List.assoc (nickname k) !string_table module type StringConvertArg = sig val key : option_name val title : string val member_message : string -> bool -> std_ppcmds val synchronous : bool end module StringConvert = functor (A : StringConvertArg) -> struct type t = string type key = string let compare = String.compare let table = string_table let encode x = x let subst _ x = x let printer = str let key = A.key let title = A.title let member_message = A.member_message let synchronous = A.synchronous end module MakeStringTable = functor (A : StringConvertArg) -> MakeTable (StringConvert(A)) let ref_table = ref [] let get_ref_table k = String.List.assoc (nickname k) !ref_table module type RefConvertArg = sig type t val compare : t -> t -> int val encode : reference -> t val subst : substitution -> t -> t val printer : t -> std_ppcmds val key : option_name val title : string val member_message : t -> bool -> std_ppcmds val synchronous : bool end module RefConvert = functor (A : RefConvertArg) -> struct type t = A.t type key = reference let compare = A.compare let table = ref_table let encode = A.encode let subst = A.subst let printer = A.printer let key = A.key let title = A.title let member_message = A.member_message let synchronous = A.synchronous end module MakeRefTable = functor (A : RefConvertArg) -> MakeTable (RefConvert(A)) (****************************************************************************) (* 2- Flags. *) type 'a option_sig = { optsync : bool; optdepr : bool; optname : string; optkey : option_name; optread : unit -> 'a; optwrite : 'a -> unit } type option_locality = OptLocal | OptDefault | OptGlobal type option_mod = OptSet | OptAppend module OptionOrd = struct type t = option_name let compare opt1 opt2 = List.compare String.compare opt1 opt2 end module OptionMap = Map.Make(OptionOrd) let value_tab = ref OptionMap.empty (* This raises Not_found if option of key [key] is unknown *) let get_option key = OptionMap.find key !value_tab let check_key key = try let _ = get_option key in error "Sorry, this option name is already used." with Not_found -> if String.List.mem_assoc (nickname key) !string_table || String.List.mem_assoc (nickname key) !ref_table then error "Sorry, this option name is already used." open Libobject open Lib let warn_deprecated_option = CWarnings.create ~name:"deprecated-option" ~category:"deprecated" (fun key -> str "Option" ++ spc () ++ str (nickname key) ++ strbrk " is deprecated") let get_locality = function | Some true -> OptLocal | Some false -> OptGlobal | None -> OptDefault let declare_option cast uncast append ?(preprocess = fun x -> x) { optsync=sync; optdepr=depr; optname=name; optkey=key; optread=read; optwrite=write } = check_key key; let default = read() in let change = if sync then let _ = Summary.declare_summary (nickname key) { Summary.freeze_function = (fun _ -> read ()); Summary.unfreeze_function = write; Summary.init_function = (fun () -> write default) } in let cache_options (_,(l,m,v)) = match m with | OptSet -> write v | OptAppend -> write (append (read ()) v) in let load_options i o = cache_options o in let subst_options (subst,obj) = obj in let discharge_options (_,(l,_,_ as o)) = match l with OptLocal -> None | _ -> Some o in let classify_options (l,_,_ as o) = match l with OptGlobal -> Substitute o | _ -> Dispose in let options : option_locality * option_mod * _ -> obj = declare_object { (default_object (nickname key)) with load_function = load_options; cache_function = cache_options; subst_function = subst_options; discharge_function = discharge_options; classify_function = classify_options } in (fun l m v -> let v = preprocess v in Lib.add_anonymous_leaf (options (l, m, v))) else (fun _ m v -> let v = preprocess v in match m with | OptSet -> write v | OptAppend -> write (append (read ()) v)) in let warn () = if depr then warn_deprecated_option key in let cread () = cast (read ()) in let cwrite l v = warn (); change l OptSet (uncast v) in let cappend l v = warn (); change l OptAppend (uncast v) in value_tab := OptionMap.add key (name, depr, (sync,cread,cwrite,cappend)) !value_tab; write type 'a write_function = 'a -> unit let declare_int_option = declare_option (fun v -> IntValue v) (function IntValue v -> v | _ -> anomaly (Pp.str "async_option")) (fun _ _ -> anomaly (Pp.str "async_option")) let declare_bool_option = declare_option (fun v -> BoolValue v) (function BoolValue v -> v | _ -> anomaly (Pp.str "async_option")) (fun _ _ -> anomaly (Pp.str "async_option")) let declare_string_option = declare_option (fun v -> StringValue v) (function StringValue v -> v | _ -> anomaly (Pp.str "async_option")) (fun x y -> x^","^y) let declare_stringopt_option = declare_option (fun v -> StringOptValue v) (function StringOptValue v -> v | _ -> anomaly (Pp.str "async_option")) (fun _ _ -> anomaly (Pp.str "async_option")) (* 3- User accessible commands *) (* Setting values of options *) let warn_unknown_option = CWarnings.create ~name:"unknown-option" ~category:"option" (fun key -> strbrk "There is no option " ++ str (nickname key) ++ str ".") let set_option_value locality check_and_cast key v = let opt = try Some (get_option key) with Not_found -> None in match opt with | None -> warn_unknown_option key | Some (name, depr, (_,read,write,append)) -> write (get_locality locality) (check_and_cast v (read ())) let bad_type_error () = error "Bad type of value for this option." let check_int_value v = function | IntValue _ -> IntValue v | _ -> bad_type_error () let check_bool_value v = function | BoolValue _ -> BoolValue v | _ -> bad_type_error () let check_string_value v = function | StringValue _ -> StringValue v | StringOptValue _ -> StringOptValue (Some v) | _ -> bad_type_error () let check_unset_value v = function | BoolValue _ -> BoolValue false | IntValue _ -> IntValue None | StringOptValue _ -> StringOptValue None | _ -> bad_type_error () (* Nota: For compatibility reasons, some errors are treated as warning. This allows a script to refer to an option that doesn't exist anymore *) let set_int_option_value_gen locality = set_option_value locality check_int_value let set_bool_option_value_gen locality key v = set_option_value locality check_bool_value key v let set_string_option_value_gen locality = set_option_value locality check_string_value let unset_option_value_gen locality key = set_option_value locality check_unset_value key () let set_string_option_append_value_gen locality key v = let opt = try Some (get_option key) with Not_found -> None in match opt with | None -> warn_unknown_option key | Some (name, depr, (_,read,write,append)) -> append (get_locality locality) (check_string_value v (read ())) let set_int_option_value = set_int_option_value_gen None let set_bool_option_value = set_bool_option_value_gen None let set_string_option_value = set_string_option_value_gen None (* Printing options/tables *) let msg_option_value (name,v) = match v with | BoolValue true -> str "on" | BoolValue false -> str "off" | IntValue (Some n) -> int n | IntValue None -> str "undefined" | StringValue s -> str "\"" ++ str s ++ str "\"" | StringOptValue None -> str"undefined" | StringOptValue (Some s) -> str "\"" ++ str s ++ str "\"" (* | IdentValue r -> pr_global_env Id.Set.empty r *) let print_option_value key = let (name, depr, (_,read,_,_)) = get_option key in let s = read () in match s with | BoolValue b -> Feedback.msg_info (str "The " ++ str name ++ str " mode is " ++ str (if b then "on" else "off")) | _ -> Feedback.msg_info (str "Current value of " ++ str name ++ str " is " ++ msg_option_value (name, s)) let get_tables () = let tables = !value_tab in let fold key (name, depr, (sync,read,_,_)) accu = let state = { opt_sync = sync; opt_name = name; opt_depr = depr; opt_value = read (); } in OptionMap.add key state accu in OptionMap.fold fold tables OptionMap.empty let print_tables () = let print_option key name value depr = let msg = str " " ++ str (nickname key) ++ str ": " ++ msg_option_value (name, value) in if depr then msg ++ str " [DEPRECATED]" ++ fnl () else msg ++ fnl () in str "Synchronous options:" ++ fnl () ++ OptionMap.fold (fun key (name, depr, (sync,read,_,_)) p -> if sync then p ++ print_option key name (read ()) depr else p) !value_tab (mt ()) ++ str "Asynchronous options:" ++ fnl () ++ OptionMap.fold (fun key (name, depr, (sync,read,_,_)) p -> if sync then p else p ++ print_option key name (read ()) depr) !value_tab (mt ()) ++ str "Tables:" ++ fnl () ++ List.fold_right (fun (nickkey,_) p -> p ++ str " " ++ str nickkey ++ fnl ()) !string_table (mt ()) ++ List.fold_right (fun (nickkey,_) p -> p ++ str " " ++ str nickkey ++ fnl ()) !ref_table (mt ()) ++ fnl () coq-8.6/library/decls.mli0000644000175000017500000000332613022274260014724 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* variable_data -> unit val variable_path : variable -> DirPath.t val variable_secpath : variable -> qualid val variable_kind : variable -> logical_kind val variable_opacity : variable -> bool val variable_context : variable -> Univ.universe_context_set val variable_polymorphic : variable -> polymorphic val variable_exists : variable -> bool (** Registration and access to the table of constants *) val add_constant_kind : constant -> logical_kind -> unit val constant_kind : constant -> logical_kind (* Prepare global named context for proof session: remove proofs of opaque section definitions and remove vm-compiled code *) val initialize_named_context_for_proof : unit -> Environ.named_context_val (** Miscellaneous functions *) val last_section_hyps : DirPath.t -> Id.t list coq-8.6/library/libobject.mli0000644000175000017500000001045413022274260015567 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit; load_function : int -> object_name * 'a -> unit; open_function : int -> object_name * 'a -> unit; classify_function : 'a -> 'a substitutivity; subst_function : substitution * 'a -> 'a; discharge_function : object_name * 'a -> 'a option; rebuild_function : 'a -> 'a } (** The default object is a "Keep" object with empty methods. Object creators are advised to use the construction [{(default_object "MY_OBJECT") with cache_function = ... }] and specify only these functions which are not empty/meaningless *) val default_object : string -> 'a object_declaration (** the identity substitution function *) val ident_subst_function : substitution * 'a -> 'a (** {6 ... } *) (** Given an object declaration, the function [declare_object_full] will hand back two functions, the "injection" and "projection" functions for dynamically typed library-objects. *) type obj val declare_object_full : 'a object_declaration -> ('a -> obj) * (obj -> 'a) val declare_object : 'a object_declaration -> ('a -> obj) val object_tag : obj -> string val cache_object : object_name * obj -> unit val load_object : int -> object_name * obj -> unit val open_object : int -> object_name * obj -> unit val subst_object : substitution * obj -> obj val classify_object : obj -> obj substitutivity val discharge_object : object_name * obj -> obj option val rebuild_object : obj -> obj (** {6 Debug} *) val dump : unit -> (int * string) list coq-8.6/library/summary.ml0000644000175000017500000001534113022274260015156 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a; unfreeze_function : 'a -> unit; init_function : unit -> unit } let summaries = ref Int.Map.empty let mangle id = id ^ "-SUMMARY" let internal_declare_summary hash sumname sdecl = let (infun, outfun) = Dyn.Easy.make_dyn (mangle sumname) in let dyn_freeze b = infun (sdecl.freeze_function b) and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum) and dyn_init = sdecl.init_function in let ddecl = { freeze_function = dyn_freeze; unfreeze_function = dyn_unfreeze; init_function = dyn_init } in summaries := Int.Map.add hash (sumname, ddecl) !summaries let all_declared_summaries = ref Int.Set.empty let summary_names = ref [] let name_of_summary name = try List.assoc name !summary_names with Not_found -> "summary name not found" let declare_summary sumname decl = let hash = String.hash sumname in let () = if Int.Map.mem hash !summaries then let (name, _) = Int.Map.find hash !summaries in anomaly ~label:"Summary.declare_summary" (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str name) in all_declared_summaries := Int.Set.add hash !all_declared_summaries; summary_names := (hash, sumname) :: !summary_names; internal_declare_summary hash sumname decl type frozen = { summaries : (int * Dyn.t) list; (** Ordered list w.r.t. the first component. *) ml_module : Dyn.t option; (** Special handling of the ml_module summary. *) } let empty_frozen = { summaries = []; ml_module = None; } let ml_modules = "ML-MODULES" let ml_modules_summary = String.hash ml_modules let freeze_summaries ~marshallable : frozen = let fold id (_, decl) accu = (* to debug missing Lazy.force if marshallable <> `No then begin let id, _ = Int.Map.find id !summaries in prerr_endline ("begin marshalling " ^ id); ignore(Marshal.to_string (decl.freeze_function marshallable) []); prerr_endline ("end marshalling " ^ id); end; /debug *) let state = decl.freeze_function marshallable in if Int.equal id ml_modules_summary then { accu with ml_module = Some state } else { accu with summaries = (id, state) :: accu.summaries } in Int.Map.fold_right fold !summaries empty_frozen let unfreeze_summaries fs = (* The unfreezing of [ml_modules_summary] has to be anticipated since it * may modify the content of [summaries] ny loading new ML modules *) let (_, decl) = try Int.Map.find ml_modules_summary !summaries with Not_found -> anomaly (str "Undeclared summary " ++ str ml_modules) in let () = match fs.ml_module with | None -> anomaly (str "Undeclared summary " ++ str ml_modules) | Some state -> decl.unfreeze_function state in let fold id (_, decl) states = if Int.equal id ml_modules_summary then states else match states with | [] -> let () = decl.init_function () in [] | (nid, state) :: rstates -> if Int.equal id nid then let () = decl.unfreeze_function state in rstates else let () = decl.init_function () in states in let fold id decl state = try fold id decl state with e when CErrors.noncritical e -> let e = CErrors.push e in Printf.eprintf "Error unfrezing summay %s\n%s\n%!" (name_of_summary id) (Pp.string_of_ppcmds (CErrors.iprint e)); iraise e in (** We rely on the order of the frozen list, and the order of folding *) ignore (Int.Map.fold_left fold !summaries fs.summaries) let init_summaries () = Int.Map.iter (fun _ (_, decl) -> decl.init_function ()) !summaries (** For global tables registered statically before the end of coqtop launch, the following empty [init_function] could be used. *) let nop () = () (** Selective freeze *) type frozen_bits = (int * Dyn.t) list let ids_of_string_list complement ids = if not complement then List.map String.hash ids else let fold accu id = let id = String.hash id in Int.Set.remove id accu in let ids = List.fold_left fold !all_declared_summaries ids in Int.Set.elements ids let freeze_summary ~marshallable ?(complement=false) ids = let ids = ids_of_string_list complement ids in List.map (fun id -> let (_, summary) = Int.Map.find id !summaries in id, summary.freeze_function marshallable) ids let unfreeze_summary datas = List.iter (fun (id, data) -> let (name, summary) = Int.Map.find id !summaries in try summary.unfreeze_function data with e -> let e = CErrors.push e in prerr_endline ("Exception unfreezing " ^ name); iraise e) datas let surgery_summary { summaries; ml_module } bits = let summaries = List.map (fun (id, _ as orig) -> try id, List.assoc id bits with Not_found -> orig) summaries in { summaries; ml_module } let project_summary { summaries; ml_module } ?(complement=false) ids = let ids = ids_of_string_list complement ids in List.filter (fun (id, _) -> List.mem id ids) summaries let pointer_equal l1 l2 = let ptr_equal d1 d2 = let Dyn.Dyn (t1, x1) = d1 in let Dyn.Dyn (t2, x2) = d2 in match Dyn.eq t1 t2 with | None -> false | Some Refl -> x1 == x2 in CList.for_all2eq (fun (id1,v1) (id2,v2) -> id1 = id2 && ptr_equal v1 v2) l1 l2 (** All-in-one reference declaration + registration *) let ref ?(freeze=fun _ r -> r) ~name x = let r = ref x in declare_summary name { freeze_function = (fun b -> freeze b !r); unfreeze_function = ((:=) r); init_function = (fun () -> r := x) }; r module Local = struct type 'a local_ref = ('a CEphemeron.key * string) ref let (:=) r v = r := (CEphemeron.create v, snd !r) let (!) r = let key, name = !r in try CEphemeron.get key with CEphemeron.InvalidKey -> let _, { init_function } = Int.Map.find (String.hash (mangle name)) !summaries in init_function (); CEphemeron.get (fst !r) let ref ?(freeze=fun x -> x) ~name init = let r = Pervasives.ref (CEphemeron.create init, name) in declare_summary name { freeze_function = (fun _ -> freeze !r); unfreeze_function = ((:=) r); init_function = (fun () -> r := init) }; r end let dump = Dyn.dump coq-8.6/library/declaremods.mli0000644000175000017500000001042413022274260016111 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Misctypes.module_kind -> 'modast -> Entries.module_struct_entry * Misctypes.module_kind type 'modast module_params = (Id.t Loc.located list * ('modast * inline)) list (** [declare_module interp_modast id fargs typ exprs] declares module [id], with structure constructed by [interp_modast] from functor arguments [fargs], with final type [typ]. [exprs] is usually of length 1 (Module definition with a concrete body), but it could also be empty ("Declare Module", with non-empty [typ]), or multiple (body of the shape M <+ N <+ ...). *) val declare_module : 'modast module_interpretor -> Id.t -> 'modast module_params -> ('modast * inline) module_signature -> ('modast * inline) list -> module_path val start_module : 'modast module_interpretor -> bool option -> Id.t -> 'modast module_params -> ('modast * inline) module_signature -> module_path val end_module : unit -> module_path (** {6 Module types } *) (** [declare_modtype interp_modast id fargs typs exprs] Similar to [declare_module], except that the types could be multiple *) val declare_modtype : 'modast module_interpretor -> Id.t -> 'modast module_params -> ('modast * inline) list -> ('modast * inline) list -> module_path val start_modtype : 'modast module_interpretor -> Id.t -> 'modast module_params -> ('modast * inline) list -> module_path val end_modtype : unit -> module_path (** Hooks for XML output *) val xml_declare_module : (module_path -> unit) Hook.t val xml_start_module : (module_path -> unit) Hook.t val xml_end_module : (module_path -> unit) Hook.t val xml_declare_module_type : (module_path -> unit) Hook.t val xml_start_module_type : (module_path -> unit) Hook.t val xml_end_module_type : (module_path -> unit) Hook.t (** {6 Libraries i.e. modules on disk } *) type library_name = DirPath.t type library_objects val register_library : library_name -> Safe_typing.compiled_library -> library_objects -> Safe_typing.vodigest -> Univ.universe_context_set -> unit val get_library_native_symbols : library_name -> Nativecode.symbols val start_library : library_name -> unit val end_library : ?except:Future.UUIDSet.t -> library_name -> Safe_typing.compiled_library * library_objects * Safe_typing.native_library (** append a function to be executed at end_library *) val append_end_library_hook : (unit -> unit) -> unit (** [really_import_module mp] opens the module [mp] (in a Caml sense). It modifies Nametab and performs the [open_object] function for every object of the module. Raises [Not_found] when [mp] is unknown or when [mp] corresponds to a functor. *) val really_import_module : module_path -> unit (** [import_module export mp] is a synchronous version of [really_import_module]. If [export] is [true], the module is also opened every time the module containing it is. *) val import_module : bool -> module_path -> unit (** Include *) val declare_include : 'modast module_interpretor -> ('modast * inline) list -> unit (** {6 ... } *) (** [iter_all_segments] iterate over all segments, the modules' segments first and then the current segment. Modules are presented in an arbitrary order. The given function is applied to all leaves (together with their section path). *) val iter_all_segments : (Libnames.object_name -> Libobject.obj -> unit) -> unit val debug_print_modtab : unit -> Pp.std_ppcmds (** For printing modules, [process_module_binding] adds names of bound module (and its components) to Nametab. It also loads objects associated to it. It may raise a [Failure] when the bound module hasn't an atomic type. *) val process_module_binding : MBId.t -> Declarations.module_alg_expr -> unit coq-8.6/library/kindops.mli0000644000175000017500000000140513022274260015275 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* logical_kind val string_of_theorem_kind : theorem_kind -> string val string_of_definition_kind : definition_kind -> string coq-8.6/library/goptions.mli0000644000175000017500000001547313022274260015502 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool -> std_ppcmds val synchronous : bool end) -> sig val active : string -> bool val elements : unit -> string list end (** The functor [MakeRefTable] declares a new table of objects of type [A.t] practically denoted by [reference]; the encoding function [encode : reference -> A.t] is typically a globalization function, possibly with some restriction checks; the function [member_message] say what to print when invoking the "Test Toto Titi foo." command; at the end [title] is the table name printed when invoking the "Print Toto Titi." command; [active] is roughly the internal version of the vernacular "Test ...": it tells if a given object is in the table. *) module MakeRefTable : functor (A : sig type t val compare : t -> t -> int val encode : reference -> t val subst : substitution -> t -> t val printer : t -> std_ppcmds val key : option_name val title : string val member_message : t -> bool -> std_ppcmds val synchronous : bool end) -> sig val active : A.t -> bool val elements : unit -> A.t list end (** {6 Options. } *) (** These types and function are for declaring a new option of name [key] and access functions [read] and [write]; the parameter [name] is the option name used when printing the option value (command "Print Toto Titi." *) type 'a option_sig = { optsync : bool; (** whether the option is synchronous w.r.t to the section/module system. *) optdepr : bool; (** whether the option is DEPRECATED *) optname : string; (** a short string describing the option *) optkey : option_name; (** the low-level name of this option *) optread : unit -> 'a; optwrite : 'a -> unit } (** When an option is declared synchronous ([optsync] is [true]), the output is a synchronous write function. Otherwise it is [optwrite] *) (** The [preprocess] function is triggered before setting the option. It can be used to emit a warning on certain values, and clean-up the final value. *) type 'a write_function = 'a -> unit val declare_int_option : ?preprocess:(int option -> int option) -> int option option_sig -> int option write_function val declare_bool_option : ?preprocess:(bool -> bool) -> bool option_sig -> bool write_function val declare_string_option: ?preprocess:(string -> string) -> string option_sig -> string write_function val declare_stringopt_option: ?preprocess:(string option -> string option) -> string option option_sig -> string option write_function (** {6 Special functions supposed to be used only in vernacentries.ml } *) module OptionMap : CSig.MapS with type key = option_name val get_string_table : option_name -> < add : string -> unit; remove : string -> unit; mem : string -> unit; print : unit > val get_ref_table : option_name -> < add : reference -> unit; remove : reference -> unit; mem : reference -> unit; print : unit > (** The first argument is a locality flag. [Some true] = "Local", [Some false]="Global". *) val set_int_option_value_gen : bool option -> option_name -> int option -> unit val set_bool_option_value_gen : bool option -> option_name -> bool -> unit val set_string_option_value_gen : bool option -> option_name -> string -> unit val set_string_option_append_value_gen : bool option -> option_name -> string -> unit val unset_option_value_gen : bool option -> option_name -> unit val set_int_option_value : option_name -> int option -> unit val set_bool_option_value : option_name -> bool -> unit val set_string_option_value : option_name -> string -> unit val print_option_value : option_name -> unit type option_value = | BoolValue of bool | IntValue of int option | StringValue of string | StringOptValue of string option (** Summary of an option status *) type option_state = { opt_sync : bool; opt_depr : bool; opt_name : string; opt_value : option_value; } val get_tables : unit -> option_state OptionMap.t val print_tables : unit -> std_ppcmds val error_undeclared_key : option_name -> 'a coq-8.6/library/heads.mli0000644000175000017500000000210713022274260014712 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit (** [is_rigid] tells if some term is known to ultimately reduce to a term with a rigid head symbol *) val is_rigid : env -> constr -> bool coq-8.6/ide/0000755000175000017500000000000013022274260012220 5ustar mdenesmdenescoq-8.6/ide/wg_Detachable.ml0000644000175000017500000000547713022274260015300 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit) -> unit method detached : callback:(GObj.widget -> unit) -> unit end class detachable (obj : ([> Gtk.box] as 'a) Gobject.obj) = object(self) inherit GPack.box_skel (obj :> Gtk.box Gobject.obj) as super val but = GButton.button () val win = GWindow.window () val frame = GBin.frame ~shadow_type:`NONE () val mutable detached = false val mutable detached_cb = (fun _ -> ()) val mutable attached_cb = (fun _ -> ()) method child = frame#child method add = frame#add method pack ?from ?expand ?fill ?padding w = if frame#all_children = [] then self#add w else raise (Invalid_argument "detachable#pack") method title = win#title method set_title = win#set_title method connect : detachable_signals = object inherit GContainer.container_signals_impl obj method attached ~callback = attached_cb <- callback method detached ~callback = detached_cb <- callback end method show = if detached then win#present () else self#misc#show (); method hide = if detached then win#misc#hide () else self#misc#hide () method visible = win#misc#visible || self#misc#visible method frame = frame method button = but method attach () = win#misc#hide (); frame#misc#reparent self#coerce; detached <- false; attached_cb self#child method detach () = frame#misc#reparent win#coerce; self#misc#hide (); win#present (); detached <- true; detached_cb self#child initializer self#set_homogeneous false; super#pack ~expand:false but#coerce; super#pack ~expand:true ~fill:true frame#coerce; win#misc#hide (); but#add (GMisc.label ~markup:"D\nE\nT\nA\nC\nH" ())#coerce; ignore(win#event#connect#delete ~callback:(fun _ -> self#attach (); true)); ignore(but#connect#clicked ~callback:(fun _ -> self#detach ())) end let detachable ?title = GtkPack.Box.make_params [] ~cont:( GContainer.pack_container ~create:(fun p -> let d = new detachable (GtkPack.Box.create `HORIZONTAL p) in Option.iter d#set_title title; d)) coq-8.6/ide/serialize.mli0000644000175000017500000000312213022274260014710 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (string * string) list -> string val constructor: string -> string -> xml list -> xml val do_match: string -> (string -> xml list -> 'b) -> xml -> 'b val singleton: 'a list -> 'a val raw_string: xml list -> string val of_unit: unit -> xml val to_unit: xml -> unit val of_bool: bool -> xml val to_bool: xml -> bool val of_list: ('a -> xml) -> 'a list -> xml val to_list: (xml -> 'a) -> xml -> 'a list val of_option: ('a -> xml) -> 'a option -> xml val to_option: (xml -> 'a) -> xml -> 'a option val of_string: string -> xml val to_string: xml -> string val of_int: int -> xml val to_int: xml -> int val of_pair: ('a -> xml) -> ('b -> xml) -> 'a * 'b -> xml val to_pair: (xml -> 'a) -> (xml -> 'b) -> xml -> 'a * 'b val of_union: ('a -> xml) -> ('b -> xml) -> ('a, 'b) CSig.union -> xml val to_union: (xml -> 'a) -> (xml -> 'b) -> xml -> ('a, 'b) CSig.union val of_edit_id: int -> xml val to_edit_id: xml -> int val of_loc : Loc.t -> xml val to_loc : xml -> Loc.t val of_xml : xml -> xml val to_xml : xml -> xml coq-8.6/ide/coqOps.mli0000644000175000017500000000267513022274260014201 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit task method tactic_wizard : string list -> unit task method process_next_phrase : unit task method process_until_end_or_error : unit task method handle_reset_initial : unit task method raw_coq_query : string -> unit task method show_goals : unit task method backtrack_last_phrase : unit task method initialize : unit task method join_document : unit task method stop_worker : string -> unit task method get_n_errors : int method get_errors : (int * string) list method get_slaves_status : int * int * string CString.Map.t method handle_failure : Interface.handle_exn_rty -> unit task method destroy : unit -> unit end class coqops : Wg_ScriptView.script_view -> Wg_ProofView.proof_view -> Wg_MessageView.message_view -> Wg_Segment.segment -> coqtop -> (unit -> string option) -> ops coq-8.6/ide/wg_Find.mli0000644000175000017500000000147113022274260014303 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* GText.view -> object method coerce : GObj.widget method hide : unit -> unit method show : unit -> unit method replace : unit -> unit method replace_all : unit -> unit method find_backward : unit -> unit method find_forward : unit -> unit end coq-8.6/ide/wg_Notebook.ml0000644000175000017500000000512713022274260015034 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* if i = real_pos then term else x) 0 term_list; super#set_page ?tab_label ?menu_label page method get_nth_term i = List.nth term_list i method term_num f p = Util.List.index0 f p term_list method pages = term_list method remove_page index = term_list <- Util.List.filteri (fun i x -> if i = index then kill_page x; i <> index) term_list; super#remove_page index method current_term = List.nth term_list super#current_page end let create make kill = GtkPack.Notebook.make_params [] ~cont:(GContainer.pack_container ~create:(fun pl -> let nb = GtkPack.Notebook.create pl in (new typed_notebook make kill nb))) coq-8.6/ide/project_file.ml40000644000175000017500000002054613022274260015312 0ustar mdenesmdenestype target = | ML of string (* ML file : foo.ml -> (ML "foo.ml") *) | MLI of string (* MLI file : foo.mli -> (MLI "foo.mli") *) | ML4 of string (* ML4 file : foo.ml4 -> (ML4 "foo.ml4") *) | MLLIB of string (* MLLIB file : foo.mllib -> (MLLIB "foo.mllib") *) | MLPACK of string (* MLLIB file : foo.mlpack -> (MLLIB "foo.mlpack") *) | V of string (* V file : foo.v -> (V "foo") *) | Arg of string | Special of string * string * bool * string (* file, dependencies, is_phony, command *) | Subdir of string | Def of string * string (* X=foo -> Def ("X","foo") *) | MLInclude of string (* -I physicalpath *) | Include of string * string (* -Q physicalpath logicalpath *) | RInclude of string * string (* -R physicalpath logicalpath *) type install = | NoInstall | TraditionalInstall | UserInstall | UnspecInstall exception Parsing_error let rec parse_string = parser | [< '' ' | '\n' | '\t' >] -> "" | [< 'c; s >] -> (String.make 1 c)^(parse_string s) | [< >] -> "" and parse_string2 = parser | [< ''"' >] -> "" | [< 'c; s >] -> (String.make 1 c)^(parse_string2 s) | [< >] -> raise Parsing_error and parse_skip_comment = parser | [< ''\n'; s >] -> s | [< 'c; s >] -> parse_skip_comment s | [< >] -> [< >] and parse_args = parser | [< '' ' | '\n' | '\t'; s >] -> parse_args s | [< ''#'; s >] -> parse_args (parse_skip_comment s) | [< ''"'; str = parse_string2; s >] -> ("" ^ str) :: parse_args s | [< 'c; str = parse_string; s >] -> ((String.make 1 c) ^ str) :: (parse_args s) | [< >] -> [] let parse f = let c = open_in f in let res = parse_args (Stream.of_channel c) in close_in c; res let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) l = function | [] -> opts, l | ("-h"|"--help") :: _ -> raise Parsing_error | ("-no-opt"|"-byte") :: r -> process_cmd_line orig_dir (project_file,makefile,install,false) l r | ("-full"|"-opt") :: r -> process_cmd_line orig_dir (project_file,makefile,install,true) l r | "-impredicative-set" :: r -> Feedback.msg_warning (Pp.str "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform."); process_cmd_line orig_dir opts (Arg "-impredicative-set" :: l) r | "-no-install" :: r -> Feedback.msg_warning (Pp.(++) (Pp.str "Option -no-install is deprecated.") (Pp.(++) (Pp.spc ()) (Pp.str "Use \"-install none\" instead"))); process_cmd_line orig_dir (project_file,makefile,NoInstall,opt) l r | "-install" :: d :: r -> if install <> UnspecInstall then Feedback.msg_warning (Pp.str "-install sets more than once."); let install = match d with | "user" -> UserInstall | "none" -> NoInstall | "global" -> TraditionalInstall | _ -> Feedback.msg_warning (Pp.(++) (Pp.str "invalid option '") (Pp.(++) (Pp.str d) (Pp.str "' passed to -install."))); install in process_cmd_line orig_dir (project_file,makefile,install,opt) l r | "-custom" :: com :: dependencies :: file :: r -> Feedback.msg_warning (Pp.app (Pp.str "Please now use \"-extra[-phony] result deps command\" instead of \"-custom command deps result\".") (Pp.pr_arg Pp.str "It follows makefile target declaration order and has a clearer semantic.") ); process_cmd_line orig_dir opts (Special (file,dependencies,false,com) :: l) r | "-extra" :: file :: dependencies :: com :: r -> process_cmd_line orig_dir opts (Special (file,dependencies,false,com) :: l) r | "-extra-phony" :: target :: dependencies :: com :: r -> process_cmd_line orig_dir opts (Special (target,dependencies,true,com) :: l) r | "-Q" :: d :: lp :: r -> process_cmd_line orig_dir opts ((Include (CUnix.correct_path d orig_dir, lp)) :: l) r | "-I" :: d :: r -> process_cmd_line orig_dir opts ((MLInclude (CUnix.correct_path d orig_dir)) :: l) r | "-R" :: p :: lp :: r -> process_cmd_line orig_dir opts (RInclude (CUnix.correct_path p orig_dir,lp) :: l) r | ("-Q"|"-R"|"-I"|"-custom"|"-extra"|"-extra-phony") :: _ -> raise Parsing_error | "-f" :: file :: r -> let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in let () = match project_file with | None -> () | Some _ -> Feedback.msg_warning (Pp.str "Several features will not work with multiple project files.") in let (opts',l') = process_cmd_line (Filename.dirname file) (Some file,makefile,install,opt) l (parse file) in process_cmd_line orig_dir opts' l' r | ["-f"] -> raise Parsing_error | "-o" :: file :: r -> begin try let _ = String.index file '/' in raise Parsing_error with Not_found -> let () = match makefile with |None -> () |Some f -> Feedback.msg_warning (Pp.(++) (Pp.str "Only one output file is genererated. ") (Pp.(++) (Pp.str f) (Pp.str " will not be."))) in process_cmd_line orig_dir (project_file,Some file,install,opt) l r end | v :: "=" :: def :: r -> process_cmd_line orig_dir opts (Def (v,def) :: l) r | "-arg" :: a :: r -> process_cmd_line orig_dir opts (Arg a :: l) r | f :: r -> let f = CUnix.correct_path f orig_dir in process_cmd_line orig_dir opts (( if Filename.check_suffix f ".v" then V f else if (Filename.check_suffix f ".ml") then ML f else if (Filename.check_suffix f ".ml4") then ML4 f else if (Filename.check_suffix f ".mli") then MLI f else if (Filename.check_suffix f ".mllib") then MLLIB f else if (Filename.check_suffix f ".mlpack") then MLPACK f else Subdir f) :: l) r let process_cmd_line orig_dir opts l args = let (opts, l) = process_cmd_line orig_dir opts l args in opts, List.rev l let rec post_canonize f = if Filename.basename f = Filename.current_dir_name then let dir = Filename.dirname f in if dir = Filename.current_dir_name then f else post_canonize dir else f (* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(ml_inc,q_inc,r_inc),(args,defs)) *) let split_arguments args = List.fold_right (fun a ((v,(mli,ml4,ml,mllib,mlpack as m),o,s as t), (ml_inc,q_inc,r_inc as i),(args,defs as d)) -> match a with | V n -> ((CUnix.remove_path_dot n::v,m,o,s),i,d) | ML n -> ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d) | MLI n -> ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d) | ML4 n -> ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d) | MLLIB n -> ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d) | MLPACK n -> ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d) | Special (n,dep,is_phony,c) -> ((v,m,(n,dep,is_phony,c)::o,s),i,d) | Subdir n -> ((v,m,o,n::s),i,d) | MLInclude p -> let ml_new = (CUnix.remove_path_dot (post_canonize p), CUnix.canonical_path_name p) in (t,(ml_new::ml_inc,q_inc,r_inc),d) | Include (p,l) -> let q_new = (CUnix.remove_path_dot (post_canonize p),l, CUnix.canonical_path_name p) in (t,(ml_inc,q_new::q_inc,r_inc),d) | RInclude (p,l) -> let r_new = (CUnix.remove_path_dot (post_canonize p),l, CUnix.canonical_path_name p) in (t,(ml_inc,q_inc,r_new::r_inc),d) | Def (v,def) -> (t,i,(args,(v,def)::defs)) | Arg a -> (t,i,(a::args,defs))) args (([],([],[],[],[],[]),[],[]),([],[],[]),([],[])) let read_project_file f = split_arguments (snd (process_cmd_line (Filename.dirname f) (Some f, None, NoInstall, true) [] (parse f))) let args_from_project file project_files default_name = let build_cmd_line ml_inc i_inc r_inc args = List.fold_right (fun (_,i) o -> "-I" :: i :: o) ml_inc (List.fold_right (fun (_,l,i) o -> "-Q" :: i :: l :: o) i_inc (List.fold_right (fun (_,l,p) o -> "-R" :: p :: l :: o) r_inc (List.fold_right (fun a o -> parse_args (Stream.of_string a) @ o) args []))) in try let (fname,(_,(ml_inc,i_inc,r_inc),(args,_))) = List.hd project_files in fname, build_cmd_line ml_inc i_inc r_inc args with Failure _ -> let rec find_project_file dir = try let fname = Filename.concat dir default_name in let ((v_files,_,_,_),(ml_inc,i_inc,r_inc),(args,_)) = read_project_file fname in fname, build_cmd_line ml_inc i_inc r_inc args with Sys_error s -> let newdir = Filename.dirname dir in if dir = newdir then "",[] else find_project_file newdir in find_project_file (Filename.dirname file) coq-8.6/ide/document.mli0000644000175000017500000001075313022274260014547 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a document (* Functions that work on the focused part of the document ******************* *) (** The last sentence. @raise Invalid_argument if tip has no id. @raise Empty *) val tip : 'a document -> id (** The last sentence. @raise Empty *) val tip_data : 'a document -> 'a (** Add a sentence on the top (with no state_id) *) val push : 'a document -> 'a -> unit (** Remove the tip setence. @raise Empty *) val pop : 'a document -> 'a (** Assign the state_id of the tip. @raise Empty *) val assign_tip_id : 'a document -> id -> unit (** [cut_at d id] cuts the document at [id] that is the new tip. Returns the list of sentences that were cut. @raise Not_found *) val cut_at : 'a document -> id -> 'a list (* Functions that work on the whole document ********************************* *) (** returns the id of the topmost sentence validating the predicate and a boolean that is true if one needs to unfocus the document to access such sentence. @raise Not_found *) val find_id : 'a document -> (id -> 'a -> bool) -> id * bool (** look for a sentence validating the predicate. The boolean is true if the sentence is in the zone currently focused. @raise Not_found *) val find : 'a document -> (bool -> id option -> 'a -> bool) -> 'a val find_map : 'a document -> (bool -> id option -> 'a -> 'b option) -> 'b (** After [focus s c1 c2] the top of [s] is the topmost element [x] such that [c1 x] is [true] and the bottom is the first element [y] following [x] such that [c2 y] is [true]. @raise Invalid_argument if there is no such [x] and [y] or already focused *) val focus : 'a document -> cond_top:(id -> 'a -> bool) -> cond_bot:(id -> 'a -> bool) -> unit (** Undoes a [focus]. @raise Invalid_argument "CStack.unfocus" if the stack is not focused *) val unfocus : 'a document -> unit (** Is the document focused *) val focused : 'a document -> bool (** No sentences at all *) val is_empty : 'a document -> bool (** returns the 1 to-last sentence, and true if we need to unfocus to reach it. @raise Not_found *) val before_tip : 'a document -> id * bool (** Is the id in the focused zone? *) val is_in_focus : 'a document -> id -> bool (** Folds over the whole document starting from the topmost (maybe unfocused) sentence. *) val fold_all : 'a document -> 'c -> ('c -> bool -> id option -> 'a -> 'c) -> 'c (** Returns (top,bot) such that the document is morally (top @ s @ bot) where s is the focused part. @raise Invalid_argument *) val context : 'a document -> (id * 'a) list * (id * 'a) list (** debug print *) val print : 'a document -> (bool -> id option -> 'a -> Pp.std_ppcmds) -> Pp.std_ppcmds (** Callbacks on documents *) class type ['a] signals = object method popped : callback:('a -> ('a list * 'a list) option -> unit) -> unit method pushed : callback:('a -> ('a list * 'a list) option -> unit) -> unit end val connect : 'a document -> 'a signals coq-8.6/ide/session.ml0000644000175000017500000005034713022274260014246 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit method on_update : callback:('a -> unit) -> unit method data : 'a end class type control = object method detach : unit -> unit end type errpage = (int * string) list page type jobpage = string CString.Map.t page type session = { buffer : GText.buffer; script : Wg_ScriptView.script_view; proof : Wg_ProofView.proof_view; messages : Wg_MessageView.message_view; segment : Wg_Segment.segment; fileops : FileOps.ops; coqops : CoqOps.ops; coqtop : Coq.coqtop; command : Wg_Command.command_window; finder : Wg_Find.finder; tab_label : GMisc.label; errpage : errpage; jobpage : jobpage; mutable control : control; } let create_buffer () = let buffer = GSourceView2.source_buffer ~tag_table:Tags.Script.table ~highlight_matching_brackets:true ?language:(lang_manager#language source_language#get) ?style_scheme:(style_manager#style_scheme source_style#get) () in let _ = buffer#create_mark ~name:"start_of_input" buffer#start_iter in let _ = buffer#create_mark ~left_gravity:false ~name:"stop_of_input" buffer#end_iter in let _ = buffer#create_mark ~name:"prev_insert" buffer#start_iter in let _ = buffer#place_cursor ~where:buffer#start_iter in let _ = buffer#add_selection_clipboard Ideutils.cb in buffer let create_script coqtop source_buffer = let script = Wg_ScriptView.script_view coqtop ~source_buffer ~show_line_numbers:true ~wrap_mode:`NONE () in let _ = script#misc#set_name "ScriptWindow" in script (** NB: Events during text edition: - [begin_user_action] - [insert_text] (or [delete_range] when deleting) - [changed] - [end_user_action] When pasting a text containing tags (e.g. the sentence terminators), there is actually many [insert_text] and [changed]. For instance, for "a. b.": - [begin_user_action] - [insert_text] (for "a") - [changed] - [insert_text] (for ".") - [changed] - [apply_tag] (for the tag of ".") - [insert_text] (for " b") - [changed] - [insert_text] (for ".") - [changed] - [apply_tag] (for the tag of ".") - [end_user_action] Since these copy-pasted tags may interact badly with the retag mechanism, we now don't monitor the "changed" event, but rather the "begin_user_action" and "end_user_action". We begin by setting a mark at the initial cursor point. At the end, the zone between the mark and the cursor is to be untagged and then retagged. *) let set_buffer_handlers (buffer : GText.buffer) script (coqops : CoqOps.ops) coqtop = let action_was_cancelled = ref true in let no_coq_action_required = ref true in let cur_action = ref 0 in let new_action_id = let id = ref 0 in fun () -> incr id; !id in let running_action = ref None in let cancel_signal ?(stop_emit=true) reason = Minilib.log ("user_action cancelled: "^reason); action_was_cancelled := true; if stop_emit then GtkSignal.stop_emit () in let del_mark () = try buffer#delete_mark (`NAME "target") with GText.No_such_mark _ -> () in let add_mark it = del_mark (); buffer#create_mark ~name:"target" it in let call_coq_or_cancel_action f = no_coq_action_required := false; let action = !cur_action in let action, fallback = Coq.seq (Coq.lift (fun () -> running_action := Some action)) f, fun () -> (* If Coq is busy due to the current action, we don't cancel *) match !running_action with | Some aid when aid = action -> () | _ -> cancel_signal ~stop_emit:false "Coq busy" in Coq.try_grab coqtop action fallback in let get_start () = buffer#get_iter_at_mark (`NAME "start_of_input") in let get_stop () = buffer#get_iter_at_mark (`NAME "stop_of_input") in let ensure_marks_exist () = try ignore(buffer#get_mark (`NAME "stop_of_input")) with GText.No_such_mark _ -> assert false in let get_insert () = buffer#get_iter_at_mark `INSERT in let update_prev it = let prev = buffer#get_iter_at_mark (`NAME "prev_insert") in if it#offset < prev#offset then buffer#move_mark (`NAME "prev_insert") ~where:it in let debug_edit_zone () = if false (*!Minilib.debug*) then begin buffer#remove_tag Tags.Script.edit_zone ~start:buffer#start_iter ~stop:buffer#end_iter; buffer#apply_tag Tags.Script.edit_zone ~start:(get_start()) ~stop:(get_stop()) end in let backto_before_error it = let rec aux old it = if it#is_start || not(it#has_tag Tags.Script.error_bg) then old else aux it it#backward_char in aux it it in let insert_cb it s = if String.length s = 0 then () else begin Minilib.log ("insert_cb " ^ string_of_int it#offset); let text_mark = add_mark it in let () = update_prev it in if it#has_tag Tags.Script.to_process then cancel_signal "Altering the script being processed in not implemented" else if it#has_tag Tags.Script.processed then call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) else if it#has_tag Tags.Script.error_bg then begin let prev_sentence_end = backto_before_error it in let text_mark = add_mark prev_sentence_end in call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) end end in let delete_cb ~start ~stop = Minilib.log (Printf.sprintf "delete_cb %d %d" start#offset stop#offset); let min_iter, max_iter = if start#compare stop < 0 then start, stop else stop, start in let () = update_prev min_iter in let text_mark = add_mark min_iter in let rec aux min_iter = if min_iter#equal max_iter then () else if min_iter#has_tag Tags.Script.to_process then cancel_signal "Altering the script being processed in not implemented" else if min_iter#has_tag Tags.Script.processed then call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) else if min_iter#has_tag Tags.Script.error_bg then let prev_sentence_end = backto_before_error min_iter in let text_mark = add_mark prev_sentence_end in call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) else aux min_iter#forward_char in aux min_iter in let begin_action_cb () = Minilib.log "begin_action_cb"; action_was_cancelled := false; no_coq_action_required := true; cur_action := new_action_id (); let where = get_insert () in buffer#move_mark (`NAME "prev_insert") ~where in let end_action_cb () = Minilib.log "end_action_cb"; ensure_marks_exist (); if not !action_was_cancelled then begin (* If coq was asked to backtrack, the clenup must be done by the backtrack_until function, since it may move the stop_of_input to a point indicated by coq. *) if !no_coq_action_required then begin let start, stop = get_start (), get_stop () in List.iter (fun tag -> buffer#remove_tag tag ~start ~stop) Tags.Script.ephemere; Sentence.tag_on_insert buffer end; end in let mark_deleted_cb m = match GtkText.Mark.get_name m with | Some "insert" -> () | Some s -> Minilib.log (s^" deleted") | None -> () in let mark_set_cb it m = debug_edit_zone (); let ins = get_insert () in let line = ins#line + 1 in let off = ins#line_offset + 1 in let msg = Printf.sprintf "Line: %5d Char: %3d" line off in let () = !Ideutils.set_location msg in match GtkText.Mark.get_name m with | Some "insert" -> () | Some s -> Minilib.log (s^" moved") | None -> () in (** Pluging callbacks *) let _ = buffer#connect#insert_text ~callback:insert_cb in let _ = buffer#connect#delete_range ~callback:delete_cb in let _ = buffer#connect#begin_user_action ~callback:begin_action_cb in let _ = buffer#connect#end_user_action ~callback:end_action_cb in let _ = buffer#connect#after#mark_set ~callback:mark_set_cb in let _ = buffer#connect#after#mark_deleted ~callback:mark_deleted_cb in () let find_int_col s l = match List.assoc s l with `IntC c -> c | _ -> assert false let find_string_col s l = match List.assoc s l with `StringC c -> c | _ -> assert false let make_table_widget ?sort cd cb = let frame = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC () in let columns, store = let cols = new GTree.column_list in let columns = List.map (function | (`Int,n,_) -> n, `IntC (cols#add Gobject.Data.int) | (`String,n,_) -> n, `StringC (cols#add Gobject.Data.string)) cd in columns, GTree.list_store cols in let data = GTree.view ~vadjustment:frame#vadjustment ~hadjustment:frame#hadjustment ~rules_hint:true ~headers_visible:false ~model:store ~packing:frame#add () in let () = data#set_headers_visible true in let () = data#set_headers_clickable true in let refresh clr = data#misc#modify_base [`NORMAL, `NAME clr] in let _ = background_color#connect#changed refresh in let _ = data#misc#connect#realize (fun () -> refresh background_color#get) in let mk_rend c = GTree.cell_renderer_text [], ["text",c] in let cols = List.map2 (fun (_,c) (_,n,v) -> let c = match c with | `IntC c -> GTree.view_column ~renderer:(mk_rend c) () | `StringC c -> GTree.view_column ~renderer:(mk_rend c) () in c#set_title n; c#set_visible v; c#set_sizing `AUTOSIZE; c) columns cd in let make_sorting i (_, c) = let sort (store : GTree.model) it1 it2 = match c with | `IntC c -> Pervasives.compare (store#get ~row:it1 ~column:c) (store#get ~row:it2 ~column:c) | `StringC c -> Pervasives.compare (store#get ~row:it1 ~column:c) (store#get ~row:it2 ~column:c) in store#set_sort_func i sort in CList.iteri make_sorting columns; CList.iteri (fun i c -> c#set_sort_column_id i) cols; List.iter (fun c -> ignore(data#append_column c)) cols; ignore( data#connect#row_activated ~callback:(fun tp vc -> cb columns store tp vc) ); let () = match sort with None -> () | Some (i, t) -> store#set_sort_column_id i t in frame, (fun f -> f columns store) let create_errpage (script : Wg_ScriptView.script_view) : errpage = let table, access = make_table_widget ~sort:(0, `ASCENDING) [`Int,"Line",true; `String,"Error message",true] (fun columns store tp vc -> let row = store#get_iter tp in let lno = store#get ~row ~column:(find_int_col "Line" columns) in let where = script#buffer#get_iter (`LINE (lno-1)) in script#buffer#place_cursor ~where; script#misc#grab_focus (); ignore (script#scroll_to_iter ~use_align:false ~yalign:0.75 ~within_margin:0.25 where)) in let tip = GMisc.label ~text:"Double click to jump to error line" () in let box = GPack.vbox ~homogeneous:false () in let () = box#pack ~expand:true table#coerce in let () = box#pack ~expand:false ~padding:2 tip#coerce in let last_update = ref [] in let callback = ref (fun _ -> ()) in object (self) inherit GObj.widget box#as_widget method update errs = if !last_update = errs then () else begin last_update := errs; access (fun _ store -> store#clear ()); !callback errs; List.iter (fun (lno, msg) -> access (fun columns store -> let line = store#append () in store#set line (find_int_col "Line" columns) lno; store#set line (find_string_col "Error message" columns) msg)) errs end method on_update ~callback:cb = callback := cb method data = !last_update end let create_jobpage coqtop coqops : jobpage = let table, access = make_table_widget ~sort:(0, `ASCENDING) [`String,"Worker",true; `String,"Job name",true] (fun columns store tp vc -> let row = store#get_iter tp in let w = store#get ~row ~column:(find_string_col "Worker" columns) in let info () = Minilib.log ("Coq busy, discarding query") in Coq.try_grab coqtop (coqops#stop_worker w) info ) in let tip = GMisc.label ~text:"Double click to interrupt worker" () in let box = GPack.vbox ~homogeneous:false () in let () = box#pack ~expand:true table#coerce in let () = box#pack ~expand:false ~padding:2 tip#coerce in let last_update = ref CString.Map.empty in let callback = ref (fun _ -> ()) in object (self) inherit GObj.widget box#as_widget method update jobs = if !last_update = jobs then () else begin last_update := jobs; access (fun _ store -> store#clear ()); !callback jobs; CString.Map.iter (fun id job -> access (fun columns store -> let column = find_string_col "Worker" columns in if job = "Dead" then store#foreach (fun _ row -> if store#get ~row ~column = id then store#remove row || true else false) else let line = store#append () in store#set line column id; store#set line (find_string_col "Job name" columns) job)) jobs end method on_update ~callback:cb = callback := cb method data = !last_update end let create_proof () = let proof = Wg_ProofView.proof_view () in let _ = proof#misc#set_can_focus true in let _ = GtkBase.Widget.add_events proof#as_widget [`ENTER_NOTIFY;`POINTER_MOTION] in proof let create_messages () = let messages = Wg_MessageView.message_view () in let _ = messages#misc#set_can_focus true in messages let dummy_control : control = object method detach () = () end let create file coqtop_args = let basename = match file with |None -> "*scratch*" |Some f -> Glib.Convert.filename_to_utf8 (Filename.basename f) in let coqtop = Coq.spawn_coqtop coqtop_args in let reset () = Coq.reset_coqtop coqtop in let buffer = create_buffer () in let script = create_script coqtop buffer in let proof = create_proof () in let messages = create_messages () in let segment = new Wg_Segment.segment () in let command = new Wg_Command.command_window basename coqtop in let finder = new Wg_Find.finder basename (script :> GText.view) in let fops = new FileOps.fileops (buffer :> GText.buffer) file reset in let _ = fops#update_stats in let cops = new CoqOps.coqops script proof messages segment coqtop (fun () -> fops#filename) in let errpage = create_errpage script in let jobpage = create_jobpage coqtop cops in let _ = set_buffer_handlers (buffer :> GText.buffer) script cops coqtop in let _ = Coq.set_reset_handler coqtop cops#handle_reset_initial in let _ = Coq.init_coqtop coqtop cops#initialize in { buffer = (buffer :> GText.buffer); script=script; proof=proof; messages=messages; segment=segment; fileops=fops; coqops=cops; coqtop=coqtop; command=command; finder=finder; tab_label= GMisc.label ~text:basename (); errpage=errpage; jobpage=jobpage; control = dummy_control; } let kill (sn:session) = (* To close the detached views of this script, we call manually [destroy] on it, triggering some callbacks in [detach_view]. In a more modern lablgtk, rather use the page-removed signal ? *) sn.coqops#destroy (); sn.script#destroy (); Coq.close_coqtop sn.coqtop let build_layout (sn:session) = let session_paned = GPack.paned `VERTICAL () in let session_box = GPack.vbox ~packing:(session_paned#pack1 ~shrink:false ~resize:true) () in (** Right part of the window. *) let eval_paned = GPack.paned `HORIZONTAL ~border_width:5 ~packing:(session_box#pack ~expand:true) () in let script_frame = GBin.frame ~shadow_type:`IN ~packing:eval_paned#add1 () in let script_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:script_frame#add () in let state_paned = GPack.paned `VERTICAL ~packing:eval_paned#add2 () in (** Proof buffer. *) let title = Printf.sprintf "Proof (%s)" sn.tab_label#text in let proof_detachable = Wg_Detachable.detachable ~title () in let () = proof_detachable#button#misc#hide () in let () = proof_detachable#frame#set_shadow_type `IN in let () = state_paned#add1 proof_detachable#coerce in let callback _ = proof_detachable#show in let () = proof_detachable#connect#attached ~callback in let callback _ = sn.proof#coerce#misc#set_size_request ~width:500 ~height:400 () in let () = proof_detachable#connect#detached ~callback in let proof_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:proof_detachable#pack () in (** Message buffer. *) let message_frame = GPack.notebook ~packing:state_paned#add () in let add_msg_page pos name text (w : GObj.widget) = let detachable = Wg_Detachable.detachable ~title:(text^" ("^name^")") () in detachable#add w#coerce; let label = GPack.hbox ~spacing:5 () in let lbl = GMisc.label ~text ~packing:label#add () in let but = GButton.button () in but#add (GMisc.label ~markup:"↗" ())#coerce; label#add but#coerce; ignore(message_frame#insert_page ~pos ~tab_label:label#coerce detachable#coerce); ignore(but#connect#clicked ~callback:(fun _ -> message_frame#remove_page (message_frame#page_num detachable#coerce); detachable#button#clicked ())); detachable#connect#detached ~callback:(fun _ -> if message_frame#all_children = [] then message_frame#misc#hide (); w#misc#set_size_request ~width:500 ~height:400 ()); detachable#connect#attached ~callback:(fun _ -> ignore(message_frame#insert_page ~pos ~tab_label:label#coerce detachable#coerce); message_frame#misc#show (); detachable#show); detachable#button#misc#hide (); detachable, lbl in let session_tab = GPack.hbox ~homogeneous:false () in let img = GMisc.image ~icon_size:`SMALL_TOOLBAR ~packing:session_tab#pack () in let _ = sn.buffer#connect#modified_changed ~callback:(fun () -> if sn.buffer#modified then img#set_stock `SAVE else img#set_stock `YES) in let _ = eval_paned#misc#connect#size_allocate ~callback: (let old_paned_width = ref 2 in let old_paned_height = ref 2 in fun {Gtk.width=paned_width;Gtk.height=paned_height} -> if !old_paned_width <> paned_width || !old_paned_height <> paned_height then begin eval_paned#set_position (eval_paned#position * paned_width / !old_paned_width); state_paned#set_position (state_paned#position * paned_height / !old_paned_height); old_paned_width := paned_width; old_paned_height := paned_height; end) in session_box#pack sn.finder#coerce; session_box#pack sn.segment#coerce; sn.command#pack_in (session_paned#pack2 ~shrink:false ~resize:false); script_scroll#add sn.script#coerce; proof_scroll#add sn.proof#coerce; let detach, _ = add_msg_page 0 sn.tab_label#text "Messages" sn.messages#coerce in let _, label = add_msg_page 1 sn.tab_label#text "Errors" sn.errpage#coerce in let _, _ = add_msg_page 2 sn.tab_label#text "Jobs" sn.jobpage#coerce in (** When a message is received, focus on the message pane *) let _ = sn.messages#connect#pushed ~callback:(fun _ _ -> let num = message_frame#page_num detach#coerce in if 0 <= num then message_frame#goto_page num ) in (** When an error occurs, paint the error label in red *) let txt = label#text in let red s = "" ^ s ^ "" in sn.errpage#on_update ~callback:(fun l -> if l = [] then (label#set_use_markup false; label#set_text txt) else (label#set_text (red txt);label#set_use_markup true)); session_tab#pack sn.tab_label#coerce; img#set_stock `YES; eval_paned#set_position 1; state_paned#set_position 1; let control = object method detach () = proof_detachable#detach () end in let () = sn.control <- control in (Some session_tab#coerce,None,session_paned#coerce) coq-8.6/ide/minilib.ml0000644000175000017500000000400513022274260014174 0ustar mdenesmdenes(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* () | [x] -> print fmt x | x :: r -> print fmt x; print_list print fmt r type level = [ | `DEBUG | `INFO | `NOTICE | `WARNING | `ERROR | `FATAL ] (** Some excerpt of Util and similar files to avoid loading the whole module and its dependencies (and hence Compat and Camlp4) *) let debug = ref false (* On a Win32 application with no console, writing to stderr raise a Sys_error "bad file descriptor", hence the "try" below. Ideally, we should re-route message to a log file somewhere, or print in the response buffer. *) let log ?(level = `DEBUG) msg = let prefix = match level with | `DEBUG -> "DEBUG" | `INFO -> "INFO" | `NOTICE -> "NOTICE" | `WARNING -> "WARNING" | `ERROR -> "ERROR" | `FATAL -> "FATAL" in if !debug then begin try Printf.eprintf "[%s] %s\n%!" prefix msg with _ -> () end let coqify d = Filename.concat d "coq" let coqide_config_home () = coqify (Glib.get_user_config_dir ()) let coqide_data_dirs () = coqify (Glib.get_user_data_dir ()) :: List.map coqify (Glib.get_system_data_dirs ()) @ Option.List.cons Coq_config.datadir [] let coqide_config_dirs () = coqide_config_home () :: List.map coqify (Glib.get_system_config_dirs ()) @ Option.List.cons Coq_config.configdir [] let is_prefix_of pre s = let i = ref 0 in let () = while (!i < (String.length pre) && !i < (String.length s) && pre.[!i] = s.[!i]) do incr i done in !i = String.length pre coq-8.6/ide/tags.mli0000644000175000017500000000246313022274260013666 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string val color_of_string : string -> Gdk.color coq-8.6/ide/coqide_ui.ml0000644000175000017500000001315213022274260014515 0ustar mdenesmdeneslet ui_m = GAction.ui_manager ();; let no_under = Util.String.map (fun x -> if x = '_' then '-' else x) let list_items menu li = let res_buf = Buffer.create 500 in let tactic_item = function |[] -> Buffer.create 1 |[s] -> let b = Buffer.create 16 in let () = Buffer.add_string b ("\n") in b |s::_ as l -> let b = Buffer.create 50 in let () = (Buffer.add_string b ("\n")) in let () = (List.iter (fun x -> Buffer.add_string b ("\n")) l) in let () = Buffer.add_string b"\n" in b in let () = List.iter (fun b -> Buffer.add_buffer res_buf (tactic_item b)) li in res_buf let list_queries menu li = let res_buf = Buffer.create 500 in let query_item (q, _) = let s = "\n" in Buffer.add_string res_buf s in let () = List.iter query_item li in res_buf let init () = let theui = Printf.sprintf " %s %s %s %s " (if Coq_config.gtk_platform <> `QUARTZ then "" else "") (Buffer.contents (list_items "Tactic" Coq_commands.tactics)) (Buffer.contents (list_items "Template" Coq_commands.commands)) (Buffer.contents (list_queries "User-Query" Preferences.user_queries#get)) in ignore (ui_m#add_ui_from_string theui); coq-8.6/ide/xml_printer.mli0000644000175000017500000000223013022274260015263 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t (** Print the xml data structure to a source into a compact xml string (without any user-readable formating ). *) val print : t -> xml -> unit (** Print the xml data structure into a compact xml string (without any user-readable formating ). *) val to_string : xml -> string (** Print the xml data structure into an user-readable string with tabs and lines break between different nodes. *) val to_string_fmt : xml -> string (** Print PCDATA as a string by escaping XML entities. *) val pcdata_to_string : string -> string coq-8.6/ide/wg_ScriptView.mli0000644000175000017500000000365313022274260015526 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Coq.coqtop -> object inherit GSourceView2.source_view method undo : unit -> unit method redo : unit -> unit method clear_undo : unit -> unit method auto_complete : bool method set_auto_complete : bool -> unit method right_margin_position : int method set_right_margin_position : int -> unit method show_right_margin : bool method set_show_right_margin : bool -> unit method comment : unit -> unit method uncomment : unit -> unit method recenter_insert : unit method complete_popup : Wg_Completion.complete_popup end val script_view : Coq.coqtop -> ?source_buffer:GSourceView2.source_buffer -> ?draw_spaces:SourceView2Enums.source_draw_spaces_flags list -> ?auto_indent:bool -> ?highlight_current_line:bool -> ?indent_on_tab:bool -> ?indent_width:int -> ?insert_spaces_instead_of_tabs:bool -> ?right_margin_position:int -> ?show_line_marks:bool -> ?show_line_numbers:bool -> ?show_right_margin:bool -> ?smart_home_end:SourceView2Enums.source_smart_home_end_type -> ?tab_width:int -> ?editable:bool -> ?cursor_visible:bool -> ?justification:GtkEnums.justification -> ?wrap_mode:GtkEnums.wrap_mode -> ?accepts_tab:bool -> ?border_width:int -> ?width:int -> ?height:int -> ?packing:(GObj.widget -> unit) -> ?show:bool -> unit -> script_view coq-8.6/ide/tags.ml0000644000175000017500000000500613022274260013511 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* value in Unix.putenv var new_val let resources_dir = let working_dir = Sys.getcwd () in let () = Sys.chdir (Filename.dirname (Sys.executable_name)) in let app_root_dir = Filename.dirname (Sys.getcwd ()) in let () = Sys.chdir working_dir in Filename.concat app_root_dir "Resources" let lib_dir = Filename.concat resources_dir "lib" let etc_dir = Filename.concat resources_dir "etc" let xdg_home = Filename.concat (Sys.getenv "HOME") "Library/Application Support" let () = Unix.putenv "DYLD_LIBRARY_PATH" lib_dir let () = Unix.putenv "XDG_DATA_HOME" xdg_home let () = Unix.putenv "XDG_CONFIG_HOME" xdg_home let () = append_to_var "XDG_DATA_DIRS" (Filename.concat resources_dir "share") let () = append_to_var "XDG_CONFIG_DIRS" (Filename.concat etc_dir "xdg") let () = Unix.putenv "GTK_DATA_PREFIX" resources_dir let () = Unix.putenv "GTK_EXE_PREFIX" resources_dir let () = Unix.putenv "GTK_PATH" resources_dir let () = Unix.putenv "GTK2_RC_FILES" (Filename.concat etc_dir "gtk-2.0/gtkrc") let () = Unix.putenv "GTK_IM_MODULE_FILE" (Filename.concat etc_dir "gtk-2.0/gtk-immodules.loaders") let () = Unix.putenv "GDK_PIXBUF_MODULE_FILE" (Filename.concat etc_dir "gtk-2.0/gdk-pixbuf.loaders") let () = Unix.putenv "PANGO_LIBDIR" lib_dir let () = Unix.putenv "PANGO_SYSCONFIGDIR" etc_dir let () = Unix.putenv "CHARSETALIASDIR" lib_dir let () = append_to_var "PATH" (Filename.concat resources_dir "bin") coq-8.6/ide/utf8_convert.mll0000644000175000017500000000243313022274260015356 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* s in let c = if Glib.Utf8.validate code then code else s in Buffer.add_string b c; entry lexbuf } | _ { let s = lexeme lexbuf in Buffer.add_string b s; entry lexbuf} | eof { let s = Buffer.contents b in Buffer.reset b ; s } { let f s = let lb = from_string s in Buffer.reset b; entry lb } coq-8.6/ide/coq.mli0000644000175000017500000001547613022274260013522 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a task (** Monadic return of values as tasks. *) val bind : 'a task -> ('a -> 'b task) -> 'b task (** Monadic binding of tasks *) val lift : (unit -> 'a) -> 'a task (** Return the imperative computation waiting to be processed. *) val seq : unit task -> 'a task -> 'a task (** Sequential composition *) (** {5 Coqtop process management} *) type reset_kind = Planned | Unexpected (** A reset may occur accidentally or voluntarily, so we discriminate between these. *) val is_computing : coqtop -> bool (** Check if coqtop is computing, i.e. already has a current task *) val spawn_coqtop : string list -> coqtop (** Create a coqtop process with some command-line arguments. *) val set_reset_handler : coqtop -> unit task -> unit (** Register a handler called when a coqtop dies (badly or on purpose) *) val set_feedback_handler : coqtop -> (Feedback.feedback -> unit) -> unit (** Register a handler called when coqtop sends a feedback message *) val init_coqtop : coqtop -> unit task -> unit (** Finish initializing a freshly spawned coqtop, by running a first task on it. The task should run its inner continuation at the end. *) val break_coqtop : coqtop -> string list -> unit (** Interrupt the current computation of coqtop or the worker if coqtop it not running. *) val close_coqtop : coqtop -> unit (** Close coqtop. Subsequent requests will be discarded. Hook ignored. *) val reset_coqtop : coqtop -> unit (** Reset coqtop. Pending requests will be discarded. The reset handler of coqtop will be called with [Planned] as first argument *) val get_arguments : coqtop -> string list (** Get the current arguments used by coqtop. *) val set_arguments : coqtop -> string list -> unit (** Set process arguments. This also forces a planned reset. *) (** In win32, sockets are not like regular files *) val gio_channel_of_descr_socket : (Unix.file_descr -> Glib.Io.channel) ref (** {5 Task processing} *) val try_grab : coqtop -> unit task -> (unit -> unit) -> unit (** Try to schedule a task on a coqtop. If coqtop is available, the task callback is run (asynchronously), otherwise the [(unit->unit)] callback is triggered. - If coqtop ever dies during the computation, this function restarts coqtop and calls the restart hook with the fresh coqtop. - If the argument function raises an exception, a coqtop reset occurs. - The task may be discarded if a [close_coqtop] or [reset_coqtop] occurs before its completion. - The task callback should run its inner continuation at the end. *) (** {5 Atomic calls to coqtop} *) (** These atomic calls can be combined to form arbitrary multi-call tasks. They correspond to the protocol calls (cf [Serialize] for more details). Note that each call is asynchronous: it will return immediately, but the inner callback will be executed later to handle the call answer when this answer is available. Except for interp, we use the default logger for any call. *) type 'a query = 'a Interface.value task (** A type abbreviation for coqtop specific answers *) val add : ?logger:Ideutils.logger -> Interface.add_sty -> Interface.add_rty query val edit_at : Interface.edit_at_sty -> Interface.edit_at_rty query val query : ?logger:Ideutils.logger -> Interface.query_sty -> Interface.query_rty query val status : ?logger:Ideutils.logger -> Interface.status_sty -> Interface.status_rty query val goals : ?logger:Ideutils.logger -> Interface.goals_sty -> Interface.goals_rty query val evars : Interface.evars_sty -> Interface.evars_rty query val hints : Interface.hints_sty -> Interface.hints_rty query val mkcases : Interface.mkcases_sty -> Interface.mkcases_rty query val search : Interface.search_sty -> Interface.search_rty query val init : Interface.init_sty -> Interface.init_rty query val stop_worker: Interface.stop_worker_sty-> Interface.stop_worker_rty query (** A specialized version of [raw_interp] dedicated to set/unset options. *) module PrintOpt : sig type t (** Representation of an option *) type bool_descr = { opts : t list; init : bool; label : string } val bool_items : bool_descr list val set : t -> bool -> unit val set_printing_width : int -> unit (** [enforce] transmits to coq the current option values. It is also called by [goals] and [evars] above. *) val enforce : unit task end (** {5 Miscellaneous} *) val short_version : unit -> string (** Return a short phrase identifying coqtop version and date of compilation, as given by the [configure] script. *) val version : unit -> string (** More verbose description, including details about libraries and architecture. *) val filter_coq_opts : string list -> string list (** * Launch a test coqtop processes, ask for a correct coqtop if it fails. @return the list of arguments that coqtop did not understand (the files probably ..). This command may terminate coqide in case of trouble. *) val check_connection : string list -> unit (** Launch a coqtop with the user args in order to be sure that it works, checking in particular that Prelude.vo is found. This command may terminate coqide in case of trouble *) val interrupter : (int -> unit) ref coq-8.6/ide/FAQ0000644000175000017500000000472213022274260012557 0ustar mdenesmdenes CoqIde FAQ Q0) What is CoqIde? R0: A powerful graphical interface for Coq. See http://coq.inria.fr. for more informations. Q1) How to enable Emacs keybindings? R1: Insert gtk-key-theme-name = "Emacs" in your gtkrc file. The location of this file is system-dependent. If you're running Gnome, you may use the graphical configuration tools. Q2) How to enable antialiased fonts? R2) Set the GDK_USE_XFT variable to 1. This is by default with Gtk >= 2.2. If some of your fonts are not available, set GDK_USE_XFT to 0. Q4) How to use those Forall and Exists pretty symbols? R4) Thanks to the Notation features in Coq, you just need to insert these lines in your Coq Buffer : ====================================================================== Notation "∀ x : t, P" := (forall x:t, P) (at level 200, x ident). Notation "∃ x : t, P" := (exists x:t, P) (at level 200, x ident). ====================================================================== Copy/Paste of these lines from this file will not work outside of CoqIde. You need to load a file containing these lines or to enter the "∀" using an input method (see Q5). To try it just use "Require utf8" from inside CoqIde. To enable these notations automatically start coqide with coqide -l utf8 In the ide subdir of Coq library, you will find a sample utf8.v with some pretty simple notations. Q5) How to define an input method for non ASCII symbols? R5)-First solution : type "2200" to enter a forall in the script widow. 2200 is the hexadecimal code for forall in unicode charts and is encoded as "∀" in UTF-8. 2203 is for exists. See http://www.unicode.org for more codes. -Second solution : Use an input method editor, such as SCIM or iBus. The latter offers a module for LaTeX-like inputting. Q6) How to customize the shortcuts for menus? R6) Two solutions are offered: - Edit $XDG_CONFIG_HOME/coq/coqide.keys by hand or - If your system allows it, from CoqIde, you may select a menu entry and press the desired shortcut. Q7) What encoding should I use? What is this \x{iiii} in my file? R7) The encoding option is related to the way files are saved. Keep it as UTF-8 until it becomes important for you to exchange files with non UTF-8 aware applications. If you choose something else than UTF-8, then missing characters will be encoded by \x{....} or \x{........} where each dot is an hex. digit. The number between braces is the hexadecimal UNICODE index for the missing character. coq-8.6/ide/xml_parser.ml0000644000175000017500000001444713022274260014740 0ustar mdenesmdenes(* * Xml Light, an small Xml parser/printer with DTD support. * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com) * Copyright (C) 2003 Jacques Garrigue * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open Printf open Xml_datatype type xml = Xml_datatype.xml type error_pos = { eline : int; eline_start : int; emin : int; emax : int; } type error_msg = | UnterminatedComment | UnterminatedString | UnterminatedEntity | IdentExpected | CloseExpected | NodeExpected | AttributeNameExpected | AttributeValueExpected | EndOfTagExpected of string | EOFExpected | Empty type error = error_msg * error_pos exception Error of error exception File_not_found of string type t = { mutable check_eof : bool; mutable concat_pcdata : bool; source : Lexing.lexbuf; stack : Xml_lexer.token Stack.t; } type source = | SChannel of in_channel | SString of string | SLexbuf of Lexing.lexbuf exception Internal_error of error_msg exception NoMoreData let xml_error = ref (fun _ -> assert false) let file_not_found = ref (fun _ -> assert false) let is_blank s = let len = String.length s in let break = ref true in let i = ref 0 in while !break && !i < len do let c = s.[!i] in (* no '\r' because we replaced them in the lexer *) if c = ' ' || c = '\n' || c = '\t' then incr i else break := false done; !i = len let _raises e f = xml_error := e; file_not_found := f let make source = let source = match source with | SChannel chan -> Lexing.from_channel chan | SString s -> Lexing.from_string s | SLexbuf lexbuf -> lexbuf in let () = Xml_lexer.init source in { check_eof = false; concat_pcdata = true; source = source; stack = Stack.create (); } let check_eof p v = p.check_eof <- v let pop s = try Stack.pop s.stack with Stack.Empty -> Xml_lexer.token s.source let push t s = Stack.push t s.stack let canonicalize l = let has_elt = List.exists (function Element _ -> true | _ -> false) l in if has_elt then List.filter (function PCData s -> not (is_blank s) | _ -> true) l else l let rec read_xml do_not_canonicalize s = let rec read_node s = match pop s with | Xml_lexer.PCData s -> PCData s | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, []) | Xml_lexer.Tag (tag, attr, false) -> let elements = read_elems tag s in let elements = if do_not_canonicalize then elements else canonicalize elements in Element (tag, attr, elements) | t -> push t s; raise NoMoreData and read_elems tag s = let elems = ref [] in (try while true do let node = read_node s in match node, !elems with | PCData c , (PCData c2) :: q -> elems := PCData (c2 ^ c) :: q | _, l -> elems := node :: l done with NoMoreData -> ()); match pop s with | Xml_lexer.Endtag s when s = tag -> List.rev !elems | t -> raise (Internal_error (EndOfTagExpected tag)) in match read_node s with | (Element _) as node -> node | PCData c -> if is_blank c then read_xml do_not_canonicalize s else raise (Xml_lexer.Error Xml_lexer.ENodeExpected) let convert = function | Xml_lexer.EUnterminatedComment -> UnterminatedComment | Xml_lexer.EUnterminatedString -> UnterminatedString | Xml_lexer.EIdentExpected -> IdentExpected | Xml_lexer.ECloseExpected -> CloseExpected | Xml_lexer.ENodeExpected -> NodeExpected | Xml_lexer.EAttributeNameExpected -> AttributeNameExpected | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected | Xml_lexer.EUnterminatedEntity -> UnterminatedEntity let error_of_exn xparser = function | NoMoreData when pop xparser = Xml_lexer.Eof -> Empty | NoMoreData -> NodeExpected | Internal_error e -> e | Xml_lexer.Error e -> convert e | e -> (*let e = Errors.push e in: We do not record backtrace here. *) raise e let do_parse do_not_canonicalize xparser = try Xml_lexer.init xparser.source; let x = read_xml do_not_canonicalize xparser in if xparser.check_eof && pop xparser <> Xml_lexer.Eof then raise (Internal_error EOFExpected); Xml_lexer.close (); x with any -> Xml_lexer.close (); raise (!xml_error (error_of_exn xparser any) xparser.source) let parse ?(do_not_canonicalize=false) p = do_parse do_not_canonicalize p let error_msg = function | UnterminatedComment -> "Unterminated comment" | UnterminatedString -> "Unterminated string" | UnterminatedEntity -> "Unterminated entity" | IdentExpected -> "Ident expected" | CloseExpected -> "Element close expected" | NodeExpected -> "Xml node expected" | AttributeNameExpected -> "Attribute name expected" | AttributeValueExpected -> "Attribute value expected" | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag | EOFExpected -> "End of file expected" | Empty -> "Empty" let error (msg,pos) = if pos.emin = pos.emax then sprintf "%s line %d character %d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) else sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) (pos.emax - pos.eline_start) let line e = e.eline let range e = e.emin - e.eline_start , e.emax - e.eline_start let abs_range e = e.emin , e.emax let pos source = let line, lstart, min, max = Xml_lexer.pos source in { eline = line; eline_start = lstart; emin = min; emax = max; } let () = _raises (fun x p -> (* local cast : Xml.error_msg -> error_msg *) Error (x, pos p)) (fun f -> File_not_found f) coq-8.6/ide/wg_Segment.mli0000644000175000017500000000224113022274260015021 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit) -> GtkSignal.id end class type model = object method changed : callback:(model_event -> unit) -> unit method length : int method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a end class segment : unit -> object inherit GObj.widget val obj : Gtk.widget Gtk.obj method set_model : model -> unit method connect : segment_signals method default_color : color method set_default_color : color -> unit end coq-8.6/ide/coqOps.ml0000644000175000017500000010165413022274260014025 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mem_flag = function | `ERROR _ -> `ERROR | `WARNING _ -> `WARNING | (`INCOMPLETE | `UNSAFE | `PROCESSING) as mem_flag -> mem_flag let str_of_flag = function | `UNSAFE -> "U" | `PROCESSING -> "P" | `ERROR _ -> "E" | `WARNING _ -> "W" | `INCOMPLETE -> "I" class type signals = object inherit GUtil.ml_signals method changed : callback:(int * mem_flag list -> unit) -> GtkSignal.id end module SentenceId : sig type sentence = private { start : GText.mark; stop : GText.mark; mutable flags : flag list; mutable tooltips : (int * int * string) list; edit_id : int; mutable index : int; changed_sig : (int * mem_flag list) GUtil.signal; } val mk_sentence : start:GText.mark -> stop:GText.mark -> flag list -> sentence val add_flag : sentence -> flag -> unit val has_flag : sentence -> mem_flag -> bool val remove_flag : sentence -> mem_flag -> unit val find_all_tooltips : sentence -> int -> string list val add_tooltip : sentence -> int -> int -> string -> unit val set_index : sentence -> int -> unit val connect : sentence -> signals val dbg_to_string : GText.buffer -> bool -> Stateid.t option -> sentence -> Pp.std_ppcmds end = struct type sentence = { start : GText.mark; stop : GText.mark; mutable flags : flag list; mutable tooltips : (int * int * string) list; edit_id : int; mutable index : int; changed_sig : (int * mem_flag list) GUtil.signal; } let connect s : signals = object inherit GUtil.ml_signals [s.changed_sig#disconnect] method changed = s.changed_sig#connect ~after end let id = ref 0 let mk_sentence ~start ~stop flags = decr id; { start = start; stop = stop; flags = flags; edit_id = !id; tooltips = []; index = -1; changed_sig = new GUtil.signal (); } let changed s = s.changed_sig#call (s.index, List.map mem_flag_of_flag s.flags) let add_flag s f = s.flags <- CList.add_set (=) f s.flags; changed s let has_flag s mf = List.exists (fun f -> mem_flag_of_flag f = mf) s.flags let remove_flag s mf = s.flags <- List.filter (fun f -> mem_flag_of_flag f <> mf) s.flags; changed s let find_all_tooltips s off = CList.map_filter (fun (start,stop,t) -> if start <= off && off <= stop then Some t else None) s.tooltips let add_tooltip s a b t = s.tooltips <- (a,b,t) :: s.tooltips let set_index s i = s.index <- i let dbg_to_string (b : GText.buffer) focused id s = let ellipsize s = Str.global_replace (Str.regexp "^[\n ]*") "" (if String.length s > 20 then String.sub s 0 17 ^ "..." else s) in Pp.str (Printf.sprintf "%s[%3d,%3s](%5d,%5d) %s [%s] %s" (if focused then "*" else " ") s.edit_id (Stateid.to_string (Option.default Stateid.dummy id)) (b#get_iter_at_mark s.start)#offset (b#get_iter_at_mark s.stop)#offset (ellipsize ((b#get_iter_at_mark s.start)#get_slice (b#get_iter_at_mark s.stop))) (String.concat "," (List.map str_of_flag s.flags)) (ellipsize (String.concat "," (List.map (fun (a,b,t) -> Printf.sprintf "<%d,%d> %s" a b t) s.tooltips)))) end open SentenceId let log msg : unit task = Coq.lift (fun () -> Minilib.log msg) class type ops = object method go_to_insert : unit task method go_to_mark : GText.mark -> unit task method tactic_wizard : string list -> unit task method process_next_phrase : unit task method process_until_end_or_error : unit task method handle_reset_initial : unit task method raw_coq_query : string -> unit task method show_goals : unit task method backtrack_last_phrase : unit task method initialize : unit task method join_document : unit task method stop_worker : string -> unit task method get_n_errors : int method get_errors : (int * string) list method get_slaves_status : int * int * string CString.Map.t method handle_failure : handle_exn_rty -> unit task method destroy : unit -> unit end let flags_to_color f = if List.mem `PROCESSING f then `NAME "blue" else if List.mem `ERROR f then `NAME "red" else if List.mem `UNSAFE f then `NAME "orange" else if List.mem `INCOMPLETE f then `NAME "gray" else `NAME Preferences.processed_color#get let validate s = let open Xml_datatype in let rec validate = function | PCData s -> Glib.Utf8.validate s | Element (_, _, children) -> List.for_all validate children in validate (Richpp.repr s) module Doc = Document let segment_model (doc : sentence Doc.document) : Wg_Segment.model = object (self) val mutable cbs = [] val mutable document_length = 0 method length = document_length method changed ~callback = cbs <- callback :: cbs method fold : 'a. ('a -> Wg_Segment.color -> 'a) -> 'a -> 'a = fun f accu -> let fold accu _ _ s = let flags = List.map mem_flag_of_flag s.flags in f accu (flags_to_color flags) in Doc.fold_all doc accu fold method private on_changed (i, f) = let data = (i, flags_to_color f) in List.iter (fun f -> f (`SET data)) cbs method private on_push s ctx = let after = match ctx with | None -> [] | Some (l, _) -> l in List.iter (fun s -> set_index s (s.index + 1)) after; set_index s (document_length - List.length after); ignore ((SentenceId.connect s)#changed self#on_changed); document_length <- document_length + 1; List.iter (fun f -> f `INSERT) cbs method private on_pop s ctx = let () = match ctx with | None -> () | Some (l, _) -> List.iter (fun s -> set_index s (s.index - 1)) l in set_index s (-1); document_length <- document_length - 1; List.iter (fun f -> f `REMOVE) cbs initializer let _ = (Doc.connect doc)#pushed self#on_push in let _ = (Doc.connect doc)#popped self#on_pop in () end class coqops (_script:Wg_ScriptView.script_view) (_pv:Wg_ProofView.proof_view) (_mv:Wg_MessageView.message_view) (_sg:Wg_Segment.segment) (_ct:Coq.coqtop) get_filename = object(self) val script = _script val buffer = (_script#source_buffer :> GText.buffer) val proof = _pv val messages = _mv val segment = _sg val document : sentence Doc.document = Doc.create () val mutable document_length = 0 val mutable initial_state = Stateid.initial (* proofs being processed by the slaves *) val mutable to_process = 0 val mutable processed = 0 val mutable slaves_status = CString.Map.empty val feedbacks : feedback Queue.t = Queue.create () val feedback_timer = Ideutils.mktimer () initializer Coq.set_feedback_handler _ct self#enqueue_feedback; script#misc#set_has_tooltip true; ignore(script#misc#connect#query_tooltip ~callback:self#tooltip_callback); feedback_timer.Ideutils.run ~ms:300 ~callback:self#process_feedback; let md = segment_model document in segment#set_model md; let on_click id = let find _ _ s = Int.equal s.index id in let sentence = Doc.find document find in let mark = sentence.start in let iter = script#buffer#get_iter_at_mark mark in (** Sentence starts tend to be at the end of a line, so we rather choose the first non-line-ending position. *) let rec sentence_start iter = if iter#ends_line then sentence_start iter#forward_line else iter in let iter = sentence_start iter in script#buffer#place_cursor iter; ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter) in let _ = segment#connect#clicked on_click in () method private tooltip_callback ~x ~y ~kbd tooltip = let x, y = script#window_to_buffer_coords `WIDGET x y in let iter = script#get_iter_at_location x y in if iter#has_tag Tags.Script.tooltip then begin let s = let rec aux iter = let marks = iter#marks in if marks = [] then aux iter#backward_char else let mem_marks _ _ s = List.exists (fun m -> Gobject.get_oid m = Gobject.get_oid (buffer#get_mark s.start)) marks in try Doc.find document mem_marks with Not_found -> aux iter#backward_char in aux iter in let ss = find_all_tooltips s (iter#offset - (buffer#get_iter_at_mark s.start)#offset) in let msg = String.concat "\n" (CList.uniquize ss) in GtkBase.Tooltip.set_icon_from_stock tooltip `INFO `BUTTON; script#misc#set_tooltip_markup ("" ^ msg ^ "") end else begin script#misc#set_tooltip_text ""; script#misc#set_has_tooltip true end; false method destroy () = feedback_timer.Ideutils.kill () method private print_stack = Minilib.log "document:"; Minilib.log (Pp.string_of_ppcmds (Doc.print document (dbg_to_string buffer))) method private enter_focus start stop = let at id id' _ = Stateid.equal id' id in self#print_stack; Minilib.log("Focusing "^Stateid.to_string start^" "^Stateid.to_string stop); Doc.focus document ~cond_top:(at start) ~cond_bot:(at stop); self#print_stack; let qed_s = Doc.tip_data document in buffer#move_mark ~where:(buffer#get_iter_at_mark qed_s.stop) (`NAME "stop_of_input") method private exit_focus = Minilib.log "Unfocusing"; Doc.unfocus document; self#print_stack; begin try let where = buffer#get_iter_at_mark (Doc.tip_data document).stop in buffer#move_mark ~where (`NAME "start_of_input"); with Doc.Empty -> () end; buffer#move_mark ~where:buffer#end_iter (`NAME "stop_of_input") method private get_start_of_input = buffer#get_iter_at_mark (`NAME "start_of_input") method private get_end_of_input = buffer#get_iter_at_mark (`NAME "stop_of_input") method private get_insert = buffer#get_iter_at_mark `INSERT method private show_goals_aux ?(move_insert=false) () = Coq.PrintOpt.set_printing_width proof#width; if move_insert then begin let dest = self#get_start_of_input in if (buffer#get_iter_at_mark `INSERT)#compare dest <= 0 then begin buffer#place_cursor ~where:dest; script#recenter_insert end end; Coq.bind (Coq.goals ~logger:messages#push ()) (function | Fail x -> self#handle_failure_aux ~move_insert x | Good goals -> Coq.bind (Coq.evars ()) (function | Fail x -> self#handle_failure_aux ~move_insert x | Good evs -> proof#set_goals goals; proof#set_evars evs; proof#refresh (); Coq.return () ) ) method show_goals = self#show_goals_aux () (* This method is intended to perform stateless commands *) method raw_coq_query phrase = let action = log "raw_coq_query starting now" in let display_error s = if not (validate s) then flash_info "This error is so nasty that I can't even display it." else messages#add s; in let query = Coq.query ~logger:messages#push (phrase,Stateid.dummy) in let next = function | Fail (_, _, err) -> display_error err; Coq.return () | Good msg -> messages#add_string msg; Coq.return () in Coq.bind (Coq.seq action query) next method private mark_as_needed sentence = Minilib.log("Marking " ^ Pp.string_of_ppcmds (dbg_to_string buffer false None sentence)); let start = buffer#get_iter_at_mark sentence.start in let stop = buffer#get_iter_at_mark sentence.stop in let to_process = Tags.Script.to_process in let processed = Tags.Script.processed in let unjustified = Tags.Script.unjustified in let error_bg = Tags.Script.error_bg in let error = Tags.Script.error in let incomplete = Tags.Script.incomplete in let all_tags = [ error_bg; to_process; incomplete; processed; unjustified; error ] in let tags = (if has_flag sentence `PROCESSING then [to_process] else if has_flag sentence `ERROR then [error_bg] else if has_flag sentence `INCOMPLETE then [incomplete] else [processed]) @ (if has_flag sentence `UNSAFE then [unjustified] else []) in List.iter (fun t -> buffer#remove_tag t ~start ~stop) all_tags; List.iter (fun t -> buffer#apply_tag t ~start ~stop) tags method private attach_tooltip sentence loc text = let start_sentence, stop_sentence, phrase = self#get_sentence sentence in let pre_chars, post_chars = if Loc.is_ghost loc then 0, String.length phrase else Loc.unloc loc in let pre = b2c phrase pre_chars in let post = b2c phrase post_chars in let start = start_sentence#forward_chars pre in let stop = start_sentence#forward_chars post in let markup = Glib.Markup.escape_text text in buffer#apply_tag Tags.Script.tooltip ~start ~stop; add_tooltip sentence pre post markup method private is_dummy_id id = match id with | Edit 0 -> true | State id when Stateid.equal id Stateid.dummy -> true | _ -> false method private enqueue_feedback msg = let id = msg.id in if self#is_dummy_id id then () else Queue.add msg feedbacks method private process_feedback () = let rec eat_feedback n = if n = 0 then true else let msg = Queue.pop feedbacks in let id = msg.id in let sentence = let finder _ state_id s = match state_id, id with | Some id', State id when Stateid.equal id id' -> Some (state_id, s) | _, Edit id when id = s.edit_id -> Some (state_id, s) | _ -> None in try Some (Doc.find_map document finder) with Not_found -> None in let log s state_id = Minilib.log ("Feedback " ^ s ^ " on " ^ Stateid.to_string (Option.default Stateid.dummy state_id)) in begin match msg.contents, sentence with | AddedAxiom, Some (id,sentence) -> log "AddedAxiom" id; remove_flag sentence `PROCESSING; remove_flag sentence `ERROR; add_flag sentence `UNSAFE; self#mark_as_needed sentence | Processed, Some (id,sentence) -> log "Processed" id; remove_flag sentence `PROCESSING; self#mark_as_needed sentence | ProcessingIn _, Some (id,sentence) -> log "ProcessingIn" id; add_flag sentence `PROCESSING; self#mark_as_needed sentence | Incomplete, Some (id, sentence) -> log "Incomplete" id; add_flag sentence `INCOMPLETE; self#mark_as_needed sentence | Complete, Some (id, sentence) -> log "Complete" id; remove_flag sentence `INCOMPLETE; self#mark_as_needed sentence | GlobRef(loc, filepath, modpath, ident, ty), Some (id,sentence) -> log "GlobRef" id; self#attach_tooltip sentence loc (Printf.sprintf "%s %s %s" filepath ident ty) | Message(Error, loc, msg), Some (id,sentence) -> let loc = Option.default Loc.ghost loc in let msg = Richpp.raw_print msg in log "ErrorMsg" id; remove_flag sentence `PROCESSING; add_flag sentence (`ERROR (loc, msg)); self#mark_as_needed sentence; self#attach_tooltip sentence loc msg; if not (Loc.is_ghost loc) then self#position_error_tag_at_sentence sentence (Some (Loc.unloc loc)) | Message(Warning, loc, msg), Some (id,sentence) -> let loc = Option.default Loc.ghost loc in let msg = Richpp.raw_print msg in log "WarningMsg" id; add_flag sentence (`WARNING (loc, msg)); self#attach_tooltip sentence loc msg; self#position_warning_tag_at_sentence sentence loc | Message((Info|Notice|Debug as lvl), _, msg), _ -> messages#push lvl msg | InProgress n, _ -> if n < 0 then processed <- processed + abs n else to_process <- to_process + n | WorkerStatus(id,status), _ -> log "WorkerStatus" None; slaves_status <- CString.Map.add id status slaves_status | _ -> if sentence <> None then Minilib.log "Unsupported feedback message" else if Doc.is_empty document then () else try match id, Doc.tip document with | Edit _, _ -> () | State id1, id2 when Stateid.newer_than id2 id1 -> () | _ -> Queue.add msg feedbacks with Doc.Empty | Invalid_argument _ -> Queue.add msg feedbacks end; eat_feedback (n-1) in eat_feedback (Queue.length feedbacks) method private commit_queue_transaction sentence = (* A queued command has been successfully done, we push it to [cmd_stack]. We reget the iters here because Gtk is unable to warranty that they were not modified meanwhile. Not really necessary but who knows... *) self#mark_as_needed sentence; let stop = buffer#get_iter_at_mark sentence.stop in buffer#move_mark ~where:stop (`NAME "start_of_input"); method private position_error_tag_at_iter iter phrase = function | None -> () | Some (start, stop) -> buffer#apply_tag Tags.Script.error ~start:(iter#forward_chars (b2c phrase start)) ~stop:(iter#forward_chars (b2c phrase stop)) method private position_error_tag_at_sentence sentence loc = let start, _, phrase = self#get_sentence sentence in self#position_error_tag_at_iter start phrase loc method private position_warning_tag_at_iter iter_start iter_stop phrase loc = if Loc.is_ghost loc then buffer#apply_tag Tags.Script.warning ~start:iter_start ~stop:iter_stop else buffer#apply_tag Tags.Script.warning ~start:(iter_start#forward_chars (b2c phrase loc.Loc.bp)) ~stop:(iter_stop#forward_chars (b2c phrase loc.Loc.ep)) method private position_warning_tag_at_sentence sentence loc = let start, stop, phrase = self#get_sentence sentence in self#position_warning_tag_at_iter start stop phrase loc method private process_interp_error queue sentence loc msg tip id = Coq.bind (Coq.return ()) (function () -> let start, stop, phrase = self#get_sentence sentence in buffer#remove_tag Tags.Script.to_process ~start ~stop; self#discard_command_queue queue; pop_info (); if Stateid.equal id tip || Stateid.equal id Stateid.dummy then begin self#position_error_tag_at_iter start phrase loc; buffer#place_cursor ~where:stop; messages#clear; messages#push Feedback.Error msg; self#show_goals end else self#show_goals_aux ~move_insert:true () ) method private get_sentence sentence = let start = buffer#get_iter_at_mark sentence.start in let stop = buffer#get_iter_at_mark sentence.stop in let phrase = start#get_slice ~stop in start, stop, phrase (** [fill_command_queue until q] fills a command queue until the [until] condition returns true; it is fed with the number of phrases read and the iters enclosing the current sentence. *) method private fill_command_queue until queue = let topstack = if Doc.focused document then fst (Doc.context document) else [] in let rec loop n iter = match Sentence.find buffer iter with | None -> () | Some (start, stop) -> if until n start stop then begin () end else if List.exists (fun (_, s) -> start#equal (buffer#get_iter_at_mark s.start) && stop#equal (buffer#get_iter_at_mark s.stop)) topstack then begin Queue.push (`Skip (start, stop)) queue; loop n stop end else begin buffer#apply_tag Tags.Script.to_process ~start ~stop; let sentence = mk_sentence ~start:(`MARK (buffer#create_mark start)) ~stop:(`MARK (buffer#create_mark stop)) [] in Queue.push (`Sentence sentence) queue; if not stop#is_end then loop (succ n) stop end in loop 0 self#get_start_of_input method private discard_command_queue queue = while not (Queue.is_empty queue) do match Queue.pop queue with | `Skip _ -> () | `Sentence sentence -> let start = buffer#get_iter_at_mark sentence.start in let stop = buffer#get_iter_at_mark sentence.stop in buffer#remove_tag Tags.Script.to_process ~start ~stop; buffer#delete_mark sentence.start; buffer#delete_mark sentence.stop; done (** Compute the phrases until [until] returns [true]. *) method private process_until ?move_insert until verbose = let logger lvl msg = if verbose then messages#push lvl msg in let fill_queue = Coq.lift (fun () -> let queue = Queue.create () in (* Lock everything and fill the waiting queue *) push_info "Coq is computing"; messages#clear; script#set_editable false; self#fill_command_queue until queue; (* Now unlock and process asynchronously. Since [until] may contain iterators, it shouldn't be used anymore *) script#set_editable true; Minilib.log "Begin command processing"; queue) in let conclude topstack = pop_info (); script#recenter_insert; match topstack with | [] -> self#show_goals_aux ?move_insert () | (_,s)::_ -> self#backtrack_to_iter (buffer#get_iter_at_mark s.start) in let process_queue queue = let rec loop tip topstack = if Queue.is_empty queue then conclude topstack else match Queue.pop queue, topstack with | `Skip(start,stop), [] -> logger Feedback.Error (Richpp.richpp_of_string "You must close the proof with Qed or Admitted"); self#discard_command_queue queue; conclude [] | `Skip(start,stop), (_,s) :: topstack -> assert(start#equal (buffer#get_iter_at_mark s.start)); assert(stop#equal (buffer#get_iter_at_mark s.stop)); loop tip topstack | `Sentence sentence, _ :: _ -> assert false | `Sentence ({ edit_id } as sentence), [] -> add_flag sentence `PROCESSING; Doc.push document sentence; let _, _, phrase = self#get_sentence sentence in let coq_query = Coq.add ~logger ((phrase,edit_id),(tip,verbose)) in let handle_answer = function | Good (id, (Util.Inl (* NewTip *) (), msg)) -> Doc.assign_tip_id document id; logger Feedback.Notice (Richpp.richpp_of_string msg); self#commit_queue_transaction sentence; loop id [] | Good (id, (Util.Inr (* Unfocus *) tip, msg)) -> Doc.assign_tip_id document id; let topstack, _ = Doc.context document in self#exit_focus; self#cleanup (Doc.cut_at document tip); logger Feedback.Notice (Richpp.richpp_of_string msg); self#mark_as_needed sentence; if Queue.is_empty queue then loop tip [] else loop tip (List.rev topstack) | Fail (id, loc, msg) -> let sentence = Doc.pop document in self#process_interp_error queue sentence loc msg tip id in Coq.bind coq_query handle_answer in let tip = try Doc.tip document with Doc.Empty -> initial_state | Invalid_argument _ -> assert false in loop tip [] in Coq.bind fill_queue process_queue method join_document = let next = function | Good _ -> messages#clear; messages#push Feedback.Info (Richpp.richpp_of_string "All proof terms checked by the kernel"); Coq.return () | Fail x -> self#handle_failure x in Coq.bind (Coq.status ~logger:messages#push true) next method stop_worker n = Coq.bind (Coq.stop_worker n) (fun _ -> Coq.return ()) method get_slaves_status = processed, to_process, slaves_status method get_n_errors = Doc.fold_all document 0 (fun n _ _ s -> if has_flag s `ERROR then n+1 else n) method get_errors = let extract_error s = match List.find (function `ERROR _ -> true | _ -> false) s.flags with | `ERROR (loc, msg) -> let iter = if Loc.is_ghost loc then buffer#get_iter_at_mark s.start else let (iter, _, phrase) = self#get_sentence s in let (start, _) = Loc.unloc loc in iter#forward_chars (b2c phrase start) in iter#line + 1, msg | _ -> assert false in List.rev (Doc.fold_all document [] (fun acc _ _ s -> if has_flag s `ERROR then extract_error s :: acc else acc)) method process_next_phrase = let until n _ _ = n >= 1 in self#process_until ~move_insert:true until true method private process_until_iter iter = let until _ start stop = if Preferences.stop_before#get then stop#compare iter > 0 else start#compare iter >= 0 in self#process_until until false method process_until_end_or_error = self#process_until_iter self#get_end_of_input (* finds the state_id and if it an unfocus is needed to reach it *) method private find_id until = try Doc.find_id document (fun id { start;stop } -> until (Some id) start stop) with Not_found -> initial_state, Doc.focused document method private cleanup seg = if seg <> [] then begin let start = buffer#get_iter_at_mark (CList.last seg).start in let stop = buffer#get_iter_at_mark (CList.hd seg).stop in Minilib.log (Printf.sprintf "Cleanup in range %d -> %d" start#offset stop#offset); buffer#remove_tag Tags.Script.processed ~start ~stop; buffer#remove_tag Tags.Script.incomplete ~start ~stop; buffer#remove_tag Tags.Script.unjustified ~start ~stop; buffer#remove_tag Tags.Script.tooltip ~start ~stop; buffer#remove_tag Tags.Script.to_process ~start ~stop; buffer#move_mark ~where:start (`NAME "start_of_input") end; List.iter (fun { start } -> buffer#delete_mark start) seg; List.iter (fun { stop } -> buffer#delete_mark stop) seg; self#print_stack (** Wrapper around the raw undo command *) method private backtrack_to_id ?(move_insert=true) (to_id, unfocus_needed) = Minilib.log("backtrack_to_id "^Stateid.to_string to_id^ " (unfocus_needed="^string_of_bool unfocus_needed^")"); let opening () = push_info "Coq is undoing" in let conclusion () = pop_info (); if move_insert then begin buffer#place_cursor ~where:self#get_start_of_input; script#recenter_insert; end; let start = self#get_start_of_input in let stop = self#get_end_of_input in Minilib.log(Printf.sprintf "cleanup tags %d %d" start#offset stop#offset); buffer#remove_tag Tags.Script.tooltip ~start ~stop; buffer#remove_tag Tags.Script.processed ~start ~stop; buffer#remove_tag Tags.Script.incomplete ~start ~stop; buffer#remove_tag Tags.Script.to_process ~start ~stop; buffer#remove_tag Tags.Script.unjustified ~start ~stop; self#show_goals in Coq.bind (Coq.lift opening) (fun () -> let rec undo to_id unfocus_needed = Coq.bind (Coq.edit_at to_id) (function | Good (CSig.Inl (* NewTip *) ()) -> if unfocus_needed then self#exit_focus; self#cleanup (Doc.cut_at document to_id); conclusion () | Good (CSig.Inr (* Focus *) (stop_id,(start_id,tip))) -> if unfocus_needed then self#exit_focus; self#cleanup (Doc.cut_at document tip); self#enter_focus start_id stop_id; self#cleanup (Doc.cut_at document to_id); conclusion () | Fail (safe_id, loc, msg) -> (* if loc <> None then messages#push Feedback.Error (Richpp.richpp_of_string "Fixme LOC"); *) messages#push Feedback.Error msg; if Stateid.equal safe_id Stateid.dummy then self#show_goals else undo safe_id (Doc.focused document && Doc.is_in_focus document safe_id)) in undo to_id unfocus_needed) method private backtrack_until ?move_insert until = self#backtrack_to_id ?move_insert (self#find_id until) method private backtrack_to_iter ?move_insert iter = let until _ _ stop = iter#compare (buffer#get_iter_at_mark stop) >= 0 in self#backtrack_until ?move_insert until method private handle_failure_aux ?(move_insert=false) (safe_id, (loc : (int * int) option), msg) = messages#push Feedback.Error msg; ignore(self#process_feedback ()); if Stateid.equal safe_id Stateid.dummy then Coq.lift (fun () -> ()) else Coq.seq (self#backtrack_until ~move_insert (fun id _ _ -> id = Some safe_id)) (Coq.lift (fun () -> script#recenter_insert)) method handle_failure f = self#handle_failure_aux f method backtrack_last_phrase = messages#clear; try let tgt = Doc.before_tip document in self#backtrack_to_id tgt with Not_found -> Coq.return (Coq.reset_coqtop _ct) method go_to_insert = Coq.bind (Coq.return ()) (fun () -> messages#clear; let point = self#get_insert in if point#compare self#get_start_of_input >= 0 then self#process_until_iter point else self#backtrack_to_iter ~move_insert:false point) method go_to_mark m = Coq.bind (Coq.return ()) (fun () -> messages#clear; let point = buffer#get_iter_at_mark m in if point#compare self#get_start_of_input >= 0 then Coq.seq (self#process_until_iter point) (Coq.lift (fun () -> Sentence.tag_on_insert buffer)) else Coq.seq (self#backtrack_to_iter ~move_insert:false point) (Coq.lift (fun () -> Sentence.tag_on_insert buffer))) method tactic_wizard l = let insert_phrase phrase tag = let stop = self#get_start_of_input in let phrase' = if stop#starts_line then phrase else "\n"^phrase in buffer#insert ~iter:stop phrase'; Sentence.tag_on_insert buffer; let start = self#get_start_of_input in buffer#move_mark ~where:stop (`NAME "start_of_input"); buffer#apply_tag tag ~start ~stop; if self#get_insert#compare stop <= 0 then buffer#place_cursor ~where:stop; let sentence = mk_sentence ~start:(`MARK (buffer#create_mark start)) ~stop:(`MARK (buffer#create_mark stop)) [] in Doc.push document sentence; messages#clear; self#show_goals in let display_error (loc, s) = if not (validate s) then flash_info "This error is so nasty that I can't even display it." else messages#add s in let try_phrase phrase stop more = let action = log "Sending to coq now" in let query = Coq.query (phrase,Stateid.dummy) in let next = function | Fail (_, l, str) -> (* FIXME: check *) display_error (l, str); messages#add (Richpp.richpp_of_string ("Unsuccessfully tried: "^phrase)); more | Good msg -> messages#add_string msg; stop Tags.Script.processed in Coq.bind (Coq.seq action query) next in let rec loop l = match l with | [] -> Coq.return () | p :: l' -> try_phrase ("progress "^p^".") (insert_phrase (p^".")) (loop l') in loop l method handle_reset_initial = let action () = (* clear the stack *) if Doc.focused document then Doc.unfocus document; while not (Doc.is_empty document) do let phrase = Doc.pop document in buffer#delete_mark phrase.start; buffer#delete_mark phrase.stop done; List.iter (buffer#remove_tag ~start:buffer#start_iter ~stop:buffer#end_iter) Tags.Script.all; (* reset the buffer *) buffer#move_mark ~where:buffer#start_iter (`NAME "start_of_input"); buffer#move_mark ~where:buffer#end_iter (`NAME "stop_of_input"); Sentence.tag_all buffer; (* clear the views *) messages#clear; proof#clear (); clear_info (); processed <- 0; to_process <- 0; push_info "Restarted"; (* apply the initial commands to coq *) in Coq.seq (Coq.lift action) self#initialize method initialize = let get_initial_state = let next = function | Fail (_, _, message) -> let message = "Couldn't initialize coqtop\n\n" ^ (Richpp.raw_print message) in let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok ~message_type:`ERROR ~message () in ignore (popup#run ()); exit 1 | Good id -> initial_state <- id; Coq.return () in Coq.bind (Coq.init (get_filename ())) next in Coq.seq get_initial_state Coq.PrintOpt.enforce end coq-8.6/ide/wg_Command.ml0000644000175000017500000001456713022274260014642 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* notebook#misc#set_size_request ~height:200 ()) in let _ = frame#connect#detached ~callback:(fun _ -> notebook#misc#set_size_request ~width:600 ~height:500 (); notebook#misc#grab_focus ()) in object(self) val frame = frame val notebook = notebook method pack_in (f : GObj.widget -> unit) = f frame#coerce val mutable new_page : GObj.widget = (GMisc.label ())#coerce val mutable views = [] method private new_page_maker = let page = notebook#append_page (GMisc.label ~text:"No query" ())#coerce in let page = notebook#get_nth_page page in let b = GButton.button () in b#add (Ideutils.stock_to_widget ~size:(`CUSTOM(12,12)) `NEW); ignore(b#connect#clicked ~callback:self#new_query); notebook#set_page ~tab_label:b#coerce page; new_page <- page method new_query ?command ?term () = self#new_query_aux ?command ?term () method private new_query_aux ?command ?term ?(grab_now=true) () = let frame = GBin.frame ~shadow_type:`NONE () in ignore(notebook#insert_page ~pos:(notebook#page_num new_page) frame#coerce); let new_tab_lbl text = let hbox = GPack.hbox ~homogeneous:false () in ignore(GMisc.label ~width:100 ~ellipsize:`END ~text ~packing:hbox#pack()); let b = GButton.button ~packing:hbox#pack () in ignore(b#connect#clicked ~callback:(fun () -> views <- List.filter (fun (f,_,_) -> f#get_oid <> frame#coerce#get_oid) views; notebook#remove_page (notebook#page_num frame#coerce))); b#add (Ideutils.stock_to_widget ~size:(`CUSTOM(12,10)) `CLOSE); hbox#coerce in notebook#set_page ~tab_label:(new_tab_lbl "New query") frame#coerce; notebook#goto_page (notebook#page_num frame#coerce); let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in let combo, entry, ok_b = let bar = GButton.toolbar ~style:`ICONS ~packing:(vbox#pack ~expand:false) () in let bar_add ~expand w = let item = GButton.tool_item ~expand () in item#add w#coerce; bar#insert item in let combo, _ = GEdit.combo_box_entry_text ~strings:Coq_commands.state_preserving () in combo#entry#set_text "Search"; let entry = GEdit.entry () in entry#misc#set_can_default true; let ok_b = GButton.button () in ok_b#add (Ideutils.stock_to_widget `OK); bar_add ~expand:false combo; bar_add ~expand:true entry; bar_add ~expand:false ok_b; combo, entry, ok_b in let r_bin = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(vbox#pack ~fill:true ~expand:true) () in let result = GText.view ~packing:r_bin#add () in views <- (frame#coerce, result, combo#entry) :: views; let cb clr = result#misc#modify_base [`NORMAL, `NAME clr] in let _ = background_color#connect#changed cb in let _ = result#misc#connect#realize (fun () -> cb background_color#get) in let cb ft = result#misc#modify_font (Pango.Font.from_string ft) in stick text_font result cb; result#misc#set_can_focus true; (* false causes problems for selection *) result#set_editable false; let callback () = let com = combo#entry#text in let arg = entry#text in if Str.string_match (Str.regexp "^ *$") (com^arg) 0 then () else let phrase = if Str.string_match (Str.regexp "\\. *$") com 0 then com else com ^ " " ^ arg ^" . " in let log level message = Ideutils.insert_xml result#buffer message; result#buffer#insert "\n"; in let process = Coq.bind (Coq.query ~logger:log (phrase,Stateid.dummy)) (function | Interface.Fail (_,l,str) -> Ideutils.insert_xml result#buffer str; notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce; Coq.return () | Interface.Good res -> result#buffer#insert res; notebook#set_page ~tab_label:(new_tab_lbl arg) frame#coerce; Coq.return ()) in result#buffer#set_text ("Result for command " ^ phrase ^ ":\n"); Coq.try_grab coqtop process ignore in ignore (combo#entry#connect#activate ~callback); ignore (ok_b#connect#clicked ~callback); begin match command with | None -> () | Some c -> combo#entry#set_text c end; begin match term with | None -> () | Some t -> entry#set_text t end; combo#entry#misc#grab_focus (); if grab_now then entry#misc#grab_default (); ignore (entry#connect#activate ~callback); ignore (combo#entry#connect#activate ~callback); ignore (combo#entry#event#connect#key_press ~callback:(fun ev -> if GdkEvent.Key.keyval ev = GdkKeysyms._Tab then (entry#misc#grab_focus ();true) else false)) method show = frame#show; let cur_page = notebook#get_nth_page notebook#current_page in let _, _, e = List.find (fun (p,_,_) -> p#get_oid == cur_page#get_oid) views in e#misc#grab_focus () method hide = frame#hide method visible = frame#visible method private refresh_color clr = let clr = Tags.color_of_string clr in let iter (_,view,_) = view#misc#modify_base [`NORMAL, `COLOR clr] in List.iter iter views initializer self#new_page_maker; self#new_query_aux ~grab_now:false (); frame#misc#hide (); let _ = background_color#connect#changed self#refresh_color in self#refresh_color background_color#get; ignore(notebook#event#connect#key_press ~callback:(fun ev -> if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then (self#hide; true) else false )); end coq-8.6/ide/nanoPG.ml0000644000175000017500000003126313022274260013741 0ustar mdenesmdenes(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ag#name = name) gui.action_groups let ct gui = gui.notebook#current_term let get_sel b = b#selection_bounds let sel_nonempty b = let i, j = get_sel b in not (i#equal j) let get_sel_txt b = let i, j = get_sel b in i#get_text ~stop:j type status = { move : int option; kill : (string * bool) option; sel: bool } let pr_status { move; kill; sel } = let move = Option.cata (fun i -> string_of_int i) "" move in let kill = Option.cata (fun (s,b) -> sprintf "kill(%b) %S" b s) "" kill in let sel = string_of_bool sel in Printf.sprintf "{ move: %s; kill: %s; sel: %s }" move kill sel let pr_key t = let kv = GdkEvent.Key.keyval t in let str = GdkEvent.Key.string t in let str_of_mod = function | `SHIFT -> "SHIFT" | `LOCK -> "LOCK" | `CONTROL -> "CONTROL" | `MOD1 -> "MOD1" | `MOD2 -> "MOD2" | `MOD3 -> "MOD3" | `MOD4 -> "MOD4" | `MOD5 -> "MOD5" | `BUTTON1 -> "BUTTON1" | `BUTTON2 -> "BUTTON2" | `BUTTON3 -> "BUTTON3" | `BUTTON4 -> "BUTTON4" | `BUTTON5 -> "BUTTON5" | `SUPER -> "SUPER" | `HYPER -> "HYPER" | `META -> "META" | `RELEASE -> "RELEASE" in let mods = String.concat " " (List.map str_of_mod (GdkEvent.Key.state t)) in Printf.sprintf "'%s' (%d, %s)" str kv mods type action = | Action of string * string | Callback of (gui -> unit) | Edit of (status -> GSourceView2.source_buffer -> GText.iter -> (string -> string -> unit) -> status) | Motion of (status -> GText.iter -> GText.iter * status) type 'c entry = { mods : Gdk.Tags.modifier list; key : Gdk.keysym; keyname : string; doc : string; contents : 'c } let mC = [`CONTROL] let mM = [`MOD1] let mod_of t x = List.for_all (fun m -> List.mem m (GdkEvent.Key.state t)) x let pr_keymod l = if l = mC then "C-" else if l = mM then "M-" else "" let mkE ?(mods=mC) key keyname doc ?(alias=[]) contents = List.map (fun (mods, key, keyname) -> { mods; key; keyname; doc; contents }) ((mods, key, keyname)::alias) type keypaths = Step of action entry list * keypaths entry list let print_keypaths kps = let rec aux prefix (Step (l, konts)) = String.concat "\n" ( (List.map (fun x -> prefix ^ pr_keymod x.mods ^ x.keyname ^ " " ^ x.doc ) l) @ (List.map (fun x -> aux (prefix^pr_keymod x.mods^x.keyname^" ") x.contents) konts)) in aux " " kps let empty = Step([],[]) let frontier (Step(l1,l2)) = List.map (fun x -> pr_keymod x.mods ^ x.keyname) l1 @ List.map (fun x -> pr_keymod x.mods ^ x.keyname) l2 let insert kps name enter_syms bindings = let rec aux kps enter_syms = match enter_syms, kps with | [], Step (el, konts) -> Step (List.flatten bindings @ el, konts) | (mods, key, keyname)::gs, Step (el, konts) -> if List.exists (fun { key = k; mods = m } -> key = k && mods = m) konts then let konts = List.map (fun ({ key = k; contents } as x) -> if key <> k then x else { x with contents = aux contents gs }) konts in Step(el,konts) else let kont = { mods; key; keyname; doc = name; contents = aux empty gs } in Step(el, kont::konts) in aux kps enter_syms let run_action gui group name = ((actiong gui group)#get_action name)#activate () let run key gui action status = match action with | Callback f -> f gui; status | Action(group, name) -> run_action gui group name; status | Edit f -> let b = (ct gui).script#source_buffer in let i = b#get_iter_at_mark `INSERT in let status = f status b i (run_action gui) in if not status.sel then b#place_cursor ~where:(b#get_iter_at_mark `SEL_BOUND); status | Motion f -> let b, script = (ct gui).script#source_buffer, (ct gui).script in let sel_mode = status.sel || List.mem `SHIFT (GdkEvent.Key.state key) in let i = if sel_mode then b#get_iter_at_mark `SEL_BOUND else b#get_iter_at_mark `INSERT in let where, status = f status i in let sel_mode = status.sel || List.mem `SHIFT (GdkEvent.Key.state key) in if sel_mode then (b#move_mark `SEL_BOUND ~where; script#scroll_mark_onscreen `SEL_BOUND) else (b#place_cursor ~where; script#scroll_mark_onscreen `INSERT); status let emacs = empty let emacs = insert emacs "Emacs" [] [ (* motion *) mkE _e "e" "Move to end of line" (Motion(fun s i -> (if not i#ends_line then i#forward_to_line_end else i), { s with move = None })); mkE _a "a" "Move to beginning of line" (Motion(fun s i -> (i#set_line_offset 0), { s with move = None })); mkE ~mods:mM _e "e" "Move to end of sentence" (Motion(fun s i -> i#forward_sentence_end, { s with move = None })); mkE ~mods:mM _a "a" "Move to beginning of sentence" (Motion(fun s i -> i#backward_sentence_start, { s with move = None })); mkE _n "n" "Move to next line" ~alias:[[],_Down,"DOWN"] (Motion(fun s i -> let orig_off = Option.default i#line_offset s.move in let i = i#forward_line in let new_off = min (i#chars_in_line - 1) orig_off in (if new_off > 0 then i#set_line_offset new_off else i), { s with move = Some orig_off })); mkE _p "p" "Move to previous line" ~alias:[[],_Up,"UP"] (Motion(fun s i -> let orig_off = Option.default i#line_offset s.move in let i = i#backward_line in let new_off = min (i#chars_in_line - 1) orig_off in (if new_off > 0 then i#set_line_offset new_off else i), { s with move = Some orig_off })); mkE _f "f" "Forward char" ~alias:[[],_Right,"RIGHT"] (Motion(fun s i -> i#forward_char, { s with move = None })); mkE _b "b" "Backward char" ~alias:[[],_Left,"LEFT"] (Motion(fun s i -> i#backward_char, { s with move = None })); mkE ~mods:mM _f "f" "Forward word" ~alias:[mC,_Right,"RIGHT"] (Motion(fun s i -> i#forward_word_end, { s with move = None })); mkE ~mods:mM _b "b" "Backward word" ~alias:[mC,_Left,"LEFT"] (Motion(fun s i -> i#backward_word_start, { s with move = None })); mkE _space "SPC" "Set mark" ~alias:[mC,_at,"@"] (Motion(fun s i -> if s.sel = false then i, { s with sel = true } else i, { s with sel = false } )); (* edits *) mkE ~mods:mM _w "w" "Copy selected region" (Edit(fun s b i run -> if sel_nonempty b then let txt = get_sel_txt b in run "Edit" "Copy"; { s with kill = Some(txt,false); sel = false } else s)); mkE _w "w" "Kill selected region" (Edit(fun s b i run -> if sel_nonempty b then let txt = get_sel_txt b in run "Edit" "Cut"; { s with kill = Some(txt,false); sel = false } else s)); mkE _k "k" "Kill untill the end of line" (Edit(fun s b i _ -> let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in let k = if i#ends_line then begin b#delete ~start:i ~stop:i#forward_char; "\n" end else begin let k = b#get_text ~start:i ~stop:i#forward_to_line_end () in b#delete ~start:i ~stop:i#forward_to_line_end; k end in { s with kill = Some (already_killed ^ k,true) })); mkE ~mods:mM _d "d" "Kill next word" (Edit(fun s b i _ -> let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in let k = let k = b#get_text ~start:i ~stop:i#forward_word_end () in b#delete ~start:i ~stop:i#forward_word_end; k in { s with kill = Some (already_killed ^ k,true) })); mkE ~mods:mM _k "k" "Kill until sentence end" (Edit(fun s b i _ -> let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in let k = let k = b#get_text ~start:i ~stop:i#forward_sentence_end () in b#delete ~start:i ~stop:i#forward_sentence_end; k in { s with kill = Some (already_killed ^ k,true) })); mkE ~mods:mM _BackSpace "DELBACK" "Kill word before cursor" (Edit(fun s b i _ -> let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in let k = let k = b#get_text ~start:i ~stop:i#backward_word_start () in b#delete ~start:i ~stop:i#backward_word_start; k in { s with kill = Some (already_killed ^ k,true) })); mkE _d "d" "Delete next character" (Edit(fun s b i _ -> b#delete ~start:i ~stop:i#forward_char; s)); mkE _y "y" "Yank killed text back " (Edit(fun s b i _ -> let k, s = match s.kill with | Some (k,_) -> k, { s with kill = Some (k,false) } | _ -> "", s in b#insert ~iter:i k; s)); (* misc *) mkE _underscore "_" "Undo" (Action("Edit", "Undo")); mkE _g "g" "Esc" (Callback(fun gui -> (ct gui).finder#hide ())); mkE _s "s" "Search" (Callback(fun gui -> if (ct gui).finder#coerce#misc#visible then run_action gui "Edit" "Find Next" else run_action gui "Edit" "Find")); mkE _s "r" "Search backward" (Callback(fun gui -> if (ct gui).finder#coerce#misc#visible then run_action gui "Edit" "Find Previous" else run_action gui "Edit" "Find")); ] let emacs = insert emacs "Emacs" [mC,_x,"x"] [ mkE _s "s" "Save" (Action("File", "Save")); mkE _c "c" "Quit" (Action("File", "Quit")); mkE _f "f" "Open" (Action("File", "Open")); mkE ~mods:[] _u "u" "Undo" (Action("Edit", "Undo")); ] let pg = insert emacs "Proof General" [mC,_c,"c"] [ mkE _Return "RET" "Go to" (Action("Navigation", "Go to")); mkE _n "n" "Advance 1 sentence" (Action("Navigation", "Forward")); mkE _u "u" "Retract 1 sentence" (Action("Navigation", "Backward")); mkE _b "b" "Advance" (Action("Navigation", "End")); mkE _r "r" "Restart" (Action("Navigation", "Start")); mkE _c "c" "Stop" (Action("Navigation", "Interrupt")); ] let command gui c = let command = (ct gui).command in let script = (ct gui).script in let term = let i, j = script#source_buffer#selection_bounds in if i#equal j then None else Some (script#buffer#get_text ~start:i ~stop:j ()) in command#show; command#new_query ~command:c ?term () let pg = insert pg "Proof General" [mC,_c,"c"; mC,_a,"a"] [ mkE _p "p" "Print" (Callback (fun gui -> command gui "Print")); mkE _c "c" "Check" (Callback (fun gui -> command gui "Check")); mkE _b "b" "About" (Callback (fun gui -> command gui "About")); mkE _a "a" "Search About" (Callback (fun gui -> command gui "SearchAbout")); mkE _o "o" "Search Pattern" (Callback (fun gui->command gui "SearchPattern")); mkE _l "l" "Locate" (Callback (fun gui -> command gui "Locate")); mkE _Return "RET" "match template" (Action("Templates","match")); ] let empty = { sel = false; kill = None; move = None } let find gui (Step(here,konts)) t = (* hack: ^c does copy in clipboard *) let sel_nonempty () = sel_nonempty (ct gui).script#source_buffer in let k = GdkEvent.Key.keyval t in if k = _x && mod_of t mC && sel_nonempty () then ignore(run t gui (Action("Edit","Cut")) empty) else if k = _c && mod_of t mC && sel_nonempty () then ignore(run t gui (Action("Edit","Copy")) empty); let cmp { key; mods } = key = k && mod_of t mods in try `Do (List.find cmp here) with Not_found -> try `Cont (List.find cmp konts).contents with Not_found -> `NotFound let init w nb ags = let gui = { notebook = nb; action_groups = ags } in let cur = ref pg in let status = ref empty in let reset () = eprintf "reset\n%!"; cur := pg in ignore(w#event#connect#key_press ~callback:(fun t -> let on_current_term f = let term = try Some nb#current_term with Invalid_argument _ -> None in match term with None -> false | Some t -> f t in on_current_term (fun x -> if x.script#misc#get_property "has-focus" <> `BOOL true then false else begin eprintf "got key %s\n%!" (pr_key t); if nanoPG#get then begin match find gui !cur t with | `Do e -> eprintf "run (%s) %s on %s\n%!" e.keyname e.doc (pr_status !status); status := run t gui e.contents !status; reset (); true | `Cont c -> flash_info ("Waiting one of " ^ String.concat " " (frontier c)); cur := c; true | `NotFound -> reset (); false end else false end))); ignore(w#event#connect#button_press ~callback:(fun t -> reset (); false)) let get_documentation () = print_keypaths pg coq-8.6/ide/coq_style.xml0000644000175000017500000000264113022274260014747 0ustar mdenesmdenes The Coq Dev Team <_description>Coq/Ssreflect color scheme for the vernacular language