diff options
35 files changed, 837 insertions, 503 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index a2bc490198..cf9be860f9 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -175,8 +175,8 @@ after_script: artifacts: name: "%CI_JOB_NAME%" paths: - - dev\nsis\*.exe - - coq-opensource-archive-windows-*.zip + - artifacts + when: always expire_in: 1 week dependencies: [] tags: diff --git a/default.nix b/default.nix index 88992a30a3..29c0c68174 100644 --- a/default.nix +++ b/default.nix @@ -23,8 +23,8 @@ { pkgs ? (import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/947ae71dcec680b5075ece14e38eae64831b9819.tar.gz"; - sha256 = "15nryymfch4fzxk6nacli4gw4cyicpdjwzai5v3bc0azaslww2x5"; + url = "https://github.com/NixOS/nixpkgs/archive/52a1179b6c20e923beddde1dd1e0034aa19176d2.tar.gz"; + sha256 = "040xrsgnip6gqljfyy1ad0l7q41h659h5hqbcn96bzhdiakcr4yc"; }) {}) , ocamlPackages ? pkgs.ocaml-ng.ocamlPackages_4_06 , buildIde ? true diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index 5af0fcff3a..61cf6bc4cc 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -247,7 +247,7 @@ IF "%~0" == "-addon" ( IF NOT "%~0" == "" ( ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW ECHO !!! Illegal parameter %~0 - ECHO Usage: + ECHO Usage: ECHO MakeCoq_MinGW CALL :PrintPars GOTO :EOF @@ -267,7 +267,6 @@ IF "%INSTALLMODE%" == "mingwincygwin" ( IF "%MAKEINSTALLER%" == "Y" ( SET INSTALLMODE=relocatable - SET INSTALLOCAML=Y ) REM ========== CONFIRM PARAMETERS ========== @@ -275,7 +274,7 @@ REM ========== CONFIRM PARAMETERS ========== CALL :PrintPars REM Note: DOS batch replaces variables on parsing, so one can't use a variable just set in an () block IF "%COQREGTESTING%"=="Y" (GOTO DontAsk) - SET /p ANSWER=Is this correct? y/n + SET /p ANSWER="Is this correct? y/n " IF NOT "%ANSWER%"=="y" (GOTO :EOF) :DontAsk @@ -315,12 +314,13 @@ ECHO RESULT INSTALL DIR (MINGW) = %RESULT_INSTALLDIR_MFMT% ECHO RESULT INSTALL DIR (CYGWIN) = %RESULT_INSTALLDIR_CFMT% REM WARNING: Add a space after the = in case you want set this to empty, otherwise the variable will be unset -SET MAKE_OPT=-j %MAKE_THREADS% +SET MAKE_OPT=-j %MAKE_THREADS% REM ========== DERIVED CYGWIN SETUP OPTIONS ========== -REM WARNING: Add a space after the = otherwise the variable will be unset -SET CYGWIN_OPT= +REM One can't set a variable to empty in DOS, but you can set it to a space this way. +REM The quotes are just there to make the space visible and to protect from "remove trailing spaces". +SET "CYGWIN_OPT= " IF "%CYGWIN_FROM_CACHE%" == "Y" ( SET CYGWIN_OPT= %CYGWIN_OPT% -L @@ -334,8 +334,6 @@ IF "%GTK_FROM_SOURCES%"=="N" ( SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk2.0,mingw64-%ARCH%-gtksourceview2.0 ) -ECHO ========== INSTALL CYGWIN ========== - REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES. REM Otherwise chmod won't work and e.g. the ocaml build will fail. REM Cygwin setup does not touch the ACLs of existing folders. @@ -349,7 +347,10 @@ IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" ( IF NOT "%CYGWIN_QUIET%" == "Y" ( SET RUNSETUP=Y ) + IF "%COQREGTESTING%" == "Y" ( + ECHO "========== REMOVE EXISTING CYGWIN ==========" + DEL /S /F /Q "%CYGWIN_INSTALLDIR_WFMT%" > NUL SET RUNSETUP=Y ) @@ -359,6 +360,8 @@ IF NOT "%APPVEYOR%" == "True" ( SET EXTRAPACKAGES=-P wget,curl,git,gcc-core,gcc-g++,automake1.5 ) +ECHO "========== INSTALL CYGWIN ==========" + IF "%RUNSETUP%"=="Y" ( %SETUP% ^ --proxy "%PROXY%" ^ @@ -436,10 +439,10 @@ ECHO ========== BATCH FUNCTIONS ========== ECHO -proxy ^<internet proxy^> ECHO -cygrepo ^<cygwin download repository^> ECHO -cygcache ^<local cygwin repository/cache^> - ECHO -cyglocal ^<Y or N^> install cygwin from cache + ECHO -cyglocal ^<Y or N^> install cygwin from cache ECHO -cygquiet ^<Y or N^> install cygwin without user interaction ECHO -srccache ^<local source code repository/cache^> - ECHO -coqver ^<Coq version to install^> + ECHO -coqver ^<Coq version to install^> ECHO -gtksrc ^<Y or N^> build GTK ^(90 min^) or use cygwin version ECHO -threads ^<1..N^> Number of make threads ECHO -addon ^<name^> Enable building selected addon (can be repeated) @@ -452,9 +455,9 @@ ECHO ========== BATCH FUNCTIONS ========== ECHO -ocaml = %INSTALLOCAML% ECHO -installer= %MAKEINSTALLER% ECHO -make = %INSTALLMAKE% - ECHO -destcyg = %DESTCYG% - ECHO -destcoq = %DESTCOQ% - ECHO -setup = %SETUP% + ECHO -destcyg = %DESTCYG% + ECHO -destcoq = %DESTCOQ% + ECHO -setup = %SETUP% ECHO -proxy = %PROXY% ECHO -cygrepo = %CYGWIN_REPOSITORY% ECHO -cygcache = %CYGWIN_LOCAL_CACHE_WFMT% diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 2a29b0d3b6..23eb6fbc63 100644..100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -18,6 +18,8 @@ set -o nounset set -o errexit set -x +# Print current wall time as part of the xtrace +export PS4='+\t ' # Set this to 1 if all module directories shall be removed before build (no incremental make) RMDIR_BEFORE_BUILD=1 @@ -119,7 +121,11 @@ mkdir -p "$PREFIXCOQ/bin" mkdir -p "$PREFIXOCAML/bin" # This is required for building addons and plugins +# This must be CFMT (/cygdrive/c/...) otherwise coquelicot 3.0.2 configure fails. +# coquelicot uses which ${COQBIN}/coqc to check if coqc exists. This does not work with COQBIN in MFMT. export COQBIN=$RESULT_INSTALLDIR_CFMT/bin/ +# This must be MFMT (C:/) otherwise bignums 68a7a3d7e0b21985913a6c3ee12067f4c5ac4e20 fails +export COQLIB=$RESULT_INSTALLDIR_MFMT/lib/coq/ ###################### Copy Cygwin Setup Info ##################### @@ -145,27 +151,64 @@ LOGS=$(pwd)/buildlogs # The current log target (first part of the log file name) LOGTARGET=other -# Log command output - take log target name from command name (like log1 make => log target is "<module>-make") -log1() { - "$@" > >(tee "$LOGS/$LOGTARGET-$1.log" | sed -e "s/^/$LOGTARGET-$1.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1.err" | sed -e "s/^/$LOGTARGET-$1.err: /" 1>&2) -} - -# Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") -log2() { - "$@" > >(tee "$LOGS/$LOGTARGET-$1-$2.log" | sed -e "s/^/$LOGTARGET-$1-$2.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$2.err" | sed -e "s/^/$LOGTARGET-$1-$2.err: /" 1>&2) -} - -# Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") -log_1_3() { - "$@" > >(tee "$LOGS/$LOGTARGET-$1-$3.log" | sed -e "s/^/$LOGTARGET-$1-$3.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$3.err" | sed -e "s/^/$LOGTARGET-$1-$3.err: /" 1>&2) -} - -# Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") -logn() { - LOGTARGETEX=$1 - shift - "$@" > >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.log" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.log: /") 2> >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.err" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.err: /" 1>&2) -} +# For an explanation of ${COQREGTESTING:-N} search for ${parameter:-word} in +# http://pubs.opengroup.org/onlinepubs/009695399/utilities/xcu_chap02.html + +if [ "${COQREGTESTING:-N}" == "Y" ] ; then + # If COQREGTESTING, log to log files only + # Log command output - take log target name from command name (like log1 make => log target is "<module>-make") + log1() { + { local -; set +x; } 2> /dev/null + "$@" >"$LOGS/$LOGTARGET-$1.log" 2>"$LOGS/$LOGTARGET-$1.err" + } + + # Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") + log2() { + { local -; set +x; } 2> /dev/null + "$@" >"$LOGS/$LOGTARGET-$1-$2.log" 2>"$LOGS/$LOGTARGET-$1-$2.err" + } + + # Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") + log_1_3() { + { local -; set +x; } 2> /dev/null + "$@" >"$LOGS/$LOGTARGET-$1-$3.log" 2>"$LOGS/$LOGTARGET-$1-$3.err" + } + + # Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") + logn() { + { local -; set +x; } 2> /dev/null + LOGTARGETEX=$1 + shift + "$@" >"$LOGS/$LOGTARGET-$LOGTARGETEX.log" 2>"$LOGS/$LOGTARGET-$LOGTARGETEX.err" + } +else + # If COQREGTESTING, log to log files and console + # Log command output - take log target name from command name (like log1 make => log target is "<module>-make") + log1() { + { local -; set +x; } 2> /dev/null + "$@" > >(tee "$LOGS/$LOGTARGET-$1.log" | sed -e "s/^/$LOGTARGET-$1.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1.err" | sed -e "s/^/$LOGTARGET-$1.err: /" 1>&2) + } + + # Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") + log2() { + { local -; set +x; } 2> /dev/null + "$@" > >(tee "$LOGS/$LOGTARGET-$1-$2.log" | sed -e "s/^/$LOGTARGET-$1-$2.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$2.err" | sed -e "s/^/$LOGTARGET-$1-$2.err: /" 1>&2) + } + + # Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") + log_1_3() { + { local -; set +x; } 2> /dev/null + "$@" > >(tee "$LOGS/$LOGTARGET-$1-$3.log" | sed -e "s/^/$LOGTARGET-$1-$3.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$3.err" | sed -e "s/^/$LOGTARGET-$1-$3.err: /" 1>&2) + } + + # Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") + logn() { + { local -; set +x; } 2> /dev/null + LOGTARGETEX=$1 + shift + "$@" > >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.log" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.log: /") 2> >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.err" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.err: /" 1>&2) + } +fi ###################### 'UNFIX' SED ##################### @@ -229,7 +272,7 @@ function get_expand_source_tar { if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" ] ; then cp "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" "$TARBALLS" else - wget "$1/$2.$3" + wget --progress=dot:giga "$1/$2.$3" if file -i "$2.$3" | grep text/html; then echo Download failed: "$1/$2.$3" echo The file wget downloaded is an html file: @@ -260,8 +303,8 @@ function get_expand_source_tar { if [ "$3" == "zip" ] ; then log1 unzip "$TARBALLS/$name.$3" if [ "$strip" == "1" ] ; then - # Ok, this is dirty, but it works and it fails if there are name clashes - mv -- */* . + # move subfolders of root folders one level up + find "$(ls)" -mindepth 1 -maxdepth 1 -exec mv -- "{}" . \; else echo "Unzip strip count not supported" return 1 @@ -314,13 +357,13 @@ function build_prep { fi # Check if build is already done - if [ ! -f "flagfiles/$name.finished" ] ; then + if [ ! -f "$FLAGFILES/$name.finished" ] ; then BUILD_PACKAGE_NAME=$name BUILD_OLDPATH=$PATH BUILD_OLDPWD=$(pwd) LOGTARGET=$name - touch "flagfiles/$name.started" + touch "$FLAGFILES/$name.started" get_expand_source_tar "$1" "$2" "$3" "$strip" "$name" @@ -344,9 +387,9 @@ function build_prep { # ------------------------------------------------------------------------------ function build_post { - if [ ! -f "flagfiles/$BUILD_PACKAGE_NAME.finished" ]; then + if [ ! -f "$FLAGFILES/$BUILD_PACKAGE_NAME.finished" ]; then cd "$BUILD_OLDPWD" - touch "flagfiles/$BUILD_PACKAGE_NAME.finished" + touch "$FLAGFILES/$BUILD_PACKAGE_NAME.finished" PATH=$BUILD_OLDPATH LOGTARGET=other fi @@ -384,19 +427,17 @@ function build_conf_make_inst { # Install all files given by a glob pattern to a given folder # # parameters -# $1 glob pattern (in '') -# $2 target folder +# $1 source path +# $2 pattern (in '') +# $3 target folder # ------------------------------------------------------------------------------ function install_glob { - # Check if any files matching the pattern exist - if [ "$(echo $1)" != "$1" ] ; then - # shellcheck disable=SC2086 - install -D -t $2 $1 - fi + SRCDIR=$(realpath -m $1) + DESTDIR=$(realpath -m $3) + ( cd "$SRCDIR" && find . -maxdepth 1 -type f -name "$2" -exec install -D -T "$SRCDIR"/{} "$DESTDIR"/{} \; ) } - # ------------------------------------------------------------------------------ # Recursively Install all files given by a glob pattern to a given folder # @@ -407,12 +448,15 @@ function install_glob { # ------------------------------------------------------------------------------ function install_rec { - ( cd "$1" && find . -type f -name "$2" -exec install -D -T "$1"/{} "$3"/{} \; ) + SRCDIR=$(realpath -m $1) + DESTDIR=$(realpath -m $3) + ( cd "$SRCDIR" && find . -type f -name "$2" -exec install -D -T "$SRCDIR"/{} "$DESTDIR"/{} \; ) } # ------------------------------------------------------------------------------ # Write a file list of the target folder # The file lists are used to create file lists for the windows installer +# Don't overwrite an existing file list # # parameters # $1 name of file list @@ -425,6 +469,19 @@ function list_files { } # ------------------------------------------------------------------------------ +# Write a file list of the target folder +# The file lists are used to create file lists for the windows installer +# Do overwrite an existing file list +# +# parameters +# $1 name of file list +# ------------------------------------------------------------------------------ + +function list_files_always { + ( cd "$PREFIXCOQ" && find . -type f | sort > /build/filelists/"$1" ) +} + +# ------------------------------------------------------------------------------ # Compute the set difference of two file lists # # parameters @@ -777,15 +834,15 @@ function make_flex_dll_link { # For this purpose hard links are better. function make_ln { - if [ ! -f flagfiles/myln.finished ] ; then - touch flagfiles/myln.started + if [ ! -f $FLAGFILES/myln.finished ] ; then + touch $FLAGFILES/myln.started mkdir -p myln ( cd myln cp $PATCHES/ln.c . "$TARGET_ARCH-gcc" -DUNICODE -D_UNICODE -DIGNORE_SYMBOLIC -mconsole -o ln.exe ln.c install -D ln.exe "$PREFIXCOQ/bin/ln.exe" ) - touch flagfiles/myln.finished + touch $FLAGFILES/myln.finished fi } @@ -848,7 +905,6 @@ function make_ocaml { function make_ocaml_tools { make_findlib - # make_menhir make_camlp5 } @@ -865,7 +921,7 @@ function make_ocaml_libs { function make_num { make_ocaml # We need this commit due to windows fixed, IMHO this is better than patching v1.1. - if build_prep https://github.com/ocaml/num/archive/ 7dd5e935aaa2b902585b3b2d0e55ad9b2442fff0 zip 1 num-1.1-7d; then + if build_prep https://github.com/ocaml/num/archive 7dd5e935aaa2b902585b3b2d0e55ad9b2442fff0 zip 1 num-1.1-7d; then log2 make all # log2 make test log2 make install @@ -874,10 +930,23 @@ function make_num { fi } +##### OCAMLBUILD ##### + +function make_ocamlbuild { + make_ocaml + if build_prep https://github.com/ocaml/ocamlbuild/archive 0.12.0 tar.gz 1 ocamlbuild-0.12.0; then + log2 make configure OCAML_NATIVE=true OCAMLBUILD_PREFIX=$PREFIXOCAML OCAMLBUILD_BINDIR=$PREFIXOCAML/bin OCAMLBUILD_LIBDIR=$PREFIXOCAML/lib + log1 make + log2 make install + build_post + fi +} + ##### FINDLIB Ocaml library manager ##### function make_findlib { make_ocaml + make_ocamlbuild if build_prep https://opam.ocaml.org/1.2.2/archives ocamlfind.1.8.0+opam tar.gz 1 ; then logn configure ./configure -bindir "$PREFIXOCAML\\bin" -sitelib "$PREFIXOCAML\\libocaml\\site-lib" -config "$PREFIXOCAML\\etc\\findlib.conf" # Note: findlib doesn't support -j 8, so don't pass MAKE_OPT @@ -885,6 +954,10 @@ function make_findlib { log2 make opt log2 make install log2 make clean + # Add Coq install library path to ocamlfind config file + # $(ocamlfind printconf conf | tr -d '\r') is the name of the config file + # printf "%q" "$PREFIXCOQ/lib" | sed -e 's/\\/\\\\/g' is the coq lib path double escaped for sed + sed -i -e 's|path="\(.*\)"|path="\1;'$(printf "%q" "$PREFIXCOQ/lib" | sed -e 's/\\/\\\\/g')'"|' $(ocamlfind printconf conf | tr -d '\r') build_post fi } @@ -894,15 +967,11 @@ function make_findlib { function make_menhir { make_ocaml make_findlib - # if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20151112 tar.gz 1 ; then - # For Ocaml 4.02 - # if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20151012 tar.gz 1 ; then - # For Ocaml 4.01 - if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20140422 tar.gz 1 ; then + make_ocamlbuild + if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20180530 tar.gz 1 ; then # Note: menhir doesn't support -j 8, so don't pass MAKE_OPT log2 make all PREFIX="$PREFIXOCAML" log2 make install PREFIX="$PREFIXOCAML" - mv "$PREFIXOCAML/bin/menhir" "$PREFIXOCAML/bin/menhir.exe" build_post fi } @@ -1085,13 +1154,13 @@ function copy_coq_dlls { function copy_coq_objects { # copy objects only from folders which exist in the target lib directory find . -type d | while read -r FOLDER ; do - if [ -e "$PREFIXCOQ/lib/$FOLDER" ] ; then - install_glob "$FOLDER"/'*.cmxa' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.cmi' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.cma' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.cmo' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.a' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.o' "$PREFIXCOQ/lib/$FOLDER" + if [ -e "$PREFIXCOQ/lib/coq/$FOLDER" ] ; then + install_glob "$FOLDER" '*.cmxa' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.cmi' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.cma' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.cmo' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.a' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.o' "$PREFIXCOQ/lib/coq/$FOLDER" fi done } @@ -1103,10 +1172,10 @@ function copq_coq_gtk { echo 'gtk-fallback-icon-theme = "Tango"' >> "$PREFIX/etc/gtk-2.0/gtkrc" if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - install_glob "$PREFIX/etc/gtk-2.0/"'*' "$PREFIXCOQ/gtk-2.0" - install_glob "$PREFIX/share/gtksourceview-2.0/language-specs/"'*' "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" - install_glob "$PREFIX/share/gtksourceview-2.0/styles/"'*' "$PREFIXCOQ/share/gtksourceview-2.0/styles" - install_rec "$PREFIX/share/themes/" '*' "$PREFIXCOQ/share/themes" + install_glob "$PREFIX/etc/gtk-2.0" '*' "$PREFIXCOQ/gtk-2.0" + install_glob "$PREFIX/share/gtksourceview-2.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" + install_glob "$PREFIX/share/gtksourceview-2.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-2.0/styles" + install_rec "$PREFIX/share/themes" '*' "$PREFIXCOQ/share/themes" # This below item look like a bug in make install if [ -d "$PREFIXCOQ/share/coq/" ] ; then @@ -1136,7 +1205,7 @@ function copy_coq_license { install -D README.md "$PREFIXCOQ/license_readme/coq/ReadMe.md" install -D CHANGES "$PREFIXCOQ/license_readme/coq/Changes.txt" install -D INSTALL "$PREFIXCOQ/license_readme/coq/Install.txt" - install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" + install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" || true fi } @@ -1175,11 +1244,11 @@ function make_coq { then if [ "$INSTALLMODE" == "relocatable" ]; then # HACK: for relocatable builds, first configure with ./, then build but before install reconfigure with the real target path - ./configure -with-doc no -prefix ./ -libdir ./lib -mandir ./man + logn configure ./configure -with-doc no -prefix ./ -libdir ./lib/coq -mandir ./man elif [ "$INSTALLMODE" == "absolute" ]; then - ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" + logn configure ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib/coq" -mandir "$PREFIXCOQ/man" else - ./configure -with-doc no -prefix "$PREFIXCOQ" + logn configure ./configure -with-doc no -prefix "$PREFIXCOQ" fi # The windows resource compiler binary name is hard coded @@ -1191,21 +1260,21 @@ function make_coq { log1 make else # shellcheck disable=SC2086 - make $MAKE_OPT + log1 make $MAKE_OPT fi if [ "$INSTALLMODE" == "relocatable" ]; then - ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" + logn reconfigure ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib/coq" -mandir "$PREFIXCOQ/man" fi - make install - copy_coq_dlls + log2 make install + log1 copy_coq_dlls if [ "$INSTALLOCAML" == "Y" ]; then copy_coq_objects fi - copq_coq_gtk - copy_coq_license + log1 copq_coq_gtk + log1 copy_coq_license # make clean seems to be broken for 8.5pl2 # 1.) find | xargs fails on cygwin, can be fixed by sed -i 's|\| xargs rm -f|-exec rm -fv \{\} \+|' Makefile @@ -1213,8 +1282,8 @@ function make_coq { # make clean # Copy these files somewhere the plugin builds can find them - cp dev/ci/ci-basic-overlay.sh /build/ - cp -r dev/ci/user-overlays /build/ + logn copy-basic-overlays cp dev/ci/ci-basic-overlay.sh /build/ + logn copy-user-overlays cp -r dev/ci/user-overlays /build/ build_post fi @@ -1283,8 +1352,8 @@ function make_gcc { ##### Get sources for Cygwin MinGW packages ##### function get_cygwin_mingw_sources { - if [ ! -f flagfiles/cygwin_mingw_sources.finished ] ; then - touch flagfiles/cygwin_mingw_sources.started + if [ ! -f $FLAGFILES/cygwin_mingw_sources.finished ] ; then + touch $FLAGFILES/cygwin_mingw_sources.started # Find all installed files with mingw in the name and download the corresponding source code file from cygwin # Steps: @@ -1311,7 +1380,7 @@ function get_cygwin_mingw_sources { if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" ] ; then cp "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" $TARBALLS else - wget "$CYGWIN_REPOSITORY/$SOURCE" + wget --progress=dot:giga "$CYGWIN_REPOSITORY/$SOURCE" mv "$SOURCEFILE" "$TARBALLS" # Save the source archive in the source cache if [ -d "$SOURCE_LOCAL_CACHE_CFMT" ] ; then @@ -1322,7 +1391,7 @@ function get_cygwin_mingw_sources { done - touch flagfiles/cygwin_mingw_sources.finished + touch $FLAGFILES/cygwin_mingw_sources.finished fi } @@ -1344,7 +1413,7 @@ function make_coq_installer { filter_files coq_objects coq '\.(cmxa|cmi|cma|cmo|a|o)$' # Filter out plugin object files - filter_files coq_objects_plugins coq_objects '/lib/plugins/.*\.(cmxa|cmi|cma|cmo|a|o)$' + filter_files coq_objects_plugins coq_objects '/lib/coq/plugins/.*\.(cmxa|cmi|cma|cmo|a|o)$' # Coq objects objects required for plugin development = coq objects except those for pre installed plugins diff_files coq_plugindev coq_objects coq_objects_plugins @@ -1460,6 +1529,8 @@ function make_addons { ###################### TOP LEVEL BUILD ##################### +ocamlfind list || true + make_sed make_ocaml make_ocaml_tools @@ -1477,7 +1548,7 @@ list_files ocaml_coq make_addons -list_files ocaml_coq_addons +list_files_always ocaml_coq_addons if [ "$MAKEINSTALLER" == "Y" ] ; then make_coq_installer diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat index 973319de68..31bd65af08 100644..100755 --- a/dev/ci/gitlab.bat +++ b/dev/ci/gitlab.bat @@ -2,6 +2,16 @@ REM This script builds and signs the Windows packages on Gitlab +ECHO "Start Time" +TIME /T + +REM List currently used cygwin and target folders for debugging / maintenance purposes + +ECHO "Currently used cygwin folders" +DIR C:\cygwin* +ECHO "Currently used target folders" +DIR C:\coq* + if %ARCH% == 32 ( SET ARCHLONG=i686 SET CYGROOT=C:\cygwin @@ -14,11 +24,15 @@ if %ARCH% == 64 ( SET SETUP=setup-x86_64.exe ) +SET DESTCOQ=C:\coq%ARCH%_inst + +CALL :MakeUniqueFolder %CYGROOT% CYGROOT +CALL :MakeUniqueFolder %DESTCOQ% DESTCOQ + powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/%SETUP%', '%SETUP%')" SET CYGCACHE=%CYGROOT%\var\cache\setup SET CI_PROJECT_DIR_MFMT=%CI_PROJECT_DIR:\=/% SET CI_PROJECT_DIR_CFMT=%CI_PROJECT_DIR_MFMT:C:/=/cygdrive/c/% -SET DESTCOQ=C:\coq%ARCH%_inst SET COQREGTESTING=Y SET PATH=%PATH%;C:\Program Files\7-Zip\;C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin @@ -29,10 +43,24 @@ call %CI_PROJECT_DIR%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^ -arch=%ARCH% -installer=Y -coqver=%CI_PROJECT_DIR_CFMT% ^ -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^ -addon="bignums ltac2 equations" -make=N ^ - -setup %CI_PROJECT_DIR%\%SETUP% || GOTO ErrorExit + -setup %CI_PROJECT_DIR%\%SETUP% || GOTO ErrorCopyLogFilesAndExit + + +ECHO "Start Artifact Creation" +TIME /T + +mkdir artifacts -copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis || GOTO ErrorExit -7z a coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit +CALL :CopyLogFiles + +copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" artifacts || GOTO ErrorExit +REM The open source archive is only required for release builds +IF DEFINED WIN_CERTIFICATE_PATH ( + 7z a artifacts\coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit +) ELSE ( + REM In non release builds, create a dummy file + ECHO "This is not a release build - open source archive not created / uploaded" > artifacts\coq-opensource-info.txt +) REM DO NOT echo the signing command below, as this would leak secrets in the logs IF DEFINED WIN_CERTIFICATE_PATH ( @@ -43,8 +71,49 @@ IF DEFINED WIN_CERTIFICATE_PATH ( ) ) +ECHO "Finished Artifact Creation" +TIME /T + +CALL :CleanupFolders + +ECHO "Finished Cleanup" +TIME /T + GOTO :EOF +:CopyLogFiles + ECHO Copy log files for artifact upload + MKDIR artifacts\buildlogs + COPY %CYGROOT%\build\buildlogs\* artifacts\buildlogs + MKDIR artifacts\filelists + COPY %CYGROOT%\build\filelists\* artifacts\filelists + MKDIR artifacts\flagfiles + COPY %CYGROOT%\build\flagfiles\* artifacts\flagfiles + GOTO :EOF + +:CleanupFolders + ECHO "Cleaning %CYGROOT%" + DEL /S /F /Q "%CYGROOT%" > NUL + ECHO "Cleaning %DESTCOQ%" + DEL /S /F /Q "%DESTCOQ%" > NUL + GOTO :EOF + +:MakeUniqueFolder + REM Create a uniquely named folder + REM This script is safe because folder creation is atomic - either we create it or fail + REM %1 = base path or directory (_%RANDOM%_%RANDOM% is appended to this) + REM %2 = name of the variable which receives the unique folder name + SET "UNIQUENAME=%1_%RANDOM%_%RANDOM%" + MKDIR "%UNIQUENAME%" + IF ERRORLEVEL 1 GOTO :MakeUniqueFolder + SET "%2=%UNIQUENAME%" + GOTO :EOF + +:ErrorCopyLogFilesAndExit + CALL :CopyLogFiles + REM fall through + :ErrorExit + CALL :CleanupFolders ECHO ERROR %0 failed EXIT /b 1 diff --git a/dev/doc/profiling.txt b/dev/doc/profiling.txt index b5dd8445db..45766293c7 100644 --- a/dev/doc/profiling.txt +++ b/dev/doc/profiling.txt @@ -21,6 +21,58 @@ and plug into the process perf record -g -p PID +### Per-component [flame graphs](https://github.com/brendangregg/FlameGraph) + +I (Andres Erbsen) have found it useful to look at library-wide flame graphs of +coq time consumption. As the Ltac interpreter stack is reflected in the OCaml +stack, calls to the same primitive can appear on top of multiple essentially +equivalent stacks. To make the profiles more readable, one could either try to +edit the stack trace to merge "equivalent" frames, or simply look at the +aggregate profile on a component-by-component basis. Here is how to do the +second for the standard library ([example output](https://cdn.rawgit.com/andres-erbsen/b29b29cb6480dfc6a662062e4fcd0ae3/raw/304fc3fea9630c8e453929aa7920ca8a2a570d0b/stdlib_categorized_outermost.svg)). + +~~~~~ +#!/bin/bash +make -f Makefile.dune clean +make -f Makefile.dune states +perf record -F99 `# ~1GB of data` --call-graph=dwarf -- make -f Makefile.dune world +perf script --time '0%-100%' | + stackcollapse-perf.pl | + grep Coqtop__compile | + sed -rf <(cat <<'EOF' + s/;caml/;/g + s/_[0-9]*;/;/g + s/Logic_monad__fun;//g + s/_apply[0-9];//g + s/;System/@&@/ + s/;Hashcons/@&@/ + s/;Grammar/@&@/ + s/;Declaremods/@&@/ + s/;Tactics/@&@/ + s/;Pretyping/@&@/ + s/;Typeops/@&@/ + s/;Reduction/@&@/ + s/;Unification/@&@/ + s/;Evarutil/@&@/ + s/;Evd/@&@/ + s/;EConstr/@&@/ + s/;Constr/@&@/ + s/;Univ/@&@/ + s/;Ugraph/@&@/ + s/;UState/@&@/ + s/;Micromega/@&@/ + s/;Omega/@&@/ + s/;Auto/@&@/ + s/;Ltac_plugin__Tacinterp/@&@/ + s/;Ltac_plugin__Rewrite/@&@/ + s/[^@]*@;([^@]*)@/\1;\1/ + s/@//g + :a; s/;([^;]+);\1;/;\1;/g;ta +EOF + ) | + flamegraph.pl +~~~~~ + ## Memory You first need a few commits atop trunk for this to work. diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 2913645c1c..678f7c6ce6 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -445,10 +445,22 @@ let fold sigma f acc c = match kind sigma c with let compare_gen k eq_inst eq_sort eq_constr nargs c1 c2 = (c1 == c2) || Constr.compare_head_gen_with k k eq_inst eq_sort eq_constr nargs c1 c2 +let eq_einstance sigma i1 i2 = + let i1 = EInstance.kind sigma (EInstance.make i1) in + let i2 = EInstance.kind sigma (EInstance.make i2) in + Univ.Instance.equal i1 i2 + +let eq_esorts sigma s1 s2 = + let s1 = ESorts.kind sigma (ESorts.make s1) in + let s2 = ESorts.kind sigma (ESorts.make s2) in + Sorts.equal s1 s2 + let eq_constr sigma c1 c2 = let kind c = kind_upto sigma c in + let eq_inst _ _ i1 i2 = eq_einstance sigma i1 i2 in + let eq_sorts s1 s2 = eq_esorts sigma s1 s2 in let rec eq_constr nargs c1 c2 = - compare_gen kind (fun _ _ -> Univ.Instance.equal) Sorts.equal eq_constr nargs c1 c2 + compare_gen kind eq_inst eq_sorts eq_constr nargs c1 c2 in eq_constr 0 (unsafe_to_constr c1) (unsafe_to_constr c2) @@ -461,8 +473,10 @@ let eq_constr_nounivs sigma c1 c2 = let compare_constr sigma cmp c1 c2 = let kind c = kind_upto sigma c in + let eq_inst _ _ i1 i2 = eq_einstance sigma i1 i2 in + let eq_sorts s1 s2 = eq_esorts sigma s1 s2 in let cmp nargs c1 c2 = cmp (of_constr c1) (of_constr c2) in - compare_gen kind (fun _ _ -> Univ.Instance.equal) Sorts.equal cmp 0 (unsafe_to_constr c1) (unsafe_to_constr c2) + compare_gen kind eq_inst eq_sorts cmp 0 (unsafe_to_constr c1) (unsafe_to_constr c2) let compare_cumulative_instances cv_pb nargs_ok variances u u' cstrs = let open UnivProblem in diff --git a/interp/notation.ml b/interp/notation.ml index a6a14efc87..02c7812e21 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -379,23 +379,364 @@ module InnerPrimToken = struct end -(* The following two tables of (un)interpreters will *not* be synchronized. - But their indexes will be checked to be unique *) +(* The following two tables of (un)interpreters will *not* be + synchronized. But their indexes will be checked to be unique. + These tables contain primitive token interpreters which are + registered in plugins, such as string and ascii syntax. It is + essential that only plugins add to these tables, and that + vernacular commands do not. See + https://github.com/coq/coq/issues/8401 for details of what goes + wrong when vernacular commands add to these tables. *) let prim_token_interpreters = (Hashtbl.create 7 : (prim_token_uid, InnerPrimToken.interpreter) Hashtbl.t) let prim_token_uninterpreters = (Hashtbl.create 7 : (prim_token_uid, InnerPrimToken.uninterpreter) Hashtbl.t) +(*******************************************************) +(* Numeral notation interpretation *) +type numeral_notation_error = + | UnexpectedTerm of Constr.t + | UnexpectedNonOptionTerm of Constr.t + +exception NumeralNotationError of Environ.env * Evd.evar_map * numeral_notation_error + +type numnot_option = + | Nop + | Warning of raw_natural_number + | Abstract of raw_natural_number + +type int_ty = + { uint : Names.inductive; + int : Names.inductive } + +type z_pos_ty = + { z_ty : Names.inductive; + pos_ty : Names.inductive } + +type target_kind = + | Int of int_ty (* Coq.Init.Decimal.int + uint *) + | UInt of Names.inductive (* Coq.Init.Decimal.uint *) + | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) + +type option_kind = Option | Direct +type conversion_kind = target_kind * option_kind + +type numeral_notation_obj = + { to_kind : conversion_kind; + to_ty : GlobRef.t; + of_kind : conversion_kind; + of_ty : GlobRef.t; + num_ty : Libnames.qualid; (* for warnings / error messages *) + warning : numnot_option } + +module Numeral = struct +(** * Numeral notation *) + +(** Reduction + + The constr [c] below isn't necessarily well-typed, since we + built it via an [mkApp] of a conversion function on a term + that starts with the right constructor but might be partially + applied. + + At least [c] is known to be evar-free, since it comes from + our own ad-hoc [constr_of_glob] or from conversions such + as [coqint_of_rawnum]. +*) + +let eval_constr env sigma (c : Constr.t) = + let c = EConstr.of_constr c in + let sigma,t = Typing.type_of env sigma c in + let c' = Vnorm.cbv_vm env sigma c t in + EConstr.Unsafe.to_constr c' + +(* For testing with "compute" instead of "vm_compute" : +let eval_constr env sigma (c : Constr.t) = + let c = EConstr.of_constr c in + let c' = Tacred.compute env sigma c in + EConstr.Unsafe.to_constr c' +*) + +let eval_constr_app env sigma c1 c2 = + eval_constr env sigma (mkApp (c1,[| c2 |])) + +exception NotANumber + +let warn_large_num = + CWarnings.create ~name:"large-number" ~category:"numbers" + (fun ty -> + strbrk "Stack overflow or segmentation fault happens when " ++ + strbrk "working with large numbers in " ++ pr_qualid ty ++ + strbrk " (threshold may vary depending" ++ + strbrk " on your system limits and on the command executed).") + +let warn_abstract_large_num = + CWarnings.create ~name:"abstract-large-number" ~category:"numbers" + (fun (ty,f) -> + strbrk "To avoid stack overflow, large numbers in " ++ + pr_qualid ty ++ strbrk " are interpreted as applications of " ++ + Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ".") + +(** Comparing two raw numbers (base 10, big-endian, non-negative). + A bit nasty, but not critical: only used to decide when a + number is considered as large (see warnings above). *) + +exception Comp of int + +let rec rawnum_compare s s' = + let l = String.length s and l' = String.length s' in + if l < l' then - rawnum_compare s' s + else + let d = l-l' in + try + for i = 0 to d-1 do if s.[i] != '0' then raise (Comp 1) done; + for i = d to l-1 do + let c = Pervasives.compare s.[i] s'.[i-d] in + if c != 0 then raise (Comp c) + done; + 0 + with Comp c -> c + +(***********************************************************************) + +(** ** Conversion between Coq [Decimal.int] and internal raw string *) + +(** Decimal.Nil has index 1, then Decimal.D0 has index 2 .. Decimal.D9 is 11 *) + +let digit_of_char c = + assert ('0' <= c && c <= '9'); + Char.code c - Char.code '0' + 2 + +let char_of_digit n = + assert (2<=n && n<=11); + Char.chr (n-2 + Char.code '0') + +let coquint_of_rawnum uint str = + let nil = mkConstruct (uint,1) in + let rec do_chars s i acc = + if i < 0 then acc + else + let dg = mkConstruct (uint, digit_of_char s.[i]) in + do_chars s (i-1) (mkApp(dg,[|acc|])) + in + do_chars str (String.length str - 1) nil + +let coqint_of_rawnum inds (str,sign) = + let uint = coquint_of_rawnum inds.uint str in + mkApp (mkConstruct (inds.int, if sign then 1 else 2), [|uint|]) + +let rawnum_of_coquint c = + let rec of_uint_loop c buf = + match Constr.kind c with + | Construct ((_,1), _) (* Nil *) -> () + | App (c, [|a|]) -> + (match Constr.kind c with + | Construct ((_,n), _) (* D0 to D9 *) -> + let () = Buffer.add_char buf (char_of_digit n) in + of_uint_loop a buf + | _ -> raise NotANumber) + | _ -> raise NotANumber + in + let buf = Buffer.create 64 in + let () = of_uint_loop c buf in + if Int.equal (Buffer.length buf) 0 then + (* To avoid ambiguities between Nil and (D0 Nil), we choose + to not display Nil alone as "0" *) + raise NotANumber + else Buffer.contents buf + +let rawnum_of_coqint c = + match Constr.kind c with + | App (c,[|c'|]) -> + (match Constr.kind c with + | Construct ((_,1), _) (* Pos *) -> (rawnum_of_coquint c', true) + | Construct ((_,2), _) (* Neg *) -> (rawnum_of_coquint c', false) + | _ -> raise NotANumber) + | _ -> raise NotANumber + + +(***********************************************************************) + +(** ** Conversion between Coq [Z] and internal bigint *) + +(** First, [positive] from/to bigint *) + +let rec pos_of_bigint posty n = + match Bigint.div2_with_rest n with + | (q, false) -> + let c = mkConstruct (posty, 2) in (* xO *) + mkApp (c, [| pos_of_bigint posty q |]) + | (q, true) when not (Bigint.equal q Bigint.zero) -> + let c = mkConstruct (posty, 1) in (* xI *) + mkApp (c, [| pos_of_bigint posty q |]) + | (q, true) -> + mkConstruct (posty, 3) (* xH *) + +let rec bigint_of_pos c = match Constr.kind c with + | Construct ((_, 3), _) -> (* xH *) Bigint.one + | App (c, [| d |]) -> + begin match Constr.kind c with + | Construct ((_, n), _) -> + begin match n with + | 1 -> (* xI *) Bigint.add_1 (Bigint.mult_2 (bigint_of_pos d)) + | 2 -> (* xO *) Bigint.mult_2 (bigint_of_pos d) + | n -> assert false (* no other constructor of type positive *) + end + | x -> raise NotANumber + end + | x -> raise NotANumber + +(** Now, [Z] from/to bigint *) + +let z_of_bigint { z_ty; pos_ty } n = + if Bigint.equal n Bigint.zero then + mkConstruct (z_ty, 1) (* Z0 *) + else + let (s, n) = + if Bigint.is_pos_or_zero n then (2, n) (* Zpos *) + else (3, Bigint.neg n) (* Zneg *) + in + let c = mkConstruct (z_ty, s) in + mkApp (c, [| pos_of_bigint pos_ty n |]) + +let bigint_of_z z = match Constr.kind z with + | Construct ((_, 1), _) -> (* Z0 *) Bigint.zero + | App (c, [| d |]) -> + begin match Constr.kind c with + | Construct ((_, n), _) -> + begin match n with + | 2 -> (* Zpos *) bigint_of_pos d + | 3 -> (* Zneg *) Bigint.neg (bigint_of_pos d) + | n -> assert false (* no other constructor of type Z *) + end + | _ -> raise NotANumber + end + | _ -> raise NotANumber + +(** The uninterp function below work at the level of [glob_constr] + which is too low for us here. So here's a crude conversion back + to [constr] for the subset that concerns us. *) + +let rec constr_of_glob env sigma g = match DAst.get g with + | Glob_term.GRef (ConstructRef c, _) -> + let sigma,c = Evd.fresh_constructor_instance env sigma c in + sigma,mkConstructU c + | Glob_term.GApp (gc, gcl) -> + let sigma,c = constr_of_glob env sigma gc in + let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in + sigma,mkApp (c, Array.of_list cl) + | _ -> + raise NotANumber + +let rec glob_of_constr ?loc env sigma c = match Constr.kind c with + | App (c, ca) -> + let c = glob_of_constr ?loc env sigma c in + let cel = List.map (glob_of_constr ?loc env sigma) (Array.to_list ca) in + DAst.make ?loc (Glob_term.GApp (c, cel)) + | Construct (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstructRef c, None)) + | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstRef c, None)) + | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (IndRef ind, None)) + | Var id -> DAst.make ?loc (Glob_term.GRef (VarRef id, None)) + | _ -> Loc.raise ?loc (NumeralNotationError(env,sigma,UnexpectedTerm c)) + +let no_such_number ?loc ty = + CErrors.user_err ?loc + (str "Cannot interpret this number as a value of type " ++ + pr_qualid ty) + +let interp_option ty ?loc env sigma c = + match Constr.kind c with + | App (_Some, [| _; c |]) -> glob_of_constr ?loc env sigma c + | App (_None, [| _ |]) -> no_such_number ?loc ty + | x -> Loc.raise ?loc (NumeralNotationError(env,sigma,UnexpectedNonOptionTerm c)) + +let uninterp_option c = + match Constr.kind c with + | App (_Some, [| _; x |]) -> x + | _ -> raise NotANumber + +let big2raw n = + if Bigint.is_pos_or_zero n then (Bigint.to_string n, true) + else (Bigint.to_string (Bigint.neg n), false) + +let raw2big (n,s) = + if s then Bigint.of_string n else Bigint.neg (Bigint.of_string n) + +let interp o ?loc n = + begin match o.warning with + | Warning threshold when snd n && rawnum_compare (fst n) threshold >= 0 -> + warn_large_num o.num_ty + | _ -> () + end; + let c = match fst o.to_kind with + | Int int_ty -> coqint_of_rawnum int_ty n + | UInt uint_ty when snd n -> coquint_of_rawnum uint_ty (fst n) + | UInt _ (* n <= 0 *) -> no_such_number ?loc o.num_ty + | Z z_pos_ty -> z_of_bigint z_pos_ty (raw2big n) + in + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma,to_ty = Evd.fresh_global env sigma o.to_ty in + let to_ty = EConstr.Unsafe.to_constr to_ty in + match o.warning, snd o.to_kind with + | Abstract threshold, Direct when rawnum_compare (fst n) threshold >= 0 -> + warn_abstract_large_num (o.num_ty,o.to_ty); + glob_of_constr ?loc env sigma (mkApp (to_ty,[|c|])) + | _ -> + let res = eval_constr_app env sigma to_ty c in + match snd o.to_kind with + | Direct -> glob_of_constr ?loc env sigma res + | Option -> interp_option o.num_ty ?loc env sigma res + +let uninterp o (Glob_term.AnyGlobConstr n) = + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma,of_ty = Evd.fresh_global env sigma o.of_ty in + let of_ty = EConstr.Unsafe.to_constr of_ty in + try + let sigma,n = constr_of_glob env sigma n in + let c = eval_constr_app env sigma of_ty n in + let c = if snd o.of_kind == Direct then c else uninterp_option c in + match fst o.of_kind with + | Int _ -> Some (rawnum_of_coqint c) + | UInt _ -> Some (rawnum_of_coquint c, true) + | Z _ -> Some (big2raw (bigint_of_z c)) + with + | Type_errors.TypeError _ | Pretype_errors.PretypeError _ -> None (* cf. eval_constr_app *) + | NotANumber -> None (* all other functions except big2raw *) +end + +(* A [prim_token_infos], which is synchronized with the document + state, either contains a unique id pointing to an unsynchronized + prim token function, or a numeral notation object describing how to + interpret and uninterpret. We provide [prim_token_infos] because + we expect plugins to provide their own interpretation functions, + rather than going through numeral notations, which are available as + a vernacular. *) + +type prim_token_interp_info = + Uid of prim_token_uid + | NumeralNotation of numeral_notation_obj + +type prim_token_infos = { + pt_local : bool; (** Is this interpretation local? *) + pt_scope : scope_name; (** Concerned scope *) + pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a numeral notation object describing (un)interp functions *) + pt_required : required_module; (** Module that should be loaded first *) + pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) + pt_in_match : bool (** Is this prim token legal in match patterns ? *) +} + (* Table from scope_name to backtrack-able informations about interpreters (in particular interpreter unique id). *) let prim_token_interp_infos = - ref (String.Map.empty : (required_module * prim_token_uid) String.Map.t) + ref (String.Map.empty : (required_module * prim_token_interp_info) String.Map.t) (* Table from global_reference to backtrack-able informations about prim_token uninterpretation (in particular uninterpreter unique id). *) let prim_token_uninterp_infos = - ref (GlobRef.Map.empty : (scope_name * prim_token_uid * bool) GlobRef.Map.t) + ref (GlobRef.Map.empty : (scope_name * prim_token_interp_info * bool) GlobRef.Map.t) let hashtbl_check_and_set allow_overwrite uid f h eq = match Hashtbl.find h uid with @@ -425,23 +766,14 @@ let register_string_interpretation ?(allow_overwrite=false) uid (interp, uninter register_gen_interpretation allow_overwrite uid (InnerPrimToken.StringInterp interp, InnerPrimToken.StringUninterp uninterp) -type prim_token_infos = { - pt_local : bool; (** Is this interpretation local? *) - pt_scope : scope_name; (** Concerned scope *) - pt_uid : prim_token_uid; (** Unique id "pointing" to (un)interp functions *) - pt_required : required_module; (** Module that should be loaded first *) - pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) - pt_in_match : bool (** Is this prim token legal in match patterns ? *) -} - let cache_prim_token_interpretation (_,infos) = + let ptii = infos.pt_interp_info in let sc = infos.pt_scope in - let uid = infos.pt_uid in check_scope ~tolerant:true sc; prim_token_interp_infos := - String.Map.add sc (infos.pt_required,infos.pt_uid) !prim_token_interp_infos; + String.Map.add sc (infos.pt_required,ptii) !prim_token_interp_infos; List.iter (fun r -> prim_token_uninterp_infos := - GlobRef.Map.add r (sc,uid,infos.pt_in_match) + GlobRef.Map.add r (sc,ptii,infos.pt_in_match) !prim_token_uninterp_infos) infos.pt_refs @@ -479,7 +811,7 @@ let declare_numeral_interpreter ?(local=false) sc dir interp (patl,uninterp,b) = enable_prim_token_interpretation { pt_local = local; pt_scope = sc; - pt_uid = uid; + pt_interp_info = Uid uid; pt_required = dir; pt_refs = List.map_filter glob_prim_constr_key patl; pt_in_match = b } @@ -489,7 +821,7 @@ let declare_string_interpreter ?(local=false) sc dir interp (patl,uninterp,b) = enable_prim_token_interpretation { pt_local = local; pt_scope = sc; - pt_uid = uid; + pt_interp_info = Uid uid; pt_required = dir; pt_refs = List.map_filter glob_prim_constr_key patl; pt_in_match = b } @@ -605,9 +937,12 @@ let find_prim_token check_allowed ?loc p sc = pat, df with Not_found -> (* Try for a primitive numerical notation *) - let (spdir,uid) = String.Map.find sc !prim_token_interp_infos in + let (spdir,info) = String.Map.find sc !prim_token_interp_infos in check_required_module ?loc sc spdir; - let interp = Hashtbl.find prim_token_interpreters uid in + let interp = match info with + | Uid uid -> Hashtbl.find prim_token_interpreters uid + | NumeralNotation o -> InnerPrimToken.RawNumInterp (Numeral.interp o) + in let pat = InnerPrimToken.do_interp ?loc interp p in check_allowed pat; pat, ((dirpath (fst spdir),DirPath.empty),"") @@ -783,8 +1118,11 @@ let uninterp_prim_token c = | None -> raise Notation_ops.No_match | Some r -> try - let (sc,uid,_) = GlobRef.Map.find r !prim_token_uninterp_infos in - let uninterp = Hashtbl.find prim_token_uninterpreters uid in + let (sc,info,_) = GlobRef.Map.find r !prim_token_uninterp_infos in + let uninterp = match info with + | Uid uid -> Hashtbl.find prim_token_uninterpreters uid + | NumeralNotation o -> InnerPrimToken.RawNumUninterp (Numeral.uninterp o) + in match InnerPrimToken.do_uninterp uninterp (AnyGlobConstr c) with | None -> raise Notation_ops.No_match | Some n -> (sc,n) @@ -799,12 +1137,16 @@ let availability_of_prim_token n printer_scope local_scopes = let f scope = try let uid = snd (String.Map.find scope !prim_token_interp_infos) in - let interp = Hashtbl.find prim_token_interpreters uid in let open InnerPrimToken in - match n, interp with - | Numeral _, (RawNumInterp _ | BigNumInterp _) -> true - | String _, StringInterp _ -> true - | _ -> false + match n, uid with + | Numeral _, NumeralNotation _ -> true + | _, NumeralNotation _ -> false + | _, Uid uid -> + let interp = Hashtbl.find prim_token_interpreters uid in + match n, interp with + | Numeral _, (RawNumInterp _ | BigNumInterp _) -> true + | String _, StringInterp _ -> true + | _ -> false with Not_found -> false in let scopes = make_current_scopes local_scopes in diff --git a/interp/notation.mli b/interp/notation.mli index 6e59c0fd70..734198bbf6 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -102,10 +102,51 @@ val register_bignumeral_interpretation : val register_string_interpretation : ?allow_overwrite:bool -> prim_token_uid -> string prim_token_interpretation -> unit +(** * Numeral notation *) + +type numeral_notation_error = + | UnexpectedTerm of Constr.t + | UnexpectedNonOptionTerm of Constr.t + +exception NumeralNotationError of Environ.env * Evd.evar_map * numeral_notation_error + +type numnot_option = + | Nop + | Warning of raw_natural_number + | Abstract of raw_natural_number + +type int_ty = + { uint : Names.inductive; + int : Names.inductive } + +type z_pos_ty = + { z_ty : Names.inductive; + pos_ty : Names.inductive } + +type target_kind = + | Int of int_ty (* Coq.Init.Decimal.int + uint *) + | UInt of Names.inductive (* Coq.Init.Decimal.uint *) + | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) + +type option_kind = Option | Direct +type conversion_kind = target_kind * option_kind + +type numeral_notation_obj = + { to_kind : conversion_kind; + to_ty : GlobRef.t; + of_kind : conversion_kind; + of_ty : GlobRef.t; + num_ty : Libnames.qualid; (* for warnings / error messages *) + warning : numnot_option } + +type prim_token_interp_info = + Uid of prim_token_uid + | NumeralNotation of numeral_notation_obj + type prim_token_infos = { pt_local : bool; (** Is this interpretation local? *) pt_scope : scope_name; (** Concerned scope *) - pt_uid : prim_token_uid; (** Unique id "pointing" to (un)interp functions *) + pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a numeral notation object describing (un)interp functions *) pt_required : required_module; (** Module that should be loaded first *) pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) pt_in_match : bool (** Is this prim token legal in match patterns ? *) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 489a40ed09..e114a0119e 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -98,7 +98,7 @@ let functional_induction with_clean c princl pat = List.map2 (fun c pat -> ((None, - Ltac_plugin.Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))), + Tactics.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))), (None,pat), None)) (args@c_list) diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 8dad6260ae..d42876e23e 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -26,6 +26,7 @@ open Termops open Equality open Namegen open Tactypes +open Tactics open Proofview.Notations open Vernacinterp diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index c13bd69daf..929390b1c4 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -314,22 +314,23 @@ GEXTEND Gram range_selector_or_nth: [ [ n = natural ; "-" ; m = natural; l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - SelectList ((n, m) :: Option.default [] l) + Goal_select.SelectList ((n, m) :: Option.default [] l) | n = natural; l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> + let open Goal_select in Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ] ; selector_body: [ [ l = range_selector_or_nth -> l - | test_bracket_ident; "["; id = ident; "]" -> SelectId id ] ] + | test_bracket_ident; "["; id = ident; "]" -> Goal_select.SelectId id ] ] ; selector: [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ] ; toplevel_selector: [ [ sel = selector_body; ":" -> sel - | "!"; ":" -> SelectAlreadyFocused - | IDENT "all"; ":" -> SelectAll ] ] + | "!"; ":" -> Goal_select.SelectAlreadyFocused + | IDENT "all"; ":" -> Goal_select.SelectAll ] ] ; tactic_mode: [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> tac g @@ -346,7 +347,7 @@ GEXTEND Gram hint: [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; tac = Pltac.tactic -> - Vernacexpr.HintsExtern (n,c, in_tac tac) ] ] + Hints.HintsExtern (n,c, in_tac tac) ] ] ; operconstr: LEVEL "0" [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> @@ -373,6 +374,7 @@ let _ = declare_int_option { } let vernac_solve n info tcom b = + let open Goal_select in let status = Proof_global.with_current_proof (fun etac p -> let with_end_tac = if b then Some etac else None in let global = match n with SelectAll | SelectList _ -> true | _ -> false in @@ -432,7 +434,7 @@ VERNAC tactic_mode EXTEND VernacSolve VtLater ] -> [ let t = rm_abstract t in - vernac_solve SelectAll n t def + vernac_solve Goal_select.SelectAll n t def ] END diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 2e1ce814aa..571595be70 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -21,6 +21,8 @@ open Constrexpr open Libnames open Tok open Tactypes +open Tactics +open Inv open Locus open Decl_kinds diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 4357689ee2..803d35d07c 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -28,6 +28,7 @@ open Printer open Tacexpr open Tacarg +open Tactics module Tag = struct @@ -507,7 +508,7 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_destruction_arg prc prlc (clear_flag,h) = pr_clear_flag clear_flag (pr_core_destruction_arg prc prlc) h - let pr_inversion_kind = function + let pr_inversion_kind = let open Inv in function | SimpleInversion -> primitive "simple inversion" | FullInversion -> primitive "inversion" | FullInversionClear -> primitive "inversion_clear" @@ -516,7 +517,7 @@ let string_of_genarg_arg (ArgumentType arg) = if Int.equal i j then int i else int i ++ str "-" ++ int j -let pr_goal_selector toplevel = function +let pr_goal_selector toplevel = let open Goal_select in function | SelectAlreadyFocused -> str "!:" | SelectNth i -> int i ++ str ":" | SelectList l -> prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ str ":" diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 59b748e25e..11d13d3a2f 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -37,16 +37,24 @@ type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use type goal_selector = Goal_select.t = | SelectAlreadyFocused + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectNth of int + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectList of (int * int) list + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectId of Id.t + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectAll -[@@ocaml.deprecated "Use Vernacexpr.goal_selector"] + [@ocaml.deprecated "Use constructors in [Goal_select]"] +[@@ocaml.deprecated "Use [Goal_select.t]"] type 'a core_destruction_arg = 'a Tactics.core_destruction_arg = | ElimOnConstr of 'a + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnIdent of lident + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnAnonHyp of int + [@ocaml.deprecated "Use constructors in [Tactics]"] [@@ocaml.deprecated "Use Tactics.core_destruction_arg"] type 'a destruction_arg = @@ -55,8 +63,11 @@ type 'a destruction_arg = type inversion_kind = Inv.inversion_kind = | SimpleInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversionClear + [@ocaml.deprecated "Use constructors in [Inv]"] [@@ocaml.deprecated "Use Tactics.inversion_kind"] type ('c,'d,'id) inversion_strength = diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 3a0badb28f..6b131edaac 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -37,16 +37,24 @@ type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use type goal_selector = Goal_select.t = | SelectAlreadyFocused + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectNth of int + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectList of (int * int) list + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectId of Id.t + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectAll + [@ocaml.deprecated "Use constructors in [Goal_select]"] [@@ocaml.deprecated "Use Vernacexpr.goal_selector"] type 'a core_destruction_arg = 'a Tactics.core_destruction_arg = | ElimOnConstr of 'a + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnIdent of lident + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnAnonHyp of int + [@ocaml.deprecated "Use constructors in [Tactics]"] [@@ocaml.deprecated "Use Tactics.core_destruction_arg"] type 'a destruction_arg = @@ -55,8 +63,11 @@ type 'a destruction_arg = type inversion_kind = Inv.inversion_kind = | SimpleInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversionClear + [@ocaml.deprecated "Use constructors in [Inv]"] [@@ocaml.deprecated "Use Tactics.inversion_kind"] type ('c,'d,'id) inversion_strength = diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 1444800624..5501cf92a5 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -29,6 +29,7 @@ open Stdarg open Tacarg open Namegen open Tactypes +open Tactics open Locus (** Globalization of tactic expressions : diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 71da6c7667..414173ca79 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -37,6 +37,7 @@ open Tacarg open Printer open Pretyping open Tactypes +open Tactics open Locus open Tacintern open Taccoerce diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index dd799dc131..4626378db6 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -15,6 +15,7 @@ open Genarg open Stdarg open Tacarg open Tactypes +open Tactics open Globnames open Genredexpr open Patternops diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index 5e36fbeb81..53153198f9 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -94,7 +94,7 @@ let _ = at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = sc; - pt_uid = sc; + pt_interp_info = Uid sc; pt_required = (ascii_path,ascii_module); pt_refs = [static_glob_Ascii]; pt_in_match = true } diff --git a/plugins/syntax/g_numeral.ml4 b/plugins/syntax/g_numeral.ml4 index ec14df3baa..55f61a58f9 100644 --- a/plugins/syntax/g_numeral.ml4 +++ b/plugins/syntax/g_numeral.ml4 @@ -10,6 +10,7 @@ DECLARE PLUGIN "numeral_notation_plugin" +open Notation open Numeral open Pp open Names diff --git a/plugins/syntax/int31_syntax.ml b/plugins/syntax/int31_syntax.ml index d3ffe936a9..e34a401c2c 100644 --- a/plugins/syntax/int31_syntax.ml +++ b/plugins/syntax/int31_syntax.ml @@ -108,7 +108,7 @@ let _ = at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = int31_scope; - pt_uid = int31_scope; + pt_interp_info = Uid int31_scope; pt_required = (int31_path,int31_module); pt_refs = [int31_construct]; pt_in_match = true } diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index fee93593d0..10a0af0b8f 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -15,351 +15,18 @@ open Libnames open Globnames open Constrexpr open Constrexpr_ops -open Constr +open Notation (** * Numeral notation *) -(** Reduction - - The constr [c] below isn't necessarily well-typed, since we - built it via an [mkApp] of a conversion function on a term - that starts with the right constructor but might be partially - applied. - - At least [c] is known to be evar-free, since it comes from - our own ad-hoc [constr_of_glob] or from conversions such - as [coqint_of_rawnum]. -*) - -let eval_constr env sigma (c : Constr.t) = - let c = EConstr.of_constr c in - let sigma,t = Typing.type_of env sigma c in - let c' = Vnorm.cbv_vm env sigma c t in - EConstr.Unsafe.to_constr c' - -(* For testing with "compute" instead of "vm_compute" : -let eval_constr env sigma (c : Constr.t) = - let c = EConstr.of_constr c in - let c' = Tacred.compute env sigma c in - EConstr.Unsafe.to_constr c' -*) - -let eval_constr_app env sigma c1 c2 = - eval_constr env sigma (mkApp (c1,[| c2 |])) - -exception NotANumber - -let warn_large_num = - CWarnings.create ~name:"large-number" ~category:"numbers" - (fun ty -> - strbrk "Stack overflow or segmentation fault happens when " ++ - strbrk "working with large numbers in " ++ pr_qualid ty ++ - strbrk " (threshold may vary depending" ++ - strbrk " on your system limits and on the command executed).") - -let warn_abstract_large_num = - CWarnings.create ~name:"abstract-large-number" ~category:"numbers" - (fun (ty,f) -> - strbrk "To avoid stack overflow, large numbers in " ++ - pr_qualid ty ++ strbrk " are interpreted as applications of " ++ - Printer.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ".") - let warn_abstract_large_num_no_op = CWarnings.create ~name:"abstract-large-number-no-op" ~category:"numbers" (fun f -> strbrk "The 'abstract after' directive has no effect when " ++ strbrk "the parsing function (" ++ - Printer.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ + Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ strbrk "option type.") -(** Comparing two raw numbers (base 10, big-endian, non-negative). - A bit nasty, but not critical: only used to decide when a - number is considered as large (see warnings above). *) - -exception Comp of int - -let rec rawnum_compare s s' = - let l = String.length s and l' = String.length s' in - if l < l' then - rawnum_compare s' s - else - let d = l-l' in - try - for i = 0 to d-1 do if s.[i] != '0' then raise (Comp 1) done; - for i = d to l-1 do - let c = Pervasives.compare s.[i] s'.[i-d] in - if c != 0 then raise (Comp c) - done; - 0 - with Comp c -> c - -(***********************************************************************) - -(** ** Conversion between Coq [Decimal.int] and internal raw string *) - -type int_ty = - { uint : Names.inductive; - int : Names.inductive } - -(** Decimal.Nil has index 1, then Decimal.D0 has index 2 .. Decimal.D9 is 11 *) - -let digit_of_char c = - assert ('0' <= c && c <= '9'); - Char.code c - Char.code '0' + 2 - -let char_of_digit n = - assert (2<=n && n<=11); - Char.chr (n-2 + Char.code '0') - -let coquint_of_rawnum uint str = - let nil = mkConstruct (uint,1) in - let rec do_chars s i acc = - if i < 0 then acc - else - let dg = mkConstruct (uint, digit_of_char s.[i]) in - do_chars s (i-1) (mkApp(dg,[|acc|])) - in - do_chars str (String.length str - 1) nil - -let coqint_of_rawnum inds (str,sign) = - let uint = coquint_of_rawnum inds.uint str in - mkApp (mkConstruct (inds.int, if sign then 1 else 2), [|uint|]) - -let rawnum_of_coquint c = - let rec of_uint_loop c buf = - match Constr.kind c with - | Construct ((_,1), _) (* Nil *) -> () - | App (c, [|a|]) -> - (match Constr.kind c with - | Construct ((_,n), _) (* D0 to D9 *) -> - let () = Buffer.add_char buf (char_of_digit n) in - of_uint_loop a buf - | _ -> raise NotANumber) - | _ -> raise NotANumber - in - let buf = Buffer.create 64 in - let () = of_uint_loop c buf in - if Int.equal (Buffer.length buf) 0 then - (* To avoid ambiguities between Nil and (D0 Nil), we choose - to not display Nil alone as "0" *) - raise NotANumber - else Buffer.contents buf - -let rawnum_of_coqint c = - match Constr.kind c with - | App (c,[|c'|]) -> - (match Constr.kind c with - | Construct ((_,1), _) (* Pos *) -> (rawnum_of_coquint c', true) - | Construct ((_,2), _) (* Neg *) -> (rawnum_of_coquint c', false) - | _ -> raise NotANumber) - | _ -> raise NotANumber - - -(***********************************************************************) - -(** ** Conversion between Coq [Z] and internal bigint *) - -type z_pos_ty = - { z_ty : Names.inductive; - pos_ty : Names.inductive } - -(** First, [positive] from/to bigint *) - -let rec pos_of_bigint posty n = - match Bigint.div2_with_rest n with - | (q, false) -> - let c = mkConstruct (posty, 2) in (* xO *) - mkApp (c, [| pos_of_bigint posty q |]) - | (q, true) when not (Bigint.equal q Bigint.zero) -> - let c = mkConstruct (posty, 1) in (* xI *) - mkApp (c, [| pos_of_bigint posty q |]) - | (q, true) -> - mkConstruct (posty, 3) (* xH *) - -let rec bigint_of_pos c = match Constr.kind c with - | Construct ((_, 3), _) -> (* xH *) Bigint.one - | App (c, [| d |]) -> - begin match Constr.kind c with - | Construct ((_, n), _) -> - begin match n with - | 1 -> (* xI *) Bigint.add_1 (Bigint.mult_2 (bigint_of_pos d)) - | 2 -> (* xO *) Bigint.mult_2 (bigint_of_pos d) - | n -> assert false (* no other constructor of type positive *) - end - | x -> raise NotANumber - end - | x -> raise NotANumber - -(** Now, [Z] from/to bigint *) - -let z_of_bigint { z_ty; pos_ty } n = - if Bigint.equal n Bigint.zero then - mkConstruct (z_ty, 1) (* Z0 *) - else - let (s, n) = - if Bigint.is_pos_or_zero n then (2, n) (* Zpos *) - else (3, Bigint.neg n) (* Zneg *) - in - let c = mkConstruct (z_ty, s) in - mkApp (c, [| pos_of_bigint pos_ty n |]) - -let bigint_of_z z = match Constr.kind z with - | Construct ((_, 1), _) -> (* Z0 *) Bigint.zero - | App (c, [| d |]) -> - begin match Constr.kind c with - | Construct ((_, n), _) -> - begin match n with - | 2 -> (* Zpos *) bigint_of_pos d - | 3 -> (* Zneg *) Bigint.neg (bigint_of_pos d) - | n -> assert false (* no other constructor of type Z *) - end - | _ -> raise NotANumber - end - | _ -> raise NotANumber - -(** The uninterp function below work at the level of [glob_constr] - which is too low for us here. So here's a crude conversion back - to [constr] for the subset that concerns us. *) - -let rec constr_of_glob env sigma g = match DAst.get g with - | Glob_term.GRef (ConstructRef c, _) -> - let sigma,c = Evd.fresh_constructor_instance env sigma c in - sigma,mkConstructU c - | Glob_term.GApp (gc, gcl) -> - let sigma,c = constr_of_glob env sigma gc in - let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in - sigma,mkApp (c, Array.of_list cl) - | _ -> - raise NotANumber - -let rec glob_of_constr ?loc c = match Constr.kind c with - | App (c, ca) -> - let c = glob_of_constr ?loc c in - let cel = List.map (glob_of_constr ?loc) (Array.to_list ca) in - DAst.make ?loc (Glob_term.GApp (c, cel)) - | Construct (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstructRef c, None)) - | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstRef c, None)) - | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (IndRef ind, None)) - | Var id -> DAst.make ?loc (Glob_term.GRef (VarRef id, None)) - | _ -> let (sigma, env) = Pfedit.get_current_context () in - CErrors.user_err ?loc - (strbrk "Unexpected term " ++ - Printer.pr_constr_env env sigma c ++ - strbrk " while parsing a numeral notation.") - -let no_such_number ?loc ty = - CErrors.user_err ?loc - (str "Cannot interpret this number as a value of type " ++ - pr_qualid ty) - -let interp_option ty ?loc c = - match Constr.kind c with - | App (_Some, [| _; c |]) -> glob_of_constr ?loc c - | App (_None, [| _ |]) -> no_such_number ?loc ty - | x -> let (sigma, env) = Pfedit.get_current_context () in - CErrors.user_err ?loc - (strbrk "Unexpected non-option term " ++ - Printer.pr_constr_env env sigma c ++ - strbrk " while parsing a numeral notation.") - -let uninterp_option c = - match Constr.kind c with - | App (_Some, [| _; x |]) -> x - | _ -> raise NotANumber - -let big2raw n = - if Bigint.is_pos_or_zero n then (Bigint.to_string n, true) - else (Bigint.to_string (Bigint.neg n), false) - -let raw2big (n,s) = - if s then Bigint.of_string n else Bigint.neg (Bigint.of_string n) - -type target_kind = - | Int of int_ty (* Coq.Init.Decimal.int + uint *) - | UInt of Names.inductive (* Coq.Init.Decimal.uint *) - | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) - -type option_kind = Option | Direct -type conversion_kind = target_kind * option_kind - -type numnot_option = - | Nop - | Warning of raw_natural_number - | Abstract of raw_natural_number - -type numeral_notation_obj = - { to_kind : conversion_kind; - to_ty : GlobRef.t; - of_kind : conversion_kind; - of_ty : GlobRef.t; - num_ty : Libnames.qualid; (* for warnings / error messages *) - warning : numnot_option } - -let interp o ?loc n = - begin match o.warning with - | Warning threshold when snd n && rawnum_compare (fst n) threshold >= 0 -> - warn_large_num o.num_ty - | _ -> () - end; - let c = match fst o.to_kind with - | Int int_ty -> coqint_of_rawnum int_ty n - | UInt uint_ty when snd n -> coquint_of_rawnum uint_ty (fst n) - | UInt _ (* n <= 0 *) -> no_such_number ?loc o.num_ty - | Z z_pos_ty -> z_of_bigint z_pos_ty (raw2big n) - in - let env = Global.env () in - let sigma = Evd.from_env env in - let sigma,to_ty = Evd.fresh_global env sigma o.to_ty in - let to_ty = EConstr.Unsafe.to_constr to_ty in - match o.warning, snd o.to_kind with - | Abstract threshold, Direct when rawnum_compare (fst n) threshold >= 0 -> - warn_abstract_large_num (o.num_ty,o.to_ty); - glob_of_constr ?loc (mkApp (to_ty,[|c|])) - | _ -> - let res = eval_constr_app env sigma to_ty c in - match snd o.to_kind with - | Direct -> glob_of_constr ?loc res - | Option -> interp_option o.num_ty ?loc res - -let uninterp o (Glob_term.AnyGlobConstr n) = - let env = Global.env () in - let sigma = Evd.from_env env in - let sigma,of_ty = Evd.fresh_global env sigma o.of_ty in - let of_ty = EConstr.Unsafe.to_constr of_ty in - try - let sigma,n = constr_of_glob env sigma n in - let c = eval_constr_app env sigma of_ty n in - let c = if snd o.of_kind == Direct then c else uninterp_option c in - match fst o.of_kind with - | Int _ -> Some (rawnum_of_coqint c) - | UInt _ -> Some (rawnum_of_coquint c, true) - | Z _ -> Some (big2raw (bigint_of_z c)) - with - | Type_errors.TypeError _ | Pretype_errors.PretypeError _ -> None (* cf. eval_constr_app *) - | NotANumber -> None (* all other functions except big2raw *) - -(* Here we only register the interp and uninterp functions - for a particular Numeral Notation (determined by a unique - string). The actual activation of the notation will be done - later (cf. Notation.enable_prim_token_interpretation). - This registration of interp/uninterp must be added in the - libstack, otherwise this won't work through a Require. *) - -let load_numeral_notation _ (_, (uid,opts)) = - Notation.register_rawnumeral_interpretation - ~allow_overwrite:true uid (interp opts, uninterp opts) - -let cache_numeral_notation x = load_numeral_notation 1 x - -(* TODO: substitution ? - TODO: uid pas stable par substitution dans opts - *) - -let inNumeralNotation : string * numeral_notation_obj -> Libobject.obj = - Libobject.declare_object { - (Libobject.default_object "NUMERAL NOTATION") with - Libobject.cache_function = cache_numeral_notation; - Libobject.load_function = load_numeral_notation } - let get_constructors ind = let mib,oib = Global.lookup_inductive ind in let mc = oib.Declarations.mind_consnames in @@ -464,15 +131,12 @@ let vernac_numeral_notation local ty f g scope opts = (match opts, to_kind with | Abstract _, (_, Option) -> warn_abstract_large_num_no_op o.to_ty | _ -> ()); - (* TODO: un hash suffit-il ? *) - let uid = Marshal.to_string o [] in - let i = Notation.( + let i = { pt_local = local; pt_scope = scope; - pt_uid = uid; + pt_interp_info = NumeralNotation o; pt_required = Nametab.path_of_global (IndRef tyc),[]; pt_refs = constructors; - pt_in_match = true }) + pt_in_match = true } in - Lib.add_anonymous_leaf (inNumeralNotation (uid,o)); - Notation.enable_prim_token_interpretation i + enable_prim_token_interpretation i diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli index 83ede6f48f..f96b8321f8 100644 --- a/plugins/syntax/numeral.mli +++ b/plugins/syntax/numeral.mli @@ -9,14 +9,9 @@ (************************************************************************) open Libnames -open Constrexpr open Vernacexpr +open Notation (** * Numeral notation *) -type numnot_option = - | Nop - | Warning of raw_natural_number - | Abstract of raw_natural_number - val vernac_numeral_notation : locality_flag -> qualid -> qualid -> qualid -> Notation_term.scope_name -> numnot_option -> unit diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 04946c158b..49497aef54 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -143,7 +143,7 @@ let _ = at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = r_scope; - pt_uid = r_scope; + pt_interp_info = Uid r_scope; pt_required = (r_path,["Coq";"Reals";"Rdefinitions"]); pt_refs = [glob_IZR]; pt_in_match = false } diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index 640bcfde91..7478c1e978 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -75,7 +75,7 @@ let _ = at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = sc; - pt_uid = sc; + pt_interp_info = Uid sc; pt_required = (string_path,["Coq";"Strings";"String"]); pt_refs = [static_glob_String; static_glob_EmptyString]; pt_in_match = true } diff --git a/proofs/logic.ml b/proofs/logic.ml index e8ca719932..613581ade7 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -62,6 +62,7 @@ let is_unification_error = function let catchable_exception = function | CErrors.UserError _ | TypeError _ + | Notation.NumeralNotationError _ | RefinerError _ | Indrec.RecursionSchemeError _ | Nametab.GlobalizationError _ (* reduction errors *) diff --git a/test-suite/vio/numeral.v b/test-suite/vio/numeral.v new file mode 100644 index 0000000000..f28355bb29 --- /dev/null +++ b/test-suite/vio/numeral.v @@ -0,0 +1,21 @@ +Lemma foo : True. +Proof. +Check 0 : nat. +Check 0 : nat. +exact I. +Qed. + +Lemma bar : True. +Proof. +pose (0 : nat). +exact I. +Qed. + +Require Import Coq.Strings.Ascii. +Open Scope char_scope. + +Lemma baz : True. +Proof. +pose "s". +exact I. +Qed. diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index ca7d3ec074..3a2503d6b7 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -19,7 +19,7 @@ Require Export DoubleType. (** This file contains basic definitions of a 31-bit integer arithmetic. In fact it is more general than that. The only reason - for this use of 31 is the underlying mecanism for hardware-efficient + for this use of 31 is the underlying mechanism for hardware-efficient computations by A. Spiwack. Apart from this, a switch to, say, 63-bit integers is now just a matter of replacing every occurrences of 31 by 63. This is actually made possible by the use of diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 504e7095b0..7cf4e64805 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -64,6 +64,8 @@ let process_vernac_interp_error exn = match fst exn with wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te) | PretypeError(ctx,sigma,te) -> wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) + | Notation.NumeralNotationError(ctx,sigma,te) -> + wrap_vernac_error exn (Himsg.explain_numeral_notation_error ctx sigma te) | Typeclasses_errors.TypeClassError(env, te) -> wrap_vernac_error exn (Himsg.explain_typeclass_error env te) | Implicit_quantifiers.MismatchedContextInstance(e,c,l,x) -> diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg index dacef6e211..ecc7d3ff88 100644 --- a/vernac/g_proofs.mlg +++ b/vernac/g_proofs.mlg @@ -13,6 +13,7 @@ open Glob_term open Constrexpr open Vernacexpr +open Hints open Proof_global open Pcoq diff --git a/vernac/himsg.ml b/vernac/himsg.ml index a4650cfd92..e7b2a0e8a6 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -1315,3 +1315,13 @@ let explain_reduction_tactic_error = function quote (pr_goal_concl_style_env env sigma c) ++ spc () ++ str "is not well typed." ++ fnl () ++ explain_type_error env' (Evd.from_env env') e + +let explain_numeral_notation_error env sigma = function + | Notation.UnexpectedTerm c -> + (strbrk "Unexpected term " ++ + pr_constr_env env sigma c ++ + strbrk " while parsing a numeral notation.") + | Notation.UnexpectedNonOptionTerm c -> + (strbrk "Unexpected non-option term " ++ + pr_constr_env env sigma c ++ + strbrk " while parsing a numeral notation.") diff --git a/vernac/himsg.mli b/vernac/himsg.mli index 91caddcf13..02b3c45501 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -46,3 +46,5 @@ val explain_module_internalization_error : val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error + +val explain_numeral_notation_error : env -> Evd.evar_map -> Notation.numeral_notation_error -> Pp.t diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index e15e57a003..b4b3aead91 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -178,11 +178,11 @@ open Pputils | [] -> mt() | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z - let pr_reference_or_constr pr_c = function + let pr_reference_or_constr pr_c = let open Hints in function | HintsReference r -> pr_qualid r | HintsConstr c -> pr_c c - let pr_hint_mode = function + let pr_hint_mode = let open Hints in function | ModeInput -> str"+" | ModeNoHeadEvar -> str"!" | ModeOutput -> str"-" @@ -194,6 +194,7 @@ open Pputils let pr_hints db h pr_c pr_pat = let opth = pr_opt_hintbases db in let pph = + let open Hints in match h with | HintsResolve l -> keyword "Resolve " ++ prlist_with_sep sep diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 0c0204a728..13c8830b84 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -16,11 +16,11 @@ open Libnames type class_rawexpr = FunClass | SortClass | RefClass of qualid or_by_notation type goal_selector = Goal_select.t = - | SelectAlreadyFocused - | SelectNth of int - | SelectList of (int * int) list - | SelectId of Id.t - | SelectAll + | SelectAlreadyFocused [@ocaml.deprecated "Use Goal_select.SelectAlreadyFocused"] + | SelectNth of int [@ocaml.deprecated "Use Goal_select.SelectNth"] + | SelectList of (int * int) list [@ocaml.deprecated "Use Goal_select.SelectList"] + | SelectId of Id.t [@ocaml.deprecated "Use Goal_select.SelectId"] + | SelectAll [@ocaml.deprecated "Use Goal_select.SelectAll"] [@@ocaml.deprecated "Use Goal_select.t"] type goal_identifier = string @@ -103,14 +103,14 @@ type comment = | CommentInt of int type reference_or_constr = Hints.reference_or_constr = - | HintsReference of qualid - | HintsConstr of constr_expr + | HintsReference of qualid [@ocaml.deprecated "Use Hints.HintsReference"] + | HintsConstr of constr_expr [@ocaml.deprecated "Use Hints.HintsConstr"] [@@ocaml.deprecated "Please use [Hints.reference_or_constr]"] type hint_mode = Hints.hint_mode = - | ModeInput (* No evars *) - | ModeNoHeadEvar (* No evar at the head *) - | ModeOutput (* Anything *) + | ModeInput [@ocaml.deprecated "Use Hints.ModeInput"] + | ModeNoHeadEvar [@ocaml.deprecated "Use Hints.ModeNoHeadEvar"] + | ModeOutput [@ocaml.deprecated "Use Hints.ModeOutput"] [@@ocaml.deprecated "Please use [Hints.hint_mode]"] type 'a hint_info_gen = 'a Typeclasses.hint_info_gen = @@ -128,13 +128,21 @@ type 'a hints_transparency_target = 'a Hints.hints_transparency_target = type hints_expr = Hints.hints_expr = | HintsResolve of (Hints.hint_info_expr * bool * Hints.reference_or_constr) list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsResolveIFF of bool * qualid list * int option + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsImmediate of Hints.reference_or_constr list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsUnfold of qualid list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsTransparency of qualid hints_transparency_target * bool + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsMode of qualid * Hints.hint_mode list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsConstructors of qualid list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsExtern of int * constr_expr option * Genarg.raw_generic_argument + [@ocaml.deprecated "Use the constructor in module [Hints]"] [@@ocaml.deprecated "Please use [Hints.hints_expr]"] type search_restriction = @@ -289,7 +297,9 @@ type bullet = Proof_bullet.t type 'a module_signature = 'a Declaremods.module_signature = | Enforce of 'a (** ... : T *) + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] | Check of 'a list (** ... <: T1 <: T2, possibly empty *) + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] [@@ocaml.deprecated "please use [Declaremods.module_signature]."] (** Which module inline annotations should we honor, @@ -298,8 +308,11 @@ type 'a module_signature = 'a Declaremods.module_signature = type inline = Declaremods.inline = | NoInline + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] | DefaultInline + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] | InlineAt of int + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] [@@ocaml.deprecated "please use [Declaremods.inline]."] type module_ast_inl = module_ast * Declaremods.inline |