diff options
116 files changed, 1326 insertions, 662 deletions
diff --git a/.gitattributes b/.gitattributes index 6af0a106ba..00f78b4494 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1,5 +1,3 @@ -.dir-locals.el export-ignore .gitattributes export-ignore .gitignore export-ignore .mailmap export-ignore -TODO export-ignore diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ae55302d11..d2e335d45a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -60,6 +60,7 @@ before_script: paths: - _install_ci - config/Makefile + - test-suite/misc/universes/all_stdlib.v expire_in: 1 week script: - set -e @@ -70,6 +71,7 @@ before_script: - echo 'start:coq.build' - make -j ${NJOBS} + - make test-suite/misc/universes/all_stdlib.v - echo 'end:coq:build' - echo 'start:coq.install' diff --git a/.travis.yml b/.travis.yml index 6c926aacbd..1a9f6964f7 100644 --- a/.travis.yml +++ b/.travis.yml @@ -31,6 +31,7 @@ env: # system is == 4.02.3 - COMPILER="system" - CAMLP5_VER="6.14" + - FINDLIB_VER="1.4.1" - NATIVE_COMP="yes" - COQ_DEST="-local" # Main test suites @@ -62,9 +63,6 @@ env: matrix: - allow_failures: - - env: TEST_TARGET="ci-geocoq TIMED=1" - include: # Full Coq test-suite with two compilers - env: @@ -95,6 +93,7 @@ matrix: - env: - TEST_TARGET="test-suite" - COMPILER="4.05.0" + - FINDLIB_VER="1.7.3" - CAMLP5_VER="7.01" - EXTRA_CONF="-coqide opt -with-doc yes" - EXTRA_OPAM="lablgtk-extras hevea" @@ -125,6 +124,7 @@ matrix: - TEST_TARGET="coqocaml" - COMPILER="4.05.0" - CAMLP5_VER="7.01" + - FINDLIB_VER="1.7.3" - EXTRA_CONF="-coqide opt -warn-error" - EXTRA_OPAM="lablgtk-extras hevea" # dummy target @@ -140,7 +140,7 @@ matrix: env: - TEST_TARGET="test-suite" - COMPILER="4.02.3" - - CAMLP5_VER="6.17" + - CAMLP5_VER="6.17" - NATIVE_COMP="no" - COQ_DEST="-local" before_install: @@ -173,14 +173,6 @@ matrix: skip_cleanup: true on: all_branches: true - - provider: releases - api_key: - secure: "Z/ewvydCLXEhlBBtQGYm2nZ8o+2RP+MwA5uEDuu6mEpZttUZAYaoHivChxADLXz8LNKvUloIeBeIL/PrLk6QnhSur/s2iEYHssrnl99SkAPtoWggyfsdacuKLMkpLoZGOBIEYKPuXuEZyqvugSUO42rSya1zdjcnXc4l+E/bXMc=" - file: _build/*.dmg - skip_cleanup: true - on: - tags: true - repo: coq/coq before_install: - if [ "${TRAVIS_PULL_REQUEST}" != "false" ]; then echo "Tested commit (followed by parent commits):"; git log -1; for commit in `git log -1 --format="%P"`; do echo; git log -1 $commit; done; fi @@ -189,7 +181,7 @@ install: - opam init -j ${NJOBS} --compiler=${COMPILER} -n -y - eval $(opam config env) - opam config list -- opam install -j ${NJOBS} -y camlp5.${CAMLP5_VER} ocamlfind ${EXTRA_OPAM} +- opam install -j ${NJOBS} -y camlp5.${CAMLP5_VER} ocamlfind.${FINDLIB_VER} ${EXTRA_OPAM} - opam list script: diff --git a/API/API.ml b/API/API.ml index 46ad36d36d..bf99d0febd 100644 --- a/API/API.ml +++ b/API/API.ml @@ -212,7 +212,7 @@ module Pputils = Pputils module Ppconstr = Ppconstr module Printer = Printer (* module Printmod *) -(* module Prettyp *) +module Prettyp = Prettyp module Ppvernac = Ppvernac (******************************************************************************) diff --git a/API/API.mli b/API/API.mli index 3ed326ff0e..3bd047043a 100644 --- a/API/API.mli +++ b/API/API.mli @@ -1795,6 +1795,7 @@ sig val pr_path : full_path -> Pp.t val make_path : Names.DirPath.t -> Names.Id.t -> full_path val eq_full_path : full_path -> full_path -> bool + val repr_path : full_path -> Names.DirPath.t * Names.Id.t val dirpath : full_path -> Names.DirPath.t val path_of_string : string -> full_path @@ -1935,24 +1936,19 @@ module Nametab : sig exception GlobalizationError of Libnames.qualid - type ltac_constant = Names.KerName.t - val global : Libnames.reference -> Globnames.global_reference val global_of_path : Libnames.full_path -> Globnames.global_reference val shortest_qualid_of_global : Names.Id.Set.t -> Globnames.global_reference -> Libnames.qualid val path_of_global : Globnames.global_reference -> Libnames.full_path val locate_extended : Libnames.qualid -> Globnames.extended_global_reference val full_name_module : Libnames.qualid -> Names.DirPath.t - val locate_tactic : Libnames.qualid -> Names.KerName.t val pr_global_env : Names.Id.Set.t -> Globnames.global_reference -> Pp.t - val shortest_qualid_of_tactic : Names.KerName.t -> Libnames.qualid val basename_of_global : Globnames.global_reference -> Names.Id.t type visibility = | Until of int | Exactly of int - val push_tactic : visibility -> Libnames.full_path -> Names.KerName.t -> unit val error_global_not_found : ?loc:Loc.t -> Libnames.qualid -> 'a val shortest_qualid_of_module : Names.ModPath.t -> Libnames.qualid val dirpath_of_module : Names.ModPath.t -> Names.DirPath.t @@ -1960,6 +1956,40 @@ sig val dirpath_of_global : Globnames.global_reference -> Names.DirPath.t val locate : Libnames.qualid -> Globnames.global_reference val locate_constant : Libnames.qualid -> Names.Constant.t + + (** NOT FOR PUBLIC USE YET. Plugin writers, please do not rely on this API. *) + + module type UserName = sig + type t + val equal : t -> t -> bool + val to_string : t -> string + val repr : t -> Names.Id.t * Names.Id.t list + end + + module type EqualityType = + sig + type t + val equal : t -> t -> bool + end + + module type NAMETREE = sig + type elt + type t + type user_name + + val empty : t + val push : visibility -> user_name -> elt -> t -> t + val locate : Libnames.qualid -> t -> elt + val find : user_name -> t -> elt + val exists : user_name -> t -> bool + val user_name : Libnames.qualid -> t -> user_name + val shortest_qualid : Names.Id.Set.t -> user_name -> t -> Libnames.qualid + val find_prefixes : Libnames.qualid -> t -> elt list + end + + module Make (U : UserName) (E : EqualityType) : + NAMETREE with type user_name = U.t and type elt = E.t + end module Global : @@ -4975,6 +5005,21 @@ sig val pr_transparent_state : Names.transparent_state -> Pp.t end +module Prettyp : +sig + type 'a locatable_info = { + locate : Libnames.qualid -> 'a option; + locate_all : Libnames.qualid -> 'a list; + shortest_qualid : 'a -> Libnames.qualid; + name : 'a -> Pp.t; + print : 'a -> Pp.t; + about : 'a -> Pp.t; + } + + val register_locatable : string -> 'a locatable_info -> unit + val print_located_other : string -> Libnames.reference -> Pp.t +end + (************************************************************************) (* End of modules from printing/ *) (************************************************************************) @@ -5,6 +5,8 @@ Notations - Recursive notations with the recursive pattern repeating on the right (e.g. "( x ; .. ; y ; z )") now supported. +- Notations with a specific level for the leftmost nonterminal, + when printing-only, are supported. Tactics @@ -13,14 +15,22 @@ Tactics profiling, and "Set NativeCompute Profile Filename" customizes the profile filename. -Changes from 8.7+beta1 to 8.7.0 -=============================== +Changes from 8.7+beta1 to 8.7+beta2 +=================================== Tools - In CoqIDE, the "Compile Buffer" command takes account of flags in _CoqProject or other project file. +Improvements around some error messages. + +Many bug fixes including two important ones: + +- BZ#5730: CoqIDE becomes unresponsive on file open. +- coq_makefile: make sure compile flags for Coq and coq_makefile are in sync + (in particular, make sure the `-safe-string` option is used to compile plugins). + Changes from 8.6.1 to 8.7+beta1 =============================== @@ -1,5 +1,5 @@ - INSTALLATION PROCEDURES FOR THE COQ V8.6 SYSTEM + INSTALLATION PROCEDURES FOR THE COQ V8.7 SYSTEM ----------------------------------------------- @@ -27,19 +27,16 @@ WHAT DO YOU NEED ? port install coq - To compile Coq V8.6 yourself, you need: + To compile Coq V8.7 yourself, you need: - - OCaml version 4.02.1 or later - (available at http://caml.inria.fr/) + - OCaml version 4.02.3 or later + (available at https://ocaml.org/) - OCaml version 4.02.0 is not supported because of a severe performance - issue increasing compilation time. + - Findlib (version >= 1.4.1) + (available at http://projects.camlcity.org/projects/findlib.html) - - Findlib (included in OCaml binary distribution under windows, - probably available in your distribution and for sure at - http://projects.camlcity.org/projects/findlib.html) - - - Camlp5 (version >= 6.02) + - Camlp5 (version >= 6.14) + (available at https://camlp5.github.io/) - GNU Make version 3.81 or later @@ -48,6 +45,12 @@ WHAT DO YOU NEED ? - for Coqide, the Lablgtk development files, and the GTK libraries incuding gtksourceview, see INSTALL.ide for more details + Opam (https://opam.ocaml.org/) is recommended to install ocaml and + the corresponding packages. + + $ opam install ocamlfind camlp5 lablgtk-extras + + should get you a reasonable OCaml environment to compile Coq. QUICK INSTALLATION PROCEDURE. ============================= diff --git a/Makefile.build b/Makefile.build index 26a40c6cc1..ecaaccaafe 100644 --- a/Makefile.build +++ b/Makefile.build @@ -195,8 +195,8 @@ MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB) OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) -BYTEFLAGS=-thread $(CAMLDEBUG) $(USERFLAGS) -OPTFLAGS=-thread $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) +BYTEFLAGS=$(CAMLDEBUG) $(USERFLAGS) +OPTFLAGS=$(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) DEPFLAGS=$(LOCALINCLUDES)$(if $(filter plugins/%,$<),, -I ide -I ide/utils) # On MacOS, the binaries are signed, except our private ones @@ -429,6 +429,7 @@ tools: $(TOOLS) $(OCAMLLIBDEP) $(COQDEPBOOT) # is being built. COQDEPBOOTSRC := lib/minisys.cmo \ + lib/segmenttree.cmo lib/unicodetable.cmo lib/unicode.cmo \ tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep_boot.cmo tools/coqdep_lexer.cmo : tools/coqdep_lexer.cmi @@ -449,6 +450,7 @@ $(OCAMLLIBDEP): $(call bestobj, tools/ocamllibdep.cmo) # 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/segmenttree.cmo lib/unicodetable.cmo lib/unicode.cmo \ lib/system.cmo tools/coqdep_lexer.cmo tools/coqdep_common.cmo \ tools/coqdep.cmo diff --git a/config/coq_config.mli b/config/coq_config.mli index b0f39e9d28..429d8811bd 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -36,6 +36,7 @@ val camlp4compat : string (* compatibility argument to camlp4/5 *) val coqideincl : string (* arguments for building coqide (e.g. lablgtk) *) val cflags : string (* arguments passed to gcc *) +val caml_flags : string (* arguments passed to ocamlc (ie. CAMLFLAGS) *) val best : string (* byte/opt *) val arch : string (* architecture *) diff --git a/configure.ml b/configure.ml index b5e4567792..fc2233f78d 100644 --- a/configure.ml +++ b/configure.ml @@ -263,10 +263,6 @@ module Prefs = struct let debug = ref true let profile = ref false let annotate = ref false - (* Note, disabling this should be OK, but be careful with the - sharing invariants. - *) - let safe_string = ref true let nativecompiler = ref (not (os_type_win32 || os_type_cygwin)) let coqwebsite = ref "http://coq.inria.fr/" let force_caml_version = ref false @@ -376,8 +372,9 @@ let coq_annotate_flag = then if program_in_path "ocamlmerlin" then "-bin-annot" else "-annot" else "" -let coq_safe_string = - if !Prefs.safe_string then "-safe-string" else "" +(* This variable can be overriden only for debug purposes, use with + care. *) +let coq_safe_string = "-safe-string" let cflags = "-Wall -Wno-unused -g -O2" @@ -512,19 +509,22 @@ let camltag = match caml_version_list with 50: unexpected documentation comment: too common and annoying to avoid 56: unreachable match case: the [_ -> .] syntax doesn't exist in 4.02.3 *) -let coq_warn_flags = - let warnings = "-w +a-4-9-27-41-42-44-45-48-50" in - let errors = +let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-50" +let coq_warn_error = if !Prefs.warn_error then "-warn-error +a" ^ (if caml_version_nums > [4;2;3] then "-56" else "") else "" - in - warnings ^ " " ^ errors +(* Flags used to compile Coq and plugins (via coq_makefile) *) +let caml_flags = + Printf.sprintf "-thread -rectypes %s %s %s" coq_warnings coq_annotate_flag coq_safe_string +(* Flags used to compile Coq but _not_ plugins (via coq_makefile) *) +let coq_caml_flags = + coq_warn_error (** * CamlpX configuration *) @@ -1050,6 +1050,7 @@ let write_configml f = pr_s "camlp4lib" camlpXlibdir; pr_s "camlp4compat" camlp4compat; pr_s "cflags" cflags; + pr_s "caml_flags" caml_flags; pr_s "best" best_compiler; pr_s "osdeplibs" osdeplibs; pr_s "version" coq_version; @@ -1156,7 +1157,7 @@ let write_makefile f = pr "CAMLHLIB=%S\n\n" camllib; pr "# Caml link command and Caml make top command\n"; pr "# Caml flags\n"; - pr "CAMLFLAGS=-rectypes %s %s %s\n" coq_warn_flags coq_annotate_flag coq_safe_string; + pr "CAMLFLAGS=%s %s\n" caml_flags coq_caml_flags; pr "# User compilation flag\n"; pr "USERFLAGS=\n\n"; pr "# Flags for GCC\n"; diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 8e7265969b..43525dcd40 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -127,5 +127,5 @@ ######################################################################## # Bignums ######################################################################## -: ${bignums_CI_BRANCH:=fix-thunk-printer} -: ${bignums_CI_GITURL:=https://github.com/ppedrot/bignums.git} +: ${bignums_CI_BRANCH:=master} +: ${bignums_CI_GITURL:=https://github.com/coq/bignums.git} diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index eadeb7c38c..8e6448e764 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -8,9 +8,5 @@ GeoCoq_CI_DIR=${CI_BUILD_DIR}/GeoCoq git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} ${GeoCoq_CI_DIR} ( cd ${GeoCoq_CI_DIR} && \ - ./configure.sh && \ - sed -i.bak '/Ch16_coordinates_with_functions\.v/d' Make && \ - sed -i.bak '/Elements\/Book_1\.v/d' Make && \ - sed -i.bak '/Elements\/Book_3\.v/d' Make && \ - coq_makefile -f Make -o Makefile && \ + ./configure-ci.sh && \ make ) diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 5ed74917aa..b5e19f33c3 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -641,6 +641,12 @@ The main search functions now take a function iterating over the results. This allows for clients to use streaming or more economic printing. +### XML Protocol + +- 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". + ## Changes between Coq 8.4 and Coq 8.5 ### Refactoring : more mli interfaces and simpler grammar.cma diff --git a/dev/doc/xml-protocol.md b/dev/doc/xml-protocol.md index cf7d205d8b..18f6288f6f 100644 --- a/dev/doc/xml-protocol.md +++ b/dev/doc/xml-protocol.md @@ -1,4 +1,4 @@ -#Coq XML Protocol for Coq 8.6# +# Coq XML Protocol This document is based on documentation originally written by CJ Bell for his [vscoq](https://github.com/siegebell/vscoq/) project. @@ -12,11 +12,7 @@ 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" +Changes to the XML protocol are documented as part of [`dev/doc/changes.txt`](/dev/doc/changes.txt). * [Commands](#commands) - [About](#command-about) diff --git a/doc/common/styles/html/coqremote/cover.html b/doc/common/styles/html/coqremote/cover.html index 1c415eca69..5d151381ff 100644 --- a/doc/common/styles/html/coqremote/cover.html +++ b/doc/common/styles/html/coqremote/cover.html @@ -52,20 +52,7 @@ <h2 style="text-align:center; font-size: 150%">The Coq Development Team</h2> <br /><br /><br /> -<div style="text-align: left; font-size: 80%; text-indent: 0pt"> -<ul style="list-style: none; margin-left: 0pt"> - <li>V7.x © INRIA 1999-2004</li> - <li>V8.0 © INRIA 2004-2008</li> - <li>V8.1 © INRIA 2006-2011</li> - <li>V8.2 © INRIA 2008-2011</li> - <li>V8.3 © INRIA 2010-2011</li> - <li>V8.4 © INRIA 2012-2014</li> - <li>V8.5 © INRIA 2015-2016</li> - <li>V8.6 © INRIA 2016</li> -</ul> - -<p style="text-indent:0pt">This research was partly supported by IST - working group ``Types''</p> +<p style="text-indent:0pt">Copyright © INRIA 1999-2017</p> <p style="text-indent:0pt">This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at <a href="http://www.opencontent.org/openpub">http://www.opencontent.org/openpub</a>). Options A and B are not elected.</p> diff --git a/doc/common/styles/html/simple/cover.html b/doc/common/styles/html/simple/cover.html index 25fb56320b..6053131045 100644 --- a/doc/common/styles/html/simple/cover.html +++ b/doc/common/styles/html/simple/cover.html @@ -30,20 +30,7 @@ <br /><br /><br /> -<div style="text-align: left; font-size: 80%; text-indent: 0pt"> -<ul style="list-style: none; margin-left: 0pt"> - <li>V7.x © INRIA 1999-2004</li> - <li>V8.0 © INRIA 2004-2008</li> - <li>V8.1 © INRIA 2006-2011</li> - <li>V8.2 © INRIA 2008-2011</li> - <li>V8.3 © INRIA 2010-2011</li> - <li>V8.4 © INRIA 2012-2014</li> - <li>V8.5 © INRIA 2015-2016</li> - <li>V8.6 © INRIA 2016</li> -</ul> - -<p style="text-indent:0pt">This research was partly supported by IST - working group ``Types''</p> +<p style="text-indent:0pt">Copyright © INRIA 1999-2017</p> <p style="text-indent: 0pt">This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at <a href="http://www.opencontent.org/openpub">http://www.opencontent.org/openpub</a>). Options A and B are not elected.</p> diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index 9790111f14..892c9931b6 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -107,6 +107,15 @@ The following command-line options are recognized by the commands {\tt recursively available from {\Coq} using absolute names (extending the {\dirpath} prefix) (see Section~\ref{LongNames}). + Note that only those subdirectories and files which obey the lexical + conventions of what is an {\ident} (see Section~\ref{lexical}) + are taken into account. Conversely, the underlying file systems or + operating systems may be more restrictive than {\Coq}. While Linux's + ext4 file system supports any {\Coq} recursive layout + (within the limit of 255 bytes per file name), the default on NTFS + (Windows) or HFS+ (MacOS X) file systems is on the contrary to + disallow two files differing only in the case in the same directory. + \SeeAlso Section~\ref{Libraries}. \item[{\tt -R} {\em directory} {\dirpath}]\ % diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 339c6a248e..eabfb7b398 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -478,8 +478,6 @@ type clear_dependency_error = 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 = @@ -552,13 +550,6 @@ let rec check_and_clear_in_constr env evdref err ids global c = let evd = !evdref in let (evd,_) = restrict_evar evd evk filter None 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 *) Evd.existential_value !evdref ev | _ -> map_constr (check_and_clear_in_constr env evdref err ids global) c @@ -665,11 +656,9 @@ let rec advance sigma evk = 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 + match is_restricted_evar evi with + | Some evk -> advance sigma evk + | None -> None (** The following functions return the set of undefined evars contained in the object, the defined evars being traversed. diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 14173e774d..ee0fae3d46 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -204,10 +204,6 @@ type clear_dependency_error = 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 diff --git a/engine/evd.ml b/engine/evd.ml index f1b5419dec..324f883e8e 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -630,7 +630,9 @@ 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 restricted = Store.field () + +let define_aux ?dorestrict def undef evk body = let oldinfo = try EvMap.find evk undef with Not_found -> @@ -640,7 +642,10 @@ let define_aux def undef evk body = 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 + let evar_extra = match dorestrict with + | Some evk' -> Store.set oldinfo.evar_extra restricted evk' + | None -> oldinfo.evar_extra in + let newinfo = { oldinfo with evar_body = Evar_defined body; evar_extra } in EvMap.add evk newinfo def, EvMap.remove evk undef (* define the existential of section path sp as the constr body *) @@ -653,6 +658,9 @@ let define evk body evd = let evar_names = EvNames.remove_name_defined evk evd.evar_names in { evd with defn_evars; undf_evars; last_mods; evar_names } +let is_restricted_evar evi = + Store.get evi.evar_extra restricted + let restrict evk filter ?candidates ?src evd = let evk' = new_untyped_evar () in let evar_info = EvMap.find evk evd.undf_evars in @@ -667,7 +675,7 @@ let restrict evk filter ?candidates ?src evd = let ctxt = Filter.filter_list filter (evar_context evar_info) in let id_inst = Array.map_of_list (NamedDecl.get_id %> mkVar) 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 + let (defn_evars, undf_evars) = define_aux ~dorestrict:evk' evd.defn_evars evd.undf_evars evk body in { evd with undf_evars = EvMap.add evk' evar_info' undf_evars; defn_evars; last_mods; evar_names }, evk' diff --git a/engine/evd.mli b/engine/evd.mli index abcabe8157..96e4b6acce 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -31,7 +31,7 @@ open Environ (** {6 Evars} *) type evar = existential_key -(** Existential variables. TODO: Should be made opaque one day. *) +(** Existential variables. *) val string_of_existential : evar -> string @@ -244,6 +244,9 @@ val restrict : evar -> Filter.t -> ?candidates:constr list -> (** Restrict an undefined evar into a new evar by filtering context and possibly limiting the instances to a set of candidates *) +val is_restricted_evar : evar_info -> evar option +(** Tell if an evar comes from restriction of another evar, and if yes, which *) + 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 *) diff --git a/engine/namegen.ml b/engine/namegen.ml index 1dd29e6eae..2e62b89011 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -43,6 +43,8 @@ let default_non_dependent_ident = Id.of_string default_non_dependent_string let default_dependent_ident = Id.of_string "x" +let default_generated_non_letter_string = "x" + (**********************************************************************) (* Globality of identifiers *) @@ -107,7 +109,17 @@ let head_name sigma c = (* Find the head constant of a constr if any *) hdrec c let lowercase_first_char id = (* First character of a constr *) - Unicode.lowercase_first_char (Id.to_string id) + let s = Id.to_string id in + match Unicode.split_at_first_letter s with + | None -> + (* General case: nat -> n *) + Unicode.lowercase_first_char s + | Some (s,s') -> + if String.length s' = 0 then + (* No letter, e.g. __, or __'_, etc. *) + default_generated_non_letter_string + else + s ^ Unicode.lowercase_first_char s' let sort_hdchar = function | Prop(_) -> "P" diff --git a/engine/proofview.ml b/engine/proofview.ml index eef2b83f44..598358c472 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -153,8 +153,12 @@ let focus i j sp = ( { 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 + unsolved (after advancing cleared goals). Note that order matters. *) +let undefined defs l = + List.fold_right (fun evk l -> + match Evarutil.advance defs evk with + | Some evk -> List.add_set Evar.equal evk l + | None -> l) l [] (** Unfocuses a proofview with respect to a context. *) let unfocus c sp = diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml index 03e8ea43d1..4a471d4a2b 100644 --- a/intf/vernacexpr.ml +++ b/intf/vernacexpr.ml @@ -91,7 +91,7 @@ type locatable = | LocateTerm of reference or_by_notation | LocateLibrary of reference | LocateModule of reference - | LocateTactic of reference + | LocateOther of string * reference | LocateFile of string type showable = diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index d2b41aae98..8568bf14b8 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -166,16 +166,10 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = 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 + | Abstract -> + 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 | Algebraic (NoFunctor (MEident(mp'))) -> check_modpath_equiv env' mp1 mp'; old.mod_constraints diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index ad622b07d8..fd024b2157 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -683,12 +683,15 @@ let build_module_body params restype senv = with one extra component and some updated fields (constraints, required, etc) *) +let allow_delayed_constants = ref false + 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 = []); + if not !allow_delayed_constants && later_cst <> [] then + CErrors.anomaly ~label:"safe_typing" + Pp.(str "True Future.t were created for opaque constants even if -async-proofs is off"); { oldsenv with env = newenv; modresolver = newresolver; diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 752fdd793e..f0f273f354 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -158,6 +158,10 @@ val add_module_parameter : MBId.t -> Entries.module_struct_entry -> Declarations.inline -> Mod_subst.delta_resolver safe_transformer +(** Traditional mode: check at end of module that no future was + created. *) +val allow_delayed_constants : bool ref + (** The optional result type is given without its functorial part *) val end_module : diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 3f42c348fc..0c0b910e1d 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -428,13 +428,12 @@ let build_constant_declaration kn env result = 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; + if !Flags.record_aux_file 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 + if !Flags.record_aux_file then record_aux env Id.Set.empty Id.Set.empty ""; [], def (* Empty section context: no need to check *) | Some declared -> @@ -614,7 +613,7 @@ let translate_local_def mb env id centry = let open Cooking in let decl = infer_declaration ~trust:mb env None (DefinitionEntry centry) in let typ = decl.cook_type in - if Option.is_empty decl.cook_context && !Flags.compilation_mode = Flags.BuildVo then begin + if Option.is_empty decl.cook_context && !Flags.record_aux_file then begin match decl.cook_body with | Undef _ -> () | Def _ -> () diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 044877e82a..b40badd7c8 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -65,6 +65,10 @@ let type_of_type u = let uu = Universe.super u in mkType uu +let type_of_sort = function + | Prop c -> type1 + | Type u -> type_of_type u + (*s Type of a de Bruijn index. *) let type_of_relative env n = @@ -323,11 +327,7 @@ let rec execute env cstr = let open Context.Rel.Declaration in match kind_of_term cstr with (* Atomic terms *) - | Sort (Prop c) -> - type1 - - | Sort (Type u) -> - type_of_type u + | Sort s -> type_of_sort s | Rel n -> type_of_relative env n diff --git a/kernel/typeops.mli b/kernel/typeops.mli index a8f7fba9a0..96be6c14a4 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -37,15 +37,19 @@ val assumption_of_judgment : env -> unsafe_judgment -> types val type_judgment : env -> unsafe_judgment -> unsafe_type_judgment (** {6 Type of sorts. } *) +val type1 : types +val type_of_sort : Sorts.t -> types 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 type_of_relative : env -> int -> types val judge_of_relative : env -> int -> unsafe_judgment (** {6 Type of variables } *) +val type_of_variable : env -> variable -> types val judge_of_variable : env -> variable -> unsafe_judgment (** {6 type of a constant } *) @@ -66,9 +70,9 @@ 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 sort_of_product : env -> sorts -> sorts -> sorts +val type_of_product : env -> Name.t -> sorts -> sorts -> types val judge_of_product : env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index ff71452672..3699b1c614 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -93,8 +93,12 @@ let split_flags s = "all" flag, and reverses the list. *) let rec cut_before_all_rev acc = function | [] -> acc - | (_status,name as w) :: warnings -> - cut_before_all_rev (w :: if is_all_keyword name then [] else acc) warnings + | (status,name as w) :: warnings -> + let acc = + if is_all_keyword name then [w] + else if is_none_keyword name then [(Disabled,"all")] + else w :: acc in + cut_before_all_rev acc warnings let cut_before_all_rev warnings = cut_before_all_rev [] warnings diff --git a/lib/envars.ml b/lib/envars.ml index 68604ae6c9..206d750338 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -213,6 +213,7 @@ let print_config ?(prefix_var_name="") f coq_src_subdirs = fprintf f "%sCAMLP4BIN=%s/\n" prefix_var_name (camlp4bin ()); fprintf f "%sCAMLP4LIB=%s\n" prefix_var_name (camlp4lib ()); fprintf f "%sCAMLP4OPTIONS=%s\n" prefix_var_name Coq_config.camlp4compat; + fprintf f "%sCAMLFLAGS=%s\n" prefix_var_name Coq_config.caml_flags; fprintf f "%sHASNATDYNLINK=%s\n" prefix_var_name (if Coq_config.has_natdynlink then "true" else "false"); fprintf f "%sCOQ_SRC_SUBDIRS=%s\n" prefix_var_name (String.concat " " coq_src_subdirs) diff --git a/lib/flags.ml b/lib/flags.ml index d4be81c61a..a178eb7552 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -43,11 +43,8 @@ let with_extra_values o l f x = let boot = ref false let load_init = ref true -let batch_mode = ref false -type compilation_mode = BuildVo | BuildVio | Vio2Vo -let compilation_mode = ref BuildVo -let compilation_output_name = ref None +let record_aux_file = ref false let test_mode = ref false diff --git a/lib/flags.mli b/lib/flags.mli index 3024c60396..8ec2a80730 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -13,12 +13,9 @@ val boot : bool ref val load_init : bool ref -(* Will affect STM caching *) -val batch_mode : bool ref - -type compilation_mode = BuildVo | BuildVio | Vio2Vo -val compilation_mode : compilation_mode ref -val compilation_output_name : string option ref +(** Set by coqtop to tell the kernel to output to the aux file; will + be eventually removed by cleanups such as PR#1103 *) +val record_aux_file : bool ref (* Flag set when the test-suite is called. Its only effect to display verbose information for `Fail` *) @@ -82,10 +82,21 @@ let utf8_length s = done ; !cnt -let app s1 s2 = match s1, s2 with - | Ppcmd_empty, s - | s, Ppcmd_empty -> s - | s1, s2 -> Ppcmd_glue [s1; s2] +let rec app d1 d2 = match d1, d2 with + | Ppcmd_empty, d + | d, Ppcmd_empty -> d + + (* Optimizations *) + | Ppcmd_glue [l1;l2], Ppcmd_glue l3 -> Ppcmd_glue (l1 :: l2 :: l3) + | Ppcmd_glue [l1;l2], d2 -> Ppcmd_glue [l1 ; l2 ; d2] + | d1, Ppcmd_glue l2 -> Ppcmd_glue (d1 :: l2) + + | Ppcmd_tag(t1,d1), Ppcmd_tag(t2,d2) + when t1 = t2 -> Ppcmd_tag(t1,app d1 d2) + | d1, d2 -> Ppcmd_glue [d1; d2] + (* Optimizations deemed too costly *) + (* | Ppcmd_glue l1, Ppcmd_glue l2 -> Ppcmd_glue (l1 @ l2) *) + (* | Ppcmd_string s1, Ppcmd_string s2 -> Ppcmd_string (s1 ^ s2) *) let seq s = Ppcmd_glue s diff --git a/lib/system.ml b/lib/system.ml index 12eacf2eaf..4b5066ef41 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -52,7 +52,9 @@ let dirmap = ref StrMap.empty let make_dir_table dir = let filter_dotfiles s f = if f.[0] = '.' then s else StrSet.add f s in - Array.fold_left filter_dotfiles StrSet.empty (readdir dir) + Array.fold_left filter_dotfiles StrSet.empty (Sys.readdir dir) + +let trust_file_cache = ref true let exists_in_dir_respecting_case dir bf = let cache_dir dir = @@ -62,10 +64,10 @@ let exists_in_dir_respecting_case dir bf = let contents, fresh = try (* in batch mode, assume the directory content is still fresh *) - StrMap.find dir !dirmap, !Flags.batch_mode + StrMap.find dir !dirmap, !trust_file_cache with Not_found -> (* in batch mode, we are not yet sure the directory exists *) - if !Flags.batch_mode && not (exists_dir dir) then StrSet.empty, true + if !trust_file_cache && not (exists_dir dir) then StrSet.empty, true else cache_dir dir, true in StrSet.mem bf contents || not fresh && @@ -80,7 +82,7 @@ let file_exists_respecting_case path f = let df = Filename.dirname f in (String.equal df "." || aux df) && exists_in_dir_respecting_case (Filename.concat path df) bf - in (!Flags.batch_mode || Sys.file_exists (Filename.concat path f)) && aux f + in (!trust_file_cache || Sys.file_exists (Filename.concat path f)) && aux f let rec search paths test = match paths with diff --git a/lib/system.mli b/lib/system.mli index 7281de97c9..aa964abebe 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -54,6 +54,12 @@ val where_in_path_rex : val find_file_in_path : ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string +val trust_file_cache : bool ref +(** [trust_file_cache] indicates whether we trust the underlying + mapped file-system not to change along the execution of Coq. This + assumption greatly speds up file search, but it is often + inconvenient in interactive mode *) + val file_exists_respecting_case : string -> string -> bool (** {6 I/O functions } *) diff --git a/lib/unicode.ml b/lib/unicode.ml index 959ccaf73c..f193c4e0f8 100644 --- a/lib/unicode.ml +++ b/lib/unicode.ml @@ -8,13 +8,14 @@ (** Unicode utilities *) -type status = Letter | IdentPart | Symbol | Unknown +type status = Letter | IdentPart | Symbol | IdentSep | Unknown (* The following table stores classes of Unicode characters that - are used by the lexer. There are 3 different classes so 2 bits are - allocated for each character. We only use 16 bits over the 31 bits - to simplify the masking process. (This choice seems to be a good - trade-off between speed and space after some benchmarks.) *) + are used by the lexer. There are 5 different classes so 3 bits + are allocated for each character. We encode the masks of 8 + characters per word, thus using 24 bits over the 31 available + bits. (This choice seems to be a good trade-off between speed + and space after some benchmarks.) *) (* A 256 KiB table, initially filled with zeros. *) let table = Array.make (1 lsl 17) 0 @@ -24,14 +25,15 @@ let table = Array.make (1 lsl 17) 0 define the position of the pattern in the word. Notice that pattern "00" means "undefined". *) let mask i = function - | Letter -> 1 lsl ((i land 7) lsl 1) (* 01 *) - | IdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *) - | Symbol -> 3 lsl ((i land 7) lsl 1) (* 11 *) - | Unknown -> 0 lsl ((i land 7) lsl 1) (* 00 *) + | Letter -> 1 lsl ((i land 7) * 3) (* 001 *) + | IdentPart -> 2 lsl ((i land 7) * 3) (* 010 *) + | Symbol -> 3 lsl ((i land 7) * 3) (* 011 *) + | IdentSep -> 4 lsl ((i land 7) * 3) (* 100 *) + | Unknown -> 0 lsl ((i land 7) * 3) (* 000 *) -(* Helper to reset 2 bits in a word. *) +(* Helper to reset 3 bits in a word. *) let reset_mask i = - lnot (3 lsl ((i land 7) lsl 1)) + lnot (7 lsl ((i land 7) * 3)) (* Initialize the lookup table from a list of segments, assigning a status to every character of each segment. The order of these @@ -50,13 +52,14 @@ let mk_lookup_table_from_unicode_tables_for status tables = (* Look up into the table and interpret the found pattern. *) let lookup x = - let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in + let v = (table.(x lsr 3) lsr ((x land 7) * 3)) land 7 in if v = 1 then Letter else if v = 2 then IdentPart else if v = 3 then Symbol + else if v = 4 then IdentSep else Unknown -(* [classify] discriminates between 3 different kinds of +(* [classify] discriminates between 5 different kinds of symbols based on the standard unicode classification (extracted from Camomile). *) let classify = @@ -67,13 +70,13 @@ let classify = Unicodetable.sm; (* Symbol, maths. *) Unicodetable.sc; (* Symbol, currency. *) Unicodetable.so; (* Symbol, modifier. *) - Unicodetable.pd; (* Punctation, dash. *) - Unicodetable.pc; (* Punctation, connector. *) - Unicodetable.pe; (* Punctation, open. *) - Unicodetable.ps; (* Punctation, close. *) - Unicodetable.pi; (* Punctation, initial quote. *) - Unicodetable.pf; (* Punctation, final quote. *) - Unicodetable.po; (* Punctation, other. *) + Unicodetable.pd; (* Punctuation, dash. *) + Unicodetable.pc; (* Punctuation, connector. *) + Unicodetable.pe; (* Punctuation, open. *) + Unicodetable.ps; (* Punctution, close. *) + Unicodetable.pi; (* Punctuation, initial quote. *) + Unicodetable.pf; (* Punctuation, final quote. *) + Unicodetable.po; (* Punctuation, other. *) ]; mk_lookup_table_from_unicode_tables_for Letter [ @@ -107,14 +110,14 @@ let classify = [(0x02074, 0x02079)]; (* Superscript 4-9. *) single 0x0002E; (* Dot. *) ]; - mk_lookup_table_from_unicode_tables_for Letter + mk_lookup_table_from_unicode_tables_for IdentSep [ single 0x005F; (* Underscore. *) single 0x00A0; (* Non breaking space. *) ]; mk_lookup_table_from_unicode_tables_for IdentPart [ - single 0x0027; (* Special space. *) + single 0x0027; (* Single quote. *) ]; (* Lookup *) lookup @@ -163,24 +166,75 @@ let is_utf8 s = in try check 0 with End_of_input -> true | Invalid_argument _ -> false +(* Escape string if it contains non-utf8 characters *) + +let escaped_non_utf8 s = + let mk_escape x = Printf.sprintf "%%%X" x in + let buff = Buffer.create (String.length s * 3) in + let rec process_trailing_aux i j = + if i = j then i else + match String.unsafe_get s i with + | '\128'..'\191' -> process_trailing_aux (i+1) j + | _ -> i in + let process_trailing i n = + let j = if i+n-1 >= String.length s then i+1 else process_trailing_aux (i+1) (i+n) in + (if j = i+n then + Buffer.add_string buff (String.sub s i n) + else + let v = Array.init (j-i) (fun k -> mk_escape (Char.code s.[i+k])) in + Buffer.add_string buff (String.concat "" (Array.to_list v))); + j in + let rec process i = + if i >= String.length s then Buffer.contents buff else + let c = String.unsafe_get s i in + match c with + | '\000'..'\127' -> Buffer.add_char buff c; process (i+1) + | '\128'..'\191' | '\248'..'\255' -> Buffer.add_string buff (mk_escape (Char.code c)); process (i+1) + | '\192'..'\223' -> process (process_trailing i 2) + | '\224'..'\239' -> process (process_trailing i 3) + | '\240'..'\247' -> process (process_trailing i 4) + in + process 0 + +let escaped_if_non_utf8 s = + if is_utf8 s then s else escaped_non_utf8 s + (* Check the well-formedness of an identifier *) +let is_valid_ident_initial = function + | Letter | IdentSep -> true + | IdentPart | Symbol | Unknown -> false + let initial_refutation j n s = - match classify n with - | Letter -> None - | _ -> + if is_valid_ident_initial (classify n) then None + else let c = String.sub s 0 j in Some (false, "Invalid character '"^c^"' at beginning of identifier \""^s^"\".") +let is_valid_ident_trailing = function + | Letter | IdentSep | IdentPart -> true + | Symbol | Unknown -> false + let trailing_refutation i j n s = - match classify n with - | Letter | IdentPart -> None - | _ -> + if is_valid_ident_trailing (classify n) then None + else let c = String.sub s i j in Some (false, "Invalid character '"^c^"' in identifier \""^s^"\".") +let is_unknown = function + | Unknown -> true + | Letter | IdentSep | IdentPart | Symbol -> false + +let is_ident_part = function + | IdentPart -> true + | Letter | IdentSep | Symbol | Unknown -> false + +let is_ident_sep = function + | IdentSep -> true + | Letter | IdentPart | Symbol | Unknown -> false + let ident_refutation s = if s = ".." then None else try let j, n = next_utf8 s 0 in @@ -198,7 +252,7 @@ let ident_refutation s = |x -> x with | End_of_input -> Some (true,"The empty string is not an identifier.") - | Invalid_argument _ -> Some (true,s^": invalid utf8 sequence.") + | Invalid_argument _ -> Some (true,escaped_non_utf8 s^": invalid utf8 sequence.") let lowercase_unicode = let tree = Segmenttree.make Unicodetable.to_lower in @@ -214,6 +268,26 @@ let lowercase_first_char s = let j, n = next_utf8 s 0 in utf8_of_unicode (lowercase_unicode n) +let split_at_first_letter s = + let n, v = next_utf8 s 0 in + if ((* optim *) n = 1 && s.[0] != '_') || not (is_ident_sep (classify v)) then None + else begin + let n = ref n in + let p = ref 0 in + while !n < String.length s && + let n', v = next_utf8 s !n in + p := n'; + (* Test if not letter *) + ((* optim *) n' = 1 && (s.[!n] = '_' || s.[!n] = '\'')) + || let st = classify v in + is_ident_sep st || is_ident_part st + do n := !n + !p + done; + let s1 = String.sub s 0 !n in + let s2 = String.sub s !n (String.length s - !n) in + Some (s1,s2) + end + (** For extraction, we need to encode unicode character into ascii ones *) let is_basic_ascii s = @@ -268,9 +342,7 @@ let utf8_length s = | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *) | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *) | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *) - | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *) - | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *) - | '\254'..'\255' -> nc := 0 (* invalid byte *) + | '\248'..'\255' -> nc := 0 (* invalid byte *) end ; incr p ; while !p < len && !nc > 0 do @@ -299,9 +371,7 @@ let utf8_sub s start_u len_u = | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *) | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *) | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *) - | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *) - | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *) - | '\254'..'\255' -> nc := 0 (* invalid byte *) + | '\248'..'\255' -> nc := 0 (* invalid byte *) end ; incr p ; while !p < len_b && !nc > 0 do diff --git a/lib/unicode.mli b/lib/unicode.mli index c7d7424801..32ffbb8e94 100644 --- a/lib/unicode.mli +++ b/lib/unicode.mli @@ -8,7 +8,7 @@ (** Unicode utilities *) -type status = Letter | IdentPart | Symbol | Unknown +type status (** Classify a unicode char into 3 classes or unknown. *) val classify : int -> status @@ -17,10 +17,23 @@ val classify : int -> status Return [Some (b,s)] otherwise, where [s] is an explanation and [b] is severity. *) val ident_refutation : string -> (bool * string) option +(** Tells if a valid initial character for an identifier *) +val is_valid_ident_initial : status -> bool + +(** Tells if a valid non-initial character for an identifier *) +val is_valid_ident_trailing : status -> bool + +(** Tells if a character is unclassified *) +val is_unknown : status -> bool + (** First char of a string, converted to lowercase @raise Assert_failure if the input string is empty. *) val lowercase_first_char : string -> string +(** Split a string supposed to be an ident at the first letter; + as an optimization, return None if the first character is a letter *) +val split_at_first_letter : string -> (string * string) option + (** Return [true] if all UTF-8 characters in the input string are just plain ASCII characters. Returns [false] otherwise. *) val is_basic_ascii : string -> bool @@ -40,3 +53,6 @@ val utf8_length : string -> int (** Variant of {!String.sub} for UTF-8 strings. *) val utf8_sub : string -> int -> int -> string + +(** Return a "%XX"-escaped string if it contains non UTF-8 characters. *) +val escaped_if_non_utf8 : string -> string diff --git a/library/library.ml b/library/library.ml index 28afa054e9..e2832ecdc3 100644 --- a/library/library.ml +++ b/library/library.ml @@ -620,25 +620,6 @@ let check_coq_overwriting p id = (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 = user_err (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 @@ -648,7 +629,6 @@ let start_library fo = 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; @@ -703,7 +683,8 @@ let error_recursively_dependent_library dir = let save_library_to ?todo dir f otab = let except = match todo with | None -> - assert(!Flags.compilation_mode = Flags.BuildVo); + (* XXX *) + (* assert(!Flags.compilation_mode = Flags.BuildVo); *) assert(Filename.check_suffix f ".vo"); Future.UUIDSet.empty | Some (l,_) -> diff --git a/library/nametab.ml b/library/nametab.ml index 68fdbb4f38..0ec4a37cdb 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -19,10 +19,6 @@ exception GlobalizationError of qualid let error_global_not_found ?loc q = Loc.raise ?loc (GlobalizationError q) -(* Kinds of global names *) - -type ltac_constant = kernel_name - (* The visibility can be registered either - for all suffixes not shorter then a given int - when the object is loaded inside a module @@ -274,19 +270,14 @@ struct 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) @@ -327,10 +318,6 @@ 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 @@ -368,13 +355,6 @@ 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; @@ -402,8 +382,6 @@ let locate_syndef qid = match locate_extended qid with 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 = @@ -428,8 +406,6 @@ let locate_all qid = 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 @@ -471,8 +447,6 @@ 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 = @@ -492,9 +466,6 @@ let path_of_syndef kn = 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 @@ -519,10 +490,6 @@ 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 -> @@ -541,28 +508,24 @@ let global_inductive r = (********************************************************************) (* Registration of tables as a global table and rollback *) -type frozen = ccitab * dirtab * mptab * kntab - * globrevtab * mprevtab * mptrevtab * knrevtab +type frozen = ccitab * dirtab * mptab + * globrevtab * mprevtab * mptrevtab let freeze _ : frozen = !the_ccitab, !the_dirtab, !the_modtypetab, - !the_tactictab, !the_globrevtab, !the_modrevtab, - !the_modtyperevtab, - !the_tacticrevtab + !the_modtyperevtab -let unfreeze (ccit,dirt,mtyt,tact,globr,modr,mtyr,tacr) = +let unfreeze (ccit,dirt,mtyt,globr,modr,mtyr) = the_ccitab := ccit; the_dirtab := dirt; the_modtypetab := mtyt; - the_tactictab := tact; the_globrevtab := globr; the_modrevtab := modr; - the_modtyperevtab := mtyr; - the_tacticrevtab := tacr + the_modtyperevtab := mtyr let _ = Summary.declare_summary "names" diff --git a/library/nametab.mli b/library/nametab.mli index 025a63b1ce..3a380637c2 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -78,10 +78,6 @@ 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 @@ -95,7 +91,6 @@ 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 @@ -109,7 +104,6 @@ val global_inductive : reference -> inductive 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 @@ -125,7 +119,6 @@ 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 } *) @@ -144,7 +137,6 @@ 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 *) @@ -166,7 +158,6 @@ 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 *) diff --git a/man/coqdep.1 b/man/coqdep.1 index 81f7e1e0df..ed727db7c8 100644 --- a/man/coqdep.1 +++ b/man/coqdep.1 @@ -82,7 +82,7 @@ Prints the dependencies of Caml modules. \" the standard output. No dependency is computed with this option. .TP .BI \-I/\-Q/\-R \ options -Have the same effects on load path and modules names than for other +Have the same effects on load path and modules names as for other coq commands (coqtop, coqc). .TP .BI \-coqlib \ directory diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index 9c9189ffeb..f26398fa92 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -245,8 +245,8 @@ let check_ident str = loop_id true s | [< s >] -> match unlocated lookup_utf8 Ploc.dummy s with - | Utf8Token (Unicode.Letter, n) -> njunk n s; loop_id true s - | Utf8Token (Unicode.IdentPart, n) when intail -> + | Utf8Token (st, n) when not intail && Unicode.is_valid_ident_initial st -> njunk n s; loop_id true s + | Utf8Token (st, n) when intail && Unicode.is_valid_ident_trailing st -> njunk n s; loop_id true s | EmptyStream -> () @@ -311,9 +311,9 @@ let rec ident_tail loc len = parser ident_tail loc (store len c) s | [< s >] -> match lookup_utf8 loc s with - | Utf8Token ((Unicode.IdentPart | Unicode.Letter), n) -> + | Utf8Token (st, n) when Unicode.is_valid_ident_trailing st -> ident_tail loc (nstore n len s) s - | Utf8Token (Unicode.Unknown, n) -> + | Utf8Token (st, n) when Unicode.is_unknown st -> let id = get_buff len in let u = String.concat "" (List.map (String.make 1) (Stream.npeek n s)) in warn_unrecognized_unicode ~loc:!@loc (u,id); len @@ -539,7 +539,7 @@ let parse_after_dot loc c bp = (try find_keyword loc ("."^field) s with Not_found -> FIELD field) | [< s >] -> match lookup_utf8 loc s with - | Utf8Token (Unicode.Letter, n) -> + | Utf8Token (st, n) when Unicode.is_valid_ident_initial st -> let len = ident_tail loc (nstore n 0 s) s in let field = get_buff len in (try find_keyword loc ("."^field) s with Not_found -> FIELD field) @@ -553,7 +553,7 @@ let parse_after_qmark loc bp s = | None -> KEYWORD "?" | _ -> match lookup_utf8 loc s with - | Utf8Token (Unicode.Letter, _) -> LEFTQMARK + | Utf8Token (st, _) when Unicode.is_valid_ident_initial st -> LEFTQMARK | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars loc bp '?' s) @@ -618,13 +618,13 @@ let rec next_token loc = parser bp comment_stop bp; between_commands := new_between_commands; t | [< s >] -> match lookup_utf8 loc s with - | Utf8Token (Unicode.Letter, n) -> + | Utf8Token (st, n) when Unicode.is_valid_ident_initial st -> let len = ident_tail loc (nstore n 0 s) s in let id = get_buff len in let ep = Stream.count s in comment_stop bp; (try find_keyword loc id s with Not_found -> IDENT id), set_loc_pos loc bp ep - | AsciiChar | Utf8Token ((Unicode.Symbol | Unicode.IdentPart | Unicode.Unknown), _) -> + | AsciiChar | Utf8Token _ -> let t = process_chars loc bp (Stream.next s) s in comment_stop bp; t | EmptyStream -> diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 819d236cd3..3e0b85b54a 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -1020,8 +1020,7 @@ GEXTEND Gram | IDENT "Term"; qid = smart_global -> LocateTerm qid | IDENT "File"; f = ne_string -> LocateFile f | IDENT "Library"; qid = global -> LocateLibrary qid - | IDENT "Module"; qid = global -> LocateModule qid - | IDENT "Ltac"; qid = global -> LocateTactic qid ] ] + | IDENT "Module"; qid = global -> LocateModule qid ] ] ; option_value: [ [ n = integer -> IntValue (Some n) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index f503c572d0..3c46d5c43b 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -342,7 +342,7 @@ let rec extract_structure env mp reso ~all = function and extract_mexpr env mp = function | MEwith _ -> assert false (* no 'with' syntax for modules *) - | me when lang () != Ocaml -> + | me when lang () != Ocaml || Table.is_extrcompute () -> (* In Haskell/Scheme, we expand everything. For now, we also extract everything, dead code will be removed later (see [Modutil.optimize_struct]. *) @@ -570,11 +570,12 @@ let print_structure_to_file (fn,si,mo) dry struc = let reset () = Visit.reset (); reset_tables (); reset_renaming_tables Everything -let init modular library = +let init ?(compute=false) modular library = check_inside_section (); check_inside_module (); set_keywords (descr ()).keywords; set_modular modular; set_library library; + set_extrcompute compute; reset (); if modular && lang () == Scheme then error_scheme () @@ -684,8 +685,22 @@ let extraction_library is_rec m = List.iter print struc; reset () +(** For extraction compute, we flatten all the module structure, + getting rid of module types or unapplied functors *) + +let flatten_structure struc = + let rec flatten_elem (lab,elem) = match elem with + |SEdecl d -> [d] + |SEmodtype _ -> [] + |SEmodule m -> match m.ml_mod_expr with + |MEfunctor _ -> [] + |MEident _ | MEapply _ -> assert false (* should be expanded *) + |MEstruct (_,elems) -> flatten_elems elems + and flatten_elems l = List.flatten (List.map flatten_elem l) + in flatten_elems (List.flatten (List.map snd struc)) + let structure_for_compute c = - init false false; + init false false ~compute:true; let env = Global.env () in let ast, mlt = Extraction.extract_constr env c in let ast = Mlutil.normalize ast in @@ -694,8 +709,7 @@ let structure_for_compute c = 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 + (flatten_structure struc), ast, mlt (* For the test-suite : extraction to a temporary file + run ocamlc on it *) diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 5769ff1176..7bbb825b10 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -34,5 +34,4 @@ val print_one_decl : (* Used by Extraction Compute *) val structure_for_compute : - Term.constr -> - Miniml.ml_flat_structure * Miniml.ml_ast * Miniml.ml_type + Term.constr -> (Miniml.ml_decl list) * Miniml.ml_ast * Miniml.ml_type diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index edebba49df..5e967ef379 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -187,8 +187,6 @@ type ml_structure = (ModPath.t * ml_module_structure) list type ml_signature = (ModPath.t * ml_module_sig) list -type ml_flat_structure = ml_structure_elem list - type unsafe_needs = { mldummy : bool; tdummy : bool; diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index a4c2bcd883..b01b0198d5 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -127,11 +127,15 @@ let rec mgu = function | Taxiom, Taxiom -> () | _ -> raise Impossible -let needs_magic p = try mgu p; false with Impossible -> true +let skip_typing () = lang () == Scheme || is_extrcompute () -let put_magic_if b a = if b && lang () != Scheme then MLmagic a else a +let needs_magic p = + if skip_typing () then false + else try mgu p; false with Impossible -> true -let put_magic p a = if needs_magic p && lang () != Scheme then MLmagic a else a +let put_magic_if b a = if b then MLmagic a else a + +let put_magic p a = if needs_magic p then MLmagic a else a let generalizable a = lang () != Ocaml || @@ -769,6 +773,20 @@ let eta_red e = else e | _ -> e +(* Performs an eta-reduction when the core is atomic, + or otherwise returns None *) + +let atomic_eta_red e = + let ids,t = collect_lams e in + let n = List.length ids in + match t with + | MLapp (f,a) when test_eta_args_lift 0 n a -> + (match f with + | MLrel k when k>n -> Some (MLrel (k-n)) + | MLglob _ | MLexn _ | MLdummy _ -> Some f + | _ -> None) + | _ -> None + (*s Computes all head linear beta-reductions possible in [(t a)]. Non-linear head beta-redex become let-in. *) @@ -1053,6 +1071,10 @@ let rec simpl o = function simpl o (MLcase(typ,e,br')) | MLmagic(MLdummy _ as e) when lang () == Haskell -> e | MLmagic(MLexn _ as e) -> e + | MLlam _ as e -> + (match atomic_eta_red e with + | Some e' -> e' + | None -> ast_map (simpl o) e) | a -> ast_map (simpl o) a (* invariant : list [a] of arguments is non-empty *) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 30e3b520f9..995d5fd19d 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -250,6 +250,11 @@ let modular () = !modular_ref let set_library b = library_ref := b let library () = !library_ref +let extrcompute = ref false + +let set_extrcompute b = extrcompute := b +let is_extrcompute () = !extrcompute + (*s Printing. *) (* The following functions work even on objects not in [Global.env ()]. diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 7e47d0bc81..cc93f294b3 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -165,6 +165,9 @@ val modular : unit -> bool val set_library : bool -> unit val library : unit -> bool +val set_extrcompute : bool -> unit +val is_extrcompute : unit -> bool + (*s Table for custom inlining *) val to_inline : global_reference -> bool diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index 86c983bdd9..d639dd0e1c 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -482,6 +482,11 @@ VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY [ Feedback.msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] END +VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY +| [ "Locate" "Ltac" reference(r) ] -> + [ Tacentries.print_located_tactic r ] +END + let pr_ltac_ref = Libnames.pr_reference let pr_tacdef_body tacdef_body = diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index 12b4c81fc4..3972b7aac3 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -1,9 +1,9 @@ Tacarg +Tacsubst +Tacenv Pptactic Pltac Taccoerce -Tacsubst -Tacenv Tactic_debug Tacintern Tacentries diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index d8bd166208..d588c888c4 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -336,7 +336,7 @@ type 'a extra_genarg_printer = let pr_ltac_constant kn = if !Flags.in_debugger then KerName.print kn else try - pr_qualid (Nametab.shortest_qualid_of_tactic kn) + pr_qualid (Tacenv.shortest_qualid_of_tactic kn) with Not_found -> (* local tactic not accessible anymore *) str "<" ++ KerName.print kn ++ str ">" diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index c79d5b389f..d9da954fe6 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -93,7 +93,7 @@ val pr_alias_key : Names.KerName.t -> Pp.t val pr_alias : (Val.t -> Pp.t) -> int -> Names.KerName.t -> Val.t list -> Pp.t -val pr_ltac_constant : Nametab.ltac_constant -> Pp.t +val pr_ltac_constant : ltac_constant -> Pp.t val pr_raw_tactic : raw_tactic_expr -> Pp.t diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index a8d518fbd8..bcd5b388a1 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -409,7 +409,7 @@ let create_ltac_quotation name cast (e, l) = type tacdef_kind = | NewTac of Id.t - | UpdateTac of Nametab.ltac_constant + | UpdateTac of Tacexpr.ltac_constant let is_defined_tac kn = try ignore (Tacenv.interp_ltac kn); true with Not_found -> false @@ -441,7 +441,7 @@ let register_ltac local tacl = | Tacexpr.TacticRedefinition (ident, body) -> let loc = loc_of_reference ident in let kn = - try Nametab.locate_tactic (snd (qualid_of_reference ident)) + try Tacenv.locate_tactic (snd (qualid_of_reference ident)) with Not_found -> CErrors.user_err ?loc (str "There is no Ltac named " ++ pr_reference ident ++ str ".") @@ -464,7 +464,7 @@ let register_ltac local tacl = 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 iter_rec (sp, kn) = Tacenv.push_tactic (Nametab.Until 1) sp kn in let () = List.iter iter_rec recvars in List.map map rfun in @@ -475,7 +475,7 @@ let register_ltac local tacl = Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is defined") | UpdateTac kn -> Tacenv.redefine_ltac local kn tac; - let name = Nametab.shortest_qualid_of_tactic kn in + let name = Tacenv.shortest_qualid_of_tactic kn in Flags.if_verbose Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined") in List.iter iter defs @@ -488,7 +488,7 @@ let print_ltacs () = let entries = List.sort sort entries in let map (kn, entry) = let qid = - try Some (Nametab.shortest_qualid_of_tactic kn) + try Some (Tacenv.shortest_qualid_of_tactic kn) with Not_found -> None in match qid with @@ -506,6 +506,31 @@ let print_ltacs () = in Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) +let locatable_ltac = "Ltac" + +let () = + let open Prettyp in + let locate qid = try Some (Tacenv.locate_tactic qid) with Not_found -> None in + let locate_all = Tacenv.locate_extended_all_tactic in + let shortest_qualid = Tacenv.shortest_qualid_of_tactic in + let name kn = str "Ltac" ++ spc () ++ pr_path (Tacenv.path_of_tactic kn) in + let print kn = + let qid = qualid_of_path (Tacenv.path_of_tactic kn) in + Tacintern.print_ltac qid + in + let about = name in + register_locatable locatable_ltac { + locate; + locate_all; + shortest_qualid; + name; + print; + about; + } + +let print_located_tactic qid = + Feedback.msg_notice (Prettyp.print_located_other locatable_ltac qid) + (** Grammar *) let () = diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index aa8f4efe65..ab2c6b3073 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -62,3 +62,6 @@ val create_ltac_quotation : string -> val print_ltacs : unit -> unit (** Display the list of ltac definitions currently available. *) + +val print_located_tactic : Libnames.reference -> unit +(** Display the absolute name of a tactic. *) diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index 13b44f0e2c..8c59a36fa6 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -11,6 +11,42 @@ open Pp open Names open Tacexpr +(** Nametab for tactics *) + +(** TODO: Share me somewhere *) +module FullPath = +struct + open Libnames + 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 KnTab = Nametab.Make(FullPath)(KerName) + +let tactic_tab = Summary.ref ~name:"LTAC-NAMETAB" (KnTab.empty, KNmap.empty) + +let push_tactic vis sp kn = + let (tab, revtab) = !tactic_tab in + let tab = KnTab.push vis sp kn tab in + let revtab = KNmap.add kn sp revtab in + tactic_tab := (tab, revtab) + +let locate_tactic qid = KnTab.locate qid (fst !tactic_tab) + +let locate_extended_all_tactic qid = KnTab.find_prefixes qid (fst !tactic_tab) + +let exists_tactic kn = KnTab.exists kn (fst !tactic_tab) + +let path_of_tactic kn = KNmap.find kn (snd !tactic_tab) + +let shortest_qualid_of_tactic kn = + let sp = KNmap.find kn (snd !tactic_tab) in + KnTab.shortest_qualid Id.Set.empty sp (fst !tactic_tab) + (** Tactic notations (TacAlias) *) type alias = KerName.t @@ -103,19 +139,19 @@ let replace kn path t = 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 + let () = if not local then 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 + let () = if not local then 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 + let () = push_tactic (Until 1) sp kn in add kn b t | Some kn0 -> replace kn0 kn t @@ -128,7 +164,7 @@ let subst_md (subst, (local, id, b, t)) = let classify_md (local, _, _, _ as o) = Substitute o -let inMD : bool * Nametab.ltac_constant option * bool * glob_tactic_expr -> obj = +let inMD : bool * ltac_constant option * bool * glob_tactic_expr -> obj = declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; diff --git a/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli index 958109e5a7..4ecc978fea 100644 --- a/plugins/ltac/tacenv.mli +++ b/plugins/ltac/tacenv.mli @@ -7,11 +7,21 @@ (************************************************************************) open Names +open Libnames open Tacexpr open Geninterp (** This module centralizes the various ways of registering tactics. *) +(** {5 Tactic naming} *) + +val push_tactic : Nametab.visibility -> full_path -> ltac_constant -> unit +val locate_tactic : qualid -> ltac_constant +val locate_extended_all_tactic : qualid -> ltac_constant list +val exists_tactic : full_path -> bool +val path_of_tactic : ltac_constant -> full_path +val shortest_qualid_of_tactic : ltac_constant -> qualid + (** {5 Tactic notations} *) type alias = KerName.t diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 64da097deb..2c36faeff4 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -10,13 +10,14 @@ open Loc open Names open Constrexpr open Libnames -open Nametab open Genredexpr open Genarg open Pattern open Misctypes open Locus +type ltac_constant = KerName.t + type direction_flag = bool (* true = Left-to-right false = right-to-right *) type lazy_flag = | General (* returns all possible successes *) diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index fc6ee6aab6..99d7684d36 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -118,7 +118,7 @@ let intern_constr_reference strict ist = function let intern_isolated_global_tactic_reference r = let (loc,qid) = qualid_of_reference r in - TacCall (Loc.tag ?loc (ArgArg (loc,locate_tactic qid),[])) + TacCall (Loc.tag ?loc (ArgArg (loc,Tacenv.locate_tactic qid),[])) let intern_isolated_tactic_reference strict ist r = (* An ltac reference *) @@ -137,7 +137,7 @@ let intern_isolated_tactic_reference strict ist r = let intern_applied_global_tactic_reference r = let (loc,qid) = qualid_of_reference r in - ArgArg (loc,locate_tactic qid) + ArgArg (loc,Tacenv.locate_tactic qid) let intern_applied_tactic_reference ist r = (* An ltac reference *) @@ -722,7 +722,7 @@ let pr_ltac_fun_arg n = spc () ++ Name.print n let print_ltac id = try - let kn = Nametab.locate_tactic id in + let kn = Tacenv.locate_tactic id in let entries = Tacenv.ltac_entries () in let tac = KNmap.find kn entries in let filter mp = diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 18348bc113..20f117ff4f 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1394,7 +1394,13 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = 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 + | (VFun(appl,trace,olfun,[],body)) -> + let extra_args = List.length largs in + Tacticals.New.tclZEROMSG (str "Illegal tactic application: got " ++ + str (string_of_int extra_args) ++ + str " extra " ++ str (String.plural extra_args "argument") ++ + str ".") + | VRec(_,_) -> fail else fail (* Gives the tactic corresponding to the tactic value *) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index cf5fdf3184..d37c676e38 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -814,8 +814,8 @@ let ssr_n_tac seed n gl = let name = if n = -1 then seed else ("ssr" ^ seed ^ string_of_int n) in let fail msg = CErrors.user_err (Pp.str msg) in let tacname = - try Nametab.locate_tactic (Libnames.qualid_of_ident (Id.of_string name)) - with Not_found -> try Nametab.locate_tactic (ssrqid name) + try Tacenv.locate_tactic (Libnames.qualid_of_ident (Id.of_string name)) + with Not_found -> try Tacenv.locate_tactic (ssrqid name) with Not_found -> if n = -1 then fail "The ssreflect library was not loaded" else fail ("The tactic "^name^" was not found") in diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 1e1a986daa..7b591feada 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -1554,8 +1554,8 @@ END let ssrautoprop gl = try let tacname = - try Nametab.locate_tactic (qualid_of_ident (Id.of_string "ssrautoprop")) - with Not_found -> Nametab.locate_tactic (ssrqid "ssrautoprop") in + try Tacenv.locate_tactic (qualid_of_ident (Id.of_string "ssrautoprop")) + with Not_found -> Tacenv.locate_tactic (ssrqid "ssrautoprop") in let tacexpr = Loc.tag @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in Proofview.V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl with Not_found -> Proofview.V82.of_tactic (Auto.full_trivial []) gl diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 2e5522b83f..e3e34616bf 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -502,16 +502,16 @@ let ungen_upat lhs (sigma, uc, t) u = 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 + let nargs_of_proj t = match kind_of_term t 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 + | _ -> assert false 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 -> nargs_of_proj u.up_f + | Proj (c',_) when Constant.equal (Projection.constant c') pc -> nargs_of_proj u.up_f | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) | _ -> -1 with Not_found -> -1 diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 39c2ceeba8..1038945c18 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -5,13 +5,11 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open CErrors open Term open Vars open Environ open Reduction -open Univ open Declarations open Names open Inductive @@ -20,8 +18,6 @@ open Nativecode open Nativevalues open Context.Rel.Declaration -module RelDecl = Context.Rel.Declaration - (** This module implements normalization by evaluation to OCaml code *) exception Find_at of int @@ -177,44 +173,6 @@ let build_case_type dep p realargs c = if dep then mkApp(mkApp(p, realargs), [|c|]) else mkApp(p, realargs) -(* TODO move this function *) -let type_of_rel env n = - env |> lookup_rel n |> RelDecl.get_type |> lift n - -let type_of_prop = mkSort type1_sort - -let type_of_sort s = - match s with - | Prop _ -> type_of_prop - | Type u -> mkType (Univ.super u) - -let type_of_var env id = - let open Context.Named.Declaration in - try env |> lookup_named id |> get_type - with Not_found -> - anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound.") - -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 (sup u1 type0_univ) - (* Product rule (Prop,Type_i,Type_i) *) - | (Prop Pos, Type u2) -> Type (sup 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 (sup u1 u2) - (* normalisation of values *) let branch_of_switch lvl ans bs = @@ -328,15 +286,15 @@ and nf_atom_type env sigma atom = match atom with | Arel i -> let n = (nb_rel env - i) in - mkRel n, type_of_rel env n + mkRel n, Typeops.type_of_relative env n | Aconstant cst -> mkConstU cst, Typeops.type_of_constant_in env cst | Aind ind -> mkIndU ind, Inductiveops.type_of_inductive env ind | Asort s -> - mkSort s, type_of_sort s + mkSort s, Typeops.type_of_sort s | Avar id -> - mkVar id, type_of_var env id + mkVar id, Typeops.type_of_variable env id | Acase(ans,accu,p,bs) -> let a,ta = nf_accu_type env sigma accu in let ((mind,_),u as ind),allargs = find_rectype_a env ta in @@ -387,7 +345,7 @@ and nf_atom_type env sigma atom = let vn = mk_rel_accu (nb_rel env) in let env = push_rel (LocalAssum (n,dom)) env in let codom,s2 = nf_type_sort env sigma (codom vn) in - mkProd(n,dom,codom), mkSort (sort_of_product env s1 s2) + mkProd(n,dom,codom), Typeops.type_of_product env n s1 s2 | Aevar(ev,ty) -> let ty = nf_type env sigma ty in mkEvar ev, ty diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 079524f344..56f8b33e01 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -214,7 +214,6 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty = type_of_inductive_knowing_conclusion env sigma (spec, EInstance.kind sigma u) conclty | Const (cst, u) -> let t = constant_type_in env (cst, EInstance.kind sigma u) in - (* TODO *) sigma, EConstr.of_constr t | Var id -> sigma, type_of_var env id | Construct (cstr, u) -> sigma, EConstr.of_constr (type_of_constructor env (cstr, EInstance.kind sigma u)) diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 10dd42ea91..a1cdfdbaa2 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -1156,7 +1156,7 @@ open Decl_kinds | LocateFile f -> keyword "File" ++ spc() ++ qs f | LocateLibrary qid -> keyword "Library" ++ spc () ++ pr_module qid | LocateModule qid -> keyword "Module" ++ spc () ++ pr_module qid - | LocateTactic qid -> keyword "Ltac" ++ spc () ++ pr_ltac_ref qid + | LocateOther (s, qid) -> keyword s ++ spc () ++ pr_ltac_ref qid in return (keyword "Locate" ++ spc() ++ pr_locate loc) | VernacRegister (id, RegisterInline) -> diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 09859157c3..2077526db4 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -304,14 +304,33 @@ let print_inductive_argument_scopes = (*********************) (* "Locate" commands *) +type 'a locatable_info = { + locate : qualid -> 'a option; + locate_all : qualid -> 'a list; + shortest_qualid : 'a -> qualid; + name : 'a -> Pp.t; + print : 'a -> Pp.t; + about : 'a -> Pp.t; +} + +type locatable = Locatable : 'a locatable_info -> locatable + type logical_name = | Term of global_reference | Dir of global_dir_reference | Syntactic of kernel_name | ModuleType of module_path - | Tactic of Nametab.ltac_constant + | Other : 'a * 'a locatable_info -> logical_name | Undefined of qualid +(** Generic table for objects that are accessible through a name. *) +let locatable_map : locatable String.Map.t ref = ref String.Map.empty + +let register_locatable name f = + locatable_map := String.Map.add name (Locatable f) !locatable_map + +exception ObjFound of logical_name + let locate_any_name ref = let (loc,qid) = qualid_of_reference ref in try Term (Nametab.locate qid) @@ -321,7 +340,13 @@ let locate_any_name ref = try Dir (Nametab.locate_dir qid) with Not_found -> try ModuleType (Nametab.locate_modtype qid) - with Not_found -> Undefined qid + with Not_found -> + let iter _ (Locatable info) = match info.locate qid with + | None -> () + | Some ans -> raise (ObjFound (Other (ans, info))) + in + try String.Map.iter iter !locatable_map; Undefined qid + with ObjFound obj -> obj let pr_located_qualid = function | Term ref -> @@ -344,8 +369,7 @@ let pr_located_qualid = function str s ++ spc () ++ pr_dirpath dir | ModuleType mp -> str "Module Type" ++ spc () ++ pr_path (Nametab.path_of_modtype mp) - | Tactic kn -> - str "Ltac" ++ spc () ++ pr_path (Nametab.path_of_tactic kn) + | Other (obj, info) -> info.name obj | Undefined qid -> pr_qualid qid ++ spc () ++ str "not a defined object." @@ -383,10 +407,6 @@ let locate_term qid = in List.map expand (Nametab.locate_extended_all qid) -let locate_tactic qid = - let all = Nametab.locate_extended_all_tactic qid in - List.map (fun kn -> (Tactic kn, Nametab.shortest_qualid_of_tactic kn)) all - let locate_module qid = let all = Nametab.locate_extended_all_dir qid in let map dir = match dir with @@ -408,13 +428,30 @@ let locate_modtype qid = in modtypes @ List.map_filter map all +let locate_other s qid = + let Locatable info = String.Map.find s !locatable_map in + let ans = info.locate_all qid in + let map obj = (Other (obj, info), info.shortest_qualid obj) in + List.map map ans + +type locatable_kind = +| LocTerm +| LocModule +| LocOther of string +| LocAny + let print_located_qualid name flags ref = let (loc,qid) = qualid_of_reference ref in - let located = [] in - let located = if List.mem `LTAC flags then locate_tactic qid @ located else located in - let located = if List.mem `MODTYPE flags then locate_modtype qid @ located else located in - let located = if List.mem `MODULE flags then locate_module qid @ located else located in - let located = if List.mem `TERM flags then locate_term qid @ located else located in + let located = match flags with + | LocTerm -> locate_term qid + | LocModule -> locate_modtype qid @ locate_module qid + | LocOther s -> locate_other s qid + | LocAny -> + locate_term qid @ + locate_modtype qid @ + locate_module qid @ + String.Map.fold (fun s _ accu -> locate_other s qid @ accu) !locatable_map [] + in match located with | [] -> let (dir,id) = repr_qualid qid in @@ -432,10 +469,10 @@ let print_located_qualid name flags ref = else mt ()) ++ display_alias o)) l -let print_located_term ref = print_located_qualid "term" [`TERM] ref -let print_located_tactic ref = print_located_qualid "tactic" [`LTAC] ref -let print_located_module ref = print_located_qualid "module" [`MODULE; `MODTYPE] ref -let print_located_qualid ref = print_located_qualid "object" [`TERM; `LTAC; `MODULE; `MODTYPE] ref +let print_located_term ref = print_located_qualid "term" LocTerm ref +let print_located_other s ref = print_located_qualid s (LocOther s) ref +let print_located_module ref = print_located_qualid "module" LocModule ref +let print_located_qualid ref = print_located_qualid "object" LocAny ref (******************************************) (**** Printing declarations and judgments *) @@ -765,7 +802,7 @@ let print_any_name = function | Dir (DirModule(dirpath,(mp,_))) -> print_module (printable_body dirpath) mp | Dir _ -> mt () | ModuleType mp -> print_modtype mp - | Tactic kn -> mt () (** TODO *) + | Other (obj, info) -> info.print obj | Undefined qid -> try (* Var locale de but, pas var de section... donc pas d'implicits *) let dir,str = repr_qualid qid in @@ -822,8 +859,9 @@ let print_about_any ?loc k = v 0 ( print_syntactic_def kn ++ fnl () ++ hov 0 (str "Expands to: " ++ pr_located_qualid k)) - | Dir _ | ModuleType _ | Tactic _ | Undefined _ -> + | Dir _ | ModuleType _ | Undefined _ -> hov 0 (pr_located_qualid k) + | Other (obj, info) -> hov 0 (info.about obj) let print_about = function | ByNotation (loc,(ntn,sc)) -> diff --git a/printing/prettyp.mli b/printing/prettyp.mli index f4277b6c50..dbd1011593 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -50,12 +50,34 @@ val print_all_instances : unit -> Pp.t val inspect : int -> Pp.t -(** Locate *) +(** {5 Locate} *) + +type 'a locatable_info = { + locate : qualid -> 'a option; + (** Locate the most precise object with the provided name if any. *) + locate_all : qualid -> 'a list; + (** Locate all objects whose name is a suffix of the provided name *) + shortest_qualid : 'a -> qualid; + (** Return the shortest name in the current context *) + name : 'a -> Pp.t; + (** Data as printed by the Locate command *) + print : 'a -> Pp.t; + (** Data as printed by the Print command *) + about : 'a -> Pp.t; + (** Data as printed by the About command *) +} +(** Generic data structure representing locatable objects. *) + +val register_locatable : string -> 'a locatable_info -> unit +(** Define a new type of locatable objects that can be reached via the + corresponding generic vernacular commands. The string should be a unique + name describing the kind of objects considered and that is added as a + grammar command prefix for vernacular commands Locate. *) val print_located_qualid : reference -> Pp.t val print_located_term : reference -> Pp.t -val print_located_tactic : reference -> Pp.t val print_located_module : reference -> Pp.t +val print_located_other : string -> reference -> Pp.t type object_pr = { print_inductive : mutual_inductive -> Pp.t; diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index f80cb7cc66..4f575ab4be 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -110,10 +110,6 @@ module Strict = struct let push (b:t) pr = focus bullet_cond (b::get_bullets pr) 1 pr - (* Used only in the next function. - TODO: use a recursive function instead? *) - exception SuggestFound of t - let suggest_bullet (prf : proof): suggestion = if is_done prf then ProofFinished else if not (no_focused_goal prf) @@ -122,24 +118,24 @@ module Strict = struct | b::_ -> Unfinished b | _ -> NoBulletInUse else (* There is no goal under focus but some are unfocussed, - let us look at the bullet needed. If no *) - let pcobaye = ref prf in - try - while true do - let pcobaye', b = pop !pcobaye in - (* pop went well, this means that there are no more goals - *under this* bullet b, see if a new b can be pushed. *) - (try let _ = push b pcobaye' in (* push didn't fail so a new b can be pushed. *) - raise (SuggestFound b) - with SuggestFound _ as e -> raise e - | _ -> ()); (* b could not be pushed, so we must look for a outer bullet *) - pcobaye := pcobaye' - done; - assert false - with SuggestFound b -> Suggest b - | _ -> NeedClosingBrace (* No push was possible, but there are still - subgoals somewhere: there must be a "}" to use. *) - + let us look at the bullet needed. *) + let rec loop prf = + match pop prf with + | prf, b -> + (* pop went well, this means that there are no more goals + *under this* bullet b, see if a new b can be pushed. *) + begin + try ignore (push b prf); Suggest b + with _ -> + (* b could not be pushed, so we must look for a outer bullet *) + loop prf + end + | exception _ -> + (* No pop was possible, but there are still + subgoals somewhere: there must be a "}" to use. *) + NeedClosingBrace + in + loop prf let rec pop_until (prf : proof) bul : proof = let prf', b = pop prf in diff --git a/stm/stm.ml b/stm/stm.ml index 7c44fc86fb..2c5e9ed819 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -64,11 +64,6 @@ let call_process_error_once = end -(* During interactive use we cache more states so that Undoing is fast *) -let interactive () = - if !Flags.ide_slave || not !Flags.batch_mode then `Yes - else `No - let async_proofs_workers_extra_env = ref [||] type aast = { @@ -253,6 +248,12 @@ end (* }}} *) (*************************** THE DOCUMENT *************************************) (******************************************************************************) +(* The main document type associated to a VCS *) +type stm_doc_type = + | VoDoc of Names.DirPath.t + | VioDoc of Names.DirPath.t + | Interactive of Names.DirPath.t + (* Imperative wrap around VCS to obtain _the_ VCS that is the * representation of the document Coq is currently processing *) module VCS : sig @@ -269,7 +270,10 @@ module VCS : sig type vcs = (branch_type, transaction, vcs state_info, box) Vcs_.t - val init : id -> unit + val init : stm_doc_type -> id -> unit + (* val get_type : unit -> stm_doc_type *) + val is_interactive : unit -> [`Yes | `No | `Shallow] + val is_vio_doc : unit -> bool val current_branch : unit -> Branch.t val checkout : Branch.t -> unit @@ -451,10 +455,25 @@ end = struct (* {{{ *) type vcs = (branch_type, transaction, vcs state_info, box) t let vcs : vcs ref = ref (empty Stateid.dummy) - let init id = + let doc_type = ref (Interactive (Names.DirPath.make [])) + + let init dt id = + doc_type := dt; vcs := empty id; vcs := set_info !vcs id (default_info ()) + (* let get_type () = !doc_type *) + + let is_interactive () = + match !doc_type with + | Interactive _ -> `Yes + | _ -> `No + + let is_vio_doc () = + match !doc_type with + | VioDoc _ -> true + | _ -> false + let current_branch () = current_branch !vcs let checkout head = vcs := checkout !vcs head @@ -765,7 +784,7 @@ end = struct (* {{{ *) | { state = Error ie } -> cur_id := id; Exninfo.iraise ie | _ -> (* coqc has a 1 slot cache and only for valid states *) - if interactive () = `No && Stateid.equal id !cur_id then () + if VCS.is_interactive () = `No && Stateid.equal id !cur_id then () else anomaly Pp.(str "installing a non cached state.") let get_cached id = @@ -1044,8 +1063,18 @@ end = struct (* {{{ *) match f acc (id, vcs, ids, tactic, undo) with | `Stop x -> x | `Cont acc -> next acc - + + let undo_costly_in_batch_mode = + CWarnings.create ~name:"undo-batch-mode" ~category:"non-interactive" Pp.(fun v -> + str "Command " ++ Ppvernac.pr_vernac v ++ + str (" is not recommended in batch mode. In particular, going back in the document" ^ + " is not efficient in batch mode due to Coq not caching previous states for memory optimization reasons." ^ + " If your use is intentional, you may want to disable this warning and pass" ^ + " the \"-async-proofs-cache force\" option to Coq.")) + let undo_vernac_classifier v = + if VCS.is_interactive () = `No && !Flags.async_proofs_cache <> Some Flags.Force + then undo_costly_in_batch_mode v; try match v with | VernacResetInitial -> @@ -1096,7 +1125,7 @@ end = struct (* {{{ *) VtBack (true, oid), VtLater | VernacBacktrack (id,_,_) | VernacBackTo id -> - VtBack (not !Flags.batch_mode, Stateid.of_int id), VtNow + VtBack (VCS.is_interactive () = `Yes, Stateid.of_int id), VtNow | _ -> VtUnknown, VtNow with | Not_found -> @@ -1354,7 +1383,7 @@ end = struct (* {{{ *) let build_proof_here ?loc ~drop_pt (id,valid) eop = Future.create (State.exn_on id ~valid) (fun () -> let wall_clock1 = Unix.gettimeofday () in - if !Flags.batch_mode then Reach.known_state ~cache:`No eop + if VCS.is_interactive () = `No then Reach.known_state ~cache:`No eop else Reach.known_state ~cache:`Shallow eop; let wall_clock2 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc "proof_build_time" @@ -1491,7 +1520,6 @@ end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(ProofTask) let queue = ref None - let init () = if Flags.async_proofs_is_master () then queue := Some (TaskQueue.create !Flags.async_proofs_n_workers) @@ -1627,7 +1655,7 @@ end = struct (* {{{ *) let id, valid as t_exn_info = exn_info in let cancel_switch = ref false in if TaskQueue.n_workers (Option.get !queue) = 0 then - if !Flags.compilation_mode = Flags.BuildVio then begin + if VCS.is_vio_doc () then begin let f,assign = Future.create_delegate ~blocking:true ~name:pname (State.exn_on id ~valid) in let t_uuid = Future.uuid f in @@ -1952,14 +1980,14 @@ let pstate = summary_pstate let async_policy () = let open Flags in if is_universe_polymorphism () then false - else if interactive () = `Yes then + else if VCS.is_interactive () = `Yes then (async_proofs_is_master () || !async_proofs_mode = APonLazy) else - (!compilation_mode = BuildVio || !async_proofs_mode <> APoff) + (VCS.is_vio_doc () || !async_proofs_mode <> APoff) let delegate name = get_hint_bp_time name >= !Flags.async_proofs_delegation_threshold - || !Flags.compilation_mode = Flags.BuildVio + || VCS.is_vio_doc () || !Flags.async_proofs_full let warn_deprecated_nested_proofs = @@ -2020,7 +2048,7 @@ let collect_proof keep cur hd brkind id = `ASync (parent last,accn,name,delegate name) | `Fork((_, hd', GuaranteesOpacity, ids), _) when has_proof_no_using last && not (State.is_cached_and_valid (parent last)) && - !Flags.compilation_mode = Flags.BuildVio -> + VCS.is_vio_doc () -> assert (VCS.Branch.equal hd hd'||VCS.Branch.equal hd VCS.edit_branch); (try let name, hint = name ids, get_hint_ctx loc in @@ -2329,9 +2357,20 @@ end (* }}} *) (********************************* STM API ************************************) (******************************************************************************) -let init () = - VCS.init Stateid.initial; +type stm_init_options = { + doc_type : stm_doc_type; +(* + fb_handler : Feedback.feedback -> unit; + iload_path : (string list * string * bool) list; + require_libs : (Names.DirPath.t * string * bool option) list; + implicit_std : bool; +*) +} + +let init { doc_type } = + VCS.init doc_type Stateid.initial; set_undo_classifier Backtrack.undo_vernac_classifier; + (* we declare the library here XXX: *) State.define ~cache:`Yes (fun () -> ()) Stateid.initial; Backtrack.record (); Slaves.init (); @@ -2352,7 +2391,7 @@ let init () = let observe id = let vcs = VCS.backup () in try - Reach.known_state ~cache:(interactive ()) id; + Reach.known_state ~cache:(VCS.is_interactive ()) id; VCS.print () with e -> let e = CErrors.push e in @@ -2508,7 +2547,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) stm_prerr_endline (fun () -> "undo to state " ^ Stateid.to_string id); Backtrack.backto id; VCS.checkout_shallowest_proof_branch (); - Reach.known_state ~cache:(interactive ()) id; `Ok + Reach.known_state ~cache:(VCS.is_interactive ()) id; `Ok | VtBack (false, id), VtLater -> anomaly(str"classifier: VtBack + VtLater must imply part_of_script.") @@ -2526,7 +2565,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) let id = VCS.new_node ~id:newtip () in let queue = if !Flags.async_proofs_full then `QueryQueue (ref false) - else if Flags.(!compilation_mode = BuildVio) && + else if VCS.is_vio_doc () && VCS.((get_branch head).kind = `Master) && may_pierce_opaque x then `SkipQueue @@ -2616,7 +2655,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) let step () = VCS.checkout VCS.Branch.master; let mid = VCS.get_branch_pos VCS.Branch.master in - Reach.known_state ~cache:(interactive ()) mid; + Reach.known_state ~cache:(VCS.is_interactive ()) mid; stm_vernac_interp id x; (* Vernac x may or may not start a proof *) if not in_proof && Proof_global.there_are_pending_proofs () then @@ -2824,7 +2863,7 @@ let edit_at id = VCS.edit_branch (`Edit (mode, qed_id, master_id, keep, old_branch)); VCS.delete_boxes_of id; cancel_switch := true; - Reach.known_state ~cache:(interactive ()) id; + Reach.known_state ~cache:(VCS.is_interactive ()) id; VCS.checkout_shallowest_proof_branch (); `Focus { stop = qed_id; start = master_id; tip } in let no_edit = function @@ -2847,7 +2886,7 @@ let edit_at id = VCS.gc (); VCS.print (); if not !Flags.async_proofs_full then - Reach.known_state ~cache:(interactive ()) id; + Reach.known_state ~cache:(VCS.is_interactive ()) id; VCS.checkout_shallowest_proof_branch (); `NewTip in try @@ -2876,7 +2915,7 @@ let edit_at id = | true, None, _ -> if on_cur_branch id then begin VCS.reset_branch (VCS.current_branch ()) id; - Reach.known_state ~cache:(interactive ()) id; + Reach.known_state ~cache:(VCS.is_interactive ()) id; VCS.checkout_shallowest_proof_branch (); `NewTip end else if is_ancestor_of_cur_branch id then begin diff --git a/stm/stm.mli b/stm/stm.mli index 3f01fca013..ea8aecaed0 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -10,6 +10,26 @@ open Names (** state-transaction-machine interface *) +(** The STM doc type determines some properties such as what + uncompleted proofs are allowed and recording of aux files. *) +type stm_doc_type = + | VoDoc of DirPath.t + | VioDoc of DirPath.t + | Interactive of DirPath.t + +(* Main initalization routine *) +type stm_init_options = { + doc_type : stm_doc_type; +(* + fb_handler : Feedback.feedback -> unit; + iload_path : (string list * string * bool) list; + require_libs : (Names.DirPath.t * string * bool option) list; + implicit_std : bool; +*) +} + +val init : stm_init_options -> unit + (* [parse_sentence sid pa] Reads a sentence from [pa] with parsing state [sid] Returns [End_of_input] if the stream ends *) val parse_sentence : Stateid.t -> Pcoq.Gram.coq_parsable -> @@ -83,9 +103,6 @@ val finish_tasks : string -> (* Id of the tip of the current branch *) val get_current_state : unit -> Stateid.t -(* Misc *) -val init : unit -> unit - (* This returns the node at that position *) val get_ast : Stateid.t -> (Vernacexpr.vernac_expr Loc.located) option diff --git a/tactics/auto.ml b/tactics/auto.ml index 7aa5114a4f..d0424eb892 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -187,35 +187,34 @@ let _ = add_option ["Info";"Trivial"] global_info_trivial; add_option ["Info";"Auto"] global_info_auto -let no_dbg () = (Off,0,ref []) +type debug_kind = ReportForTrivial | ReportForAuto + +let no_dbg (_,whatfor,_,_) = (Off,whatfor,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). *) + in (d,ReportForTrivial,0,ref []) 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 []) + in (d,ReportForAuto,0,ref []) -let incr_dbg = function (dbg,depth,trace) -> (dbg,depth+1,trace) +let incr_dbg = function (dbg,whatfor,depth,trace) -> (dbg,whatfor,depth+1,trace) (** A tracing tactic for debug/info trivial/auto *) -let tclLOG (dbg,depth,trace) pp tac = +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 + let s = String.make (depth+1) '*' in Proofview.V82.tactic begin fun gl -> try let out = Proofview.V82.of_tactic tac gl in @@ -256,23 +255,23 @@ 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-1) ' ') ++ pp () ++ str "." + str (String.make d ' ') ++ pp () ++ str "." let pr_info_trace = function - | (Info,_,{contents=(d,Some pp)::l}) -> + | (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.") + | (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: *)") + | (Off,_,_,_) -> () + | (Debug,ReportForTrivial,_,_) -> Feedback.msg_debug (str "(* debug trivial: *)") + | (Debug,ReportForAuto,_,_) -> Feedback.msg_debug (str "(* debug auto: *)") + | (Info,ReportForTrivial,_,_) -> Feedback.msg_info (str "(* info trivial: *)") + | (Info,ReportForAuto,_,_) -> Feedback.msg_info (str "(* info auto: *)") let tclTRY_dbg d tac = let delay f = Proofview.tclUNIT () >>= fun () -> f () in @@ -382,7 +381,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= (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) + (trivial_fail_db (no_dbg dbg) (not (Option.is_empty flags)) db_list local_db) | Unfold_nth c -> Proofview.Goal.enter begin fun gl -> if exists_evaluable_reference (Tacmach.New.pf_env gl) c then diff --git a/tactics/tactics.ml b/tactics/tactics.ml index d6c24e9cc9..6f7e61f6ba 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1579,11 +1579,11 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in let indmv = destMeta sigma (nth_arg sigma i elimclause.templval.rebus) in let hypmv = - try match List.remove Int.equal indmv (clenv_independent elimclause) with - | [a] -> a - | _ -> failwith "" - with Failure _ -> user_err ~hdr:"elimination_clause" - (str "The type of elimination clause is not well-formed.") in + match List.remove Int.equal indmv (clenv_independent elimclause) with + | [a] -> a + | _ -> user_err ~hdr:"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 diff --git a/test-suite/Makefile b/test-suite/Makefile index ae426f0daf..61e75fa5d3 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -92,7 +92,7 @@ VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ coqdoc # All subsystems -SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coq-makefile +SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile PREREQUISITELOG = prerequisite/admit.v.log \ prerequisite/make_local.v.log prerequisite/make_notation.v.log @@ -156,6 +156,7 @@ summary: $(call summary_dir, "IDE tests", ide); \ $(call summary_dir, "VI tests", vio); \ $(call summary_dir, "Coqchk tests", coqchk); \ + $(call summary_dir, "Coqwc tests", coqwc); \ $(call summary_dir, "Coq makefile", coq-makefile); \ $(call summary_dir, "Coqdoc tests", coqdoc); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ @@ -498,6 +499,26 @@ coqchk: $(patsubst %.v,%.chk.log,$(wildcard coqchk/*.v)) fi; \ } > "$@" +# coqwc : test output + +coqwc : $(patsubst %.v,%.v.log,$(wildcard coqwc/*.v)) + +coqwc/%.v.log : coqwc/%.v + $(HIDE){ \ + echo $(call log_intro,$<); \ + tmpoutput=`mktemp /tmp/coqwc.XXXXXX`; \ + $(BIN)coqwc $< 2>&1 > $$tmpoutput; \ + diff -u --strip-trailing-cr coqwc/$*.out $$tmpoutput 2>&1; R=$$?; times; \ + if [ $$R = 0 ]; then \ + echo $(log_success); \ + echo " $<...Ok"; \ + else \ + echo $(log_failure); \ + echo " $<...Error! (unexpected output)"; \ + fi; \ + rm $$tmpoutput; \ + } > "$@" + # coq_makefile coq-makefile: $(patsubst %/run.sh,%.log,$(wildcard coq-makefile/*/run.sh)) diff --git a/test-suite/bugs/closed/4852.v b/test-suite/bugs/closed/4852.v new file mode 100644 index 0000000000..5068ed9b95 --- /dev/null +++ b/test-suite/bugs/closed/4852.v @@ -0,0 +1,54 @@ +(** BZ 4852 : unsatisfactory Extraction Implicit for a fixpoint defined via wf *) + +Require Import Coq.Lists.List. +Import ListNotations. +Require Import Omega. + +Definition wfi_lt := well_founded_induction_type Wf_nat.lt_wf. + +Tactic Notation "wfinduction" constr(term) "on" ne_hyp_list(Hs) "as" ident(H) := + let R := fresh in + let E := fresh in + remember term as R eqn:E; + revert E; revert Hs; + induction R as [R H] using wfi_lt; + intros; subst R. + +Hint Rewrite @app_comm_cons @app_assoc @app_length : app_rws. + +Ltac solve_nat := autorewrite with app_rws in *; cbn in *; omega. + +Notation "| x |" := (length x) (at level 11, no associativity, format "'|' x '|'"). + +Definition split_acc (ls : list nat) : forall acc1 acc2, + (|acc1| = |acc2| \/ |acc1| = S (|acc2|)) -> + { lss : list nat * list nat | + let '(ls1, ls2) := lss in |ls1++ls2| = |ls++acc1++acc2| /\ (|ls1| = |ls2| \/ |ls1| = S (|ls2|))}. +Proof. + induction ls as [|a ls IHls]. all:intros acc1 acc2 H. + { exists (acc1, acc2). cbn. intuition reflexivity. } + destruct (IHls (a::acc2) acc1) as [[ls1 ls2] (H1 & H2)]. 1:solve_nat. + exists (ls1, ls2). cbn. intuition solve_nat. +Defined. + +Definition join(ls : list nat) : { rls : list nat | |rls| = |ls| }. +Proof. + wfinduction (|ls|) on ls as IH. + case (split_acc ls [] []). 1:solve_nat. + intros (ls1 & ls2) (H1 & H2). + destruct ls2 as [|a ls2]. + - exists ls1. solve_nat. + - unshelve eelim (IH _ _ ls1 eq_refl). 1:solve_nat. intros rls1 H3. + unshelve eelim (IH _ _ ls2 eq_refl). 1:solve_nat. intros rls2 H4. + exists (a :: rls1 ++ rls2). solve_nat. +Defined. + +Require Import ExtrOcamlNatInt. +Extract Inlined Constant length => "List.length". +Extract Inlined Constant app => "List.append". + +Extraction Inline wfi_lt. +Extraction Implicit wfi_lt [1 3]. +Recursive Extraction join. (* was: Error: An implicit occurs after extraction *) +Extraction TestCompile join. + diff --git a/test-suite/bugs/closed/5692.v b/test-suite/bugs/closed/5692.v new file mode 100644 index 0000000000..55ef7abe40 --- /dev/null +++ b/test-suite/bugs/closed/5692.v @@ -0,0 +1,38 @@ +Set Primitive Projections. +Require Import ZArith ssreflect. + +Module Test3. + +Set Primitive Projections. + +Structure semigroup := SemiGroup { + sg_car :> Type; + sg_op : sg_car -> sg_car -> sg_car; +}. + +Structure group := Something { + group_car :> Type; + group_op : group_car -> group_car -> group_car; + group_neg : group_car -> group_car; + group_neg_op' x y : group_neg (group_op x y) = group_op (group_neg x) (group_neg y) +}. + +Coercion group_sg (X : group) : semigroup := + SemiGroup (group_car X) (group_op X). +Canonical Structure group_sg. + +Axiom group_neg_op : forall (X : group) (x y : X), + group_neg X (sg_op (group_sg X) x y) = sg_op (group_sg X) (group_neg X x) (group_neg X y). + +Canonical Structure Z_sg := SemiGroup Z Z.add . +Canonical Structure Z_group := Something Z Z.add Z.opp Z.opp_add_distr. + +Lemma foo (x y : Z) : + sg_op Z_sg (group_neg Z_group x) (group_neg Z_group y) = + group_neg Z_group (sg_op Z_sg x y). +Proof. + rewrite -group_neg_op. + reflexivity. +Qed. + +End Test3. diff --git a/test-suite/bugs/closed/5741.v b/test-suite/bugs/closed/5741.v new file mode 100644 index 0000000000..f6598f192d --- /dev/null +++ b/test-suite/bugs/closed/5741.v @@ -0,0 +1,4 @@ +(* Check no anomaly in info_trivial *) + +Goal True. +info_trivial. diff --git a/test-suite/bugs/closed/5757.v b/test-suite/bugs/closed/5757.v new file mode 100644 index 0000000000..0d0f2eed44 --- /dev/null +++ b/test-suite/bugs/closed/5757.v @@ -0,0 +1,76 @@ +(* Check that resolved status of evars follows "restrict" *) + +Axiom H : forall (v : nat), Some 0 = Some v -> True. +Lemma L : True. +eapply H with _; +match goal with + | |- Some 0 = Some ?v => change (Some (0+0) = Some v) +end. +Abort. + +(* The original example *) + +Set Default Proof Using "Type". + +Module heap_lang. + +Inductive expr := + | InjR (e : expr). + +Inductive val := + | InjRV (v : val). + +Bind Scope val_scope with val. + +Fixpoint of_val (v : val) : expr := + match v with + | InjRV v => InjR (of_val v) + end. + +Fixpoint to_val (e : expr) : option val := None. + +End heap_lang. +Export heap_lang. + +Module W. +Inductive expr := + | Val (v : val) + (* Sums *) + | InjR (e : expr). + +Fixpoint to_expr (e : expr) : heap_lang.expr := + match e with + | Val v => of_val v + | InjR e => heap_lang.InjR (to_expr e) + end. + +End W. + + + +Section Tests. + + Context (iProp: Type). + Context (WPre: expr -> Prop). + + Context (tac_wp_alloc : + forall (e : expr) (v : val), + to_val e = Some v -> WPre e). + + Lemma push_atomic_spec (x: val) : + WPre (InjR (of_val x)). + Proof. +(* This works. *) +eapply tac_wp_alloc with _. +match goal with + | |- to_val ?e = Some ?v => + change (to_val (W.to_expr (W.InjR (W.Val x))) = Some v) +end. +Undo. Undo. +(* This is fixed *) +eapply tac_wp_alloc with _; +match goal with + | |- to_val ?e = Some ?v => + change (to_val (W.to_expr (W.InjR (W.Val x))) = Some v) +end. +Abort. diff --git a/test-suite/bugs/closed/5765.v b/test-suite/bugs/closed/5765.v new file mode 100644 index 0000000000..343ab49357 --- /dev/null +++ b/test-suite/bugs/closed/5765.v @@ -0,0 +1,3 @@ +(* 'pat binder not (yet?) allowed in parameters of inductive types *) + +Fail Inductive X '(a,b) := x. diff --git a/test-suite/bugs/closed/5769.v b/test-suite/bugs/closed/5769.v new file mode 100644 index 0000000000..42573aad87 --- /dev/null +++ b/test-suite/bugs/closed/5769.v @@ -0,0 +1,20 @@ +(* Check a few naming heuristics based on types *) +(* was buggy for types names _something *) + +Inductive _foo :=. +Lemma bob : (sigT (fun x : nat => _foo)) -> _foo. +destruct 1. +exact _f. +Abort. + +Inductive _'Foo :=. +Lemma bob : (sigT (fun x : nat => _'Foo)) -> _'Foo. +destruct 1. +exact _'f. +Abort. + +Inductive ____ :=. +Lemma bob : (sigT (fun x : nat => ____)) -> ____. +destruct 1. +exact x0. +Abort. diff --git a/test-suite/coqwc/BZ5637.out b/test-suite/coqwc/BZ5637.out new file mode 100644 index 0000000000..f0b5e4f7eb --- /dev/null +++ b/test-suite/coqwc/BZ5637.out @@ -0,0 +1,2 @@ + spec proof comments + 5 0 0 coqwc/BZ5637.v diff --git a/test-suite/coqwc/BZ5637.v b/test-suite/coqwc/BZ5637.v new file mode 100644 index 0000000000..6428b10ff8 --- /dev/null +++ b/test-suite/coqwc/BZ5637.v @@ -0,0 +1,5 @@ +Local Obligation Tactic := idtac. +Definition a := 1. +Definition b := 1. +Definition c := 1. +Definition d := 1. diff --git a/test-suite/coqwc/BZ5756.out b/test-suite/coqwc/BZ5756.out new file mode 100644 index 0000000000..039d1e5008 --- /dev/null +++ b/test-suite/coqwc/BZ5756.out @@ -0,0 +1,2 @@ + spec proof comments + 3 0 2 coqwc/BZ5756.v diff --git a/test-suite/coqwc/BZ5756.v b/test-suite/coqwc/BZ5756.v new file mode 100644 index 0000000000..ccb12076a3 --- /dev/null +++ b/test-suite/coqwc/BZ5756.v @@ -0,0 +1,3 @@ +Definition myNextValue := 0. (* OK *) +Definition x := myNextValue. (* not OK *) +Definition y := 0. diff --git a/test-suite/coqwc/false.out b/test-suite/coqwc/false.out new file mode 100644 index 0000000000..14c5713f6d --- /dev/null +++ b/test-suite/coqwc/false.out @@ -0,0 +1,2 @@ + spec proof comments + 3 3 1 coqwc/false.v diff --git a/test-suite/coqwc/false.v b/test-suite/coqwc/false.v new file mode 100644 index 0000000000..640f9ea7f0 --- /dev/null +++ b/test-suite/coqwc/false.v @@ -0,0 +1,8 @@ +Axiom x : nat. + +Definition foo (x : nat) := x + 1. + +Lemma bar : False. + idtac. + idtac. (* truth is overrated *) +Admitted. diff --git a/test-suite/coqwc/next-obligation.out b/test-suite/coqwc/next-obligation.out new file mode 100644 index 0000000000..7a0fd777c1 --- /dev/null +++ b/test-suite/coqwc/next-obligation.out @@ -0,0 +1,2 @@ + spec proof comments + 1 7 0 coqwc/next-obligation.v diff --git a/test-suite/coqwc/next-obligation.v b/test-suite/coqwc/next-obligation.v new file mode 100644 index 0000000000..786df98913 --- /dev/null +++ b/test-suite/coqwc/next-obligation.v @@ -0,0 +1,10 @@ +(* make sure all proof lines are counted *) + +Goal True. + Next Obligation. + idtac. + Next Obligation. + idtac. + Next Obligation. + idtac. +Qed. diff --git a/test-suite/coqwc/theorem.out b/test-suite/coqwc/theorem.out new file mode 100644 index 0000000000..d01507bf78 --- /dev/null +++ b/test-suite/coqwc/theorem.out @@ -0,0 +1,2 @@ + spec proof comments + 1 9 2 coqwc/theorem.v diff --git a/test-suite/coqwc/theorem.v b/test-suite/coqwc/theorem.v new file mode 100644 index 0000000000..901c9074fd --- /dev/null +++ b/test-suite/coqwc/theorem.v @@ -0,0 +1,10 @@ +Theorem foo : True. +Proof. + idtac. (* comment *) + idtac. + idtac. + idtac. (* comment *) + idtac. + idtac. + auto. +Qed. diff --git a/test-suite/misc/deps-utf8.sh b/test-suite/misc/deps-utf8.sh new file mode 100755 index 0000000000..13e264c09c --- /dev/null +++ b/test-suite/misc/deps-utf8.sh @@ -0,0 +1,17 @@ +# Check reading directories matching non pure ascii idents +# See bug #5715 (utf-8 working on macos X and linux) +# Windows is still not compliant +a=`uname` +if [ "$a" = "Darwin" -o "$a" = "Linux" ]; then +rm -f misc/deps/théorèmes/*.v +tmpoutput=`mktemp /tmp/coqcheck.XXXXXX` +$coqc -R misc/deps AlphaBêta misc/deps/αβ/γδ.v +R=$? +$coqtop -R misc/deps AlphaBêta -load-vernac-source misc/deps/αβ/εζ.v +S=$? +if [ $R = 0 -a $S = 0 ]; then + exit 0 +else + exit 1 +fi +fi diff --git a/test-suite/misc/deps/αβ/γδ.v b/test-suite/misc/deps/αβ/γδ.v new file mode 100644 index 0000000000..f43a2d6571 --- /dev/null +++ b/test-suite/misc/deps/αβ/γδ.v @@ -0,0 +1,4 @@ +Theorem simple : forall A, A -> A. +Proof. +auto. +Qed. diff --git a/test-suite/misc/deps/αβ/εζ.v b/test-suite/misc/deps/αβ/εζ.v new file mode 100644 index 0000000000..e7fd25c0d1 --- /dev/null +++ b/test-suite/misc/deps/αβ/εζ.v @@ -0,0 +1 @@ +Require Import γδ. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 65efe228af..6ef75dd135 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -124,3 +124,7 @@ return (1, 2, 3, 4) : nat !!! _ _ : nat, True : (nat -> Prop) * ((nat -> Prop) * Prop) +((*1).2).3 + : nat +*(1.2) + : nat diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index ea372ad1a3..8c7bbe5917 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -190,3 +190,10 @@ Check 1+1+1. (* Test presence of notation variables in the recursive parts (introduced in dfdaf4de) *) Notation "!!! x .. y , b" := ((fun x => b), .. ((fun y => b), True) ..) (at level 200, x binder). Check !!! (x y:nat), True. + +(* Allow level for leftmost nonterminal when printing-only, BZ#5739 *) + +Notation "* x" := (id x) (only printing, at level 15, format "* x"). +Notation "x . y" := (x + y) (only printing, at level 20, x at level 14, left associativity, format "x . y"). +Check (((id 1) + 2) + 3). +Check (id (1 + 2)). diff --git a/test-suite/output/auto.out b/test-suite/output/auto.out index a5b55a9993..2761b87b02 100644 --- a/test-suite/output/auto.out +++ b/test-suite/output/auto.out @@ -18,3 +18,5 @@ Debug: 1 depth=5 Debug: 1.1 depth=4 simple apply or_intror Debug: 1.1.1 depth=4 intro Debug: 1.1.1.1 depth=4 exact H +(* info trivial: *) +exact I (in core). diff --git a/test-suite/output/auto.v b/test-suite/output/auto.v index a77b7b82e6..92917cdfc7 100644 --- a/test-suite/output/auto.v +++ b/test-suite/output/auto.v @@ -9,3 +9,7 @@ info_eauto. Undo. debug eauto. Qed. + +Goal True. +info_trivial. +Qed. diff --git a/test-suite/output/ltac_extra_args.out b/test-suite/output/ltac_extra_args.out new file mode 100644 index 0000000000..77e799d359 --- /dev/null +++ b/test-suite/output/ltac_extra_args.out @@ -0,0 +1,8 @@ +The command has indeed failed with message: +Illegal tactic application: got 1 extra argument. +The command has indeed failed with message: +Illegal tactic application: got 2 extra arguments. +The command has indeed failed with message: +Illegal tactic application: got 1 extra argument. +The command has indeed failed with message: +Illegal tactic application: got 2 extra arguments. diff --git a/test-suite/output/ltac_extra_args.v b/test-suite/output/ltac_extra_args.v new file mode 100644 index 0000000000..4caf619fee --- /dev/null +++ b/test-suite/output/ltac_extra_args.v @@ -0,0 +1,10 @@ +Ltac foo := idtac. +Ltac bar H := idtac. + +Goal True. +Proof. + Fail foo H. + Fail foo H H'. + Fail bar H H'. + Fail bar H H' H''. +Abort. diff --git a/test-suite/success/unshelve.v b/test-suite/success/unshelve.v index 672222bdd6..a4fa544cd9 100644 --- a/test-suite/success/unshelve.v +++ b/test-suite/success/unshelve.v @@ -9,3 +9,11 @@ unshelve (refine (F _ _ _ _)). + exact (@eq_refl bool true). + exact (@eq_refl unit tt). Qed. + +(* This was failing in 8.6, because of ?a:nat being wrongly duplicated *) + +Goal (forall a : nat, a = 0 -> True) -> True. +intros F. +unshelve (eapply (F _);clear F). +2:reflexivity. +Qed. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index afe8e62ee3..cfa5526025 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -39,6 +39,7 @@ CAMLP4O := $(COQMF_CAMLP4O) CAMLP4BIN := $(COQMF_CAMLP4BIN) CAMLP4LIB := $(COQMF_CAMLP4LIB) CAMLP4OPTIONS := $(COQMF_CAMLP4OPTIONS) +CAMLFLAGS := $(COQMF_CAMLFLAGS) HASNATDYNLINK := $(COQMF_HASNATDYNLINK) @CONF_FILE@: @PROJECT_FILE@ @@ -100,11 +101,11 @@ AFTER ?= CAMLDONTLINK=camlp5.gramlib,unix,str # OCaml binaries -CAMLC ?= "$(OCAMLFIND)" ocamlc -c -rectypes -thread -CAMLOPTC ?= "$(OCAMLFIND)" opt -c -rectypes -thread -CAMLLINK ?= "$(OCAMLFIND)" ocamlc -rectypes -thread -linkpkg -dontlink $(CAMLDONTLINK) -CAMLOPTLINK ?= "$(OCAMLFIND)" opt -rectypes -thread -linkpkg -dontlink $(CAMLDONTLINK) -CAMLDOC ?= "$(OCAMLFIND)" ocamldoc -rectypes +CAMLC ?= "$(OCAMLFIND)" ocamlc -c +CAMLOPTC ?= "$(OCAMLFIND)" opt -c +CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkpkg -dontlink $(CAMLDONTLINK) +CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkpkg -dontlink $(CAMLDONTLINK) +CAMLDOC ?= "$(OCAMLFIND)" ocamldoc CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack # DESTDIR is prepended to all installation paths @@ -114,8 +115,6 @@ DESTDIR ?= CAMLDEBUG ?= COQDEBUG ?= -# Extra flags to the OCaml compiler -CAMLFLAGS ?= # Extra packages to be linked in (as in findlib -package) CAMLPKGS ?= @@ -749,7 +748,7 @@ printenv:: # file you can extend the merlin-hook target in @LOCAL_FILE@ .merlin: $(SHOW)'FILL .merlin' - $(HIDE)echo 'FLG -rectypes -thread' > .merlin + $(HIDE)echo 'FLG $(COQMF_CAMLFLAGS)' > .merlin $(HIDE)echo 'B $(COQLIB)' >> .merlin $(HIDE)echo 'S $(COQLIB)' >> .merlin $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll index 8eeb59898f..564e20d0e8 100644 --- a/tools/coqdep_lexer.mll +++ b/tools/coqdep_lexer.mll @@ -25,8 +25,6 @@ exception Fin_fichier exception Syntax_error of int*int - let field_name s = String.sub s 1 (String.length s - 1) - let unquote_string s = String.sub s 1 (String.length s - 2) @@ -40,6 +38,18 @@ let syntax_error lexbuf = raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) + let check_valid lexbuf s = + match Unicode.ident_refutation s with + | None -> s + | Some _ -> syntax_error lexbuf + + let get_ident lexbuf = + let s = Lexing.lexeme lexbuf in check_valid lexbuf s + + let get_field_name lexbuf = + let s = Lexing.lexeme lexbuf in + check_valid lexbuf (String.sub s 1 (String.length s - 1)) + [@@@ocaml.warning "-3"] (* String.uncapitalize_ascii since 4.03.0 GPR#124 *) let uncapitalize = String.uncapitalize [@@@ocaml.warning "+3"] @@ -52,20 +62,8 @@ let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] let caml_up_ident = uppercase identchar* let caml_low_ident = lowercase identchar* -let coq_firstchar = - (* This is only an approximation, refer to lib/util.ml for correct def *) - ['A'-'Z' 'a'-'z' '_'] | - (* superscript 1 *) - '\194' '\185' | - (* utf-8 latin 1 supplement *) - '\195' ['\128'-'\150'] | '\195' ['\152'-'\182'] | '\195' ['\184'-'\191'] | - (* utf-8 letters *) - '\206' (['\145'-'\161'] | ['\163'-'\187']) - '\226' ('\130' [ '\128'-'\137' ] (* subscripts *) - | '\129' [ '\176'-'\187' ] (* superscripts *) - | '\132' ['\128'-'\191'] | '\133' ['\128'-'\143']) -let coq_identchar = coq_firstchar | ['\'' '0'-'9'] -let coq_ident = coq_firstchar coq_identchar* +(* This is an overapproximation, we check correctness afterwards *) +let coq_ident = ['A'-'Z' 'a'-'z' '_' '\128'-'\255'] ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9' '\128'-'\255']* let coq_field = '.' coq_ident let dot = '.' ( space+ | eof) @@ -102,7 +100,7 @@ and from_rule = parse | space+ { from_rule lexbuf } | coq_ident - { let from = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + { let from = coq_qual_id_tail [get_ident lexbuf] lexbuf in consume_require (Some from) lexbuf } | eof { syntax_error lexbuf } @@ -241,7 +239,7 @@ and load_file = parse parse_dot lexbuf; Load (unquote_vfile_string s) } | coq_ident - { let s = lexeme lexbuf in skip_to_dot lexbuf; Load s } + { let s = get_ident lexbuf in skip_to_dot lexbuf; Load s } | eof { syntax_error lexbuf } | _ @@ -253,7 +251,7 @@ and require_file from = parse | space+ { require_file from lexbuf } | coq_ident - { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + { let name = coq_qual_id_tail [get_ident lexbuf] lexbuf in let qid = coq_qual_id_list [name] lexbuf in parse_dot lexbuf; Require (from, qid) } @@ -278,7 +276,7 @@ and coq_qual_id = parse | space+ { coq_qual_id lexbuf } | coq_ident - { coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf } + { coq_qual_id_tail [get_ident lexbuf] lexbuf } | _ { syntax_error lexbuf } @@ -288,7 +286,7 @@ and coq_qual_id_tail module_name = parse | space+ { coq_qual_id_tail module_name lexbuf } | coq_field - { coq_qual_id_tail (field_name (Lexing.lexeme lexbuf) :: module_name) lexbuf } + { coq_qual_id_tail (get_field_name lexbuf :: module_name) lexbuf } | eof { syntax_error lexbuf } | _ @@ -301,7 +299,7 @@ and coq_qual_id_list module_names = parse | space+ { coq_qual_id_list module_names lexbuf } | coq_ident - { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + { let name = coq_qual_id_tail [get_ident lexbuf] lexbuf in coq_qual_id_list (name :: module_names) lexbuf } | eof diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml index 28a3c791cb..c21db300ad 100644 --- a/tools/coqmktop.ml +++ b/tools/coqmktop.ml @@ -252,6 +252,17 @@ let create_tmp_main_file modules = with reraise -> clean main_name; raise reraise +(* TODO: remove once OCaml 4.04 is adopted *) +let split_on_char sep s = + let r = ref [] in + let j = ref (String.length s) in + for i = String.length s - 1 downto 0 do + if s.[i] = sep then begin + r := String.sub s (i + 1) (!j - i - 1) :: !r; + j := i + end + done; + String.sub s 0 !j :: !r (** {6 Main } *) @@ -271,8 +282,10 @@ let main () = try (* - We add topstart.cmo explicitly because we shunted ocamlmktop wrapper. - With the coq .cma, we MUST use the -linkall option. *) + let coq_camlflags = + List.filter ((<>) "") (split_on_char ' ' Coq_config.caml_flags) in let args = - "-linkall" :: "-rectypes" :: "-w" :: "-31" :: flags @ copts @ options @ + coq_camlflags @ "-linkall" :: "-w" :: "-31" :: flags @ copts @ options @ (std_includes basedir) @ tolink @ [ main_file ] @ topstart in if !echo then begin diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 5ca8869655..8f676c656b 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -32,7 +32,7 @@ let load_rcfile sid = try if !rcfile_specified then if CUnix.file_readable_p !rcfile then - Vernac.load_vernac false sid !rcfile + Vernac.load_vernac ~verbosely:false ~interactive:false ~check:true sid !rcfile else raise (Sys_error ("Cannot read rcfile: "^ !rcfile)) else try @@ -43,7 +43,7 @@ let load_rcfile sid = Envars.home ~warn / "."^rcdefaultname^"."^Coq_config.version; Envars.home ~warn / "."^rcdefaultname ] in - Vernac.load_vernac false sid inferedrc + Vernac.load_vernac ~verbosely:false ~interactive:false ~check:true sid inferedrc with Not_found -> sid (* Flags.if_verbose @@ -114,9 +114,6 @@ let init_load_path () = (* additional ml directories, given with option -I *) List.iter Mltop.add_ml_dir (List.rev !ml_includes) -let init_library_roots () = - includes := [] - (* Initialises the Ocaml toplevel before launching it, so that it can find the "include" file in the *source* directory *) let init_ocaml_path () = diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli index 3432e79cc0..1f7fd6ed95 100644 --- a/toplevel/coqinit.mli +++ b/toplevel/coqinit.mli @@ -21,6 +21,5 @@ val push_include : string -> Names.DirPath.t -> bool -> unit val push_ml_include : string -> unit val init_load_path : unit -> unit -val init_library_roots : unit -> unit val init_ocaml_path : unit -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index c1cdaa5a34..0624c9bed8 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -9,7 +9,6 @@ open Pp open CErrors open Libnames -open Coqinit let () = at_exit flush_all @@ -121,6 +120,14 @@ let print_memory_stat () = let _ = at_exit print_memory_stat +(******************************************************************************) +(* Deprecated *) +(******************************************************************************) +let _remove_top_ml () = Mltop.remove () + +(******************************************************************************) +(* Engagement *) +(******************************************************************************) let impredicative_set = ref Declarations.PredicativeSet let set_impredicative_set c = impredicative_set := Declarations.ImpredicativeSet let set_type_in_type () = @@ -129,14 +136,18 @@ let set_type_in_type () = let engage () = Global.set_engagement !impredicative_set -let set_batch_mode () = Flags.batch_mode := true - +(******************************************************************************) +(* Interactive toplevel name *) +(******************************************************************************) let toplevel_default_name = Names.(DirPath.make [Id.of_string "Top"]) let toplevel_name = ref toplevel_default_name let set_toplevel_name dir = if Names.DirPath.is_empty dir then user_err Pp.(str "Need a non empty toplevel module name"); toplevel_name := dir +(******************************************************************************) +(* Input/Output State *) +(******************************************************************************) let warn_deprecated_inputstate = CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" (fun () -> strbrk "The inputstate option is deprecated and discouraged.") @@ -164,21 +175,22 @@ let outputstate () = let fname = CUnix.make_suffix !outputstate ".coq" in States.extern_state fname -let set_include d p implicit = - let p = dirpath_of_string p in - push_include d p implicit - +(******************************************************************************) +(* Interactive Load File Simulation *) +(******************************************************************************) let load_vernacular_list = ref ([] : (string * bool) list) + let add_load_vernacular verb s = load_vernacular_list := ((CUnix.make_suffix s ".v"),verb) :: !load_vernacular_list + let load_vernacular sid = List.fold_left - (fun sid (s,v) -> - let s = Loadpath.locate_file s in + (fun sid (f_in, verbosely) -> + let s = Loadpath.locate_file f_in in if !Flags.beautify then - Flags.(with_option beautify_file (Vernac.load_vernac v sid) s) + Flags.with_option Flags.beautify_file (Vernac.load_vernac ~verbosely ~interactive:false ~check:true sid) f_in else - Vernac.load_vernac v sid s) + Vernac.load_vernac ~verbosely ~interactive:false ~check:true sid s) sid (List.rev !load_vernacular_list) let load_vernacular_obj = ref ([] : string list) @@ -187,6 +199,13 @@ let load_vernac_obj () = let map dir = Qualid (Loc.tag @@ qualid_of_string dir) in Vernacentries.vernac_require None None (List.rev_map map !load_vernacular_obj) +(******************************************************************************) +(* Required Modules *) +(******************************************************************************) +let set_include d p implicit = + let p = dirpath_of_string p in + Coqinit.push_include d p implicit + let require_prelude () = let vo = Envars.coqlib () / "theories/Init/Prelude.vo" in let vio = Envars.coqlib () / "theories/Init/Prelude.vio" in @@ -209,10 +228,23 @@ let add_compat_require v = | Flags.V8_7 -> add_require "Coq.Compat.Coq87" | Flags.VOld | Flags.Current -> () -let compile_list = ref ([] : (bool * string) list) +(******************************************************************************) +(* File Compilation *) +(******************************************************************************) let glob_opt = ref false +let compile_list = ref ([] : (bool * string) list) +let _compilation_list : Stm.stm_doc_type list ref = ref [] + +let compilation_mode = ref Vernac.BuildVo +let compilation_output_name = ref None + +let batch_mode = ref false +let set_batch_mode () = + System.trust_file_cache := false; + batch_mode := true + let add_compile verbose s = set_batch_mode (); Flags.quiet := true; @@ -226,21 +258,66 @@ let add_compile verbose s = in compile_list := (verbose,s) :: !compile_list -let compile_file (v,f) = +let compile_file mode (verbosely,f_in) = if !Flags.beautify then - Flags.(with_option beautify_file (Vernac.compile v) f) + Flags.with_option Flags.beautify_file (fun f_in -> Vernac.compile ~verbosely ~mode ~f_in ~f_out:None) f_in else - Vernac.compile v f + Vernac.compile ~verbosely ~mode ~f_in ~f_out:None let compile_files () = if !compile_list == [] then () else let init_state = States.freeze ~marshallable:`No in + let mode = !compilation_mode in List.iter (fun vf -> States.unfreeze init_state; - compile_file vf) + compile_file mode vf) (List.rev !compile_list) +(******************************************************************************) +(* VIO Dispatching *) +(******************************************************************************) + +let vio_tasks = ref [] +let add_vio_task f = + set_batch_mode (); + Flags.quiet := true; + vio_tasks := f :: !vio_tasks +let check_vio_tasks () = + let rc = + List.fold_left (fun acc t -> Vio_checking.check_vio t && acc) + true (List.rev !vio_tasks) in + if not rc then exit 1 + +(* vio files *) +let vio_files = ref [] +let vio_files_j = ref 0 +let vio_checking = ref false +let add_vio_file f = + set_batch_mode (); + Flags.quiet := true; + vio_files := f :: !vio_files + +let set_vio_checking_j opt j = + try vio_files_j := int_of_string j + with Failure _ -> + prerr_endline ("The first argument of " ^ opt ^ " must the number"); + prerr_endline "of concurrent workers to be used (a positive integer)."; + prerr_endline "Makefiles generated by coq_makefile should be called"; + prerr_endline "setting the J variable like in 'make vio2vo J=3'"; + exit 1 + +let schedule_vio_checking () = + if !vio_files <> [] && !vio_checking then + Vio_checking.schedule_vio_checking !vio_files_j !vio_files + +let schedule_vio_compilation () = + if !vio_files <> [] && not !vio_checking then + Vio_checking.schedule_vio_compilation !vio_files_j !vio_files + +(******************************************************************************) +(* UI Options *) +(******************************************************************************) (** Options for proof general *) let set_emacs () = @@ -296,14 +373,15 @@ let usage_no_coqlib = CWarnings.create ~name:"usage-no-coqlib" ~category:"filesy (fun () -> Pp.str "cannot guess a path for Coq libraries; dynaminally loaded flags will not be mentioned") exception NoCoqLib -let usage () = + +let usage batch = begin try Envars.set_coqlib ~fail:(fun x -> raise NoCoqLib); - init_load_path (); + Coqinit.init_load_path (); with NoCoqLib -> usage_no_coqlib () end; - if !Flags.batch_mode then Usage.print_usage_coqc () + if batch then Usage.print_usage_coqc () else begin Mltop.load_ml_objects_raw_rex (Str.regexp (if Mltop.is_native then "^.*top.cmxs$" else "^.*top.cma$")); @@ -389,47 +467,10 @@ let get_error_resilience opt = function let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s) -let vio_tasks = ref [] - -let add_vio_task f = - set_batch_mode (); - Flags.quiet := true; - vio_tasks := f :: !vio_tasks - -let check_vio_tasks () = - let rc = - List.fold_left (fun acc t -> Vio_checking.check_vio t && acc) - true (List.rev !vio_tasks) in - if not rc then exit 1 - -let vio_files = ref [] -let vio_files_j = ref 0 -let vio_checking = ref false -let add_vio_file f = - set_batch_mode (); - Flags.quiet := true; - vio_files := f :: !vio_files - -let set_vio_checking_j opt j = - try vio_files_j := int_of_string j - with Failure _ -> - prerr_endline ("The first argument of " ^ opt ^ " must the number"); - prerr_endline "of concurrent workers to be used (a positive integer)."; - prerr_endline "Makefiles generated by coq_makefile should be called"; - prerr_endline "setting the J variable like in 'make vio2vo J=3'"; - exit 1 - let is_not_dash_option = function | Some f when String.length f > 0 && f.[0] <> '-' -> true | _ -> false -let schedule_vio_checking () = - if !vio_files <> [] && !vio_checking then - Vio_checking.schedule_vio_checking !vio_files_j !vio_files -let schedule_vio_compilation () = - if !vio_files <> [] && not !vio_checking then - Vio_checking.schedule_vio_compilation !vio_files_j !vio_files - let get_native_name s = (* We ignore even critical errors because this mode has to be super silent *) try @@ -464,7 +505,7 @@ let parse_args arglist = (* Complex options with many args *) |"-I"|"-include" -> begin match rem with - | d :: rem -> push_ml_include d; args := rem + | d :: rem -> Coqinit.push_ml_include d; args := rem | [] -> error_missing_arg opt end |"-Q" -> @@ -522,7 +563,7 @@ let parse_args arglist = |"-dump-glob" -> Dumpglob.dump_into_file (next ()); glob_opt := true |"-feedback-glob" -> Dumpglob.feedback_glob () |"-exclude-dir" -> System.exclude_directory (next ()) - |"-init-file" -> set_rcfile (next ()) + |"-init-file" -> Coqinit.set_rcfile (next ()) |"-inputstate"|"-is" -> set_inputstate (next ()) |"-load-ml-object" -> Mltop.dir_ml_load (next ()) |"-load-ml-source" -> Mltop.dir_ml_use (next ()) @@ -537,10 +578,17 @@ let parse_args arglist = |"-with-geoproof" -> Coq_config.with_geoproof := get_bool opt (next ()) |"-main-channel" -> Spawned.main_channel := get_host_port opt (next()) |"-control-channel" -> Spawned.control_channel := get_host_port opt (next()) - |"-vio2vo" -> add_compile false (next ()); Flags.compilation_mode := Flags.Vio2Vo + |"-vio2vo" -> + add_compile false (next ()); + compilation_mode := Vernac.Vio2Vo |"-toploop" -> set_toploop (next ()) - |"-w" | "-W" -> CWarnings.set_flags (CWarnings.normalize_flags_string (next ())) - |"-o" -> Flags.compilation_output_name := Some (next()) + |"-w" | "-W" -> + let w = next () in + if w = "none" then CWarnings.set_flags w + else + let w = CWarnings.get_flags () ^ "," ^ w in + CWarnings.set_flags (CWarnings.normalize_flags_string w) + |"-o" -> compilation_output_name := Some (next()) (* Options with zero arg *) |"-async-queries-always-delegate" @@ -552,15 +600,15 @@ let parse_args arglist = |"-batch" -> set_batch_mode () |"-test-mode" -> Flags.test_mode := true |"-beautify" -> Flags.beautify := true - |"-boot" -> Flags.boot := true; no_load_rc () + |"-boot" -> Flags.boot := true; Coqinit.no_load_rc () |"-bt" -> Backtrace.record_backtrace true |"-color" -> set_color (next ()) |"-config"|"--config" -> print_config := true - |"-debug" -> set_debug () + |"-debug" -> Coqinit.set_debug () |"-stm-debug" -> Flags.stm_debug := true |"-emacs" -> set_emacs () |"-filteropts" -> filter_opts := true - |"-h"|"-H"|"-?"|"-help"|"--help" -> usage () + |"-h"|"-H"|"-?"|"-help"|"--help" -> usage !batch_mode |"-ideslave" -> set_ideslave () |"-impredicative-set" -> set_impredicative_set () |"-indices-matter" -> Indtypes.enforce_indices_matter () @@ -573,9 +621,11 @@ let parse_args arglist = else Flags.native_compiler := true |"-output-context" -> output_context := true |"-profile-ltac" -> Flags.profile_ltac := true - |"-q" -> no_load_rc () + |"-q" -> Coqinit.no_load_rc () |"-quiet"|"-silent" -> Flags.quiet := true; Flags.make_warn false - |"-quick" -> Flags.compilation_mode := Flags.BuildVio + |"-quick" -> + Safe_typing.allow_delayed_constants := true; + compilation_mode := Vernac.BuildVio |"-list-tags" -> print_tags := true |"-time" -> Flags.time := true |"-type-in-type" -> set_type_in_type () @@ -610,7 +660,7 @@ let init_toplevel arglist = if !print_config then (Envars.print_config stdout Coq_config.all_src_dirs; exit (exitcode ())); if !print_tags then (print_style_tags (); exit (exitcode ())); if !filter_opts then (print_string (String.concat "\n" extras); exit 0); - init_load_path (); + Coqinit.init_load_path (); Option.iter Mltop.load_ml_object_raw !toploop; let extras = !toploop_init extras in if not (CList.is_empty extras) then begin @@ -622,20 +672,19 @@ let init_toplevel arglist = inputstate (); Mltop.init_known_plugins (); engage (); - if (not !Flags.batch_mode || CList.is_empty !compile_list) + if (not !batch_mode || CList.is_empty !compile_list) && Global.env_is_initial () then Declaremods.start_library !toplevel_name; - init_library_roots (); load_vernac_obj (); require (); - (* XXX: This is incorrect in batch mode, as we will initialize - the STM before having done Declaremods.start_library, thus - state 1 is invalid. This bug was present in 8.5/8.6. *) - Stm.init (); - let sid = load_rcfile (Stm.get_current_state ()) in + Stm.(init { doc_type = Interactive Names.DirPath.empty }); + let sid = Coqinit.load_rcfile (Stm.get_current_state ()) in (* XXX: We ignore this for now, but should be threaded to the toplevels *) let _sid = load_vernacular sid in compile_files (); + (* All these tasks use coqtop as a driver to invoke more coqtop, + * they should be really orthogonal to coqtop. + *) schedule_vio_checking (); schedule_vio_compilation (); check_vio_tasks (); @@ -643,13 +692,13 @@ let init_toplevel arglist = with any -> flush_all(); let extra = - if !Flags.batch_mode && not Stateid.(equal (Stm.get_current_state ()) dummy) + if !batch_mode && not Stateid.(equal (Stm.get_current_state ()) dummy) then None else Some (str "Error during initialization: ") in fatal_error ?extra any end; - if !Flags.batch_mode then begin + if !batch_mode then begin flush_all(); if !output_context then Feedback.msg_notice Flags.(with_option raw_print Prettyp.print_full_pure_context () ++ fnl ()); diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index 892d64d917..ac2be7e161 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -15,7 +15,6 @@ val init_toplevel : string list -> unit val start : unit -> unit - (* For other toploops *) val toploop_init : (string list -> string list) ref val toploop_run : (unit -> unit) ref diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 4b97ee0dde..cb89dc8ff9 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -47,35 +47,29 @@ let beautify_suffix = ".beautified" let set_formatter_translator ch = let out s b e = output_substring ch s b e in - Format.set_formatter_output_functions out (fun () -> flush ch); - Format.set_max_boxes max_int + let ft = Format.make_formatter out (fun () -> flush ch) in + Format.pp_set_max_boxes ft max_int; + ft -let pr_new_syntax_in_context ?loc chan_beautify ocom = +let pr_new_syntax_in_context ?loc ft_beautify ocom = let loc = Option.cata Loc.unloc (0,0) loc in - if !Flags.beautify_file then set_formatter_translator chan_beautify; let fs = States.freeze ~marshallable:`No in - (* The content of this is not supposed to fail, but if ever *) - try - (* Side-effect: order matters *) - let before = comment (CLexer.extract_comments (fst loc)) in - let com = match ocom with - | Some com -> Ppvernac.pr_vernac com - | None -> mt() in - let after = comment (CLexer.extract_comments (snd loc)) in - if !Flags.beautify_file then - (Pp.pp_with !Topfmt.std_ft (hov 0 (before ++ com ++ after)); - Format.pp_print_flush !Topfmt.std_ft ()) - else - Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); - States.unfreeze fs; - Format.set_formatter_out_channel stdout - with any -> - States.unfreeze fs; - Format.set_formatter_out_channel stdout - -let pr_new_syntax ?loc po chan_beautify ocom = + (* Side-effect: order matters *) + let before = comment (CLexer.extract_comments (fst loc)) in + let com = match ocom with + | Some com -> Ppvernac.pr_vernac com + | None -> mt() in + let after = comment (CLexer.extract_comments (snd loc)) in + if !Flags.beautify_file then + (Pp.pp_with ft_beautify (hov 0 (before ++ com ++ after)); + Format.pp_print_flush ft_beautify ()) + else + Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); + States.unfreeze fs + +let pr_new_syntax ?loc po ft_beautify ocom = (* Reinstall the context of parsing which includes the bindings of comments to locations *) - Pcoq.Gram.with_parsable po (pr_new_syntax_in_context ?loc chan_beautify) ocom + Pcoq.Gram.with_parsable po (pr_new_syntax_in_context ?loc ft_beautify) ocom (* For coqtop -time, we display the position in the file, and a glimpse of the executed command *) @@ -119,40 +113,45 @@ let vernac_error msg = (* Stm.End_of_input -> true *) (* | _ -> false *) -let rec interp_vernac sid (loc,com) = +let rec interp_vernac ~check ~interactive sid (loc,com) = let interp = function | VernacLoad (verbosely, fname) -> let fname = Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in let fname = CUnix.make_suffix fname ".v" in let f = Loadpath.locate_file fname in - load_vernac verbosely sid f + load_vernac ~verbosely ~check ~interactive sid f | v -> (* XXX: We need to run this before add as the classification is highly dynamic and depends on the structure of the document. Hopefully this is fixed when VtBack can be removed and Undo etc... are just interpreted regularly. *) + + (* XXX: The classifier can emit warnings so we need to guard + against that... *) + let wflags = CWarnings.get_flags () in + CWarnings.set_flags "none"; let is_proof_step = match fst (Vernac_classifier.classify_vernac v) with | VtProofStep _ | VtBack (_, _) | VtStartProof _ -> true | _ -> false in + CWarnings.set_flags wflags; let nsid, ntip = Stm.add ~ontop:sid (not !Flags.quiet) (loc,v) in (* Main STM interaction *) if ntip <> `NewTip then anomaly (str "vernac.ml: We got an unfocus operation on the toplevel!"); + (* Due to bug #5363 we cannot use observe here as we should, it otherwise reveals bugs *) (* Stm.observe nsid; *) - - let check_proof = Flags.(!compilation_mode = BuildVo || not !batch_mode) in - if check_proof then Stm.finish (); + if check then Stm.finish (); (* We could use a more refined criteria that depends on the vernac. For now we imitate the old approach and rely on the classification. *) - let print_goals = not !Flags.batch_mode && not !Flags.quiet && + let print_goals = interactive && not !Flags.quiet && is_proof_step && Proof_global.there_are_pending_proofs () in if print_goals then Feedback.msg_notice (pr_open_cur_subgoals ()); @@ -167,7 +166,7 @@ let rec interp_vernac sid (loc,com) = with reraise -> (* XXX: In non-interactive mode edit_at seems to do very weird things, so we better avoid it while we investigate *) - if not !Flags.batch_mode then ignore(Stm.edit_at sid); + if interactive then ignore(Stm.edit_at sid); let (reraise, info) = CErrors.push reraise in let info = begin match Loc.get_loc info with @@ -176,9 +175,14 @@ let rec interp_vernac sid (loc,com) = end in iraise (reraise, info) (* Load a vernac file. CErrors are annotated with file and location *) -and load_vernac verbosely sid file = - let chan_beautify = - if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout in +and load_vernac ~verbosely ~check ~interactive sid file = + let ft_beautify, close_beautify = + if !Flags.beautify_file then + let chan_beautify = open_out (file^beautify_suffix) in + set_formatter_translator chan_beautify, fun () -> close_out chan_beautify; + else + !Topfmt.std_ft, fun () -> () + in let in_chan = open_utf8_file_in file in let in_echo = if verbosely then Some (open_utf8_file_in file) else None in let in_pa = Pcoq.Gram.parsable ~file:(Loc.InFile file) (Stream.of_channel in_chan) in @@ -208,11 +212,11 @@ and load_vernac verbosely sid file = *) in (* Printing of vernacs *) - if !Flags.beautify then pr_new_syntax ?loc in_pa chan_beautify (Some ast); + if !Flags.beautify then pr_new_syntax ?loc in_pa ft_beautify (Some ast); Option.iter (vernac_echo ?loc) in_echo; checknav_simple (loc, ast); - let nsid = Flags.silently (interp_vernac !rsid) (loc, ast) in + let nsid = Flags.silently (interp_vernac ~check ~interactive !rsid) (loc, ast) in rsid := nsid done; !rsid @@ -224,11 +228,11 @@ and load_vernac verbosely sid file = | Stm.End_of_input -> (* Is this called so comments at EOF are printed? *) if !Flags.beautify then - pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) in_pa chan_beautify None; - if !Flags.beautify_file then close_out chan_beautify; + pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) in_pa ft_beautify None; + if !Flags.beautify_file then close_beautify (); !rsid | reraise -> - if !Flags.beautify_file then close_out chan_beautify; + if !Flags.beautify_file then close_beautify (); iraise (disable_drop e, info) (** [eval_expr : ?preserving:bool -> Loc.t * Vernacexpr.vernac_expr -> unit] @@ -240,7 +244,7 @@ and load_vernac verbosely sid file = let process_expr sid loc_ast = checknav_deep loc_ast; - interp_vernac sid loc_ast + interp_vernac ~interactive:true ~check:true sid loc_ast let warn_file_no_extension = CWarnings.create ~name:"file-no-extension" ~category:"filesystem" @@ -277,8 +281,10 @@ let ensure_exists f = if not (Sys.file_exists f) then vernac_error (hov 0 (str "Can't find file" ++ spc () ++ str f)) +type compilation_mode = BuildVo | BuildVio | Vio2Vo + (* Compile a vernac file *) -let compile verbosely f = +let compile ~verbosely ~mode ~f_in ~f_out= let check_pending_proofs () = let pfs = Proof_global.get_all_proof_names () in if not (List.is_empty pfs) then @@ -288,12 +294,12 @@ let compile verbosely f = |> prlist_with_sep pr_comma Names.Id.print) ++ str ".") in - match !Flags.compilation_mode with - | Flags.BuildVo -> - let long_f_dot_v = ensure_v f in + match mode with + | BuildVo -> + let long_f_dot_v = ensure_v f_in in ensure_exists long_f_dot_v; let long_f_dot_vo = - match !Flags.compilation_output_name with + match f_out with | None -> long_f_dot_v ^ "o" | Some f -> ensure_vo long_f_dot_v f in let ldir = Flags.verbosely Library.start_library long_f_dot_vo in @@ -304,7 +310,7 @@ let compile verbosely f = Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo; Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n"); let wall_clock1 = Unix.gettimeofday () in - let _ = load_vernac verbosely (Stm.get_current_state ()) long_f_dot_v in + let _ = load_vernac ~verbosely ~check:true ~interactive:false (Stm.get_current_state ()) long_f_dot_v in Stm.join (); let wall_clock2 = Unix.gettimeofday () in check_pending_proofs (); @@ -313,32 +319,31 @@ let compile verbosely f = (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); Aux_file.stop_aux_file (); Dumpglob.end_dump_glob () - | Flags.BuildVio -> - let long_f_dot_v = ensure_v f in + | BuildVio -> + let long_f_dot_v = ensure_v f_in in ensure_exists long_f_dot_v; let long_f_dot_vio = - match !Flags.compilation_output_name with + match f_out with | None -> long_f_dot_v ^ "io" | Some f -> ensure_vio long_f_dot_v f in let ldir = Flags.verbosely Library.start_library long_f_dot_vio in Dumpglob.noglob (); Stm.set_compilation_hints long_f_dot_vio; - let _ = load_vernac verbosely (Stm.get_current_state ()) long_f_dot_v in + let _ = load_vernac ~verbosely ~check:false ~interactive:false (Stm.get_current_state ()) long_f_dot_v in Stm.finish (); check_pending_proofs (); Stm.snapshot_vio ldir long_f_dot_vio; Stm.reset_task_queue () - | Flags.Vio2Vo -> + | Vio2Vo -> let open Filename in - let open Library in Dumpglob.noglob (); - let f = if check_suffix f ".vio" then chop_extension f else f in - let lfdv, sum, lib, univs, disch, tasks, proofs = load_library_todo f in + let f = if check_suffix f_in ".vio" then chop_extension f_in else f_in in + let lfdv, sum, lib, univs, disch, tasks, proofs = Library.load_library_todo f in Stm.set_compilation_hints lfdv; let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in Library.save_library_raw lfdv sum lib univs proofs -let compile v f = +let compile ~verbosely ~mode ~f_in ~f_out = ignore(CoqworkmgrApi.get 1); - compile v f; + compile ~verbosely ~mode ~f_in ~f_out; CoqworkmgrApi.giveback 1 diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index bccf560e16..410dcf0d46 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -17,7 +17,9 @@ val process_expr : Stateid.t -> Vernacexpr.vernac_expr Loc.located -> Stateid.t (** [load_vernac echo sid file] Loads [file] on top of [sid], will echo the commands if [echo] is set. Callers are expected to handle and print errors in form of exceptions. *) -val load_vernac : bool -> Stateid.t -> string -> Stateid.t +val load_vernac : verbosely:bool -> check:bool -> interactive:bool -> Stateid.t -> string -> Stateid.t + +type compilation_mode = BuildVo | BuildVio | Vio2Vo (** Compile a vernac file, (f is assumed without .v suffix) *) -val compile : bool -> string -> unit +val compile : verbosely:bool -> mode:compilation_mode -> f_in:string -> f_out:string option -> unit diff --git a/vernac/command.ml b/vernac/command.ml index 120f9590f2..a1a87d54e0 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -518,7 +518,8 @@ let check_param = function | CLocalDef (na, _, _) -> check_named na | CLocalAssum (nas, Default _, _) -> List.iter check_named nas | CLocalAssum (nas, Generalized _, _) -> () -| CLocalPattern _ -> assert false +| CLocalPattern (loc,_) -> + Loc.raise ?loc (Stream.Error "pattern with quote not allowed here.") let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = check_all_names_different indl; diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 12b68fe38e..189c47aab9 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -84,7 +84,7 @@ let rec contract3' env sigma a b c = function (** Ad-hoc reductions *) let j_nf_betaiotaevar sigma j = - { uj_val = Evarutil.nf_evar sigma j.uj_val; + { uj_val = j.uj_val; uj_type = Reductionops.nf_betaiota sigma j.uj_type } let jv_nf_betaiotaevar sigma jl = @@ -173,7 +173,6 @@ let explain_unbound_var env v = str "No such section variable or assumption: " ++ var ++ str "." let explain_not_type env sigma j = - let j = Evarutil.j_nf_evar sigma j in let pe = pr_ne_context_of (str "In environment") env sigma in let pc,pt = pr_ljudge_env env sigma j in pe ++ str "The term" ++ brk(1,1) ++ pc ++ spc () ++ @@ -241,7 +240,6 @@ let explain_elim_arity env sigma ind sorts c pj okinds = fnl () ++ msg let explain_case_not_inductive env sigma cj = - let cj = Evarutil.j_nf_evar sigma cj in let env = make_all_name_different env sigma in let pc = pr_leconstr_env env sigma cj.uj_val in let pct = pr_leconstr_env env sigma cj.uj_type in @@ -254,7 +252,6 @@ let explain_case_not_inductive env sigma cj = str "which is not a (co-)inductive type." let explain_number_branches env sigma cj expn = - let cj = Evarutil.j_nf_evar sigma cj in let env = make_all_name_different env sigma in let pc = pr_leconstr_env env sigma cj.uj_val in let pct = pr_leconstr_env env sigma cj.uj_type in @@ -263,7 +260,7 @@ let explain_number_branches env sigma cj expn = str "expects " ++ int expn ++ str " branches." let explain_ill_formed_branch env sigma c ci actty expty = - let simp t = Reductionops.nf_betaiota sigma (Evarutil.nf_evar sigma t) in + let simp t = Reductionops.nf_betaiota sigma t in let env = make_all_name_different env sigma in let pc = pr_leconstr_env env sigma c in let pa, pe = pr_explicit env sigma (simp actty) (simp expty) in @@ -300,10 +297,10 @@ let explain_unification_error env sigma p1 p2 = function | NotSameArgSize | NotSameHead | NoCanonicalStructure -> (* Error speaks from itself *) [] | ConversionFailed (env,t1,t2) -> + let t1 = Reductionops.nf_betaiota sigma t1 in + let t2 = Reductionops.nf_betaiota sigma t2 in if EConstr.eq_constr sigma t1 p1 && EConstr.eq_constr sigma t2 p2 then [] else let env = make_all_name_different env sigma in - let t1 = Evarutil.nf_evar sigma t1 in - let t2 = Evarutil.nf_evar sigma t2 in if not (EConstr.eq_constr sigma t1 p1) || not (EConstr.eq_constr sigma t2 p2) then let t1, t2 = pr_explicit env sigma t1 t2 in [str "cannot unify " ++ t1 ++ strbrk " and " ++ t2] @@ -327,8 +324,6 @@ let explain_unification_error env sigma p1 p2 = function | CannotSolveConstraint ((pb,env,t,u),e) -> let t = EConstr.of_constr t in let u = EConstr.of_constr u in - let t = Evarutil.nf_evar sigma t in - let u = Evarutil.nf_evar sigma u in let env = make_all_name_different env sigma in (strbrk "cannot satisfy constraint " ++ pr_leconstr_env env sigma t ++ str " == " ++ pr_leconstr_env env sigma u) @@ -359,9 +354,7 @@ let explain_actual_type env sigma j t reason = let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = let randl = jv_nf_betaiotaevar sigma randl in - let exptyp = Evarutil.nf_evar sigma exptyp in let actualtyp = Reductionops.nf_betaiota sigma actualtyp in - let rator = Evarutil.j_nf_evar sigma rator in let env = make_all_name_different env sigma in let actualtyp, exptyp = pr_explicit env sigma actualtyp exptyp in let nargs = Array.length randl in @@ -386,8 +379,6 @@ let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = exptyp ++ str "." let explain_cant_apply_not_functional env sigma rator randl = - let randl = Evarutil.jv_nf_evar sigma randl in - let rator = Evarutil.j_nf_evar sigma rator in let env = make_all_name_different env sigma in let nargs = Array.length randl in (* let pe = pr_ne_context_of (str "in environment") env sigma in*) @@ -407,8 +398,6 @@ let explain_cant_apply_not_functional env sigma rator randl = fnl () ++ str " " ++ v 0 appl let explain_unexpected_type env sigma actual_type expected_type = - let actual_type = Evarutil.nf_evar sigma actual_type in - let expected_type = Evarutil.nf_evar sigma expected_type in let pract, prexp = pr_explicit env sigma actual_type expected_type in str "Found type" ++ spc () ++ pract ++ spc () ++ str "where" ++ spc () ++ prexp ++ str " was expected." @@ -510,8 +499,6 @@ let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = with e when CErrors.noncritical e -> mt ()) let explain_ill_typed_rec_body env sigma i names vdefj vargs = - let vdefj = Evarutil.jv_nf_evar sigma vdefj in - let vargs = Array.map (Evarutil.nf_evar sigma) vargs in let env = make_all_name_different env sigma in let pvd = pr_leconstr_env env sigma vdefj.(i).uj_val in let pvdt, pv = pr_explicit env sigma vdefj.(i).uj_type vargs.(i) in @@ -575,9 +562,9 @@ let rec explain_evar_kind env sigma evk ty = function | Evar_kinds.SubEvar evk' -> let evi = Evd.find sigma evk' in let pc = match evi.evar_body with - | Evar_defined c -> pr_leconstr_env env sigma (Evarutil.nf_evar sigma (EConstr.of_constr c)) + | Evar_defined c -> pr_leconstr_env env sigma (EConstr.of_constr c) | Evar_empty -> assert false in - let ty' = Evarutil.nf_evar sigma (EConstr.of_constr evi.evar_concl) in + let ty' = EConstr.of_constr evi.evar_concl in pr_existential_key sigma evk ++ str " of type " ++ ty ++ str " in the partial instance " ++ pc ++ str " found for " ++ explain_evar_kind env sigma evk' @@ -628,8 +615,6 @@ let explain_wrong_case_info env (ind,u) ci = let explain_cannot_unify env sigma m n e = let env = make_all_name_different env sigma in - let m = Evarutil.nf_evar sigma m in - let n = Evarutil.nf_evar sigma n in let pm, pn = pr_explicit env sigma m n in let ppreason = explain_unification_error env sigma m n e in let pe = pr_ne_context_of (str "In environment") env sigma in diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 5298ef2e44..b2d48bb2f9 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -991,7 +991,7 @@ let is_not_printable onlyparse nonreversible = function (warn_non_reversible_notation (); true) else onlyparse -let find_precedence lev etyps symbols = +let find_precedence lev etyps symbols onlyprint = let first_symbol = let rec aux = function | Break _ :: t -> aux t @@ -1009,8 +1009,13 @@ let find_precedence lev etyps symbols = | None -> [],0 | Some (NonTerminal x) -> (try match List.assoc x etyps with - | ETConstr _ -> - user_err Pp.(str "The level of the leftmost non-terminal cannot be changed.") + | ETConstr _ -> + if onlyprint then + if Option.is_empty lev then + user_err Pp.(str "Explicit level needed in only-printing mode when the level of the leftmost non-terminal is given.") + else [],Option.get lev + else + user_err Pp.(str "The level of the leftmost non-terminal cannot be changed.") | ETName | ETBigint | ETReference -> begin match lev with | None -> @@ -1134,7 +1139,7 @@ let compute_syntax_data df modifiers = let need_squash = not (List.equal Notation.symbol_eq symbols symbols_for_grammar) in let ntn_for_grammar = if need_squash then make_notation_key symbols_for_grammar else ntn_for_interp in if not onlyprint then check_rule_productivity symbols_for_grammar; - let msgs,n = find_precedence mods.level mods.etyps symbols in + let msgs,n = find_precedence mods.level mods.etyps symbols onlyprint in (* To globalize... *) let etyps = join_auxiliary_recursive_types recvars mods.etyps in let sy_typs, prec = diff --git a/vernac/mltop.ml b/vernac/mltop.ml index 1edbd1a850..d3de10235f 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -174,6 +174,7 @@ let warn_cannot_use_directory = let convert_string d = try Names.Id.of_string d with UserError _ -> + let d = Unicode.escaped_if_non_utf8 d in warn_cannot_use_directory d; raise Exit diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 83296cf58f..203d913db8 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1785,7 +1785,7 @@ let vernac_locate = let open Feedback in function (Constrextern.without_symbols pr_lglob_constr) ntn sc) | LocateLibrary qid -> print_located_library qid | LocateModule qid -> msg_notice (print_located_module qid) - | LocateTactic qid -> msg_notice (print_located_tactic qid) + | LocateOther (s, qid) -> msg_notice (print_located_other s qid) | LocateFile f -> msg_notice (locate_file f) let vernac_register id r = |