aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorGravatar Maxime Dénès <mail@maximedenes.fr>2017-04-15 12:15:13 +0200
committerGravatar Maxime Dénès <mail@maximedenes.fr>2017-04-15 12:15:13 +0200
commit0147ae6ba6db24d4f9b29ff477d374a6abb103dd (patch)
treeb07f2d41760b7c138fc7b7b6a652320e5169e4f3
parented09fccb6405fb832cab867919cc4b0be32dea36 (diff)
parent727ef1bd345f9ad9e08d9e4f136e2db7d034a93d (diff)
Merge branch 'v8.6' into trunk
-rwxr-xr-xdev/ci/ci-fiat-crypto.sh2
-rw-r--r--dev/doc/xml-protocol.md745
-rw-r--r--interp/topconstr.ml4
-rw-r--r--kernel/nativecode.ml5
-rw-r--r--plugins/ltac/tactic_debug.ml8
-rw-r--r--pretyping/cases.ml17
-rw-r--r--stm/stm.ml21
-rw-r--r--stm/vernac_classifier.ml4
-rw-r--r--test-suite/bugs/closed/5435.v2
-rw-r--r--test-suite/bugs/closed/5460.v11
-rw-r--r--test-suite/bugs/closed/5469.v3
-rw-r--r--test-suite/bugs/closed/5470.v3
-rw-r--r--test-suite/success/Notations.v7
-rw-r--r--test-suite/success/all-check.v3
-rw-r--r--theories/Init/Logic.v6
-rw-r--r--vernac/command.ml3
-rw-r--r--vernac/metasyntax.ml40
-rw-r--r--vernac/vernacentries.ml2
18 files changed, 850 insertions, 36 deletions
diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh
index 93d39aab0..c6df45a1d 100755
--- a/dev/ci/ci-fiat-crypto.sh
+++ b/dev/ci/ci-fiat-crypto.sh
@@ -7,4 +7,4 @@ fiat_crypto_CI_DIR=${CI_BUILD_DIR}/fiat-crypto
git_checkout ${fiat_crypto_CI_BRANCH} ${fiat_crypto_CI_GITURL} ${fiat_crypto_CI_DIR}
-( cd ${fiat_crypto_CI_DIR} && make -j ${NJOBS} )
+( cd ${fiat_crypto_CI_DIR} && make -j ${NJOBS} lite )
diff --git a/dev/doc/xml-protocol.md b/dev/doc/xml-protocol.md
new file mode 100644
index 000000000..2ff82c688
--- /dev/null
+++ b/dev/doc/xml-protocol.md
@@ -0,0 +1,745 @@
+#Coq XML Protocol for Coq 8.6#
+
+This document is based on documentation originally written by CJ Bell
+for his [vscoq](https://github.com/siegebell/vscoq/) project.
+
+Here, the aim is to provide a "hands on" description of the XML
+protocol that coqtop and IDEs use to communicate. The protocol first appeared
+with Coq 8.5, and is used by CoqIDE. It will also be used in upcoming
+versions of Proof General.
+
+A somewhat out-of-date description of the async state machine is
+[documented here](https://github.com/ejgallego/jscoq/blob/master/etc/notes/coq-notes.md).
+OCaml types for the protocol can be found in the [`ide/interface.mli` file](/ide/interface.mli).
+
+# CHANGES
+## Changes from 8.5:
+ * In several places, flat text wrapped in <string> tags now appears as structured text inside <richpp> tags
+ * The "errormsg" feedback has been replaced by a "message" feedback which contains
+ <feedback\_content> tag, with a message_level attribute of "error"
+
+* [Commands](#commands)
+ - [About](#command-about)
+ - [Add](#command-add)
+ - [EditAt](#command-editAt)
+ - [Init](#command-init)
+ - [Goal](#command-goal)
+ - [Status](#command-status)
+ - [Query](#command-query)
+ - [Evars](#command-evars)
+ - [Hints](#command-hints)
+ - [Search](#command-search)
+ - [GetOptions](#command-getoptions)
+ - [SetOptions](#command-setoptions)
+ - [MkCases](#command-mkcases)
+ - [StopWorker](#command-stopworker)
+ - [PrintAst](#command-printast)
+ - [Annotate](#command-annotate)
+* [Feedback messages](#feedback)
+ - [Added Axiom](#feedback-addedaxiom)
+ - [Processing](#feedback-processing)
+ - [Processed](#feedback-processed)
+ - [Incomplete](#feedback-incomplete)
+ - [Complete](#feedback-complete)
+ - [GlobRef](#feedback-globref)
+ - [Error](#feedback-error)
+ - [InProgress](#feedback-inprogress)
+ - [WorkerStatus](#feedback-workerstatus)
+ - [File Dependencies](#feedback-filedependencies)
+ - [File Loaded](#feedback-fileloaded)
+ - [Message](#feedback-message)
+ - [Custom](#feedback-custom)
+
+Sentences: each command sent to Coqtop is a "sentence"; they are typically terminated by ".\s" (followed by whitespace or EOF).
+Examples: "Lemma a: True.", "(* asdf *) Qed.", "auto; reflexivity."
+In practice, the command sentences sent to Coqtop are terminated at the "." and start with any previous whitespace.
+Each sentence is assigned a unique stateId after being sent to Coq (via Add).
+States:
+ * Processing: has been received by Coq and has no obvious syntax error (that would prevent future parsing)
+ * Processed:
+ * InProgress:
+ * Incomplete: the validity of the sentence cannot be checked due to a prior error
+ * Complete:
+ * Error: the sentence has an error
+
+State ID 0 is reserved as a 'dummy' state.
+
+--------------------------
+
+## <a name="commands">Commands</a>
+
+### <a name="command-about">**About(unit)**</a>
+Returns information about the protocol and build dates for Coqtop.
+```
+<call val="About">
+ <unit/>
+</call>
+```
+#### *Returns*
+```html
+ <value val="good">
+ <coq_info><string>8.6</string>
+ <string>20150913</string>
+ <string>December 2016</string>
+ <string>Dec 23 2016 16:16:30</string>
+ </coq_info>
+</value>
+```
+The string fields are the Coq version, the protocol version, the release date, and the compile time of Coqtop.
+The protocol version is a date in YYYYMMDD format, where "20150913" corresponds to Coq 8.6. An IDE that wishes
+to support multiple Coq versions can use the protocol version information to know how to handle output from Coqtop.
+
+### <a name="command-add">**Add(stateId: integer, command: string, verbose: boolean)**</a>
+Adds a toplevel command (e.g. vernacular, definition, tactic) to the given state.
+`verbose` controls whether out-of-band messages will be generated for the added command (e.g. "foo is assumed" in response to adding "Axiom foo: nat.").
+```html
+<call val="Add">
+ <pair>
+ <pair>
+ <string>${command}</string>
+ <int>${editId}</int>
+ </pair>
+ <pair>
+ <state_id val="${stateId}"/>
+ <bool val="${verbose}"/>
+ </pair>
+ </pair>
+</call>
+```
+
+#### *Returns*
+* The added command is given a fresh `stateId` and becomes the next "tip".
+```html
+<value val="good">
+ <pair>
+ <state_id val="${newStateId}"/>
+ <pair>
+ <union val="in_l"><unit/></union>
+ <string>${message}</string>
+ </pair>
+ </pair>
+</value>
+```
+* When closing a focused proof (in the middle of a bunch of interpreted commands),
+the `Qed` will be assigned a prior `stateId` and `nextStateId` will be the id of an already-interpreted
+state that should become the next tip.
+```html
+<value val="good">
+ <pair>
+ <state_id val="${stateId}"/>
+ <pair>
+ <union val="in_r"><state_id val="${nextStateId}"/></union>
+ <string>${message}</string>
+ </pair>
+ </pair>
+</value>
+```
+* Failure:
+ - Syntax error. Error offsets are byte offsets (not character offsets) with respect to the start of the sentence, starting at 0.
+ ```html
+ <value val="fail"
+ loc_s="${startOffsetOfError}"
+ loc_e="${endOffsetOfError}">
+ <state_id val="${stateId}"/>
+ <richpp>${errorMessage}</richpp>
+ </value>
+ ```
+ - Another kind of error, for example, Qed with a pending goal.
+ ```html
+ <value val="fail"><state_id val="${stateId}"/><richpp>${errorMessage}</richpp></value>
+ ```
+
+-------------------------------
+
+### <a name="command-editAt">**EditAt(stateId: integer)**</a>
+Moves current tip to `${stateId}`, such that commands may be added to the new state ID.
+```html
+<call val="Edit_at"><state_id val="${stateId}"/></call>
+```
+#### *Returns*
+* Simple backtrack; focused stateId becomes the parent state
+```html
+<value val="good">
+ <union val="in_l"><unit/></union>
+</value>
+```
+
+* New focus; focusedQedStateId is the closing Qed of the new focus; senteneces between the two should be cleared
+```html
+<value val="good">
+ <union val="in_r">
+ <pair>
+ <state_id val="${focusedStateId}"/>
+ <pair>
+ <state_id val="${focusedQedStateId}"/>
+ <state_id val="${oldFocusedStateId}"/>
+ </pair>
+ </pair>
+ </union>
+</value>
+```
+* Failure: If `stateId` is in an error-state and cannot be jumped to, `errorFreeStateId` is the parent state of ``stateId` that shopuld be edited instead.
+```html
+<value val="fail" loc_s="${startOffsetOfError}" loc_e="${endOffsetOfError}">
+ <state_id val="${errorFreeStateId}"/>
+ ${errorMessage}
+</value>
+```
+
+-------------------------------
+
+### <a name="command-init">**Init()**</a>
+* No options.
+```html
+<call val="Init"><option val="none"/></call>
+```
+* With options. Looking at
+ [ide_slave.ml](https://github.com/coq/coq/blob/c5d0aa889fa80404f6c291000938e443d6200e5b/ide/ide_slave.ml#L355),
+ it seems that `options` is just the name of a script file, whose path
+ is added via `Add LoadPath` to the initial state.
+```html
+<call val="Init">
+ <option val="some">
+ <string>${options}</string>
+ </option>
+</call>
+```
+Providing the script file enables Coq to use .aux files created during
+compilation. Those file contain timing information that allow Coq to
+choose smartly between asynchronous and synchronous processing of
+proofs.
+
+#### *Returns*
+* The initial stateId (not associated with a sentence)
+```html
+<value val="good">
+ <state_id val="${initialStateId}"/>
+</value>
+```
+
+-------------------------------
+
+
+### <a name="command-goal">**Goal()**</a>
+```html
+<call val="Goal"><unit/></call>
+```
+#### *Returns*
+* If there is a goal. `shelvedGoals` and `abandonedGoals` have the same structure as the first set of (current/foreground) goals. `backgroundGoals` contains a list of pairs of lists of goals (list ((list Goal)*(list Goal))); it represents a "focus stack" ([see code for reference](https://github.com/coq/coq/blob/trunk/engine/proofview.ml#L113)). Each time a proof is focused, it will add a new pair of lists-of-goals. The first pair is the most nested set of background goals, the last pair is the top level set of background goals. The first list in the pair is in reverse order. Each time you focus the goal (e.g. using `Focus` or a bullet), a new pair will be prefixed to the list.
+```html
+<value val="good">
+ <option val="some">
+ <goals>
+ <!-- current goals -->
+ <list>
+ <goal>
+ <string>3</string>
+ <list>
+ <richpp>${hyp1}</richpp>
+ ...
+ <richpp>${hypN}</richpp>
+ </list>
+ <richpp>${goal}</richpp>
+ </goal>
+ ...
+ ${goalN}
+ </list>
+ <!-- `backgroundGoals` -->
+ <list>
+ <pair>
+ <list><goal />...</list>
+ <list><goal />...</list>
+ </pair>
+ ...
+ </list>
+ ${shelvedGoals}
+ ${abandonedGoals}
+ </goals>
+ </option>
+</value>
+```
+
+For example, this script:
+```coq
+Goal P -> (1=1/\2=2) /\ (3=3 /\ (4=4 /\ 5=5) /\ 6=6) /\ 7=7.
+intros.
+split; split. (* current visible goals are [1=1, 2=2, 3=3/\(4=4/\5=5)/\6=6, 7=7] *)
+Focus 3. (* focus on 3=3/\(4=4/\5=5)/\6=6; bg-before: [1=1, 2=2], bg-after: [7=7] *)
+split; [ | split ]. (* current visible goals are [3=3, 4=4/\5=5, 6=6] *)
+Focus 2. (* focus on 4=4/\5=5; bg-before: [3=3], bg-after: [6=6] *)
+* (* focus again on 4=4/\5=5; bg-before: [], bg-after: [] *)
+split. (* current visible goals are [4=4,5=5] *)
+```
+should generate the following goals structure:
+```
+goals: [ P|-4=4, P|-5=5 ]
+background:
+[
+ ( [], [] ), (* bullet with one goal has no before or after background goals *)
+ ( [ P|-3=3 ], [ P|-6=6 ] ), (* Focus 2 *)
+ ( [ P|-2=2, P|-1=1 ], [ P|-7=7 ] ) (* Focus 3; notice that 1=1 and 2=2 are reversed *)
+]
+```
+Pseudocode for listing all of the goals in order: `rev (flat_map fst background) ++ goals ++ flat_map snd background`.
+
+* No goal:
+```html
+<value val="good"><option val="none"/></value>
+```
+
+-------------------------------
+
+
+### <a name="command-status">**Status(force: bool)**</a>
+CoqIDE typically sets `force` to `false`.
+```html
+<call val="Status"><bool val="${force}"/></call>
+```
+#### *Returns*
+*
+```html
+<status>
+ <string>${path}</string>
+ <string>${proofName}</string>
+ <string>${allProofs}</string>
+ <string>${proofNumber}</string>
+</status>
+```
+
+-------------------------------
+
+
+### <a name="command-query">**Query(query: string, stateId: integer)**</a>
+In practice, `stateId` is 0, but the effect is to perform the query on the currently-focused state.
+```html
+<call val="Query">
+ <pair>
+ <string>${query}</string>
+ <state_id val="${stateId}"/>
+ </pair>
+</call>
+```
+#### *Returns*
+*
+```html
+<value val="good">
+ <string>${message}</string>
+</value>
+```
+-------------------------------
+
+
+
+### <a name="command-evars">**Evars()**</a>
+```html
+<call val="Evars"><unit/></call>
+```
+#### *Returns*
+*
+```html
+<value val="good">
+ <option val="some">
+ <list>
+ <evar>${evar1}</evar>
+ ...
+ <evar>${evarN}</evar>
+ </list>
+ </option>
+</value>
+```
+
+-------------------------------
+
+
+### <a name="command-hints">**Hints()**</a>
+```html
+<call val="Hints"><unit/></call>
+```
+#### *Returns*
+*
+```html
+<value val="good">
+ <option val="some">
+ <pair>
+ <list/>
+ <list>
+ <pair>
+ <string>${hint1}</string>
+ <string>${hint2}</string>
+ </pair>
+ ...
+ <pair>
+ <string>${hintN-1}</string>
+ <string>${hintN}</string>
+ </pair>
+ </list>
+ </pair>
+ </option>
+</value>
+```
+
+-------------------------------
+
+
+### <a name="command-search">**Search([(constraintTypeN: string, constraintValueN: string, positiveConstraintN: boolean)])**</a>
+Searches for objects that satisfy a list of constraints. If `${positiveConstraint}` is `false`, then the constraint is inverted.
+```html
+<call val="Search">
+ <list>
+ <pair>
+ <search_cst val="${constraintType1}">
+ ${constraintValue1}
+ </search_cst>
+ <bool val="${positiveConstraint1}"/>
+ </pair>
+ ...
+ <!-- Example: -->
+ <pair>
+ <search_cst val="name_pattern">
+ <string>bool_rect</string>
+ </search_cst>
+ <bool val="true"/>
+ </pair>
+ </list>
+</call>
+```
+#### *Returns*
+*
+```html
+<value val="good">
+ <list>
+ <coq_object>
+ <list>
+ <string>${metaInfo}</string>
+ ...
+ </list>
+ <list>
+ <string>${name}</string>
+ </list>
+ <string>${definition}</string>
+ </coq_object>
+ ...
+ </list>
+</value>
+```
+##### Types of constraints:
+* Name pattern: `${constraintType} = "name_pattern"`; `${constraintValue}` is a regular expression string.
+* Type pattern: `${constraintType} = "type_pattern"`; `${constraintValue}` is a pattern (???: an open gallina term) string.
+* SubType pattern: `${constraintType} = "subtype_pattern"`; `${constraintValue}` is a pattern (???: an open gallina term) string.
+* In module: `${constraintType} = "in_module"`; `${constraintValue}` is a list of strings specifying the module/directory structure.
+* Include blacklist: `${constraintType} = "include_blacklist"`; `${constraintValue}` *is ommitted*.
+
+-------------------------------
+
+
+### <a name="command-getoptions">**GetOptions()**</a>
+```html
+<call val="GetOptions"><unit/></call>
+```
+#### *Returns*
+*
+```html
+<value val="good">
+ <list>
+ <pair>
+ <list><string>${string1}</string>...</list>
+ <option_state>
+ <bool>${sync}</bool>
+ <bool>${deprecated}</bool>
+ <string>${name}</string>
+ ${option_value}
+ </option_state>
+ </pair>
+ ...
+ </list>
+</value>
+```
+
+-------------------------------
+
+
+### <a name="command-setoptions">**SetOptions(options)**</a>
+Sends a list of option settings, where each setting roughly looks like:
+`([optionNamePart1, ..., optionNamePartN], value)`.
+```html
+<call val="SetOptions">
+ <list>
+ <pair>
+ <list>
+ <string>optionNamePart1</string>
+ ...
+ <string>optionNamePartN</string>
+ </list>
+ <option_value val="${typeOfOption}">
+ <option val="some">
+ ${value}
+ </option>
+ </option_value>
+ </pair>
+ ...
+ <!-- Example: -->
+ <pair>
+ <list>
+ <string>Printing</string>
+ <string>Width</string>
+ </list>
+ <option_value val="intvalue">
+ <option val="some"><int>60</int></option>
+ </option_value>
+ </pair>
+ </list>
+</call>
+```
+CoqIDE sends the following settings (defaults in parentheses):
+```
+Printing Width : (<option_value val="intvalue"><int>60</int></option_value>),
+Printing Coercions : (<option_value val="boolvalue"><bool val="false"/></option_value>),
+Printing Matching : (...true...)
+Printing Notations : (...true...)
+Printing Existential Instances : (...false...)
+Printing Implicit : (...false...)
+Printing All : (...false...)
+Printing Universes : (...false...)
+```
+#### *Returns*
+*
+```html
+<value val="good"><unit/></value>
+```
+
+-------------------------------
+
+
+### <a name="command-mkcases">**MkCases(...)**</a>
+```html
+<call val="MkCases"><string>...</string></call>
+```
+#### *Returns*
+*
+```html
+<value val="good">
+ <list>
+ <list><string>${string1}</string>...</list>
+ ...
+ </list>
+</value>
+```
+
+-------------------------------
+
+
+### <a name="command-stopworker">**StopWorker(worker: string)**</a>
+```html
+<call val="StopWorker"><string>${worker}</string></call>
+```
+#### *Returns*
+*
+```html
+<value val="good"><unit/></value>
+```
+
+-------------------------------
+
+
+### <a name="command-printast">**PrintAst(stateId: integer)**</a>
+```html
+<call val="PrintAst"><state_id val="${stateId}"/></call>
+```
+#### *Returns*
+*
+```html
+<value val="good">
+ <gallina begin="${gallina_begin}" end="${gallina_end}">
+ <theorem begin="${theorem_begin}" end="${theorem_end}" type="Theorem" name="${theorem_name}">
+ <apply begin="${apply_begin}" end="${apply_end}">
+ <operator begin="${operator_begin}" end="${operator_end}" name="${operator_name}"/>
+ <typed begin="${typed_begin}" end="${typed_end}">
+ <constant begin="${constant_begin}" end="${constant_end}" name="${constant_name}"/>
+ ...
+ <token begin="${token_begin}" end="token_end">${token}</token>
+ ...
+ </typed>
+ ...
+ </apply>
+ </theorem>
+ ...
+ </gallina>
+</value>
+```
+
+-------------------------------
+
+
+
+### <a name="command-annotate">**Annotate(annotation: string)**</a>
+```html
+<call val="Annotate"><string>${annotation}</string></call>
+```
+#### *Returns*
+*
+
+take `<call val="Annotate"><string>Theorem plus_0_r : forall n : nat, n + 0 = n.</string></call>` as an example.
+
+```html
+<value val="good">
+ <pp startpos="0" endpos="45">
+ <vernac_expr startpos="0" endpos="44">
+ <keyword startpos="0" endpos="7">Theorem</keyword>
+ &nbsp;plus_0_r&nbsp;:&nbsp;
+ <constr_expr startpos="19" endpos="44">
+ <keyword startpos="19" endpos="25">forall</keyword>
+ &nbsp;n&nbsp;:&nbsp;
+ <constr_expr startpos="30" endpos="33">nat</constr_expr>
+ ,&nbsp;
+ <unparsing startpos="35" endpos="44">
+ <unparsing startpos="35" endpos="40">
+ <unparsing startpos="35" endpos="40">
+ <unparsing startpos="35" endpos="36">
+ <constr_expr startpos="35" endpos="36">n</constr_expr>
+ </unparsing>
+ <unparsing startpos="36" endpos="38">&nbsp;+</unparsing>
+ <unparsing startpos="38" endpos="39">&nbsp;</unparsing>
+ <unparsing startpos="39" endpos="40">
+ <constr_expr startpos="39" endpos="40">0</constr_expr>
+ </unparsing>
+ </unparsing>
+ </unparsing>
+ <unparsing startpos="40" endpos="42">&nbsp;=</unparsing>
+ <unparsing startpos="42" endpos="43">&nbsp;</unparsing>
+ <unparsing startpos="43" endpos="44">
+ <constr_expr startpos="43" endpos="44">n</constr_expr>
+ </unparsing>
+ </unparsing>
+ </constr_expr>
+ </vernac_expr>
+ .
+ </pp>
+</value>
+```
+
+-------------------------------
+
+## <a name="feedback">Feedback messages</a>
+
+Feedback messages are issued out-of-band,
+ giving updates on the current state of sentences/stateIds,
+ worker-thread status, etc.
+
+In the descriptions of feedback syntax below, wherever a `state_id`
+tag may occur, there may instead be an `edit_id` tag.
+
+* <a name="feedback-addedaxiom">Added Axiom</a>: in response to `Axiom`, `admit`, `Admitted`, etc.
+```html
+<feedback object="state" route="0">
+ <state_id val="${stateId}"/>
+ <feedback_content val="addedaxiom" />
+</feedback>
+```
+* <a name="feedback-processing">Processing</a>
+```html
+<feedback object="state" route="0">
+ <state_id val="${stateId}"/>
+ <feedback_content val="processingin">
+ <string>${workerName}</string>
+ </feedback_content>
+</feedback>
+```
+* <a name="feedback-processed">Processed</a>
+```html
+<feedback object="state" route="0">
+ <feedback object="state" route="0">
+ <state_id val="${stateId}"/>
+ <feedback_content val="processed"/>
+</feedback>
+```
+* <a name="feedback-incomplete">Incomplete</a>
+```html
+<feedback object="state" route="0">
+ <state_id val="${stateId}"/>
+ <feedback_content val="incomplete" />
+</feedback>
+```
+* <a name="feedback-complete">Complete</a>
+* <a name="feedback-globref">GlobRef</a>
+* <a name="feedback-error">Error</a>. Issued, for example, when a processed tactic has failed or is unknown.
+The error offsets may both be 0 if there is no particular syntax involved.
+* <a name="feedback-inprogress">InProgress</a>
+```html
+<feedback object="state" route="0">
+ <state_id val="${stateId}"/>
+ <feedback_content val="inprogress">
+ <int>1</int>
+ </feedback_content>
+</feedback>
+```
+* <a name="feedback-workerstatus">WorkerStatus</a>
+Ex: `workername = "proofworker:0"`
+Ex: `status = "Idle"` or `status = "proof: myLemmaName"` or `status = "Dead"`
+```html
+<feedback object="state" route="0">
+ <state_id val="${stateId}"/>
+ <feedback_content val="workerstatus">
+ <pair>
+ <string>${workerName}</string>
+ <string>${status}</string>
+ </pair>
+ </feedback_content>
+</feedback>
+```
+* <a name="feedback-filedependencies">File Dependencies</a>. Typically in response to a `Require`. Dependencies are *.vo files.
+ - State `stateId` directly depends on `dependency`:
+ ```html
+ <feedback object="state" route="0">
+ <state_id val="${stateId}"/>
+ <feedback_content val="filedependency">
+ <option val="none"/>
+ <string>${dependency}</string>
+ </feedback_content>
+ </feedback>
+ ```
+ - State `stateId` depends on `dependency` via dependency `sourceDependency`
+ ```xml
+ <feedback object="state" route="0">
+ <state_id val="${stateId}"/>
+ <feedback_content val="filedependency">
+ <option val="some"><string>${sourceDependency}</string></option>
+ <string>${dependency}</string>
+ </feedback_content>
+ </feedback>
+ ```
+* <a name="feedback-fileloaded">File Loaded</a>. For state `stateId`, module `module` is being loaded from `voFileName`
+```xml
+<feedback object="state" route="0">
+ <state_id val="${stateId}"/>
+ <feedback_content val="fileloaded">
+ <string>${module}</string>
+ <string>${voFileName`}</string>
+ </feedback_content>
+</feedback>
+```
+
+* <a name="feedback-message">Message</a>. `level` is one of `{info,warning,notice,error,debug}`. For example, in response to an <a href="#command-add">add</a> `"Axiom foo: nat."` with `verbose=true`, message `foo is assumed` will be emitted in response.
+```xml
+<feedback object="state" route="0">
+ <state_id val="${stateId}"/>
+ <feedback_content val="message">
+ <message>
+ <message_level val="${level}"/>
+ <string>${message}</string>
+ </message>
+ </feedback_content>
+</feedback>
+```
+
+* <a name="feedback-custom">Custom</a>. A feedback message that Coq plugins can use to return structured results, including results from Ltac profiling. Optionally, `startPos` and `stopPos` define a range of offsets in the document that the message refers to; otherwise, they will be 0. `customTag` is intended as a unique string that identifies what kind of payload is contained in `customXML`.
+```xml
+<feedback object="state" route="0">
+ <state_id val="${stateId}"/>
+ <feedback_content val="custom">
+ <loc start="${startPos}" stop="${stopPos}"/>
+ <string>${customTag}</string>
+ ${customXML}
+ </feedback_content>
+</feedback>
+```
+
diff --git a/interp/topconstr.ml b/interp/topconstr.ml
index 89e04b69d..d3142e7f0 100644
--- a/interp/topconstr.ml
+++ b/interp/topconstr.ml
@@ -58,7 +58,9 @@ let rec cases_pattern_fold_names f a = function
| CPatDelimiters (_,_,pat) -> cases_pattern_fold_names f a pat
| CPatAtom (_,Some (Ident (_,id))) when not (is_constructor id) -> f id a
| CPatPrim _ | CPatAtom _ -> a
- | CPatCast _ -> assert false
+ | CPatCast (loc,_,_) ->
+ CErrors.user_err ~loc ~hdr:"cases_pattern_fold_names"
+ (Pp.strbrk "Casts are not supported here.")
let ids_of_pattern =
cases_pattern_fold_names Id.Set.add Id.Set.empty
diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml
index 33bd7d8dd..d9659d681 100644
--- a/kernel/nativecode.ml
+++ b/kernel/nativecode.ml
@@ -1848,9 +1848,10 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml =
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 n = Context.Rel.length env.env_rel_context - n in
let open Context.Rel.Declaration in
- match Context.Rel.lookup n env.env_rel_context with
+ let decl = Context.Rel.lookup n env.env_rel_context in
+ let n = Context.Rel.length env.env_rel_context - n in
+ match decl 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
diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml
index b2601ad32..dffeade29 100644
--- a/plugins/ltac/tactic_debug.ml
+++ b/plugins/ltac/tactic_debug.ml
@@ -108,6 +108,8 @@ let string_get s i =
try Proofview.NonLogical.return (String.get s i)
with e -> Proofview.NonLogical.raise e
+let run_invalid_arg () = Proofview.NonLogical.raise (Invalid_argument "run_com")
+
(* Gives the number of steps or next breakpoint of a run command *)
let run_com inst =
let open Proofview.NonLogical in
@@ -118,14 +120,14 @@ let run_com inst =
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 ()) >>
+ (if num<0 then run_invalid_arg () else return ()) >>
(skip:=num) >> (skipped:=0)
else
breakpoint:=Some (possibly_unquote s)
else
- invalid_arg "run_com"
+ run_invalid_arg ()
else
- invalid_arg "run_com"
+ run_invalid_arg ()
(* Prints the run counter *)
let run ini =
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index c5cf74ccf..6bc2a4f94 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -563,31 +563,30 @@ let dependencies_in_rhs sigma nargs current tms eqns =
declarations [d(i+1);...;dn] the term [tmi] is dependent in.
[find_dependencies_signature (used1,...,usedn) ((tm1,d1),...,(tmn,dn))]
- returns [(deps1,...,depsn)] where [depsi] is a subset of n,..,i+1
+ returns [(deps1,...,depsn)] where [depsi] is a subset of tm(i+1),..,tmn
denoting in which of the d(i+1)...dn, the term tmi is dependent.
- Dependencies are expressed by index, e.g. in dependency list
- [n-2;1], [1] points to [dn] and [n-2] to [d3]
*)
let rec find_dependency_list sigma tmblock = function
| [] -> []
- | (used,tdeps,d)::rest ->
+ | (used,tdeps,tm,d)::rest ->
let deps = find_dependency_list sigma tmblock rest in
if used && List.exists (fun x -> dependent_decl sigma x d) tmblock
then
- List.add_set Int.equal
- (List.length rest + 1) (List.union Int.equal deps tdeps)
+ match EConstr.kind sigma tm with
+ | Rel n -> List.add_set Int.equal n (List.union Int.equal deps tdeps)
+ | _ -> List.union Int.equal deps tdeps
else deps
let find_dependencies sigma is_dep_or_cstr_in_rhs (tm,(_,tmtypleaves),d) nextlist =
let deps = find_dependency_list sigma (tm::tmtypleaves) nextlist in
if is_dep_or_cstr_in_rhs || not (List.is_empty deps)
- then ((true ,deps,d)::nextlist)
- else ((false,[] ,d)::nextlist)
+ then ((true ,deps,tm,d)::nextlist)
+ else ((false,[] ,tm,d)::nextlist)
let find_dependencies_signature sigma deps_in_rhs typs =
let l = List.fold_right2 (find_dependencies sigma) deps_in_rhs typs [] in
- List.map (fun (_,deps,_) -> deps) l
+ List.map (fun (_,deps,_,_) -> deps) l
(* Assume we had terms t1..tq to match in a context xp:Tp,...,x1:T1 |-
and xn:Tn has just been regeneralized into x:Tn so that the terms
diff --git a/stm/stm.ml b/stm/stm.ml
index fd264e404..e823373f7 100644
--- a/stm/stm.ml
+++ b/stm/stm.ml
@@ -1810,12 +1810,13 @@ end = struct (* {{{ *)
{ indentation; verbose; loc; expr = e; strlen }
=
let e, time, fail =
- let rec find time fail = function
- | VernacTime (_,e) | VernacRedirect (_,(_,e)) -> find true fail e
- | VernacFail e -> find time true e
- | _ -> e, time, fail in find false false e in
+ let rec find ~time ~fail = function
+ | VernacTime (_,e) -> find ~time:true ~fail e
+ | VernacRedirect (_,(_,e)) -> find ~time ~fail e
+ | VernacFail e -> find ~time ~fail:true e
+ | e -> e, time, fail in find ~time:false ~fail:false e in
Vernacentries.with_fail fail (fun () ->
- (if time then System.with_time false else (fun x -> x)) (fun () ->
+ (if time then System.with_time !Flags.time else (fun x -> x)) (fun () ->
ignore(TaskQueue.with_n_workers nworkers (fun queue ->
Proof_global.with_current_proof (fun _ p ->
let goals, _, _, _, _ = Proof.proof p in
@@ -1976,10 +1977,14 @@ let collect_proof keep cur hd brkind id =
| [] -> no_name
| id :: _ -> Names.Id.to_string id in
let loc = (snd cur).loc in
- let is_defined = function
- | _, { expr = VernacEndProof (Proved ((Transparent|Opaque (Some _)),_)) } ->
- true
+ let rec is_defined_expr = function
+ | VernacEndProof (Proved ((Transparent|Opaque (Some _)),_)) -> true
+ | VernacTime (_, e) -> is_defined_expr e
+ | VernacRedirect (_, (_, e)) -> is_defined_expr e
+ | VernacTimeout (_, e) -> is_defined_expr e
| _ -> false in
+ let is_defined = function
+ | _, { expr = e } -> is_defined_expr e in
let proof_using_ast = function
| Some (_, ({ expr = VernacProof(_,Some _) } as v)) -> Some v
| _ -> None in
diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml
index 5908c09d0..fb6adaec5 100644
--- a/stm/vernac_classifier.ml
+++ b/stm/vernac_classifier.ml
@@ -202,8 +202,8 @@ let rec classify_vernac e =
(* What are these? *)
| VernacToplevelControl _
| VernacRestoreState _
- | VernacWriteState _ -> VtUnknown, VtNow
- | VernacError _ -> assert false
+ | VernacWriteState _
+ | VernacError _ -> VtUnknown, VtNow
(* Plugins should classify their commands *)
| VernacExtend (s,l) ->
try List.assoc s !classifiers l ()
diff --git a/test-suite/bugs/closed/5435.v b/test-suite/bugs/closed/5435.v
new file mode 100644
index 000000000..60ace5ce9
--- /dev/null
+++ b/test-suite/bugs/closed/5435.v
@@ -0,0 +1,2 @@
+Definition foo (x : nat) := Eval native_compute in x.
+
diff --git a/test-suite/bugs/closed/5460.v b/test-suite/bugs/closed/5460.v
new file mode 100644
index 000000000..50221cdd8
--- /dev/null
+++ b/test-suite/bugs/closed/5460.v
@@ -0,0 +1,11 @@
+(* Bugs in computing dependencies in pattern-matching compilation *)
+
+Inductive A := a1 | a2.
+Inductive B := b.
+Inductive C : A -> Type := c : C a1 | d : C a2.
+Definition P (x : A) (y : C x) (z : B) : nat :=
+ match z, x, y with
+ | b, a1, c => 0
+ | b, a2, d => 0
+ | _, _, _ => 1
+ end.
diff --git a/test-suite/bugs/closed/5469.v b/test-suite/bugs/closed/5469.v
new file mode 100644
index 000000000..fce671c75
--- /dev/null
+++ b/test-suite/bugs/closed/5469.v
@@ -0,0 +1,3 @@
+(* Some problems with the special treatment of curly braces *)
+
+Reserved Notation "'a' { x }" (at level 0, format "'a' { x }").
diff --git a/test-suite/bugs/closed/5470.v b/test-suite/bugs/closed/5470.v
new file mode 100644
index 000000000..5b3984b6d
--- /dev/null
+++ b/test-suite/bugs/closed/5470.v
@@ -0,0 +1,3 @@
+(* This used to raise an anomaly *)
+
+Fail Reserved Notation "x +++ y" (at level 70, x binder).
diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v
index 52acad746..837f2efd0 100644
--- a/test-suite/success/Notations.v
+++ b/test-suite/success/Notations.v
@@ -121,6 +121,7 @@ Notation " |- {{ a }} b" := (a=b) (no associativity, at level 10).
Goal True.
{{ exact I. }}
Qed.
+
Check |- {{ 0 }} 0.
(* Check parsing of { and } is not affected by notations #3479 *)
@@ -135,3 +136,9 @@ Notation "" := (@nil) (only printing).
(* Check that a notation cannot be neither parsing nor printing. *)
Fail Notation "'foobarkeyword'" := (@nil) (only parsing, only printing).
+
+(* Check "where" clause for inductive types with parameters *)
+
+Reserved Notation "x === y" (at level 50).
+Inductive EQ {A} (x:A) : A -> Prop := REFL : x === x
+ where "x === y" := (EQ x y).
diff --git a/test-suite/success/all-check.v b/test-suite/success/all-check.v
new file mode 100644
index 000000000..391bc540e
--- /dev/null
+++ b/test-suite/success/all-check.v
@@ -0,0 +1,3 @@
+Goal True.
+Fail all:Check _.
+Abort.
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v
index 9b58c524e..f659c31f9 100644
--- a/theories/Init/Logic.v
+++ b/theories/Init/Logic.v
@@ -262,9 +262,9 @@ Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..))
Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q))
(at level 200, x ident, p at level 200, right associativity) : type_scope.
-Notation "'exists2' x : t , p & q" := (ex2 (fun x:t => p) (fun x:t => q))
- (at level 200, x ident, t at level 200, p at level 200, right associativity,
- format "'[' 'exists2' '/ ' x : t , '/ ' '[' p & '/' q ']' ']'")
+Notation "'exists2' x : A , p & q" := (ex2 (A:=A) (fun x => p) (fun x => q))
+ (at level 200, x ident, A at level 200, p at level 200, right associativity,
+ format "'[' 'exists2' '/ ' x : A , '/ ' '[' p & '/' q ']' ']'")
: type_scope.
(** Derived rules for universal quantification *)
diff --git a/vernac/command.ml b/vernac/command.ml
index 4a5a4312e..5ec708446 100644
--- a/vernac/command.ml
+++ b/vernac/command.ml
@@ -603,12 +603,13 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite =
lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in
let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in
let impls = compute_internalization_env env0 (Inductive params) indnames fullarities indimpls in
+ let implsforntn = compute_internalization_env env0 Variable indnames fullarities indimpls in
let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in
let constructors =
Metasyntax.with_syntax_protection (fun () ->
(* Temporary declaration of notations and scopes *)
- List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
+ List.iter (Metasyntax.set_notation_for_interpretation implsforntn) notations;
(* Interpret the constructor types *)
List.map3 (interp_cstrs env_ar_params evdref impls) mldatas arities indl)
() in
diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml
index 7e98d114a..f805eeaa9 100644
--- a/vernac/metasyntax.ml
+++ b/vernac/metasyntax.ml
@@ -522,11 +522,35 @@ let read_recursive_format sl fmt =
let slfmt, fmt = get_head fmt in
slfmt, get_tail (slfmt, fmt)
+let warn_skip_spaces_curly =
+ CWarnings.create ~name:"skip-spaces-curly" ~category:"parsing"
+ (fun () ->strbrk "Skipping spaces inside curly brackets")
+
+let rec drop_spacing = function
+ | UnpCut _ as u :: fmt -> warn_skip_spaces_curly (); drop_spacing fmt
+ | UnpTerminal s' :: fmt when String.equal s' (String.make (String.length s') ' ') -> warn_skip_spaces_curly (); drop_spacing fmt
+ | fmt -> fmt
+
+let has_closing_curly_brace symbs fmt =
+ (* TODO: recognize and fail in case a box overlaps a pair of curly braces *)
+ let fmt = drop_spacing fmt in
+ match symbs, fmt with
+ | NonTerminal s :: symbs, (UnpTerminal s' as u) :: fmt when Id.equal s (Id.of_string s') ->
+ let fmt = drop_spacing fmt in
+ (match fmt with
+ | UnpTerminal "}" :: fmt -> Some (u :: fmt)
+ | _ -> None)
+ | _ -> None
+
let hunks_of_format (from,(vars,typs)) symfmt =
+ let a = ref None in
let rec aux = function
| symbs, (UnpTerminal s' as u) :: fmt
when String.equal s' (String.make (String.length s') ' ') ->
let symbs, l = aux (symbs,fmt) in symbs, u :: l
+ | symbs, (UnpTerminal "{") :: fmt when (a := has_closing_curly_brace symbs fmt; !a <> None) ->
+ let newfmt = Option.get !a in
+ aux (symbs,newfmt)
| Terminal s :: symbs, (UnpTerminal s') :: fmt
when String.equal s (String.drop_simple_quotes s') ->
let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l
@@ -814,6 +838,15 @@ let check_useless_entry_types recvars mainvars etyps =
(pr_id x ++ str " is unbound in the notation.")
| _ -> ()
+let check_binder_type recvars etyps =
+ let l1,l2 = List.split recvars in
+ let l = l1@l2 in
+ List.iter (function
+ | (x,ETBinder b) when not (List.mem x l) ->
+ CErrors.user_err (str (if b then "binder" else "closed binder") ++
+ strbrk " is only for use in recursive notations for binders.")
+ | _ -> ()) etyps
+
let not_a_syntax_modifier = function
| SetOnlyParsing -> true
| SetOnlyPrinting -> true
@@ -981,10 +1014,6 @@ let check_curly_brackets_notation_exists () =
error "Notations involving patterns of the form \"{ _ }\" are treated \n\
specially and require that the notation \"{ _ }\" is already reserved."
-let warn_skip_spaces_curly =
- CWarnings.create ~name:"skip-spaces-curly" ~category:"parsing"
- (fun () ->strbrk "Skipping spaces inside curly brackets")
-
(* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *)
let remove_curly_brackets l =
let rec skip_break acc = function
@@ -1057,9 +1086,10 @@ let compute_syntax_data df modifiers =
let toks = split_notation_string df in
let recvars,mainvars,symbols = analyze_notation_tokens toks in
let _ = check_useless_entry_types recvars mainvars mods.etyps in
+ let _ = check_binder_type recvars mods.etyps in
(* Notations for interp and grammar *)
- let ntn_for_interp = make_notation_key symbols in
+let ntn_for_interp = make_notation_key symbols in
let symbols' = remove_curly_brackets symbols in
let ntn_for_grammar = make_notation_key symbols' in
if not onlyprint then check_rule_productivity symbols';
diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml
index 287584d56..92b1a5956 100644
--- a/vernac/vernacentries.ml
+++ b/vernac/vernacentries.ml
@@ -2200,7 +2200,7 @@ let interp ?(verbosely=true) ?proof (loc,c) =
current_timeout := Some n;
aux ?locality ?polymorphism isprogcmd v
| VernacRedirect (s, (_,v)) ->
- Topfmt.with_output_to_file s (aux false) v
+ Topfmt.with_output_to_file s (aux ?locality ?polymorphism isprogcmd) v
| VernacTime (_,v) ->
System.with_time !Flags.time
(aux ?locality ?polymorphism isprogcmd) v;