diff options
221 files changed, 3083 insertions, 8852 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 56bd34f6fd..fe7913a3d2 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -16,8 +16,6 @@ /META.coq.in @coq/legacy-build-maintainers -/dev/build/windows @coq/windows-build-maintainers - ########## CI infrastructure ########## /dev/ci/ @coq/ci-maintainers diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index bf3ac7a727..754c09776e 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -256,23 +256,18 @@ before_script: OPAM_SWITCH: "edge" OPAM_VARIANT: "+flambda" -.windows-template: +.platform-template: stage: stage-1 interruptible: true + variables: + PLATFORM: "https://github.com/coq/platform/archive/master.zip" artifacts: - name: "%CI_JOB_NAME%" + name: "$CI_JOB_NAME" paths: - artifacts when: always expire_in: 1 week - tags: - - windows-inria - before_script: [] - script: - - call dev/ci/gitlab.bat - only: - variables: - - $WINDOWS =~ /enabled/ + before_script: [] # We don't want to use the shared 'before_script' .deploy-template: stage: deploy @@ -349,16 +344,13 @@ build:quick: when: always windows64: - extends: .windows-template + extends: .platform-template variables: ARCH: "64" - -windows32: - extends: .windows-template - variables: - ARCH: "32" - except: - - /^pr-.*$/ + script: + - call dev/ci/platform-windows.bat + tags: + - windows-inria lint: stage: stage-1 diff --git a/Makefile.ide b/Makefile.ide index 54bf0b6a4e..6e3713c7bf 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -233,7 +233,6 @@ install-ide-info: .PHONY: $(COQIDEAPP)/Contents $(COQIDEAPP)/Contents: - rm -rdf $@ $(MKDIR) $@ sed -e "s/VERSION/$(VERSION4MACOS)/g" ide/coqide/MacOS/Info.plist.template > $@/Info.plist $(MKDIR) "$@/MacOS" @@ -282,6 +281,10 @@ $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib $(COQIDEAPP)/Contents/Resources/lib: $(COQIDEAPP)/Contents/Resources/immodules $(COQIDEAPP)/Contents/Resources/loaders $(COQIDEAPP)/Contents $(COQIDEINAPP) $(MKDIR) $@ macpack -d ../Resources/lib $(COQIDEINAPP) + for i in $@/../bin/*; \ + do \ + macpack -d ../lib $$i; \ + done for i in $@/../loaders/*.so $@/../immodules/*.{dylib,so}; \ do \ macpack -d ../lib $$i; \ diff --git a/checker/checker.ml b/checker/checker.ml index 08d92bb7b3..bdfc5f07be 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -289,7 +289,7 @@ let explain_exn = function Constr.debug_print a ++ fnl ()); Feedback.msg_notice (str"====== universes ====" ++ fnl () ++ (UGraph.pr_universes Univ.Level.pr - (ctx.Environ.env_stratification.Environ.env_universes))); + (UGraph.repr (ctx.Environ.env_stratification.Environ.env_universes)))); str "CantApplyBadType at argument " ++ int n | CantApplyNonFunctional _ -> str"CantApplyNonFunctional" | IllFormedRecBody _ -> str"IllFormedRecBody" diff --git a/checker/values.ml b/checker/values.ml index 4e99d087df..907f9f7e32 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -147,7 +147,7 @@ let rec v_constr = [|v_puniverses v_cst|]; (* Const *) [|v_puniverses v_ind|]; (* Ind *) [|v_puniverses v_cons|]; (* Construct *) - [|v_caseinfo;v_constr;v_case_invert;v_constr;Array v_constr|]; (* Case *) + [|v_caseinfo;v_instance; Array v_constr; v_case_return; v_case_invert; v_constr; Array v_case_branch|]; (* Case *) [|v_fix|]; (* Fix *) [|v_cofix|]; (* CoFix *) [|v_proj;v_constr|]; (* Proj *) @@ -160,7 +160,11 @@ and v_prec = Tuple ("prec_declaration", [|Array (v_binder_annot v_name); Array v_constr; Array v_constr|]) and v_fix = Tuple ("pfixpoint", [|Tuple ("fix2",[|Array Int;Int|]);v_prec|]) and v_cofix = Tuple ("pcofixpoint",[|Int;v_prec|]) -and v_case_invert = Sum ("case_inversion", 1, [|[|v_instance;Array v_constr|]|]) +and v_case_invert = Sum ("case_inversion", 1, [|[|Array v_constr|]|]) + +and v_case_branch = Tuple ("case_branch", [|Array (v_binder_annot v_name); v_constr|]) + +and v_case_return = Tuple ("case_return", [|Array (v_binder_annot v_name); v_constr|]) let v_rdecl = v_sum "rel_declaration" 0 [| [|v_binder_annot v_name; v_constr|]; (* LocalAssum *) diff --git a/dev/build/osx/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh index 35d0379008..2550cbb31c 100755 --- a/dev/build/osx/make-macos-dmg.sh +++ b/dev/build/osx/make-macos-dmg.sh @@ -8,12 +8,12 @@ DMGDIR=$PWD/_dmg VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) APP=bin/CoqIDE_${VERSION}.app -# Create a .app file with CoqIDE, without signing it -make PRIVATEBINARIES="$APP" -j "$NJOBS" -l2 "$APP" - -# Add Coq to the .app file +# Install Coq into the .app file make OLDROOT="$OUTDIR" COQINSTALLPREFIX="$APP/Contents/Resources" install-coq install-ide-toploop +# Fill .app file with metadata and other .app specific stuff (like non-system .so) +make PRIVATEBINARIES="$APP" -j 1 -l2 "$APP" VERBOSE=1 + # Create the dmg bundle mkdir -p "$DMGDIR" ln -sf /Applications "$DMGDIR/Applications" diff --git a/dev/build/windows/CAVEATS.txt b/dev/build/windows/CAVEATS.txt deleted file mode 100644 index cb1ae3aaaf..0000000000 --- a/dev/build/windows/CAVEATS.txt +++ /dev/null @@ -1,22 +0,0 @@ -===== Environemt SIZE =====
-
-find and xargs can fail if the environment is to large. I think the limit is 8k.
-
-xargs --show-limits
-
-shows the actual environment size
-
-The configure_profile.sh script sets ORIGINAL_PATH (set by cygwin) to "" to
-avoid issues
-
-===== OCAMLLIB =====
-
-If the environment variable OCAMLLIB is defined, it takes precedence over the
-internal paths of ocaml tools. This usually messes up things considerably. A
-typical failure is
-
-Error: Error on dynamically loaded library: .\dlllablgtk2.dll: %1 is not a valid Win32 application.
-
-The configure_profile.sh script clears OCAMLLIB, but if you use the ocaml
-compiler from outside the provided cygwin shell, OCAMLLIB might be defined.
-
diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat deleted file mode 100755 index 8eff2cf577..0000000000 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ /dev/null @@ -1,499 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== NOTES ==========
-
-REM For Cygwin setup command line options
-REM see https://cygwin.com/faq/faq.html#faq.setup.cli
-
-REM ========== DEFAULT VALUES FOR PARAMETERS ==========
-
-REM For a description of all parameters, see ReadMe.txt
-
-SET BATCHFILE=%~0
-SET BATCHDIR=%~dp0
-
-REM see -arch in ReadMe.txt, but values are x86_64 or i686 (not 64 or 32)
-SET ARCH=x86_64
-
-REM see -mode in ReadMe.txt
-SET INSTALLMODE=absolute
-
-REM see -installer in ReadMe.txt
-SET MAKEINSTALLER=N
-
-REM see -ocaml in ReadMe.txt
-SET INSTALLOCAML=N
-
-REM see -make in ReadMe.txt
-SET INSTALLMAKE=N
-
-REM see -destcyg in ReadMe.txt
-SET DESTCYG=C:\bin\cygwin_coq
-
-REM see -destcoq in ReadMe.txt
-SET DESTCOQ=C:\bin\coq
-
-REM see -setup in ReadMe.txt
-SET SETUP=setup-x86_64.exe
-
-REM see -proxy in ReadMe.txt
-IF DEFINED HTTP_PROXY (
- SET PROXY=%HTTP_PROXY:http://=%
-) else (
- 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 "PROXY= "
-)
-
-REM see -cygrepo in ReadMe.txt
-SET CYGWIN_REPOSITORY=https://mirrors.kernel.org/sourceware/cygwin
-
-REM see -cygcache in ReadMe.txt
-SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache
-
-REM see -cyglocal in ReadMe.txt
-SET CYGWIN_FROM_CACHE=N
-
-REM see -cygquiet in ReadMe.txt
-SET CYGWIN_QUIET=Y
-
-REM see -srccache in ReadMe.txt
-SET SOURCE_LOCAL_CACHE_WFMT=%BATCHDIR%source_cache
-
-REM see -coqver in ReadMe.txt
-SET COQ_VERSION=8.5pl3
-
-REM see -gtksrc in ReadMe.txt
-SET GTK_FROM_SOURCES=N
-
-REM see -threads in ReadMe.txt
-SET MAKE_THREADS=8
-
-REM see -addon in ReadMe.txt
-SET "COQ_ADDONS= "
-
-REM ========== PARSE COMMAND LINE PARAMETERS ==========
-
-SHIFT
-
-:Parse
-
-IF "%~0" == "-arch" (
- IF "%~1" == "32" (
- SET ARCH=i686
- SET SETUP=setup-x86.exe
- ) ELSE (
- IF "%~1" == "64" (
- SET ARCH=x86_64
- SET SETUP=setup-x86_64.exe
- ) ELSE (
- ECHO "Invalid -arch, valid are 32 and 64"
- GOTO :EOF
- )
- )
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-mode" (
- IF "%~1" == "mingwincygwin" (
- SET INSTALLMODE=%~1
- ) ELSE (
- IF "%~1" == "absolute" (
- SET INSTALLMODE=%~1
- ) ELSE (
- IF "%~1" == "relocatable" (
- SET INSTALLMODE=%~1
- ) ELSE (
- ECHO "Invalid -mode, valid are mingwincygwin, absolute and relocatable"
- GOTO :EOF
- )
- )
- )
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-installer" (
- SET MAKEINSTALLER=%~1
- CALL :CheckYN -installer %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-ocaml" (
- SET INSTALLOCAML=%~1
- CALL :CheckYN -installer %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-make" (
- SET INSTALLMAKE=%~1
- CALL :CheckYN -installer %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-destcyg" (
- SET DESTCYG=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-destcoq" (
- SET DESTCOQ=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-setup" (
- SET SETUP=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-proxy" (
- SET PROXY=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cygrepo" (
- SET CYGWIN_REPOSITORY=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cygcache" (
- SET CYGWIN_LOCAL_CACHE_WFMT=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cyglocal" (
- SET CYGWIN_FROM_CACHE=%~1
- CALL :CheckYN -cyglocal %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cygquiet" (
- SET CYGWIN_QUIET=%~1
- CALL :CheckYN -cygquiet %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-srccache" (
- SET SOURCE_LOCAL_CACHE_WFMT=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-coqver" (
- SET COQ_VERSION=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-gtksrc" (
- SET GTK_FROM_SOURCES=%~1
- CALL :CheckYN -gtksrc %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-threads" (
- SET MAKE_THREADS=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-addon" (
- SET "COQ_ADDONS=%COQ_ADDONS% %~1"
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-
-IF NOT "%~0" == "" (
- ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW
- ECHO !!! Illegal parameter %~0
- ECHO Usage:
- ECHO MakeCoq_MinGW
- CALL :PrintPars
- GOTO :EOF
-)
-
-IF NOT EXIST %SETUP% (
- ECHO The cygwin setup program %SETUP% doesn't exist. You must download it from https://cygwin.com/install.html.
- ECHO If the setup is in a different folder, set the full path to %SETUP% using the -setup option.
- GOTO :EOF
-)
-
-REM ========== ADJUST PARAMETERS ==========
-
-IF "%INSTALLMODE%" == "mingwincygwin" (
- SET DESTCOQ=%DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw
-)
-
-IF "%MAKEINSTALLER%" == "Y" (
- SET INSTALLMODE=relocatable
-)
-
-REM ========== CONFIRM PARAMETERS ==========
-
-CALL :PrintPars
-REM Note: DOS batch replaces variables on parsing, so one can't use a variable just set in an () block
-IF "%COQREGTESTING%"=="Y" (GOTO DontAsk)
- SET /p ANSWER="Is this correct? y/n "
- IF NOT "%ANSWER%"=="y" (GOTO :EOF)
-:DontAsk
-
-REM ========== DERIVED VARIABLES ==========
-
-SET CYGWIN_INSTALLDIR_WFMT=%DESTCYG%
-SET RESULT_INSTALLDIR_WFMT=%DESTCOQ%
-SET TARGET_ARCH=%ARCH%-w64-mingw32
-SET BASH=%CYGWIN_INSTALLDIR_WFMT%\bin\bash
-
-REM Convert paths to various formats
-REM WFMT = windows format (C:\..) Used in this batch file.
-REM CFMT = cygwin format (\cygdrive\c\..) Used for Cygwin PATH variable, which is : separated, so C: doesn't work.
-REM MFMT = MinGW format (C:/...) Used for the build, because \\ requires escaping. Mingw can handle \ and /.
-
-SET CYGWIN_INSTALLDIR_MFMT=%CYGWIN_INSTALLDIR_WFMT:\=/%
-SET RESULT_INSTALLDIR_MFMT=%RESULT_INSTALLDIR_WFMT:\=/%
-SET SOURCE_LOCAL_CACHE_MFMT=%SOURCE_LOCAL_CACHE_WFMT:\=/%
-
-SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_MFMT:C:/=/cygdrive/c/%
-SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_MFMT:C:/=/cygdrive/c/%
-SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_MFMT:C:/=/cygdrive/c/%
-
-SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:D:/=/cygdrive/d/%
-SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:D:/=/cygdrive/d/%
-SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:D:/=/cygdrive/d/%
-
-SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:E:/=/cygdrive/e/%
-SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:E:/=/cygdrive/e/%
-SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:E:/=/cygdrive/e/%
-
-ECHO CYGWIN INSTALL DIR (WIN) = %CYGWIN_INSTALLDIR_WFMT%
-ECHO CYGWIN INSTALL DIR (MINGW) = %CYGWIN_INSTALLDIR_MFMT%
-ECHO CYGWIN INSTALL DIR (CYGWIN) = %CYGWIN_INSTALLDIR_CFMT%
-ECHO RESULT INSTALL DIR (WIN) = %RESULT_INSTALLDIR_WFMT%
-ECHO RESULT INSTALL DIR (MINGW) = %RESULT_INSTALLDIR_MFMT%
-ECHO RESULT INSTALL DIR (CYGWIN) = %RESULT_INSTALLDIR_CFMT%
-
-REM WARNING: Add a space after the = in case you want set this to empty, otherwise the variable will be unset
-SET MAKE_OPT=-j %MAKE_THREADS%
-
-REM ========== DERIVED CYGWIN SETUP OPTIONS ==========
-
-REM 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
-)
-
-IF "%CYGWIN_QUIET%" == "Y" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -q --no-admin
-)
-
-IF "%GTK_FROM_SOURCES%"=="N" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk3,mingw64-%ARCH%-libxml2
- REM gtksourceview3 is always built from sources until the bug in DLLMain is fixed in cygwin
- REM SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtksourceview3.0
-)
-
-REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES.
-REM Otherwise chmod won't work and e.g. the ocaml build will fail.
-REM Cygwin setup does not touch the ACLs of existing folders.
-
-REM Run Cygwin Setup
-
-SET RUNSETUP=Y
-IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" (
- SET RUNSETUP=N
-)
-IF NOT "%CYGWIN_QUIET%" == "Y" (
- SET RUNSETUP=Y
-)
-
-IF "%COQREGTESTING%" == "Y" (
- ECHO "========== REMOVE EXISTING CYGWIN =========="
- DEL /S /F /Q "%CYGWIN_INSTALLDIR_WFMT%" > NUL
- SET RUNSETUP=Y
-)
-
-SET "EXTRAPACKAGES= "
-
-IF NOT "%APPVEYOR%" == "True" (
- SET EXTRAPACKAGES=-P wget,curl,git,gcc-core,gcc-g++,automake1.5
-)
-
-ECHO "========== INSTALL CYGWIN =========="
-
-REM If you need to add packages, see https://cygwin.com/packages/package_list.html for package names
-REM In the description of each package you also find the file list and maintainer there
-
-IF "%RUNSETUP%"=="Y" (
- %SETUP% ^
- --proxy "%PROXY%" ^
- --site "%CYGWIN_REPOSITORY%" ^
- --root "%CYGWIN_INSTALLDIR_WFMT%" ^
- --local-package-dir "%CYGWIN_LOCAL_CACHE_WFMT%" ^
- --no-shortcuts ^
- %CYGWIN_OPT% ^
- -P make,unzip ^
- -P gdb,liblzma5 ^
- -P patch,automake1.14 ^
- -P pkg-config ^
- -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-windows_default_manifest ^
- -P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^
- -P mingw64-%ARCH%-gmp,mingw64-%ARCH%-mpfr ^
- -P adwaita-icon-theme ^
- -P libiconv-devel,libunistring-devel,libncurses-devel ^
- -P gettext-devel,libgettextpo-devel ^
- -P libglib2.0-devel,libgdk_pixbuf2.0-devel ^
- -P libfontconfig1 ^
- -P gtk-update-icon-cache ^
- -P libtool,automake ^
- -P libgmp-devel ^
- -P intltool ^
- -P bison,flex ^
- %EXTRAPACKAGES% ^
- || GOTO ErrorExit
-
- MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build"
- MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\buildlogs"
-)
-
-IF NOT "%CYGWIN_QUIET%" == "Y" (
- REM Like most setup programs, cygwin setup starts the real setup as a separate process, so wait for it.
- REM This is not required with the -cygquiet=Y and the resulting --no-admin option.
- :waitsetup
- tasklist /fi "imagename eq %SETUP%" | find ":" > NUL
- IF ERRORLEVEL 1 GOTO waitsetup
-)
-
-ECHO ========== CONFIGURE CYGWIN USER ACCOUNT ==========
-
-REM In case this batch file is called from a cygwin bash (e.g. a git repo) we need to clear
-REM HOME (otherwise we get to the home directory of the other installation)
-REM PROFILEREAD (this is set to true if the /etc/profile has been read, which creates user)
-SET "HOME="
-SET "PROFILEREAD="
-
-copy "%BATCHDIR%\configure_profile.sh" "%CYGWIN_INSTALLDIR_WFMT%\var\tmp" || GOTO ErrorExit
-%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\var\tmp\configure_profile.sh" "%PROXY%" || GOTO ErrorExit
-
-ECHO ========== BUILD COQ ==========
-
-MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build"
-RMDIR /S /Q "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
-MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
-
-COPY "%BATCHDIR%\makecoq_mingw.sh" "%CYGWIN_INSTALLDIR_WFMT%\build" || GOTO ErrorExit
-COPY "%BATCHDIR%\patches_coq\*.*" "%CYGWIN_INSTALLDIR_WFMT%\build\patches" || GOTO ErrorExit
-
-%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\build\makecoq_mingw.sh" || GOTO ErrorExit
-
-ECHO ========== FINISHED ==========
-
-GOTO :EOF
-
-ECHO ========== BATCH FUNCTIONS ==========
-
-:PrintPars
- REM 01234567890123456789012345678901234567890123456789012345678901234567890123456789
- ECHO -arch ^<i686 or x86_64^> Set cygwin, ocaml and coq to 32 or 64 bit
- ECHO -mode ^<mingwincygwin = install coq in default cygwin mingw sysroot^>
- ECHO ^<absolute = install coq in -destcoq absolute path^>
- ECHO ^<relocatable = install relocatable coq in -destcoq path^>
- ECHO -installer^<Y or N^> create a windows installer (will be in /build/coq/dev/nsis)
- ECHO -ocaml ^<Y or N^> install OCaml in Coq folder (Y) or just in cygwin folder (N)
- ECHO -make ^<Y or N^> install GNU Make in Coq folder (Y) or not (N)
- ECHO -destcyg ^<path to cygwin destination folder^>
- ECHO -destcoq ^<path to coq destination folder (mode=absolute/relocatable)^>
- ECHO -setup ^<cygwin setup program name^> (auto adjusted to -arch)
- 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 -cygquiet ^<Y or N^> install cygwin without user interaction
- ECHO -srccache ^<local source code repository/cache^>
- 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)
- ECHO(
- ECHO See ReadMe.txt for a detailed description of all parameters
- ECHO(
- ECHO Parameter values (default or currently set):
- ECHO -arch = %ARCH%
- ECHO -mode = %INSTALLMODE%
- ECHO -ocaml = %INSTALLOCAML%
- ECHO -installer= %MAKEINSTALLER%
- ECHO -make = %INSTALLMAKE%
- ECHO -destcyg = %DESTCYG%
- ECHO -destcoq = %DESTCOQ%
- ECHO -setup = %SETUP%
- ECHO -proxy = %PROXY%
- ECHO -cygrepo = %CYGWIN_REPOSITORY%
- ECHO -cygcache = %CYGWIN_LOCAL_CACHE_WFMT%
- ECHO -cyglocal = %CYGWIN_FROM_CACHE%
- ECHO -cygquiet = %CYGWIN_QUIET%
- ECHO -srccache = %SOURCE_LOCAL_CACHE_WFMT%
- ECHO -coqver = %COQ_VERSION%
- ECHO -gtksrc = %GTK_FROM_SOURCES%
- ECHO -threads = %MAKE_THREADS%
- ECHO -addon = %COQ_ADDONS%
- GOTO :EOF
-
-:CheckYN
- REM Reset errorlevel to 0
- CMD /c "EXIT /b 0"
- IF "%2" == "Y" (
- REM OK Y
- ) ELSE IF "%2" == "N" (
- REM OK N
- ) ELSE (
- ECHO ERROR Parameter %1 must be Y or N, but is %2
- GOTO ErrorExit
- )
- GOTO :EOF
-
-:ErrorExit
- ECHO ERROR MakeCoq_MinGW.bat failed
- EXIT /b 1
diff --git a/dev/build/windows/MakeCoq_SetRootPath.bat b/dev/build/windows/MakeCoq_SetRootPath.bat deleted file mode 100644 index bcb104772c..0000000000 --- a/dev/build/windows/MakeCoq_SetRootPath.bat +++ /dev/null @@ -1,27 +0,0 @@ -REM ========== COPYRIGHT/COPYLEFT ========== - -REM (C) 2016 Intel Deutschland GmbH -REM Author: Michael Soegtrop - -REM Released to the public by Intel under the -REM GNU Lesser General Public License Version 2.1 or later -REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -REM ========== CHOOSE A SENSIBLE ROOT PATH ========== - -@ ECHO OFF - -REM Figure out a root path for coq and cygwin - -REM For the \nul trick for testing folders see -REM https://support.microsoft.com/en-us/kb/65994 - -IF EXIST D:\bin\nul ( - SET ROOTPATH=D:\bin -) else if EXIST C:\bin ( - SET ROOTPATH=C:\bin -) else ( - SET ROOTPATH=C: -) - -ECHO ROOTPATH set to %ROOTPATH% diff --git a/dev/build/windows/MakeCoq_explicitcachefolders_installer.bat b/dev/build/windows/MakeCoq_explicitcachefolders_installer.bat deleted file mode 100755 index d7d3c5b9d3..0000000000 --- a/dev/build/windows/MakeCoq_explicitcachefolders_installer.bat +++ /dev/null @@ -1,28 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=git-v8.6 ^
- -destcyg="%ROOTPATH%\cygwin_coq64_cachefolder_inst" ^
- -destcoq="%ROOTPATH%\coq64_cachefolder_inst" ^
- -cygcache="%ROOTPATH%\cache\cygwin" ^
- -srccache="%ROOTPATH%\cache\source"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_explicitcachefolders_installer.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_local_installer.bat b/dev/build/windows/MakeCoq_local_installer.bat deleted file mode 100755 index 752b73c10a..0000000000 --- a/dev/build/windows/MakeCoq_local_installer.bat +++ /dev/null @@ -1,26 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=/cygdrive/d/coqgit/coq-8.6 ^
- -destcyg="%ROOTPATH%\cygwin_coq64_local_inst" ^
- -destcoq="%ROOTPATH%\coq64_local_inst"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_local_installer.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_master_installer.bat b/dev/build/windows/MakeCoq_master_installer.bat deleted file mode 100755 index 72640d5d79..0000000000 --- a/dev/build/windows/MakeCoq_master_installer.bat +++ /dev/null @@ -1,26 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=git-master ^
- -destcyg="%ROOTPATH%\cygwin_coq64_trunk_inst" ^
- -destcoq="%ROOTPATH%\coq64_trunk_inst"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_86git_installer.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_regtest_noproxy.bat b/dev/build/windows/MakeCoq_regtest_noproxy.bat deleted file mode 100644 index 7140a7c619..0000000000 --- a/dev/build/windows/MakeCoq_regtest_noproxy.bat +++ /dev/null @@ -1,29 +0,0 @@ -REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-SET HTTP_PROXY=
-SET HTTPS_PROXY=
-MKDIR C:\Temp\srccache
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -mode=absolute ^
- -ocaml=Y ^
- -make=Y ^
- -coqver 8.5pl2 ^
- -srccache C:\Temp\srccache ^
- -cygquiet=Y ^
- -destcyg %ROOTPATH%\cygwin_coq64_85pl2_abs ^
- -destcoq %ROOTPATH%\coq64_85pl2_abs
-
-pause
diff --git a/dev/build/windows/MakeCoq_regtests.bat b/dev/build/windows/MakeCoq_regtests.bat deleted file mode 100644 index 74c26456b4..0000000000 --- a/dev/build/windows/MakeCoq_regtests.bat +++ /dev/null @@ -1,36 +0,0 @@ -REM ========== COPYRIGHT/COPYLEFT ========== - -REM (C) 2016 Intel Deutschland GmbH -REM Author: Michael Soegtrop - -REM Released to the public by Intel under the -REM GNU Lesser General Public License Version 2.1 or later -REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -REM ========== RUN REGRESSION TESTS FOR COQ BUILD SCRIPTS ========== - -SET COQREGTESTING=Y - -REM Current stable -call MakeCoq_86git_abs_ocaml.bat || GOTO Error -call MakeCoq_86git_installer.bat || GOTO Error -call MakeCoq_86git_installer_32.bat || GOTO Error - -REM Old but might still be used -call MakeCoq_85pl3_abs_ocaml.bat || GOTO Error -call MakeCoq_84pl6_abs_ocaml.bat || GOTO Error - -REM Special variants, e.g. for debugging -call MakeCoq_86git_abs_ocaml_gtksrc.bat || GOTO Error -call MakeCoq_local_installer.bat || GOTO Error -call MakeCoq_explicitcachefolders_installer.bat || GOTO Error - -REM Bleeding edge -call MakeCoq_trunk_installer.bat || GOTO Error - -ECHO MakeCoq_regtests.bat: All tests finished successfully -GOTO :EOF - -:Error -ECHO MakeCoq_regtests.bat failed with error code %ERRORLEVEL% -EXIT /b %ERRORLEVEL% diff --git a/dev/build/windows/ReadMe.txt b/dev/build/windows/ReadMe.txt deleted file mode 100644 index f34bbea4e9..0000000000 --- a/dev/build/windows/ReadMe.txt +++ /dev/null @@ -1,442 +0,0 @@ -(C) 2016 Intel Deutschland GmbH -Author: Michael Soegtrop - -Released to the public by Intel under the -GNU Lesser General Public License Version 2.1 or later -See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -This license also applies to all files in the patches_coq subfolder. - -==================== Purpose / Goal ==================== - -The main purpose of these scripts is to build Coq for Windows in a reproducible -and at least by this script documented way without using binary libraries and -executables from various sources. These scripts use only MinGW libraries -provided by Cygwin or compile things from sources. For some libraries there are -options to build them from sources or to use the Cygwin version. - -Another goal (which is not yet achieved) is to have a Coq installer for -Windows, which includes all tools required for native compute and Coq plugin -development without Cygwin. - -Coq requires OCaml for this and OCaml requires binutils, gcc and a posix shell. -Since the standard Windows OCaml installation requires Cygwin to deliver some of -these components, you might be able to imagine that this is not so easy. - -These scripts can produce the following: - -- Coq running on MinGW - -- OCaml producing MinGW code and running on MinGW - -- GCC producing MinGW code and running on MinGW - -- binutils producing MinGW code and running on MinGW - -With "running on MinGW" I mean that the tools accept paths like -"C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys DLL. The -MinGW gcc and binutils provided by Cygwin produce MinGW code, but they run only -on Cygwin. - -With "producing MinGW code" I mean that the programs created by the tools accept -paths like "C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys -DLL. - -The missing piece is a posix shell running on plain Windows (without msys or -Cygwin DLL) and not being a binary from obscure sources. I am working on it ... - -Since compiling gcc and binutils takes a while and it is not of much use without -a shell, the building of these components is currently disabled. OCaml is built -anyway, because this MinGW/MinGW OCaml (rather than a Cygwin/MinGW OCaml) is -used to compile Coq. - -Until the shell is there, the Cygwin created by these scripts is required to run -OCaml tools. When everything is finished, this will no longer be required. - -==================== Usage ==================== - -The Script MakeCoq_MinGW does: -- download Cygwin (except the Setup.exe or Setup64.exe) -- install Cygwin -- either installs MinGW GTK via Cygwin or compiles it fom sources -- download, compile and install OCaml, CamlP5, Menhir, lablgtk -- download, compile and install Coq -- download, compile and install selected addons -- create a Windows installer (NSIS based) - -The parameters are described below. Mostly paths and the HTTP proxy need to be -set. - -There are two main usages: - -- Compile and install OCaml and Coq in a given folder - - This works reliably, because absolute library paths can be compiled into Coq - and OCaml. - - WARNING: See the "Purpose / Goal" section above for status. - - See MakeCoq_85pl2_abs_ocaml.bat for parameters. - -- Create a Windows installer. - - This works well for Coq but not so well for OCaml. - - WARNING: See the "Purpose / Goal" section above for status. - - See MakeCoq_85pl2_installer.bat for parameters. - -There is also an option to compile OCaml and Coq inside Cygwin, but this is -currently not recommended. The resulting Coq and OCaml work, but Coq is slow -because it scans the largish Cygwin share folder. This will be fixed in a future -version. - -Procedure: - -- Unzip contents of CoqSetup.zip in a folder - -- Adjust parameters in MakeCoq_85pl2_abs_ocaml.bat or in MakeCoq_85pl2_installer.bat. - -- Download Cygwin setup from https://Cygwin.com/install.html - For 32 bit Coq : setup-x86.exe (https://Cygwin.com/setup-x86.exe) - For 64 bit Coq : setup-x86_64.exe (https://Cygwin.com/setup-x86_64.exe) - -- Run MakeCoq_85pl3_abs_ocaml.bat or MakeCoq_85pl3_installer.bat - -- Check MakeCoq_regtests.bat to see what combinations of options are tested - -==================== MakeCoq_MinGW Parameters ==================== - -===== -arch ===== - -Set the target architecture. - -Possible values: - -32: Install/build Cygwin, ocaml and coq for 32 bit windows - -64: Install/build Cygwin, ocaml and coq for 64 bit windows - -Default value: 64 - - -===== -mode ===== - -Set the installation mode / target folder structure. - -Possible values: - -mingwinCygwin: Install coq in the default Cygwin mingw sysroot folder. - This is %DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw. - Todo: The coq share folder should be configured to e.g. /share/coq. - As is, coqc scans the complete share folder, which slows it down 5x for short files. - -absolute: Install coq in the absolute path given with -destcoq. - The resulting Coq will not be relocatable. - That is the root folder must not be renamed/moved. - -relocatable: Install coq in the absolute path given with -destcoq. - The resulting Coq will be relocatable. - That is the root folder may be renamed/moved. - If OCaml is installed, please note that OCaml cannot be build really relocatable. - If the root folder is moved, the environment variable OCAMLLIB must be set to the libocaml sub folder. - Also the file <root>\libocaml\ld.conf must be adjusted. - -Default value: absolute - - -===== -installer ===== - -Create a Windows installer (it will be in build/coq-8.xplx/dev/nsis) - -Possible values: - -Y: Create a windows installer - this forces -mode=relocatable. - -N: Don't create a windows installer - use the created Coq installation as is. - -Default value: N - - -===== -ocaml ===== - -Install OCaml for later use with Coq or just for building. - -Possible values: - -Y: Install OCaml in the same root as Coq (as given with -coqdest) - This also copies all .o, .cmo, .a, .cmxa files in the lib folder required for compiling plugins. - -N: Install OCaml in the default Cygwin mingw sysroot folder. - This is %DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw. - -Default value: N - - -===== -make ===== - -Build and install MinGW GNU make - -Possible values: - -Y: Install MinGW GNU make in the same root as Coq (as given with -coqdest). - -N: Don't build or install MinGW GNU make. - For building everything always Cygwin GNU make is used. - -Default value: Y - - -===== -destcyg ===== - -Destination folder in which Cygwin is installed. - -This must be an absolute path in Windows format (with drive letter and \\). - ->>>>> This folder may be deleted after the Coq build is finished! <<<<< - -Default value: C:\bin\Cygwin_coq - - -===== -destcoq ===== - -Destination folder in which Coq is installed. - -This must be an absolute path in Windows format (with drive letter and \\). - -This option is not required if -mode mingwinCygwin is used. - -Default value: C:\bin\coq - - -===== -setup ===== - -Name/path of the Cygwin setup program. - -The Cygwin setup program is called setup-x86.exe or setup-x86_64.exe. -It can be downloaded from: https://Cygwin.com/install.html. - -Default value: setup-x86.exe or setup-x86_64.exe, depending on -arch. - - -===== -proxy ===== - -Internet proxy setting for downloading Cygwin, ocaml and coq. - -The format is <server>:<port>, e.g. proxy.mycompany.com:911 - -The same proxy is used for HTTP, HTTPS and FTP. -If you need separate proxies for separate protocols, you please put your proxies directly into configure_profile.sh (line 11..13). - -Default value: Value of HTTP_PROXY environment variable or none if this variable does not exist. - -ATTENTION: With the --proxy setting of the Cygwin setup, it is possible to -supply a proxy server, but if this parameter is "", Cygwin setup might use proxy -settings from previous setups. If you once did a Cygwin setup behind a firewall -and now want to do a Cygwin setup without a firewall, use the -cygquiet=N -setting to perform a GUI install, where you can adjust the proxy setting. - -===== -cygrepo ===== - -The online repository, from which Cygwin packages are downloaded. - -Note: although most repositories end with Cygwin32, they are good for 32 and 64 bit Cygwin. - -Default value: http://ftp.inf.tu-dresden.de/software/windows/Cygwin32 - ->>>>> If you are not in Europe, you might want to change this! <<<<< - - -===== -cygcache ===== - -The local cache folder for Cygwin repositories. - -You can also copy files here from a backup/reference and set -cyglocal. -The setup will then not download/update from the internet but only use the local cache. - -Default value: <folder of MakeCoq_MinGW.bat>\Cygwin_cache - - -===== -cyglocal ===== - -Control if the Cygwin setup uses the latest version from the internet or the version as is in the local folder. - -Possible values: - -Y: Install exactly the Cygwin version from the local repository cache. - Don't update from the internet. - -N: Download the latest Cygwin version from the internet. - Update the local repository cache with the latest version. - -Default value: N - - -===== -cygquiet ===== - -Control if the Cygwin setup runs quietly or interactive. - -Possible values: - -Y: Install Cygwin quietly without user interaction. - -N: Install Cygwin interactively (allows to select additional packages). - -Default value: Y - - -===== -srccache ===== - -The local cache folder for ocaml/coq/... sources. - -Default value: <folder of MakeCoq_MinGW.bat>\source_cache - - -===== -coqver ===== - -The version of Coq to download and compile. - -Possible values: 8.4pl6, 8.5pl2, 8.5pl3, 8.6 - (download from https://coq.inria.fr/distrib/V$COQ_VERSION/files/coq-<version>.tar.gz) - Others versions might work, but are untested. - 8.4 is only tested in mode=absolute - - git-v8.6, git-trunk - (download from https://github.com/coq/coq/archive/<version without git->.zip) - - /cygdrive/.... - Use local folder. The sources are archived as coq-local.tar.gz - -Default value: 8.5pl3 - -If git- is prepended, the Coq sources are loaded from git. - -ATTENTION: with default options, the scripts cache source tar balls in two -places, the <destination>/build/tarballs folder and the <scripts>/source_cache -folder. If you modified something in git, you need to delete the cached tar ball -in both places! - -===== -gtksrc ===== - -Control if GTK and its prerequisites are build from sources or if binary MinGW packages from Cygwin are used - -Possible values: - -Y: Build GTK from sources, takes about 90 minutes extra. - This is useful, if you want to debug/fix GTK or library issues. - -N: Use prebuilt MinGW libraries from Cygwin - - -===== -threads ===== - -Control the maximum number of make threads for modules which support parallel make. - -Possible values: 1..N. - Should not be more than 1.5x the number of cores. - Should not be more than available RAM/2GB (e.g. 4 for 8GB) - -===== -addon ===== - -Enable build and installation of selected Coq package (can be repeated for -selecting more packages) - -==================== TODO ==================== - -- Check for spaces in destination paths -- Check for = signs in all paths (DOS commands don't work with paths with = in it, possibly even when quoted) -- Installer doesn't remove OCAMLLIB environment variables (it is in the script, but doesn't seem to work) -- CoqIDE doesn't find theme files -- Finish / test mingw_in_Cygwin mode (coqide doesn't start, coqc slow cause of scanning complete share folder) -- Possibly create/login as specific user to bash (not sure if it makes sense - need to create additional bash login link then) -- maybe move share/doc/menhir somewhere else (reduces coqc startup time) -- Use original installed file list for removing files in uninstaller - -==================== Issues with relocation ==================== - -Coq and OCaml are built in a specific folder and are not really intended for relocation e.g. by an installer. -Some absolute paths in config files are patched in coq_new.nsi. - -Coq is made fairly relocatable by first configuring it with PREFIX=./ and then PREFIX=<installdir>. -OCaml is made relocatable mostly by defining the OCAMLLIB environment variable and by patching some files. -If you have issues with one of the remaining (unpatched) files below, please let me know. - -Text files patched by the installer: - -./ocamllib/ld.conf -./etc/findlib.conf:destdir="D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib" -./etc/findlib.conf:path="D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib" - -Text files containing the install folder path after install: - -./libocaml/Makefile.config:PREFIX=D:/bin/coq64_buildtest_reloc_ocaml20 -./libocaml/Makefile.config:LIBDIR=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml -./libocaml/site-lib/findlib/Makefile.config:OCAML_CORE_BIN=/cygdrive/d/bin/coq64_buildtest_reloc_ocaml20/bin -./libocaml/site-lib/findlib/Makefile.config:OCAML_SITELIB=D:/bin/coq64_buildtest_reloc_ocaml20\libocaml\site-lib -./libocaml/site-lib/findlib/Makefile.config:OCAMLFIND_BIN=D:/bin/coq64_buildtest_reloc_ocaml20\bin -./libocaml/site-lib/findlib/Makefile.config:OCAMLFIND_CONF=D:/bin/coq64_buildtest_reloc_ocaml20\etc\findlib.conf -./libocaml/topfind:#directory "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib";; -./libocaml/topfind: Topdirs.dir_load Format.err_formatter "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib.cma"; -./libocaml/topfind: Topdirs.dir_load Format.err_formatter "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma"; -./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib.cma";; *) -./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma";; *) - -Binary files containing the build folder path after install: - -$ find . -type f -exec grep "Cygwin_coq64_buildtest_reloc_ocaml20" {} /dev/null \; -Binary file ./bin/coqtop.byte.exe matches -Binary file ./bin/coqtop.exe matches -Binary file ./bin/ocamldoc.exe matches -Binary file ./bin/ocamldoc.opt.exe matches -Binary file ./libocaml/ocamldoc/odoc_info.a matches -Binary file ./libocaml/ocamldoc/odoc_info.cma matches - -Binary files containing the install folder path after install: - -$ find . -type f -exec grep "coq64_buildtest_reloc_ocaml20" {} /dev/null \; -Binary file ./bin/coqc.exe matches -Binary file ./bin/coqchk.exe matches -Binary file ./bin/coqdep.exe matches -Binary file ./bin/coqdoc.exe matches -Binary file ./bin/coqide.exe matches -Binary file ./bin/coqtop.byte.exe matches -Binary file ./bin/coqtop.exe matches -Binary file ./bin/coqworkmgr.exe matches -Binary file ./bin/coq_makefile.exe matches -Binary file ./bin/menhir matches -Binary file ./bin/ocaml.exe matches -Binary file ./bin/ocamlc.exe matches -Binary file ./bin/ocamlc.opt.exe matches -Binary file ./bin/ocamldebug.exe matches -Binary file ./bin/ocamldep.exe matches -Binary file ./bin/ocamldep.opt.exe matches -Binary file ./bin/ocamldoc.exe matches -Binary file ./bin/ocamldoc.opt.exe matches -Binary file ./bin/ocamlfind.exe matches -Binary file ./bin/ocamlmklib.exe matches -Binary file ./bin/ocamlobjinfo.exe matches -Binary file ./bin/ocamlopt.exe matches -Binary file ./bin/ocamlopt.opt.exe matches -Binary file ./bin/ocamlprof.exe matches -Binary file ./bin/ocamlrun.exe matches -Binary file ./bin/ocpp5.exe matches -Binary file ./lib/config/coq_config.cmo matches -Binary file ./lib/config/coq_config.o matches -Binary file ./lib/grammar/grammar.cma matches -Binary file ./lib/ide/coqide/ide_win32_stubs.o matches -Binary file ./lib/lib/clib.a matches -Binary file ./lib/lib/clib.cma matches -Binary file ./lib/libcoqrun.a matches -Binary file ./libocaml/compiler-libs/ocamlcommon.a matches -Binary file ./libocaml/compiler-libs/ocamlcommon.cma matches -Binary file ./libocaml/dynlink.cma matches -Binary file ./libocaml/expunge.exe matches -Binary file ./libocaml/extract_crc.exe matches -Binary file ./libocaml/libcamlrun.a matches -Binary file ./libocaml/ocamlbuild/ocamlbuildlib.a matches -Binary file ./libocaml/ocamlbuild/ocamlbuildlib.cma matches -Binary file ./libocaml/ocamldoc/odoc_info.a matches -Binary file ./libocaml/ocamldoc/odoc_info.cma matches -Binary file ./libocaml/site-lib/findlib/findlib.a matches -Binary file ./libocaml/site-lib/findlib/findlib.cma matches -Binary file ./libocaml/site-lib/findlib/findlib.cmxs matches diff --git a/dev/build/windows/configure_profile.sh b/dev/build/windows/configure_profile.sh deleted file mode 100644 index 7e606b5544..0000000000 --- a/dev/build/windows/configure_profile.sh +++ /dev/null @@ -1,43 +0,0 @@ -#!/bin/bash - -###################### COPYRIGHT/COPYLEFT ###################### - -# (C) 2016 Intel Deutschland GmbH -# Author: Michael Soegtrop -# -# Released to the public by Intel under the -# GNU Lesser General Public License Version 2.1 or later -# See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -###################### CONFIGURE CYGWIN USER PROFILE FOR BUILDING COQ ###################### - -rcfile=~/.bash_profile -donefile=~/.bash_profile.upated - -# to learn about `exec >> $file`, see https://www.tldp.org/LDP/abs/html/x17974.html -exec >> $rcfile - -if [ ! -f $donefile ] ; then - - if [ "$1" != "" ] && [ "$1" != " " ]; then - echo export http_proxy="http://$1" - echo export https_proxy="http://$1" - echo export ftp_proxy="http://$1" - fi - - mkdir -p "$RESULT_INSTALLDIR_CFMT/bin" - - # A tightly controlled path helps to avoid issues - # Note: the order is important: first have the cygwin binaries, then the mingw binaries in the path! - # Note: /bin is mounted at /usr/bin and /lib at /usr/lib and it is common to use /usr/bin in PATH - # See cat /proc/mounts - echo "export PATH=/usr/local/bin:/usr/bin:$RESULT_INSTALLDIR_CFMT/bin:/usr/$TARGET_ARCH/sys-root/mingw/bin:/cygdrive/c/Windows/system32:/cygdrive/c/Windows" - - # find and xargs complain if the environment is larger than (I think) 8k. - # ORIGINAL_PATH (set by cygwin) can be a few k and exceed the limit - echo unset ORIGINAL_PATH - # Other installations of OCaml will mess up things - echo unset OCAMLLIB - - touch $donefile -fi diff --git a/dev/build/windows/difftar-folder.sh b/dev/build/windows/difftar-folder.sh deleted file mode 100644 index 543ca972cd..0000000000 --- a/dev/build/windows/difftar-folder.sh +++ /dev/null @@ -1,89 +0,0 @@ -#!/bin/bash - -###################### COPYRIGHT/COPYLEFT ###################### - -# (C) 2016 Intel Deutschland GmbH -# Author: Michael Soegtrop -# -# Released to the public by Intel under the -# GNU Lesser General Public License Version 2.1 or later -# See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -###################### DIFF A TAR FILE AND A FOLDER ###################### - -set -o nounset - -# Print usage - -if [ "$#" -lt 2 ] ; then - echo 'Diff a tar (or compressed tar) file with a folder' - echo 'difftar-folder.sh <tarfile> <folder> [strip]' - echo '<tarfile> is the name of the tar file do diff with (required)' - echo '<folder> is the name of the folder to diff with (required)' - echo '<strip> is the number of path components to strip from tar file (default is 0)' - echo 'All files in the tar file must have at least <strip> path components.' - echo 'This also adds new files from folder.new, if folder.new exists' - exit 1 -fi - -# Parse parameters - -tarfile=$1 -folder=$2 - -if [ "$#" -ge 3 ] ; then - strip=$3 -else - strip=0 -fi - -# Get path prefix if --strip is used - -if [ "$strip" -gt 0 ] ; then - # Get the path/name of the first file from the tar and extract the first $strip path components - # This assumes that the first file in the tar file has at least $strip many path components - prefix=$(tar -t -f "$tarfile" | head -1 | cut -d / -f -$strip)/ -else - prefix= -fi - -# Original folder - -orig=$folder.orig -mkdir -p "$orig" - -# New amd empty filefolder - -new=$folder.new -empty=$folder.empty -mkdir -p "$empty" - -# Print information (this is ignored by patch) - -echo diff/patch file created on "$(date)" with: -echo difftar-folder.sh "$@" -echo TARFILE= "$tarfile" -echo FOLDER= "$folder" -echo TARSTRIP= "$strip" -echo TARPREFIX= "$prefix" -echo ORIGFOLDER= "$orig" - -# Make sure tar uses english output (for Mod time differs) -export LC_ALL=C - -# Search all files with a deviating modification time using tar --diff -tar --diff -a -f "$tarfile" --strip $strip --directory "$folder" | grep "Mod time differs" | while read -r file ; do - # Substitute ': Mod time differs' with nothing - file=${file/: Mod time differs/} - # Check if file exists - if [ -f "$folder/$file" ] ; then - # Extract original file - tar -x -a -f "$tarfile" --strip $strip --directory "$orig" "$prefix$file" - # Compute diff - diff -u "$orig/$file" "$folder/$file" - fi -done - -if [ -d "$new" ] ; then - diff -u -r --unidirectional-new-file "$empty" "$new" -fi diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh deleted file mode 100755 index 4c376f563f..0000000000 --- a/dev/build/windows/makecoq_mingw.sh +++ /dev/null @@ -1,2033 +0,0 @@ -#!/bin/bash - -###################### COPYRIGHT/COPYLEFT ###################### - -# (C) 2016..2018 Intel Deutschland GmbH -# Author: Michael Soegtrop -# -# Released to the public by Intel under the -# GNU Lesser General Public License Version 2.1 or later -# See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html -# -# With very valuable help on building GTK from -# https://wiki.gnome.org/Projects/GTK+/Win32/MSVCCompilationOfGTKStack -# http://www.gaia-gis.it/spatialite-3.0.0-BETA/mingw64_how_to.html - -###################### Script safety and debugging settings ###################### - -set -o nounset -set -o errexit -set -x -# 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 - -###################### NOTES ##################### - -# - This file goes together with MakeCoq_ForMignGW.bat, which sets up cygwin -# with all required packages and then calls this script. -# -# - This script uses set -o errexit, so if anything fails, the script will stop -# -# - cygwin provided mingw64 packages like mingw64-x86_64-zlib are installed to -# /usr/$TARGET_ARCH/sys-root/mingw, so we use this as install prefix -# -# - if mingw64-x86_64-pkg-config is installed BEFORE building libpng or pixman, -# the .pc files are properly created in /usr/$TARGET_ARCH/sys-root/mingw/lib/pkgconfig -# -# - pango and some others uses pkg-config executable names without path, which doesn't work in cross compile mode -# There are several possible solutions -# 1.) patch build files to get the prefix from pkg-config and use $prefix/bin/ as path -# - doesn't work for pango because automake goes wild -# - mingw tools are not able to handle cygwin path (they need absolute windows paths) -# 2.) export PATH=$PATH:/usr/$TARGET_ARCH/sys-root/mingw/bin -# - a bit dangerous because this exposes much more than required -# - mingw tools are not able to handle cygwin path (they need absolute windows paths) -# 3.) Install required tools via cygwin modules libglib2.0-devel and libgdk_pixbuf2.0-devel -# - Possibly version compatibility issues -# - Possibly mingw/cygwin compatibility issues, e.g. when building font or terminfo databases -# 4.) Build required tools for mingw and cygwin -# - Possibly mingw/cygwin compatibility issues, e.g. when building font or terminfo databases -# -# We use method 3 below -# Method 2 can be tried by putting the cross tools in the path before the cygwin tools (in configure_profile.sh) -# -# - It is tricky to build 64 bit binaries with 32 bit cross tools and vice versa. -# This is because the linker needs to load DLLs from C:\windows\system32, which contains -# both 32 bit and 64 bit DLLs, and which one you get depends by some black magic on if the using -# app is a 32 bit or 64 bit app. So better build 32 bit mingw with 32 bit cygwin and 64 with 64. -# Alternatively the required 32 bit or 64 bit DLLs need to be copied with a 32 bit/64bit cp to some -# folder without such black magic. -# -# - The file selection for the Coq Windows Installer is done with make install (unlike the original script) -# Relocatble builds are first configured with prefix=./ then build and then -# reconfigured with prefix=<installroot> before make install. - - -###################### ARCHITECTURES ##################### - -# The OS on which the build of the tool/lib runs -BUILD=$(gcc -dumpmachine) - -# The OS on which the tool runs -# "`find /bin -name "*mingw32-gcc.exe"`" -dumpmachine -HOST=$TARGET_ARCH - -# The OS for which the tool creates code/for which the libs are -TARGET=$TARGET_ARCH - -# Cygwin uses different arch name for 32 bit than mingw/gcc -case $ARCH in - x86_64) CYGWINARCH=x86_64 ;; - i686) CYGWINARCH=x86 ;; - *) false ;; -esac - -###################### PATHS ##################### - -# Name and create some 'global' folders -PATCHES=/build/patches -BUILDLOGS=/build/buildlogs -FLAGFILES=/build/flagfiles -TARBALLS=/build/tarballs -FILELISTS=/build/filelists - -mkdir -p $BUILDLOGS -mkdir -p $FLAGFILES -mkdir -p $TARBALLS -mkdir -p $FILELISTS -cd /build - -# Create source cache folder -mkdir -p "$SOURCE_LOCAL_CACHE_CFMT" - -# sysroot prefix for the above /build/host/target combination -# This must be in MFMT (C:/.../) because the OCaml library path is based on it and OCaml is a MinGW application. -PREFIXMINGW=$CYGWIN_INSTALLDIR_MFMT/usr/$TARGET_ARCH/sys-root/mingw - -# Install / Prefix folder for COQ -PREFIXCOQ=$RESULT_INSTALLDIR_MFMT - -# Install / Prefix folder for OCaml -if [ "$INSTALLOCAML" == "Y" ]; then - PREFIXOCAML=$PREFIXCOQ -else - PREFIXOCAML=$PREFIXMINGW -fi - -mkdir -p "$PREFIXMINGW/bin" -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 ##################### - -# Copy Cygwin repo ini file and installed files db to tarballs folder. -# Both files together document the exact selection and version of cygwin packages. -# Do this as early as possible to avoid changes by other setups (the repo folder is shared). - -# Escape URL to folder name -CYGWIN_REPO_FOLDER=${CYGWIN_REPOSITORY}/ -CYGWIN_REPO_FOLDER=${CYGWIN_REPO_FOLDER//:/%3a} -CYGWIN_REPO_FOLDER=${CYGWIN_REPO_FOLDER//\//%2f} - -# Copy files -cp "$CYGWIN_LOCAL_CACHE_WFMT/$CYGWIN_REPO_FOLDER/$CYGWINARCH/setup.ini" $TARBALLS -cp /etc/setup/installed.db $TARBALLS - -# Gtksourceview3 needs python but Cygwin now only installs python2 -ln -s -f /usr/bin/python2 /usr/bin/python - -###################### LOGGING ##################### - -# The folder which receives log files -mkdir -p buildlogs -LOGS=$(pwd)/buildlogs - -# The current log target (first part of the log file name) -LOGTARGET=other - -# 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.txt" 2>"$LOGS/$LOGTARGET-$1_err.txt" - } - - # 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.txt" 2>"$LOGS/$LOGTARGET-$1-$2_err.txt" - } - - # 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.txt" 2>"$LOGS/$LOGTARGET-$1-$3_err.txt" - } - - # 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.txt" 2>"$LOGS/$LOGTARGET-${LOGTARGETEX}_err.txt" - } -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.txt" | sed -e "s/^/$LOGTARGET-$1_log.txt: /") 2> >(tee "$LOGS/$LOGTARGET-$1_err.txt" | sed -e "s/^/$LOGTARGET-$1_err.txt: /" 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.txt" | sed -e "s/^/$LOGTARGET-$1-$2_log.txt: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$2_err.txt" | sed -e "s/^/$LOGTARGET-$1-$2_err.txt: /" 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.txt" | sed -e "s/^/$LOGTARGET-$1-$3_log.txt: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$3_err.txt" | sed -e "s/^/$LOGTARGET-$1-$3_err.txt: /" 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.txt" | sed -e "s/^/$LOGTARGET-${LOGTARGETEX}_log.txt: /") 2> >(tee "$LOGS/$LOGTARGET-${LOGTARGETEX}_err.txt" | sed -e "s/^/$LOGTARGET-${LOGTARGETEX}_err.txt: /" 1>&2) - } -fi - -###################### 'UNFIX' SED ##################### - -# In Cygwin SED used to do CR-LF to LF conversion, but since sed 4.4-1 this was changed -# We replace sed with a shell script which restores the old behavior for piped input - -#if [ -f /bin/sed.exe ] -#then -# mv /bin/sed.exe /bin/sed_orig.exe -#fi -#cat > /bin/sed << EOF -##!/bin/sh -#dos2unix | /bin/sed_orig.exe "$@" -#EOF -#chmod a+x /bin/sed - -###################### UTILITY FUNCTIONS ##################### - -# ------------------------------------------------------------------------------ -# Get a source tar ball, expand and patch it -# - get source archive from $SOURCE_LOCAL_CACHE_CFMT or online using wget -# - create build folder -# - extract source archive -# - patch source file if patch exists -# -# Parameters -# $1 file server name including protocol prefix -# $2 file name (without extension) -# $3 file extension -# $4 [optional] number of path levels to strip from tar (usually 1) -# $5 [optional] module name (if different from archive) -# $6 [optional] expand folder name (if different from module name) -# $7 [optional] module base name (used as 2nd choice for patches, defaults to $5) -# ------------------------------------------------------------------------------ - -function get_expand_source_tar { - # Handle optional parameters - if [ "$#" -ge 4 ] ; then - strip=$4 - else - strip=1 - fi - - if [ "$#" -ge 5 ] ; then - name=$5 - else - name=$2 - fi - - if [ "$#" -ge 6 ] ; then - folder=$6 - else - folder=$name - fi - - if [ "$#" -ge 7 ] ; then - basename=$7 - else - basename=$name - fi - - # Set logging target - logtargetold=$LOGTARGET - LOGTARGET=$name - - # Get the source archive either from the source cache or online - if [ ! -f "$TARBALLS/$name.$3" ] ; then - if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" ] ; then - cp "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" "$TARBALLS" - else - wget --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: - cat "$2.$3" - exit 1 - fi - if [ ! "$2.$3" == "$name.$3" ] ; then - mv "$2.$3" "$name.$3" - fi - mv "$name.$3" "$TARBALLS" - # Save the source archive in the source cache - if [ -d "$SOURCE_LOCAL_CACHE_CFMT" ] ; then - cp "$TARBALLS/$name.$3" "$SOURCE_LOCAL_CACHE_CFMT" - fi - fi - fi - - # Remove build directory (clean build) - if [ $RMDIR_BEFORE_BUILD -eq 1 ] ; then - rm -f -r "$folder" - fi - - # Create build directory and cd - mkdir -p "$folder" - cd "$folder" - - # Extract source archive - if [ "$3" == "zip" ] ; then - log1 unzip "$TARBALLS/$name.$3" - if [ "$strip" == "1" ] ; then - # move subfolders of root folders one level up - find "$(ls)" -mindepth 1 -maxdepth 1 -exec mv -- "{}" . \; - else - echo "Unzip strip count not supported" - exit 1 - fi - else - logn untar tar xvaf "$TARBALLS/$name.$3" --strip $strip - fi - - # Patch if patch file exists - # First try specific patch file name then generic patch file name - # Note: set -o errexit does not work inside a function called in an if, so exit explicity. - if [ -f "$PATCHES/$name.patch" ] ; then - log1 patch -p1 -i "$PATCHES/$name.patch" || exit 1 - elif [ -f "$PATCHES/$basename.patch" ] ; then - log1 patch -p1 -i "$PATCHES/$basename.patch" || exit 1 - fi - - # Go back to base folder - cd .. - - LOGTARGET=$logtargetold -} - -# ------------------------------------------------------------------------------ -# Prepare a module build -# - check if build is already done (name.finished file exists) - if so return 1 -# - create name.started -# - get source archive from $SOURCE_LOCAL_CACHE_CFMT or online using wget -# - create build folder -# - cd to build folder and extract source archive -# - create bin_special subfolder and add it to $PATH -# - remember things for build_post -# -# Parameters -# $1 file server name including protocol prefix -# $2 file name (without extension) -# $3 file extension -# $4 [optional] number of path levels to strip from tar (usually 1) -# $5 [optional] module name (if different from archive) -# $6 [optional] module base name (used as 2nd choice for patches, defaults to $5) -# ------------------------------------------------------------------------------ - -function build_prep { - # Handle optional parameters - if [ "$#" -ge 4 ] ; then - strip=$4 - else - strip=1 - fi - - if [ "$#" -ge 5 ] ; then - name=$5 - else - name=$2 - fi - - if [ "$#" -ge 6 ] ; then - basename=$6 - else - basename=$name - fi - - # Set installer section to not set by default - installersection= - - # Check if build is already done - if [ ! -f "$FLAGFILES/$name.finished" ] ; then - BUILD_PACKAGE_NAME=$name - BUILD_OLDPATH=$PATH - BUILD_OLDPWD=$(pwd) - LOGTARGET=$name - - touch "$FLAGFILES/$name.started" - - get_expand_source_tar "$1" "$2" "$3" "$strip" "$name" "$name" "$basename" - - cd "$name" - - # Create a folder and add it to path, where we can put special binaries - # The path is restored in build_post - mkdir bin_special - PATH=$(pwd)/bin_special:$PATH - - return 0 - else - return 1 - fi -} - -# ------------------------------------------------------------------------------ -# Like build_prep, but gets the data from an entry in ci-basic-overlay.sh -# This assumes the following definitions exist in ci-basic-overlay.sh -# $1_CI_REF -# $1_CI_ARCHIVEURL -# $1_CI_GITURL -# ATTENTION: variables in ci-basic-overlay.sh are loaded by load_overlay_data. -# load_overlay_data is is called at the end of make_coq (even if the build is skipped) -# -# Parameters -# $1 base name of module in ci-basic-overlay.sh, e.g. mathcomp, bignums, ... -# ------------------------------------------------------------------------------ - -function build_prep_overlay { - urlvar=$1_CI_ARCHIVEURL - gitvar=$1_CI_GITURL - refvar=$1_CI_REF - url=${!urlvar} - git=${!gitvar} - ref=${!refvar} - ver=$(git ls-remote "$git" "refs/heads/$ref" | cut -f 1) - if [[ "$ver" == "" ]]; then - # $1_CI_REF must have been a tag or hash, not a branch - ver="$ref" - fi - build_prep "$url" "$ver" tar.gz 1 "$1-$ver" "$1" -} - -# ------------------------------------------------------------------------------ -# Load overlay version variables from ci-basic-overlay.sh -# ------------------------------------------------------------------------------ - -function load_overlay_data { - if [ -n "${GITLAB_CI-}" ]; then - export CI_BRANCH="$CI_COMMIT_REF_NAME" - if [[ ${CI_BRANCH#pr-} =~ ^[0-9]*$ ]]; then - export CI_PULL_REQUEST="${CI_BRANCH#pr-}" - else - export CI_PULL_REQUEST="" - fi - else - export CI_BRANCH="" - export CI_PULL_REQUEST="" - fi - - . /build/ci-basic-overlay.sh -} - -# ------------------------------------------------------------------------------ -# Finalize a module build -# - create name.finished -# - go back to base folder -# ------------------------------------------------------------------------------ - -function build_post { - if [ ! -f "$FLAGFILES/$BUILD_PACKAGE_NAME.finished" ]; then - cd "$BUILD_OLDPWD" - touch "$FLAGFILES/$BUILD_PACKAGE_NAME.finished" - PATH=$BUILD_OLDPATH - LOGTARGET=other - installer_addon_end - fi -} - -# ------------------------------------------------------------------------------ -# Build and install a module using the standard configure/make/make install process -# - prepare build (as above) -# - configure -# - make -# - make install -# - finalize build (as above) -# -# parameters -# $1 file server name including protocol prefix -# $2 file name (without extension) -# $3 file extension -# $4 patch function to call between untar and configure (or true if none) -# $5.. extra configure arguments -# ------------------------------------------------------------------------------ - -function build_conf_make_inst { - if build_prep "$1" "$2" "$3" ; then - $4 - logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXMINGW" "${@:5}" - # shellcheck disable=SC2086 - log1 make $MAKE_OPT - log2 make install - log2 make clean - build_post - fi -} - -# ------------------------------------------------------------------------------ -# Install all files given by a glob pattern to a given folder -# -# parameters -# $1 source path -# $2 pattern (in '') -# $3 target folder -# ------------------------------------------------------------------------------ - -function install_glob { - 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 -# -# parameters -# $1 source path -# $2 pattern (in '') -# $3 target folder -# ------------------------------------------------------------------------------ - -function install_rec { - 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 -# ------------------------------------------------------------------------------ - -function list_files { - if [ ! -e "/build/filelists/$1" ] ; then - ( cd "$PREFIXCOQ" && find . -type f | sort > /build/filelists/"$1" ) - fi -} - -# ------------------------------------------------------------------------------ -# 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 -# $1 name of list A-B (set difference of set A minus set B) -# $2 name of list A -# $3 name of list B -# ------------------------------------------------------------------------------ - -function diff_files { - # See http://www.catonmat.net/blog/set-operations-in-unix-shell/ for file list set operations - comm -23 <(sort "/build/filelists/$2") <(sort "/build/filelists/$3") > "/build/filelists/$1" -} - -# ------------------------------------------------------------------------------ -# Filter a list of files with a regular expression -# -# parameters -# $1 name of output file list -# $2 name of input file list -# $3 name of filter regexp -# ------------------------------------------------------------------------------ - -function filter_files { - grep -E "$3" "/build/filelists/$2" > "/build/filelists/$1" -} - -# ------------------------------------------------------------------------------ -# Convert a file list to NSIS installer format -# -# parameters -# $1 name of file list file (output file is the same with extension .nsi) -# ------------------------------------------------------------------------------ - -function files_to_nsis { - # Split the path in the file list into path and filename and create SetOutPath and File instructions - # Note: File /oname cannot be used, because it does not create the paths as SetOutPath does - # Note: I didn't check if the redundant SetOutPath instructions have a bad impact on installer size or install time - tr '/' '\\' < "/build/filelists/$1" | sed -r 's/^\.(.*)\\([^\\]+)$/SetOutPath $INSTDIR\\\1\nFile ${COQ_SRC_PATH}\\\1\\\2/' > "/build/filelists/$1.nsh" -} - -# ------------------------------------------------------------------------------ -# Create an nsis installer addon section -# -# parameters -# $1 identifier of installer section and base name of file list files -# $2 human readable name of section -# $3 description of section -# $4 flags (space separated list of keywords): off = default off -# -# $1 must be a valid NSIS identifier! -# ------------------------------------------------------------------------------ - -function installer_addon_section { - installersection=$1 - list_files "addon_pre_$installersection" - - echo 'LangString' "DESC_$1" '${LANG_ENGLISH}' "\"$3\"" >> "/build/filelists/addon_strings.nsh" - - echo '!insertmacro MUI_DESCRIPTION_TEXT' '${'"Sec_$1"'}' '$('"DESC_$1"')' >> "/build/filelists/addon_descriptions.nsh" - - local sectionoptions= - if [[ "$4" == *off* ]] ; then sectionoptions+=" /o" ; fi - - echo "Section $sectionoptions \"$2\" Sec_$1" >> "/build/filelists/addon_sections.nsh" - echo 'SetOutPath "$INSTDIR\"' >> "/build/filelists/addon_sections.nsh" - echo '!include "..\..\..\filelists\addon_'"$1"'.nsh"' >> "/build/filelists/addon_sections.nsh" - echo 'SectionEnd' >> "/build/filelists/addon_sections.nsh" -} - -# ------------------------------------------------------------------------------ -# Start an installer addon dependency group -# -# parameters -# $1 identifier of the section which depends on other sections -# The parameters must match the $1 parameter of a installer_addon_section call -# ------------------------------------------------------------------------------ - -dependencysections= - -function installer_addon_dependency_beg { - installer_addon_dependency "$1" - dependencysections="$1 $dependencysections" -} - -# ------------------------------------------------------------------------------ -# End an installer addon dependency group -# ------------------------------------------------------------------------------ - -function installer_addon_dependency_end { - set -- $dependencysections - shift - dependencysections="$*" -} - -# ------------------------------------------------------------------------------ -# Create an nsis installer addon dependency entry -# This needs to be bracketed with installer_addon_dependencies_beg/end -# -# parameters -# $1 identifier of the section on which other sections might depend -# The parameters must match the $1 parameter of a installer_addon_section call -# ------------------------------------------------------------------------------ - -function installer_addon_dependency { - for section in $dependencysections ; do - echo '${CheckSectionDependency} ${Sec_'"$section"'} ${Sec_'"$1"'} '"'$section' '$1'" >> "/build/filelists/addon_dependencies.nsh" - done -} - -# ------------------------------------------------------------------------------ -# Finish an installer section after an addon build -# -# This creates the file list files -# -# parameters: none -# ------------------------------------------------------------------------------ - -function installer_addon_end { - if [ -n "$installersection" ]; then - list_files "addon_post_$installersection" - diff_files "addon_$installersection" "addon_post_$installersection" "addon_pre_$installersection" - files_to_nsis "addon_$installersection" - fi -} - -# ------------------------------------------------------------------------------ -# Set all timeouts in all .v files to 1000 -# Since timeouts can lead to CI failures, this is useful -# -# parameters: none -# ------------------------------------------------------------------------------ - -function coq_set_timeouts_1000 { - find . -type f -name '*.v' -print0 | xargs -0 sed -i 's/timeout\s\+[0-9]\+/timeout 1000/g' -} - -###################### MODULE BUILD FUNCTIONS ##################### - -##### SED ##### - -function make_sed { - if build_prep https://ftp.gnu.org/gnu/sed/ sed-4.2.2 tar.gz ; then - logn configure ./configure - log1 make $MAKE_OPT - log2 make install - log2 make clean - build_post - fi -} - -##### LIBPNG ##### - -function make_libpng { - build_conf_make_inst http://prdownloads.sourceforge.net/libpng libpng-1.6.34 tar.gz true -} - -##### PIXMAN ##### - -function make_pixman { - build_conf_make_inst http://cairographics.org/releases pixman-0.34.0 tar.gz true -} - -##### FREETYPE ##### - -function make_freetype { - build_conf_make_inst http://sourceforge.net/projects/freetype/files/freetype2/2.9.1 freetype-2.9.1 tar.bz2 true -} - -##### EXPAT ##### - -function make_expat { - build_conf_make_inst http://sourceforge.net/projects/expat/files/expat/2.1.0 expat-2.1.0 tar.gz true -} - -##### FONTCONFIG ##### - -function make_fontconfig { - make_freetype - make_expat - # CONFIGURE PARAMETERS - # build/install fails without --disable-docs - build_conf_make_inst http://www.freedesktop.org/software/fontconfig/release fontconfig-2.12.93 tar.gz true --disable-docs -} - -##### ICONV ##### - -function make_libiconv { - build_conf_make_inst http://ftp.gnu.org/pub/gnu/libiconv libiconv-1.15 tar.gz true -} - -##### UNISTRING ##### - -function make_libunistring { - build_conf_make_inst http://ftp.gnu.org/gnu/libunistring libunistring-0.9.5 tar.xz true -} - -##### NCURSES ##### - -function make_ncurses { - # NOTE: ncurses is not required below. This is just kept for documentary purposes in case I need it later. - # - # NOTE: make install fails building the terminfo database because - # : ${TIC_PATH:=unknown} in run_tic.sh - # As a result pkg-config .pc files are not generated - # Also configure of gettext gives two "considers" - # checking where terminfo library functions come from... not found, consider installing GNU ncurses - # checking where termcap library functions come from... not found, consider installing GNU ncurses - # gettext make/make install work anyway - # - # CONFIGURE PARAMETERS - # --enable-term-driver --enable-sp-funcs is required for mingw (see README.MinGW) - # additional changes - # ADD --with-pkg-config - # ADD --enable-pc-files - # ADD --without-manpages - # REM --with-pthread - build_conf_make_inst http://ftp.gnu.org/gnu/ncurses ncurses-5.9 tar.gz true --disable-home-terminfo --enable-reentrant --enable-sp-funcs --enable-term-driver --enable-interop --with-pkg-config --enable-pc-files --without-manpages -} - -##### GETTEXT ##### - -function make_gettext { - # Cygwin packet dependencies: (not 100% sure) libiconv-devel,libunistring-devel,libncurses-devel - # Cygwin packet dependencies for gettext users: (not 100% sure) gettext-devel,libgettextpo-devel - # gettext configure complains that ncurses is also required, but it builds without it - # Ncurses is tricky to install/configure for mingw64, so I dropped ncurses - make_libiconv - make_libunistring - build_conf_make_inst http://ftp.gnu.org/pub/gnu/gettext gettext-0.19 tar.gz true -} - -##### LIBFFI ##### - -function make_libffi { - # NOTE: The official download server is down ftp://sourceware.org/pub/libffi/libffi-3.2.1.tar.gz - build_conf_make_inst http://www.mirrorservice.org/sites/sourceware.org/pub/libffi libffi-3.2.1 tar.gz true -} - -##### LIBEPOXY ##### - -function make_libepoxy { - build_conf_make_inst https://github.com/anholt/libepoxy/releases/download/v1.3.1 libepoxy-1.3.1 tar.bz2 true -} - -##### LIBPCRE ##### - -function make_libpcre { - build_conf_make_inst ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre pcre-8.39 tar.bz2 true -} - -function make_libpcre2 { - build_conf_make_inst ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre pcre2-10.22 tar.bz2 true -} - -##### GLIB ##### - -function make_glib { - # Cygwin packet dependencies: mingw64-x86_64-zlib - make_gettext - make_libffi - make_libpcre - - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/glib/2.57 glib-2.57.1 tar.xz true - -} - -##### ATK ##### - -function make_atk { - make_gettext - make_glib - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/atk/2.30 atk-2.30.0 tar.xz true -} - -##### PIXBUF ##### - -function make_gdk-pixbuf { - # Cygwin packet dependencies: mingw64-x86_64-zlib - make_libpng - make_gettext - make_glib - # CONFIGURE PARAMETERS - # --with-included-loaders=yes statically links the image file format handlers - # This avoids "Cannot open pixbuf loader module file '/usr/x86_64-w64-mingw32/sys-root/mingw/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache': No such file or directory" - build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/gdk-pixbuf/2.38 gdk-pixbuf-2.38.0 tar.xz true --with-included-loaders=yes -} - -##### CAIRO ##### - -function make_cairo { - # Cygwin packet dependencies: mingw64-x86_64-zlib - make_libpng - make_glib - make_pixman - make_fontconfig - build_conf_make_inst http://cairographics.org/releases rcairo-1.16.2 tar.xz true -} - -##### PANGO ##### - -function make_pango { - make_cairo - make_glib - make_fontconfig - build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/pango/1.42 pango-1.42.4 tar.xz true -} - -##### GTK3 ##### - -function make_gtk3 { - - if [ "$GTK_FROM_SOURCES" == "Y" ]; then - - make_glib - make_atk - make_pango - make_gdk-pixbuf - make_cairo - make_libepoxy - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/3.24 gtk+-3.24.5 tar.xz true - fi - - # make all incl. tests and examples runs through fine - # make install fails with issue with - # - # make[5]: Entering directory '/home/soegtrop/GTK/gtk+-3.16.7/demos/gtk-demo' - # test -n "" || ../../gtk/gtk-update-icon-cache --ignore-theme-index --force "/usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor" - # gtk-update-icon-cache.exe: Failed to open file /usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor/.icon-theme.cache : No such file or directory - # Makefile:1373: recipe for target 'install-update-icon-cache' failed - # make[5]: *** [install-update-icon-cache] Error 1 - # make[5]: Leaving directory '/home/soegtrop/GTK/gtk+-3.16.7/demos/gtk-demo' -} - -##### LIBXML2 ##### - -function make_libxml2 { - # Cygwin packet dependencies: libtool automake - # Note: latest release version 2.9.2 fails during configuring lzma, so using 2.9.1 - # Note: python binding requires <sys/select.h> which doesn't exist on cygwin - if build_prep https://git.gnome.org/browse/libxml2/snapshot libxml2-2.9.1 tar.xz ; then - # ./autogen.sh --build=$BUILD --host=$HOST --target=$TARGET --prefix="$PREFIXMINGW" --disable-shared --without-python - # shared library required by gtksourceview - ./autogen.sh --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXMINGW" --without-python - # shellcheck disable=SC2086 - log1 make $MAKE_OPT all - log2 make install - log2 make clean - build_post - fi -} - -##### GTK-SOURCEVIEW3 ##### - -function make_gtk_sourceview3 { - # Cygwin packet dependencies: intltool - # Note: this is always built from sources cause of a bug in the cygwin delivery. - # Just dependencies are only built if we build from sources - if [ "$GTK_FROM_SOURCES" == "Y" ]; then - make_gtk3 - make_libxml2 - fi - build_conf_make_inst https://download.gnome.org/sources/gtksourceview/3.24 gtksourceview-3.24.11 tar.xz make_arch_pkg_config -} - -##### LN replacement ##### - -# Note: this does support symlinks, but symlinks require special user rights on Windows. -# ocamlbuild uses symlinks to link the executables in the build folder to the base folder. -# For this purpose hard links are better. - -function make_ln { - if [ ! -f $FLAGFILES/myln.finished ] ; then - touch $FLAGFILES/myln.started - mkdir -p myln - ( cd myln - cp $PATCHES/ln.c . - "$TARGET_ARCH-gcc" -DUNICODE -D_UNICODE -DIGNORE_SYMBOLIC -mconsole -o ln.exe ln.c - install -D ln.exe "$PREFIXCOQ/bin/ln.exe" - ) - touch $FLAGFILES/myln.finished - fi -} - -##### ARCH-pkg-config replacement ##### - -# cygwin replaced ARCH-pkg-config with a shell script, which doesn't work e.g. for dune on Windows. -# This builds a binary replacement for the shell script and puts it into the bin_special folder. -# There is no global installation since it is module specific what pkg-config is needed under what name. - -function make_arch_pkg_config { - gcc -DARCH="$TARGET_ARCH" -o bin_special/pkg-config.exe $PATCHES/pkg-config.c -} - -##### OCAML ##### - -function make_ocaml { - if build_prep https://github.com/ocaml/ocaml/archive 4.10.2 tar.gz 1 ocaml-4.10.2 ; then - # see https://github.com/ocaml/ocaml/blob/4.08/README.win32.adoc - - # get flexdll sources into folder ./flexdll - get_expand_source_tar https://github.com/alainfrisch/flexdll/archive 0.37 tar.gz 1 flexdll-0.37 flexdll - - # We don't want to mess up Coq's directory structure so put the OCaml library in a separate folder - logn configure ./configure --build=i686-pc-cygwin --host="$TARGET_ARCH" --prefix="$PREFIXOCAML" --libdir="$PREFIXOCAML/libocaml" - - log2 make flexdll $MAKE_OPT - # Note the next command might change after 4.09.x to just make - # see https://github.com/ocaml/ocaml/blob/4.09/README.win32.adoc - # compare to https://github.com/ocaml/ocaml/blob/4.10/README.win32.adoc - log2 make world.opt $MAKE_OPT - log2 make flexlink.opt $MAKE_OPT - log2 make install $MAKE_OPT - - # Move license files and other into into special folder - if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - mkdir -p "$PREFIXOCAML/license_readme/ocaml" - # 4.01 installs these files, 4.02 doesn't. So delete them and copy them from the sources. - rm -f ./*.txt - cp LICENSE "$PREFIXOCAML/license_readme/ocaml/License.txt" - cp INSTALL.adoc "$PREFIXOCAML/license_readme/ocaml/Install.txt" - cp README.adoc "$PREFIXOCAML/license_readme/ocaml/ReadMe.txt" - cp README.win32.adoc "$PREFIXOCAML/license_readme/ocaml/ReadMeWin32.txt" - cp VERSION "$PREFIXOCAML/license_readme/ocaml/Version.txt" - cp Changes "$PREFIXOCAML/license_readme/ocaml/Changes.txt" - fi - - # Since 4.07 this library is part of ocaml - mkdir -p "$PREFIXOCAML/libocaml/site-lib/seq/" - cat > "$PREFIXOCAML/libocaml/site-lib/seq/META" <<EOT -name="seq" -version="[distributed with OCaml 4.07 or above]" -description="dummy backward-compatibility package for iterators" -requires="" -EOT - - build_post - fi -} - -##### OCAML EXTRA TOOLS ##### - -function make_ocaml_tools { - make_findlib -} - -##### OCAML EXTRA LIBRARIES ##### - -function make_ocaml_libs { - make_num - make_zarith - make_findlib - make_lablgtk -} - -##### Ocaml num library ##### -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 - log2 make all - # log2 make test - log2 make install - log2 make clean - build_post - fi -} - -function make_zarith { - make_ocaml - if build_prep https://github.com/ocaml/Zarith/archive release-1.10 tar.gz 1 zarith-1.10; then - logn configure ./configure - log1 make - log2 make install - build_post - fi -} - -##### OCAMLBUILD ##### - -function make_ocamlbuild { - make_ocaml - if build_prep https://github.com/ocaml/ocamlbuild/archive 0.14.0 tar.gz 1 ocamlbuild-0.14.0; then - log2 make configure OCAML_NATIVE=true OCAMLBUILD_PREFIX=$PREFIXOCAML OCAMLBUILD_BINDIR=$PREFIXOCAML/bin OCAMLBUILD_LIBDIR=$PREFIXOCAML/lib - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -##### FINDLIB Ocaml library manager ##### - -function make_findlib { - make_ocaml - make_ocamlbuild - if build_prep http://download.camlcity.org/download/ findlib-1.8.1 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 - log2 make all - 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 -} - -##### Dune build system ##### - -function make_dune { - make_ocaml - - if build_prep https://github.com/ocaml/dune/archive/ 2.0.0 tar.gz 1 dune-2.0.0 ; then - - log2 make release - log2 make install - - # Dune support libs, we don't install glob and action-plugin as - # they are not needed by Coq - logn dune-private-build dune build -p dune-private-libs @install - logn dune-private-install dune install dune-private-libs - - logn dune-configurator-build dune build -p dune-configurator @install - logn dune-configurator-install dune install dune-configurator - - logn dune-build-info dune build -p dune-build-info @install - logn dune-build-info dune install dune-build-info - - build_post - fi -} - -##### MENHIR Ocaml Parser Generator ##### - -function make_menhir { - make_ocaml - make_findlib - make_ocamlbuild - if build_prep https://gitlab.inria.fr/fpottier/menhir/-/archive/20200525 menhir-20200525 tar.gz 1 ; then - # ToDo: don't know if this is the intended / most reliable to do it, but it works - log2 dune build @install - log2 dune install menhir menhirSdk menhirLib - build_post - fi -} - -##### CAMLP5 Ocaml Preprocessor ##### - -function make_camlp5 { - make_ocaml - make_findlib - - if build_prep https://github.com/camlp5/camlp5/archive rel711 tar.gz 1 camlp5-rel711; then - logn configure ./configure - # Somehow my virus scanner has the boot.new/SAVED directory locked after the move for a second => repeat until success - sed -i 's/mv boot.new boot/until mv boot.new boot; do sleep 1; done/' Makefile - # shellcheck disable=SC2086 - log1 make world.opt $MAKE_OPT - log2 make install - cp lib/*.a "$PREFIXOCAML/libocaml/camlp5/" - log2 make clean - # For some reason META is not built / copied, but it is required - log2 make -C etc META - mkdir -p "$PREFIXOCAML/libocaml/site-lib/camlp5/" - cp etc/META "$PREFIXOCAML/libocaml/site-lib/camlp5/" - log2 make clean - build_post - fi -} - -##### LABLGTK Ocaml GTK binding ##### - -# Note: when rebuilding lablgtk by deleting the .finished file, -# also delete <root>\usr\x86_64-w64-mingw32\sys-root\mingw\lib\site-lib -# Otherwise make install fails - -function make_ocaml_cairo2 { - if build_prep https://github.com/Chris00/ocaml-cairo/archive 0.6 tar.gz 1 ocaml_cairo2-0.6; then - make_arch_pkg_config - - log2 dune build cairo2.install - log2 dune install cairo2 - # See https://github.com/ocaml/dune/issues/2921 - # log2 dune clean - build_post - - fi -} - -function make_lablgtk { - make_ocaml - make_findlib - make_dune - make_gtk3 - make_gtk_sourceview3 - make_ocaml_cairo2 - - if build_prep https://github.com/garrigue/lablgtk/archive 3.1.1 tar.gz 1 lablgtk-3.1.1 ; then - make_arch_pkg_config - - # lablgtk3 includes more packages that are not relevant for Coq, - # such as gtkspell - log2 dune build -p lablgtk3 - log2 dune install lablgtk3 - - log2 dune build -p lablgtk3-sourceview3 - log2 dune install lablgtk3-sourceview3 - - # See https://github.com/ocaml/dune/issues/2921 - # log2 dune clean - build_post - fi -} - -##### Elpi ##### - -function make_seq { - make_ocaml - # since 4.07 this package is part of ocaml - -} - -function make_re { - make_ocaml - make_dune - make_seq - - if build_prep https://github.com/ocaml/ocaml-re/archive 1.9.0 tar.gz 1 ocaml-re; then - - log2 dune build -p re - log2 dune install re - - build_post - fi - -} - -function make_elpi { - make_ocaml - make_findlib - make_camlp5 - make_dune - make_re - - if build_prep https://github.com/LPCIC/elpi/archive v1.12.0 tar.gz 1 elpi; then - - log2 dune build -p elpi - log2 dune install elpi - - build_post - - fi - -} - -##### COQ ##### - -# Copy one DLLfrom cygwin MINGW packages to Coq install folder - -function copy_coq_dll { - if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - cp "$PREFIXMINGW/bin/$1" "$PREFIXCOQ/bin/$1" - fi -} - -# Copy required DLLs from cygwin MINGW packages to Coq install folder - -function copy_coq_dlls { - # HOW TO CREATE THE DLL LIST - # With the list empty, after the build/install is finished, open coqide in dependency walker. - # See http://www.dependencywalker.com/ - # Make sure to use the 32 bit / 64 bit version of depends matching the target architecture. - # Select all missing DLLs from the module list, right click "copy filenames" - # Delay loaded DLLs from Windows can be ignored (hour-glass icon at begin of line) - # Do this recursively until there are no further missing DLLs (File close + reopen) - # For running this quickly, just do "cd coq-<ver> ; copy_coq_dlls ; cd .." at the end of this script. - # Do the same for coqc and ocamlc (usually doesn't result in additional files) - - copy_coq_dll LIBCAIRO-2.DLL - copy_coq_dll LIBFONTCONFIG-1.DLL - copy_coq_dll LIBFREETYPE-6.DLL - copy_coq_dll LIBGDK-3-0.DLL - copy_coq_dll LIBGDK_PIXBUF-2.0-0.DLL - copy_coq_dll LIBGLIB-2.0-0.DLL - copy_coq_dll LIBGOBJECT-2.0-0.DLL - copy_coq_dll LIBGTK-3-0.DLL - copy_coq_dll LIBGTKSOURCEVIEW-3.0-1.DLL - copy_coq_dll LIBPANGO-1.0-0.DLL - copy_coq_dll LIBATK-1.0-0.DLL - copy_coq_dll LIBBZ2-1.DLL - copy_coq_dll LIBCAIRO-GOBJECT-2.DLL - copy_coq_dll LIBEPOXY-0.DLL - copy_coq_dll LIBEXPAT-1.DLL - copy_coq_dll LIBFFI-6.DLL - copy_coq_dll LIBGIO-2.0-0.DLL - copy_coq_dll LIBGMODULE-2.0-0.DLL - copy_coq_dll LIBINTL-8.DLL - copy_coq_dll LIBPANGOCAIRO-1.0-0.DLL - copy_coq_dll LIBPANGOWIN32-1.0-0.DLL - copy_coq_dll LIBPCRE-1.DLL - copy_coq_dll LIBPIXMAN-1-0.DLL - copy_coq_dll LIBPNG16-16.DLL - copy_coq_dll LIBXML2-2.DLL - copy_coq_dll ZLIB1.DLL - copy_coq_dll ICONV.DLL - copy_coq_dll LIBLZMA-5.DLL - copy_coq_dll LIBPANGOFT2-1.0-0.DLL - copy_coq_dll LIBHARFBUZZ-0.DLL - - # Depends on if GTK is built from sources - if [ "$GTK_FROM_SOURCES" == "Y" ]; then - echo "Building GTK from sources is currently not supported" - exit 1 - fi; - - # Architecture dependent files - case $ARCH in - x86_64) copy_coq_dll LIBGCC_S_SEH-1.DLL ;; - i686) copy_coq_dll LIBGCC_S_SJLJ-1.DLL ;; - *) false ;; - esac - - # Win pthread version change - copy_coq_dll LIBWINPTHREAD-1.DLL -} - -function copy_coq_objects { - # copy objects only from folders which exist in the target lib directory - find . -type d | while read -r FOLDER ; do - 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 -} - -# Copy required GTK config and support files -# This must be called from inside the coq build folder! - -function copy_coq_gtk { - - glib-compile-schemas $PREFIXMINGW/share/glib-2.0/schemas/ - echo 'gtk-theme-name = "Default"' > "$PREFIXMINGW/etc/gtk-3.0/gtkrc" - - if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - install_glob "$PREFIXMINGW/etc/gtk-3.0" '*' "$PREFIXCOQ/gtk-3.0" - install -D -T "$PREFIXMINGW/share/glib-2.0/schemas/gschemas.compiled" "$PREFIXCOQ/share/glib-2.0/schemas/gschemas.compiled" - - install_glob "$PREFIXMINGW/share/gtksourceview-3.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-3.0/language-specs" - install -D -T "ide/coqide/coq.lang" "$PREFIXCOQ/share/gtksourceview-3.0/language-specs/coq.lang" - install -D -T "ide/coqide/coq-ssreflect.lang" "$PREFIXCOQ/share/gtksourceview-3.0/language-specs/coq-ssreflect.lang" - - install_glob "$PREFIXMINGW/share/gtksourceview-3.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-3.0/styles" - install -D -T "ide/coqide/coq_style.xml" "$PREFIXCOQ/share/gtksourceview-3.0/styles/coq_style.xml" - - install_rec "$PREFIXMINGW/share/themes" '*' "$PREFIXCOQ/share/themes" - - FOLDERS="" - # The sizes include all default sizes given in index.theme - # The types used haven been recorded with ProcMon in an installation with all icons present - for SIZE in 16x16 22x22 32x32 48x48; do - for TYPE in \ - actions/bookmark actions/document devices/drive actions/format-text actions/go actions/list \ - actions/media actions/pan actions/process actions/system actions/window \ - mimetypes/text places/folder places/user status/dialog - do - CLASS=$(dirname $TYPE) - ICON=$(basename $TYPE) - if [[ ! "$FOLDERS" =~ "$SIZE/$CLASS" ]] ;then - FOLDERS="$FOLDERS$SIZE/$CLASS," - fi - install_rec "/usr/share/icons/Adwaita/$SIZE/$CLASS" "$ICON*" "$PREFIXCOQ/share/icons/Adwaita/$SIZE/$CLASS" - done - done - echo Folders=$FOLDERS - install -D -T "/usr/share/icons/Adwaita/index.theme" "$PREFIXCOQ/share/icons/Adwaita/index.theme" - sed -i "s|^Directories=.*|Directories=$FOLDERS|" "$PREFIXCOQ/share/icons/Adwaita/index.theme" - gtk-update-icon-cache -f "$PREFIXCOQ/share/icons/Adwaita/" - - # This below item look like a bug in make install - # if [ -d "$PREFIXCOQ/share/coq/" ] ; then - # COQSHARE="$PREFIXCOQ/share/coq/" - # else - # COQSHARE="$PREFIXCOQ/share/" - # fi - - # mkdir -p "$PREFIXCOQ/ide/coqide" - # mv "$COQSHARE"*.png "$PREFIXCOQ/ide/coqide" - # rmdir "$PREFIXCOQ/share/coq" || true - fi -} - -# Copy license and other info files - -function copy_coq_license { - if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - install -D doc/LICENSE "$PREFIXCOQ/license_readme/coq/LicenseDoc.txt" - install -D LICENSE "$PREFIXCOQ/license_readme/coq/License.txt" - install -D plugins/micromega/LICENSE.sos "$PREFIXCOQ/license_readme/coq/LicenseMicromega.txt" - # FIXME: this is not the micromega license - # It only applies to code that was copied into one single file! - install -D README.md "$PREFIXCOQ/license_readme/coq/ReadMe.md" - install -D INSTALL.md "$PREFIXCOQ/license_readme/coq/Install.txt" - install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" || true - fi -} - -# Main function for creating Coq - -function make_coq { - make_ocaml - make_num - make_findlib - make_lablgtk - if - case $COQ_VERSION in - # e.g. git-v8.6 => download from https://github.com/coq/coq/archive/v8.6.zip - # e.g. git-trunk => download from https://github.com/coq/coq/archive/trunk.zip - git-*) - COQ_BUILD_PATH=/build/coq-${COQ_VERSION} - build_prep https://github.com/coq/coq/archive "${COQ_VERSION##git-}" zip 1 "coq-${COQ_VERSION}" - ;; - - # e.g. /cygdrive/d/coqgit - /*) - # Todo: --exclude-vcs-ignores doesn't work because tools/coqdoc/coqdoc.sty is excluded => fix .gitignore - # But this is not a big deal, only 2 files are removed with --exclude-vcs-ignores from a fresch clone - COQ_BUILD_PATH=/build/coq-local - tar -zcf $TARBALLS/coq-local.tar.gz --exclude-vcs -C "${COQ_VERSION%/*}" "${COQ_VERSION##*/}" - build_prep NEVER-DOWNLOADED coq-local tar.gz - ;; - - # e.g. 8.6 => https://coq.inria.fr/distrib/8.6/files/coq-8.6.tar.gz - *) - COQ_BUILD_PATH=/build/coq-$COQ_VERSION - build_prep "https://coq.inria.fr/distrib/V$COQ_VERSION/files" "coq-$COQ_VERSION" tar.gz - ;; - esac - then - if [ "$INSTALLMODE" == "relocatable" ]; then - # HACK: for relocatable builds, first configure with ./, then build but before install reconfigure with the real target path - logn configure ./configure -with-doc no -prefix ./ -libdir ./lib/coq -mandir ./man - elif [ "$INSTALLMODE" == "absolute" ]; then - logn configure ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib/coq" -mandir "$PREFIXCOQ/man" - else - logn configure ./configure -with-doc no -prefix "$PREFIXCOQ" - fi - - # 8.4x doesn't support parallel make - if [[ $COQ_VERSION == 8.4* ]] ; then - log1 make - else - # shellcheck disable=SC2086 - log1 make $MAKE_OPT - fi - - if [ "$INSTALLMODE" == "relocatable" ]; then - logn reconfigure ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib/coq" -mandir "$PREFIXCOQ/man" - fi - - log2 make install - log1 copy_coq_dlls - log1 copy_coq_gtk - - if [ "$INSTALLOCAML" == "Y" ]; then - copy_coq_objects - fi - - 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 - # 2.) clean of test suites fails with "cannot run complexity tests (no bogomips found)" - # make clean - - # Copy these files somewhere the plugin builds can find them - #logn copy-basic-overlays cp dev/ci/ci-basic-overlay.sh /build/ - - build_post - fi - - #load_overlay_data -} - -##### GNU Make for MinGW ##### - -function make_mingw_make { - if build_prep http://ftp.gnu.org/gnu/make make-4.2 tar.bz2 ; then - # The config.h.win32 file is fine - don't edit it - # We need to copy the mingw gcc here as "gcc" - then the batch file will use it - cp "/usr/bin/${ARCH}-w64-mingw32-gcc-6.4.0.exe" ./gcc.exe - # By some magic cygwin bash can run batch files - logn build ./build_w32.bat gcc - # Copy make to Coq folder - cp GccRel/gnumake.exe "$PREFIXCOQ/bin/make.exe" - build_post - fi -} - -##### GNU binutils for native OCaml ##### - -function make_binutils { - if build_prep http://ftp.gnu.org/gnu/binutils binutils-2.27 tar.gz ; then - logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXCOQ" --program-prefix="$TARGET-" - # shellcheck disable=SC2086 - log1 make $MAKE_OPT - log2 make install - # log2 make clean - build_post - fi -} - -##### GNU GCC for native OCaml ##### - -function make_gcc { - # Note: the bz2 file is smaller, but decompressing bz2 really takes ages - if build_prep ftp://ftp.fu-berlin.de/unix/languages/gcc/releases/gcc-5.4.0 gcc-5.4.0 tar.gz ; then - # This is equivalent to "contrib/download_prerequisites" but uses caching - # Update versions when updating gcc version - get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure mpfr-2.4.2 tar.bz2 1 mpfr-2.4.2 mpfr - get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure gmp-4.3.2 tar.bz2 1 gmp-4.3.2 gmp - get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure mpc-0.8.1 tar.gz 1 mpc-0.8.1 mpc - get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure isl-0.14 tar.bz2 1 isl-0.14 isl - - # For whatever reason gcc needs this (although it never puts anything into it) - # Error: "The directory that should contain system headers does not exist:" - # mkdir -p /mingw/include without --with-sysroot - mkdir -p "$PREFIXCOQ/mingw/include" - - # See https://gcc.gnu.org/install/configure.html - logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" \ - --prefix="$PREFIXCOQ" --program-prefix="$TARGET-" --disable-win32-registry --with-sysroot="$PREFIXCOQ" \ - --enable-languages=c --disable-nls \ - --disable-libsanitizer --disable-libssp --disable-libquadmath --disable-libgomp --disable-libvtv --disable-lto - # --disable-decimal-float seems to be required - # --with-sysroot="$PREFIXMINGW" results in configure error that this is not an absolute path - # shellcheck disable=SC2086 - log1 make $MAKE_OPT - log2 make install - # log2 make clean - build_post - fi -} - -##### Get sources for Cygwin MinGW packages ##### - -function get_cygwin_mingw_sources { - if [ ! -f $FLAGFILES/cygwin_mingw_sources.finished ] ; then - touch $FLAGFILES/cygwin_mingw_sources.started - - # Find all installed files with mingw in the name and download the corresponding source code file from cygwin - # Steps: - # grep /etc/setup/installed.db for mingw => mingw64-x86_64-gcc-g++ mingw64-x86_64-gcc-g++-5.4.0-2.tar.bz2 1 - # remove archive ending and trailing number => mingw64-x86_64-gcc-g++ mingw64-x86_64-gcc-g++-5.4.0-2 - # replace space with / => ${ARCHIVE} = mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g++-5.4.0-2 - # escape + signs using ${var//pattern/replace} => ${ARCHIVEESC} = mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g\+\+-5.4.0-2 - # grep cygwin setup.ini for installed line + next line (the -A 1 option includes and "after context" of 1 line) - # Note that the folders of the installed binaries and source are different. So we cannot grep just for the source line. - # We could strip off the path and just grep for the file, though. - # => install: x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g++-5.4.0-2.tar.xz 10163848 2f8cb7ba3e16ac8ce0455af01de490ded09061b1b06a9a8e367426635b5a33ce230e04005f059d4ea7b52580757da1f6d5bae88eba6b9da76d1bd95e8844b705 - # source: x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-5.4.0-2-src.tar.xz 95565368 03f22997b7173b243fff65ea46a39613a2e4e75fc7e6cf0fa73b7bcb86071e15ba6d0ca29d330c047fb556a5e684cad57cd2f5adb6e794249e4b01fe27f92c95 - # Take the 2nd field of the last line => ${SOURCE} = x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-5.4.0-2-src.tar.xz - # Remove that path part => ${SOURCEFILE} = mingw64-x86_64-gcc-5.4.0-2-src.tar.xz - - grep "mingw" /etc/setup/installed.db | sed 's/\.tar\.bz2 [0-1]$//' | sed 's/ /\//' | while read -r ARCHIVE ; do - local ARCHIVEESC=${ARCHIVE//+/\\+} - local SOURCE - SOURCE=$(grep -E -A 1 "install: ($CYGWINARCH|noarch)/release/[-+_/a-z0-9]*$ARCHIVEESC" $TARBALLS/setup.ini | tail -1 | cut -d " " -f 2) - local SOURCEFILE=${SOURCE##*/} - - # Get the source file (either from the source cache or online) - if [ ! -f "$TARBALLS/$SOURCEFILE" ] ; then - if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" ] ; then - cp "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" $TARBALLS - else - wget --progress=dot:giga "$CYGWIN_REPOSITORY/$SOURCE" - mv "$SOURCEFILE" "$TARBALLS" - # Save the source archive in the source cache - if [ -d "$SOURCE_LOCAL_CACHE_CFMT" ] ; then - cp "$TARBALLS/$SOURCEFILE" "$SOURCE_LOCAL_CACHE_CFMT" - fi - fi - fi - - done - - touch $FLAGFILES/cygwin_mingw_sources.finished - fi -} - -##### Coq Windows Installer ##### - -function make_coq_installer { - make_coq - get_cygwin_mingw_sources - - # Prepare the file lists for the installer. We created to file list dumps of the target folder during the build: - # ocaml: ocaml + menhir + camlp5 + findlib - # ocaml_coq: as above + coq - # ocaml_coq_addons: as above + lib/user-contrib/* - - # Create coq file list as ocaml_coq / ocaml - diff_files coq ocaml_coq ocaml - - # Filter out object files - filter_files coq_objects coq '\.(cmxa|cmi|cma|cmo|a|o)$' - - # Filter out plugin object files - filter_files coq_objects_plugins coq_objects '/lib/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 - - # Addons (TODO: including objects that could go to the plugindev thing, but - # then one would have to make that package depend on this one, so not - # implemented yet) - diff_files coq_addons ocaml_coq_addons ocaml_coq - - # Coq files, except objects needed only for plugin development - diff_files coq_base coq coq_plugindev - - # Convert section files to NSIS format - files_to_nsis coq_base - files_to_nsis coq_addons - files_to_nsis coq_plugindev - files_to_nsis ocaml - - # Get and extract NSIS Binaries - if build_prep http://downloads.sourceforge.net/project/nsis/NSIS%202/2.51 nsis-2.51 zip ; then - NSIS=$(pwd)/makensis.exe - chmod u+x "$NSIS" - # Change to Coq folder - cd "$COQ_BUILD_PATH" - # Copy patched nsi file - cp ../patches/coq_new.nsi dev/nsis - cp ../patches/StrRep.nsh dev/nsis - cp ../patches/ReplaceInFile.nsh dev/nsis - VERSION=$(grep '^VERSION=' config/Makefile | cut -d = -f 2 | tr -d '\r') - cd dev/nsis - logn nsis-installer "$NSIS" -DVERSION="$VERSION" -DARCH="$ARCH" -DCOQ_SRC_PATH="$PREFIXCOQ" -DCOQ_ICON=..\\..\\ide\\coqide\\coq.ico -DCOQ_ADDONS="$COQ_ADDONS" coq_new.nsi - - build_post - fi -} - -###################### ADDON COQ LIBRARIES / PLUGINS / TOOLS ##################### - -# The bignums library -# Provides BigN, BigZ, BigQ that used to be part of Coq standard library - -function make_addon_bignums { - installer_addon_dependency bignums - if build_prep_overlay bignums; then - installer_addon_section bignums "Bignums" "Coq library for fast arbitrary size numbers" "" - # To make command lines shorter :-( - echo 'COQ_SRC_SUBDIRS:=$(filter-out plugins/%,$(COQ_SRC_SUBDIRS)) plugins/syntax' >> Makefile.coq.local - log1 make $MAKE_OPT all - log2 make install - build_post - fi -} - -# Equations plugin -# A function definition plugin - -function make_addon_equations { - installer_addon_dependency equations - if build_prep_overlay equations; then - installer_addon_section equations "Equations" "Coq plugin for defining functions by equations" "" - # Note: PATH is automatically saved/restored by build_prep / build_post - PATH=$COQBIN:$PATH - logn coq_makefile ${COQBIN}coq_makefile -f _CoqProject -o Makefile - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# mathcomp - ssreflect and mathematical components library - -function make_addon_mathcomp { - installer_addon_dependency mathcomp - if build_prep_overlay mathcomp; then - installer_addon_section mathcomp "Math-Components" "Coq library with mathematical components" "" - cd mathcomp - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# ssreflect part of mathcomp - -function make_addon_ssreflect { - # if mathcomp addon is requested, build this instead - if [[ "$COQ_ADDONS" == *mathcomp* ]]; then - make_addon_mathcomp - else - # Note: since either mathcomp or ssreflect is defined, it is fine to name both mathcomp - installer_addon_dependency ssreflect - if build_prep_overlay mathcomp; then - installer_addon_section ssreflect "SSReflect" "Coq support library for small scale reflection plugin" "" - cd mathcomp - logn make-makefile make Makefile.coq - logn make-ssreflect make $MAKE_OPT -f Makefile.coq ssreflect/all_ssreflect.vo - logn make-install make -f Makefile.coq install - build_post - fi - fi -} - -# UniCoq plugin -# An alternative unification algorithm -function make_addon_unicoq { - installer_addon_dependency unicoq - if build_prep_overlay unicoq; then - installer_addon_section unicoq "Unicoq" "Coq plugin for an enhanced unification algorithm" "" - log1 coq_makefile -f Make -o Makefile - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# Mtac2 plugin -# An alternative typed tactic language -function make_addon_mtac2 { - installer_addon_dependency_beg mtac2 - make_addon_unicoq - installer_addon_dependency_end - if build_prep_overlay mtac2; then - installer_addon_section mtac2 "Mtac-2" "Coq plugin for a typed tactic language for Coq." "" - log1 coq_makefile -f _CoqProject -o Makefile - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# Menhir parser generator - -function make_addon_menhir { - make_menhir - # If COQ and OCaml are installed to the same folder, there is nothing to do - installer_addon_dependency menhir - if [ "$PREFIXOCAML" != "$PREFIXCOQ" ] ; then - # Just install menhir files required for COQ to COQ target folder - if [ ! -f "$FLAGFILES/menhir-addon.finished" ] ; then - installer_addon_section menhir "Menhir" "Menhir parser generator windows executable and libraries" "" - LOGTARGET=menhir-addon - touch "$FLAGFILES/menhir-addon.started" - # Menhir executable - install_glob "$PREFIXOCAML/bin" 'menhir.exe' "$PREFIXCOQ/bin/" - # Menhir PDF doc - install_glob "$PREFIXOCAML/doc/menhir/" '*.pdf' "$PREFIXCOQ/doc/menhir/" - touch "$FLAGFILES/menhir-addon.finished" - LOGTARGET=other - installer_addon_end - fi - fi -} - -# COQ library for Menhir - -function make_addon_menhirlib { - installer_addon_dependency menhirlib - if build_prep_overlay menhirlib; then - installer_addon_section menhirlib "Menhirlib" "Coq support library for using Menhir generated parsers in Coq" "" - # The supplied makefiles don't work in any way on cygwin - # ToDo: dune also doesn't seem to work for the coq files - cd coq-menhirlib/src - echo -R . MenhirLib > _CoqProject - ls -1 *.v >> _CoqProject - log1 coq_makefile -f _CoqProject -o Makefile.coq - log1 make -f Makefile.coq $MAKE_OPT all - logn make-install make -f Makefile.coq install - build_post - fi -} - -# CompCert - -function make_addon_compcert { - installer_addon_dependency_beg compcert - make_menhir - make_addon_menhirlib - installer_addon_dependency_end - if build_prep_overlay compcert; then - installer_addon_section compcert "CompCert" "ATTENTION: THIS IS NOT OPEN SOURCE! CompCert verified C compiler and Clightgen (required for using VST for your own code)" "off" - logn configure ./configure -ignore-coq-version -clightgen -prefix "$PREFIXCOQ" -coqdevdir "$PREFIXCOQ/lib/coq/user-contrib/compcert" x86_32-cygwin -use-external-MenhirLib -use-external-Flocq - log1 make $MAKE_OPT - log2 make install - logn install-license-1 install -D -T "LICENSE" "$PREFIXCOQ/lib/coq/user-contrib/compcert/LICENSE" - logn install-license-2 install -D -T "LICENSE" "$PREFIXCOQ/lib/compcert/LICENSE" - build_post - fi -} - -# Princeton VST - -function install_addon_vst { - VSTDEST="$PREFIXCOQ/lib/coq/user-contrib/VST" - - # Install VST .v, .vo, .c and .h files - install_rec compcert '*.v' "$VSTDEST/compcert/" - install_rec compcert '*.vo' "$VSTDEST/compcert/" - install_glob "msl" '*.v' "$VSTDEST/msl/" - install_glob "msl" '*.vo' "$VSTDEST/msl/" - install_glob "sepcomp" '*.v' "$VSTDEST/sepcomp/" - install_glob "sepcomp" '*.vo' "$VSTDEST/sepcomp/" - install_glob "floyd" '*.v' "$VSTDEST/floyd/" - install_glob "floyd" '*.vo' "$VSTDEST/floyd/" - install_glob "progs" '*.v' "$VSTDEST/progs/" - install_glob "progs" '*.c' "$VSTDEST/progs/" - install_glob "progs" '*.h' "$VSTDEST/progs/" - install_glob "veric" '*.v' "$VSTDEST/veric/" - install_glob "veric" '*.vo' "$VSTDEST/veric/" - - # Install VST documentation files - install_glob "." 'LICENSE' "$VSTDEST" - install_glob "." '*.md' "$VSTDEST" - install_glob "compcert" '*' "$VSTDEST/compcert" - install_glob "doc" '*.pdf' "$VSTDEST/doc" - - # Install VST _CoqProject files - install_glob "." '_CoqProject*' "$VSTDEST" - install_glob "." '_CoqProject-export' "$VSTDEST/progs" -} - -function vst_patch_compcert_refs { - find . -type f -name '*.v' -print0 | xargs -0 sed -E -i \ - -e 's/(Require\s+(Import\s+|Export\s+)*)compcert\./\1VST.compcert./g' \ - -e 's/From compcert Require/From VST.compcert Require/g' -} - -function make_addon_vst { - installer_addon_dependency vst - if build_prep_overlay vst; then - installer_addon_section vst "VST" "ATTENTION: SOME INCLUDED COMPCERT PARTS ARE NOT OPEN SOURCE! Verified Software Toolchain for verifying C code" "off" - # log1 coq_set_timeouts_1000 - log1 vst_patch_compcert_refs - # The usage of the shell variable ARCH in VST collides with the usage in this shellscript - logn make env -u ARCH make IGNORECOQVERSION=true $MAKE_OPT - log1 install_addon_vst - build_post - fi -} - -# coquelicot Real analysis - -function make_addon_coquelicot { - installer_addon_dependency_beg coquelicot - make_addon_ssreflect - installer_addon_dependency_end - if build_prep_overlay coquelicot; then - installer_addon_section coquelicot "Coquelicot" "Coq library for real analysis" "" - log1 autoreconf -i -s - logn configure ./configure --libdir="$PREFIXCOQ/lib/coq/user-contrib/Coquelicot" - logn remake ./remake - logn remake-install ./remake install - build_post - fi -} - -# AAC associative / commutative rewriting - -function make_addon_aactactics { - installer_addon_dependency aac - if build_prep_overlay aac_tactics; then - installer_addon_section aac "AAC" "Coq plugin for extensible associative and commutative rewriting" "" - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# extlib - -function make_addon_extlib { - installer_addon_dependency extlib - if build_prep_overlay ext_lib; then - installer_addon_section extlib "Ext-Lib" "Coq library with many reusable general purpose components" "" - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# SimpleIO - -function make_addon_simple_io { - installer_addon_dependency simpleIO - if build_prep_overlay simple_io; then - installer_addon_section simpleIO "SimpleIO" "Coq plugin for reading and writing files directly from Coq code" "" - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# Quickchick Randomized Property-Based Testing Plugin for Coq - -function make_addon_quickchick { - installer_addon_dependency_beg quickchick - make_addon_ssreflect - make_addon_extlib - make_addon_simple_io - make_ocamlbuild - installer_addon_dependency_end - if build_prep_overlay quickchick; then - installer_addon_section quickchick "QuickChick" "Coq plugin for randomized testing and counter example search" "" - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# Flocq: Floating point library - -function make_addon_flocq { - if build_prep_overlay flocq; then - installer_addon_section flocq "Flocq" "Coq library for floating point arithmetic" "" - log1 autoreconf - logn configure ./configure - logn remake ./remake --jobs=$MAKE_THREADS - logn install ./remake install - build_post - fi -} - -# Coq-Interval: interval arithmetic and inequality proofs - -function make_addon_interval { - installer_addon_dependency_beg interval - make_addon_mathcomp - make_addon_coquelicot - make_addon_bignums - make_addon_flocq - installer_addon_dependency_end - if build_prep_overlay interval; then - installer_addon_section interval "Interval" "Coq library and tactic for proving real inequalities" "" - log1 autoreconf - logn configure ./configure - logn remake ./remake --jobs=$MAKE_THREADS - logn install ./remake install - build_post - fi -} - -# Gappa: Automatic generation of arithmetic proofs (mostly on limited precision arithmetic) - -function install_boost { - # The extra tar parameter extracts only the boost headers, not the boost library source code (which is huge and takes a long time) - if build_prep https://dl.bintray.com/boostorg/release/1.69.0/source boost_1_69_0 tar.gz 1 boost_1_69_0 boost boost_1_69_0/boost; then - # Move extracted boost folder where mingw-gcc can find it - mv boost /usr/$TARGET_ARCH/sys-root/mingw/include - build_post - fi -} - -function copy_gappa_dlls { - copy_coq_dll LIBGMP-10.DLL - copy_coq_dll LIBMPFR-6.DLL - copy_coq_dll LIBSTDC++-6.DLL -} - -function make_addon_gappa_tool { - install_boost - if build_prep_overlay gappa_tool; then - installer_addon_section gappa_tool "Gappa tool" "Stand alone tool for automated generation of numerical arithmetic proofs" "" - log1 autoreconf - # Note: configure.in seems to reference this file - touch stamp-config_h.in - logn configure ./configure --build="$HOST" --host="$HOST" --target="$TARGET" --prefix="$PREFIXCOQ" - logn remake ./remake --jobs=$MAKE_THREADS - logn install ./remake -d install - log1 copy_gappa_dlls - build_post - fi -} - -function make_addon_gappa { - make_camlp5 - installer_addon_dependency_beg gappa - make_addon_gappa_tool - make_addon_flocq - installer_addon_dependency_end - if build_prep_overlay gappa_plugin ; then - installer_addon_section gappa "Gappa plugin" "Coq plugin for the Gappa tool" "" - log1 autoreconf - logn configure ./configure - logn remake ./remake - logn install ./remake install - build_post - fi -} - -# Elpi: extension language for Coq based. It lets one define commands in tactics -# in a high level programming language with support for binders and unification -# variables. - -function make_addon_elpi { - make_elpi - installer_addon_dependency elpi - if build_prep_overlay elpi ; then - installer_addon_section elpi "Elpi extension language" "Coq plugin for the Elpi extension language" "" - logn build make - logn installe make install - build_post - fi -} - -# Hierarchy Builder: high level language to declare a hierarchy of structures -# compiled down to records and canonical structures. - -function make_addon_HB { - installer_addon_dependency_beg elpi_hb - make_addon_elpi - installer_addon_dependency_end - if build_prep_overlay elpi_hb ; then - installer_addon_section elpi_hb "Hierarchy Builder" "Coq library to declare algebraic hierarchies" "" - logn build make - logn install make install VFILES=structures.v - build_post - fi -} - -# Main function for building addons - -function make_addons { - # Note: ':' is the empty command, which does not produce any output - : > "/build/filelists/addon_dependencies.nsh" - : > "/build/filelists/addon_strings.nsh" - : > "/build/filelists/addon_descriptions.nsh" - : > "/build/filelists/addon_sections.nsh" - - for addon in $COQ_ADDONS; do - "make_addon_$addon" - done - - sort -u -o "/build/filelists/addon_dependencies.nsh" "/build/filelists/addon_dependencies.nsh" -} - -###################### TOP LEVEL BUILD ##################### - -ocamlfind list || true - -make_sed -make_ocaml -make_ocaml_tools -make_ocaml_libs - -list_files ocaml - -make_coq - -if [ "$INSTALLMAKE" == "Y" ] ; then - make_mingw_make -fi - -list_files ocaml_coq - -make_addons - -list_files_always ocaml_coq_addons - -if [ "$MAKEINSTALLER" == "Y" ] ; then - make_coq_installer -fi diff --git a/dev/build/windows/patches_coq/ReplaceInFile.nsh b/dev/build/windows/patches_coq/ReplaceInFile.nsh deleted file mode 100644 index 27c7eb2fd9..0000000000 --- a/dev/build/windows/patches_coq/ReplaceInFile.nsh +++ /dev/null @@ -1,67 +0,0 @@ -; From NSIS Wiki http://nsis.sourceforge.net/ReplaceInFile -; Modifications: -; - Replace only once per line -; - Don't keep original as .old -; - Use StrRep instead of StrReplace (seems to be cleaner) - -Function Func_ReplaceInFile - ClearErrors - - Exch $0 ; REPLACEMENT - Exch - Exch $1 ; SEARCH_TEXT - Exch 2 - Exch $2 ; SOURCE_FILE - - Push $R0 ; SOURCE_FILE file handle - Push $R1 ; temporary file handle - Push $R2 ; unique temporary file name - Push $R3 ; a line to search and replace / save - Push $R4 ; shift puffer - - IfFileExists $2 +1 error ; Check if file exists and open it - FileOpen $R0 $2 "r" - - GetTempFileName $R2 ; Create temporary output file - FileOpen $R1 $R2 "w" - - loop: ; Loop over lines of file - FileRead $R0 $R3 ; Read line - IfErrors finished - Push "$R3" ; Replacine string in line once - Push "$1" - Push "$0" - Call Func_StrRep - Pop $R3 - FileWrite $R1 "$R3" ; Write result - Goto loop - - finished: - FileClose $R1 ; Close files - FileClose $R0 - Delete "$2" ; Delete original file and rename temporary file to target - Rename "$R2" "$2" - ClearErrors - Goto out - - error: - SetErrors - - out: - Pop $R4 - Pop $R3 - Pop $R2 - Pop $R1 - Pop $R0 - Pop $2 - Pop $0 - Pop $1 -FunctionEnd - -!macro ReplaceInFile SOURCE_FILE SEARCH_TEXT REPLACEMENT - Push "${SOURCE_FILE}" - Push "${SEARCH_TEXT}" - Push "${REPLACEMENT}" - Call Func_ReplaceInFile -!macroend - diff --git a/dev/build/windows/patches_coq/StrRep.nsh b/dev/build/windows/patches_coq/StrRep.nsh deleted file mode 100644 index d94a9f88b4..0000000000 --- a/dev/build/windows/patches_coq/StrRep.nsh +++ /dev/null @@ -1,60 +0,0 @@ -; From NSIS Wiki http://nsis.sourceforge.net/StrRep -; Slightly modified - -Function Func_StrRep - Exch $R2 ;new - Exch 1 - Exch $R1 ;old - Exch 2 - Exch $R0 ;string - Push $R3 - Push $R4 - Push $R5 - Push $R6 - Push $R7 - Push $R8 - Push $R9 - - StrCpy $R3 0 - StrLen $R4 $R1 - StrLen $R6 $R0 - StrLen $R9 $R2 - loop: - StrCpy $R5 $R0 $R4 $R3 - StrCmp $R5 $R1 found - StrCmp $R3 $R6 done - IntOp $R3 $R3 + 1 ;move offset by 1 to check the next character - Goto loop - found: - StrCpy $R5 $R0 $R3 - IntOp $R8 $R3 + $R4 - StrCpy $R7 $R0 "" $R8 - StrCpy $R0 $R5$R2$R7 - StrLen $R6 $R0 - IntOp $R3 $R3 + $R9 ;move offset by length of the replacement string - Goto loop - done: - - Pop $R9 - Pop $R8 - Pop $R7 - Pop $R6 - Pop $R5 - Pop $R4 - Pop $R3 - Push $R0 - Push $R1 - Pop $R0 - Pop $R1 - Pop $R0 - Pop $R2 - Exch $R1 -FunctionEnd - -!macro StrRep output string old new - Push `${string}` - Push `${old}` - Push `${new}` - Call Func_StrRep - Pop ${output} -!macroend diff --git a/dev/build/windows/patches_coq/VST.patch b/dev/build/windows/patches_coq/VST.patch deleted file mode 100644 index d047eb107f..0000000000 --- a/dev/build/windows/patches_coq/VST.patch +++ /dev/null @@ -1,14 +0,0 @@ -diff --git a/Makefile b/Makefile ---- a/Makefile -+++ b/Makefile -@@ -82,8 +82,8 @@ endif - - COMPCERTDIRS=lib common $(ARCHDIRS) cfrontend flocq exportclight $(BACKEND) - --COMPCERT_R_FLAGS= $(foreach d, $(COMPCERTDIRS), -R $(COMPCERT)/$(d) compcert.$(d)) --EXTFLAGS= $(foreach d, $(COMPCERTDIRS), -Q $(COMPCERT)/$(d) compcert.$(d)) -+COMPCERT_R_FLAGS= $(foreach d, $(COMPCERTDIRS), -R $(COMPCERT)/$(d) VST.compcert.$(d)) -+EXTFLAGS= $(foreach d, $(COMPCERTDIRS), -Q $(COMPCERT)/$(d) VST.compcert.$(d)) - # for ITrees - ifeq ($(wildcard InteractionTrees/the?ries),"InteractionTrees/theories") - EXTFLAGS:=$(EXTFLAGS) -Q InteractionTrees/theories ITree diff --git a/dev/build/windows/patches_coq/coq_new.nsi b/dev/build/windows/patches_coq/coq_new.nsi deleted file mode 100644 index 9947965c28..0000000000 --- a/dev/build/windows/patches_coq/coq_new.nsi +++ /dev/null @@ -1,330 +0,0 @@ -; This script is used to build the Windows install program for Coq. - -; NSIS Modern User Interface -; Written by Joost Verburg -; Modified by Julien Narboux, Pierre Letouzey, Enrico Tassi and Michael Soegtrop - -; The following command line defines are expected: -; VERSION Coq version, e.g. 8.5-pl2 -; ARCH The target architecture, either x86_64 or i686 -; COQ_SRC_PATH path of Coq installation in Windows or MinGW format (either \\ or /, but with drive letter) -; COQ_ICON path of Coq icon file in Windows or MinGW format -; COQ_ADDONS list of addons that are shipped - -; Enable compression after debugging. -; SetCompress off -SetCompressor lzma - -!define MY_PRODUCT "Coq" ;Define your own software name here -!define OUTFILE "coq-${VERSION}-installer-windows-${ARCH}.exe" - -!include "MUI2.nsh" -!include "FileAssociation.nsh" -!include "StrRep.nsh" -!include "ReplaceInFile.nsh" -!include "winmessages.nsh" - -Var COQ_SRC_PATH_BS ; COQ_SRC_PATH with \ instead of / -Var COQ_SRC_PATH_DBS ; COQ_SRC_PATH with \\ instead of / -Var INSTDIR_DBS ; INSTDIR with \\ instead of \ - -;-------------------------------- -;Configuration - - Name "Coq" - - ;General - OutFile "${OUTFILE}" - - ;Folder selection page - InstallDir "C:\${MY_PRODUCT}" - - ;Remember install folder - InstallDirRegKey HKCU "Software\${MY_PRODUCT}" "" - -;-------------------------------- -;Extra license pages - -!macro MUI_PAGE_LICENSE_EXTRA Licensefile Header Subheader Bottom SelFunc - !define MUI_PAGE_HEADER_TEXT "${Header}" - !define MUI_PAGE_HEADER_SUBTEXT "${Subheader}" - !define MUI_LICENSEPAGE_TEXT_BOTTOM "${Bottom}" - !define MUI_PAGE_CUSTOMFUNCTION_PRE ${SelFunc} - !insertmacro MUI_PAGE_LICENSE "${Licensefile}" -!macroend - -;-------------------------------- -; Check for white spaces -Function .onVerifyInstDir - StrLen $0 "$INSTDIR" - StrCpy $1 0 - ${While} $1 < $0 - StrCpy $3 $INSTDIR 1 $1 - StrCmp $3 " " SpacesInPath - IntOp $1 $1 + 1 - ${EndWhile} - Goto done - SpacesInPath: - Abort - done: -FunctionEnd - -;-------------------------------- -;Installer Sections - -Section "Coq" Sec1 - - SetOutPath "$INSTDIR\" - !include "..\..\..\filelists\coq_base.nsh" - - ${registerExtension} "$INSTDIR\bin\coqide.exe" ".v" "Coq Script File" - - ;Store install folder - WriteRegStr HKCU "Software\${MY_PRODUCT}" "" $INSTDIR - - ;Create uninstaller - WriteUninstaller "$INSTDIR\Uninstall.exe" - WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "DisplayName" "Coq Version ${VERSION}" - WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "UninstallString" '"$INSTDIR\Uninstall.exe"' - WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "DisplayVersion" "${VERSION}" - WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "NoModify" "1" - WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "NoRepair" "1" - WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "URLInfoAbout" "http://coq.inria.fr" - - ; Create start menu entries - ; SetOutPath is required for the path in the .lnk files - SetOutPath "$INSTDIR" - CreateDirectory "$SMPROGRAMS\Coq" - ; The first shortcut set here is treated as main application by Windows 7/8. - ; Use CoqIDE as main application - CreateShortCut "$SMPROGRAMS\Coq\CoqIde.lnk" "$INSTDIR\bin\coqide.exe" - CreateShortCut "$SMPROGRAMS\Coq\Coq.lnk" "$INSTDIR\bin\coqtop.exe" - WriteINIStr "$SMPROGRAMS\Coq\The Coq HomePage.url" "InternetShortcut" "URL" "http://coq.inria.fr" - WriteINIStr "$SMPROGRAMS\Coq\The Coq Standard Library.url" "InternetShortcut" "URL" "http://coq.inria.fr/library" - CreateShortCut "$SMPROGRAMS\Coq\Uninstall.lnk" "$INSTDIR\Uninstall.exe" "" "$INSTDIR\Uninstall.exe" 0 - -SectionEnd - -;OCAML Section "Ocaml for native compute and plugin development" Sec2 -;OCAML SetOutPath "$INSTDIR\" -;OCAML !include "..\..\..\filelists\ocaml.nsh" -;OCAML -;OCAML ; Create a few slash / backslash variants of the source and install path -;OCAML ; Note: NSIS has variables, written as $VAR and defines, written as ${VAR} -;OCAML !insertmacro StrRep $COQ_SRC_PATH_BS ${COQ_SRC_PATH} "/" "\" -;OCAML !insertmacro StrRep $COQ_SRC_PATH_DBS ${COQ_SRC_PATH} "/" "\\" -;OCAML !insertmacro StrRep $INSTDIR_DBS $INSTDIR "\" "\\" -;OCAML -;OCAML ; Replace absolute paths in some OCaml config files -;OCAML ; These are not all, see ReadMe.txt -;OCAML !insertmacro ReplaceInFile "$INSTDIR\libocaml\ld.conf" "/" "\" -;OCAML !insertmacro ReplaceInFile "$INSTDIR\libocaml\ld.conf" "$COQ_SRC_PATH_BS" "$INSTDIR" -;OCAML !insertmacro ReplaceInFile "$INSTDIR\etc\findlib.conf" "$COQ_SRC_PATH_DBS" "$INSTDIR_DBS" -;OCAML SectionEnd - -SectionGroup "Coq addons" Sec2 - !include "..\..\..\filelists\addon_sections.nsh" -SectionGroupEnd - -Section "Coq files for plugin developers" Sec3 - SetOutPath "$INSTDIR\" - !include "..\..\..\filelists\coq_plugindev.nsh" -SectionEnd - -;OCAML Section "OCAMLLIB current user" Sec4 -;OCAML WriteRegStr HKCU "Environment" "OCAMLLIB" "$INSTDIR\libocaml" -;OCAML ; This is required, so that a newly started shell gets the new environment variable -;OCAML ; But it really takes a few seconds -;OCAML DetailPrint "Broadcasting OCAMLLIB environment variable change (current user)" -;OCAML SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=1000 -;OCAML SectionEnd - -;OCAML Section "OCAMLLIB all users" Sec5 -;OCAML WriteRegStr HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment" "OCAMLLIB" "$INSTDIR\libocaml" -;OCAML ; This is required, so that a newly started shell gets the new environment variable -;OCAML ; But it really takes a few seconds -;OCAML DetailPrint "Broadcasting OCAMLLIB environment variable change (all users)" -;OCAML SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=1000 -;OCAML SectionEnd - -;-------------------------------- -;Section dependencies - -; Parameters on the stack: -; top-0 : section B on which section A dependencies -; top-1 : section A, which depends on section B -; top-2 : name of section B -; top-3 : name of section A - -Function CheckSectionDependency - ; stack=nameB nameA secB secA rest - Exch $R3 ; stack=$R3 nameA secB secA rest; $R3=nameB - Exch ; stack=nameA $R3 secB secA rest - Exch $R2 ; stack=$R2 $R3 secB secA rest; $R2=nameA - Exch 2 ; stack=secB $R3 $R2 secA rest - Exch $R1 ; stack=$R1 $R3 $R2 secA rest; $R1=secB - Exch 3 ; stack=secA $R3 $R2 $R1 rest; - Exch $R0 ; stack=$R0 $R3 $R2 $R1 rest; $R0=secA - ; Take care of save order when popping the stack! - Push $R4 - Push $R5 - - SectionGetFlags $R0 $R0 - IntOp $R0 $R0 & ${SF_SELECTED} - - SectionGetFlags $R1 $R4 - IntOp $R5 $R4 & ${SF_SELECTED} - - ${If} $R0 == ${SF_SELECTED} - ${AndIf} $R5 != ${SF_SELECTED} - - IntOp $R5 $R4 | ${SF_SELECTED} - SectionSetFlags $R1 $R5 - MessageBox MB_OK '"$R3" has been selected, because "$R2" depends on it' - - ${EndIf} - - Pop $R5 - Pop $R4 - Pop $R0 - Pop $R3 - Pop $R2 - Pop $R1 -FunctionEnd - -!macro CheckSectionDependency secA secB nameA nameB - Push "${secA}" - Push "${secB}" - Push "${nameA}" - Push "${nameB}" - Call CheckSectionDependency -!macroend - -!define CheckSectionDependency "!insertmacro CheckSectionDependency" - -Function .onSelChange - !include "..\..\..\filelists\addon_dependencies.nsh" -FunctionEnd - -;-------------------------------- -;Modern UI Configuration - -; Note: this must be placed after the sections, because below we need to check at compile time -; if sections exist (by !ifdef <section_index_var>) to decide if the license page must be included. -; The section index variables are only defined after the section definitions. - - !define MUI_ICON "${COQ_ICON}" - - !insertmacro MUI_PAGE_WELCOME - !insertmacro MUI_PAGE_LICENSE "${COQ_SRC_PATH}/license_readme/coq/License.txt" - !insertmacro MUI_PAGE_COMPONENTS - - !ifdef Sec_compcert - !define LicCompCert_Title "CompCert License Agreement" - !define LicCompCert_SubTitle "You selected the CompCert addon. CompCert is not open source. Please review the license terms before installing CompCert!" - !define LicCompCert_Bottom "If you accept the terms of the agreement, click I Agree to continue. Otherwise go back and unselect the CompCert addon." - !insertmacro MUI_PAGE_LICENSE_EXTRA "${COQ_SRC_PATH}/lib/coq/user-contrib/compcert/LICENSE" "${LicCompCert_Title}" "${LicCompCert_SubTitle}" "${LicCompCert_Bottom}" SelFuncCompCert - - Function SelFuncCompCert - ${Unless} ${SectionIsSelected} ${Sec_compcert} - Abort - ${EndUnless} - FunctionEnd - !endif - - !ifdef Sec_vst - !define LicVST_Title "Princeton VST License Agreement" - !define LicVST_SubTitle "You selected the VST addon. VST contains parts of CompCert which are not open source. Please review the license terms before installing VST!" - !define LicVST_Bottom "If you accept the terms of the agreement, click I Agree to continue. Otherwise go back and unselect the VST addon." - !insertmacro MUI_PAGE_LICENSE_EXTRA "${COQ_SRC_PATH}/lib/coq/user-contrib/VST/LICENSE" "${LicVST_Title}" "${LicVST_SubTitle}" "${LicVST_Bottom}" SelFuncVST - - Function SelFuncVST - ${Unless} ${SectionIsSelected} ${Sec_vst} - Abort - ${EndUnless} - FunctionEnd - !endif - - !define MUI_DIRECTORYPAGE_TEXT_TOP "Select where to install Coq. The path MUST NOT include spaces." - !insertmacro MUI_PAGE_DIRECTORY - !insertmacro MUI_PAGE_INSTFILES - !insertmacro MUI_PAGE_FINISH - - !insertmacro MUI_UNPAGE_WELCOME - !insertmacro MUI_UNPAGE_CONFIRM - !insertmacro MUI_UNPAGE_INSTFILES - !insertmacro MUI_UNPAGE_FINISH - -;-------------------------------- -;Languages - - !insertmacro MUI_LANGUAGE "English" - -;-------------------------------- -;Language Strings - - ;Description - LangString DESC_1 ${LANG_ENGLISH} "This package contains Coq and CoqIDE." - LangString DESC_2 ${LANG_ENGLISH} "This package contains the following extra Coq packages: ${COQ_ADDONS}" - LangString DESC_3 ${LANG_ENGLISH} "This package contains the development files needed in order to build a plugin for Coq." - ; LangString DESC_4 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for the current user." - ; LangString DESC_5 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for all users." - !include "..\..\..\filelists\addon_strings.nsh" - -;-------------------------------- -;Descriptions - -!insertmacro MUI_FUNCTION_DESCRIPTION_BEGIN - !insertmacro MUI_DESCRIPTION_TEXT ${Sec1} $(DESC_1) - !insertmacro MUI_DESCRIPTION_TEXT ${Sec2} $(DESC_2) - !insertmacro MUI_DESCRIPTION_TEXT ${Sec3} $(DESC_3) - ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec4} $(DESC_4) - ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec5} $(DESC_5) - !include "..\..\..\filelists\addon_descriptions.nsh" -!insertmacro MUI_FUNCTION_DESCRIPTION_END - -;-------------------------------- -;Uninstaller Section - -Section "Uninstall" - ; Files and folders - RMDir /r "$INSTDIR\bin" - RMDir /r "$INSTDIR\doc" - RMDir /r "$INSTDIR\etc" - RMDir /r "$INSTDIR\lib" - RMDir /r "$INSTDIR\libocaml" - RMDir /r "$INSTDIR\share" - RMDir /r "$INSTDIR\ide" - RMDir /r "$INSTDIR\gtk-2.0" - RMDir /r "$INSTDIR\latex" - RMDir /r "$INSTDIR\license_readme" - RMDir /r "$INSTDIR\man" - RMDir /r "$INSTDIR\emacs" - - ; Start Menu - Delete "$SMPROGRAMS\Coq\Coq.lnk" - Delete "$SMPROGRAMS\Coq\CoqIde.lnk" - Delete "$SMPROGRAMS\Coq\Uninstall.lnk" - Delete "$SMPROGRAMS\Coq\The Coq HomePage.url" - Delete "$SMPROGRAMS\Coq\The Coq Standard Library.url" - Delete "$INSTDIR\Uninstall.exe" - - ; Registry keys - DeleteRegKey HKCU "Software\${MY_PRODUCT}" - DeleteRegKey HKLM "SOFTWARE\Coq" - DeleteRegKey HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\Coq" - DeleteRegKey HKCU "Environment\OCAMLLIB" - DeleteRegKey HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment\OCAMLLIB" - ${unregisterExtension} ".v" "Coq Script File" - - ; Root folders - RMDir "$INSTDIR" - RMDir "$SMPROGRAMS\Coq" - -SectionEnd diff --git a/dev/build/windows/patches_coq/flexdll-0.37.patch b/dev/build/windows/patches_coq/flexdll-0.37.patch deleted file mode 100644 index 82806f9ea4..0000000000 --- a/dev/build/windows/patches_coq/flexdll-0.37.patch +++ /dev/null @@ -1,19 +0,0 @@ -diff/patch file created on Tue, Feb 19, 2019 9:41:26 PM with: -difftar-folder.sh tarballs/flexdll-0.37.tar.gz flexdll-0.37 1 -TARFILE= tarballs/flexdll-0.37.tar.gz -FOLDER= flexdll-0.37 -TARSTRIP= 1 -TARPREFIX= flexdll-0.37/ -ORIGFOLDER= flexdll-0.37.orig ---- flexdll-0.37.orig/cmdline.ml 2017-10-25 10:40:46.000000000 +0200 -+++ flexdll-0.37/cmdline.ml 2019-02-19 21:41:18.157024900 +0100 -@@ -248,6 +248,9 @@ - String.sub s 0 2 :: String.sub s 2 (String.length s - 2) :: tr rest - | s :: rest when String.length s >= 5 && String.sub s 0 5 = "/link" -> - "-link" :: String.sub s 5 (String.length s - 5) :: tr rest -+ (* Convert gcc linker option prefix -Wl, to flexlink linker prefix -link *) -+ | s :: rest when String.length s >= 6 && String.sub s 0 5 = "-Wl,-" -> -+ "-link" :: String.sub s 4 (String.length s - 4) :: tr rest - | "-arg" :: x :: rest -> - tr (Array.to_list (Arg.read_arg x)) @ rest - | "-arg0" :: x :: rest -> diff --git a/dev/build/windows/patches_coq/isl-0.14.patch b/dev/build/windows/patches_coq/isl-0.14.patch deleted file mode 100644 index f3b8ead1ab..0000000000 --- a/dev/build/windows/patches_coq/isl-0.14.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- orig.isl-0.14/configure 2014-10-26 08:36:32.000000000 +0100 -+++ isl-0.14/configure 2016-10-10 18:16:01.430224500 +0200 -@@ -8134,7 +8134,7 @@ - lt_sysroot=`$CC --print-sysroot 2>/dev/null` - fi - ;; #( -- /*) -+ /*|[A-Z]:\\*|[A-Z]:/*) - lt_sysroot=`echo "$with_sysroot" | sed -e "$sed_quote_subst"` - ;; #( - no|'') diff --git a/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch b/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch deleted file mode 100644 index 1c6a038da9..0000000000 --- a/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch +++ /dev/null @@ -1,76 +0,0 @@ -diff/patch file created on Wed, Feb 20, 2019 11:29:48 AM with: -difftar-folder.sh tarballs/lablgtk-3.0.beta4.tar.gz lablgtk-3.0.beta4 1 -TARFILE= tarballs/lablgtk-3.0.beta4.tar.gz -FOLDER= lablgtk-3.0.beta4 -TARSTRIP= 1 -TARPREFIX= lablgtk-3.0.beta4/ -ORIGFOLDER= lablgtk-3.0.beta4.orig ---- lablgtk-3.0.beta4.orig/src/glib.ml 2019-02-11 07:08:17.000000000 +0100 -+++ lablgtk-3.0.beta4/src/glib.ml 2019-02-20 11:28:28.439137100 +0100 -@@ -72,6 +72,8 @@ - type id - external channel_of_descr : Unix.file_descr -> channel - = "ml_g_io_channel_unix_new" -+ external channel_of_descr_socket : Unix.file_descr -> channel -+ = "ml_g_io_channel_unix_new_socket" - external remove : id -> unit = "ml_g_source_remove" - external add_watch : - cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id ---- lablgtk-3.0.beta4.orig/src/glib.mli 2019-02-11 07:08:17.000000000 +0100 -+++ lablgtk-3.0.beta4/src/glib.mli 2019-02-20 11:28:28.423592200 +0100 -@@ -75,6 +75,7 @@ - type condition = [ `ERR | `HUP | `IN | `NVAL | `OUT | `PRI] - type id - val channel_of_descr : Unix.file_descr -> channel -+ val channel_of_descr_socket : Unix.file_descr -> channel - val add_watch : - cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id - val remove : id -> unit ---- lablgtk-3.0.beta4.orig/src/ml_glib.c 2019-02-11 07:08:17.000000000 +0100 -+++ lablgtk-3.0.beta4/src/ml_glib.c 2019-02-20 11:28:28.455395900 +0100 -@@ -25,6 +25,8 @@ - #include <string.h> - #include <locale.h> - #ifdef _WIN32 -+/* to kill a #warning: include winsock2.h before windows.h */ -+#include <winsock2.h> - #include "win32.h" - #include <wtypes.h> - #include <io.h> -@@ -38,6 +40,11 @@ - #include <caml/callback.h> - #include <caml/threads.h> - -+#ifdef _WIN32 -+/* for Socket_val */ -+#include <caml/unixsupport.h> -+#endif -+ - #include "wrappers.h" - #include "ml_glib.h" - #include "glib_tags.h" -@@ -326,14 +333,23 @@ - - #ifndef _WIN32 - ML_1 (g_io_channel_unix_new, Int_val, Val_GIOChannel_noref) -+CAMLprim value ml_g_io_channel_unix_new_socket (value arg1) { -+ return Val_GIOChannel_noref (g_io_channel_unix_new (Int_val (arg1))); -+} - - #else - CAMLprim value ml_g_io_channel_unix_new(value wh) - { - return Val_GIOChannel_noref -- (g_io_channel_unix_new -+ (g_io_channel_win32_new_fd - (_open_osfhandle((long)*(HANDLE*)Data_custom_val(wh), O_BINARY))); - } -+ -+CAMLprim value ml_g_io_channel_unix_new_socket(value wh) -+{ -+ return Val_GIOChannel_noref -+ (g_io_channel_win32_new_socket(Socket_val(wh))); -+} - #endif - - static gboolean ml_g_io_channel_watch(GIOChannel *s, GIOCondition c, diff --git a/dev/build/windows/patches_coq/ln.c b/dev/build/windows/patches_coq/ln.c deleted file mode 100644 index 41f64f98b2..0000000000 --- a/dev/build/windows/patches_coq/ln.c +++ /dev/null @@ -1,137 +0,0 @@ -// (C) 2016 Intel Deutschland GmbH -// Author: Michael Soegtrop -// Released to the public under CC0 -// See https://creativecommons.org/publicdomain/zero/1.0/ - -// Windows drop in repacement for Linux ln -// Supports command form "ln TARGET LINK_NAME" -// Supports -s and -f options -// Does not support hard links to folders (but symlinks are ok) - -#include <windows.h> -#include <stdio.h> -#include <tchar.h> - -// Cygwin MinGW doesn't have this Vista++ function in windows.h -#ifdef UNICODE - WINBASEAPI BOOLEAN APIENTRY CreateSymbolicLinkW ( LPCWSTR, LPCWSTR, DWORD ); - #define CreateSymbolicLink CreateSymbolicLinkW - #define CommandLineToArgv CommandLineToArgvW -#else - WINBASEAPI BOOLEAN APIENTRY CreateSymbolicLinkA ( LPCSTR, LPCSTR, DWORD ); - #define CreateSymbolicLink CreateSymbolicLinkA - #define CommandLineToArgv CommandLineToArgvA -#endif -#define SYMBOLIC_LINK_FLAG_DIRECTORY 1 - -int WINAPI WinMain( HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLineA, int nShowCmd ) -{ - int iarg; - BOOL symbolic = FALSE; - BOOL force = FALSE; - BOOL folder; - const _TCHAR *target; - const _TCHAR *link; - LPTSTR lpCmdLine; - int argc; - LPTSTR *argv; - - // Parse command line - // This is done explicitly here for two reasons - // 1.) MinGW doesn't seem to support _tmain, wWinMain and the like - // 2.) We want to make sure that CommandLineToArgv is used - lpCmdLine = GetCommandLine(); - argv = CommandLineToArgv( lpCmdLine, &argc ); - - // Get target and link name - if( argc<3 ) - { - _ftprintf( stderr, _T("Expecting at least 2 arguments, got %d\n"), argc-1 ); - return 1; - } - target = argv[argc-2]; - link = argv[argc-1]; - - // Parse options - // The last two arguments are interpreted as file names - // All other arguments must be -s or -f os multi letter options like -sf - for(iarg=1; iarg<argc-2; iarg++ ) - { - const _TCHAR *pos = argv[iarg]; - if( *pos != _T('-') ) - { - _ftprintf( stderr, _T("Command line option expected in argument %d\n"), iarg ); - return 1; - } - pos ++; - - while( *pos ) - { - switch( *pos ) - { - case _T('s') : symbolic = TRUE; break; - case _T('f') : force = TRUE; break; - default : - _ftprintf( stderr, _T("Unknown option '%c'\n"), *pos ); - return 1; - } - pos ++; - } - } - - #ifdef IGNORE_SYMBOLIC - symbolic = FALSE; - #endif - - // Check if link already exists - delete it if force is given or abort - { - if( GetFileAttributes(link) != INVALID_FILE_ATTRIBUTES ) - { - if( force ) - { - if( !DeleteFile( link ) ) - { - _ftprintf( stderr, _T("Error deleting file '%s'\n"), link ); - return 1; - } - } - else - { - _ftprintf( stderr, _T("File '%s' exists!\n"), link ); - return 1; - } - } - } - - // Check if target is a folder - folder = ( (GetFileAttributes(target) & FILE_ATTRIBUTE_DIRECTORY) ) != 0; - - // Create link - if(symbolic) - { - if( !CreateSymbolicLink( link, target, folder ? SYMBOLIC_LINK_FLAG_DIRECTORY : 0 ) ) - { - _ftprintf( stderr, _T("Error creating symbolic link '%s' -> '%s'!\n"), link, target ); - return 1; - } - } - else - { - if( folder ) - { - _ftprintf( stderr, _T("Cannot create hard link to folder") ); - return 1; - } - else - { - if( !CreateHardLink( link, target, NULL ) ) - { - _ftprintf( stderr, _T("Error creating hard link '%s' -> '%s'!\n"), link, target ); - return 1; - } - } - } - - // Everything is fine - return 0; -} diff --git a/dev/build/windows/patches_coq/ocaml-4.07.1.patch b/dev/build/windows/patches_coq/ocaml-4.07.1.patch deleted file mode 100644 index 2d61b5b838..0000000000 --- a/dev/build/windows/patches_coq/ocaml-4.07.1.patch +++ /dev/null @@ -1,97 +0,0 @@ -diff/patch file created on Tue, Jun 11, 2019 10:15:38 AM with: -difftar-folder.sh tarballs/ocaml-4.07.1.tar.gz ocaml-4.07.1 1 -TARFILE= tarballs/ocaml-4.07.1.tar.gz -FOLDER= ocaml-4.07.1/ -TARSTRIP= 1 -TARPREFIX= ocaml-4.07.1/ -ORIGFOLDER= ocaml-4.07.1.orig ---- ocaml-4.07.1.orig/byterun/caml/osdeps.h 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1/byterun/caml/osdeps.h 2019-06-11 10:13:50.766997600 +0200 -@@ -98,6 +98,11 @@ - */ - extern char_os *caml_secure_getenv(char_os const *var); - -+/* Modify or delete environment variable. -+ Returns 0 on success or an error code. -+*/ -+extern int caml_putenv(char_os const *var, char_os const *value); -+ - /* If [fd] refers to a terminal or console, return the number of rows - (lines) that it displays. Otherwise, or if the number of rows - cannot be determined, return -1. */ ---- ocaml-4.07.1.orig/byterun/debugger.c 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1/byterun/debugger.c 2019-06-11 10:14:02.706013700 +0200 -@@ -180,6 +180,7 @@ - if (address == NULL) return; - if (dbg_addr != NULL) caml_stat_free(dbg_addr); - dbg_addr = address; -+ caml_putenv(_T("CAML_DEBUG_SOCKET"),_T("")); - - #ifdef _WIN32 - winsock_startup(); ---- ocaml-4.07.1.orig/byterun/unix.c 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1/byterun/unix.c 2019-06-11 10:14:11.252438800 +0200 -@@ -430,6 +430,19 @@ - #endif - } - -+int caml_putenv(char_os const *var, char_os const *value) -+{ -+ char_os * s; -+ int ret; -+ -+ s = caml_stat_strconcat_os(3, var, _T("="), value); -+ ret = putenv_os(s); -+ if (ret == -1) { -+ caml_stat_free(s); -+ } -+ return ret; -+} -+ - int caml_num_rows_fd(int fd) - { - #ifdef TIOCGWINSZ ---- ocaml-4.07.1.orig/byterun/win32.c 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1/byterun/win32.c 2019-06-11 10:14:19.485640700 +0200 -@@ -727,6 +727,19 @@ - return _wgetenv(var); - } - -+int caml_putenv(char_os const *var, char_os const *value) -+{ -+ char_os * s; -+ int ret; -+ -+ s = caml_stat_strconcat_os(3, var, _T("="), value); -+ ret = putenv_os(s); -+ if (ret == -1) { -+ caml_stat_free(s); -+ } -+ return ret; -+} -+ - /* caml_win32_getenv is used to implement Sys.getenv and Unix.getenv in such a - way that they get direct access to the Win32 environment rather than to the - copy that is cached by the C runtime system. The result of caml_win32_getenv ---- ocaml-4.07.1.orig/config/Makefile.mingw 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1//config/Makefile.mingw 2019-06-11 10:14:44.492969800 +0200 -@@ -89,7 +89,7 @@ - NATDYNLINK=true - NATDYNLINKOPTS= - CMXS=cmxs --RUNTIMED=false -+RUNTIMED=true - ASM_CFI_SUPPORTED=false - WITH_FRAME_POINTERS=false - UNIX_OR_WIN32=win32 ---- ocaml-4.07.1.orig/config/Makefile.mingw64 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1//config/Makefile.mingw64 2019-06-11 10:14:53.664784900 +0200 -@@ -89,7 +89,7 @@ - NATDYNLINK=true - NATDYNLINKOPTS= - CMXS=cmxs --RUNTIMED=false -+RUNTIMED=true - ASM_CFI_SUPPORTED=false - WITH_FRAME_POINTERS=false - UNIX_OR_WIN32=win32 diff --git a/dev/build/windows/patches_coq/ocaml-4.08.1.patch b/dev/build/windows/patches_coq/ocaml-4.08.1.patch deleted file mode 100644 index a79033a061..0000000000 --- a/dev/build/windows/patches_coq/ocaml-4.08.1.patch +++ /dev/null @@ -1,25 +0,0 @@ -diff --git a/runtime/caml/misc.h b/runtime/caml/misc.h -index 6aa98516b..8184c2797 100644 ---- a/runtime/caml/misc.h -+++ b/runtime/caml/misc.h -@@ -327,7 +327,6 @@ extern void caml_set_fields (intnat v, uintnat, uintnat); - - #if defined(_WIN32) && !defined(_UCRT) - extern int caml_snprintf(char * buf, size_t size, const char * format, ...); --#define snprintf caml_snprintf - #endif - - #ifdef CAML_INSTR -@@ -336,6 +335,12 @@ extern int caml_snprintf(char * buf, size_t size, const char * format, ...); - #include <time.h> - #include <stdio.h> - -+/* snprintf emulation for Win32 - do define after stdio.h, in case snprintf is defined */ -+ -+#if defined(_WIN32) && !defined(_UCRT) -+#define snprintf caml_snprintf -+#endif -+ - extern intnat caml_stat_minor_collections; - extern intnat caml_instr_starttime, caml_instr_stoptime; - diff --git a/dev/build/windows/patches_coq/pkg-config.c b/dev/build/windows/patches_coq/pkg-config.c deleted file mode 100644 index c4c7ec2bff..0000000000 --- a/dev/build/windows/patches_coq/pkg-config.c +++ /dev/null @@ -1,29 +0,0 @@ -// MinGW personality wrapper for pkgconf -// This is an executable replacement for the shell scripts /bin/ARCH-pkg-config -// Compile with e.g. -// gcc pkg-config.c -DARCH=x86_64-w64-mingw32 -o pkg-config.exe -// gcc pkg-config.c -DARCH=i686-w64-mingw32 -o pkg-config.exe -// ATTENTION: Do not compile with MinGW-gcc, compile with cygwin gcc! -// -// To test it execute e.g. -// $ ./pkg-config --path zlib -// /usr/x86_64-w64-mingw32/sys-root/mingw/lib/pkgconfig/zlib.pc - -#include <unistd.h> - -#define STRINGIFY1(arg) #arg -#define STRINGIFY(arg) STRINGIFY1(arg) - -int main(int argc, char *argv[]) -{ - // +1 for extra argument, +1 for trailing NULL - char * argvnew[argc+2]; - int id=0, is=0; - - argvnew[id++] = argv[is++]; - argvnew[id++] = "--personality="STRINGIFY(ARCH); - while( is<argc ) argvnew[id++] = argv[is++]; - argvnew[id++] = 0; - - return execv("/usr/bin/pkgconf", argvnew); -} diff --git a/dev/build/windows/patches_coq/quickchick.patch b/dev/build/windows/patches_coq/quickchick.patch deleted file mode 100644 index 4b7b86ff05..0000000000 --- a/dev/build/windows/patches_coq/quickchick.patch +++ /dev/null @@ -1,47 +0,0 @@ -diff/patch file created on Wed, Jul 17, 2019 8:06:45 PM with: -difftar-folder.sh tarballs/quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0.tar.gz quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0 1 -TARFILE= tarballs/quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0.tar.gz -FOLDER= quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0 -TARSTRIP= 1 -TARPREFIX= QuickChick-741fb98eb865129a70c4ef7a64db2739c4a5eab0/ -ORIGFOLDER= quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0.orig ---- quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0.orig/Makefile 2019-06-26 12:09:01.000000000 +0200 -+++ quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0/Makefile 2019-07-17 20:05:44.322251200 +0200 -@@ -2,7 +2,7 @@ - .PHONY: plugin install install-plugin clean quickChickTool - - QCTOOL_DIR=quickChickTool --QCTOOL_EXE=quickChickTool.byte -+QCTOOL_EXE=quickChickTool.native - QCTOOL_SRC=$(QCTOOL_DIR)/quickChickTool.ml \ - $(QCTOOL_DIR)/quickChickToolTypes.ml \ - $(QCTOOL_DIR)/quickChickToolLexer.mll \ -@@ -20,8 +20,8 @@ - - all: quickChickTool plugin documentation-check - --plugin: Makefile.coq -- $(MAKE) -f Makefile.coq -+plugin: Makefile.coq -+ $(MAKE) -f Makefile.coq - - documentation-check: plugin - coqc -R src QuickChick -I src QuickChickInterface.v -@@ -32,7 +32,7 @@ - install: all - $(V)$(MAKE) -f Makefile.coq install > $(TEMPFILE) - # Manually copying the remaining files -- $(V)cp $(QCTOOL_DIR)/$(QCTOOL_EXE) $(shell opam config var bin)/quickChick -+ $(V)cp $(QCTOOL_DIR)/$(QCTOOL_EXE) "$(COQBIN)/quickChick" - # $(V)cp src/quickChickLib.cmx $(COQLIB)/user-contrib/QuickChick - # $(V)cp src/quickChickLib.o $(COQLIB)/user-contrib/QuickChick - -@@ -56,7 +56,7 @@ - $(MAKE) -C examples/RedBlack test - # cd examples/stlc; make clean && make - $(MAKE) -C examples/multifile-mutation test --# This takes too long. -+# This takes too long. - # $(MAKE) -C examples/c-mutation test - # coqc examples/BSTTest.v - coqc examples/DependentTest.v diff --git a/dev/build/windows/patches_coq/sed-4.2.2-3.src.patch b/dev/build/windows/patches_coq/sed-4.2.2-3.src.patch deleted file mode 100644 index d210a04153..0000000000 --- a/dev/build/windows/patches_coq/sed-4.2.2-3.src.patch +++ /dev/null @@ -1,1301 +0,0 @@ ---- origsrc/sed-4.2.2/doc/sed.1 2012-12-22 15:27:13.000000000 +0100 -+++ src/sed-4.2.2/doc/sed.1 2013-06-27 18:10:47.974060492 +0200 -@@ -1,5 +1,5 @@ - .\" DO NOT MODIFY THIS FILE! It was generated by help2man 1.28. --.TH SED "1" "December 2012" "sed 4.2.2" "User Commands" -+.TH SED "1" "June 2013" "sed 4.2.2" "User Commands" - .SH NAME - sed \- stream editor for filtering and transforming text - .SH SYNOPSIS -@@ -40,6 +40,10 @@ follow symlinks when processing in place - .IP - edit files in place (makes backup if SUFFIX supplied) - .HP -+\fB\-b\fR, \fB\-\-binary\fR -+.IP -+open files in binary mode (CR+LFs are not processed specially) -+.HP - \fB\-l\fR N, \fB\-\-line\-length\fR=\fIN\fR - .IP - specify the desired line-wrap length for the `l' command ---- origsrc/sed-4.2.2/lib/regcomp.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regcomp.c 2013-06-27 18:05:27.044448044 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static reg_errcode_t re_compile_internal (regex_t *preg, const char * pattern, - size_t length, reg_syntax_t syntax); -@@ -95,20 +94,20 @@ static reg_errcode_t build_charclass (RE - bitset_t sbcset, - re_charset_t *mbcset, - Idx *char_class_alloc, -- const unsigned char *class_name, -+ const char *class_name, - reg_syntax_t syntax); - #else /* not RE_ENABLE_I18N */ - static reg_errcode_t build_equiv_class (bitset_t sbcset, - const unsigned char *name); - static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans, - bitset_t sbcset, -- const unsigned char *class_name, -+ const char *class_name, - reg_syntax_t syntax); - #endif /* not RE_ENABLE_I18N */ - static bin_tree_t *build_charclass_op (re_dfa_t *dfa, - RE_TRANSLATE_TYPE trans, -- const unsigned char *class_name, -- const unsigned char *extra, -+ const char *class_name, -+ const char *extra, - bool non_match, reg_errcode_t *err); - static bin_tree_t *create_tree (re_dfa_t *dfa, - bin_tree_t *left, bin_tree_t *right, -@@ -293,7 +292,7 @@ weak_alias (__re_compile_fastmap, re_com - #endif - - static inline void --__attribute ((always_inline)) -+__attribute__ ((always_inline)) - re_set_fastmap (char *fastmap, bool icase, int ch) - { - fastmap[ch] = 1; -@@ -587,7 +586,7 @@ weak_alias (__regerror, regerror) - static const bitset_t utf8_sb_map = - { - /* Set the first 128 bits. */ --# ifdef __GNUC__ -+# if defined __GNUC__ && !defined __STRICT_ANSI__ - [0 ... 0x80 / BITSET_WORD_BITS - 1] = BITSET_WORD_MAX - # else - # if 4 * BITSET_WORD_BITS < ASCII_CHARS -@@ -664,7 +663,10 @@ regfree (preg) - { - re_dfa_t *dfa = preg->buffer; - if (BE (dfa != NULL, 1)) -- free_dfa_content (dfa); -+ { -+ lock_fini (dfa->lock); -+ free_dfa_content (dfa); -+ } - preg->buffer = NULL; - preg->allocated = 0; - -@@ -785,6 +787,8 @@ re_compile_internal (regex_t *preg, cons - preg->used = sizeof (re_dfa_t); - - err = init_dfa (dfa, length); -+ if (BE (err == REG_NOERROR && lock_init (dfa->lock) != 0, 0)) -+ err = REG_ESPACE; - if (BE (err != REG_NOERROR, 0)) - { - free_dfa_content (dfa); -@@ -798,8 +802,6 @@ re_compile_internal (regex_t *preg, cons - strncpy (dfa->re_str, pattern, length + 1); - #endif - -- __libc_lock_init (dfa->lock); -- - err = re_string_construct (®exp, pattern, length, preg->translate, - (syntax & RE_ICASE) != 0, dfa); - if (BE (err != REG_NOERROR, 0)) -@@ -807,6 +809,7 @@ re_compile_internal (regex_t *preg, cons - re_compile_internal_free_return: - free_workarea_compile (preg); - re_string_destruct (®exp); -+ lock_fini (dfa->lock); - free_dfa_content (dfa); - preg->buffer = NULL; - preg->allocated = 0; -@@ -839,6 +842,7 @@ re_compile_internal (regex_t *preg, cons - - if (BE (err != REG_NOERROR, 0)) - { -+ lock_fini (dfa->lock); - free_dfa_content (dfa); - preg->buffer = NULL; - preg->allocated = 0; -@@ -954,10 +958,10 @@ static void - internal_function - init_word_char (re_dfa_t *dfa) - { -- dfa->word_ops_used = 1; - int i = 0; - int j; - int ch = 0; -+ dfa->word_ops_used = 1; - if (BE (dfa->map_notascii == 0, 1)) - { - bitset_word_t bits0 = 0x00000000; -@@ -2423,8 +2427,8 @@ parse_expression (re_string_t *regexp, r - case OP_WORD: - case OP_NOTWORD: - tree = build_charclass_op (dfa, regexp->trans, -- (const unsigned char *) "alnum", -- (const unsigned char *) "_", -+ "alnum", -+ "_", - token->type == OP_NOTWORD, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; -@@ -2432,8 +2436,8 @@ parse_expression (re_string_t *regexp, r - case OP_SPACE: - case OP_NOTSPACE: - tree = build_charclass_op (dfa, regexp->trans, -- (const unsigned char *) "space", -- (const unsigned char *) "", -+ "space", -+ "", - token->type == OP_NOTSPACE, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; -@@ -2713,7 +2717,6 @@ build_range_exp (const reg_syntax_t synt - wchar_t wc; - wint_t start_wc; - wint_t end_wc; -- wchar_t cmp_buf[6] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; - - start_ch = ((start_elem->type == SB_CHAR) ? start_elem->opr.ch - : ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0] -@@ -2727,11 +2730,7 @@ build_range_exp (const reg_syntax_t synt - ? __btowc (end_ch) : end_elem->opr.wch); - if (start_wc == WEOF || end_wc == WEOF) - return REG_ECOLLATE; -- cmp_buf[0] = start_wc; -- cmp_buf[4] = end_wc; -- -- if (BE ((syntax & RE_NO_EMPTY_RANGES) -- && wcscoll (cmp_buf, cmp_buf + 4) > 0, 0)) -+ else if (BE ((syntax & RE_NO_EMPTY_RANGES) && start_wc > end_wc, 0)) - return REG_ERANGE; - - /* Got valid collation sequence values, add them as a new entry. -@@ -2772,9 +2771,7 @@ build_range_exp (const reg_syntax_t synt - /* Build the table for single byte characters. */ - for (wc = 0; wc < SBC_MAX; ++wc) - { -- cmp_buf[2] = wc; -- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 -- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) -+ if (start_wc <= wc && wc <= end_wc) - bitset_set (sbcset, wc); - } - } -@@ -2843,40 +2840,29 @@ parse_bracket_exp (re_string_t *regexp, - - /* Local function for parse_bracket_exp used in _LIBC environment. - Seek the collating symbol entry corresponding to NAME. -- Return the index of the symbol in the SYMB_TABLE. */ -+ Return the index of the symbol in the SYMB_TABLE, -+ or -1 if not found. */ - - auto inline int32_t -- __attribute ((always_inline)) -- seek_collating_symbol_entry (name, name_len) -- const unsigned char *name; -- size_t name_len; -- { -- int32_t hash = elem_hash ((const char *) name, name_len); -- int32_t elem = hash % table_size; -- if (symb_table[2 * elem] != 0) -- { -- int32_t second = hash % (table_size - 2) + 1; -- -- do -- { -- /* First compare the hashing value. */ -- if (symb_table[2 * elem] == hash -- /* Compare the length of the name. */ -- && name_len == extra[symb_table[2 * elem + 1]] -- /* Compare the name. */ -- && memcmp (name, &extra[symb_table[2 * elem + 1] + 1], -- name_len) == 0) -- { -- /* Yep, this is the entry. */ -- break; -- } -+ __attribute__ ((always_inline)) -+ seek_collating_symbol_entry (const unsigned char *name, size_t name_len) -+ { -+ int32_t elem; - -- /* Next entry. */ -- elem += second; -- } -- while (symb_table[2 * elem] != 0); -- } -- return elem; -+ for (elem = 0; elem < table_size; elem++) -+ if (symb_table[2 * elem] != 0) -+ { -+ int32_t idx = symb_table[2 * elem + 1]; -+ /* Skip the name of collating element name. */ -+ idx += 1 + extra[idx]; -+ if (/* Compare the length of the name. */ -+ name_len == extra[idx] -+ /* Compare the name. */ -+ && memcmp (name, &extra[idx + 1], name_len) == 0) -+ /* Yep, this is the entry. */ -+ return elem; -+ } -+ return -1; - } - - /* Local function for parse_bracket_exp used in _LIBC environment. -@@ -2884,9 +2870,8 @@ parse_bracket_exp (re_string_t *regexp, - Return the value if succeeded, UINT_MAX otherwise. */ - - auto inline unsigned int -- __attribute ((always_inline)) -- lookup_collation_sequence_value (br_elem) -- bracket_elem_t *br_elem; -+ __attribute__ ((always_inline)) -+ lookup_collation_sequence_value (bracket_elem_t *br_elem) - { - if (br_elem->type == SB_CHAR) - { -@@ -2914,7 +2899,7 @@ parse_bracket_exp (re_string_t *regexp, - int32_t elem, idx; - elem = seek_collating_symbol_entry (br_elem->opr.name, - sym_name_len); -- if (symb_table[2 * elem] != 0) -+ if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; -@@ -2932,7 +2917,7 @@ parse_bracket_exp (re_string_t *regexp, - /* Return the collation sequence value. */ - return *(unsigned int *) (extra + idx); - } -- else if (symb_table[2 * elem] == 0 && sym_name_len == 1) -+ else if (sym_name_len == 1) - { - /* No valid character. Match it as a single byte - character. */ -@@ -2953,12 +2938,9 @@ parse_bracket_exp (re_string_t *regexp, - update it. */ - - auto inline reg_errcode_t -- __attribute ((always_inline)) -- build_range_exp (sbcset, mbcset, range_alloc, start_elem, end_elem) -- re_charset_t *mbcset; -- Idx *range_alloc; -- bitset_t sbcset; -- bracket_elem_t *start_elem, *end_elem; -+ __attribute__ ((always_inline)) -+ build_range_exp (bitset_t sbcset, re_charset_t *mbcset, int *range_alloc, -+ bracket_elem_t *start_elem, bracket_elem_t *end_elem) - { - unsigned int ch; - uint32_t start_collseq; -@@ -2971,6 +2953,7 @@ parse_bracket_exp (re_string_t *regexp, - 0)) - return REG_ERANGE; - -+ /* FIXME: Implement rational ranges here, too. */ - start_collseq = lookup_collation_sequence_value (start_elem); - end_collseq = lookup_collation_sequence_value (end_elem); - /* Check start/end collation sequence values. */ -@@ -3036,26 +3019,23 @@ parse_bracket_exp (re_string_t *regexp, - pointer argument since we may update it. */ - - auto inline reg_errcode_t -- __attribute ((always_inline)) -- build_collating_symbol (sbcset, mbcset, coll_sym_alloc, name) -- re_charset_t *mbcset; -- Idx *coll_sym_alloc; -- bitset_t sbcset; -- const unsigned char *name; -+ __attribute__ ((always_inline)) -+ build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset, -+ Idx *coll_sym_alloc, const unsigned char *name) - { - int32_t elem, idx; - size_t name_len = strlen ((const char *) name); - if (nrules != 0) - { - elem = seek_collating_symbol_entry (name, name_len); -- if (symb_table[2 * elem] != 0) -+ if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; - /* Skip the name of collating element name. */ - idx += 1 + extra[idx]; - } -- else if (symb_table[2 * elem] == 0 && name_len == 1) -+ else if (name_len == 1) - { - /* No valid character, treat it as a normal - character. */ -@@ -3298,7 +3278,8 @@ parse_bracket_exp (re_string_t *regexp, - #ifdef RE_ENABLE_I18N - mbcset, &char_class_alloc, - #endif /* RE_ENABLE_I18N */ -- start_elem.opr.name, syntax); -+ (const char *) start_elem.opr.name, -+ syntax); - if (BE (*err != REG_NOERROR, 0)) - goto parse_bracket_exp_free_return; - break; -@@ -3578,14 +3559,14 @@ static reg_errcode_t - #ifdef RE_ENABLE_I18N - build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, - re_charset_t *mbcset, Idx *char_class_alloc, -- const unsigned char *class_name, reg_syntax_t syntax) -+ const char *class_name, reg_syntax_t syntax) - #else /* not RE_ENABLE_I18N */ - build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, -- const unsigned char *class_name, reg_syntax_t syntax) -+ const char *class_name, reg_syntax_t syntax) - #endif /* not RE_ENABLE_I18N */ - { - int i; -- const char *name = (const char *) class_name; -+ const char *name = class_name; - - /* In case of REG_ICASE "upper" and "lower" match the both of - upper and lower cases. */ -@@ -3659,8 +3640,8 @@ build_charclass (RE_TRANSLATE_TYPE trans - - static bin_tree_t * - build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, -- const unsigned char *class_name, -- const unsigned char *extra, bool non_match, -+ const char *class_name, -+ const char *extra, bool non_match, - reg_errcode_t *err) - { - re_bitset_ptr_t sbcset; ---- origsrc/sed-4.2.2/lib/regex-quote.c 1970-01-01 01:00:00.000000000 +0100 -+++ src/sed-4.2.2/lib/regex-quote.c 2013-06-27 18:05:27.081447884 +0200 -@@ -0,0 +1,216 @@ -+/* Construct a regular expression from a literal string. -+ Copyright (C) 1995, 2010-2013 Free Software Foundation, Inc. -+ Written by Bruno Haible <haible@clisp.cons.org>, 2010. -+ -+ This program is free software: you can redistribute it and/or modify -+ it under the terms of the GNU General Public License as published by -+ the Free Software Foundation; either version 3 of the License, or -+ (at your option) any later version. -+ -+ This program is distributed in the hope that it will be useful, -+ but WITHOUT ANY WARRANTY; without even the implied warranty of -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -+ GNU General Public License for more details. -+ -+ You should have received a copy of the GNU General Public License -+ along with this program. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <config.h> -+ -+/* Specification. */ -+#include "regex-quote.h" -+ -+#include <string.h> -+ -+#include "mbuiter.h" -+#include "xalloc.h" -+ -+/* Characters that are special in a BRE. */ -+static const char bre_special[] = "$^.*[]\\"; -+ -+/* Characters that are special in an ERE. */ -+static const char ere_special[] = "$^.*[]\\+?{}()|"; -+ -+struct regex_quote_spec -+regex_quote_spec_posix (int cflags, bool anchored) -+{ -+ struct regex_quote_spec result; -+ -+ strcpy (result.special, cflags != 0 ? ere_special : bre_special); -+ result.multibyte = true; -+ result.anchored = anchored; -+ -+ return result; -+} -+ -+/* Syntax bit values, defined in GNU <regex.h>. We don't include it here, -+ otherwise this module would need to depend on gnulib module 'regex'. */ -+#define RE_BK_PLUS_QM 0x00000002 -+#define RE_INTERVALS 0x00000200 -+#define RE_LIMITED_OPS 0x00000400 -+#define RE_NEWLINE_ALT 0x00000800 -+#define RE_NO_BK_BRACES 0x00001000 -+#define RE_NO_BK_PARENS 0x00002000 -+#define RE_NO_BK_VBAR 0x00008000 -+ -+struct regex_quote_spec -+regex_quote_spec_gnu (unsigned long /*reg_syntax_t*/ syntax, bool anchored) -+{ -+ struct regex_quote_spec result; -+ char *p; -+ -+ p = result.special; -+ memcpy (p, bre_special, sizeof (bre_special) - 1); -+ p += sizeof (bre_special) - 1; -+ if ((syntax & RE_LIMITED_OPS) == 0 && (syntax & RE_BK_PLUS_QM) == 0) -+ { -+ *p++ = '+'; -+ *p++ = '?'; -+ } -+ if ((syntax & RE_INTERVALS) != 0 && (syntax & RE_NO_BK_BRACES) != 0) -+ { -+ *p++ = '{'; -+ *p++ = '}'; -+ } -+ if ((syntax & RE_NO_BK_PARENS) != 0) -+ { -+ *p++ = '('; -+ *p++ = ')'; -+ } -+ if ((syntax & RE_LIMITED_OPS) == 0 && (syntax & RE_NO_BK_VBAR) != 0) -+ *p++ = '|'; -+ if ((syntax & RE_NEWLINE_ALT) != 0) -+ *p++ = '\n'; -+ *p = '\0'; -+ -+ result.multibyte = true; -+ result.anchored = anchored; -+ -+ return result; -+} -+ -+/* Characters that are special in a PCRE. */ -+static const char pcre_special[] = "$^.*[]\\+?{}()|"; -+ -+/* Options bit values, defined in <pcre.h>. We don't include it here, because -+ it is not a standard header. */ -+#define PCRE_ANCHORED 0x00000010 -+#define PCRE_EXTENDED 0x00000008 -+ -+struct regex_quote_spec -+regex_quote_spec_pcre (int options, bool anchored) -+{ -+ struct regex_quote_spec result; -+ char *p; -+ -+ p = result.special; -+ memcpy (p, bre_special, sizeof (pcre_special) - 1); -+ p += sizeof (pcre_special) - 1; -+ if (options & PCRE_EXTENDED) -+ { -+ *p++ = ' '; -+ *p++ = '\t'; -+ *p++ = '\n'; -+ *p++ = '\v'; -+ *p++ = '\f'; -+ *p++ = '\r'; -+ *p++ = '#'; -+ } -+ *p = '\0'; -+ -+ /* PCRE regular expressions consist of UTF-8 characters of options contains -+ PCRE_UTF8 and of single bytes otherwise. */ -+ result.multibyte = false; -+ /* If options contains PCRE_ANCHORED, the anchoring is implicit. */ -+ result.anchored = (options & PCRE_ANCHORED ? 0 : anchored); -+ -+ return result; -+} -+ -+size_t -+regex_quote_length (const char *string, const struct regex_quote_spec *spec) -+{ -+ const char *special = spec->special; -+ size_t length; -+ -+ length = 0; -+ if (spec->anchored) -+ length += 2; /* for '^' at the beginning and '$' at the end */ -+ if (spec->multibyte) -+ { -+ mbui_iterator_t iter; -+ -+ for (mbui_init (iter, string); mbui_avail (iter); mbui_advance (iter)) -+ { -+ /* We know that special contains only ASCII characters. */ -+ if (mb_len (mbui_cur (iter)) == 1 -+ && strchr (special, * mbui_cur_ptr (iter))) -+ length += 1; -+ length += mb_len (mbui_cur (iter)); -+ } -+ } -+ else -+ { -+ const char *iter; -+ -+ for (iter = string; *iter != '\0'; iter++) -+ { -+ if (strchr (special, *iter)) -+ length += 1; -+ length += 1; -+ } -+ } -+ -+ return length; -+} -+ -+char * -+regex_quote_copy (char *p, const char *string, const struct regex_quote_spec *spec) -+{ -+ const char *special = spec->special; -+ -+ if (spec->anchored) -+ *p++ = '^'; -+ if (spec->multibyte) -+ { -+ mbui_iterator_t iter; -+ -+ for (mbui_init (iter, string); mbui_avail (iter); mbui_advance (iter)) -+ { -+ /* We know that special contains only ASCII characters. */ -+ if (mb_len (mbui_cur (iter)) == 1 -+ && strchr (special, * mbui_cur_ptr (iter))) -+ *p++ = '\\'; -+ memcpy (p, mbui_cur_ptr (iter), mb_len (mbui_cur (iter))); -+ p += mb_len (mbui_cur (iter)); -+ } -+ } -+ else -+ { -+ const char *iter; -+ -+ for (iter = string; *iter != '\0'; iter++) -+ { -+ if (strchr (special, *iter)) -+ *p++ = '\\'; -+ *p++ = *iter++; -+ } -+ } -+ if (spec->anchored) -+ *p++ = '$'; -+ -+ return p; -+} -+ -+char * -+regex_quote (const char *string, const struct regex_quote_spec *spec) -+{ -+ size_t length = regex_quote_length (string, spec); -+ char *result = XNMALLOC (length + 1, char); -+ char *p; -+ -+ p = result; -+ p = regex_quote_copy (p, string, spec); -+ *p = '\0'; -+ return result; -+} ---- origsrc/sed-4.2.2/lib/regex-quote.h 1970-01-01 01:00:00.000000000 +0100 -+++ src/sed-4.2.2/lib/regex-quote.h 2013-06-27 18:05:27.112447751 +0200 -@@ -0,0 +1,88 @@ -+/* Construct a regular expression from a literal string. -+ Copyright (C) 1995, 2010-2013 Free Software Foundation, Inc. -+ Written by Bruno Haible <haible@clisp.cons.org>, 2010. -+ -+ This program is free software: you can redistribute it and/or modify -+ it under the terms of the GNU General Public License as published by -+ the Free Software Foundation; either version 3 of the License, or -+ (at your option) any later version. -+ -+ This program is distributed in the hope that it will be useful, -+ but WITHOUT ANY WARRANTY; without even the implied warranty of -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -+ GNU General Public License for more details. -+ -+ You should have received a copy of the GNU General Public License -+ along with this program. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#ifndef _REGEX_QUOTE_H -+#define _REGEX_QUOTE_H -+ -+#include <stddef.h> -+#include <stdbool.h> -+ -+ -+/* Specifies a quotation task for converting a fixed string to a regular -+ expression pattern. */ -+struct regex_quote_spec -+{ -+ /* True if the regular expression pattern consists of multibyte characters -+ (in the encoding given by the LC_CTYPE category of the locale), -+ false if it consists of single bytes or UTF-8 characters. */ -+ unsigned int /*bool*/ multibyte : 1; -+ /* True if the regular expression pattern shall match only entire lines. */ -+ unsigned int /*bool*/ anchored : 1; -+ /* Set of characters that need to be escaped (all ASCII), as a -+ NUL-terminated string. */ -+ char special[30 + 1]; -+}; -+ -+ -+/* Creates a quotation task that produces a POSIX regular expression, that is, -+ a pattern that can be compiled with regcomp(). -+ CFLAGS can be 0 or REG_EXTENDED. -+ If it is 0, the result is a Basic Regular Expression (BRE) -+ <http://www.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap09.html#tag_09_03>. -+ If it is REG_EXTENDED, the result is an Extended Regular Expression (ERE) -+ <http://www.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap09.html#tag_09_04>. -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_posix (int cflags, bool anchored); -+ -+/* Creates a quotation task that produces a regular expression that can be -+ compiled with the GNU API function re_compile_pattern(). -+ SYNTAX describes the syntax of the regular expression (such as -+ RE_SYNTAX_POSIX_BASIC, RE_SYNTAX_POSIX_EXTENDED, RE_SYNTAX_EMACS, all -+ defined in <regex.h>). It must be the same value as 're_syntax_options' -+ at the moment of the re_compile_pattern() call. -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_gnu (unsigned long /*reg_syntax_t*/ syntax, bool anchored); -+ -+/* Creates a quotation task that produces a PCRE regular expression, that is, -+ a pattern that can be compiled with pcre_compile(). -+ OPTIONS is the same value as the second argument passed to pcre_compile(). -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_pcre (int options, bool anchored); -+ -+ -+/* Returns the number of bytes needed for the quoted string. */ -+extern size_t -+ regex_quote_length (const char *string, const struct regex_quote_spec *spec); -+ -+/* Copies the quoted string to p and returns the incremented p. -+ There must be room for regex_quote_length (string, spec) + 1 bytes at p. */ -+extern char * -+ regex_quote_copy (char *p, -+ const char *string, const struct regex_quote_spec *spec); -+ -+/* Returns the freshly allocated quoted string. */ -+extern char * -+ regex_quote (const char *string, const struct regex_quote_spec *spec); -+ -+ -+#endif /* _REGEX_QUOTE_H */ ---- origsrc/sed-4.2.2/lib/regex.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regex.c 2013-06-27 18:05:27.138447639 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _LIBC - # include <config.h> -@@ -25,6 +24,7 @@ - # pragma GCC diagnostic ignored "-Wsuggest-attribute=pure" - # endif - # if (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) || 4 < __GNUC__ -+# pragma GCC diagnostic ignored "-Wold-style-definition" - # pragma GCC diagnostic ignored "-Wtype-limits" - # endif - #endif ---- origsrc/sed-4.2.2/lib/regex.h 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regex.h 2013-06-27 18:05:27.168447509 +0200 -@@ -1,23 +1,22 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Definitions for data structures and routines for the regular - expression library. -- Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2012 -- Free Software Foundation, Inc. -+ Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2013 Free Software -+ Foundation, Inc. - This file is part of the GNU C Library. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _REGEX_H - #define _REGEX_H 1 ---- origsrc/sed-4.2.2/lib/regex_internal.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regex_internal.c 2013-06-27 18:05:27.199447375 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static void re_string_construct_common (const char *str, Idx len, - re_string_t *pstr, -@@ -835,7 +834,7 @@ re_string_reconstruct (re_string_t *pstr - } - - static unsigned char --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_string_peek_byte_case (const re_string_t *pstr, Idx idx) - { - int ch; -@@ -975,7 +974,7 @@ re_node_set_alloc (re_node_set *set, Idx - set->alloc = size; - set->nelem = 0; - set->elems = re_malloc (Idx, size); -- if (BE (set->elems == NULL, 0)) -+ if (BE (set->elems == NULL, 0) && (MALLOC_0_IS_NONNULL || size != 0)) - return REG_ESPACE; - return REG_NOERROR; - } -@@ -1355,7 +1354,7 @@ re_node_set_insert_last (re_node_set *se - Return true if SET1 and SET2 are equivalent. */ - - static bool --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_node_set_compare (const re_node_set *set1, const re_node_set *set2) - { - Idx i; -@@ -1370,7 +1369,7 @@ re_node_set_compare (const re_node_set * - /* Return (idx + 1) if SET contains the element ELEM, return 0 otherwise. */ - - static Idx --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_node_set_contains (const re_node_set *set, Idx elem) - { - __re_size_t idx, right, mid; -@@ -1444,11 +1443,9 @@ re_dfa_add_node (re_dfa_t *dfa, re_token - dfa->nodes[dfa->nodes_len] = token; - dfa->nodes[dfa->nodes_len].constraint = 0; - #ifdef RE_ENABLE_I18N -- { -- int type = token.type; - dfa->nodes[dfa->nodes_len].accept_mb = -- (type == OP_PERIOD && dfa->mb_cur_max > 1) || type == COMPLEX_BRACKET; -- } -+ ((token.type == OP_PERIOD && dfa->mb_cur_max > 1) -+ || token.type == COMPLEX_BRACKET); - #endif - dfa->nexts[dfa->nodes_len] = REG_MISSING; - re_node_set_init_empty (dfa->edests + dfa->nodes_len); ---- origsrc/sed-4.2.2/lib/regex_internal.h 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regex_internal.h 2013-06-27 18:05:27.230447242 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _REGEX_INTERNAL_H - #define _REGEX_INTERNAL_H 1 -@@ -28,21 +27,54 @@ - #include <string.h> - - #include <langinfo.h> --#ifndef _LIBC --# include "localcharset.h" --#endif - #include <locale.h> - #include <wchar.h> - #include <wctype.h> - #include <stdbool.h> - #include <stdint.h> --#if defined _LIBC -+ -+#ifdef _LIBC - # include <bits/libc-lock.h> -+# define lock_define(name) __libc_lock_define (, name) -+# define lock_init(lock) (__libc_lock_init (lock), 0) -+# define lock_fini(lock) 0 -+# define lock_lock(lock) __libc_lock_lock (lock) -+# define lock_unlock(lock) __libc_lock_unlock (lock) -+#elif defined GNULIB_LOCK -+# include "glthread/lock.h" -+ /* Use gl_lock_define if empty macro arguments are known to work. -+ Otherwise, fall back on less-portable substitutes. */ -+# if ((defined __GNUC__ && !defined __STRICT_ANSI__) \ -+ || (defined __STDC_VERSION__ && 199901L <= __STDC_VERSION__)) -+# define lock_define(name) gl_lock_define (, name) -+# elif USE_POSIX_THREADS -+# define lock_define(name) pthread_mutex_t name; -+# elif USE_PTH_THREADS -+# define lock_define(name) pth_mutex_t name; -+# elif USE_SOLARIS_THREADS -+# define lock_define(name) mutex_t name; -+# elif USE_WINDOWS_THREADS -+# define lock_define(name) gl_lock_t name; -+# else -+# define lock_define(name) -+# endif -+# define lock_init(lock) glthread_lock_init (&(lock)) -+# define lock_fini(lock) glthread_lock_destroy (&(lock)) -+# define lock_lock(lock) glthread_lock_lock (&(lock)) -+# define lock_unlock(lock) glthread_lock_unlock (&(lock)) -+#elif defined GNULIB_PTHREAD -+# include <pthread.h> -+# define lock_define(name) pthread_mutex_t name; -+# define lock_init(lock) pthread_mutex_init (&(lock), 0) -+# define lock_fini(lock) pthread_mutex_destroy (&(lock)) -+# define lock_lock(lock) pthread_mutex_lock (&(lock)) -+# define lock_unlock(lock) pthread_mutex_unlock (&(lock)) - #else --# define __libc_lock_define(CLASS,NAME) --# define __libc_lock_init(NAME) do { } while (0) --# define __libc_lock_lock(NAME) do { } while (0) --# define __libc_lock_unlock(NAME) do { } while (0) -+# define lock_define(name) -+# define lock_init(lock) 0 -+# define lock_fini(lock) 0 -+# define lock_lock(lock) ((void) 0) -+# define lock_unlock(lock) ((void) 0) - #endif - - /* In case that the system doesn't have isblank(). */ -@@ -65,7 +97,7 @@ - # ifdef _LIBC - # undef gettext - # define gettext(msgid) \ -- INTUSE(__dcgettext) (_libc_intl_domainname, msgid, LC_MESSAGES) -+ __dcgettext (_libc_intl_domainname, msgid, LC_MESSAGES) - # endif - #else - # define gettext(msgid) (msgid) -@@ -101,6 +133,8 @@ - - /* Rename to standard API for using out of glibc. */ - #ifndef _LIBC -+# undef __wctype -+# undef __iswctype - # define __wctype wctype - # define __iswctype iswctype - # define __btowc btowc -@@ -110,10 +144,8 @@ - # define attribute_hidden - #endif /* not _LIBC */ - --#if __GNUC__ >= 4 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 1) --# define __attribute(arg) __attribute__ (arg) --#else --# define __attribute(arg) -+#if __GNUC__ < 3 + (__GNUC_MINOR__ < 1) -+# define __attribute__(arg) - #endif - - typedef __re_idx_t Idx; -@@ -429,7 +461,7 @@ static void build_upper_buffer (re_strin - static void re_string_translate_buffer (re_string_t *pstr) internal_function; - static unsigned int re_string_context_at (const re_string_t *input, Idx idx, - int eflags) -- internal_function __attribute ((pure)); -+ internal_function __attribute__ ((pure)); - #endif - #define re_string_peek_byte(pstr, offset) \ - ((pstr)->mbs[(pstr)->cur_idx + offset]) -@@ -448,7 +480,9 @@ static unsigned int re_string_context_at - #define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx)) - #define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx)) - --#include <alloca.h> -+#if defined _LIBC || HAVE_ALLOCA -+# include <alloca.h> -+#endif - - #ifndef _LIBC - # if HAVE_ALLOCA -@@ -465,6 +499,12 @@ static unsigned int re_string_context_at - # endif - #endif - -+#ifdef _LIBC -+# define MALLOC_0_IS_NONNULL 1 -+#elif !defined MALLOC_0_IS_NONNULL -+# define MALLOC_0_IS_NONNULL 0 -+#endif -+ - #ifndef MAX - # define MAX(a,b) ((a) < (b) ? (b) : (a)) - #endif -@@ -695,7 +735,7 @@ struct re_dfa_t - #ifdef DEBUG - char* re_str; - #endif -- __libc_lock_define (, lock) -+ lock_define (lock) - }; - - #define re_node_set_init_empty(set) memset (set, '\0', sizeof (re_node_set)) -@@ -767,7 +807,7 @@ bitset_copy (bitset_t dest, const bitset - memcpy (dest, src, sizeof (bitset_t)); - } - --static void -+static void __attribute__ ((unused)) - bitset_not (bitset_t set) - { - int bitset_i; -@@ -779,7 +819,7 @@ bitset_not (bitset_t set) - & ~set[BITSET_WORDS - 1]); - } - --static void -+static void __attribute__ ((unused)) - bitset_merge (bitset_t dest, const bitset_t src) - { - int bitset_i; -@@ -787,7 +827,7 @@ bitset_merge (bitset_t dest, const bitse - dest[bitset_i] |= src[bitset_i]; - } - --static void -+static void __attribute__ ((unused)) - bitset_mask (bitset_t dest, const bitset_t src) - { - int bitset_i; -@@ -798,7 +838,7 @@ bitset_mask (bitset_t dest, const bitset - #ifdef RE_ENABLE_I18N - /* Functions for re_string. */ - static int --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_char_size_at (const re_string_t *pstr, Idx idx) - { - int byte_idx; -@@ -811,7 +851,7 @@ re_string_char_size_at (const re_string_ - } - - static wint_t --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_wchar_at (const re_string_t *pstr, Idx idx) - { - if (pstr->mb_cur_max == 1) -@@ -821,7 +861,7 @@ re_string_wchar_at (const re_string_t *p - - # ifndef NOT_IN_libc - static int --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_elem_size_at (const re_string_t *pstr, Idx idx) - { - # ifdef _LIBC ---- origsrc/sed-4.2.2/lib/regexec.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regexec.c 2013-06-27 18:05:27.268447078 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static reg_errcode_t match_ctx_init (re_match_context_t *cache, int eflags, - Idx n) internal_function; -@@ -200,7 +199,7 @@ static Idx group_nodes_into_DFAstates (c - static bool check_node_accept (const re_match_context_t *mctx, - const re_token_t *node, Idx idx) - internal_function; --static reg_errcode_t extend_buffers (re_match_context_t *mctx) -+static reg_errcode_t extend_buffers (re_match_context_t *mctx, int min_len) - internal_function; - - /* Entry point for POSIX code. */ -@@ -229,9 +228,7 @@ regexec (preg, string, nmatch, pmatch, e - { - reg_errcode_t err; - Idx start, length; --#ifdef _LIBC - re_dfa_t *dfa = preg->buffer; --#endif - - if (eflags & ~(REG_NOTBOL | REG_NOTEOL | REG_STARTEND)) - return REG_BADPAT; -@@ -247,14 +244,14 @@ regexec (preg, string, nmatch, pmatch, e - length = strlen (string); - } - -- __libc_lock_lock (dfa->lock); -+ lock_lock (dfa->lock); - if (preg->no_sub) - err = re_search_internal (preg, string, length, start, length, - length, 0, NULL, eflags); - else - err = re_search_internal (preg, string, length, start, length, - length, nmatch, pmatch, eflags); -- __libc_lock_unlock (dfa->lock); -+ lock_unlock (dfa->lock); - return err != REG_NOERROR; - } - -@@ -422,9 +419,7 @@ re_search_stub (struct re_pattern_buffer - Idx nregs; - regoff_t rval; - int eflags = 0; --#ifdef _LIBC - re_dfa_t *dfa = bufp->buffer; --#endif - Idx last_start = start + range; - - /* Check for out-of-range. */ -@@ -435,7 +430,7 @@ re_search_stub (struct re_pattern_buffer - else if (BE (last_start < 0 || (range < 0 && start <= last_start), 0)) - last_start = 0; - -- __libc_lock_lock (dfa->lock); -+ lock_lock (dfa->lock); - - eflags |= (bufp->not_bol) ? REG_NOTBOL : 0; - eflags |= (bufp->not_eol) ? REG_NOTEOL : 0; -@@ -499,7 +494,7 @@ re_search_stub (struct re_pattern_buffer - } - re_free (pmatch); - out: -- __libc_lock_unlock (dfa->lock); -+ lock_unlock (dfa->lock); - return rval; - } - -@@ -1065,7 +1060,7 @@ prune_impossible_nodes (re_match_context - since initial states may have constraints like "\<", "^", etc.. */ - - static inline re_dfastate_t * --__attribute ((always_inline)) internal_function -+__attribute__ ((always_inline)) internal_function - acquire_init_state_context (reg_errcode_t *err, const re_match_context_t *mctx, - Idx idx) - { -@@ -1177,7 +1172,7 @@ check_matching (re_match_context_t *mctx - || (BE (next_char_idx >= mctx->input.valid_len, 0) - && mctx->input.valid_len < mctx->input.len)) - { -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, next_char_idx + 1); - if (BE (err != REG_NOERROR, 0)) - { - assert (err == REG_ESPACE); -@@ -1757,7 +1752,7 @@ clean_state_log_if_needed (re_match_cont - && mctx->input.valid_len < mctx->input.len)) - { - reg_errcode_t err; -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, next_state_log_idx + 1); - if (BE (err != REG_NOERROR, 0)) - return err; - } -@@ -2814,7 +2809,7 @@ get_subexp (re_match_context_t *mctx, Id - if (bkref_str_off >= mctx->input.len) - break; - -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, bkref_str_off + 1); - if (BE (err != REG_NOERROR, 0)) - return err; - -@@ -3937,6 +3932,7 @@ check_node_accept_bytes (const re_dfa_t - in_collseq = find_collation_sequence_value (pin, elem_len); - } - /* match with range expression? */ -+ /* FIXME: Implement rational ranges here, too. */ - for (i = 0; i < cset->nranges; ++i) - if (cset->range_starts[i] <= in_collseq - && in_collseq <= cset->range_ends[i]) -@@ -3988,18 +3984,9 @@ check_node_accept_bytes (const re_dfa_t - # endif /* _LIBC */ - { - /* match with range expression? */ --#if __GNUC__ >= 2 && ! (__STDC_VERSION__ < 199901L && defined __STRICT_ANSI__) -- wchar_t cmp_buf[] = {L'\0', L'\0', wc, L'\0', L'\0', L'\0'}; --#else -- wchar_t cmp_buf[] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; -- cmp_buf[2] = wc; --#endif - for (i = 0; i < cset->nranges; ++i) - { -- cmp_buf[0] = cset->range_starts[i]; -- cmp_buf[4] = cset->range_ends[i]; -- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 -- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) -+ if (cset->range_starts[i] <= wc && wc <= cset->range_ends[i]) - { - match_len = char_len; - goto check_node_accept_bytes_match; -@@ -4137,7 +4124,7 @@ check_node_accept (const re_match_contex - - static reg_errcode_t - internal_function __attribute_warn_unused_result__ --extend_buffers (re_match_context_t *mctx) -+extend_buffers (re_match_context_t *mctx, int min_len) - { - reg_errcode_t ret; - re_string_t *pstr = &mctx->input; -@@ -4147,8 +4134,10 @@ extend_buffers (re_match_context_t *mctx - <= pstr->bufs_len, 0)) - return REG_ESPACE; - -- /* Double the lengths of the buffers. */ -- ret = re_string_realloc_buffers (pstr, MIN (pstr->len, pstr->bufs_len * 2)); -+ /* Double the lengths of the buffers, but allocate at least MIN_LEN. */ -+ ret = re_string_realloc_buffers (pstr, -+ MAX (min_len, -+ MIN (pstr->len, pstr->bufs_len * 2))); - if (BE (ret != REG_NOERROR, 0)) - return ret; - ---- origsrc/sed-4.2.2/sed/sed.c 2012-03-16 10:13:31.000000000 +0100 -+++ src/sed-4.2.2/sed/sed.c 2013-06-27 18:06:25.592195456 +0200 -@@ -57,7 +57,11 @@ bool follow_symlinks = false; - char *in_place_extension = NULL; - - /* The mode to use to read/write files, either "r"/"w" or "rb"/"wb". */ -+#ifdef HAVE_FOPEN_RT -+char *read_mode = "rt"; -+#else - char *read_mode = "r"; -+#endif - char *write_mode = "w"; - - /* Do we need to be pedantically POSIX compliant? */ diff --git a/dev/build/windows/patches_coq/sed-4.2.2.patch b/dev/build/windows/patches_coq/sed-4.2.2.patch deleted file mode 100644 index c7ccd53c7f..0000000000 --- a/dev/build/windows/patches_coq/sed-4.2.2.patch +++ /dev/null @@ -1,1301 +0,0 @@ ---- origsrc/doc/sed.1 2012-12-22 15:27:13.000000000 +0100 -+++ src/doc/sed.1 2013-06-27 18:10:47.974060492 +0200 -@@ -1,5 +1,5 @@ - .\" DO NOT MODIFY THIS FILE! It was generated by help2man 1.28. --.TH SED "1" "December 2012" "sed 4.2.2" "User Commands" -+.TH SED "1" "June 2013" "sed 4.2.2" "User Commands" - .SH NAME - sed \- stream editor for filtering and transforming text - .SH SYNOPSIS -@@ -40,6 +40,10 @@ follow symlinks when processing in place - .IP - edit files in place (makes backup if SUFFIX supplied) - .HP -+\fB\-b\fR, \fB\-\-binary\fR -+.IP -+open files in binary mode (CR+LFs are not processed specially) -+.HP - \fB\-l\fR N, \fB\-\-line\-length\fR=\fIN\fR - .IP - specify the desired line-wrap length for the `l' command ---- origsrc/lib/regcomp.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regcomp.c 2013-06-27 18:05:27.044448044 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static reg_errcode_t re_compile_internal (regex_t *preg, const char * pattern, - size_t length, reg_syntax_t syntax); -@@ -95,20 +94,20 @@ static reg_errcode_t build_charclass (RE - bitset_t sbcset, - re_charset_t *mbcset, - Idx *char_class_alloc, -- const unsigned char *class_name, -+ const char *class_name, - reg_syntax_t syntax); - #else /* not RE_ENABLE_I18N */ - static reg_errcode_t build_equiv_class (bitset_t sbcset, - const unsigned char *name); - static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans, - bitset_t sbcset, -- const unsigned char *class_name, -+ const char *class_name, - reg_syntax_t syntax); - #endif /* not RE_ENABLE_I18N */ - static bin_tree_t *build_charclass_op (re_dfa_t *dfa, - RE_TRANSLATE_TYPE trans, -- const unsigned char *class_name, -- const unsigned char *extra, -+ const char *class_name, -+ const char *extra, - bool non_match, reg_errcode_t *err); - static bin_tree_t *create_tree (re_dfa_t *dfa, - bin_tree_t *left, bin_tree_t *right, -@@ -293,7 +292,7 @@ weak_alias (__re_compile_fastmap, re_com - #endif - - static inline void --__attribute ((always_inline)) -+__attribute__ ((always_inline)) - re_set_fastmap (char *fastmap, bool icase, int ch) - { - fastmap[ch] = 1; -@@ -587,7 +586,7 @@ weak_alias (__regerror, regerror) - static const bitset_t utf8_sb_map = - { - /* Set the first 128 bits. */ --# ifdef __GNUC__ -+# if defined __GNUC__ && !defined __STRICT_ANSI__ - [0 ... 0x80 / BITSET_WORD_BITS - 1] = BITSET_WORD_MAX - # else - # if 4 * BITSET_WORD_BITS < ASCII_CHARS -@@ -664,7 +663,10 @@ regfree (preg) - { - re_dfa_t *dfa = preg->buffer; - if (BE (dfa != NULL, 1)) -- free_dfa_content (dfa); -+ { -+ lock_fini (dfa->lock); -+ free_dfa_content (dfa); -+ } - preg->buffer = NULL; - preg->allocated = 0; - -@@ -785,6 +787,8 @@ re_compile_internal (regex_t *preg, cons - preg->used = sizeof (re_dfa_t); - - err = init_dfa (dfa, length); -+ if (BE (err == REG_NOERROR && lock_init (dfa->lock) != 0, 0)) -+ err = REG_ESPACE; - if (BE (err != REG_NOERROR, 0)) - { - free_dfa_content (dfa); -@@ -798,8 +802,6 @@ re_compile_internal (regex_t *preg, cons - strncpy (dfa->re_str, pattern, length + 1); - #endif - -- __libc_lock_init (dfa->lock); -- - err = re_string_construct (®exp, pattern, length, preg->translate, - (syntax & RE_ICASE) != 0, dfa); - if (BE (err != REG_NOERROR, 0)) -@@ -807,6 +809,7 @@ re_compile_internal (regex_t *preg, cons - re_compile_internal_free_return: - free_workarea_compile (preg); - re_string_destruct (®exp); -+ lock_fini (dfa->lock); - free_dfa_content (dfa); - preg->buffer = NULL; - preg->allocated = 0; -@@ -839,6 +842,7 @@ re_compile_internal (regex_t *preg, cons - - if (BE (err != REG_NOERROR, 0)) - { -+ lock_fini (dfa->lock); - free_dfa_content (dfa); - preg->buffer = NULL; - preg->allocated = 0; -@@ -954,10 +958,10 @@ static void - internal_function - init_word_char (re_dfa_t *dfa) - { -- dfa->word_ops_used = 1; - int i = 0; - int j; - int ch = 0; -+ dfa->word_ops_used = 1; - if (BE (dfa->map_notascii == 0, 1)) - { - bitset_word_t bits0 = 0x00000000; -@@ -2423,8 +2427,8 @@ parse_expression (re_string_t *regexp, r - case OP_WORD: - case OP_NOTWORD: - tree = build_charclass_op (dfa, regexp->trans, -- (const unsigned char *) "alnum", -- (const unsigned char *) "_", -+ "alnum", -+ "_", - token->type == OP_NOTWORD, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; -@@ -2432,8 +2436,8 @@ parse_expression (re_string_t *regexp, r - case OP_SPACE: - case OP_NOTSPACE: - tree = build_charclass_op (dfa, regexp->trans, -- (const unsigned char *) "space", -- (const unsigned char *) "", -+ "space", -+ "", - token->type == OP_NOTSPACE, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; -@@ -2713,7 +2717,6 @@ build_range_exp (const reg_syntax_t synt - wchar_t wc; - wint_t start_wc; - wint_t end_wc; -- wchar_t cmp_buf[6] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; - - start_ch = ((start_elem->type == SB_CHAR) ? start_elem->opr.ch - : ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0] -@@ -2727,11 +2730,7 @@ build_range_exp (const reg_syntax_t synt - ? __btowc (end_ch) : end_elem->opr.wch); - if (start_wc == WEOF || end_wc == WEOF) - return REG_ECOLLATE; -- cmp_buf[0] = start_wc; -- cmp_buf[4] = end_wc; -- -- if (BE ((syntax & RE_NO_EMPTY_RANGES) -- && wcscoll (cmp_buf, cmp_buf + 4) > 0, 0)) -+ else if (BE ((syntax & RE_NO_EMPTY_RANGES) && start_wc > end_wc, 0)) - return REG_ERANGE; - - /* Got valid collation sequence values, add them as a new entry. -@@ -2772,9 +2771,7 @@ build_range_exp (const reg_syntax_t synt - /* Build the table for single byte characters. */ - for (wc = 0; wc < SBC_MAX; ++wc) - { -- cmp_buf[2] = wc; -- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 -- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) -+ if (start_wc <= wc && wc <= end_wc) - bitset_set (sbcset, wc); - } - } -@@ -2843,40 +2840,29 @@ parse_bracket_exp (re_string_t *regexp, - - /* Local function for parse_bracket_exp used in _LIBC environment. - Seek the collating symbol entry corresponding to NAME. -- Return the index of the symbol in the SYMB_TABLE. */ -+ Return the index of the symbol in the SYMB_TABLE, -+ or -1 if not found. */ - - auto inline int32_t -- __attribute ((always_inline)) -- seek_collating_symbol_entry (name, name_len) -- const unsigned char *name; -- size_t name_len; -- { -- int32_t hash = elem_hash ((const char *) name, name_len); -- int32_t elem = hash % table_size; -- if (symb_table[2 * elem] != 0) -- { -- int32_t second = hash % (table_size - 2) + 1; -- -- do -- { -- /* First compare the hashing value. */ -- if (symb_table[2 * elem] == hash -- /* Compare the length of the name. */ -- && name_len == extra[symb_table[2 * elem + 1]] -- /* Compare the name. */ -- && memcmp (name, &extra[symb_table[2 * elem + 1] + 1], -- name_len) == 0) -- { -- /* Yep, this is the entry. */ -- break; -- } -+ __attribute__ ((always_inline)) -+ seek_collating_symbol_entry (const unsigned char *name, size_t name_len) -+ { -+ int32_t elem; - -- /* Next entry. */ -- elem += second; -- } -- while (symb_table[2 * elem] != 0); -- } -- return elem; -+ for (elem = 0; elem < table_size; elem++) -+ if (symb_table[2 * elem] != 0) -+ { -+ int32_t idx = symb_table[2 * elem + 1]; -+ /* Skip the name of collating element name. */ -+ idx += 1 + extra[idx]; -+ if (/* Compare the length of the name. */ -+ name_len == extra[idx] -+ /* Compare the name. */ -+ && memcmp (name, &extra[idx + 1], name_len) == 0) -+ /* Yep, this is the entry. */ -+ return elem; -+ } -+ return -1; - } - - /* Local function for parse_bracket_exp used in _LIBC environment. -@@ -2884,9 +2870,8 @@ parse_bracket_exp (re_string_t *regexp, - Return the value if succeeded, UINT_MAX otherwise. */ - - auto inline unsigned int -- __attribute ((always_inline)) -- lookup_collation_sequence_value (br_elem) -- bracket_elem_t *br_elem; -+ __attribute__ ((always_inline)) -+ lookup_collation_sequence_value (bracket_elem_t *br_elem) - { - if (br_elem->type == SB_CHAR) - { -@@ -2914,7 +2899,7 @@ parse_bracket_exp (re_string_t *regexp, - int32_t elem, idx; - elem = seek_collating_symbol_entry (br_elem->opr.name, - sym_name_len); -- if (symb_table[2 * elem] != 0) -+ if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; -@@ -2932,7 +2917,7 @@ parse_bracket_exp (re_string_t *regexp, - /* Return the collation sequence value. */ - return *(unsigned int *) (extra + idx); - } -- else if (symb_table[2 * elem] == 0 && sym_name_len == 1) -+ else if (sym_name_len == 1) - { - /* No valid character. Match it as a single byte - character. */ -@@ -2953,12 +2938,9 @@ parse_bracket_exp (re_string_t *regexp, - update it. */ - - auto inline reg_errcode_t -- __attribute ((always_inline)) -- build_range_exp (sbcset, mbcset, range_alloc, start_elem, end_elem) -- re_charset_t *mbcset; -- Idx *range_alloc; -- bitset_t sbcset; -- bracket_elem_t *start_elem, *end_elem; -+ __attribute__ ((always_inline)) -+ build_range_exp (bitset_t sbcset, re_charset_t *mbcset, int *range_alloc, -+ bracket_elem_t *start_elem, bracket_elem_t *end_elem) - { - unsigned int ch; - uint32_t start_collseq; -@@ -2971,6 +2953,7 @@ parse_bracket_exp (re_string_t *regexp, - 0)) - return REG_ERANGE; - -+ /* FIXME: Implement rational ranges here, too. */ - start_collseq = lookup_collation_sequence_value (start_elem); - end_collseq = lookup_collation_sequence_value (end_elem); - /* Check start/end collation sequence values. */ -@@ -3036,26 +3019,23 @@ parse_bracket_exp (re_string_t *regexp, - pointer argument since we may update it. */ - - auto inline reg_errcode_t -- __attribute ((always_inline)) -- build_collating_symbol (sbcset, mbcset, coll_sym_alloc, name) -- re_charset_t *mbcset; -- Idx *coll_sym_alloc; -- bitset_t sbcset; -- const unsigned char *name; -+ __attribute__ ((always_inline)) -+ build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset, -+ Idx *coll_sym_alloc, const unsigned char *name) - { - int32_t elem, idx; - size_t name_len = strlen ((const char *) name); - if (nrules != 0) - { - elem = seek_collating_symbol_entry (name, name_len); -- if (symb_table[2 * elem] != 0) -+ if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; - /* Skip the name of collating element name. */ - idx += 1 + extra[idx]; - } -- else if (symb_table[2 * elem] == 0 && name_len == 1) -+ else if (name_len == 1) - { - /* No valid character, treat it as a normal - character. */ -@@ -3298,7 +3278,8 @@ parse_bracket_exp (re_string_t *regexp, - #ifdef RE_ENABLE_I18N - mbcset, &char_class_alloc, - #endif /* RE_ENABLE_I18N */ -- start_elem.opr.name, syntax); -+ (const char *) start_elem.opr.name, -+ syntax); - if (BE (*err != REG_NOERROR, 0)) - goto parse_bracket_exp_free_return; - break; -@@ -3578,14 +3559,14 @@ static reg_errcode_t - #ifdef RE_ENABLE_I18N - build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, - re_charset_t *mbcset, Idx *char_class_alloc, -- const unsigned char *class_name, reg_syntax_t syntax) -+ const char *class_name, reg_syntax_t syntax) - #else /* not RE_ENABLE_I18N */ - build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, -- const unsigned char *class_name, reg_syntax_t syntax) -+ const char *class_name, reg_syntax_t syntax) - #endif /* not RE_ENABLE_I18N */ - { - int i; -- const char *name = (const char *) class_name; -+ const char *name = class_name; - - /* In case of REG_ICASE "upper" and "lower" match the both of - upper and lower cases. */ -@@ -3659,8 +3640,8 @@ build_charclass (RE_TRANSLATE_TYPE trans - - static bin_tree_t * - build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, -- const unsigned char *class_name, -- const unsigned char *extra, bool non_match, -+ const char *class_name, -+ const char *extra, bool non_match, - reg_errcode_t *err) - { - re_bitset_ptr_t sbcset; ---- origsrc/lib/regex-quote.c 1970-01-01 01:00:00.000000000 +0100 -+++ src/lib/regex-quote.c 2013-06-27 18:05:27.081447884 +0200 -@@ -0,0 +1,216 @@ -+/* Construct a regular expression from a literal string. -+ Copyright (C) 1995, 2010-2013 Free Software Foundation, Inc. -+ Written by Bruno Haible <haible@clisp.cons.org>, 2010. -+ -+ This program is free software: you can redistribute it and/or modify -+ it under the terms of the GNU General Public License as published by -+ the Free Software Foundation; either version 3 of the License, or -+ (at your option) any later version. -+ -+ This program is distributed in the hope that it will be useful, -+ but WITHOUT ANY WARRANTY; without even the implied warranty of -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -+ GNU General Public License for more details. -+ -+ You should have received a copy of the GNU General Public License -+ along with this program. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <config.h> -+ -+/* Specification. */ -+#include "regex-quote.h" -+ -+#include <string.h> -+ -+#include "mbuiter.h" -+#include "xalloc.h" -+ -+/* Characters that are special in a BRE. */ -+static const char bre_special[] = "$^.*[]\\"; -+ -+/* Characters that are special in an ERE. */ -+static const char ere_special[] = "$^.*[]\\+?{}()|"; -+ -+struct regex_quote_spec -+regex_quote_spec_posix (int cflags, bool anchored) -+{ -+ struct regex_quote_spec result; -+ -+ strcpy (result.special, cflags != 0 ? ere_special : bre_special); -+ result.multibyte = true; -+ result.anchored = anchored; -+ -+ return result; -+} -+ -+/* Syntax bit values, defined in GNU <regex.h>. We don't include it here, -+ otherwise this module would need to depend on gnulib module 'regex'. */ -+#define RE_BK_PLUS_QM 0x00000002 -+#define RE_INTERVALS 0x00000200 -+#define RE_LIMITED_OPS 0x00000400 -+#define RE_NEWLINE_ALT 0x00000800 -+#define RE_NO_BK_BRACES 0x00001000 -+#define RE_NO_BK_PARENS 0x00002000 -+#define RE_NO_BK_VBAR 0x00008000 -+ -+struct regex_quote_spec -+regex_quote_spec_gnu (unsigned long /*reg_syntax_t*/ syntax, bool anchored) -+{ -+ struct regex_quote_spec result; -+ char *p; -+ -+ p = result.special; -+ memcpy (p, bre_special, sizeof (bre_special) - 1); -+ p += sizeof (bre_special) - 1; -+ if ((syntax & RE_LIMITED_OPS) == 0 && (syntax & RE_BK_PLUS_QM) == 0) -+ { -+ *p++ = '+'; -+ *p++ = '?'; -+ } -+ if ((syntax & RE_INTERVALS) != 0 && (syntax & RE_NO_BK_BRACES) != 0) -+ { -+ *p++ = '{'; -+ *p++ = '}'; -+ } -+ if ((syntax & RE_NO_BK_PARENS) != 0) -+ { -+ *p++ = '('; -+ *p++ = ')'; -+ } -+ if ((syntax & RE_LIMITED_OPS) == 0 && (syntax & RE_NO_BK_VBAR) != 0) -+ *p++ = '|'; -+ if ((syntax & RE_NEWLINE_ALT) != 0) -+ *p++ = '\n'; -+ *p = '\0'; -+ -+ result.multibyte = true; -+ result.anchored = anchored; -+ -+ return result; -+} -+ -+/* Characters that are special in a PCRE. */ -+static const char pcre_special[] = "$^.*[]\\+?{}()|"; -+ -+/* Options bit values, defined in <pcre.h>. We don't include it here, because -+ it is not a standard header. */ -+#define PCRE_ANCHORED 0x00000010 -+#define PCRE_EXTENDED 0x00000008 -+ -+struct regex_quote_spec -+regex_quote_spec_pcre (int options, bool anchored) -+{ -+ struct regex_quote_spec result; -+ char *p; -+ -+ p = result.special; -+ memcpy (p, bre_special, sizeof (pcre_special) - 1); -+ p += sizeof (pcre_special) - 1; -+ if (options & PCRE_EXTENDED) -+ { -+ *p++ = ' '; -+ *p++ = '\t'; -+ *p++ = '\n'; -+ *p++ = '\v'; -+ *p++ = '\f'; -+ *p++ = '\r'; -+ *p++ = '#'; -+ } -+ *p = '\0'; -+ -+ /* PCRE regular expressions consist of UTF-8 characters of options contains -+ PCRE_UTF8 and of single bytes otherwise. */ -+ result.multibyte = false; -+ /* If options contains PCRE_ANCHORED, the anchoring is implicit. */ -+ result.anchored = (options & PCRE_ANCHORED ? 0 : anchored); -+ -+ return result; -+} -+ -+size_t -+regex_quote_length (const char *string, const struct regex_quote_spec *spec) -+{ -+ const char *special = spec->special; -+ size_t length; -+ -+ length = 0; -+ if (spec->anchored) -+ length += 2; /* for '^' at the beginning and '$' at the end */ -+ if (spec->multibyte) -+ { -+ mbui_iterator_t iter; -+ -+ for (mbui_init (iter, string); mbui_avail (iter); mbui_advance (iter)) -+ { -+ /* We know that special contains only ASCII characters. */ -+ if (mb_len (mbui_cur (iter)) == 1 -+ && strchr (special, * mbui_cur_ptr (iter))) -+ length += 1; -+ length += mb_len (mbui_cur (iter)); -+ } -+ } -+ else -+ { -+ const char *iter; -+ -+ for (iter = string; *iter != '\0'; iter++) -+ { -+ if (strchr (special, *iter)) -+ length += 1; -+ length += 1; -+ } -+ } -+ -+ return length; -+} -+ -+char * -+regex_quote_copy (char *p, const char *string, const struct regex_quote_spec *spec) -+{ -+ const char *special = spec->special; -+ -+ if (spec->anchored) -+ *p++ = '^'; -+ if (spec->multibyte) -+ { -+ mbui_iterator_t iter; -+ -+ for (mbui_init (iter, string); mbui_avail (iter); mbui_advance (iter)) -+ { -+ /* We know that special contains only ASCII characters. */ -+ if (mb_len (mbui_cur (iter)) == 1 -+ && strchr (special, * mbui_cur_ptr (iter))) -+ *p++ = '\\'; -+ memcpy (p, mbui_cur_ptr (iter), mb_len (mbui_cur (iter))); -+ p += mb_len (mbui_cur (iter)); -+ } -+ } -+ else -+ { -+ const char *iter; -+ -+ for (iter = string; *iter != '\0'; iter++) -+ { -+ if (strchr (special, *iter)) -+ *p++ = '\\'; -+ *p++ = *iter++; -+ } -+ } -+ if (spec->anchored) -+ *p++ = '$'; -+ -+ return p; -+} -+ -+char * -+regex_quote (const char *string, const struct regex_quote_spec *spec) -+{ -+ size_t length = regex_quote_length (string, spec); -+ char *result = XNMALLOC (length + 1, char); -+ char *p; -+ -+ p = result; -+ p = regex_quote_copy (p, string, spec); -+ *p = '\0'; -+ return result; -+} ---- origsrc/lib/regex-quote.h 1970-01-01 01:00:00.000000000 +0100 -+++ src/lib/regex-quote.h 2013-06-27 18:05:27.112447751 +0200 -@@ -0,0 +1,88 @@ -+/* Construct a regular expression from a literal string. -+ Copyright (C) 1995, 2010-2013 Free Software Foundation, Inc. -+ Written by Bruno Haible <haible@clisp.cons.org>, 2010. -+ -+ This program is free software: you can redistribute it and/or modify -+ it under the terms of the GNU General Public License as published by -+ the Free Software Foundation; either version 3 of the License, or -+ (at your option) any later version. -+ -+ This program is distributed in the hope that it will be useful, -+ but WITHOUT ANY WARRANTY; without even the implied warranty of -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -+ GNU General Public License for more details. -+ -+ You should have received a copy of the GNU General Public License -+ along with this program. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#ifndef _REGEX_QUOTE_H -+#define _REGEX_QUOTE_H -+ -+#include <stddef.h> -+#include <stdbool.h> -+ -+ -+/* Specifies a quotation task for converting a fixed string to a regular -+ expression pattern. */ -+struct regex_quote_spec -+{ -+ /* True if the regular expression pattern consists of multibyte characters -+ (in the encoding given by the LC_CTYPE category of the locale), -+ false if it consists of single bytes or UTF-8 characters. */ -+ unsigned int /*bool*/ multibyte : 1; -+ /* True if the regular expression pattern shall match only entire lines. */ -+ unsigned int /*bool*/ anchored : 1; -+ /* Set of characters that need to be escaped (all ASCII), as a -+ NUL-terminated string. */ -+ char special[30 + 1]; -+}; -+ -+ -+/* Creates a quotation task that produces a POSIX regular expression, that is, -+ a pattern that can be compiled with regcomp(). -+ CFLAGS can be 0 or REG_EXTENDED. -+ If it is 0, the result is a Basic Regular Expression (BRE) -+ <http://www.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap09.html#tag_09_03>. -+ If it is REG_EXTENDED, the result is an Extended Regular Expression (ERE) -+ <http://www.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap09.html#tag_09_04>. -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_posix (int cflags, bool anchored); -+ -+/* Creates a quotation task that produces a regular expression that can be -+ compiled with the GNU API function re_compile_pattern(). -+ SYNTAX describes the syntax of the regular expression (such as -+ RE_SYNTAX_POSIX_BASIC, RE_SYNTAX_POSIX_EXTENDED, RE_SYNTAX_EMACS, all -+ defined in <regex.h>). It must be the same value as 're_syntax_options' -+ at the moment of the re_compile_pattern() call. -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_gnu (unsigned long /*reg_syntax_t*/ syntax, bool anchored); -+ -+/* Creates a quotation task that produces a PCRE regular expression, that is, -+ a pattern that can be compiled with pcre_compile(). -+ OPTIONS is the same value as the second argument passed to pcre_compile(). -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_pcre (int options, bool anchored); -+ -+ -+/* Returns the number of bytes needed for the quoted string. */ -+extern size_t -+ regex_quote_length (const char *string, const struct regex_quote_spec *spec); -+ -+/* Copies the quoted string to p and returns the incremented p. -+ There must be room for regex_quote_length (string, spec) + 1 bytes at p. */ -+extern char * -+ regex_quote_copy (char *p, -+ const char *string, const struct regex_quote_spec *spec); -+ -+/* Returns the freshly allocated quoted string. */ -+extern char * -+ regex_quote (const char *string, const struct regex_quote_spec *spec); -+ -+ -+#endif /* _REGEX_QUOTE_H */ ---- origsrc/lib/regex.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regex.c 2013-06-27 18:05:27.138447639 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _LIBC - # include <config.h> -@@ -25,6 +24,7 @@ - # pragma GCC diagnostic ignored "-Wsuggest-attribute=pure" - # endif - # if (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) || 4 < __GNUC__ -+# pragma GCC diagnostic ignored "-Wold-style-definition" - # pragma GCC diagnostic ignored "-Wtype-limits" - # endif - #endif ---- origsrc/lib/regex.h 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regex.h 2013-06-27 18:05:27.168447509 +0200 -@@ -1,23 +1,22 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Definitions for data structures and routines for the regular - expression library. -- Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2012 -- Free Software Foundation, Inc. -+ Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2013 Free Software -+ Foundation, Inc. - This file is part of the GNU C Library. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _REGEX_H - #define _REGEX_H 1 ---- origsrc/lib/regex_internal.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regex_internal.c 2013-06-27 18:05:27.199447375 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static void re_string_construct_common (const char *str, Idx len, - re_string_t *pstr, -@@ -835,7 +834,7 @@ re_string_reconstruct (re_string_t *pstr - } - - static unsigned char --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_string_peek_byte_case (const re_string_t *pstr, Idx idx) - { - int ch; -@@ -975,7 +974,7 @@ re_node_set_alloc (re_node_set *set, Idx - set->alloc = size; - set->nelem = 0; - set->elems = re_malloc (Idx, size); -- if (BE (set->elems == NULL, 0)) -+ if (BE (set->elems == NULL, 0) && (MALLOC_0_IS_NONNULL || size != 0)) - return REG_ESPACE; - return REG_NOERROR; - } -@@ -1355,7 +1354,7 @@ re_node_set_insert_last (re_node_set *se - Return true if SET1 and SET2 are equivalent. */ - - static bool --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_node_set_compare (const re_node_set *set1, const re_node_set *set2) - { - Idx i; -@@ -1370,7 +1369,7 @@ re_node_set_compare (const re_node_set * - /* Return (idx + 1) if SET contains the element ELEM, return 0 otherwise. */ - - static Idx --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_node_set_contains (const re_node_set *set, Idx elem) - { - __re_size_t idx, right, mid; -@@ -1444,11 +1443,9 @@ re_dfa_add_node (re_dfa_t *dfa, re_token - dfa->nodes[dfa->nodes_len] = token; - dfa->nodes[dfa->nodes_len].constraint = 0; - #ifdef RE_ENABLE_I18N -- { -- int type = token.type; - dfa->nodes[dfa->nodes_len].accept_mb = -- (type == OP_PERIOD && dfa->mb_cur_max > 1) || type == COMPLEX_BRACKET; -- } -+ ((token.type == OP_PERIOD && dfa->mb_cur_max > 1) -+ || token.type == COMPLEX_BRACKET); - #endif - dfa->nexts[dfa->nodes_len] = REG_MISSING; - re_node_set_init_empty (dfa->edests + dfa->nodes_len); ---- origsrc/lib/regex_internal.h 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regex_internal.h 2013-06-27 18:05:27.230447242 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _REGEX_INTERNAL_H - #define _REGEX_INTERNAL_H 1 -@@ -28,21 +27,54 @@ - #include <string.h> - - #include <langinfo.h> --#ifndef _LIBC --# include "localcharset.h" --#endif - #include <locale.h> - #include <wchar.h> - #include <wctype.h> - #include <stdbool.h> - #include <stdint.h> --#if defined _LIBC -+ -+#ifdef _LIBC - # include <bits/libc-lock.h> -+# define lock_define(name) __libc_lock_define (, name) -+# define lock_init(lock) (__libc_lock_init (lock), 0) -+# define lock_fini(lock) 0 -+# define lock_lock(lock) __libc_lock_lock (lock) -+# define lock_unlock(lock) __libc_lock_unlock (lock) -+#elif defined GNULIB_LOCK -+# include "glthread/lock.h" -+ /* Use gl_lock_define if empty macro arguments are known to work. -+ Otherwise, fall back on less-portable substitutes. */ -+# if ((defined __GNUC__ && !defined __STRICT_ANSI__) \ -+ || (defined __STDC_VERSION__ && 199901L <= __STDC_VERSION__)) -+# define lock_define(name) gl_lock_define (, name) -+# elif USE_POSIX_THREADS -+# define lock_define(name) pthread_mutex_t name; -+# elif USE_PTH_THREADS -+# define lock_define(name) pth_mutex_t name; -+# elif USE_SOLARIS_THREADS -+# define lock_define(name) mutex_t name; -+# elif USE_WINDOWS_THREADS -+# define lock_define(name) gl_lock_t name; -+# else -+# define lock_define(name) -+# endif -+# define lock_init(lock) glthread_lock_init (&(lock)) -+# define lock_fini(lock) glthread_lock_destroy (&(lock)) -+# define lock_lock(lock) glthread_lock_lock (&(lock)) -+# define lock_unlock(lock) glthread_lock_unlock (&(lock)) -+#elif defined GNULIB_PTHREAD -+# include <pthread.h> -+# define lock_define(name) pthread_mutex_t name; -+# define lock_init(lock) pthread_mutex_init (&(lock), 0) -+# define lock_fini(lock) pthread_mutex_destroy (&(lock)) -+# define lock_lock(lock) pthread_mutex_lock (&(lock)) -+# define lock_unlock(lock) pthread_mutex_unlock (&(lock)) - #else --# define __libc_lock_define(CLASS,NAME) --# define __libc_lock_init(NAME) do { } while (0) --# define __libc_lock_lock(NAME) do { } while (0) --# define __libc_lock_unlock(NAME) do { } while (0) -+# define lock_define(name) -+# define lock_init(lock) 0 -+# define lock_fini(lock) 0 -+# define lock_lock(lock) ((void) 0) -+# define lock_unlock(lock) ((void) 0) - #endif - - /* In case that the system doesn't have isblank(). */ -@@ -65,7 +97,7 @@ - # ifdef _LIBC - # undef gettext - # define gettext(msgid) \ -- INTUSE(__dcgettext) (_libc_intl_domainname, msgid, LC_MESSAGES) -+ __dcgettext (_libc_intl_domainname, msgid, LC_MESSAGES) - # endif - #else - # define gettext(msgid) (msgid) -@@ -101,6 +133,8 @@ - - /* Rename to standard API for using out of glibc. */ - #ifndef _LIBC -+# undef __wctype -+# undef __iswctype - # define __wctype wctype - # define __iswctype iswctype - # define __btowc btowc -@@ -110,10 +144,8 @@ - # define attribute_hidden - #endif /* not _LIBC */ - --#if __GNUC__ >= 4 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 1) --# define __attribute(arg) __attribute__ (arg) --#else --# define __attribute(arg) -+#if __GNUC__ < 3 + (__GNUC_MINOR__ < 1) -+# define __attribute__(arg) - #endif - - typedef __re_idx_t Idx; -@@ -429,7 +461,7 @@ static void build_upper_buffer (re_strin - static void re_string_translate_buffer (re_string_t *pstr) internal_function; - static unsigned int re_string_context_at (const re_string_t *input, Idx idx, - int eflags) -- internal_function __attribute ((pure)); -+ internal_function __attribute__ ((pure)); - #endif - #define re_string_peek_byte(pstr, offset) \ - ((pstr)->mbs[(pstr)->cur_idx + offset]) -@@ -448,7 +480,9 @@ static unsigned int re_string_context_at - #define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx)) - #define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx)) - --#include <alloca.h> -+#if defined _LIBC || HAVE_ALLOCA -+# include <alloca.h> -+#endif - - #ifndef _LIBC - # if HAVE_ALLOCA -@@ -465,6 +499,12 @@ static unsigned int re_string_context_at - # endif - #endif - -+#ifdef _LIBC -+# define MALLOC_0_IS_NONNULL 1 -+#elif !defined MALLOC_0_IS_NONNULL -+# define MALLOC_0_IS_NONNULL 0 -+#endif -+ - #ifndef MAX - # define MAX(a,b) ((a) < (b) ? (b) : (a)) - #endif -@@ -695,7 +735,7 @@ struct re_dfa_t - #ifdef DEBUG - char* re_str; - #endif -- __libc_lock_define (, lock) -+ lock_define (lock) - }; - - #define re_node_set_init_empty(set) memset (set, '\0', sizeof (re_node_set)) -@@ -767,7 +807,7 @@ bitset_copy (bitset_t dest, const bitset - memcpy (dest, src, sizeof (bitset_t)); - } - --static void -+static void __attribute__ ((unused)) - bitset_not (bitset_t set) - { - int bitset_i; -@@ -779,7 +819,7 @@ bitset_not (bitset_t set) - & ~set[BITSET_WORDS - 1]); - } - --static void -+static void __attribute__ ((unused)) - bitset_merge (bitset_t dest, const bitset_t src) - { - int bitset_i; -@@ -787,7 +827,7 @@ bitset_merge (bitset_t dest, const bitse - dest[bitset_i] |= src[bitset_i]; - } - --static void -+static void __attribute__ ((unused)) - bitset_mask (bitset_t dest, const bitset_t src) - { - int bitset_i; -@@ -798,7 +838,7 @@ bitset_mask (bitset_t dest, const bitset - #ifdef RE_ENABLE_I18N - /* Functions for re_string. */ - static int --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_char_size_at (const re_string_t *pstr, Idx idx) - { - int byte_idx; -@@ -811,7 +851,7 @@ re_string_char_size_at (const re_string_ - } - - static wint_t --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_wchar_at (const re_string_t *pstr, Idx idx) - { - if (pstr->mb_cur_max == 1) -@@ -821,7 +861,7 @@ re_string_wchar_at (const re_string_t *p - - # ifndef NOT_IN_libc - static int --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_elem_size_at (const re_string_t *pstr, Idx idx) - { - # ifdef _LIBC ---- origsrc/lib/regexec.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regexec.c 2013-06-27 18:05:27.268447078 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static reg_errcode_t match_ctx_init (re_match_context_t *cache, int eflags, - Idx n) internal_function; -@@ -200,7 +199,7 @@ static Idx group_nodes_into_DFAstates (c - static bool check_node_accept (const re_match_context_t *mctx, - const re_token_t *node, Idx idx) - internal_function; --static reg_errcode_t extend_buffers (re_match_context_t *mctx) -+static reg_errcode_t extend_buffers (re_match_context_t *mctx, int min_len) - internal_function; - - /* Entry point for POSIX code. */ -@@ -229,9 +228,7 @@ regexec (preg, string, nmatch, pmatch, e - { - reg_errcode_t err; - Idx start, length; --#ifdef _LIBC - re_dfa_t *dfa = preg->buffer; --#endif - - if (eflags & ~(REG_NOTBOL | REG_NOTEOL | REG_STARTEND)) - return REG_BADPAT; -@@ -247,14 +244,14 @@ regexec (preg, string, nmatch, pmatch, e - length = strlen (string); - } - -- __libc_lock_lock (dfa->lock); -+ lock_lock (dfa->lock); - if (preg->no_sub) - err = re_search_internal (preg, string, length, start, length, - length, 0, NULL, eflags); - else - err = re_search_internal (preg, string, length, start, length, - length, nmatch, pmatch, eflags); -- __libc_lock_unlock (dfa->lock); -+ lock_unlock (dfa->lock); - return err != REG_NOERROR; - } - -@@ -422,9 +419,7 @@ re_search_stub (struct re_pattern_buffer - Idx nregs; - regoff_t rval; - int eflags = 0; --#ifdef _LIBC - re_dfa_t *dfa = bufp->buffer; --#endif - Idx last_start = start + range; - - /* Check for out-of-range. */ -@@ -435,7 +430,7 @@ re_search_stub (struct re_pattern_buffer - else if (BE (last_start < 0 || (range < 0 && start <= last_start), 0)) - last_start = 0; - -- __libc_lock_lock (dfa->lock); -+ lock_lock (dfa->lock); - - eflags |= (bufp->not_bol) ? REG_NOTBOL : 0; - eflags |= (bufp->not_eol) ? REG_NOTEOL : 0; -@@ -499,7 +494,7 @@ re_search_stub (struct re_pattern_buffer - } - re_free (pmatch); - out: -- __libc_lock_unlock (dfa->lock); -+ lock_unlock (dfa->lock); - return rval; - } - -@@ -1065,7 +1060,7 @@ prune_impossible_nodes (re_match_context - since initial states may have constraints like "\<", "^", etc.. */ - - static inline re_dfastate_t * --__attribute ((always_inline)) internal_function -+__attribute__ ((always_inline)) internal_function - acquire_init_state_context (reg_errcode_t *err, const re_match_context_t *mctx, - Idx idx) - { -@@ -1177,7 +1172,7 @@ check_matching (re_match_context_t *mctx - || (BE (next_char_idx >= mctx->input.valid_len, 0) - && mctx->input.valid_len < mctx->input.len)) - { -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, next_char_idx + 1); - if (BE (err != REG_NOERROR, 0)) - { - assert (err == REG_ESPACE); -@@ -1757,7 +1752,7 @@ clean_state_log_if_needed (re_match_cont - && mctx->input.valid_len < mctx->input.len)) - { - reg_errcode_t err; -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, next_state_log_idx + 1); - if (BE (err != REG_NOERROR, 0)) - return err; - } -@@ -2814,7 +2809,7 @@ get_subexp (re_match_context_t *mctx, Id - if (bkref_str_off >= mctx->input.len) - break; - -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, bkref_str_off + 1); - if (BE (err != REG_NOERROR, 0)) - return err; - -@@ -3937,6 +3932,7 @@ check_node_accept_bytes (const re_dfa_t - in_collseq = find_collation_sequence_value (pin, elem_len); - } - /* match with range expression? */ -+ /* FIXME: Implement rational ranges here, too. */ - for (i = 0; i < cset->nranges; ++i) - if (cset->range_starts[i] <= in_collseq - && in_collseq <= cset->range_ends[i]) -@@ -3988,18 +3984,9 @@ check_node_accept_bytes (const re_dfa_t - # endif /* _LIBC */ - { - /* match with range expression? */ --#if __GNUC__ >= 2 && ! (__STDC_VERSION__ < 199901L && defined __STRICT_ANSI__) -- wchar_t cmp_buf[] = {L'\0', L'\0', wc, L'\0', L'\0', L'\0'}; --#else -- wchar_t cmp_buf[] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; -- cmp_buf[2] = wc; --#endif - for (i = 0; i < cset->nranges; ++i) - { -- cmp_buf[0] = cset->range_starts[i]; -- cmp_buf[4] = cset->range_ends[i]; -- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 -- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) -+ if (cset->range_starts[i] <= wc && wc <= cset->range_ends[i]) - { - match_len = char_len; - goto check_node_accept_bytes_match; -@@ -4137,7 +4124,7 @@ check_node_accept (const re_match_contex - - static reg_errcode_t - internal_function __attribute_warn_unused_result__ --extend_buffers (re_match_context_t *mctx) -+extend_buffers (re_match_context_t *mctx, int min_len) - { - reg_errcode_t ret; - re_string_t *pstr = &mctx->input; -@@ -4147,8 +4134,10 @@ extend_buffers (re_match_context_t *mctx - <= pstr->bufs_len, 0)) - return REG_ESPACE; - -- /* Double the lengths of the buffers. */ -- ret = re_string_realloc_buffers (pstr, MIN (pstr->len, pstr->bufs_len * 2)); -+ /* Double the lengths of the buffers, but allocate at least MIN_LEN. */ -+ ret = re_string_realloc_buffers (pstr, -+ MAX (min_len, -+ MIN (pstr->len, pstr->bufs_len * 2))); - if (BE (ret != REG_NOERROR, 0)) - return ret; - ---- origsrc/sed/sed.c 2012-03-16 10:13:31.000000000 +0100 -+++ src/sed/sed.c 2013-06-27 18:06:25.592195456 +0200 -@@ -57,7 +57,11 @@ bool follow_symlinks = false; - char *in_place_extension = NULL; - - /* The mode to use to read/write files, either "r"/"w" or "rb"/"wb". */ -+#ifdef HAVE_FOPEN_RT -+char *read_mode = "rt"; -+#else - char *read_mode = "r"; -+#endif - char *write_mode = "w"; - - /* Do we need to be pedantically POSIX compliant? */ diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 97d9537508..8bcbd90f0b 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -101,7 +101,7 @@ project geocoq "https://github.com/GeoCoq/GeoCoq" "master" ######################################################################## # Flocq ######################################################################## -project flocq "https://gitlab.inria.fr/flocq/flocq" "master" +project flocq "https://gitlab.inria.fr/flocq/flocq" "flocq-3" ######################################################################## # coq-performance-tests diff --git a/dev/ci/ci-coq_performance_tests.sh b/dev/ci/ci-coq_performance_tests.sh index fde8df8e3d..2fa4d5c776 100755 --- a/dev/ci/ci-coq_performance_tests.sh +++ b/dev/ci/ci-coq_performance_tests.sh @@ -5,4 +5,9 @@ ci_dir="$(dirname "$0")" git_download coq_performance_tests -( cd "${CI_BUILD_DIR}/coq_performance_tests" && make coq perf-Sanity && make validate && make install ) +# run make -k; make again if make fails so that the failing file comes last, so that it's easier to find the error messages in the CI log +function make_full() { + if ! make -k "$@"; then make -k "$@"; exit 1; fi +} + +( cd "${CI_BUILD_DIR}/coq_performance_tests" && make_full coq perf-Sanity && make validate && make install ) diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat deleted file mode 100755 index dc6423332f..0000000000 --- a/dev/ci/gitlab.bat +++ /dev/null @@ -1,141 +0,0 @@ -@ECHO OFF
-
-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:\ci\cygwin*
-ECHO "Currently used target folders"
-DIR C:\ci\coq*
-ECHO "Root folders"
-DIR C:\
-
-if %ARCH% == 32 (
- SET ARCHLONG=i686
- SET SETUP=setup-x86.exe
-)
-
-if %ARCH% == 64 (
- SET ARCHLONG=x86_64
- SET SETUP=setup-x86_64.exe
-)
-
-SET CYGROOT=C:\ci\cygwin%ARCH%
-SET DESTCOQ=C:\ci\coq%ARCH%
-SET CYGCACHE=C:\ci\cache\cgwin
-
-CALL :MakeUniqueFolder %CYGROOT% CYGROOT
-CALL :MakeUniqueFolder %DESTCOQ% DESTCOQ
-
-powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/%SETUP%', '%SETUP%')"
-SET CI_PROJECT_DIR_MFMT=%CI_PROJECT_DIR:\=/%
-SET CI_PROJECT_DIR_CFMT=%CI_PROJECT_DIR_MFMT:C:/=/cygdrive/c/%
-SET COQREGTESTING=Y
-SET PATH=%PATH%;C:\Program Files\7-Zip\;C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin
-
-IF "%WINDOWS%" == "enabled_all_addons" (
- SET EXTRA_ADDONS=^
- -addon=bignums ^
- -addon=equations ^
- -addon=mtac2 ^
- -addon=mathcomp ^
- -addon=menhir ^
- -addon=menhirlib ^
- -addon=compcert ^
- -addon=extlib ^
- -addon=quickchick ^
- -addon=coquelicot ^
- -addon=vst ^
- -addon=aactactics ^
- -addon=flocq ^
- -addon=interval ^
- -addon=gappa_tool ^
- -addon=gappa ^
- -addon=elpi ^
- -addon=HB
-) ELSE (
- SET "EXTRA_ADDONS= "
-)
-
-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% ^
- %EXTRA_ADDONS% ^
- -make=N ^
- -setup %CI_PROJECT_DIR%\%SETUP% || GOTO ErrorCopyLogFilesAndExit
-
-ECHO "Start Artifact Creation"
-TIME /T
-
-mkdir artifacts
-
-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 (
- IF DEFINED WIN_CERTIFICATE_PASSWORD (
- ECHO Signing package
- @signtool sign /f %WIN_CERTIFICATE_PATH% /p %WIN_CERTIFICATE_PASSWORD% dev\nsis\*.exe
- signtool verify /pa dev\nsis\*.exe
- )
-)
-
-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%"
- RMDIR /S /Q "%CYGROOT%"
- ECHO "Cleaning %DESTCOQ%"
- RMDIR /S /Q "%DESTCOQ%"
- 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/ci/platform-windows.bat b/dev/ci/platform-windows.bat new file mode 100755 index 0000000000..513aec5f94 --- /dev/null +++ b/dev/ci/platform-windows.bat @@ -0,0 +1,105 @@ +REM @ECHO OFF
+
+REM SET ARCH=64
+REM SET PLATFORM=https://github.com/coq/platform/archive/v8.13.zip
+REM SET CI_PROJECT_DIR=C:\root
+
+REM This script builds a minimal Windows platform 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:\ci\cygwin*
+ECHO "Currently used target folders"
+DIR C:\ci\coq*
+ECHO "Root folders"
+DIR C:\
+ECHO "Powershell version"
+powershell -Command "Get-Host"
+ECHO "Git installation of Mingw"
+DIR "C:\Program Files\Git\mingw64\bin\*.exe"
+
+ECHO "--------- START -------"
+
+SET CYGROOT=C:\ci\cygwin%ARCH%
+SET CYGCACHE=C:\ci\cache\cgwin
+
+CALL :MakeUniqueFolder %CYGROOT% CYGROOT
+
+SET CI_PROJECT_DIR_MFMT=%CI_PROJECT_DIR:\=/%
+SET CI_PROJECT_DIR_CFMT=%CI_PROJECT_DIR_MFMT:C:/=/cygdrive/c/%
+SET COQREGTESTING=y
+SET PATH=%PATH%;C:\Program Files\7-Zip;C:\Program Files\Git\mingw64\bin
+
+
+ECHO "Downloading %PLATFORM%"
+curl -L -o platform.zip "%PLATFORM%"
+7z x platform.zip
+
+cd platform-*
+
+call coq_platform_make_windows.bat ^
+ -arch=%ARCH% ^
+ -destcyg=%CYGROOT% ^
+ -cygcache=%CYGCACHE% ^
+ -extent=i ^
+ -parallel=p ^
+ -jobs=2 ^
+ -switch=d || GOTO ErrorCopyLogFilesAndExit
+
+cd ..
+
+SET BASH=%CYGROOT%\bin\bash
+
+ECHO "Start Artifact Creation"
+TIME /T
+
+MKDIR %CI_PROJECT_DIR%\artifacts
+%BASH% --login -c "cd coq-platform && windows/create_installer_windows.sh && cp windows_installer/*.exe %CI_PROJECT_DIR_CFMT%/artifacts" || GOTO ErrorCopyLogFilesAndExit
+TIME /T
+
+CALL :CopyLogFiles
+
+ECHO "Finished Artifact Creation"
+TIME /T
+
+CALL :CleanupFolders
+
+ECHO "Finished Cleanup"
+TIME /T
+
+GOTO :EOF
+
+:CopyLogFiles
+ ECHO Copy log files for artifact upload
+ REM This is currently not supported by the opam based build scripts
+ GOTO :EOF
+
+:CleanupFolders
+ ECHO "Cleaning %CYGROOT%"
+ RMDIR /S /Q "%CYGROOT%"
+ 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
+ RMDIR "%UNIQUENAME%"
+ 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/ci/user-overlays/09710-ppedrot-compact-case-repr.sh b/dev/ci/user-overlays/09710-ppedrot-compact-case-repr.sh new file mode 100644 index 0000000000..dc57e6efb9 --- /dev/null +++ b/dev/ci/user-overlays/09710-ppedrot-compact-case-repr.sh @@ -0,0 +1,9 @@ +overlay coq_dpdgraph https://github.com/ppedrot/coq-dpdgraph compact-case-repr 13563 +overlay coqhammer https://github.com/ppedrot/coqhammer compact-case-repr 13563 +overlay elpi https://github.com/ppedrot/coq-elpi compact-case-repr 13563 +overlay equations https://github.com/ppedrot/Coq-Equations compact-case-repr 13563 +overlay metacoq https://github.com/ppedrot/metacoq compact-case-repr 13563 +overlay mtac2 https://github.com/ppedrot/Mtac2 compact-case-repr 13563 +overlay paramcoq https://github.com/ppedrot/paramcoq compact-case-repr 13563 +overlay relation_algebra https://github.com/ppedrot/relation-algebra compact-case-repr 13563 +overlay unicoq https://github.com/ppedrot/unicoq compact-case-repr 13563 diff --git a/dev/ci/user-overlays/13299-jashug-preserve-universes-notation.sh b/dev/ci/user-overlays/13299-jashug-preserve-universes-notation.sh new file mode 100644 index 0000000000..27e7cee42e --- /dev/null +++ b/dev/ci/user-overlays/13299-jashug-preserve-universes-notation.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "13299" ] || [ "$CI_BRANCH" = "preserve-universes-notation" ]; then + + elpi_CI_REF=overlay-universes-in-notations + elpi_CI_GITURL=https://github.com/jashug/coq-elpi + +fi diff --git a/dev/doc/case-repr.md b/dev/doc/case-repr.md new file mode 100644 index 0000000000..e1a78797bd --- /dev/null +++ b/dev/doc/case-repr.md @@ -0,0 +1,122 @@ +## Case representation + +Starting from Coq 8.14, the term representation of pattern-matching uses a +so-called *compact form*. Compared to the previous representation, the major +difference is that all type and term annotations on lambda and let abstractions +that were present in branches and return clause of pattern-matchings were +removed. In order to keep the ability to construct the old expanded form out of +the new compact form, the case node also makes explicit data that was stealthily +present in the expanded return clause, namely universe instances and parameters +of the inductive type being eliminated. + +### ML Representation + +The case node now looks like +``` +Case of + case_info * + Instance.t * (* universe instances of the inductive *) + constr array * (* parameters of the inductive *) + case_return * (* erased return clause *) + case_invert * (* SProp inversion data *) + constr * (* scrutinee *) + case_branch array (* erased branches *) +``` +where +``` +type case_branch = Name.t binder_annot array * constr +type case_return = Name.t binder_annot array * types +``` + +For comparison, pre-8.14 case nodes were defined as follows. +``` +Case of + case_info * + constr * (* annotated return clause *) + case_invert * (* SProp inversion data *) + constr * (* scrutinee *) + constr array (* annotated branches *) +``` + +### Typing Rules and Invariants + +Disregarding the `case_info` cache and the SProp inversion, the typing rules for +the case node can be given as follows. + +Provided +- Γ ⊢ c : Ind@{u} pms Indices +- Inductive Ind@{i} Δ : forall Θ, Type := cᵢ : forall Ξᵢ, Ind Δ Aᵢ +- Γ, Θ@{i := u}{Δ := pms} ⊢ p : Type +- Γ, Ξᵢ@{i := u}{Δ := pms} ⊢ snd brᵢ : p{Θ := Aᵢ{Δ := pms}} + +Then Γ ⊢ Case (_, u, pms, ( _, p), _, c, br) : p{Θ := Indices} + +In particular, this implies that Γ ⊢ pms : Δ@{i := u}. Parameters are stored in +the same order as in the application node. + +The u universe instance must be a valid instance for the corresponding +inductive type, in particular their length must coincide. + +The `Name.t binder_annot array` appearing both in the return clause and +in the branches must satisfy these invariants: +- For branches, it must have the same length as the corresponding Ξᵢ context +(including let-ins) +- For the return clause, it must have the same length as the context +Θ, self : Ind@{u} pms Θ (including let-ins). The last variable appears as +the term being destructed and corresponds to the variable introduced by the +"as" clause of the user-facing syntax. +- The relevance annotations must match with the corresponding sort of the +variable from the context. + +Note that the annotated variable array is reversed w.r.t. the context, +i.e. variables appear left to right as in standard practice. + +Let-bindings can appear in Δ, Θ or Ξᵢ, since they are arbitrary +contexts. As a general rule, let bindings appear as binders but not as +instances. That is, they MUST appear in the variable array, but they MUST NOT +appear in the parameter array. + +Example: +``` +Inductive foo (X := tt) : forall (Y := X), Type := Foo : forall (Z := X), foo. + +Definition case (x : foo) : unit := match x as x₀ in foo with Foo _ z => z end +``` +The case node of the `case` function is represented as +``` +Case ( + _, + Instance.empty, + [||], + ([|(Y, Relevant); (x₀, Relevant)|], unit), (* let (Y := tt) in fun (x₀ : foo) => unit *) + NoInvert, + #1, + [| + ([|(z, Relevant)|], #1) (* let z := tt in z *) + |] +) +``` + +This choice of representation for let-bindings requires access to the +environment in some cases, e.g. to compute branch reduction. There is a +fast-path for non-let-containing inductive types though, which are the vast +majority. + +### Porting plugins + +The conversion functions from and to the expanded form are: +- `[Inductive, EConstr].expand_case` which goes from the compact to the expanded +form and cannot fail (assuming the term was well-typed) +- `[Inductive, EConstr].contract_case` which goes the other way and will +raise anomalies if the expanded forms are not fully eta-expanded. + +As such, it is always painless to convert to the old representation. Converting +the other way, you must ensure that all the terms you provide the +compatibility function with are fully eta-expanded, **including let-bindings**. +This works as expected for the common case with eta-expanded branches but will +fail for plugins that generate non-eta-expanded branches. + +Some other useful variants of these functions are: +- `Inductive.expand_case_specif` +- `EConstr.annotate_case` +- `EConstr.expand_branch` diff --git a/dev/include_printers b/dev/include_printers index 7583762970..414468ca65 100644 --- a/dev/include_printers +++ b/dev/include_printers @@ -54,4 +54,6 @@ #install_printer (* fconstr *) ppfconstr;; +#install_printer (* fsubst *) ppfsubst;; + #install_printer (* Future.computation *) ppfuture;; diff --git a/dev/top_printers.dbg b/dev/top_printers.dbg index bfc186c862..fe95a59d9b 100644 --- a/dev/top_printers.dbg +++ b/dev/top_printers.dbg @@ -23,6 +23,7 @@ install_printer Top_printers.ppconstr_expr install_printer Top_printers.ppglob_constr install_printer Top_printers.pppattern install_printer Top_printers.ppfconstr +install_printer Top_printers.ppfsubst install_printer Top_printers.ppnumtokunsigned install_printer Top_printers.ppnumtokunsignednat install_printer Top_printers.ppintset diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 4faa12af79..f3d6239c6f 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -85,6 +85,15 @@ let pppattern = (fun x -> pp(envpp pr_constr_pattern_env x)) let pptype = (fun x -> try pp(envpp (fun env evm t -> pr_ltype_env env evm t) x) with e -> pp (str (Printexc.to_string e))) let ppfconstr c = ppconstr (CClosure.term_of_fconstr c) +let ppfsubst s = + let (s, k) = Esubst.Internal.repr s in + let sep () = str ";" ++ spc () in + let pr = function + | Esubst.Internal.REL n -> str "<#" ++ int n ++ str ">" + | Esubst.Internal.VAL (k, x) -> pr_constr (Vars.lift k (CClosure.term_of_fconstr x)) + in + pp @@ str "[" ++ prlist_with_sep sep pr s ++ str "| " ++ int k ++ str "]" + let ppnumtokunsigned n = pp (NumTok.Unsigned.print n) let ppnumtokunsignednat n = pp (NumTok.UnsignedNat.print n) @@ -231,7 +240,7 @@ let ppuniverseconstraints c = pp (UnivProblem.Set.pr c) let ppuniverse_context_future c = let ctx = Future.force c in ppuniverse_context ctx -let ppuniverses u = pp (UGraph.pr_universes Level.pr u) +let ppuniverses u = pp (UGraph.pr_universes Level.pr (UGraph.repr u)) let ppnamedcontextval e = let env = Global.env () in let sigma = Evd.from_env env in @@ -298,9 +307,9 @@ let constr_display csr = "MutConstruct(("^(MutInd.to_string sp)^","^(string_of_int i)^")," ^","^(universes_display u)^(string_of_int j)^")" | Proj (p, c) -> "Proj("^(Constant.to_string (Projection.constant p))^","^term_display c ^")" - | Case (ci,p,iv,c,bl) -> + | Case (ci,u,pms,(_,p),iv,c,bl) -> "MutCase(<abs>,"^(term_display p)^","^(term_display c)^"," - ^(array_display bl)^")" + ^(array_display (Array.map snd bl))^")" | Fix ((t,i),(lna,tl,bl)) -> "Fix(([|"^(Array.fold_right (fun x i -> (string_of_int x)^(if not(i="") then (";"^i) else "")) t "")^"|],"^(string_of_int i)^")," @@ -411,13 +420,25 @@ let print_pure_constr csr = print_int i; print_string ","; print_int j; print_string ","; universes_display u; print_string ")" - | Case (ci,p,iv,c,bl) -> + | Case (ci,u,pms,p,iv,c,bl) -> + let pr_ctx (nas, c) = + Array.iter (fun na -> print_cut (); name_display na) nas; + print_string " |- "; + box_display c + in open_vbox 0; - print_string "<"; box_display p; print_string ">"; print_cut(); print_string "Case"; - print_space(); box_display c; print_space (); print_string "of"; + print_space(); box_display c; print_space (); + print_cut(); print_string "in"; + print_cut(); print_string "Ind("; + sp_display (fst ci.ci_ind); + print_string ","; print_int (snd ci.ci_ind); print_string ")"; + print_string "@{"; universes_display u; print_string "}"; + Array.iter (fun x -> print_space (); box_display x) pms; + print_cut(); print_string "return <"; pr_ctx p; print_string ">"; + print_cut(); print_string "with"; open_vbox 0; - Array.iter (fun x -> print_cut(); box_display x) bl; + Array.iter (fun x -> print_cut(); pr_ctx x) bl; close_box(); print_cut(); print_string "end"; diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 50495dc0a4..e8ed6c709e 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -52,6 +52,7 @@ val ppconstr_expr : Constrexpr.constr_expr -> unit val ppglob_constr : 'a Glob_term.glob_constr_g -> unit val pppattern : Pattern.constr_pattern -> unit val ppfconstr : CClosure.fconstr -> unit +val ppfsubst : CClosure.fconstr Esubst.subs -> unit val ppnumtokunsigned : NumTok.Unsigned.t -> unit val ppnumtokunsignednat : NumTok.UnsignedNat.t -> unit diff --git a/doc/changelog/01-kernel/13563-compact-case-repr.rst b/doc/changelog/01-kernel/13563-compact-case-repr.rst new file mode 100644 index 0000000000..c8ee9bc1e6 --- /dev/null +++ b/doc/changelog/01-kernel/13563-compact-case-repr.rst @@ -0,0 +1,15 @@ +- **Changed:** + The term representation of pattern-matchings now uses a compact form that + provides a few static guarantees such as eta-expansion of branches and return + clauses and is usually more efficient. The most visible user change is that for + the time being, the :tacn:`destruct` tactic and its variants generate dummy + cuts (β redexes) in the branches of the generated proof. + This can also generate very uncommon backwards incompatibilities, such as a + change of occurrence numbering for subterms, or breakage of unification in + complex situations involving pattern-matchings whose underlying inductive type + declares let-bindings in parameters, arity or constructor types. For ML plugin + developers, an in-depth description of the new representation, as well as + porting tips, can be found in dev/doc/case-repr.md + (`#13563 <https://github.com/coq/coq/pull/13563>`_, + fixes `#3166 <https://github.com/coq/coq/issues/3166>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/04-tactics/13469-no-int-in-fail.rst b/doc/changelog/04-tactics/13469-no-int-in-fail.rst new file mode 100644 index 0000000000..e0fcbb924e --- /dev/null +++ b/doc/changelog/04-tactics/13469-no-int-in-fail.rst @@ -0,0 +1,5 @@ +- **Removed:** + :tacn:`fail` and :tacn:`gfail`, which formerly accepted negative + values as a parameter, now give syntax errors for negative + values (`#13469 <https://github.com/coq/coq/pull/13469>`_, + by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13696-deprecate_at_in_conversion.rst b/doc/changelog/04-tactics/13696-deprecate_at_in_conversion.rst new file mode 100644 index 0000000000..306fe8052d --- /dev/null +++ b/doc/changelog/04-tactics/13696-deprecate_at_in_conversion.rst @@ -0,0 +1,7 @@ +- **Deprecated:** + In :tacn:`change` and :tacn:`change_no_check`, the + `at ... with ...` form is deprecated. Use + `with ... at ...` instead. For `at ... with ... in H |-`, + use `with ... in H at ... |-`. + (`#13696 <https://github.com/coq/coq/pull/13696>`_, + by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13715-lia_implb.rst b/doc/changelog/04-tactics/13715-lia_implb.rst new file mode 100644 index 0000000000..dd61872342 --- /dev/null +++ b/doc/changelog/04-tactics/13715-lia_implb.rst @@ -0,0 +1,2 @@ +- **Added:** + :tacn:`lia` supports the boolean operator `Bool.implb` (`#13715 <https://github.com/coq/coq/pull/13715>`_, by Frédéric Besson). diff --git a/doc/changelog/07-vernac-commands-and-options/13556-master.rst b/doc/changelog/07-vernac-commands-and-options/13556-master.rst deleted file mode 100644 index 05a60026a3..0000000000 --- a/doc/changelog/07-vernac-commands-and-options/13556-master.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Changed:** - The warning `custom-entry-overriden` has been renamed to `custom-entry-overridden` (with two d's). - (`#13556 <https://github.com/coq/coq/pull/13556>`_, - by Simon Friis Vindum). diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index bfdbc4c4db..9495fd0e45 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -107,7 +107,7 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica .. cmd:: Axiom @ident : @term. This command links :token:`term` to the name :token:`term` as its specification in - the global context. The fact asserted by :token:`term` is thus assumed as a + the global environment. The fact asserted by :token:`term` is thus assumed as a postulate. .. cmdv:: Parameter @ident : @term. diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index 3662822a5e..8e72bb4ffd 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -100,7 +100,6 @@ Setting the target language ~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. cmd:: Extraction Language @language - :name: Extraction Language .. insertprodn language language @@ -431,12 +430,10 @@ Additional settings ~~~~~~~~~~~~~~~~~~~ .. opt:: Extraction File Comment @string - :name: Extraction File Comment Provides a comment that is included at the beginning of the output files. .. opt:: Extraction Flag @natural - :name: Extraction Flag Controls which optimizations are used during extraction, providing a finer-grained control than :flag:`Extraction Optimize`. The bits of :token:`natural` are used as a bit mask. diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index af3b61c019..9ac05fab2e 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -101,7 +101,7 @@ morphisms, that are required to be simultaneously monotone on every argument. Morphisms can also be contravariant in one or more of their arguments. -A morphism is contravariant on an argument associated to the relation +A morphism is contravariant on an argument associated with the relation instance :math:`R` if it is covariant on the same argument when the inverse relation :math:`R^{−1}` (``inverse R`` in Coq) is considered. The special arrow ``-->`` is used in signatures for contravariant morphisms. @@ -336,7 +336,7 @@ respective relation instances. in the previous example). Applying ``union_compat`` by hand we are left with the goal ``eq_set (union S S) (union S S)``. -When the relations associated to some arguments are not reflexive, the +When the relations associated with some arguments are not reflexive, the tactic cannot automatically prove the reflexivity goals, that are left to the user. @@ -477,8 +477,8 @@ documentation on :ref:`typeclasses` and the theories files in Classes for further explanations. One can inform the rewrite tactic about morphisms and relations just -by using the typeclass mechanism to declare them using Instance and -Context vernacular commands. Any object of type Proper (the type of +by using the typeclass mechanism to declare them using the :cmd:`Instance` and +:cmd:`Context` commands. Any object of type Proper (the type of morphism declarations) in the local context will also be automatically used by the rewriting tactic to solve constraints. @@ -553,7 +553,7 @@ pass additional arguments such as ``using relation``. be used to replace the first tactic argument with the second one. If omitted, it defaults to the ``DefaultRelation`` instance on the type of the objects. By default, it means the most recent ``Equivalence`` instance - in the environment, but it can be customized by declaring + in the global environment, but it can be customized by declaring new ``DefaultRelation`` instances. As Leibniz equality is a declared equivalence, it will fall back to it if no other relation is declared on a given type. @@ -608,7 +608,6 @@ Deprecated syntax and backward incompatibilities an old development to the new semantics is usually quite simple. .. cmd:: Declare Morphism @one_term : @ident - :name: Declare Morphism Declares a parameter in a module type that is a morphism. @@ -686,7 +685,7 @@ Note that when one does rewriting with a lemma under a binder using variable, as the semantics are different from rewrite where the lemma is first matched on the whole term. With the new :tacn:`setoid_rewrite`, matching is done on each subterm separately and in its local -environment, and all matches are rewritten *simultaneously* by +context, and all matches are rewritten *simultaneously* by default. The semantics of the previous :tacn:`setoid_rewrite` implementation can almost be recovered using the ``at 1`` modifier. diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index 0f0ccd6a20..09b2bb003a 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -202,7 +202,6 @@ Use :n:`:>` instead of :n:`:` before the :undocumented: .. cmd:: SubClass @ident_decl @def_body - :name: SubClass If :n:`@type` is a class :n:`@ident'` applied to some arguments then :n:`@ident` is defined and an identity coercion of name @@ -243,7 +242,6 @@ Activating the Printing of Coercions By default, coercions are not printed. .. table:: Printing Coercion @qualid - :name: Printing Coercion Specifies a set of qualids for which coercions are always displayed. Use the :cmd:`Add` and :cmd:`Remove` commands to update the set of qualids. diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index 28b60878d2..38c4886e0f 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -140,7 +140,6 @@ and checked to be :math:`-1`. ------------------------------------------------------------------- .. tacn:: lra - :name: lra This tactic is searching for *linear* refutations. As a result, this tactic explores a subset of the *Cone* defined as @@ -154,7 +153,6 @@ and checked to be :math:`-1`. --------------------------------------------- .. tacn:: lia - :name: lia This tactic solves linear goals over :g:`Z` by searching for *linear* refutations and cutting planes. :tacn:`lia` provides support for :g:`Z`, :g:`nat`, :g:`positive` and :g:`N` by pre-processing via the :tacn:`zify` tactic. @@ -220,7 +218,6 @@ a proof. -------------------------------------------------- .. tacn:: nra - :name: nra This tactic is an *experimental* proof procedure for non-linear arithmetic. The tactic performs a limited amount of non-linear @@ -241,7 +238,6 @@ proof by abstracting monomials by variables. ---------------------------------------------------------- .. tacn:: nia - :name: nia This tactic is a proof procedure for non-linear integer arithmetic. It performs a pre-processing similar to :tacn:`nra`. The obtained goal is @@ -251,7 +247,6 @@ proof by abstracting monomials by variables. ---------------------------------------------------- .. tacn:: psatz @one_term {? @nat_or_var } - :name: psatz This tactic explores the *Cone* by increasing degrees – hence the depth parameter :token:`nat_or_var`. In theory, such a proof search is complete – if the @@ -281,7 +276,6 @@ obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. ------------------------------------------ .. tacn:: zify - :name: zify This tactic is internally called by :tacn:`lia` to support additional types, e.g., :g:`nat`, :g:`positive` and :g:`N`. Additional support is provided by the following modules: diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index 2b10f5671d..0997c5e868 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -28,7 +28,6 @@ Description of ``omega`` ------------------------ .. tacn:: omega - :name: omega .. deprecated:: 8.12 diff --git a/doc/sphinx/addendum/parallel-proof-processing.rst b/doc/sphinx/addendum/parallel-proof-processing.rst index e824ae152d..ea506cec84 100644 --- a/doc/sphinx/addendum/parallel-proof-processing.rst +++ b/doc/sphinx/addendum/parallel-proof-processing.rst @@ -70,7 +70,7 @@ Coq 8.6 introduced a mechanism for error resilience: in interactive mode Coq is able to completely check a document containing errors instead of bailing out at the first failure. -Two kind of errors are supported: errors occurring in vernacular +Two kind of errors are supported: errors occurring in commands and errors occurring in proofs. To properly recover from a failing tactic, Coq needs to recognize the @@ -89,8 +89,8 @@ kind of proof blocks, and an ML API to add new ones. Caveats ```````` -When a vernacular command fails the subsequent error messages may be -bogus, i.e. caused by the first error. Error resilience for vernacular +When a command fails the subsequent error messages may be +bogus, i.e. caused by the first error. Error resilience for commands can be switched off by passing ``-async-proofs-command-error-resilience off`` to CoqIDE. diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 104f84a253..2b24ced8a1 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -161,7 +161,7 @@ Program Definition A :cmd:`Definition` command with the :attr:`program` attribute types the value term in Russell and generates proof obligations. Once solved using the commands shown below, it binds the -final Coq term to the name :n:`@ident` in the environment. +final Coq term to the name :n:`@ident` in the global environment. :n:`Program Definition @ident : @type := @term` @@ -268,7 +268,6 @@ obligations (e.g. when defining mutually recursive blocks). The optional tactic is replaced by the default one if not specified. .. cmd:: Obligation Tactic := @ltac_expr - :name: Obligation Tactic Sets the default obligation solving tactic applied to all obligations automatically, whether to solve them or when starting to prove one, diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index c93d621048..954c2c1446 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -421,7 +421,7 @@ Error messages: .. exn:: Ring operation should be declared as a morphism. - A setoid associated to the carrier of the ring structure has been found, + A setoid associated with the carrier of the ring structure has been found, but the ring operation should be declared as morphism. See :ref:`tactics-enabled-on-user-provided-relations`. How does it work? diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index 2b1f343e14..8c20e08154 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -19,7 +19,6 @@ Use of |SProp| may be disabled by passing ``-disallow-sprop`` to the Coq program or by turning the :flag:`Allow StrictProp` flag off. .. flag:: Allow StrictProp - :name: Allow StrictProp Enables or disables the use of |SProp|. It is enabled by default. The command-line flag ``-disallow-sprop`` disables |SProp| at @@ -283,7 +282,6 @@ This means that some errors will be delayed until ``Qed``: Abort. .. flag:: Elaboration StrictProp Cumulativity - :name: Elaboration StrictProp Cumulativity Unset this flag (it is on by default) to be strict with regard to :math:`\SProp` cumulativity during elaboration. @@ -320,7 +318,6 @@ so correctly converts ``x`` and ``y``. it to find when your tactics are producing incorrect marks. .. flag:: Cumulative StrictProp - :name: Cumulative StrictProp Set this flag (it is off by default) to make the kernel accept cumulativity between |SProp| and other universes. This makes diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 4143d836c4..8dc0030115 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -160,7 +160,7 @@ Sections and contexts --------------------- To ease developments parameterized by many instances, one can use the -:cmd:`Context` command to introduce these parameters into section contexts, +:cmd:`Context` command to introduce the parameters into the :term:`local context`, it works similarly to the command :cmd:`Variable`, except it accepts any binding context as an argument, so variables can be implicit, and :ref:`implicit-generalization` can be used. @@ -422,7 +422,7 @@ Summary of the commands resolution with the local hypotheses use full conversion during unification. - + The mode hints (see :cmd:`Hint Mode`) associated to a class are + + The mode hints (see :cmd:`Hint Mode`) associated with a class are taken into account by :tacn:`typeclasses eauto`. When a goal does not match any of the declared modes for its head (if any), instead of failing like :tacn:`eauto`, the goal is suspended and @@ -470,7 +470,6 @@ Summary of the commands refinement engine will be able to backtrack. .. tacn:: autoapply @one_term with @ident - :name: autoapply The tactic ``autoapply`` applies :token:`one_term` using the transparency information of the hint database :token:`ident`, and does *no* typeclass resolution. This can @@ -590,7 +589,6 @@ Settings :cmd:`Typeclasses eauto` is another way to set this flag. .. opt:: Typeclasses Depth @natural - :name: Typeclasses Depth Sets the maximum proof search depth. The default is unbounded. :cmd:`Typeclasses eauto` is another way to set this option. @@ -602,7 +600,6 @@ Settings is another way to set this flag. .. opt:: Typeclasses Debug Verbosity @natural - :name: Typeclasses Debug Verbosity Determines how much information is shown for typeclass resolution steps during search. 1 is the default level. 2 shows additional information such as tried tactics and shelving @@ -613,7 +610,6 @@ Typeclasses eauto ~~~~~~~~~~~~~~~~~ .. cmd:: Typeclasses eauto := {? debug } {? ( {| bfs | dfs } ) } {? @natural } - :name: Typeclasses eauto Allows more global customization of the :tacn:`typeclasses eauto` tactic. The options are: diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index bb78b142ca..d0b05a03f9 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -328,7 +328,7 @@ Cumulativity Weak Constraints Global and local universes --------------------------- -Each universe is declared in a global or local environment before it +Each universe is declared in a global or local context before it can be used. To ensure compatibility, every *global* universe is set to be strictly greater than :g:`Set` when it is introduced, while every *local* (i.e. polymorphically quantified) universe is introduced as @@ -617,7 +617,7 @@ definitions in the section sharing a common variable will both get parameterized by the universes produced by the variable declaration. This is in contrast to a “mononorphic” variable which introduces global universes and constraints, making the two definitions depend on -the *same* global universes associated to the variable. +the *same* global universes associated with the variable. It is possible to mix universe polymorphism and monomorphism in sections, except in the following ways: diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index fcb150e3da..d9e4e4f2b3 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -690,6 +690,17 @@ Infrastructure and dependencies by Emilio Jesus Gallego Arias and Vicent Laporte, with help from Frédéric Besson). +Changes in 8.13.0 +~~~~~~~~~~~~~~~~~ + +Commands and options +^^^^^^^^^^^^^^^^^^^^ + +- **Changed:** + The warning `custom-entry-overriden` has been renamed to `custom-entry-overridden` (with two d's). + (`#13556 <https://github.com/coq/coq/pull/13556>`_, + by Simon Friis Vindum). + Version 8.12 ------------ @@ -943,7 +954,7 @@ Notations by Hugo Herbelin). - **Fixed:** Different interpretations in different scopes of the same notation - string can now be associated to different printing formats (`#10832 + string can now be associated with different printing formats (`#10832 <https://github.com/coq/coq/pull/10832>`_, by Hugo Herbelin, fixes `#6092 <https://github.com/coq/coq/issues/6092>`_ and `#7766 <https://github.com/coq/coq/issues/7766>`_). @@ -2222,7 +2233,7 @@ Changes in 8.11+beta1 documentation. (`#10441 <https://github.com/coq/coq/pull/10441>`_, by Pierre-Marie Pédrot) - **Added:** - The :cmd:`Section` vernacular command now accepts the "universes" attribute. In + The :cmd:`Section` command now accepts the "universes" attribute. In addition to setting the section universe polymorphism, it also locally sets the universe polymorphic option inside the section. (`#10441 <https://github.com/coq/coq/pull/10441>`_, by Pierre-Marie Pédrot) @@ -3221,7 +3232,7 @@ Other changes in 8.10+beta1 New `relpre R f` definition for the preimage of a relation R under f (`#9995 <https://github.com/coq/coq/pull/9995>`_, by Georges Gonthier). -- Vernacular commands: +- Commands: - Binders for an :cmd:`Instance` now act more like binders for a :cmd:`Theorem`. Names may not be repeated, and may not overlap with section variable names @@ -3553,7 +3564,7 @@ Changes in 8.10.2 **Notations** -- Fixed an 8.10 regression related to the printing of coercions associated to notations +- Fixed an 8.10 regression related to the printing of coercions associated with notations (`#11090 <https://github.com/coq/coq/pull/11090>`_, fixes `#11033 <https://github.com/coq/coq/issues/11033>`_, by Hugo Herbelin). @@ -3794,7 +3805,7 @@ Focusing - Focusing bracket `{` now supports named goal selectors, e.g. `[x]: {` will focus on a goal (existential variable) named `x`. - As usual, unfocus with `}` once the sub-goal is fully solved. + As usual, unfocus with `}` once the subgoal is fully solved. Specification language @@ -3859,7 +3870,7 @@ Tools please open an issue. We can help set up external maintenance as part of Proof-General, or independently as part of coq-community. -Vernacular Commands +Commands - Removed deprecated commands `Arguments Scope` and `Implicit Arguments` (not the option). Use the `Arguments` command instead. @@ -4130,11 +4141,11 @@ Tactics Focusing - Focusing bracket `{` now supports single-numbered goal selector, - e.g. `2: {` will focus on the second sub-goal. As usual, unfocus - with `}` once the sub-goal is fully solved. + e.g. `2: {` will focus on the second subgoal. As usual, unfocus + with `}` once the subgoal is fully solved. The `Focus` and `Unfocus` commands are now deprecated. -Vernacular Commands +Commands - Proofs ending in "Qed exporting ident, .., ident" are not supported anymore. Constants generated during `abstract` are kept private to the @@ -4508,7 +4519,7 @@ Gallina - Now supporting all kinds of binders, including 'pat, in syntax of record fields. -Vernacular Commands +Commands - Goals context can be printed in a more compact way when `Set Printing Compact Contexts` is activated. @@ -5340,7 +5351,7 @@ Logic the dependent one. To recover the old behavior, explicitly define your inductive types in Set. -Vernacular commands +Commands - A command "Variant" allows to define non-recursive variant types. - The command "Record foo ..." does not generate induction principles @@ -5797,7 +5808,7 @@ API Details of changes in 8.5beta3 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Vernacular commands +Commands - New command "Redirect" to redirect the output of a command to a file. - New command "Undelimit Scope" to remove the delimiter of a scope. @@ -6176,7 +6187,7 @@ Regarding decision tactics, Loïc Pottier maintained nsatz, moving in particular to a typeclass based reification of goals while Frédéric Besson maintained Micromega, adding in particular support for division. -Regarding vernacular commands, Stéphane Glondu provided new commands to +Regarding commands, Stéphane Glondu provided new commands to analyze the structure of type universes. Regarding libraries, a new library about lists of a given length (called @@ -6373,7 +6384,7 @@ Tactics constructor. Last one can mark a constant so that it is unfolded only if the simplified term does not expose a match in head position. -Vernacular commands +Commands - It is now mandatory to have a space (or tabulation or newline or end-of-file) after a "." ending a sentence. @@ -6563,7 +6574,7 @@ Tools Details of changes in 8.4beta2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Vernacular commands +Commands - Commands "Back" and "BackTo" are now handling the proof states. They may perform some extra steps of backtrack to avoid states where the proof @@ -6612,7 +6623,7 @@ CoqIDE Details of changes in 8.4 ~~~~~~~~~~~~~~~~~~~~~~~~~ -Vernacular commands +Commands - The "Reset" command is now supported again in files given to coqc or Load. - "Show Script" now indents again the displayed scripts. It can also work @@ -6916,7 +6927,7 @@ Type classes anonymous instances, declarations giving terms, better handling of sections and [Context]. -Vernacular commands +Commands - New command "Timeout <n> <command>." interprets a command and a timeout interrupts the execution after <n> seconds. @@ -7089,7 +7100,7 @@ implement a new resolution-based version of the tactics dedicated to rewriting on arbitrary transitive relations. Another major improvement of Coq 8.2 is the evolution of the arithmetic -libraries and of the tools associated to them. Benjamin Grégoire and +libraries and of the tools associated with them. Benjamin Grégoire and Laurent Théry contributed a modular library for building arbitrarily large integers from bounded integers while Evgeny Makarov contributed a modular library of abstract natural and integer arithmetic together @@ -7197,7 +7208,7 @@ Language of easily fixed incompatibility in case of manual definition of a recursor in a recursive singleton inductive type]. -Vernacular commands +Commands - Added option Global to "Arguments Scope" for section surviving. - Added option "Unset Elimination Schemes" to deactivate the automatic @@ -7797,7 +7808,7 @@ Syntax - Support for primitive interpretation of string literals - Extended support for Unicode ranges -Vernacular commands +Commands - Added "Print Ltac qualid" to print a user defined tactic. - Added "Print Rewrite HintDb" to print the content of a DB used by @@ -7975,7 +7986,7 @@ Libraries - Acc in Wf.v and clos_refl_trans in Relation_Operators.v now rely on the allowance for recursively non uniform parameters (possible source of incompatibilities: explicit pattern-matching on these - types may require to remove the occurrence associated to their + types may require to remove the occurrence associated with their recursively non uniform parameter). - Coq.List.In_dec has been set transparent (this may exceptionally break proof scripts, set it locally opaque for compatibility). @@ -8194,7 +8205,7 @@ Syntax for arithmetic - Locate applied to a simple string (e.g. "+") searches for all notations containing this string -Vernacular commands +Commands - "Declare ML Module" now allows to import .cma files. This avoids to use a bunch of "Declare ML Module" statements when using several ML files. @@ -8355,7 +8366,7 @@ New concrete syntax - A completely new syntax for terms - A more uniform syntax for tactics and the tactic language -- A few syntactic changes for vernacular commands +- A few syntactic changes for commands - A smart automatic translator translating V8.0 files in old syntax to files valid for V8.0 @@ -8426,7 +8437,7 @@ Known problems of the automatic translation Details of changes in 8.0 ~~~~~~~~~~~~~~~~~~~~~~~~~ -Vernacular commands +Commands - New option "Set Printing All" to deactivate all high-level forms of printing (implicit arguments, coercions, destructing let, diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index bce88cebde..edbc89aad8 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -183,11 +183,8 @@ todo_include_todos = False nitpicky = True nitpick_ignore = [ ('token', token) for token in [ - 'tactic', 'induction_clause', - 'conversion', 'where', - 'oriented_rewriter', 'bindings_with_parameters', 'destruction_arg' ]] @@ -493,3 +490,6 @@ epub_exclude_files = ['search.html'] # navtree options navtree_shift = True + +# since sphinxcontrib-bibtex version 2 we need this +bibtex_bibfiles = [ "biblio.bib" ] diff --git a/doc/sphinx/history.rst b/doc/sphinx/history.rst index c5ef92a1bf..44f2d23801 100644 --- a/doc/sphinx/history.rst +++ b/doc/sphinx/history.rst @@ -954,7 +954,7 @@ Parsing and grammar extension for Time and to write grammar rules abbreviating several commands) (+) - The default parser for actions in the grammar rules (and for - patterns in the pretty-printing rules) is now the one associated to + patterns in the pretty-printing rules) is now the one associated with the grammar (i.e. vernac, tactic or constr); no need then for quotations as in <:vernac:<...>>; to return an "ast", the grammar must be explicitly typed with tag ": ast" or ": ast list", or if a @@ -1346,12 +1346,12 @@ Language instead to simulate the old behaviour of Local (the section part of the name is not kept though) -ML tactic and vernacular commands +ML tactics and commands - "Grammar tactic" and "Grammar vernac" of type "ast" are no longer supported (only "Grammar tactic simple_tactic" of type "tactic" remains available). -- Concrete syntax for ML written vernacular commands and tactics is +- Concrete syntax for ML written commands and tactics is now declared at ML level using camlp4 macros TACTIC EXTEND et VERNAC COMMAND EXTEND. - "Check n c" now "n:Check c", "Eval n ..." now "n:Eval ..." diff --git a/doc/sphinx/introduction.rst b/doc/sphinx/introduction.rst index 06a677d837..0b183d3f3f 100644 --- a/doc/sphinx/introduction.rst +++ b/doc/sphinx/introduction.rst @@ -45,9 +45,9 @@ This manual is organized in three main parts, plus an appendix: translated down to the language of the kernel by means of an "elaboration process". -- **The second part presents the interactive proof mode**, the central +- **The second part presents proof mode**, the central feature of Coq. :ref:`writing-proofs` introduces this interactive - proof mode and the available proof languages. + mode and the available proof languages. :ref:`automatic-tactics` presents some more advanced tactics, while :ref:`writing-tactics` is about the languages that allow a user to combine tactics together and develop new ones. diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 85b04f6df0..1cfd8dac50 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -101,7 +101,7 @@ and it can be applied to any expression of type :math:`\nat`, say :math:`t`, to object :math:`P~t` of type :math:`\Prop`, namely a proposition. Furthermore :g:`forall x:nat, P x` will represent the type of functions -which associate to each natural number :math:`n` an object of type :math:`(P~n)` and +which associate with each natural number :math:`n` an object of type :math:`(P~n)` and consequently represent the type of proofs of the formula “:math:`∀ x.~P(x)`”. @@ -111,51 +111,49 @@ Typing rules ---------------- As objects of type theory, terms are subjected to *type discipline*. -The well typing of a term depends on a global environment and a local -context. - +The well typing of a term depends on a local context and a global environment. .. _Local-context: **Local context.** -A *local context* is an ordered list of *local declarations* of names -which we call *variables*. The declaration of some variable :math:`x` is -either a *local assumption*, written :math:`x:T` (:math:`T` is a type) or a *local -definition*, written :math:`x:=t:T`. We use brackets to write local contexts. -A typical example is :math:`[x:T;~y:=u:U;~z:V]`. Notice that the variables +A :term:`local context` is an ordered list of declarations of *variables*. +The declaration of a variable :math:`x` is +either an *assumption*, written :math:`x:T` (where :math:`T` is a type) or a +*definition*, written :math:`x:=t:T`. Local contexts are written in brackets, +for example :math:`[x:T;~y:=u:U;~z:V]`. The variables declared in a local context must be distinct. If :math:`Γ` is a local context -that declares some :math:`x`, we -write :math:`x ∈ Γ`. By writing :math:`(x:T) ∈ Γ` we mean that either :math:`x:T` is an -assumption in :math:`Γ` or that there exists some :math:`t` such that :math:`x:=t:T` is a -definition in :math:`Γ`. If :math:`Γ` defines some :math:`x:=t:T`, we also write :math:`(x:=t:T) ∈ Γ`. +that declares :math:`x`, we +write :math:`x ∈ Γ`. Writing :math:`(x:T) ∈ Γ` means there is an assumption +or a definition giving the type :math:`T` to :math:`x` in :math:`Γ`. +If :math:`Γ` defines :math:`x:=t:T`, we also write :math:`(x:=t:T) ∈ Γ`. For the rest of the chapter, :math:`Γ::(y:T)` denotes the local context :math:`Γ` enriched with the local assumption :math:`y:T`. Similarly, :math:`Γ::(y:=t:T)` denotes the local context :math:`Γ` enriched with the local definition :math:`(y:=t:T)`. The -notation :math:`[]` denotes the empty local context. By :math:`Γ_1 ; Γ_2` we mean +notation :math:`[]` denotes the empty local context. Writing :math:`Γ_1 ; Γ_2` means concatenation of the local context :math:`Γ_1` and the local context :math:`Γ_2`. - .. _Global-environment: **Global environment.** -A *global environment* is an ordered list of *global declarations*. -Global declarations are either *global assumptions* or *global -definitions*, but also declarations of inductive objects. Inductive -objects themselves declare both inductive or coinductive types and -constructors (see Section :ref:`inductive-definitions`). - -A *global assumption* will be represented in the global environment as -:math:`(c:T)` which assumes the name :math:`c` to be of some type :math:`T`. A *global -definition* will be represented in the global environment as :math:`c:=t:T` -which defines the name :math:`c` to have value :math:`t` and type :math:`T`. We shall call +A :term:`global environment` is an ordered list of *declarations*. +Global declarations are either *assumptions*, *definitions* +or declarations of inductive objects. Inductive +objects declare both constructors and inductive or +coinductive types (see Section :ref:`inductive-definitions`). + +In the global environment, +*assumptions* are written as +:math:`(c:T)`, indicating that :math:`c` is of the type :math:`T`. *Definitions* +are written as :math:`c:=t:T`, indicating that :math:`c` has the value :math:`t` +and type :math:`T`. We shall call such names *constants*. For the rest of the chapter, the :math:`E;~c:T` denotes -the global environment :math:`E` enriched with the global assumption :math:`c:T`. +the global environment :math:`E` enriched with the assumption :math:`c:T`. Similarly, :math:`E;~c:=t:T` denotes the global environment :math:`E` enriched with the -global definition :math:`(c:=t:T)`. +definition :math:`(c:=t:T)`. The rules for inductive definitions (see Section :ref:`inductive-definitions`) have to be considered as assumption -rules to which the following definitions apply: if the name :math:`c` +rules in which the following definitions apply: if the name :math:`c` is declared in :math:`E`, we write :math:`c ∈ E` and if :math:`c:T` or :math:`c:=t:T` is declared in :math:`E`, we write :math:`(c : T) ∈ E`. @@ -315,7 +313,7 @@ following rules. .. note:: We may have :math:`\letin{x}{t:T}{u}` well-typed without having :math:`((λ x:T.~u)~t)` well-typed (where :math:`T` is a type of - :math:`t`). This is because the value :math:`t` associated to + :math:`t`). This is because the value :math:`t` associated with :math:`x` may be used in a conversion rule (see Section :ref:`Conversion-rules`). diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index d061ed41f1..4f54e33758 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -902,7 +902,6 @@ In addition to the powerful ``ring``, ``field`` and ``lra`` tactics (see Chapter :ref:`tactics`), there are also: .. tacn:: discrR - :name: discrR Proves that two real integer constants are different. @@ -916,7 +915,6 @@ tactics (see Chapter :ref:`tactics`), there are also: discrR. .. tacn:: split_Rabs - :name: split_Rabs Allows unfolding the ``Rabs`` constant and splits corresponding conjunctions. @@ -930,7 +928,6 @@ tactics (see Chapter :ref:`tactics`), there are also: intro; split_Rabs. .. tacn:: split_Rmult - :name: split_Rmult Splits a condition that a product is non null into subgoals corresponding to the condition on each operand of the product. diff --git a/doc/sphinx/language/core/assumptions.rst b/doc/sphinx/language/core/assumptions.rst index e86a6f4a67..8dbc1626ba 100644 --- a/doc/sphinx/language/core/assumptions.rst +++ b/doc/sphinx/language/core/assumptions.rst @@ -115,10 +115,10 @@ Section :ref:`explicit-applications`). Assumptions ----------- -Assumptions extend the environment with axioms, parameters, hypotheses +Assumptions extend the global environment with axioms, parameters, hypotheses or variables. An assumption binds an :n:`@ident` to a :n:`@type`. It is accepted -by Coq if and only if this :n:`@type` is a correct type in the environment -preexisting the declaration and if :n:`@ident` was not previously defined in +by Coq only if :n:`@type` is a correct type in the global environment +before the declaration and if :n:`@ident` was not previously defined in the same module. This :n:`@type` is considered to be the type (or specification, or statement) assumed by :n:`@ident` and we say that :n:`@ident` has type :n:`@type`. @@ -141,7 +141,7 @@ has type :n:`@type`. of_type ::= {| : | :> } @type These commands bind one or more :n:`@ident`\(s) to specified :n:`@type`\(s) as their specifications in - the global context. The fact asserted by :n:`@type` (or, equivalently, the existence + the global environment. The fact asserted by :n:`@type` (or, equivalently, the existence of an object of this type) is accepted as a postulate. They accept the :attr:`program` attribute. :cmd:`Axiom`, :cmd:`Conjecture`, :cmd:`Parameter` and their plural forms diff --git a/doc/sphinx/language/core/basic.rst b/doc/sphinx/language/core/basic.rst index 2b262b89c0..0a61c4ce22 100644 --- a/doc/sphinx/language/core/basic.rst +++ b/doc/sphinx/language/core/basic.rst @@ -64,7 +64,7 @@ appending the level to the nonterminal name (as in :n:`@term100` or populated by notations or plugins. Furthermore, some parsing rules are only activated in certain - contexts (:ref:`interactive proof mode <proofhandling>`, + contexts (:ref:`proof mode <proofhandling>`, :ref:`custom entries <custom-entries>`...). .. warning:: @@ -332,9 +332,9 @@ rest of the Coq manual: :term:`terms <term>` and :term:`types tactic - Tactics specify how to transform the current proof state as a + A :production:`tactic` specifies how to transform the current proof state as a step in creating a proof. They are syntactically valid only when - Coq is in proof mode, such as after a :cmd:`Theorem` command + Coq is in :term:`proof mode`, such as after a :cmd:`Theorem` command and before any subsequent proof-terminating command such as :cmd:`Qed`. See :ref:`proofhandling` for more on proof mode. @@ -450,7 +450,6 @@ they appear after a boldface label. They are listed in the :ref:`options_index`. .. cmd:: Set @setting_name {? {| @integer | @string } } - :name: Set If :n:`@setting_name` is a flag, no value may be provided; the flag is set to on. @@ -471,7 +470,6 @@ they appear after a boldface label. They are listed in the Coq versions. .. cmd:: Unset @setting_name - :name: Unset If :n:`@setting_name` is a flag, it is set to off. If :n:`@setting_name` is an option, it is set to its default value. diff --git a/doc/sphinx/language/core/coinductive.rst b/doc/sphinx/language/core/coinductive.rst index cf46580bdb..e742139134 100644 --- a/doc/sphinx/language/core/coinductive.rst +++ b/doc/sphinx/language/core/coinductive.rst @@ -194,7 +194,7 @@ Top-level definitions of co-recursive functions As in the :cmd:`Fixpoint` command, the :n:`with` clause allows simultaneously defining several mutual cofixpoints. - If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. diff --git a/doc/sphinx/language/core/conversion.rst b/doc/sphinx/language/core/conversion.rst index 7395b12339..09c619338b 100644 --- a/doc/sphinx/language/core/conversion.rst +++ b/doc/sphinx/language/core/conversion.rst @@ -47,7 +47,7 @@ refer the interested reader to :cite:`Coq85`. ι-reduction ~~~~~~~~~~~ -A specific conversion rule is associated to the inductive objects in +A specific conversion rule is associated with the inductive objects in the global environment. We shall give later on (see Section :ref:`Well-formed-inductive-definitions`) the precise rules but it just says that a destructor applied to an object built from a @@ -159,7 +159,8 @@ relation :math:`t` reduces to :math:`u` in the global environment reductions β, δ, ι or ζ. We say that two terms :math:`t_1` and :math:`t_2` are -*βδιζη-convertible*, or simply :gdef:`convertible`, or *equivalent*, in the +*βδιζη-convertible*, or simply :gdef:`convertible`, or +:term:`definitionally equal <definitional equality>`, in the global environment :math:`E` and local context :math:`Γ` iff there exist terms :math:`u_1` and :math:`u_2` such that :math:`E[Γ] ⊢ t_1 \triangleright … \triangleright u_1` and :math:`E[Γ] ⊢ t_2 \triangleright … \triangleright u_2` and either :math:`u_1` and diff --git a/doc/sphinx/language/core/definitions.rst b/doc/sphinx/language/core/definitions.rst index 6da1f90ecb..7196c082ed 100644 --- a/doc/sphinx/language/core/definitions.rst +++ b/doc/sphinx/language/core/definitions.rst @@ -56,7 +56,7 @@ has type :n:`@type`. Top-level definitions --------------------- -Definitions extend the environment with associations of names to terms. +Definitions extend the global environment with associations of names to terms. A definition can be seen as a way to give a meaning to a name or as a way to abbreviate a term. In any case, the name can later be replaced at any time by its definition. @@ -82,7 +82,7 @@ Section :ref:`typing-rules`. | {* @binder } : @type reduce ::= Eval @red_expr in - These commands bind :n:`@term` to the name :n:`@ident` in the environment, + These commands bind :n:`@term` to the name :n:`@ident` in the global environment, provided that :n:`@term` is well-typed. They can take the :attr:`local` :term:`attribute`, which makes the defined :n:`@ident` accessible by :cmd:`Import` and its variants only through their fully qualified names. @@ -94,7 +94,7 @@ Section :ref:`typing-rules`. :attr:`bypass_check(universes)`, :attr:`bypass_check(guard)`, and :attr:`using` attributes. - If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. @@ -120,10 +120,11 @@ Section :ref:`typing-rules`. Assertions and proofs --------------------- -An assertion states a proposition (or a type) of which the proof (or an -inhabitant of the type) is interactively built using tactics. The interactive -proof mode is described in Chapter :ref:`proofhandling` and the tactics in -Chapter :ref:`Tactics`. The basic assertion command is: +An assertion states a proposition (or a type) for which the proof (or an +inhabitant of the type) is interactively built using :term:`tactics <tactic>`. +Assertions cause Coq to enter :term:`proof mode` (see :ref:`proofhandling`). +Common tactics are described in the :ref:`writing-proofs` chapter. +The basic assertion command is: .. cmd:: @thm_token @ident_decl {* @binder } : @type {* with @ident_decl {* @binder } : @type } :name: Theorem; Lemma; Fact; Remark; Corollary; Proposition; Property @@ -142,7 +143,7 @@ Chapter :ref:`Tactics`. The basic assertion command is: After the statement is asserted, Coq needs a proof. Once a proof of :n:`@type` under the assumptions represented by :n:`@binder`\s is given and validated, the proof is generalized into a proof of :n:`forall {* @binder }, @type` and - the theorem is bound to the name :n:`@ident` in the environment. + the theorem is bound to the name :n:`@ident` in the global environment. These commands accept the :attr:`program` attribute. See :ref:`program_lemma`. @@ -159,7 +160,7 @@ Chapter :ref:`Tactics`. The basic assertion command is: have to be used on *structurally smaller* arguments (for a :cmd:`Fixpoint`) or be *guarded by a constructor* (for a :cmd:`CoFixpoint`). The verification that recursive proof arguments are correct is done only at the time of registering - the lemma in the environment. To know if the use of induction hypotheses is + the lemma in the global environment. To know if the use of induction hypotheses is correct at some time of the interactive development of a proof, use the command :cmd:`Guarded`. @@ -178,25 +179,24 @@ Chapter :ref:`Tactics`. The basic assertion command is: .. exn:: Nested proofs are discouraged and not allowed by default. This error probably means that you forgot to close the last "Proof." with "Qed." or "Defined.". \ If you really intended to use nested proofs, you can do so by turning the "Nested Proofs Allowed" flag on. - You are asserting a new statement while already being in proof editing mode. + You are asserting a new statement when you're already in proof mode. This feature, called nested proofs, is disabled by default. To activate it, turn the :flag:`Nested Proofs Allowed` flag on. -Proofs start with the keyword :cmd:`Proof`. Then Coq enters the proof editing mode -until the proof is completed. In proof editing mode, the user primarily enters -tactics, which are described in chapter :ref:`Tactics`. The user may also enter -commands to manage the proof editing mode. They are described in Chapter -:ref:`proofhandling`. +Proofs start with the keyword :cmd:`Proof`. Then Coq enters the proof mode +until the proof is completed. In proof mode, the user primarily enters +tactics (see :ref:`writing-proofs`). The user may also enter +commands to manage the proof mode (see :ref:`proofhandling`). When the proof is complete, use the :cmd:`Qed` command so the kernel verifies -the proof and adds it to the environment. +the proof and adds it to the global environment. .. note:: #. Several statements can be simultaneously asserted provided the :flag:`Nested Proofs Allowed` flag was turned on. - #. Not only other assertions but any vernacular command can be given + #. Not only other assertions but any command can be given while in the process of proving a given assertion. In this case, the command is understood as if it would have been given before the statements still to be proved. Nonetheless, this practice is discouraged @@ -211,4 +211,4 @@ the proof and adds it to the environment. side, :cmd:`Qed` (or :cmd:`Defined`) is mandatory to validate a proof. #. One can also use :cmd:`Admitted` in place of :cmd:`Qed` to turn the - current asserted statement into an axiom and exit the proof editing mode. + current asserted statement into an axiom and exit proof mode. diff --git a/doc/sphinx/language/core/inductive.rst b/doc/sphinx/language/core/inductive.rst index 4bee7cc1b1..4e892f709d 100644 --- a/doc/sphinx/language/core/inductive.rst +++ b/doc/sphinx/language/core/inductive.rst @@ -36,7 +36,7 @@ Inductive types :attr:`private(matching)` attributes. Mutually inductive types can be defined by including multiple :n:`@inductive_definition`\s. - The :n:`@ident`\s are simultaneously added to the environment before the types of constructors are checked. + The :n:`@ident`\s are simultaneously added to the global environment before the types of constructors are checked. Each :n:`@ident` can be used independently thereafter. See :ref:`mutually_inductive_types`. @@ -86,7 +86,7 @@ A simple inductive type belongs to a universe that is a simple :n:`@sort`. The type nat is defined as the least :g:`Set` containing :g:`O` and closed by the :g:`S` constructor. The names :g:`nat`, :g:`O` and :g:`S` are added to the - environment. + global environment. This definition generates four elimination principles: :g:`nat_rect`, :g:`nat_ind`, :g:`nat_rec` and :g:`nat_sind`. The type of :g:`nat_ind` is: @@ -413,7 +413,7 @@ constructions. It is especially useful when defining functions over mutually defined inductive types. Example: :ref:`Mutual Fixpoints<example_mutual_fixpoints>`. - If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. @@ -636,7 +636,7 @@ contains an inductive definition. .. example:: - Provided that our environment :math:`E` contains inductive definitions we showed before, + Provided that our global environment :math:`E` contains inductive definitions we showed before, these two inference rules above enable us to conclude that: .. math:: diff --git a/doc/sphinx/language/core/modules.rst b/doc/sphinx/language/core/modules.rst index 6d96e15202..93d70c773f 100644 --- a/doc/sphinx/language/core/modules.rst +++ b/doc/sphinx/language/core/modules.rst @@ -283,7 +283,6 @@ are now available through the dot notation. Check A.B.U. .. cmd:: Export {+ @filtered_import } - :name: Export Similar to :cmd:`Import`, except that when the module containing this command is imported, the :n:`{+ @qualid }` are imported as well. @@ -465,7 +464,7 @@ We also need additional typing judgments: + :math:`\WFT{E}{S}`, denoting that a structure :math:`S` is well-formed, + :math:`\WTM{E}{p}{S}`, denoting that the module pointed by :math:`p` has type :math:`S` in - environment :math:`E`. + the global environment :math:`E`. + :math:`\WEV{E}{S}{\ovl{S}}`, denoting that a structure :math:`S` is evaluated to a structure :math:`S` in weak head normal form. + :math:`\WS{E}{S_1}{S_2}` , denoting that a structure :math:`S_1` is a subtype of a @@ -965,7 +964,7 @@ names. A logical prefix Lib can be associated with a physical path using the command line option ``-Q`` `path` ``Lib``. All subfolders of path are -recursively associated to the logical path ``Lib`` extended with the +recursively associated with the logical path ``Lib`` extended with the corresponding suffix coming from the physical path. For instance, the folder ``path/fOO/Bar`` maps to ``Lib.fOO.Bar``. Subdirectories corresponding to invalid Coq identifiers are skipped, and, by convention, @@ -973,7 +972,7 @@ subdirectories named ``CVS`` or ``_darcs`` are skipped too. Thanks to this mechanism, ``.vo`` files are made available through the logical name of the folder they are in, extended with their own -basename. For example, the name associated to the file +basename. For example, the name associated with the file ``path/fOO/Bar/File.vo`` is ``Lib.fOO.Bar.File``. The same caveat applies for invalid identifiers. When compiling a source file, the ``.vo`` file stores its logical name, so that an error is issued if it is loaded with the diff --git a/doc/sphinx/language/core/records.rst b/doc/sphinx/language/core/records.rst index 7eedbcd59a..6671c67fb2 100644 --- a/doc/sphinx/language/core/records.rst +++ b/doc/sphinx/language/core/records.rst @@ -119,13 +119,11 @@ The following settings let you control the display format for types: You can override the display format for specified types by adding entries to these tables: .. table:: Printing Record @qualid - :name: Printing Record Specifies a set of qualids which are displayed as records. Use the :cmd:`Add` and :cmd:`Remove` commands to update the set of qualids. .. table:: Printing Constructor @qualid - :name: Printing Constructor Specifies a set of qualids which are displayed as constructors. Use the :cmd:`Add` and :cmd:`Remove` commands to update the set of qualids. @@ -208,7 +206,7 @@ other arguments are the parameters of the inductive type. This message is followed by an explanation of this impossibility. There may be three reasons: - #. The name :token:`ident` already exists in the environment (see :cmd:`Axiom`). + #. The name :token:`ident` already exists in the global environment (see :cmd:`Axiom`). #. The body of :token:`ident` uses an incorrect elimination for :token:`ident` (see :cmd:`Fixpoint` and :ref:`Destructors`). #. The type of the projections :token:`ident` depends on previous diff --git a/doc/sphinx/language/core/sections.rst b/doc/sphinx/language/core/sections.rst index 75389bb259..c16152ff4f 100644 --- a/doc/sphinx/language/core/sections.rst +++ b/doc/sphinx/language/core/sections.rst @@ -3,57 +3,33 @@ Section mechanism ----------------- -Sections create local contexts which can be shared across multiple definitions. - -.. example:: - - Sections are opened by the :cmd:`Section` command, and closed by :cmd:`End`. - - .. coqtop:: all - - Section s1. - - Inside a section, local parameters can be introduced using :cmd:`Variable`, - :cmd:`Hypothesis`, or :cmd:`Context` (there are also plural variants for - the first two). - - .. coqtop:: all - - Variables x y : nat. - - The command :cmd:`Let` introduces section-wide :ref:`let-in`. These definitions - won't persist when the section is closed, and all persistent definitions which - depend on `y'` will be prefixed with `let y' := y in`. - - .. coqtop:: in - - Let y' := y. - Definition x' := S x. - Definition x'' := x' + y'. - - .. coqtop:: all - - Print x'. - Print x''. - - End s1. - - Print x'. - Print x''. - - Notice the difference between the value of :g:`x'` and :g:`x''` inside section - :g:`s1` and outside. +Sections are naming scopes that permit creating section-local declarations that can +be used by other declarations in the section. Declarations made +with :cmd:`Variable`, :cmd:`Hypothesis`, :cmd:`Context`, +:cmd:`Let`, :cmd:`Let Fixpoint` and +:cmd:`Let CoFixpoint` (or the plural variants of the first two) within sections +are local to the section. + +In proofs done within the section, section-local declarations +are included in the :term:`local context` of the initial goal of the proof. +They are also accessible in definitions made with the :cmd:`Definition` command. + +Sections are opened by the :cmd:`Section` command, and closed by :cmd:`End`. +Sections can be nested. +When a section is closed, its local declarations are no longer available. +Global declarations that refer to them will be adjusted so they're still +usable outside the section as shown in this :ref:`example <section_local_declarations>`. .. cmd:: Section @ident - This command is used to open a section named :token:`ident`. + Opens the section named :token:`ident`. Section names do not need to be unique. .. cmd:: End @ident - This command closes the section or module named :token:`ident`. - See :ref:`Terminating an interactive module or module type definition<terminating_module>` + Closes the section or module named :token:`ident`. + See :ref:`Terminating an interactive module or module type definition <terminating_module>` for a description of its use with modules. After closing the @@ -78,14 +54,14 @@ Sections create local contexts which can be shared across multiple definitions. Let CoFixpoint @cofix_definition {* with @cofix_definition } :name: Let; Let Fixpoint; Let CoFixpoint - These commands behave like :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, except that + These are similar to :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, except that the declared constant is local to the current section. When the section is closed, all persistent definitions and theorems within it that depend on the constant will be wrapped with a :n:`@term_let` with the same declaration. As for :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, - if :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + if :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. @@ -103,3 +79,38 @@ Sections create local contexts which can be shared across multiple definitions. Context (b' := b). .. seealso:: Section :ref:`binders`. Section :ref:`contexts` in chapter :ref:`typeclasses`. + +.. _section_local_declarations: + +.. example:: Section-local declarations + + .. coqtop:: all + + Section s1. + + .. coqtop:: all + + Variables x y : nat. + + The command :cmd:`Let` introduces section-wide :ref:`let-in`. These definitions + won't persist when the section is closed, and all persistent definitions which + depend on `y'` will be prefixed with `let y' := y in`. + + .. coqtop:: in + + Let y' := y. + Definition x' := S x. + Definition x'' := x' + y'. + + .. coqtop:: all + + Print x'. + Print x''. + + End s1. + + Print x'. + Print x''. + + Notice the difference between the value of :g:`x'` and :g:`x''` inside section + :g:`s1` and outside. diff --git a/doc/sphinx/language/extensions/arguments-command.rst b/doc/sphinx/language/extensions/arguments-command.rst index d178311b4c..214541570c 100644 --- a/doc/sphinx/language/extensions/arguments-command.rst +++ b/doc/sphinx/language/extensions/arguments-command.rst @@ -4,7 +4,6 @@ Setting properties of a function's arguments ++++++++++++++++++++++++++++++++++++++++++++ .. cmd:: Arguments @reference {* @arg_specs } {* , {* @implicits_alt } } {? : {+, @args_modifier } } - :name: Arguments .. insertprodn argument_spec args_modifier diff --git a/doc/sphinx/language/extensions/canonical.rst b/doc/sphinx/language/extensions/canonical.rst index aa754ab63d..4cc35794cc 100644 --- a/doc/sphinx/language/extensions/canonical.rst +++ b/doc/sphinx/language/extensions/canonical.rst @@ -199,8 +199,8 @@ but also that the infix relation was bound to the ``nat_eq`` relation. This relation is selected whenever ``==`` is used on terms of type nat. This can be read in the line declaring the canonical structure ``nat_EQty``, where the first argument to ``Pack`` is the key and its second -argument a group of canonical values associated to the key. In this -case we associate to nat only one canonical value (since its class, +argument a group of canonical values associated with the key. In this +case we associate with nat only one canonical value (since its class, ``nat_EQcl`` has just one member). The use of the projection ``op`` requires its argument to be in the class ``EQ``, and uses such a member (function) to actually compare its arguments. @@ -530,7 +530,7 @@ instances of the ``LEQ`` class. The object ``Pack`` takes a type ``T`` (the key) and a mixin ``m``. It infers all the other pieces of the class ``LEQ`` and declares them as canonical -values associated to the ``T`` key. All in all, the only new piece of +values associated with the ``T`` key. All in all, the only new piece of information we add in the ``LEQ`` class is the mixin, all the rest is already canonical for ``T`` and hence can be inferred by Coq. diff --git a/doc/sphinx/language/extensions/evars.rst b/doc/sphinx/language/extensions/evars.rst index fd9695e270..7206fb8581 100644 --- a/doc/sphinx/language/extensions/evars.rst +++ b/doc/sphinx/language/extensions/evars.rst @@ -5,6 +5,9 @@ Existential variables --------------------- +:gdef:`Existential variables <existential variable>` represent as yet unknown +values. + .. insertprodn term_evar term_evar .. prodn:: diff --git a/doc/sphinx/language/extensions/implicit-arguments.rst b/doc/sphinx/language/extensions/implicit-arguments.rst index 23ba5f703a..765d04ec88 100644 --- a/doc/sphinx/language/extensions/implicit-arguments.rst +++ b/doc/sphinx/language/extensions/implicit-arguments.rst @@ -66,7 +66,7 @@ would be a solution of the inference problem. **Contextual Implicit Arguments** An implicit argument can be *contextual* or not. An implicit argument -is said *contextual* if it can be inferred only from the knowledge of +is said to be *contextual* if it can be inferred only from the knowledge of the type of the context of the current expression. For instance, the only argument of:: @@ -384,7 +384,7 @@ Displaying implicit arguments when pretty-printing .. flag:: Printing Implicit - By default, the basic pretty-printing rules hide the inferrable implicit + By default, the basic pretty-printing rules hide the inferable implicit arguments of an application. Turn this flag on to force printing all implicit arguments. @@ -506,7 +506,7 @@ or :g:`m` to the type :g:`nat` of natural numbers). .. flag:: Printing Use Implicit Types By default, the type of bound variables is not printed when - the variable name is associated to an implicit type which matches the + the variable name is associated with an implicit type which matches the actual type of the variable. This feature can be deactivated by turning this flag off. diff --git a/doc/sphinx/language/extensions/match.rst b/doc/sphinx/language/extensions/match.rst index 8e62c2af13..1c022448b0 100644 --- a/doc/sphinx/language/extensions/match.rst +++ b/doc/sphinx/language/extensions/match.rst @@ -252,7 +252,6 @@ If an inductive type has just one constructor, pattern matching can be written using the first destructuring let syntax. .. table:: Printing Let @qualid - :name: Printing Let Specifies a set of qualids for which pattern matching is displayed using a let expression. Note that this only applies to pattern matching instances entered with :g:`match`. @@ -269,7 +268,6 @@ can be written using ``if`` … ``then`` … ``else`` …. This table controls which types are written this way: .. table:: Printing If @qualid - :name: Printing If Specifies a set of qualids for which pattern matching is displayed using ``if`` … ``then`` … ``else`` …. Use the :cmd:`Add` and :cmd:`Remove` @@ -720,7 +718,7 @@ Recall that a list of patterns is also a pattern. So, when we destructure several terms at the same time and the branches have different types we need to provide the elimination predicate for this multiple pattern. It is done using the same scheme: each term may be -associated to an ``as`` clause and an ``in`` clause in order to introduce +associated with an ``as`` clause and an ``in`` clause in order to introduce a dependent product. For example, an equivalent definition for :g:`concat` (even though the diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index 06a196e951..a10312972e 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -43,7 +43,7 @@ Batch compilation (coqc) ------------------------ The ``coqc`` command takes a name *file* as argument. Then it looks for a -vernacular file named *file*.v, and tries to compile it into a +file named *file*.v, and tries to compile it into a *file*.vo file (See :ref:`compiled-files`). .. caution:: @@ -499,7 +499,7 @@ wrong. In the current version, it does not modify the compiled libraries to mark them as successfully checked. Note that non-logical information is not checked. By logical -information, we mean the type and optional body associated to names. +information, we mean the type and optional body associated with names. It excludes for instance anything related to the concrete syntax of objects (customized syntax rules, association between short and long names), implicit arguments, etc. diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index c239797cc2..dcc60195ed 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -7,7 +7,7 @@ Coq Integrated Development Environment The Coq Integrated Development Environment is a graphical tool, to be used as a user-friendly replacement to `coqtop`. Its main purpose is to -allow the user to navigate forward and backward into a Coq vernacular +allow the user to navigate forward and backward into a Coq file, executing corresponding commands or undoing them respectively. CoqIDE is run by typing the command `coqide` on the command line. @@ -100,10 +100,10 @@ processed color, though their preceding proofs have the processed color. Notice that for all these buttons, except for the "gears" button, their operations are also available in the menu, where their keyboard shortcuts are given. -Vernacular commands, templates ------------------------------------ +Commands and templates +---------------------- -The Templates menu allows using shortcuts to insert vernacular +The Templates menu allows using shortcuts to insert commands. This is a nice way to proceed if you are not sure of the syntax of the command you want. @@ -116,7 +116,7 @@ Queries .. image:: ../_static/coqide-queries.png :alt: CoqIDE queries -We call *query* any vernacular command that does not change the current state, +We call *query* any command that does not change the current state, such as ``Check``, ``Search``, etc. To run such commands interactively, without writing them in scripts, CoqIDE offers a *query pane*. The query pane can be displayed on demand by using the ``View`` menu, or using the shortcut ``F1``. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 87a367fc93..013ff0a83f 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -284,6 +284,8 @@ A sequence is an expression of the following form: .. tacn:: @ltac_expr3__1 ; {| @ltac_expr3__2 | @binder_tactic } :name: ltac-seq + .. todo: can't use "… ; …" as the name because of the semicolon + The expression :n:`@ltac_expr3__1` is evaluated to :n:`v__1`, which must be a tactic value. The tactic :n:`v__1` is applied to the current goals, possibly producing more goals. Then the right-hand side is evaluated to @@ -481,7 +483,6 @@ Do loop ~~~~~~~ .. tacn:: do @nat_or_var @ltac_expr3 - :name: do The do loop repeats a tactic :token:`nat_or_var` times: @@ -497,7 +498,6 @@ Repeat loop ~~~~~~~~~~~ .. tacn:: repeat @ltac_expr3 - :name: repeat The repeat loop repeats a tactic until it fails. @@ -515,7 +515,6 @@ Catching errors: try We can catch the tactic errors with: .. tacn:: try @ltac_expr3 - :name: try :n:`@ltac_expr` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied to each focused goal independently. If the application of @@ -531,7 +530,6 @@ Detecting progress We can check if a tactic made progress with: .. tacn:: progress @ltac_expr3 - :name: progress :n:`@ltac_expr` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied to each focused subgoal independently. If the application of ``v`` @@ -641,7 +639,6 @@ First tactic to succeed In some cases backtracking may be too expensive. .. tacn:: first [ {*| @ltac_expr } ] - :name: first For each focused goal, independently apply the first :token:`ltac_expr` that succeeds. The :n:`@ltac_expr`\s must evaluate to tactic values. @@ -701,7 +698,6 @@ Selects and applies the first tactic that solves each goal (i.e. leaves no subgo in a series of alternative tactics: .. tacn:: solve [ {*| @ltac_expr__i } ] - :name: solve For each current subgoal: evaluates and applies each :n:`@ltac_expr` in order until one is found that solves the subgoal. @@ -743,7 +739,6 @@ Conditional branching: tryif ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. tacn:: tryif @ltac_expr__test then @ltac_expr__then else @ltac_expr2__else - :name: tryif For each focused goal, independently: Evaluate and apply :n:`@ltac_expr__test`. If :n:`@ltac_expr__test` succeeds at least once, evaluate and apply :n:`@ltac_expr__then` @@ -772,7 +767,6 @@ Another way of restricting backtracking is to restrict a tactic to a single success: .. tacn:: once @ltac_expr3 - :name: once :n:`@ltac_expr3` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied but only its first success is used. If ``v`` fails, @@ -788,7 +782,6 @@ Coq provides an experimental way to check that a tactic has *exactly one* success: .. tacn:: exactly_once @ltac_expr3 - :name: exactly_once :n:`@ltac_expr3` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied if it has at most one success. If ``v`` fails, @@ -816,7 +809,6 @@ Checking for failure: assert_fails Coq defines an |Ltac| tactic in `Init.Tactics` to check that a tactic *fails*: .. tacn:: assert_fails @ltac_expr3 - :name: assert_fails If :n:`@ltac_expr3` fails, the proof state is unchanged and no message is printed. If :n:`@ltac_expr3` unexpectedly has at least one success, the tactic performs @@ -863,7 +855,6 @@ Coq defines an |Ltac| tactic in `Init.Tactics` to check that a tactic has *at le success: .. tacn:: assert_succeeds @ltac_expr3 - :name: assert_succeeds If :n:`@ltac_expr3` has at least one success, the proof state is unchanged and no message is printed. If :n:`@ltac_expr3` fails, the tactic performs @@ -877,7 +868,6 @@ Print/identity tactic: idtac .. tacn:: idtac {* {| @ident | @string | @natural } } - :name: idtac Leaves the proof unchanged and prints the given tokens. :token:`String<string>`\s and :token:`natural`\s are printed @@ -889,7 +879,7 @@ Print/identity tactic: idtac Failing ~~~~~~~ -.. tacn:: {| fail | gfail } {? @int_or_var } {* {| @ident | @string | @natural } } +.. tacn:: {| fail | gfail } {? @nat_or_var } {* {| @ident | @string | @natural } } :name: fail; gfail :tacn:`fail` is the always-failing tactic: it does not solve any @@ -910,7 +900,7 @@ Failing tactic into the goals, meaning that if there are no goals when it is evaluated, a tactic call like :tacn:`let` :n:`x := H in` :tacn:`fail` `0 x` will succeed. - :n:`@int_or_var` + :n:`@nat_or_var` The failure level. If no level is specified, it defaults to 0. The level is used by :tacn:`try`, :tacn:`repeat`, :tacn:`match goal` and the branching tacticals. If 0, it makes :tacn:`match goal` consider the next clause @@ -974,7 +964,6 @@ We can force a tactic to stop if it has not finished after a certain amount of time: .. tacn:: timeout @nat_or_var @ltac_expr3 - :name: timeout :n:`@ltac_expr3` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied normally, except that it is interrupted after :n:`@nat_or_var` seconds @@ -998,7 +987,6 @@ Timing a tactic A tactic execution can be timed: .. tacn:: time {? @string } @ltac_expr3 - :name: time evaluates :n:`@ltac_expr3` and displays the running time of the tactic expression, whether it fails or succeeds. In case of several successes, the time for each successive @@ -1015,7 +1003,6 @@ Tactic expressions that produce terms can be timed with the experimental tactic .. tacn:: time_constr @ltac_expr - :name: time_constr which evaluates :n:`@ltac_expr ()` and displays the time the tactic expression evaluated, assuming successful evaluation. Time is in seconds and is @@ -1026,12 +1013,10 @@ tactic implemented using the following internal tactics: .. tacn:: restart_timer {? @string } - :name: restart_timer Reset a timer .. tacn:: finish_timing {? ( @string ) } {? @string } - :name: finish_timing Display an optionally named timer. The parenthesized string argument is also optional, and determines the label associated with the timer @@ -1362,7 +1347,7 @@ Pattern matching on goals and hypotheses: match goal :tacn:`lazymatch goal`, :tacn:`match goal` and :tacn:`multimatch goal` are :token:`l1_tactic`\s. - Use this form to match hypotheses and/or goals in the proof context. These patterns have zero or + Use this form to match hypotheses and/or goals in the local context. These patterns have zero or more subpatterns to match hypotheses followed by a subpattern to match the conclusion. Except for the differences noted below, this works the same as the corresponding :n:`@match_key @ltac_expr` construct (see :tacn:`match`). Each current goal is processed independently. @@ -1533,7 +1518,7 @@ expression returns an identifier: .. todo you can't have a :tacn: with the same name as a :gdef: for now, eg `fresh` can't be both - Returns a fresh identifier name (i.e. one that is not already used in the context + Returns a fresh identifier name (i.e. one that is not already used in the local context and not previously returned by :tacn:`fresh` in the current :token:`ltac_expr`). The fresh identifier is formed by concatenating the final :token:`ident` of each :token:`qualid` (dropping any qualified components) and each specified :token:`string`. @@ -1541,11 +1526,11 @@ expression returns an identifier: If no arguments are given, the name is a fresh derivative of the name ``H``. .. note:: We recommend generating the fresh identifier immediately before - adding it in the proof context. Using :tacn:`fresh` in a local function + adding it to the local context. Using :tacn:`fresh` in a local function may not work as you expect: - Successive :tacn:`fresh`\es give distinct names even if the names haven't - yet been added to the proof context: + Successive calls to :tacn:`fresh` give distinct names even if the names haven't + yet been added to the local context: .. coqtop:: reset none @@ -1635,7 +1620,6 @@ Testing boolean expressions: guard ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. tacn:: guard @int_or_var @comparison @int_or_var - :name: guard .. insertprodn int_or_var comparison @@ -1734,7 +1718,6 @@ Defining |Ltac| symbols .. index:: ::= .. cmd:: Ltac @tacdef_body {* with @tacdef_body } - :name: Ltac .. insertprodn tacdef_body tacdef_body @@ -2248,7 +2231,6 @@ Tracing execution not printed. .. opt:: Info Level @natural - :name: Info Level This option is an alternative to the :cmd:`Info` command. @@ -2269,17 +2251,17 @@ The debugger stops, prompting for a command which can be one of the following: +-----------------+-----------------------------------------------+ -| simple newline: | go to the next step | +| newline | go to the next step | +-----------------+-----------------------------------------------+ -| h: | get help | +| h | get help | +-----------------+-----------------------------------------------+ -| x: | exit current evaluation | +| r n | advance n steps further | +-----------------+-----------------------------------------------+ -| s: | continue current evaluation without stopping | +| r string | advance up to the next call to “idtac string” | +-----------------+-----------------------------------------------+ -| r n: | advance n steps further | +| s | continue current evaluation without stopping | +-----------------+-----------------------------------------------+ -| r string: | advance up to the next call to “idtac string” | +| x | exit current evaluation | +-----------------+-----------------------------------------------+ .. exn:: Debug mode not available in the IDE @@ -2366,25 +2348,21 @@ performance issue. Unset Ltac Profiling. .. tacn:: start ltac profiling - :name: start ltac profiling This tactic behaves like :tacn:`idtac` but enables the profiler. .. tacn:: stop ltac profiling - :name: stop ltac profiling Similarly to :tacn:`start ltac profiling`, this tactic behaves like :tacn:`idtac`. Together, they allow you to exclude parts of a proof script from profiling. .. tacn:: reset ltac profile - :name: reset ltac profile Equivalent to the :cmd:`Reset Ltac Profile` command, which allows resetting the profile from tactic scripts for benchmarking purposes. .. tacn:: show ltac profile {? {| cutoff @integer | @string } } - :name: show ltac profile Equivalent to the :cmd:`Show Ltac Profile` command, which allows displaying the profile from tactic scripts for @@ -2410,11 +2388,10 @@ Run-time optimization tactic ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. tacn:: optimize_heap - :name: optimize_heap This tactic behaves like :tacn:`idtac`, except that running it compacts the - heap in the OCaml run-time system. It is analogous to the Vernacular - command :cmd:`Optimize Heap`. + heap in the OCaml run-time system. It is analogous to the + :cmd:`Optimize Heap` command. .. tacn:: infoH @ltac_expr3 diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 375129c02d..3646a32a79 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -173,7 +173,6 @@ Type declarations One can define new types with the following commands. .. cmd:: Ltac2 Type {? rec } @tac2typ_def {* with @tac2typ_def } - :name: Ltac2 Type .. insertprodn tac2typ_def tac2rec_field @@ -301,7 +300,6 @@ Ltac2 Definitions ~~~~~~~~~~~~~~~~~ .. cmd:: Ltac2 {? mutable } {? rec } @tac2def_body {* with @tac2def_body } - :name: Ltac2 .. insertprodn tac2def_body tac2def_body @@ -322,7 +320,6 @@ Ltac2 Definitions If ``mutable`` is set, the definition can be redefined at a later stage (see below). .. cmd:: Ltac2 Set @qualid {? as @ident } := @ltac2_expr - :name: Ltac2 Set This command redefines a previous ``mutable`` definition. Mutable definitions act like dynamic binding, i.e. at runtime, the last defined @@ -598,7 +595,7 @@ modes, the *strict* and the *non-strict* mode. hypotheses. If this doesn't hold, internalization will fail. To work around this error, one has to specifically use the ``&`` notation. - In non-strict mode, any simple identifier appearing in a term quotation which - is not bound in the global context is turned into a dynamic reference to a + is not bound in the global environment is turned into a dynamic reference to a hypothesis. That is to say, internalization will succeed, but the evaluation of the term at runtime will fail if there is no such variable in the dynamic context. @@ -982,7 +979,7 @@ Match over goals gmatch_hyp_pattern ::= @name : @ltac2_match_pattern Matches over goals, similar to Ltac1 :tacn:`match goal`. - Use this form to match hypotheses and/or goals in the proof context. These patterns have zero or + Use this form to match hypotheses and/or goals in the local context. These patterns have zero or more subpatterns to match hypotheses followed by a subpattern to match the conclusion. Except for the differences noted below, this works the same as the corresponding :n:`@ltac2_match_key @ltac2_expr` construct (see :tacn:`match!`). Each current goal is processed independently. @@ -1164,7 +1161,6 @@ Notations --------- .. cmd:: Ltac2 Notation {+ @ltac2_scope } {? : @natural } := @ltac2_expr - :name: Ltac2 Notation .. todo seems like name maybe should use lident rather than ident, considering: @@ -1487,7 +1483,7 @@ Other nonterminals that have syntactic classes are listed here. * - :n:`conversion` - :token:`ltac2_conversion` - - :token:`conversion` + - * - :n:`rewriting` - :token:`ltac2_oriented_rewriter` @@ -1679,7 +1675,6 @@ Evaluation Ltac2 features a toplevel loop that can be used to evaluate expressions. .. cmd:: Ltac2 Eval @ltac2_expr - :name: Ltac2 Eval This command evaluates the term in the current proof if there is one, or in the global environment otherwise, and displays the resulting value to the user @@ -1877,9 +1872,9 @@ In Ltac expressions .. exn:: Unbound {| value | constructor } X - * if `X` is meant to be a term from the current stactic environment, replace + * if `X` is meant to be a term from the current static environment, replace the problematic use by `'X`. - * if `X` is meant to be a hypothesis from the goal context, replace the + * if `X` is meant to be a hypothesis from the local context, replace the problematic use by `&X`. In quotations @@ -1889,7 +1884,7 @@ In quotations * if `X` is meant to be a tactic expression bound by a Ltac2 let or function, replace the problematic use by `$X`. - * if `X` is meant to be a hypothesis from the goal context, replace the + * if `X` is meant to be a hypothesis from the local context, replace the problematic use by `&X`. Exception catching diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 07c2d268c6..bab9d35099 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -116,8 +116,8 @@ compatible with the rest of Coq, up to a few discrepancies: + New keywords (``is``) might clash with variable, constant, tactic or - tactical names, or with quasi-keywords in tactic or vernacular - notations. + tactical names, or with quasi-keywords in tactic or + notation commands. + New tactic(al)s names (:tacn:`last`, :tacn:`done`, :tacn:`have`, :tacn:`suffices`, :tacn:`suff`, :tacn:`without loss`, :tacn:`wlog`, :tacn:`congr`, :tacn:`unlock`) might clash with user tactic names. @@ -799,8 +799,9 @@ An *occurrence switch* can be: set x := {+1 3}(f 2). Notice that some occurrences of a given term may be - hidden to the user, for example because of a notation. The vernacular - ``Set Printing All`` command displays all these hidden occurrences and + hidden to the user, for example because of a notation. Setting the + :flag:`Printing All` flag causes these hidden occurrences to + be shown when the term is displayed. This setting should be used to find the correct coding of the occurrences to be selected [#1]_. @@ -1023,7 +1024,7 @@ conversely in between deductive steps. In |SSR| these moves are performed by two *tacticals* ``=>`` and ``:``, so that the bookkeeping required by a deductive step can be -directly associated to that step, and that tactics in an |SSR| +directly associated with that step, and that tactics in an |SSR| script correspond to actual logical steps in the proof rather than merely shuffle facts. Still, some isolated bookkeeping is unavoidable, such as naming variables and assumptions at the beginning of a @@ -1189,7 +1190,7 @@ The move tactic. ```````````````` .. tacn:: move - :name: move + :name: move (ssreflect) This tactic, in its defective form, behaves like the :tacn:`hnf` tactic. @@ -5502,7 +5503,7 @@ equivalences are indeed taken into account, otherwise only single string that contains symbols or is followed by a scope key, is interpreted as the constant whose notation involves that string (e.g., :g:`+` for :g:`addn`), if this is unambiguous; otherwise the diagnostic - includes the output of the :cmd:`Locate` vernacular command. + includes the output of the :cmd:`Locate` command. + whose statement, including assumptions and types, contains a subterm matching the next patterns. If a pattern is prefixed by ``-``, the test is reversed; diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index b2ebd96607..766f7ab44e 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3,35 +3,46 @@ Tactics ======== -A deduction rule is a link between some (unique) formula, that we call -the *conclusion* and (several) formulas that we call the *premises*. A -deduction rule can be read in two ways. The first one says: “if I know -this and this then I can deduce this”. For instance, if I have a proof -of A and a proof of B then I have a proof of A ∧ B. This is forward -reasoning from premises to conclusion. The other way says: “to prove -this I have to prove this and this”. For instance, to prove A ∧ B, I -have to prove A and I have to prove B. This is backward reasoning from -conclusion to premises. We say that the conclusion is the *goal* to -prove and premises are the *subgoals*. The tactics implement *backward -reasoning*. When applied to a goal, a tactic replaces this goal with -the subgoals it generates. We say that a tactic reduces a goal to its -subgoal(s). - -Each (sub)goal is denoted with a number. The current goal is numbered -1. By default, a tactic is applied to the current goal, but one can -address a particular goal in the list by writing n:tactic which means -“apply tactic tactic to goal number n”. We can show the list of -subgoals by typing Show (see Section :ref:`requestinginformation`). - -Since not every rule applies to a given statement, not every tactic can -be used to reduce a given goal. In other words, before applying a tactic -to a given goal, the system checks that some *preconditions* are -satisfied. If it is not the case, the tactic raises an error message. - -Tactics are built from atomic tactics and tactic expressions (which -extends the folklore notion of tactical) to combine those atomic -tactics. This chapter is devoted to atomic tactics. The tactic -language will be described in Chapter :ref:`ltac`. +Tactics specify how to transform the :term:`proof state` of an +incomplete proof to eventually generate a complete proof. + +Proofs can be developed in two basic ways: In :gdef:`forward reasoning`, +the proof begins by proving simple statements that are then combined to prove the +theorem statement as the last step of the proof. With forward reasoning, +for example, +the proof of `A /\\ B` would begin with proofs of `A` and `B`, which are +then used to prove `A /\\ B`. Forward reasoning is probably the most common +approach in human-generated proofs. + +In :gdef:`backward reasoning`, the proof begins with the theorem statement +as the goal, which is then gradually transformed until every subgoal generated +along the way has been proven. In this case, the proof of `A /\\ B` begins +with that formula as the goal. This can be transformed into two subgoals, +`A` and `B`, followed by the proofs of `A` and `B`. Coq and its tactics +use backward reasoning. + +A tactic may fully prove a goal, in which case the goal is removed +from the proof state. +More commonly, a tactic replaces a goal with one or more :term:`subgoals <subgoal>`. +(We say that a tactic reduces a goal to its subgoals.) + +Most tactics require specific elements or preconditions to reduce a goal; +they display error messages if they can't be applied to the goal. +A few tactics, such as :tacn:`auto`, don't fail even if the proof state +is unchanged. + +Goals are identified by number. The current goal is number +1. Tactics are applied to the current goal by default. (The +default can be changed with the :opt:`Default Goal Selector` +option.) They can +be applied to another goal or to multiple goals with a +:ref:`goal selector <goal-selectors>` such as :n:`2: @tactic`. + +This chapter describes many of the most common built-in tactics. +Built-in tactics can be combined to form tactic expressions, which are +described in the :ref:`Ltac` chapter. Since tactic expressions can +be used anywhere that a built-in tactic can be used, "tactic" may +refer to both built-in tactics and tactic expressions. Common elements of tactics -------------------------- @@ -529,8 +540,21 @@ one or more of its hypotheses. which is equivalent to `in * |- *`. Use `* |-` to select all occurrences in all hypotheses. -Tactics that use occurrence clauses include :tacn:`set`, -:tacn:`remember`, :tacn:`induction` and :tacn:`destruct`. + Tactics that select a specific hypothesis H to apply to other hypotheses, + such as :tacn:`rewrite` `H in * |-`, won't apply H to itself. + + If multiple + occurrences are given, such as in :tacn:`rewrite` `H at 1 2 3`, the tactic + must match at least one occurrence in order to succeed. The tactic will fail + if no occurrences match. Occurrence numbers that are out of range (e.g. + `at 1 3` when there are only 2 occurrences in the hypothesis or conclusion) + are ignored. + + .. todo: remove last sentence above and add "Invalid occurrence number @natural" exn for 8.14 + per #13568. + + Tactics that use occurrence clauses include :tacn:`set`, + :tacn:`remember`, :tacn:`induction` and :tacn:`destruct`. .. seealso:: @@ -1983,7 +2007,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) This is a more basic induction tactic. Again, the type of the argument :n:`@term` must be an inductive type. Then, according to the type of the goal, the tactic ``elim`` chooses the appropriate destructor and applies it - as the tactic :tacn:`apply` would do. For instance, if the proof context + as the tactic :tacn:`apply` would do. For instance, if the local context contains :g:`n:nat` and the current goal is :g:`T` of type :g:`Prop`, then :n:`elim n` is equivalent to :n:`apply nat_ind with (n:=n)`. The tactic ``elim`` does not modify the context of the goal, neither introduces the @@ -2655,7 +2679,7 @@ and an explanation of the underlying technique. Like in a fix expression, the induction hypotheses have to be used on structurally smaller arguments. The verification that inductive proof arguments are correct is done only at the time of registering the - lemma in the environment. To know if the use of induction hypotheses + lemma in the global environment. To know if the use of induction hypotheses is correct at some time of the interactive development of a proof, use the command ``Guarded`` (see Section :ref:`requestinginformation`). @@ -2675,7 +2699,7 @@ and an explanation of the underlying technique. name given to the coinduction hypothesis. Like in a cofix expression, the use of induction hypotheses have to guarded by a constructor. The verification that the use of co-inductive hypotheses is correct is - done only at the time of registering the lemma in the environment. To + done only at the time of registering the lemma in the global environment. To know if the use of coinduction hypotheses is correct at some time of the interactive development of a proof, use the command ``Guarded`` (see Section :ref:`requestinginformation`). @@ -2756,14 +2780,11 @@ succeeds, and results in an error otherwise. :name: is_var This tactic checks whether its argument is a variable or hypothesis in - the current goal context or in the opened sections. + the current local context. .. exn:: Not a variable or hypothesis. :undocumented: - -.. _equality: - Equality -------- @@ -2958,59 +2979,7 @@ references to automatically generated names. Performance-oriented tactic variants ------------------------------------ -.. tacn:: change_no_check @term - :name: change_no_check - - For advanced usage. Similar to :tacn:`change` :n:`@term`, but as an optimization, - it skips checking that :n:`@term` is convertible to the goal. - - Recall that the Coq kernel typechecks proofs again when they are concluded to - ensure safety. Hence, using :tacn:`change` checks convertibility twice - overall, while :tacn:`change_no_check` can produce ill-typed terms, - but checks convertibility only once. - Hence, :tacn:`change_no_check` can be useful to speed up certain proof - scripts, especially if one knows by construction that the argument is - indeed convertible to the goal. - - In the following example, :tacn:`change_no_check` replaces :g:`False` by - :g:`True`, but :cmd:`Qed` then rejects the proof, ensuring consistency. - - .. example:: - - .. coqtop:: all abort - - Goal False. - change_no_check True. - exact I. - Fail Qed. - - :tacn:`change_no_check` supports all of :tacn:`change`'s variants. - - .. tacv:: change_no_check @term with @term’ - :undocumented: - - .. tacv:: change_no_check @term at {+ @natural} with @term’ - :undocumented: - - .. tacv:: change_no_check @term {? {? at {+ @natural}} with @term} in @ident - - .. example:: - - .. coqtop:: all abort - - Goal True -> False. - intro H. - change_no_check False in H. - exact H. - Fail Qed. - - .. tacv:: convert_concl_no_check @term - :name: convert_concl_no_check - - .. deprecated:: 8.11 - - Deprecated old name for :tacn:`change_no_check`. Does not support any of its - variants. +.. todo: move the following adjacent to the `exact` tactic in the rewriting chapter? .. tacn:: exact_no_check @term :name: exact_no_check diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index e866e4c624..8e2f577f6b 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1,7 +1,7 @@ .. _vernacularcommands: -Vernacular commands -============================= +Commands +======== .. _displaying: @@ -60,7 +60,7 @@ Query commands -------------- Unlike other commands, :production:`query_command`\s may be prefixed with -a goal selector (:n:`@natural:`) to specify which goal context it applies to. +a goal selector (:n:`@natural:`) to specify which goals it applies to. If no selector is provided, the command applies to the current goal. If no proof is open, then the command only applies to accessible objects. (see Section :ref:`invocation-of-tactics`). @@ -382,7 +382,6 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). SearchRewrite (_ + _ + _). .. table:: Search Blacklist @string - :name: Search Blacklist Specifies a set of strings used to exclude lemmas from the results of :cmd:`Search`, :cmd:`SearchHead`, :cmd:`SearchPattern` and :cmd:`SearchRewrite` queries. A lemma whose @@ -668,8 +667,8 @@ Loadpath ------------ Loadpaths are preferably managed using Coq command line options (see -Section :ref:`libraries-and-filesystem`) but there remain vernacular commands to manage them -for practical purposes. Such commands are only meant to be issued in +Section :ref:`libraries-and-filesystem`), but there are also commands +to manage them within Coq. These commands are only meant to be issued in the toplevel, and using them in source files is discouraged. @@ -740,7 +739,7 @@ Backtracking ------------ The backtracking commands described in this section can only be used -interactively, they cannot be part of a vernacular file loaded via +interactively, they cannot be part of a Coq file loaded via ``Load`` or compiled by ``coqc``. @@ -844,7 +843,6 @@ Quitting and debugging displayed. .. opt:: Default Timeout @natural - :name: Default Timeout If set, each :n:`@sentence` is treated as if it was prefixed with :cmd:`Timeout` :n:`@natural`, except for :cmd:`Timeout` commands themselves. If unset, @@ -883,7 +881,6 @@ Controlling display This flag controls the normal displaying. .. opt:: Warnings "{+, {? {| - | + } } @ident }" - :name: Warnings This option configures the display of warnings. It is experimental, and expects, between quotes, a comma-separated list of warning names or @@ -894,14 +891,12 @@ Controlling display right have higher priority, meaning that `A,-A` is equivalent to `-A`. .. opt:: Printing Width @natural - :name: Printing Width This command sets which left-aligned part of the width of the screen is used for display. At the time of writing this documentation, the default value is 78. .. opt:: Printing Depth @natural - :name: Printing Depth This option controls the nesting depth of the formatter used for pretty- printing. Beyond this depth, display of subterms is replaced by dots. At the diff --git a/doc/sphinx/proofs/automatic-tactics/auto.rst b/doc/sphinx/proofs/automatic-tactics/auto.rst index 472df2bd91..d7228a3907 100644 --- a/doc/sphinx/proofs/automatic-tactics/auto.rst +++ b/doc/sphinx/proofs/automatic-tactics/auto.rst @@ -335,7 +335,7 @@ Creating Hints .. exn:: @qualid cannot be used as a hint The head symbol of the type of :n:`@qualid` is a bound variable - such that this tactic cannot be associated to a constant. + such that this tactic cannot be associated with a constant. .. cmd:: Hint Immediate {+ {| @qualid | @one_term } } {? : {+ @ident } } diff --git a/doc/sphinx/proofs/writing-proofs/proof-mode.rst b/doc/sphinx/proofs/writing-proofs/proof-mode.rst index 40d032543f..931ac905f6 100644 --- a/doc/sphinx/proofs/writing-proofs/proof-mode.rst +++ b/doc/sphinx/proofs/writing-proofs/proof-mode.rst @@ -1,74 +1,175 @@ .. _proofhandling: -------------------- - Proof handling -------------------- +---------- +Proof mode +---------- -In Coq’s proof editing mode all top-level commands documented in -Chapter :ref:`vernacularcommands` remain available and the user has access to specialized -commands dealing with proof development pragmas documented in this -section. They can also use some other specialized commands called -*tactics*. They are the very tools allowing the user to deal with -logical reasoning. They are documented in Chapter :ref:`tactics`. +:gdef:`Proof mode <proof mode>` is used to prove theorems. +Coq enters proof mode when you begin a proof, +such as with the :cmd:`Theorem` command. It exits proof mode when +you complete a proof, such as with the :cmd:`Qed` command. Tactics, +which are available only in proof mode, incrementally transform incomplete +proofs to eventually generate a complete proof. -Coq user interfaces usually have a way of marking whether the user has -switched to proof editing mode. For instance, in coqtop the prompt ``Coq <`` is changed into -:n:`@ident <` where :token:`ident` is the declared name of the theorem currently edited. +When you run Coq interactively, such as through CoqIDE, Proof General or +coqtop, Coq shows the current proof state (the incomplete proof) as you +enter tactics. This information isn't shown when you run Coq in batch +mode with `coqc`. -At each stage of a proof development, one has a list of goals to -prove. Initially, the list consists only in the theorem itself. After -having applied some tactics, the list of goals contains the subgoals -generated by the tactics. +Proof State +----------- -To each subgoal is associated a number of hypotheses called the *local context* -of the goal. Initially, the local context contains the local variables and -hypotheses of the current section (see Section :ref:`gallina-assumptions`) and -the local variables and hypotheses of the theorem statement. It is enriched by -the use of certain tactics (see e.g. :tacn:`intro`). +The :gdef:`proof state` consists of one or more unproven goals. +Each goal has a :gdef:`conclusion` (the statement that is to be proven) +and a :gdef:`local context`, which contains named :term:`hypotheses <hypothesis>` +(which are propositions), variables and local definitions that can be used in +proving the conclusion. The proof may also use *constants* from the :term:`global environment` +such as definitions and proven theorems. -When a proof is completed, the message ``Proof completed`` is displayed. -One can then register this proof as a defined constant in the -environment. Because there exists a correspondence between proofs and -terms of λ-calculus, known as the *Curry-Howard isomorphism* -:cite:`How80,Bar81,Gir89,H89`, Coq stores proofs as terms of |Cic|. Those -terms are called *proof terms*. +The term ":gdef:`goal`" may refer to an entire goal or to the conclusion +of a goal, depending on the context. +The conclusion appears below a line and the local context appears above the line. +The conclusion is a type. Each item in the local context begins with a name +and ends, after a colon, with an associated type. +Local definitions are shown in the form `n := 0 : nat`, for example, in which `nat` is the +type of `0`. -.. exn:: No focused proof. +The local context of a goal contains items specific to the goal as well +as section-local variables and hypotheses (see :ref:`gallina-assumptions`) defined +in the current :ref:`section <section-mechanism>`. The latter are included in the +initial proof state. +Items in the local context are ordered; an item can only refer to items that appear +before it. (A more mathematical description of the *local context* is +:ref:`here <Local-context>`.) - Coq raises this error message when one attempts to use a proof editing command - out of the proof editing mode. +The :gdef:`global environment` has definitions and proven theorems that are global in scope. +(A more mathematical description of the *global environment* is :ref:`here <Global-environment>`.) + +When you begin proving a theorem, the proof state shows +the statement of the theorem below the line and often nothing in the +local context: + +.. coqtop:: none + + Parameter P: nat -> Prop. + +.. coqtop:: out + + Goal forall n m: nat, n > m -> P 1 /\ P 2. + +After applying the :tacn:`intros` :term:`tactic`, we see hypotheses above the line. +The names of variables (`n` and `m`) and hypotheses (`H`) appear before a colon, followed by +the type they represent. + +.. coqtop:: all + + intros. + +Some tactics, such as :tacn:`split`, create new goals, which may +be referred to as :gdef:`subgoals <subgoal>` for clarity. +Goals are numbered from 1 to N at each step of the proof to permit applying a +tactic to specific goals. The local context is only shown for the first goal. + +.. coqtop:: all + + split. + +"Variables" may refer specifically to local context items for which the type of their type +is `Set` or `Type`, and :gdef:`"hypotheses" <hypothesis>` refers to items that are +:term:`propositions <proposition>`, +for which the type of their type is `Prop` or `SProp`, +but these terms are also used interchangeably. + +.. coqtop:: out + + let t_n := type of n in idtac "type of n :" t_n; + let tt_n := type of t_n in idtac "type of" t_n ":" tt_n. + let t_H := type of H in idtac "type of H :" t_H; + let tt_H := type of t_H in idtac "type of" t_H ":" tt_H. + +A proof script, consisting of the tactics that are applied to prove a +theorem, is often informally referred to as a "proof". +The real proof, whether complete or incomplete, is a term, the :gdef:`proof term`, +which users may occasionally want to examine. (This is based on the +*Curry-Howard isomorphism* :cite:`How80,Bar81,Gir89,H89`, which is +a correspondence between between proofs and terms and between +propositions and types of λ-calculus. The isomorphism is also +sometimes called the "propositions-as-types correspondence".) + +The :cmd:`Show Proof` command displays the incomplete proof term +before you've completed the proof. For example, here's the proof +term after using the :tacn:`split` tactic above: + +.. coqtop:: all + + Show Proof. + +The incomplete parts, the goals, are represented by +:term:`existential variables <existential variable>` +with names that begin with `?Goal`. The :cmd:`Show Existentials` command +shows each existential with the hypotheses and conclusion for the associated goal. + +.. coqtop:: all + + Show Existentials. + +Coq's kernel verifies the correctness of proof terms when it exits +proof mode by checking that the proof term is :term:`well-typed` and +that its type is the same as the theorem statement. + +After a proof is completed, :cmd:`Print` `<theorem_name>` +shows the proof term and its type. The type appears after +the colon (`forall ...`), as for this theorem from Coq's standard library: + +.. coqtop:: all + + Print proj1. .. _proof-editing-mode: -Entering and leaving proof editing mode ---------------------------------------- +Entering and exiting proof mode +------------------------------- + +Coq enters :term:`proof mode` when you begin a proof through +commands such as :cmd:`Theorem` or :cmd:`Goal`. Coq user interfaces +usually have a way to indicate that you're in proof mode. + +:term:`Tactics <tactic>` are available only in proof mode (currently they give syntax +errors outside of proof mode). Most :term:`commands <command>` can be used both in and out of +proof mode, but some commands only work in or outside of proof mode. -The proof editing mode is entered by asserting a statement, which typically is -the assertion of a theorem using an assertion command like :cmd:`Theorem`. The -list of assertion commands is given in :ref:`Assertions`. The command -:cmd:`Goal` can also be used. +When the proof is completed, you can exit proof mode with commands such as +:cmd:`Qed`, :cmd:`Defined` and :cmd:`Save`. .. cmd:: Goal @type - This is intended for quick assertion of statements, without knowing in - advance which name to give to the assertion, typically for quick - testing of the provability of a statement. If the proof of the - statement is eventually completed and validated, the statement is then - bound to the name ``Unnamed_thm`` (or a variant of this name not already - used for another statement). + Asserts an unnamed proposition. This is intended for quick tests that + a proposition is provable. If the proof is eventually completed and + validated, you can assign a name with the :cmd:`Save` or :cmd:`Defined` + commands. If no name is given, the name will be `Unnamed_thm` (or, + if that name is already defined, a variant of that). .. cmd:: Qed - This command is available in interactive editing proof mode when the - proof is completed. Then :cmd:`Qed` extracts a proof term from the proof - script, switches back to Coq top-level and attaches the extracted - proof term to the declared name of the original goal. The name is - added to the environment as an opaque constant. + Passes a completed :term:`proof term` to Coq's kernel + to check that the proof term is :term:`well-typed` and + to verify that its type matches the theorem statement. If it's verified, the + proof term is added to the global environment as an opaque constant + using the declared name from the original goal. + + It's very rare for a proof term to fail verification. Generally this + indicates a bug in a tactic you used or that you misused some + unsafe tactics. .. exn:: Attempt to save an incomplete proof. :undocumented: + .. exn:: No focused proof (No proof-editing in progress). + + You tried to use a proof mode command such as :cmd:`Qed` outside of proof + mode. + .. note:: Sometimes an error occurs when building the proof term, because @@ -81,9 +182,9 @@ list of assertion commands is given in :ref:`Assertions`. The command even incur a memory overflow. .. cmd:: Save @ident - :name: Save - Saves a completed proof with the name :token:`ident`, which + Similar to :cmd:`Qed`, except that the proof term is added to the global + context with the name :token:`ident`, which overrides any name provided by the :cmd:`Theorem` command or its variants. @@ -98,7 +199,7 @@ list of assertion commands is given in :ref:`Assertions`. The command .. cmd:: Admitted - This command is available in interactive editing mode to give up + This command is available in proof mode to give up the current proof and declare the initial goal as an axiom. .. cmd:: Abort {? {| All | @ident } } @@ -120,7 +221,7 @@ list of assertion commands is given in :ref:`Assertions`. The command .. cmd:: Proof @term :name: Proof `term` - This command applies in proof editing mode. It is equivalent to + This command applies in proof mode. It is equivalent to :n:`exact @term. Qed.` That is, you have to give the full proof in one gulp, as a proof term (see Section :ref:`applyingtheorems`). @@ -159,7 +260,7 @@ list of assertion commands is given in :ref:`Assertions`. The command | Type {? * } | All - Opens proof editing mode, declaring the set of + Opens proof mode, declaring the set of section variables (see :ref:`gallina-assumptions`) used by the proof. At :cmd:`Qed` time, the system verifies that the set of section variables used in @@ -210,7 +311,7 @@ list of assertion commands is given in :ref:`Assertions`. The command .. example:: - .. coqtop:: all + .. coqtop:: all reset Section Test. Variable n : nat. @@ -232,7 +333,6 @@ The following options modify the behavior of ``Proof using``. .. opt:: Default Proof Using "@section_var_expr" - :name: Default Proof Using Use :n:`@section_var_expr` as the default ``Proof using`` value. E.g. ``Set Default Proof Using "a b"`` will complete all ``Proof`` commands not followed by a @@ -301,7 +401,7 @@ Name a set of section hypotheses for ``Proof using`` Use :cmd:`Unshelve` instead. Proof modes -``````````` +----------- When entering proof mode through commands such as :cmd:`Goal` and :cmd:`Proof`, Coq picks by default the |Ltac| mode. Nonetheless, there exist other proof modes @@ -312,8 +412,8 @@ be changed using the following option. .. opt:: Default Proof Mode @string Select the proof mode to use when starting a proof. Depending on the proof - mode, various syntactic constructs are allowed when writing an interactive - proof. All proof modes support vernacular commands; the proof mode determines + mode, various syntactic constructs are allowed when writing a + proof. All proof modes support commands; the proof mode determines which tactic language and set of tactic definitions are available. The possible option values are: @@ -349,16 +449,16 @@ Navigation in the proof tree .. cmd:: Restart - Restores the proof editing process to the original goal. + Restores the proof to the original goal. .. exn:: No focused proof to restart. :undocumented: .. cmd:: Focus {? @natural } - Focuses the attention on the first subgoal to prove or, if :token:`natural` is + Focuses the attention on the first goal to prove or, if :token:`natural` is specified, the :token:`natural`\-th. The - printing of the other subgoals is suspended until the focused subgoal + printing of the other goals is suspended until the focused goal is solved or unfocused. .. deprecated:: 8.8 @@ -379,14 +479,9 @@ Navigation in the proof tree .. _curly-braces: -.. index:: { - } - -.. todo: :name: "{"; "}" doesn't work, nor does :name: left curly bracket; right curly bracket, - hence the verbose names - .. tacn:: {? {| @natural | [ @ident ] } : } %{ - %} + %} + :name: {; } .. todo See https://github.com/coq/coq/issues/12004 and @@ -403,7 +498,7 @@ Navigation in the proof tree or focus the next one. :n:`@natural:` - Focuses on the :token:`natural`\-th subgoal to prove. + Focuses on the :token:`natural`\-th goal to prove. :n:`[ @ident ]: %{` Focuses on the named goal :token:`ident`. @@ -477,7 +572,7 @@ Navigation in the proof tree Brackets are used to focus on a single goal given either by its position or by its name if it has one. - .. seealso:: The error messages for bullets below. + .. seealso:: The error messages for bullets below. .. _bullets: @@ -567,7 +662,6 @@ Set Bullet Behavior ~~~~~~~~~~~~~~~~~~~ .. opt:: Bullet Behavior {| "None" | "Strict Subproofs" } - :name: Bullet Behavior This option controls the bullet behavior and can take two possible values: @@ -577,8 +671,7 @@ Set Bullet Behavior Modifying the order of goals ```````````````````````````` -.. tacn:: cycle @integer - :name: cycle +.. tacn:: cycle @int_or_var Reorders the selected goals so that the first :n:`@integer` goals appear after the other selected goals. @@ -601,8 +694,7 @@ Modifying the order of goals all: cycle 2. all: cycle -3. -.. tacn:: swap @integer @integer - :name: swap +.. tacn:: swap @int_or_var @int_or_var Exchanges the position of the specified goals. Negative values for :n:`@integer` indicate counting goals @@ -621,7 +713,6 @@ Modifying the order of goals all: swap 1 -1. .. tacn:: revgoals - :name: revgoals Reverses the order of the selected goals. The tactic is only useful with a goal selector, most commonly `all :`. Note that other selectors reorder goals; @@ -638,16 +729,17 @@ Modifying the order of goals Postponing the proof of some goals `````````````````````````````````` +Goals can be :gdef:`shelved` so they are no longer displayed in the proof state. +They can then be :gdef:`unshelved` to make them visible again. + .. tacn:: shelve - :name: shelve This tactic moves all goals under focus to a shelf. While on the shelf, goals will not be focused on. They can be solved by unification, or they can be called back into focus with the command :cmd:`Unshelve`. - .. tacv:: shelve_unifiable - :name: shelve_unifiable + .. tacn:: shelve_unifiable Shelves only the goals under focus that are mentioned in other goals. Goals that appear in the type of other goals can be solved by unification. @@ -667,14 +759,12 @@ Postponing the proof of some goals from the shelf into focus, by appending them to the end of the current list of focused goals. -.. tacn:: unshelve @tactic - :name: unshelve +.. tacn:: unshelve @ltac_expr1 Performs :n:`@tactic`, then unshelves existential variables added to the shelf by the execution of :n:`@tactic`, prepending them to the current goal. .. tacn:: give_up - :name: give_up This tactic removes the focused goals from the proof. They are not solved, and cannot be solved later in the proof. As the goals are not @@ -694,7 +784,7 @@ Requesting information Displays the current goals. :n:`@natural` - Display only the :token:`natural`\-th subgoal. + Display only the :token:`natural`\-th goal. :n:`@ident` Displays the named goal :token:`ident`. This is useful in @@ -791,7 +881,7 @@ Requesting information Some tactics (e.g. :tacn:`refine`) allow to build proofs using fixpoint or co-fixpoint constructions. Due to the incremental nature - of interactive proof construction, the check of the termination (or + of proof construction, the check of the termination (or guardedness) of the recursive calls in the fixpoint or cofixpoint constructions is postponed to the time of the completion of the proof. @@ -854,7 +944,6 @@ How to enable diffs ``````````````````` .. opt:: Diffs {| "on" | "off" | "removed" } - :name: Diffs The “on” setting highlights added tokens in green, while the “removed” setting additionally reprints items with removed tokens in red. Unchanged tokens in @@ -983,12 +1072,11 @@ To show differences in the proof term: .. image:: ../../_static/diffs-show-proof.png :alt: coqide with Set Diffs on with compacted hypotheses -Controlling the effect of proof editing commands ------------------------------------------------- +Controlling proof mode +---------------------- .. opt:: Hyps Limit @natural - :name: Hyps Limit This option controls the maximum number of hypotheses displayed in goals after the application of a tactic. All the hypotheses remain usable @@ -1009,7 +1097,7 @@ Controlling the effect of proof editing commands .. flag:: Printing Goal Names - When turned on, the name of the goal is printed in interactive + When turned on, the name of the goal is printed in proof mode, which can be useful in cases of cross references between goals. diff --git a/doc/sphinx/proofs/writing-proofs/rewriting.rst b/doc/sphinx/proofs/writing-proofs/rewriting.rst index 90404b7321..8873d02888 100644 --- a/doc/sphinx/proofs/writing-proofs/rewriting.rst +++ b/doc/sphinx/proofs/writing-proofs/rewriting.rst @@ -1,102 +1,123 @@ -================================= -Term rewriting and simplification -================================= +========================= +Reasoning with equalities +========================= -.. _rewritingexpressions: +There are multiple notions of :gdef:`equality` in Coq: -Rewriting expressions ---------------------- +- :gdef:`Leibniz equality` is the standard + way to define equality in Coq and the Calculus of Inductive Constructions, + which is in terms of a binary relation, i.e. a binary function that returns + a `Prop`. The standard library + defines `eq` similar to this: -These tactics use the equality :g:`eq:forall A:Type, A->A->Prop` defined in -file ``Logic.v`` (see :ref:`coq-library-logic`). The notation for :g:`eq T t u` is -simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. + .. coqdoc:: -.. tacn:: rewrite @term - :name: rewrite + Inductive eq {A : Type} (x : A) : A -> Prop := eq_refl : eq x x. - This tactic applies to any goal. The type of :token:`term` must have the form + The notation `x = y` represents the term `eq x y`. The notation `x = y :> A` + gives the type of x and y explicitly. - ``forall (x``:sub:`1` ``:A``:sub:`1` ``) ... (x``:sub:`n` ``:A``:sub:`n` ``), eq term``:sub:`1` ``term``:sub:`2` ``.`` +- :gdef:`Setoid equality <setoid equality>` defines equality in terms of an equivalence + relation. A :gdef:`setoid` is a set that is equipped with an equivalence relation + (see https://en.wikipedia.org/wiki/Setoid). These are needed to form a :gdef:`quotient set` + or :gdef:`quotient` + (see https://en.wikipedia.org/wiki/Equivalence_Class). In Coq, users generally work + with setoids rather than constructing quotients, for which there is no specific support. - where :g:`eq` is the Leibniz equality or a registered setoid equality. +- :gdef:`Definitional equality <definitional equality>` is equality based on the + :ref:`conversion rules <Conversion-rules>`, which Coq can determine automatically. + When two terms are definitionally equal, Coq knows it can + replace one with the other, such as with :tacn:`change` `X with Y`, among many + other advantages. ":term:`Convertible <convertible>`" is another way of saying that + two terms are definitionally equal. - Then :n:`rewrite @term` finds the first subterm matching `term`\ :sub:`1` in the goal, - resulting in instances `term`:sub:`1`' and `term`:sub:`2`' and then - replaces every occurrence of `term`:subscript:`1`' by `term`:subscript:`2`'. - Hence, some of the variables :g:`x`\ :sub:`i` are solved by unification, - and some of the types :g:`A`\ :sub:`1`:g:`, ..., A`\ :sub:`n` become new - subgoals. +.. _rewritingexpressions: - .. exn:: The @term provided does not end with an equation. - :undocumented: +Rewriting with Leibniz and setoid equality +------------------------------------------ - .. exn:: Tactic generated a subgoal identical to the original goal. This happens if @term does not occur in the goal. - :undocumented: +.. tacn:: rewrite {+, @oriented_rewriter } {? @occurrences } {? by @ltac_expr3 } - .. tacv:: rewrite -> @term + .. insertprodn oriented_rewriter one_term_with_bindings - Is equivalent to :n:`rewrite @term` + .. prodn:: + oriented_rewriter ::= {? {| -> | <- } } {? @natural } {? {| ? | ! } } @one_term_with_bindings + one_term_with_bindings ::= {? > } @one_term {? with @bindings } - .. tacv:: rewrite <- @term + Rewrites terms based on equalities. The type of :n:`@one_term` must have the form: - Uses the equality :n:`@term`:sub:`1` :n:`= @term` :sub:`2` from right to left + :n:`{? forall {+ (x__i: A__i) } , } EQ @term__1 @term__2` - .. tacv:: rewrite @term in @goal_occurrences + where :g:`EQ` is the Leibniz equality `eq` or a registered setoid equality. + Note that :n:`eq @term__1 @term__2` is typically written with the infix notation + :n:`@term__1 = @term__2`. You must `Require Setoid` to use the tactic + with a setoid equality or with :ref:`setoid rewriting <generalizedrewriting>`. + In the general form, any :n:`@binder` may be used, not just :n:`(x__i: A__i)`. - Analogous to :n:`rewrite @term` but rewriting is done following - the clause :token:`goal_occurrences`. For instance: + .. todo doublecheck the @binder comment is correct. - + :n:`rewrite H in H'` will rewrite `H` in the hypothesis - ``H'`` instead of the current goal. - + :n:`rewrite H in H' at 1, H'' at - 2 |- *` means - :n:`rewrite H; rewrite H in H' at 1; rewrite H in H'' at - 2.` - In particular a failure will happen if any of these three simpler tactics - fails. - + :n:`rewrite H in * |-` will do :n:`rewrite H in H'` for all hypotheses - :g:`H'` different from :g:`H`. - A success will happen as soon as at least one of these simpler tactics succeeds. - + :n:`rewrite H in *` is a combination of :n:`rewrite H` and :n:`rewrite H in * |-` - that succeeds if at least one of these two tactics succeeds. + :n:`rewrite @one_term` finds subterms matching :n:`@term__1` in the goal, + and replaces them with :n:`@term__2` (or the reverse if `<-` is given). + Some of the variables :g:`x`\ :sub:`i` are solved by unification, + and some of the types :n:`A__1, ..., A__n` may become new + subgoals. :tacn:`rewrite` won't find occurrences inside `forall` that refer + to variables bound by the `forall`; use :tacn:`setoid_rewrite` + if you want to find such occurrences. - Orientation :g:`->` or :g:`<-` can be inserted before the :token:`term` to rewrite. + :n:`{+, @oriented_rewriter }` + The :n:`@oriented_rewriter`\s are applied sequentially + to the first goal generated by the previous :n:`@oriented_rewriter`. If any of them fail, + the tactic fails. - .. tacv:: rewrite @term at @occurrences + :n:`{? {| -> | <- } }` + For `->` (the default), :n:`@term__1` is rewritten + into :n:`@term__2`. For `<-`, :n:`@term__2` is rewritten into :n:`@term__1`. - Rewrite only the given :token:`occurrences` of :token:`term`. Occurrences are - specified from left to right as for pattern (:tacn:`pattern`). The rewrite is - always performed using setoid rewriting, even for Leibniz’s equality, so one - has to ``Import Setoid`` to use this variant. + :n:`{? @natural } {? {| ? | ! } }` + :n:`@natural` is the number of rewrites to perform. If `?` is given, :n:`@natural` + is the maximum number of rewrites to perform; otherwise :n:`@natural` is the exact number + of rewrites to perform. - .. tacv:: rewrite @term by @tactic + `?` (without :n:`@natural`) performs the rewrite as many times as possible + (possibly zero times). + This form never fails. `!` (without :n:`@natural`) performs the rewrite as many + times as possible + and at least once. The tactic fails if the requested number of rewrites can't + be performed. :n:`@natural !` is equivalent to :n:`@natural`. - Use tactic to completely solve the side-conditions arising from the - :tacn:`rewrite`. + :n:`@occurrences` + If :n:`@occurrences` specifies multiple occurrences, the tactic succeeds if + any of them can be rewritten. If not specified, only the first occurrence + in the conclusion is replaced. - .. tacv:: rewrite {+, @orientation @term} {? in @ident } + If :n:`at @occs_nums` is specified, rewriting is always done with + :ref:`setoid rewriting <generalizedrewriting>`, even for Leibniz’s equality. - Is equivalent to the `n` successive tactics :n:`{+; rewrite @term}`, each one - working on the first subgoal generated by the previous one. An :production:`orientation` - ``->`` or ``<-`` can be inserted before each :token:`term` to rewrite. One - unique clause can be added at the end after the keyword in; it will then - affect all rewrite operations. + :n:`by @ltac_expr3` + If specified, is used to resolve all side conditions generated by the tactic. - In all forms of rewrite described above, a :token:`term` to rewrite can be - immediately prefixed by one of the following modifiers: + .. exn:: Tactic failure: Setoid library not loaded. + :undocumented: - + `?` : the tactic :n:`rewrite ?@term` performs the rewrite of :token:`term` as many - times as possible (perhaps zero time). This form never fails. - + :n:`@natural?` : works similarly, except that it will do at most :token:`natural` rewrites. - + `!` : works as `?`, except that at least one rewrite should succeed, otherwise - the tactic fails. - + :n:`@natural!` (or simply :n:`@natural`) : precisely :token:`natural` rewrites of :token:`term` will be done, - leading to failure if these :token:`natural` rewrites are not possible. + .. todo You can use Typeclasses Debug to tell whether rewrite used + setoid rewriting. Example here: https://github.com/coq/coq/pull/13470#discussion_r539230973 - .. tacv:: erewrite @term - :name: erewrite + .. exn:: Cannot find a relation to rewrite. + :undocumented: - This tactic works as :n:`rewrite @term` but turning - unresolved bindings into existential variables, if any, instead of - failing. It has the same variants as :tacn:`rewrite` has. + .. exn:: Tactic generated a subgoal identical to the original goal. + :undocumented: + + .. exn:: Found no subterm matching @term in @ident. + Found no subterm matching @term in the current goal. + + This happens if :n:`@term` does not occur in, respectively, the named hypothesis or the goal. + + .. tacn:: erewrite {+, @oriented_rewriter } {? @occurrences } {? by @ltac_expr3 } + + Works like :tacn:`rewrite`, but turns + unresolved bindings, if any, into existential variables instead of + failing. It has the same parameters as :tacn:`rewrite`. .. flag:: Keyed Unification @@ -105,197 +126,224 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. the same key as the left- or right-hand side of the lemma given to rewrite, and the arguments are then unified up to full reduction. -.. tacn:: replace @term with @term’ - :name: replace - - This tactic applies to any goal. It replaces all free occurrences of :n:`@term` - in the current goal with :n:`@term’` and generates an equality :n:`@term = @term’` - as a subgoal. This equality is automatically solved if it occurs among - the assumptions, or if its symmetric form occurs. It is equivalent to - :n:`cut @term = @term’; [intro H`:sub:`n` :n:`; rewrite <- H`:sub:`n` :n:`; clear H`:sub:`n`:n:`|| assumption || symmetry; try assumption]`. - - .. exn:: Terms do not have convertible types. - :undocumented: - - .. tacv:: replace @term with @term’ by @tactic - - This acts as :n:`replace @term with @term’` but applies :token:`tactic` to solve the generated - subgoal :n:`@term = @term’`. +.. tacn:: rewrite * {? {| -> | <- } } @one_term {? in @ident } {? at @rewrite_occs } {? by @ltac_expr3 } + rewrite * {? {| -> | <- } } @one_term at @rewrite_occs in @ident {? by @ltac_expr3 } + :name: rewrite *; _ + :undocumented: - .. tacv:: replace @term +.. tacn:: rewrite_db @ident {? in @ident } + :undocumented: - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term = @term’` or :n:`@term’ = @term`. +.. tacn:: replace @one_term__from with @one_term__to {? @occurrences } {? by @ltac_expr3 } + replace {? {| -> | <- } } @one_term__from {? @occurrences } + :name: replace; _ - .. tacv:: replace -> @term + The first form replaces all free occurrences of :n:`@one_term__from` + in the current goal with :n:`@one_term__to` and generates an equality + :n:`@one_term__to = @one_term__from` + as a subgoal. (Note the generated equality is reversed with respect + to the order of the two terms in the tactic syntax; see + issue `#13480 <https://github.com/coq/coq/issues/13480>`_.) + This equality is automatically solved if it occurs among + the hypotheses, or if its symmetric form occurs. - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term = @term’` + The second form, with `->` or no arrow, replaces :n:`@one_term__from` + with :n:`@term__to` using + the first hypothesis whose type has the form :n:`@one_term__from = @term__to`. + If `<-` is given, the tactic uses the first hypothesis with the reverse form, + i.e. :n:`@term__to = @one_term__from`. - .. tacv:: replace <- @term + :n:`@occurrences` + The `type of` and `value of` forms are not supported. + Note you must `Require Setoid` to use the `at` clause in :n:`@occurrences`. - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term’ = @term` + :n:`by @ltac_expr3` + Applies the :n:`@ltac_expr3` to solve the generated equality. - .. tacv:: replace @term {? with @term} in @goal_occurrences {? by @tactic} - replace -> @term in @goal_occurrences - replace <- @term in @goal_occurrences + .. exn:: Terms do not have convertible types. + :undocumented: - Acts as before but the replacements take place in the specified clauses - (:token:`goal_occurrences`) (see :ref:`performingcomputations`) and not - only in the conclusion of the goal. The clause argument must not contain - any ``type of`` nor ``value of``. + .. tacn:: cutrewrite {? {| -> | <- } } @one_term {? in @ident } - .. tacv:: cutrewrite {? {| <- | -> } } (@term__1 = @term__2) {? in @ident } - :name: cutrewrite + Where :n:`@one_term` is an equality. .. deprecated:: 8.5 Use :tacn:`replace` instead. -.. tacn:: subst @ident - :name: subst +.. tacn:: substitute {? {| -> | <- } } @one_term {? with @bindings } + :undocumented: + +.. tacn:: subst {* @ident } - This tactic applies to a goal that has :n:`@ident` in its context and (at - least) one hypothesis, say :g:`H`, of type :n:`@ident = t` or :n:`t = @ident` - with :n:`@ident` not occurring in :g:`t`. Then it replaces :n:`@ident` by - :g:`t` everywhere in the goal (in the hypotheses and in the conclusion) and - clears :n:`@ident` and :g:`H` from the context. + For each :n:`@ident`, in order, for which there is a hypothesis in the form + :n:`@ident = @term` or :n:`@term = @ident`, replaces :n:`@ident` with :n:`@term` + everywhere in the hypotheses and the conclusion and clears :n:`@ident` and the hypothesis + from the context. If there are multiple hypotheses that match the :n:`@ident`, + the first one is used. If no :n:`@ident` is given, replacement is done for all + hypotheses in the appropriate form in top to bottom order. - If :n:`@ident` is a local definition of the form :n:`@ident := t`, it is also + If :n:`@ident` is a local definition of the form :n:`@ident := @term`, it is also unfolded and cleared. - If :n:`@ident` is a section variable it is expected to have no - indirect occurrences in the goal, i.e. that no global declarations - implicitly depending on the section variable must be present in the + If :n:`@ident` is a section variable it must have no + indirect occurrences in the goal, i.e. no global declarations + implicitly depending on the section variable may be present in the goal. .. note:: - + When several hypotheses have the form :n:`@ident = t` or :n:`t = @ident`, the - first one is used. - - + If :g:`H` is itself dependent in the goal, it is replaced by the proof of - reflexivity of equality. - - .. tacv:: subst {+ @ident} - - This is equivalent to :n:`subst @ident`:sub:`1`:n:`; ...; subst @ident`:sub:`n`. - - .. tacv:: subst - - This applies :tacn:`subst` repeatedly from top to bottom to all hypotheses of the - context for which an equality of the form :n:`@ident = t` or :n:`t = @ident` - or :n:`@ident := t` exists, with :n:`@ident` not occurring in - ``t`` and :n:`@ident` not a section variable with indirect - dependencies in the goal. + If the hypothesis is itself dependent in the goal, it is replaced by the proof of + reflexivity of equality. .. flag:: Regular Subst Tactic This flag controls the behavior of :tacn:`subst`. When it is activated (it is by default), :tacn:`subst` also deals with the following corner cases: - + A context with ordered hypotheses :n:`@ident`:sub:`1` :n:`= @ident`:sub:`2` - and :n:`@ident`:sub:`1` :n:`= t`, or :n:`t′ = @ident`:sub:`1`` with `t′` not - a variable, and no other hypotheses of the form :n:`@ident`:sub:`2` :n:`= u` - or :n:`u = @ident`:sub:`2`; without the flag, a second call to - subst would be necessary to replace :n:`@ident`:sub:`2` by `t` or + + A context with ordered hypotheses :n:`@ident__1 = @ident__2` + and :n:`@ident__1 = t`, or :n:`t′ = @ident__1` with `t′` not + a variable, and no other hypotheses of the form :n:`@ident__2 = u` + or :n:`u = @ident__2`; without the flag, a second call to + subst would be necessary to replace :n:`@ident__2` by `t` or `t′` respectively. + The presence of a recursive equation which without the flag would be a cause of failure of :tacn:`subst`. - + A context with cyclic dependencies as with hypotheses :n:`@ident`:sub:`1` :n:`= f @ident`:sub:`2` - and :n:`@ident`:sub:`2` :n:`= g @ident`:sub:`1` which without the + + A context with cyclic dependencies as with hypotheses :n:`@ident__1 = f @ident__2` + and :n:`@ident__2 = g @ident__1` which without the flag would be a cause of failure of :tacn:`subst`. - Additionally, it prevents a local definition such as :n:`@ident := t` to be + Additionally, it prevents a local definition such as :n:`@ident := t` from being unfolded which otherwise it would exceptionally unfold in configurations containing hypotheses of the form :n:`@ident = u`, or :n:`u′ = @ident` with `u′` not a variable. Finally, it preserves the initial order of hypotheses, which without the flag it may break. - default. - .. exn:: Cannot find any non-recursive equality over :n:`@ident`. + .. exn:: Cannot find any non-recursive equality over @ident. :undocumented: - .. exn:: Section variable :n:`@ident` occurs implicitly in global declaration :n:`@qualid` present in hypothesis :n:`@ident`. - Section variable :n:`@ident` occurs implicitly in global declaration :n:`@qualid` present in the conclusion. + .. exn:: Section variable @ident occurs implicitly in global declaration @qualid present in hypothesis @ident. + Section variable @ident occurs implicitly in global declaration @qualid present in the conclusion. Raised when the variable is a section variable with indirect dependencies in the goal. + If :n:`@ident` is a section variable, it must not have any + indirect occurrences in the goal, i.e. no global declarations + implicitly depending on the section variable may be present in the + goal. +.. tacn:: simple subst + :undocumented: -.. tacn:: stepl @term - :name: stepl +.. tacn:: stepl @one_term {? by @ltac_expr } - This tactic is for chaining rewriting steps. It assumes a goal of the - form :n:`R @term @term` where ``R`` is a binary relation and relies on a + For chaining rewriting steps. It assumes a goal in the + form :n:`R @term__1 @term__2` where ``R`` is a binary relation and relies on a database of lemmas of the form :g:`forall x y z, R x y -> eq x z -> R z y` - where `eq` is typically a setoid equality. The application of :n:`stepl @term` - then replaces the goal by :n:`R @term @term` and adds a new goal stating - :n:`eq @term @term`. + where `eq` is typically a setoid equality. The application of :n:`stepl @one_term` + then replaces the goal by :n:`R @one_term @term__2` and adds a new goal stating + :n:`eq @one_term @term__1`. + + If :n:`@ltac_expr` is specified, it is applied to the side condition. - .. cmd:: Declare Left Step @term + .. cmd:: Declare Left Step @one_term - Adds :n:`@term` to the database used by :tacn:`stepl`. + Adds :n:`@one_term` to the database used by :tacn:`stepl`. This tactic is especially useful for parametric setoids which are not accepted as regular setoids for :tacn:`rewrite` and :tacn:`setoid_replace` (see :ref:`Generalizedrewriting`). - .. tacv:: stepl @term by @tactic + .. tacn:: stepr @one_term {? by @ltac_expr } - This applies :n:`stepl @term` then applies :token:`tactic` to the second goal. - - .. tacv:: stepr @term by @tactic - :name: stepr - - This behaves as :tacn:`stepl` but on the right-hand-side of the binary - relation. Lemmas are expected to be of the form + This behaves like :tacn:`stepl` but on the right hand side of the binary + relation. Lemmas are expected to be in the form :g:`forall x y z, R x y -> eq y z -> R x z`. - .. cmd:: Declare Right Step @term + .. cmd:: Declare Right Step @one_term Adds :n:`@term` to the database used by :tacn:`stepr`. +Rewriting with definitional equality +------------------------------------ + +.. tacn:: change {? @one_term__from {? at @occs_nums } with } @one_term__to {? @occurrences } -.. tacn:: change @term - :name: change + Replaces terms with other :term:`convertible` terms. + If :n:`@one_term__from` is not specified, then :n:`@one_term__from` replaces the conclusion and/or + the specified hypotheses. If :n:`@one_term__from` is specified, the tactic replaces occurrences + of :n:`@one_term__to` within the conclusion and/or the specified hypotheses. - This tactic applies to any goal. It implements the rule ``Conv`` given in - :ref:`subtyping-rules`. :g:`change U` replaces the current goal `T` - with `U` providing that `U` is well-formed and that `T` and `U` are - convertible. + :n:`{? @one_term__from {? at @occs_nums } with }` + Replaces the occurrences of :n:`@one_term__from` specified by :n:`@occs_nums` + with :n:`@one_term__to`, provided that the two :n:`@one_term`\s are + convertible. :n:`@one_term__from` may contain pattern variables such as `?x`, + whose value which will substituted for `x` in :n:`@one_term__to`, such as in + `change (f ?x ?y) with (g (x, y))` or `change (fun x => ?f x) with f`. + + The `at ... with ...` form is deprecated in 8.14; use `with ... at ...` instead. + For `at ... with ... in H |-`, use `with ... in H at ... |-`. + + :n:`@occurrences` + If `with` is not specified, :n:`@occurrences` must only specify + entire hypotheses and/or the goal; it must not include any + :n:`at @occs_nums` clauses. .. exn:: Not convertible. :undocumented: - .. tacv:: change @term with @term’ + .. exn:: Found an "at" clause without "with" clause + :undocumented: - This replaces the occurrences of :n:`@term` by :n:`@term’` in the current goal. - The term :n:`@term` and :n:`@term’` must be convertible. + .. tacn:: now_show @one_term - .. tacv:: change @term at {+ @natural} with @term’ + A synonym for :n:`change @one_term`. It can be used to + make some proof steps explicit when refactoring a proof script + to make it readable. - This replaces the occurrences numbered :n:`{+ @natural}` of :n:`@term` by :n:`@term’` - in the current goal. The terms :n:`@term` and :n:`@term’` must be convertible. + .. seealso:: :ref:`Performing computations <performingcomputations>` - .. exn:: Too few occurrences. - :undocumented: +.. tacn:: change_no_check {? @one_term__from {? at @occs_nums } with } @one_term__to {? @occurrences } - .. tacv:: change @term {? {? at {+ @natural}} with @term} in @goal_occurrences + For advanced usage. Similar to :tacn:`change`, but as an optimization, + it skips checking that :n:`@one_term__to` is convertible with the goal or + :n:`@one_term__from`. - In the presence of :n:`with`, this applies :tacn:`change` to the - occurrences specified by :n:`@goal_occurrences`. In the - absence of :n:`with`, :n:`@goal_occurrences` is expected to - only list hypotheses (and optionally the conclusion) without - specifying occurrences (i.e. no :n:`at` clause). + Recall that the Coq kernel typechecks proofs again when they are concluded to + ensure correctness. Hence, using :tacn:`change` checks convertibility twice + overall, while :tacn:`change_no_check` can produce ill-typed terms, + but checks convertibility only once. + Hence, :tacn:`change_no_check` can be useful to speed up certain proof + scripts, especially if one knows by construction that the argument is + indeed convertible to the goal. - .. tacv:: now_show @term + In the following example, :tacn:`change_no_check` replaces :g:`False` with + :g:`True`, but :cmd:`Qed` then rejects the proof, ensuring consistency. - This is a synonym of :n:`change @term`. It can be used to - make some proof steps explicit when refactoring a proof script - to make it readable. + .. example:: - .. seealso:: :ref:`Performing computations <performingcomputations>` + .. coqtop:: all abort fail + + Goal False. + change_no_check True. + exact I. + Qed. + + .. example:: + + .. coqtop:: all abort fail + + Goal True -> False. + intro H. + change_no_check False in H. + exact H. + Qed. + + .. tacn:: convert_concl_no_check @one_term + + .. deprecated:: 8.11 + + Deprecated old name for :tacn:`change_no_check`. Does not support any of its + variants. .. _performingcomputations: diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index f454f4313d..609884ce1d 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1073,7 +1073,7 @@ main grammar, or from another custom entry as is the case in Notation "[ e ]" := e (e custom expr at level 2). to indicate that ``e`` has to be parsed at level ``2`` of the grammar -associated to the custom entry ``expr``. The level can be omitted, as in +associated with the custom entry ``expr``. The level can be omitted, as in .. coqdoc:: @@ -1159,7 +1159,6 @@ Similarly, to indicate that a custom entry should parse global references Notation "x" := x (in custom expr at level 0, x global). .. cmd:: Print Custom Grammar @ident - :name: Print Custom Grammar This displays the state of the grammar for terms associated with the custom entry :token:`ident`. @@ -1551,7 +1550,6 @@ Displaying information about scopes Use the :cmd:`Print Visibility` command to display the current notation scope stack. .. cmd:: Print Scope @scope_name - :name: Print Scope Displays all notations defined in the notation scope :n:`@scope_name`. It also displays the delimiting key and the class to which the @@ -1685,7 +1683,6 @@ Number notations ~~~~~~~~~~~~~~~~ .. cmd:: Number Notation @qualid__type @qualid__parse @qualid__print {? ( {+, @number_modifier } ) } : @scope_name - :name: Number Notation .. insertprodn number_modifier number_string_via @@ -1842,12 +1839,12 @@ Number notations .. exn:: @qualid__parse should go from Number.int to @type or (option @type). Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first). The parsing function given to the :cmd:`Number Notation` - vernacular is not of the right type. + command is not of the right type. .. exn:: @qualid__print should go from @type to Number.int or (option Number.int). Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first). The printing function given to the :cmd:`Number Notation` - vernacular is not of the right type. + command is not of the right type. .. exn:: Unexpected term @term while parsing a number notation. @@ -1877,7 +1874,6 @@ String notations ~~~~~~~~~~~~~~~~ .. cmd:: String Notation @qualid__type @qualid__parse @qualid__print {? ( @number_string_via ) } : @scope_name - :name: String Notation Allows the user to customize how strings are parsed and printed. @@ -1921,12 +1917,12 @@ String notations .. exn:: @qualid__parse should go from Byte.byte or (list Byte.byte) to @type or (option @type). The parsing function given to the :cmd:`String Notation` - vernacular is not of the right type. + command is not of the right type. .. exn:: @qualid__print should go from @type to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)). The printing function given to the :cmd:`String Notation` - vernacular is not of the right type. + command is not of the right type. .. exn:: Unexpected term @term while parsing a string notation. diff --git a/doc/sphinx/using/libraries/funind.rst b/doc/sphinx/using/libraries/funind.rst index 93571ecebb..0f0edc6bdd 100644 --- a/doc/sphinx/using/libraries/funind.rst +++ b/doc/sphinx/using/libraries/funind.rst @@ -170,7 +170,6 @@ Tactics ------- .. tacn:: functional induction @term {? using @one_term {? with @bindings } } {? as @simple_intropattern } - :name: functional induction Performs case analysis and induction following the definition of a function :token:`qualid`, which must be fully applied to its arguments as part of @@ -221,7 +220,6 @@ Tactics :undocumented: .. tacn:: functional inversion {| @ident | @natural } {? @qualid } - :name: functional inversion Performs inversion on hypothesis :n:`@ident` of the form :n:`@qualid {+ @term} = @term` or diff --git a/doc/sphinx/using/tools/coqdoc.rst b/doc/sphinx/using/tools/coqdoc.rst index b68b2ed2a7..78ac17bda1 100644 --- a/doc/sphinx/using/tools/coqdoc.rst +++ b/doc/sphinx/using/tools/coqdoc.rst @@ -34,9 +34,9 @@ Coq material inside documentation. Coq material is quoted between the delimiters ``[`` and ``]``. Square brackets may be nested, the inner ones being understood as being part of the -quoted code (thus you can quote a term like ``fun x => u`` by writing ``[fun -x => u]``). Inside quotations, the code is pretty-printed in the same -way as it is in code parts. +quoted code (thus you can quote a term like ``let id := fun [T : Type] (x : t) => x in id 0`` +by writing ``[let id := fun [T : Type] (x : t) => x in id 0]``). +Inside quotations, the code is pretty-printed the same way as in code parts. Preformatted vernacular is enclosed by ``[[`` and ``]]``. The former must be followed by a newline and the latter must follow a newline. diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 35243b5d7d..fa739e97bc 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -345,7 +345,7 @@ class VernacVariantObject(VernacObject): .. cmd:: Axiom @ident : @term. This command links :token:`term` to the name :token:`term` as its specification in - the global context. The fact asserted by :token:`term` is thus assumed as a + the global environment. The fact asserted by :token:`term` is thus assumed as a postulate. .. cmdv:: Parameter @ident : @term. diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 75b3260166..44bb767011 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -864,8 +864,8 @@ ltac_expr1: [ | EDIT match_key ADD_OPT "reverse" "goal" "with" match_context_list "end" | MOVETO simple_tactic match_key OPT "reverse" "goal" "with" match_context_list "end" | MOVETO simple_tactic match_key ltac_expr5 "with" match_list "end" -| REPLACE failkw [ int_or_var | ] LIST0 message_token -| WITH failkw OPT int_or_var LIST0 message_token +| REPLACE failkw [ nat_or_var | ] LIST0 message_token +| WITH failkw OPT nat_or_var LIST0 message_token | REPLACE reference LIST0 tactic_arg | WITH reference LIST1 tactic_arg | l1_tactic @@ -1003,7 +1003,7 @@ simple_tactic: [ | DELETE "replace" uconstr clause | "replace" orient uconstr clause | REPLACE "rewrite" "*" orient uconstr "in" hyp "at" occurrences by_arg_tac -| WITH "rewrite" "*" orient uconstr OPT ( "in" hyp ) OPT ( "at" occurrences by_arg_tac ) +| WITH "rewrite" "*" orient uconstr OPT ( "in" hyp ) OPT ( "at" occurrences ) by_arg_tac | DELETE "rewrite" "*" orient uconstr "in" hyp by_arg_tac | DELETE "rewrite" "*" orient uconstr "at" occurrences by_arg_tac | DELETE "rewrite" "*" orient uconstr by_arg_tac @@ -1814,6 +1814,7 @@ ltac_defined_tactics: [ | "lia" | "lra" | "nia" +| "now_show" constr | "nra" | "over" TAG SSR | "split_Rabs" @@ -2373,7 +2374,7 @@ ssrapplyarg: [ ] constr_with_bindings_arg: [ -| EDIT ADD_OPT ">" constr_with_bindings TAG SSR +| EDIT ADD_OPT ">" constr_with_bindings ] destruction_arg: [ @@ -2469,6 +2470,15 @@ variance_identref: [ | EDIT ADD_OPT variance identref ] +conversion: [ +| DELETE constr +| DELETE constr "with" constr +| PRINT +| REPLACE constr "at" occs_nums "with" constr +| WITH OPT ( constr OPT ( "at" occs_nums ) "with" ) constr +| PRINT +] + SPLICE: [ | clause | noedit_mode @@ -2694,6 +2704,8 @@ SPLICE: [ | cumul_ident_decl | variance | variance_identref +| rewriter +| conversion ] (* end SPLICE *) RENAME: [ @@ -2751,6 +2763,7 @@ RENAME: [ | pattern_occ pattern_occs | hypident_occ hyp_occs | concl_occ concl_occs +| constr_with_bindings_arg one_term_with_bindings ] simple_tactic: [ diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index dd7990368e..a1c1d87763 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -1726,8 +1726,6 @@ let process_rst g file args seen tac_prods cmd_prods = let cmd_exclude_files = [ "doc/sphinx/proof-engine/ssreflect-proof-language.rst"; - "doc/sphinx/proofs/writing-proofs/rewriting.rst"; - "doc/sphinx/proofs/writing-proofs/proof-mode.rst"; "doc/sphinx/proof-engine/tactics.rst"; ] in diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index ccf38d2c15..9f2559ffbc 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -2095,7 +2095,7 @@ ltac_expr1: [ | "first" "[" LIST0 ltac_expr5 SEP "|" "]" | "solve" "[" LIST0 ltac_expr5 SEP "|" "]" | "idtac" LIST0 message_token -| failkw [ int_or_var | ] LIST0 message_token +| failkw [ nat_or_var | ] LIST0 message_token | simple_tactic | tactic_value | reference LIST0 tactic_arg diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index d950b32160..b53af609ec 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -1247,11 +1247,7 @@ lident: [ destruction_arg: [ | natural -| constr_with_bindings_arg -] - -constr_with_bindings_arg: [ -| OPT ">" one_term OPT ( "with" bindings ) (* SSR plugin *) +| one_term_with_bindings ] occurrences: [ @@ -1657,7 +1653,7 @@ simple_tactic: [ | "first" "[" LIST0 ltac_expr SEP "|" "]" | "solve" "[" LIST0 ltac_expr SEP "|" "]" | "idtac" LIST0 [ ident | string | natural ] -| [ "fail" | "gfail" ] OPT int_or_var LIST0 [ ident | string | natural ] +| [ "fail" | "gfail" ] OPT nat_or_var LIST0 [ ident | string | natural ] | ltac_expr ssrintros (* SSR plugin *) | "fun" LIST1 name "=>" ltac_expr | "eval" red_expr "in" term @@ -1691,7 +1687,7 @@ simple_tactic: [ | "absurd" one_term | "contradiction" OPT ( one_term OPT ( "with" bindings ) ) | "autorewrite" OPT "*" "with" LIST1 ident OPT occurrences OPT ( "using" ltac_expr ) -| "rewrite" "*" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) OPT ( "at" rewrite_occs OPT ( "by" ltac_expr3 ) ) +| "rewrite" "*" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) OPT ( "at" rewrite_occs ) OPT ( "by" ltac_expr3 ) | "rewrite" "*" OPT [ "->" | "<-" ] one_term "at" rewrite_occs "in" ident OPT ( "by" ltac_expr3 ) | "refine" one_term | "simple" "refine" one_term @@ -1783,12 +1779,12 @@ simple_tactic: [ | "eintros" LIST0 intropattern | "decide" "equality" | "compare" one_term one_term -| "apply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as -| "eapply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as -| "simple" "apply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as -| "simple" "eapply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as -| "elim" constr_with_bindings_arg OPT ( "using" one_term OPT ( "with" bindings ) ) -| "eelim" constr_with_bindings_arg OPT ( "using" one_term OPT ( "with" bindings ) ) +| "apply" LIST1 one_term_with_bindings SEP "," OPT in_hyp_as +| "eapply" LIST1 one_term_with_bindings SEP "," OPT in_hyp_as +| "simple" "apply" LIST1 one_term_with_bindings SEP "," OPT in_hyp_as +| "simple" "eapply" LIST1 one_term_with_bindings SEP "," OPT in_hyp_as +| "elim" one_term_with_bindings OPT ( "using" one_term OPT ( "with" bindings ) ) +| "eelim" one_term_with_bindings OPT ( "using" one_term OPT ( "with" bindings ) ) | "case" induction_clause_list | "ecase" induction_clause_list | "fix" ident natural OPT ( "with" LIST1 fixdecl ) @@ -1842,8 +1838,8 @@ simple_tactic: [ | "unfold" LIST1 reference_occs SEP "," OPT occurrences | "fold" LIST1 one_term OPT occurrences | "pattern" LIST1 pattern_occs SEP "," OPT occurrences -| "change" conversion OPT occurrences -| "change_no_check" conversion OPT occurrences +| "change" OPT ( one_term OPT ( "at" occs_nums ) "with" ) one_term OPT occurrences +| "change_no_check" OPT ( one_term OPT ( "at" occs_nums ) "with" ) one_term OPT occurrences | "btauto" | "rtauto" | "congruence" OPT natural OPT ( "with" LIST1 one_term ) @@ -1922,6 +1918,7 @@ simple_tactic: [ | "lia" | "lra" | "nia" +| "now_show" one_term | "nra" | "over" (* SSR plugin *) | "split_Rabs" @@ -1977,11 +1974,11 @@ as_name: [ ] oriented_rewriter: [ -| OPT [ "->" | "<-" ] rewriter +| OPT [ "->" | "<-" ] OPT natural OPT [ "?" | "!" ] one_term_with_bindings ] -rewriter: [ -| OPT natural OPT [ "?" | "!" ] constr_with_bindings_arg +one_term_with_bindings: [ +| OPT ">" one_term OPT ( "with" bindings ) ] induction_clause_list: [ @@ -2454,12 +2451,6 @@ cofixdecl: [ | "(" ident LIST0 simple_binder ":" term ")" ] -conversion: [ -| one_term -| one_term "with" one_term -| one_term "at" occs_nums "with" one_term -] - func_scheme_def: [ | ident ":=" "Induction" "for" qualid "Sort" sort_family (* funind plugin *) ] diff --git a/engine/eConstr.ml b/engine/eConstr.ml index c29de27efb..157995a173 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -35,6 +35,10 @@ include (Evd.MiniEConstr : module type of Evd.MiniEConstr type types = t type constr = t type existential = t pexistential +type case_return = t pcase_return +type case_branch = t pcase_branch +type case_invert = t pcase_invert +type case = (t, t, EInstance.t) pcase type fixpoint = (t, t) pfixpoint type cofixpoint = (t, t) pcofixpoint type unsafe_judgment = (constr, types) Environ.punsafe_judgment @@ -69,7 +73,7 @@ let mkInd i = of_kind (Ind (in_punivs i)) let mkConstructU pc = of_kind (Construct pc) let mkConstruct c = of_kind (Construct (in_punivs c)) let mkConstructUi ((ind,u),i) = of_kind (Construct ((ind,i),u)) -let mkCase (ci, c, iv, r, p) = of_kind (Case (ci, c, iv, r, p)) +let mkCase (ci, u, pms, c, iv, r, p) = of_kind (Case (ci, u, pms, c, iv, r, p)) let mkFix f = of_kind (Fix f) let mkCoFix f = of_kind (CoFix f) let mkProj (p, c) = of_kind (Proj (p, c)) @@ -195,7 +199,7 @@ let destCoFix sigma c = match kind sigma c with | _ -> raise DestKO let destCase sigma c = match kind sigma c with -| Case (ci, t, iv, c, p) -> (ci, t, iv, c, p) +| Case (ci, u, pms, t, iv, c, p) -> (ci, u, pms, t, iv, c, p) | _ -> raise DestKO let destProj sigma c = match kind sigma c with @@ -320,19 +324,28 @@ let existential_type = Evd.existential_type let lift n c = of_constr (Vars.lift n (unsafe_to_constr c)) -let map_under_context f n c = - let f c = unsafe_to_constr (f (of_constr c)) in - of_constr (Constr.map_under_context f n (unsafe_to_constr c)) -let map_branches f ci br = - let f c = unsafe_to_constr (f (of_constr c)) in - of_constr_array (Constr.map_branches f ci (unsafe_to_constr_array br)) -let map_return_predicate f ci p = - let f c = unsafe_to_constr (f (of_constr c)) in - of_constr (Constr.map_return_predicate f ci (unsafe_to_constr p)) +let of_branches : Constr.case_branch array -> case_branch array = + match Evd.MiniEConstr.unsafe_eq with + | Refl -> fun x -> x + +let unsafe_to_branches : case_branch array -> Constr.case_branch array = + match Evd.MiniEConstr.unsafe_eq with + | Refl -> fun x -> x + +let of_return : Constr.case_return -> case_return = + match Evd.MiniEConstr.unsafe_eq with + | Refl -> fun x -> x -let map_user_view sigma f c = +let unsafe_to_return : case_return -> Constr.case_return = + match Evd.MiniEConstr.unsafe_eq with + | Refl -> fun x -> x + +let map_branches f br = + let f c = unsafe_to_constr (f (of_constr c)) in + of_branches (Constr.map_branches f (unsafe_to_branches br)) +let map_return_predicate f p = let f c = unsafe_to_constr (f (of_constr c)) in - of_constr (Constr.map_user_view f (unsafe_to_constr (whd_evar sigma c))) + of_return (Constr.map_return_predicate f (unsafe_to_return p)) let map sigma f c = let f c = unsafe_to_constr (f (of_constr c)) in @@ -346,7 +359,61 @@ let iter sigma f c = let f c = f (of_constr c) in Constr.iter f (unsafe_to_constr (whd_evar sigma c)) -let iter_with_full_binders sigma g f n c = +let expand_case env _sigma (ci, u, pms, p, iv, c, bl) = + let u = EInstance.unsafe_to_instance u in + let pms = unsafe_to_constr_array pms in + let p = unsafe_to_return p in + let iv = unsafe_to_case_invert iv in + let c = unsafe_to_constr c in + let bl = unsafe_to_branches bl in + let (ci, p, iv, c, bl) = Inductive.expand_case env (ci, u, pms, p, iv, c, bl) in + let p = of_constr p in + let c = of_constr c in + let iv = of_case_invert iv in + let bl = of_constr_array bl in + (ci, p, iv, c, bl) + +let annotate_case env sigma (ci, u, pms, p, iv, c, bl as case) = + let (_, p, _, _, bl) = expand_case env sigma case in + let p = + (* Too bad we need to fetch this data in the environment, should be in the + case_info instead. *) + let (_, mip) = Inductive.lookup_mind_specif env ci.ci_ind in + decompose_lam_n_decls sigma (mip.Declarations.mind_nrealdecls + 1) p + in + let mk_br c n = decompose_lam_n_decls sigma n c in + let bl = Array.map2 mk_br bl ci.ci_cstr_ndecls in + (ci, u, pms, p, iv, c, bl) + +let expand_branch env _sigma u pms (ind, i) (nas, _br) = + let open Declarations in + let u = EInstance.unsafe_to_instance u in + let pms = unsafe_to_constr_array pms in + let (mib, mip) = Inductive.lookup_mind_specif env ind in + let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsubst = Vars.subst_of_rel_context_instance paramdecl (Array.to_list pms) in + let subst = paramsubst @ Inductive.ind_subst (fst ind) mib u in + let (ctx, _) = mip.mind_nf_lc.(i - 1) in + let (ctx, _) = List.chop mip.mind_consnrealdecls.(i - 1) ctx in + let ans = Inductive.instantiate_context u subst nas ctx in + let ans : rel_context = match Evd.MiniEConstr.unsafe_eq with Refl -> ans in + ans + +let contract_case env _sigma (ci, p, iv, c, bl) = + let p = unsafe_to_constr p in + let iv = unsafe_to_case_invert iv in + let c = unsafe_to_constr c in + let bl = unsafe_to_constr_array bl in + let (ci, u, pms, p, iv, c, bl) = Inductive.contract_case env (ci, p, iv, c, bl) in + let u = EInstance.make u in + let pms = of_constr_array pms in + let p = of_return p in + let iv = of_case_invert iv in + let c = of_constr c in + let bl = of_branches bl in + (ci, u, pms, p, iv, c, bl) + +let iter_with_full_binders env sigma g f n c = let open Context.Rel.Declaration in match kind sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -357,7 +424,10 @@ let iter_with_full_binders sigma g f n c = | LetIn (na,b,t,c) -> f n b; f n t; f (g (LocalDef (na, b, t)) n) c | App (c,l) -> f n c; Array.Fun1.iter f n l | Evar (_,l) -> List.iter (fun c -> f n c) l - | Case (_,p,iv,c,bl) -> f n p; iter_invert (f n) iv; f n c; Array.Fun1.iter f n bl + | Case (ci,u,pms,p,iv,c,bl) -> + let (ci, _, pms, p, iv, c, bl) = annotate_case env sigma (ci, u, pms, p, iv, c, bl) in + let f_ctx (ctx, c) = f (List.fold_right g ctx n) c in + Array.Fun1.iter f n pms; f_ctx p; iter_invert (f n) iv; f n c; Array.iter f_ctx bl | Proj (p,c) -> f n c | Fix (_,(lna,tl,bl)) -> Array.iter (f n) tl; @@ -566,8 +636,8 @@ let universes_of_constr sigma c = | Array (u,_,_,_) -> let s = LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s in fold sigma aux s c - | Case (_,_,CaseInvert {univs;args=_},_,_) -> - let s = LSet.fold LSet.add (Instance.levels (EInstance.kind sigma univs)) s in + | Case (_,u,_,_,_,_,_) -> + let s = LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s in fold sigma aux s c | _ -> fold sigma aux s c in aux LSet.empty c diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 882dfe2848..0d038e9a67 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -20,6 +20,8 @@ type t = Evd.econstr type types = t type constr = t type existential = t pexistential +type case_return = t pcase_return +type case_branch = t pcase_branch type fixpoint = (t, t) pfixpoint type cofixpoint = (t, t) pcofixpoint type unsafe_judgment = (constr, types) Environ.punsafe_judgment @@ -58,6 +60,9 @@ sig val is_empty : t -> bool end +type case_invert = t pcase_invert +type case = (t, t, EInstance.t) pcase + type 'a puniverses = 'a * EInstance.t (** {5 Destructors} *) @@ -128,7 +133,7 @@ val mkIndU : inductive * EInstance.t -> t val mkConstruct : constructor -> t val mkConstructU : constructor * EInstance.t -> t val mkConstructUi : (inductive * EInstance.t) * int -> t -val mkCase : case_info * t * (t,EInstance.t) case_invert * t * t array -> t +val mkCase : case -> t val mkFix : (t, t) pfixpoint -> t val mkCoFix : (t, t) pcofixpoint -> t val mkArrow : t -> Sorts.relevance -> t -> t @@ -199,7 +204,7 @@ val destConst : Evd.evar_map -> t -> Constant.t * EInstance.t val destEvar : Evd.evar_map -> t -> t pexistential val destInd : Evd.evar_map -> t -> inductive * EInstance.t val destConstruct : Evd.evar_map -> t -> constructor * EInstance.t -val destCase : Evd.evar_map -> t -> case_info * t * (t,EInstance.t) case_invert * t * t array +val destCase : Evd.evar_map -> t -> case val destProj : Evd.evar_map -> t -> Projection.t * t val destFix : Evd.evar_map -> t -> (t, t) pfixpoint val destCoFix : Evd.evar_map -> t -> (t, t) pcofixpoint @@ -250,14 +255,12 @@ val compare_constr : Evd.evar_map -> (t -> t -> bool) -> t -> t -> bool (** {6 Iterators} *) val map : Evd.evar_map -> (t -> t) -> t -> t -val map_user_view : Evd.evar_map -> (t -> t) -> t -> t val map_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> t) -> 'a -> t -> t -val map_under_context : (t -> t) -> int -> t -> t -val map_branches : (t -> t) -> case_info -> t array -> t array -val map_return_predicate : (t -> t) -> case_info -> t -> t +val map_branches : (t -> t) -> case_branch array -> case_branch array +val map_return_predicate : (t -> t) -> case_return -> case_return val iter : Evd.evar_map -> (t -> unit) -> t -> unit val iter_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit -val iter_with_full_binders : Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit +val iter_with_full_binders : Environ.env -> Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit val fold : Evd.evar_map -> ('a -> t -> 'a) -> 'a -> t -> 'a (** Gather the universes transitively used in the term, including in the @@ -337,6 +340,21 @@ val fresh_global : val is_global : Evd.evar_map -> GlobRef.t -> t -> bool [@@ocaml.deprecated "Use [EConstr.isRefX] instead."] +val expand_case : Environ.env -> Evd.evar_map -> + case -> (case_info * t * case_invert * t * t array) + +val annotate_case : Environ.env -> Evd.evar_map -> case -> + case_info * EInstance.t * t array * (rel_context * t) * case_invert * t * (rel_context * t) array +(** Same as above, but doesn't turn contexts into binders *) + +val expand_branch : Environ.env -> Evd.evar_map -> + EInstance.t -> t array -> constructor -> case_branch -> rel_context +(** Given a universe instance and parameters for the inductive type, + constructs the typed context in which the branch lives. *) + +val contract_case : Environ.env -> Evd.evar_map -> + (case_info * t * case_invert * t * t array) -> case + (** {5 Extra} *) val of_existential : Constr.existential -> existential @@ -345,7 +363,7 @@ val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (t, typ val to_rel_decl : Evd.evar_map -> (t, types) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt -val of_case_invert : (Constr.t,Univ.Instance.t) case_invert -> (t,EInstance.t) case_invert +val of_case_invert : Constr.case_invert -> case_invert (** {5 Unsafe operations} *) @@ -371,7 +389,7 @@ sig val to_instance : EInstance.t -> Univ.Instance.t (** Physical identity. Does not care for normalization. *) - val to_case_invert : (t,EInstance.t) case_invert -> (Constr.t,Univ.Instance.t) case_invert + val to_case_invert : case_invert -> Constr.case_invert val eq : (t, Constr.t) eq (** Use for transparent cast between types. *) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index ba6a9ea6d9..f9f8268507 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -144,7 +144,7 @@ let head_evar sigma c = let c = EConstr.Unsafe.to_constr c in let rec hrec c = match kind c with | Evar (evk,_) -> evk - | Case (_,_,_,c,_) -> hrec c + | Case (_, _, _, _, _, c, _) -> hrec c | App (c,_) -> hrec c | Cast (c,_,_) -> hrec c | Proj (p, c) -> hrec c diff --git a/engine/evd.mli b/engine/evd.mli index a6d55c2615..58f635b7bd 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -772,8 +772,8 @@ module MiniEConstr : sig (Constr.t, Constr.types) Context.Named.Declaration.pt val unsafe_to_rel_decl : (t, t) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt - val of_case_invert : (constr,Univ.Instance.t) case_invert -> (econstr,EInstance.t) case_invert - val unsafe_to_case_invert : (econstr,EInstance.t) case_invert -> (constr,Univ.Instance.t) case_invert + val of_case_invert : constr pcase_invert -> econstr pcase_invert + val unsafe_to_case_invert : econstr pcase_invert -> constr pcase_invert val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (t, t) Context.Rel.Declaration.pt val to_rel_decl : evar_map -> (t, t) Context.Rel.Declaration.pt -> diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli index 7784b38c80..5208469082 100644 --- a/engine/logic_monad.mli +++ b/engine/logic_monad.mli @@ -74,7 +74,7 @@ module NonLogical : sig (** [try ... with ...] but restricted to {!Exception}. *) val catch : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t - val timeout : int -> 'a t -> 'a option t + val timeout : float -> 'a t -> 'a option t (** Construct a monadified side-effect. Exceptions raised by the argument are wrapped with {!Exception}. *) diff --git a/engine/proofview.ml b/engine/proofview.ml index b3061eaa81..abc1a907d3 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -927,7 +927,7 @@ let _ = CErrors.register_handler begin function | _ -> None end -let tclTIMEOUT n t = +let tclTIMEOUTF n t = let open Proof in (* spiwack: as one of the monad is a continuation passing monad, it doesn't force the computation to be threaded inside the underlying @@ -952,6 +952,8 @@ let tclTIMEOUT n t = return res | Util.Inr (e, info) -> tclZERO ~info e +let tclTIMEOUT n t = tclTIMEOUTF (float_of_int n) t + let tclTIME s t = let pr_time t1 t2 n msg = let msg = diff --git a/engine/proofview.mli b/engine/proofview.mli index fe0d7ae51e..bf6021b1b6 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -418,7 +418,8 @@ val tclCHECKINTERRUPT : unit tactic (** [tclTIMEOUT n t] can have only one success. In case of timeout it fails with [tclZERO Tac_Timeout]. *) -val tclTIMEOUT : int -> 'a tactic -> 'a tactic +val tclTIMEOUTF : float -> 'a tactic -> 'a tactic +val tclTIMEOUT : int -> 'a tactic -> 'a tactic (** [tclTIME s t] displays time for each atomic call to t, using s as an identifying annotation if present *) diff --git a/engine/termops.ml b/engine/termops.ml index 66131e1a8f..4dc584cfa8 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -606,7 +606,7 @@ let map_left2 f a g b = r, s end -let map_constr_with_binders_left_to_right sigma g f l c = +let map_constr_with_binders_left_to_right env sigma g f l c = let open RelDecl in let open EConstr in match EConstr.kind sigma c with @@ -650,14 +650,20 @@ let map_constr_with_binders_left_to_right sigma g f l c = let al' = List.map_left (f l) al in if List.for_all2 (==) al' al then c else mkEvar (e, al') - | Case (ci,p,iv,b,bl) -> + | Case (ci,u,pms,p,iv,b,bl) -> + let (ci, _, pms, p0, _, b, bl0) = annotate_case env sigma (ci, u, pms, p, iv, b, bl) in + let f_ctx (nas, _ as r) (ctx, c) = + let c' = f (List.fold_right g ctx l) c in + if c' == c then r else (nas, c') + in (* In v8 concrete syntax, predicate is after the term to match! *) let b' = f l b in + let pms' = Array.map_left (f l) pms in + let p' = f_ctx p p0 in let iv' = map_invert (f l) iv in - let p' = f l p in - let bl' = Array.map_left (f l) bl in - if b' == b && p' == p && iv' == iv && bl' == bl then c - else mkCase (ci, p', iv', b', bl') + let bl' = Array.map_left (fun (c, c0) -> f_ctx c c0) (Array.map2 (fun x y -> (x, y)) bl bl0) in + if b' == b && pms' == pms && p' == p && iv' == iv && bl' == bl then c + else mkCase (ci, u, pms', p', iv', b', bl') | Fix (ln,(lna,tl,bl as fx)) -> let l' = fold_rec_types g fx l in let (tl', bl') = map_left2 (f l) tl (f l') bl in @@ -677,34 +683,8 @@ let map_constr_with_binders_left_to_right sigma g f l c = if def' == def && t' == t && ty' == ty then c else mkArray(u,t',def',ty') -let rec map_under_context_with_full_binders sigma g f l n d = - if n = 0 then f l d else - match EConstr.kind sigma d with - | LetIn (na,b,t,c) -> - let b' = f l b in - let t' = f l t in - let c' = map_under_context_with_full_binders sigma g f (g (Context.Rel.Declaration.LocalDef (na,b,t)) l) (n-1) c in - if b' == b && t' == t && c' == c then d - else EConstr.mkLetIn (na,b',t',c') - | Lambda (na,t,b) -> - let t' = f l t in - let b' = map_under_context_with_full_binders sigma g f (g (Context.Rel.Declaration.LocalAssum (na,t)) l) (n-1) b in - if t' == t && b' == b then d - else EConstr.mkLambda (na,t',b') - | _ -> CErrors.anomaly (Pp.str "Ill-formed context") - -let map_branches_with_full_binders sigma g f l ci bl = - let tags = Array.map List.length ci.ci_pp_info.cstr_tags in - let bl' = Array.map2 (map_under_context_with_full_binders sigma g f l) tags bl in - if Array.for_all2 (==) bl' bl then bl else bl' - -let map_return_predicate_with_full_binders sigma g f l ci p = - let n = List.length ci.ci_pp_info.ind_tags in - let p' = map_under_context_with_full_binders sigma g f l n p in - if p' == p then p else p' - (* strong *) -let map_constr_with_full_binders_gen userview sigma g f l cstr = +let map_constr_with_full_binders env sigma g f l cstr = let open EConstr in match EConstr.kind sigma cstr with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -736,20 +716,19 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = | Evar (e,al) -> let al' = List.map (f l) al in if List.for_all2 (==) al al' then cstr else mkEvar (e, al') - | Case (ci,p,iv,c,bl) when userview -> - let p' = map_return_predicate_with_full_binders sigma g f l ci p in - let iv' = map_invert (f l) iv in - let c' = f l c in - let bl' = map_branches_with_full_binders sigma g f l ci bl in - if p==p' && iv'==iv && c==c' && bl'==bl then cstr else - mkCase (ci, p', iv', c', bl') - | Case (ci,p,iv,c,bl) -> - let p' = f l p in + | Case (ci, u, pms, p, iv, c, bl) -> + let (ci, _, pms, p0, _, c, bl0) = annotate_case env sigma (ci, u, pms, p, iv, c, bl) in + let f_ctx (nas, _ as r) (ctx, c) = + let c' = f (List.fold_right g ctx l) c in + if c' == c then r else (nas, c') + in + let pms' = Array.Smart.map (f l) pms in + let p' = f_ctx p p0 in let iv' = map_invert (f l) iv in let c' = f l c in - let bl' = Array.map (f l) bl in - if p==p' && iv'==iv && c==c' && Array.for_all2 (==) bl bl' then cstr else - mkCase (ci, p', iv', c', bl') + let bl' = Array.map2 f_ctx bl bl0 in + if pms==pms' && p==p' && iv'==iv && c==c' && Array.for_all2 (==) bl bl' then cstr else + mkCase (ci, u, pms', p', iv', c', bl') | Fix (ln,(lna,tl,bl as fx)) -> let tl' = Array.map (f l) tl in let l' = fold_rec_types g fx l in @@ -770,12 +749,6 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = let ty' = f l ty in if def==def' && t == t' && ty==ty' then cstr else mkArray (u,t', def',ty') -let map_constr_with_full_binders sigma g f = - map_constr_with_full_binders_gen false sigma g f - -let map_constr_with_full_binders_user_view sigma g f = - map_constr_with_full_binders_gen true sigma g f - (* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate subterms of [c] starting from [acc] and proceeding from left to right according to the usual representation of the constructions as @@ -783,7 +756,7 @@ let map_constr_with_full_binders_user_view sigma g f = index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive *) -let fold_constr_with_full_binders sigma g f n acc c = +let fold_constr_with_full_binders env sigma g f n acc c = let open EConstr.Vars in let open Context.Rel.Declaration in match EConstr.kind sigma c with @@ -795,7 +768,10 @@ let fold_constr_with_full_binders sigma g f n acc c = | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_,c) -> f n acc c | Evar (_,l) -> List.fold_left (f n) acc l - | Case (_,p,iv,c,bl) -> Array.fold_left (f n) (f n (fold_invert (f n) (f n acc p) iv) c) bl + | Case (ci, u, pms, p, iv, c, bl) -> + let (ci, _, pms, p, _, c, bl) = EConstr.annotate_case env sigma (ci, u, pms, p, iv, c, bl) in + let f_ctx acc (ctx, c) = f (List.fold_right g ctx n) acc c in + Array.fold_left f_ctx (f n (fold_invert (f n) (f_ctx (Array.fold_left (f n) acc pms) p) iv) c) bl | Fix (_,(lna,tl,bl)) -> let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in diff --git a/engine/termops.mli b/engine/termops.mli index 709fa361a9..12df61e4c8 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -50,16 +50,12 @@ val it_mkLambda_or_LetIn_from_no_LetIn : Constr.constr -> Constr.rel_context -> (** {6 Generic iterators on constr} *) val map_constr_with_binders_left_to_right : - Evd.evar_map -> + Environ.env -> Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val map_constr_with_full_binders : - Evd.evar_map -> - (rel_declaration -> 'a -> 'a) -> - ('a -> constr -> constr) -> 'a -> constr -> constr -val map_constr_with_full_binders_user_view : - Evd.evar_map -> + Environ.env -> Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr @@ -73,7 +69,7 @@ val map_constr_with_full_binders_user_view : val fold_constr_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b -val fold_constr_with_full_binders : Evd.evar_map -> +val fold_constr_with_full_binders : Environ.env -> Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b diff --git a/engine/univSubst.ml b/engine/univSubst.ml index 335c2e5e68..330ed5d0ad 100644 --- a/engine/univSubst.ml +++ b/engine/univSubst.ml @@ -68,6 +68,10 @@ let subst_univs_fn_constr f c = let u' = fi u in if u' == u then t else (changed := true; mkConstructU (c, u')) + | Case (ci, u, pms, p, iv, c, br) -> + let u' = fi u in + if u' == u then map aux t + else (changed := true; map aux (mkCase (ci, u', pms, p, iv, c, br))) | _ -> map aux t in let c' = aux c in @@ -147,10 +151,10 @@ let nf_evars_and_universes_opt_subst f subst = | Sort (Type u) -> let u' = Univ.subst_univs_universe subst u in if u' == u then c else mkSort (sort_of_univ u') - | Case (ci,p,CaseInvert {univs;args},t,br) -> - let univs' = Instance.subst_fn lsubst univs in - if univs' == univs then Constr.map aux c - else Constr.map aux (mkCase (ci,p,CaseInvert {univs=univs';args},t,br)) + | Case (ci,u,pms,p,iv,t,br) -> + let u' = Instance.subst_fn lsubst u in + if u' == u then Constr.map aux c + else Constr.map aux (mkCase (ci,u',pms,p,iv,t,br)) | Array (u,elems,def,ty) -> let u' = Univ.Instance.subst_fn lsubst u in let elems' = CArray.Smart.map aux elems in diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 70a4ea35e9..7c63ebda3a 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -244,6 +244,8 @@ let contract_curly_brackets_pat ntn (l,ll) = type local_univs = { bound : Univ.Level.t Id.Map.t; unb_univs : bool } +let empty_local_univs = { bound = Id.Map.empty; unb_univs = false } + type intern_env = { ids: Id.Set.t; unb: bool; @@ -1202,6 +1204,11 @@ let intern_sort ~local_univs s = let intern_instance ~local_univs us = Option.map (List.map (map_glob_sort_gen (intern_sort_name ~local_univs))) us +let try_interp_name_alias = function + | [], { CAst.v = CRef (ref,u) } -> + NRef (intern_reference ref,intern_instance ~local_univs:empty_local_univs u) + | _ -> raise Not_found + (* Is it a global reference or a syntactic definition? *) let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = let loc = qid.loc in @@ -1251,16 +1258,16 @@ let intern_qualid_for_pattern test_global intern_not qid pats = | SynDef kn -> let filter (vars,a) = match a with - | NRef g -> + | NRef (g,_) -> (* Convention: do not deactivate implicit arguments and scopes for further arguments *) test_global g; let () = assert (List.is_empty vars) in Some (g, Some [], pats) - | NApp (NRef g,[]) -> (* special case: Syndef for @Cstr deactivates implicit arguments *) + | NApp (NRef (g,_),[]) -> (* special case: Syndef for @Cstr deactivates implicit arguments *) test_global g; let () = assert (List.is_empty vars) in Some (g, None, pats) - | NApp (NRef g,args) -> + | NApp (NRef (g,_),args) -> (* Convention: do not deactivate implicit arguments and scopes for further arguments *) test_global g; let nvars = List.length vars in @@ -1330,7 +1337,7 @@ let interp_reference vars r = let r,_ = intern_applied_reference ~isproj:None (fun _ -> error_not_enough_arguments ?loc:None) {ids = Id.Set.empty; unb = false; - local_univs = { bound=Id.Map.empty; unb_univs = false };(* <- doesn't matter here *) + local_univs = empty_local_univs;(* <- doesn't matter here *) tmp_scope = None; scopes = []; impls = empty_internalization_env; binder_block_names = None} Environ.empty_named_context_val @@ -1784,10 +1791,10 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = if Id.equal id ldots_var then DAst.make ?loc @@ RCPatAtom (Some ((make ?loc id),scopes)) else anomaly (str "Unbound pattern notation variable: " ++ Id.print id ++ str ".") end - | NRef g -> + | NRef (g,_) -> ensure_kind test_kind ?loc g; DAst.make ?loc @@ RCPatCstr (g, in_patargs ?loc scopes g true false [] args) - | NApp (NRef g,ntnpl) -> + | NApp (NRef (g,_),ntnpl) -> ensure_kind test_kind ?loc g; let ntnpl = List.map (in_not test_kind_inner loc scopes fullsubst []) ntnpl in let no_impl = @@ -2554,7 +2561,7 @@ let interp_notation_constr env ?(impls=empty_internalization_env) nenv a = let impls = Id.Map.fold (fun id _ impls -> Id.Map.remove id impls) nenv.ninterp_var_type impls in let c = internalize env {ids; unb = false; - local_univs = { bound = Id.Map.empty; unb_univs = false }; + local_univs = empty_local_univs; tmp_scope = None; scopes = []; impls; binder_block_names = None} false (empty_ltac_sign, vl) a in diff --git a/interp/constrintern.mli b/interp/constrintern.mli index f92a54e23f..65b63962d0 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -150,6 +150,10 @@ val interp_constr_pattern : (** Raise Not_found if syndef not bound to a name and error if unexisting ref *) val intern_reference : qualid -> GlobRef.t +(** For syntactic definitions: check if abbreviation to a name + and avoid early insertion of maximal implicit arguments *) +val try_interp_name_alias : 'a list * constr_expr -> notation_constr + (** Expands abbreviations (syndef); raise an error if not existing *) val interp_reference : ltac_sign -> qualid -> glob_constr diff --git a/interp/impargs.ml b/interp/impargs.ml index 7742f985de..1e85fadce5 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -209,16 +209,16 @@ let add_free_rels_until strict strongly_strict revpat bound env sigma m pos acc acc.(i) <- update pos rig acc.(i) | App (f,_) when rig && is_flexible_reference env sigma bound depth f -> if strict then () else - iter_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders env sigma push_lift (frec false) ed c | Proj (p, _) when rig -> if strict then () else - iter_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders env sigma push_lift (frec false) ed c | Case _ when rig -> if strict then () else - iter_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders env sigma push_lift (frec false) ed c | Evar _ -> () | _ -> - iter_with_full_binders sigma push_lift (frec rig) ed c + iter_with_full_binders env sigma push_lift (frec rig) ed c in let () = if not (Vars.noccur_between sigma 1 bound m) then frec true (env,1) m in acc @@ -228,7 +228,7 @@ let add_free_rels_until strict strongly_strict revpat bound env sigma m pos acc let rec is_rigid_head sigma t = match kind sigma t with | Rel _ | Evar _ -> false | Ind _ | Const _ | Var _ | Sort _ -> true - | Case (_,_,_,f,_) -> is_rigid_head sigma f + | Case (_,_,_,_,_,f,_) -> is_rigid_head sigma f | Proj (p,c) -> true | App (f,args) -> (match kind sigma f with diff --git a/interp/notation.ml b/interp/notation.ml index f2d113954b..33d96f0439 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -400,12 +400,12 @@ let cases_pattern_key c = match DAst.get c with | _ -> Oth let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) - | NApp (NRef ref,args) -> RefKey(canonical_gr ref), AppBoundedNotation (List.length args) - | NList (_,_,NApp (NRef ref,args),_,_) - | NBinderList (_,_,NApp (NRef ref,args),_,_) -> + | NApp (NRef (ref,_),args) -> RefKey(canonical_gr ref), AppBoundedNotation (List.length args) + | NList (_,_,NApp (NRef (ref,_),args),_,_) + | NBinderList (_,_,NApp (NRef (ref,_),args),_,_) -> RefKey (canonical_gr ref), AppBoundedNotation (List.length args) - | NRef ref -> RefKey(canonical_gr ref), NotAppNotation - | NApp (NList (_,_,NApp (NRef ref,args),_,_), args') -> + | NRef (ref,_) -> RefKey(canonical_gr ref), NotAppNotation + | NApp (NList (_,_,NApp (NRef (ref,_),args),_,_), args') -> RefKey (canonical_gr ref), AppBoundedNotation (List.length args + List.length args') | NApp (NList (_,_,NApp (_,args),_,_), args') -> Oth, AppBoundedNotation (List.length args + List.length args') @@ -2353,8 +2353,8 @@ let browse_notation strict ntn map = let global_reference_of_notation ~head test (ntn,sc,(on_parsing,on_printing,{not_interp = (_,c)})) = match c with - | NRef ref when test ref -> Some (on_parsing,on_printing,ntn,sc,ref) - | NApp (NRef ref, l) when head || List.for_all isNVar_or_NHole l && test ref -> + | NRef (ref,_) when test ref -> Some (on_parsing,on_printing,ntn,sc,ref) + | NApp (NRef (ref,_), l) when head || List.for_all isNVar_or_NHole l && test ref -> Some (on_parsing,on_printing,ntn,sc,ref) | _ -> None diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 0e7f085bde..ea5e2a1ad4 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -43,6 +43,28 @@ let cast_type_iter2 f t1 t2 = match t1, t2 with in NList and NBinderList, since the iterator has its own variable *) let replace_var i j var = j :: List.remove Id.equal i var +(* compare_glob_universe_instances true strictly_lt us1 us2 computes us1 <= us2, + compare_glob_universe_instances false strictly_lt us1 us2 computes us1 = us2. + strictly_lt will be set to true if any part is strictly less. *) +let compare_glob_universe_instances lt strictly_lt us1 us2 = + match us1, us2 with + | None, None -> true + | Some _, None -> strictly_lt := true; lt + | None, Some _ -> false + | Some l1, Some l2 -> + CList.for_all2eq (fun u1 u2 -> + match u1, u2 with + | UAnonymous {rigid=true}, UAnonymous {rigid=true} -> true + | UAnonymous {rigid=false}, UAnonymous {rigid=false} -> true + | UAnonymous _, UAnonymous _ -> false + | UNamed _, UAnonymous _ -> strictly_lt := true; lt + | UAnonymous _, UNamed _ -> false + | UNamed _, UNamed _ -> glob_level_eq u1 u2) l1 l2 + +(* Compute us1 <= us2, as a boolean *) +let compare_glob_universe_instances_le us1 us2 = + compare_glob_universe_instances true (ref false) us1 us2 + (* When [lt] is [true], tell if [t1] is a strict refinement of [t2] (this is a partial order, so returning [false] does not mean that [t2] is finer than [t1]); when [lt] is false, tell if [t1] is the @@ -93,7 +115,7 @@ let compare_notation_constr lt (vars1,vars2) t1 t2 = | NHole _, NVar id2 when lt && List.mem_f Id.equal id2 vars2 -> () | NVar id1, NHole (_, _, _) when lt && List.mem_f Id.equal id1 vars1 -> () | _, NVar id2 when lt && List.mem_f Id.equal id2 vars2 -> strictly_lt := true - | NRef gr1, NRef gr2 when GlobRef.equal gr1 gr2 -> () + | NRef (gr1,u1), NRef (gr2,u2) when GlobRef.equal gr1 gr2 && compare_glob_universe_instances lt strictly_lt u1 u2 -> () | NHole (_, _, _), NHole (_, _, _) -> () (* FIXME? *) | _, NHole (_, _, _) when lt -> strictly_lt := true | NList (i1, j1, iter1, tail1, b1), NList (i2, j2, iter2, tail2, b2) @@ -377,7 +399,7 @@ let glob_constr_of_notation_constr_with_binders ?loc g f ?(h=default_binder_stat | NCast (c,k) -> GCast (f e c,map_cast_type (f (h.slide e)) k) | NSort x -> GSort x | NHole (x, naming, arg) -> GHole (x, naming, arg) - | NRef x -> GRef (x,None) + | NRef (x,u) -> GRef (x,u) | NInt i -> GInt i | NFloat f -> GFloat f | NArray (t,def,ty) -> GArray(None, Array.map (f e) t, f e def, f e ty) @@ -612,7 +634,7 @@ let notation_constr_and_vars_of_glob_constr recvars a = | GHole (w,naming,arg) -> if arg != None then has_ltac := true; NHole (w, naming, arg) - | GRef (r,_) -> NRef r + | GRef (r,u) -> NRef (r,u) | GArray (_u,t,def,ty) -> NArray (Array.map aux t, aux def, aux ty) | GEvar _ | GPatVar _ -> user_err Pp.(str "Existential variables not allowed in notations.") @@ -706,10 +728,10 @@ let rec subst_pat subst pat = let rec subst_notation_constr subst bound raw = match raw with - | NRef ref -> + | NRef (ref,u) -> let ref',t = subst_global subst ref in if ref' == ref then raw else (match t with - | None -> NRef ref' + | None -> NRef (ref',u) | Some t -> fst (notation_constr_of_constr bound t.Univ.univ_abstracted_value)) @@ -1344,7 +1366,7 @@ let rec match_ inner u alp metas sigma a1 a2 = (* Matching compositionally *) | GVar id1, NVar id2 when alpha_var id1 id2 (fst (snd alp)) -> sigma - | GRef (r1,_), NRef r2 when (GlobRef.equal r1 r2) -> sigma + | GRef (r1,u1), NRef (r2,u2) when (GlobRef.equal r1 r2) && compare_glob_universe_instances_le u1 u2 -> sigma | GApp (f1,l1), NApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in let f1,l1,f2,l2 = @@ -1570,10 +1592,10 @@ let rec match_cases_pattern metas (terms,termlists,(),() as sigma) a1 a2 = match DAst.get a1, a2 with | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(false,0,[]) | PatVar Anonymous, NHole _ -> sigma,(false,0,[]) - | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (GlobRef.ConstructRef r2) when Construct.CanOrd.equal r1 r2 -> + | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (GlobRef.ConstructRef r2,None) when Construct.CanOrd.equal r1 r2 -> let l = try add_patterns_for_params_remove_local_defs (Global.env ()) r1 largs with Not_found -> raise No_match in sigma,(false,0,l) - | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (GlobRef.ConstructRef r2),l2) + | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (GlobRef.ConstructRef r2,None),l2) when Construct.CanOrd.equal r1 r2 -> let l1 = try add_patterns_for_params_remove_local_defs (Global.env()) r1 args1 with Not_found -> raise No_match in let le2 = List.length l2 in @@ -1597,9 +1619,9 @@ and match_cases_pattern_no_more_args metas sigma a1 a2 = let match_ind_pattern metas sigma ind pats a2 = match a2 with - | NRef (GlobRef.IndRef r2) when Ind.CanOrd.equal ind r2 -> + | NRef (GlobRef.IndRef r2,None) when Ind.CanOrd.equal ind r2 -> sigma,(false,0,pats) - | NApp (NRef (GlobRef.IndRef r2),l2) + | NApp (NRef (GlobRef.IndRef r2,None),l2) when Ind.CanOrd.equal ind r2 -> let le2 = List.length l2 in if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length pats diff --git a/interp/notation_term.ml b/interp/notation_term.ml index c541a19bfd..2979447cf8 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -21,7 +21,7 @@ open Glob_term type notation_constr = (* Part common to [glob_constr] and [cases_pattern] *) - | NRef of GlobRef.t + | NRef of GlobRef.t * glob_level list option | NVar of Id.t | NApp of notation_constr * notation_constr list | NHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option diff --git a/interp/reserve.ml b/interp/reserve.ml index 274d3655d3..07160dcf6f 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -71,10 +71,10 @@ let reserve_table = Summary.ref Id.Map.empty ~name:"reserved-type" let reserve_revtable = Summary.ref KeyMap.empty ~name:"reserved-type-rev" let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) - | NApp (NRef ref,args) -> RefKey(canonical_gr ref), Some (List.length args) - | NList (_,_,NApp (NRef ref,args),_,_) - | NBinderList (_,_,NApp (NRef ref,args),_,_) -> RefKey (canonical_gr ref), Some (List.length args) - | NRef ref -> RefKey(canonical_gr ref), None + | NApp (NRef (ref,_),args) -> RefKey(canonical_gr ref), Some (List.length args) + | NList (_,_,NApp (NRef (ref,_),args),_,_) + | NBinderList (_,_,NApp (NRef (ref,_),args),_,_) -> RefKey (canonical_gr ref), Some (List.length args) + | NRef (ref,_) -> RefKey(canonical_gr ref), None | _ -> Oth, None let cache_reserved_type (_,(id,t)) = diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 46baa00c74..91d05f7317 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -26,7 +26,7 @@ let global_of_extended_global_head = function | SynDef kn -> let _, syn_def = search_syntactic_definition kn in let rec head_of = function - | NRef ref -> ref + | NRef (ref,None) -> ref | NApp (rc, _) -> head_of rc | NCast (rc, _) -> head_of rc | NLetIn (_, _, _, rc) -> head_of rc @@ -37,8 +37,8 @@ let global_of_extended_global = function | TrueGlobal ref -> ref | SynDef kn -> match search_syntactic_definition kn with - | [],NRef ref -> ref - | [],NApp (NRef ref,[]) -> ref + | [],NRef (ref,None) -> ref + | [],NApp (NRef (ref,None),[]) -> ref | _ -> raise Not_found let locate_global_with_alias ?(head=false) qid = diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index f3ad3546ff..39e628883a 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -40,7 +40,7 @@ let load_syntax_constant i ((sp,kn),(_local,syndef)) = Nametab.push_syndef (Nametab.Until i) sp kn let is_alias_of_already_visible_name sp = function - | _,NRef ref -> + | _,NRef (ref,_) -> let (dir,id) = repr_qualid (Nametab.shortest_qualid_of_global Id.Set.empty ref) in DirPath.is_empty dir && Id.equal id (basename sp) | _ -> diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index 1ba6a8c8fe..4bc6848ba7 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -31,7 +31,8 @@ int arity[STOP+1]; void init_arity () { /* instruction with zero operand */ arity[ACC0]=arity[ACC1]=arity[ACC2]=arity[ACC3]=arity[ACC4]=arity[ACC5]= - arity[ACC6]=arity[ACC7]=arity[PUSH]=arity[PUSHACC0]=arity[PUSHACC1]= + arity[ACC6]=arity[ACC7]= + arity[PUSH]=arity[PUSHACC1]= arity[PUSHACC2]=arity[PUSHACC3]=arity[PUSHACC4]=arity[PUSHACC5]= arity[PUSHACC6]=arity[PUSHACC7]= arity[ENVACC0]=arity[ENVACC1]=arity[ENVACC2]=arity[ENVACC3]= @@ -39,10 +40,10 @@ void init_arity () { arity[APPLY1]=arity[APPLY2]=arity[APPLY3]=arity[APPLY4]=arity[RESTART]= arity[OFFSETCLOSURE0]=arity[OFFSETCLOSURE1]= arity[PUSHOFFSETCLOSURE0]=arity[PUSHOFFSETCLOSURE1]= - arity[GETFIELD0]=arity[GETFIELD1]=arity[SETFIELD0]=arity[SETFIELD1]= + arity[GETFIELD0]=arity[GETFIELD1]= arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= - arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= + arity[ACCUMULATE]=arity[STOP]= 0; /* instruction with one operand */ arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= @@ -60,7 +61,6 @@ void init_arity () { arity[CHECKDIV21INT63]= arity[CHECKLXORINT63]=arity[CHECKLORINT63]=arity[CHECKLANDINT63]= arity[CHECKLSLINT63]=arity[CHECKLSRINT63]=arity[CHECKADDMULDIVINT63]= - arity[CHECKLSLINT63CONST1]=arity[CHECKLSRINT63CONST1]= arity[CHECKEQINT63]=arity[CHECKLTINT63]=arity[CHECKLEINT63]= arity[CHECKCOMPAREINT63]=arity[CHECKHEAD0INT63]=arity[CHECKTAIL0INT63]= arity[CHECKEQFLOAT]=arity[CHECKLTFLOAT]=arity[CHECKLEFLOAT]= diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 6255250218..a9ea6d9f46 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -338,10 +338,6 @@ value coq_interprete print_instr("PUSH"); *--sp = accu; Next; } - Instruct(PUSHACC0) { - print_instr("PUSHACC0"); - *--sp = accu; Next; - } Instruct(PUSHACC1){ print_instr("PUSHACC1"); *--sp = accu; accu = sp[1]; Next; @@ -1015,20 +1011,6 @@ value coq_interprete Next; } - Instruct(SETFIELD0){ - print_instr("SETFIELD0"); - caml_modify(&Field(accu, 0),*sp); - sp++; - Next; - } - - Instruct(SETFIELD1){ - print_instr("SETFIELD1"); - caml_modify(&Field(accu, 1),*sp); - sp++; - Next; - } - Instruct(SETFIELD){ print_instr("SETFIELD"); caml_modify(&Field(accu, *pc),*sp); @@ -1288,16 +1270,6 @@ value coq_interprete Next; } - Instruct(MAKEPROD) { - print_instr("MAKEPROD"); - *--sp=accu; - Alloc_small(accu,2,0); - Field(accu, 0) = sp[0]; - Field(accu, 1) = sp[1]; - sp += 2; - Next; - } - Instruct(BRANCH) { /* unconditional branching */ print_instr("BRANCH"); @@ -1501,34 +1473,6 @@ value coq_interprete Next; } - Instruct(CHECKLSLINT63CONST1) { - print_instr("CHECKLSLINT63CONST1"); - if (Is_uint63(accu)) { - pc++; - Uint63_lsl1(accu); - Next; - } else { - *--sp = uint63_one(); - *--sp = accu; - accu = Field(coq_global_data, *pc++); - goto apply2; - } - } - - Instruct(CHECKLSRINT63CONST1) { - print_instr("CHECKLSRINT63CONST1"); - if (Is_uint63(accu)) { - pc++; - Uint63_lsr1(accu); - Next; - } else { - *--sp = uint63_one(); - *--sp = accu; - accu = Field(coq_global_data, *pc++); - goto apply2; - } - } - Instruct (CHECKADDMULDIVINT63) { print_instr("CHECKADDMULDIVINT63"); CheckInt3(); diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h index 13568957c2..dd9b9e55be 100644 --- a/kernel/byterun/coq_uint63_emul.h +++ b/kernel/byterun/coq_uint63_emul.h @@ -119,12 +119,8 @@ DECLARE_BINOP(lor) #define Uint63_lor(x, y) CALL_BINOP(lor, x, y) DECLARE_BINOP(lsl) #define Uint63_lsl(x, y) CALL_BINOP(lsl, x, y) -DECLARE_UNOP(lsl1) -#define Uint63_lsl1(x) CALL_UNOP(lsl1, x) DECLARE_BINOP(lsr) #define Uint63_lsr(x, y) CALL_BINOP(lsr, x, y) -DECLARE_UNOP(lsr1) -#define Uint63_lsr1(x) CALL_UNOP(lsr1, x) DECLARE_BINOP(lt) #define Uint63_lt(r, x, y) CALL_RELATION(r, lt, x, y) DECLARE_BINOP(lxor) diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h index 27696e8856..731ae8f46e 100644 --- a/kernel/byterun/coq_uint63_native.h +++ b/kernel/byterun/coq_uint63_native.h @@ -55,8 +55,6 @@ else \ accu = uint63_zero; \ }while(0) -#define Uint63_lsl1(x) (accu = (value)((((uint64_t)(x)-1) << 1) +1)) -#define Uint63_lsr1(x) (accu = (value)(((uint64_t)(x) >> 1) |1)) /* addmuldiv(p,x,y) = x * 2^p + y / 2 ^ (63 - p) */ /* (modulo 2^63) for p <= 63 */ diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index d2256720c4..a32c8f1cd1 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -34,6 +34,8 @@ open Environ open Vars open Esubst +module RelDecl = Context.Rel.Declaration + let stats = ref false (* Profiling *) @@ -342,8 +344,8 @@ and fterm = | FProj of Projection.t * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) - | FCaseInvert of case_info * constr * finvert * fconstr * constr array * fconstr subs + | FCaseT of case_info * Univ.Instance.t * constr array * case_return * fconstr * case_branch array * fconstr subs (* predicate and branches are closures *) + | FCaseInvert of case_info * Univ.Instance.t * constr array * case_return * finvert * fconstr * case_branch array * fconstr subs | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs @@ -355,7 +357,7 @@ and fterm = | FCLOS of constr * fconstr subs | FLOCKED -and finvert = Univ.Instance.t * fconstr array +and finvert = fconstr array let fterm_of v = v.term let set_ntrl v = v.mark <- Mark.set_ntrl v.mark @@ -410,7 +412,7 @@ type 'a next_native_args = (CPrimitives.arg_kind * 'a) list type stack_member = | Zapp of fconstr array - | ZcaseT of case_info * constr * constr array * fconstr subs + | ZcaseT of case_info * Univ.Instance.t * constr array * case_return * case_branch array * fconstr subs | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zprimitive of CPrimitives.t * pconstant * fconstr list * fconstr next_native_args @@ -578,10 +580,11 @@ let rec to_constr lfts v = | FFlex (ConstKey op) -> mkConstU op | FInd op -> mkIndU op | FConstruct op -> mkConstructU op - | FCaseT (ci,p,c,ve,env) -> to_constr_case lfts ci p NoInvert c ve env - | FCaseInvert (ci,p,(univs,args),c,ve,env) -> - let iv = CaseInvert {univs;args=Array.map (to_constr lfts) args} in - to_constr_case lfts ci p iv c ve env + | FCaseT (ci, u, pms, p, c, ve, env) -> + to_constr_case lfts ci u pms p NoInvert c ve env + | FCaseInvert (ci, u, pms, p, indices, c, ve, env) -> + let iv = CaseInvert {indices=Array.map (to_constr lfts) indices} in + to_constr_case lfts ci u pms p iv c ve env | FFix ((op,(lna,tys,bds)) as fx, e) -> if is_subs_id e && is_lift_id lfts then mkFix fx @@ -649,14 +652,20 @@ let rec to_constr lfts v = subst_constr subs t | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*) -and to_constr_case lfts ci p iv c ve env = +and to_constr_case lfts ci u pms p iv c ve env = if is_subs_id env && is_lift_id lfts then - mkCase (ci, p, iv, to_constr lfts c, ve) + mkCase (ci, u, pms, p, iv, to_constr lfts c, ve) else let subs = comp_subs lfts env in - mkCase (ci, subst_constr subs p, iv, - to_constr lfts c, - Array.map (fun b -> subst_constr subs b) ve) + let f_ctx (nas, c) = + let c = subst_constr (Esubst.subs_liftn (Array.length nas) subs) c in + (nas, c) + in + mkCase (ci, u, Array.map (fun c -> subst_constr subs c) pms, + f_ctx p, + iv, + to_constr lfts c, + Array.map f_ctx ve) and subst_constr subst c = match [@ocaml.warning "-4"] Constr.kind c with | Rel i -> @@ -687,8 +696,8 @@ let rec zip m stk = match stk with | [] -> m | Zapp args :: s -> zip {mark=Mark.neutr m.mark; term=FApp(m, args)} s - | ZcaseT(ci,p,br,e)::s -> - let t = FCaseT(ci, p, m, br, e) in + | ZcaseT(ci, u, pms, p, br, e)::s -> + let t = FCaseT(ci, u, pms, p, m, br, e) in let mark = mark (neutr (Mark.red_state m.mark)) Unknown in zip {mark; term=t} s | Zproj p :: s -> @@ -763,6 +772,9 @@ let rec subs_consn v i n s = if Int.equal i n then s else subs_consn v (i + 1) n (subs_cons v.(i) s) +let subs_consv v s = + subs_consn v 0 (Array.length v) s + (* Beta reduction: look for an applied argument in the stack. Since the encountered update marks are removed, h must be a whnf *) let rec get_args n tys f e = function @@ -870,6 +882,74 @@ let drop_parameters depth n argstk = (* we know that n < stack_args_size(argstk) (if well-typed term) *) anomaly (Pp.str "ill-typed term: found a match on a partially applied constructor.") +let inductive_subst (ind, _) mib u pms e = + let rec self i accu = + if Int.equal i mib.mind_ntypes then accu + else + let c = inject (mkIndU ((ind, i), u)) in + self (i + 1) (subs_cons c accu) + in + let self = self 0 (subs_id 0) in + let rec mk_pms i ctx = match ctx with + | [] -> self + | RelDecl.LocalAssum _ :: ctx -> + let c = mk_clos e pms.(i) in + let subs = mk_pms (i - 1) ctx in + subs_cons c subs + | RelDecl.LocalDef (_, c, _) :: ctx -> + let c = Vars.subst_instance_constr u c in + let subs = mk_pms i ctx in + subs_cons (mk_clos subs c) subs + in + mk_pms (Array.length pms - 1) mib.mind_params_ctxt + +(* Iota-reduction: feed the arguments of the constructor to the branch *) +let get_branch infos depth ci u pms (ind, c) br e args = + let i = c - 1 in + let args = drop_parameters depth ci.ci_npar args in + let (_nas, br) = br.(i) in + if Int.equal ci.ci_cstr_ndecls.(i) ci.ci_cstr_nargs.(i) then + (* No let-bindings in the constructor, we don't have to fetch the + environment to know the value of the branch. *) + let rec push e stk = match stk with + | [] -> e + | Zapp v :: stk -> push (subs_consv v e) stk + | (Zshift _ | ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zprimitive _) :: _ -> + assert false + in + let e = push e args in + (br, e) + else + (* The constructor contains let-bindings, but they are not physically + present in the match, so we fetch them in the environment. *) + let env = info_env infos in + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + let (ctx, _) = mip.mind_nf_lc.(i) in + let ctx, _ = List.chop mip.mind_consnrealdecls.(i) ctx in + let map = function + | Zapp args -> args + | Zshift _ | ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zprimitive _ -> + assert false + in + let ind_subst = inductive_subst ind mib u pms e in + let args = Array.concat (List.map map args) in + let rec push i e = function + | [] -> [] + | RelDecl.LocalAssum _ :: ctx -> + let ans = push (pred i) e ctx in + args.(i) :: ans + | RelDecl.LocalDef (_, b, _) :: ctx -> + let ans = push i e ctx in + let b = subst_instance_constr u b in + let s = Array.rev_of_list ans in + let e = subs_consv s ind_subst in + let v = mk_clos e b in + v :: ans + in + let ext = push (Array.length args - 1) [] ctx in + (br, subs_consv (Array.rev_of_list ext) e) + (** [eta_expand_ind_stack env ind c s t] computes stacks corresponding to the conversion of the eta expansion of t, considered as an inhabitant of ind, and the Constructor c of this inductive type applied to arguments @@ -909,7 +989,6 @@ let rec project_nth_arg n = function | (ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zshift _ | Zprimitive _) :: _ | [] -> assert false (* After drop_parameters we have a purely applicative stack *) - (* Iota reduction: expansion of a fixpoint. * Given a fixpoint and a substitution, returns the corresponding * fixpoint body, and the substitution in which it should be @@ -1269,7 +1348,7 @@ let rec knh info m stk = | FCLOS(t,e) -> knht info e t (zupdate info m stk) | FLOCKED -> assert false | FApp(a,b) -> knh info a (append_stack b (zupdate info m stk)) - | FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate info m stk) + | FCaseT(ci,u,pms,p,t,br,e) -> knh info t (ZcaseT(ci,u,pms,p,br,e)::zupdate info m stk) | FFix(((ri,n),_),_) -> (match get_nth_arg m ri.(n) stk with (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') @@ -1289,10 +1368,10 @@ and knht info e t stk = match kind t with | App(a,b) -> knht info e a (append_stack (mk_clos_vect e b) stk) - | Case(ci,p,NoInvert,t,br) -> - knht info e t (ZcaseT(ci, p, br, e)::stk) - | Case(ci,p,CaseInvert{univs;args},t,br) -> - let term = FCaseInvert (ci, p, (univs,Array.map (mk_clos e) args), mk_clos e t, br, e) in + | Case(ci,u,pms,p,NoInvert,t,br) -> + knht info e t (ZcaseT(ci, u, pms, p, br, e)::stk) + | Case(ci,u,pms,p,CaseInvert{indices},t,br) -> + let term = FCaseInvert (ci, u, pms, p, (Array.map (mk_clos e) indices), mk_clos e t, br, e) in { mark = mark Red Unknown; term }, stk | Fix fx -> knh info { mark = mark Cstr Unknown; term = FFix (fx, e) } stk | Cast(a,_,_) -> knht info e a stk @@ -1347,15 +1426,15 @@ let rec knr info tab m stk = | Def v -> kni info tab v stk | Primitive _ -> assert false | OpaqueDef _ | Undef _ -> (set_ntrl m; (m,stk))) - | FConstruct((_ind,c),_u) -> + | FConstruct(c,_u) -> let use_match = red_set info.i_flags fMATCH in let use_fix = red_set info.i_flags fFIX in if use_match || use_fix then (match [@ocaml.warning "-4"] strip_update_shift_app m stk with - | (depth, args, ZcaseT(ci,_,br,e)::s) when use_match -> + | (depth, args, ZcaseT(ci,u,pms,_,br,e)::s) when use_match -> assert (ci.ci_npar>=0); - let rargs = drop_parameters depth ci.ci_npar args in - knit info tab e br.(c-1) (rargs@s) + let (br, e) = get_branch info depth ci u pms c br e args in + knit info tab e br s | (_, cargs, Zfix(fx,par)::s) when use_fix -> let rarg = fapp_stack(m,cargs) in let stk' = par @ append_stack [|rarg|] s in @@ -1399,8 +1478,9 @@ let rec knr info tab m stk = kni info tab a (Zprimitive(op,c,rargs,nargs)::s) end | (_, _, s) -> (m, s)) - | FCaseInvert (ci,_p,iv,_c,v,env) when red_set info.i_flags fMATCH -> - begin match case_inversion info tab ci iv v with + | FCaseInvert (ci, u, pms, _p,iv,_c,v,env) when red_set info.i_flags fMATCH -> + let pms = mk_clos_vect env pms in + begin match case_inversion info tab ci u pms iv v with | Some c -> knit info tab env c stk | None -> (m, stk) end @@ -1417,13 +1497,17 @@ and knit info tab e t stk = let (ht,s) = knht info e t stk in knr info tab ht s -and case_inversion info tab ci (univs,args) v = +and case_inversion info tab ci u params indices v = let open Declarations in - if Array.is_empty args then Some v.(0) + (* No binders / lets at all in the unique branch *) + let v = match v with + | [| [||], v |] -> v + | _ -> assert false + in + if Array.is_empty indices then Some v else let env = info_env info in let ind = ci.ci_ind in - let params, indices = Array.chop ci.ci_npar args in let psubst = subs_consn params 0 ci.ci_npar (subs_id 0) in let mib = Environ.lookup_mind (fst ind) env in let mip = mib.mind_packets.(snd ind) in @@ -1432,12 +1516,12 @@ and case_inversion info tab ci (univs,args) v = let _ind, expect_args = destApp expect in let check_index i index = let expected = expect_args.(ci.ci_npar + i) in - let expected = Vars.subst_instance_constr univs expected in + let expected = Vars.subst_instance_constr u expected in let expected = mk_clos psubst expected in !conv {info with i_flags=all} tab expected index in if Array.for_all_i check_index 0 indices - then Some v.(0) else None + then Some v else None let kh info tab v stk = fapp_stack(kni info tab v stk) @@ -1448,9 +1532,13 @@ let rec zip_term zfun m stk = | [] -> m | Zapp args :: s -> zip_term zfun (mkApp(m, Array.map zfun args)) s - | ZcaseT(ci,p,br,e)::s -> - let t = mkCase(ci, zfun (mk_clos e p), NoInvert, m, - Array.map (fun b -> zfun (mk_clos e b)) br) in + | ZcaseT(ci, u, pms, p, br, e) :: s -> + let zip_ctx (nas, c) = + let e = Esubst.subs_liftn (Array.length nas) e in + (nas, zfun (mk_clos e c)) + in + let t = mkCase(ci, u, Array.map (fun c -> zfun (mk_clos e c)) pms, zip_ctx p, + NoInvert, m, Array.map zip_ctx br) in zip_term zfun t s | Zproj p::s -> let t = mkProj (Projection.make p true, m) in diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 3e8916673d..bccbddb0fc 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -110,8 +110,8 @@ type fterm = | FProj of Projection.t * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) - | FCaseInvert of case_info * constr * finvert * fconstr * constr array * fconstr subs + | FCaseT of case_info * Univ.Instance.t * constr array * case_return * fconstr * case_branch array * fconstr subs (* predicate and branches are closures *) + | FCaseInvert of case_info * Univ.Instance.t * constr array * case_return * finvert * fconstr * case_branch array * fconstr subs | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs @@ -130,7 +130,7 @@ type 'a next_native_args = (CPrimitives.arg_kind * 'a) list type stack_member = | Zapp of fconstr array - | ZcaseT of case_info * constr * constr array * fconstr subs + | ZcaseT of case_info * Univ.Instance.t * constr array * case_return * case_branch array * fconstr subs | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zprimitive of CPrimitives.t * pconstant * fconstr list * fconstr next_native_args diff --git a/kernel/constr.ml b/kernel/constr.ml index bbaf95c9df..30542597c5 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -83,9 +83,15 @@ type pconstant = Constant.t puniverses type pinductive = inductive puniverses type pconstructor = constructor puniverses -type ('constr, 'univs) case_invert = +type 'constr pcase_invert = | NoInvert - | CaseInvert of { univs : 'univs; args : 'constr array } + | CaseInvert of { indices : 'constr array } + +type 'constr pcase_branch = Name.t Context.binder_annot array * 'constr +type 'types pcase_return = Name.t Context.binder_annot array * 'types + +type ('constr, 'types, 'univs) pcase = + case_info * 'univs * 'constr array * 'types pcase_return * 'constr pcase_invert * 'constr * 'constr pcase_branch array (* [Var] is used for named variables and [Rel] for variables as de Bruijn indices. *) @@ -103,7 +109,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Const of (Constant.t * 'univs) | Ind of (inductive * 'univs) | Construct of (constructor * 'univs) - | Case of case_info * 'constr * ('constr, 'univs) case_invert * 'constr * 'constr array + | Case of case_info * 'univs * 'constr array * 'types pcase_return * 'constr pcase_invert * 'constr * 'constr pcase_branch array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr @@ -119,6 +125,10 @@ type existential = existential_key * constr list type types = constr +type case_invert = constr pcase_invert +type case_return = types pcase_return +type case_branch = constr pcase_branch +type case = (constr, types, Instance.t) pcase type rec_declaration = (constr, types) prec_declaration type fixpoint = (constr, types) pfixpoint type cofixpoint = (constr, types) pcofixpoint @@ -194,7 +204,7 @@ let mkConstructU c = Construct c let mkConstructUi ((ind,u),i) = Construct ((ind,i),u) (* Constructs the term <p>Case c of c1 | c2 .. | cn end *) -let mkCase (ci, p, iv, c, ac) = Case (ci, p, iv, c, ac) +let mkCase (ci, u, params, p, iv, c, ac) = Case (ci, u, params, p, iv, c, ac) (* If recindxs = [|i1,...in|] funnames = [|f1,...fn|] @@ -425,7 +435,7 @@ let destConstruct c = match kind c with (* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) let destCase c = match kind c with - | Case (ci,p,iv,c,v) -> (ci,p,iv,c,v) + | Case (ci,u,params,p,iv,c,v) -> (ci,u,params,p,iv,c,v) | _ -> raise DestKO let destProj c = match kind c with @@ -471,8 +481,8 @@ let decompose_appvect c = let fold_invert f acc = function | NoInvert -> acc - | CaseInvert {univs=_;args} -> - Array.fold_left f acc args + | CaseInvert {indices} -> + Array.fold_left f acc indices let fold f acc c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -484,7 +494,8 @@ let fold f acc c = match kind c with | App (c,l) -> Array.fold_left f (f acc c) l | Proj (_p,c) -> f acc c | Evar (_,l) -> List.fold_left f acc l - | Case (_,p,iv,c,bl) -> Array.fold_left f (f (fold_invert f (f acc p) iv) c) bl + | Case (_,_,pms,(_,p),iv,c,bl) -> + Array.fold_left (fun acc (_, b) -> f acc b) (f (fold_invert f (f (Array.fold_left f acc pms) p) iv) c) bl | Fix (_,(_lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl | CoFix (_,(_lna,tl,bl)) -> @@ -498,8 +509,8 @@ let fold f acc c = match kind c with let iter_invert f = function | NoInvert -> () - | CaseInvert {univs=_; args;} -> - Array.iter f args + | CaseInvert {indices;} -> + Array.iter f indices let iter f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -511,7 +522,8 @@ let iter f c = match kind c with | App (c,l) -> f c; Array.iter f l | Proj (_p,c) -> f c | Evar (_,l) -> List.iter f l - | Case (_,p,iv,c,bl) -> f p; iter_invert f iv; f c; Array.iter f bl + | Case (_,_,pms,p,iv,c,bl) -> + Array.iter f pms; f (snd p); iter_invert f iv; f c; Array.iter (fun (_, b) -> f b) bl | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl | Array(_u,t,def,ty) -> Array.iter f t; f def; f ty @@ -531,7 +543,12 @@ let iter_with_binders g f n c = match kind c with | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c | App (c,l) -> f n c; Array.Fun1.iter f n l | Evar (_,l) -> List.iter (fun c -> f n c) l - | Case (_,p,iv,c,bl) -> f n p; iter_invert (f n) iv; f n c; Array.Fun1.iter f n bl + | Case (_,_,pms,p,iv,c,bl) -> + Array.Fun1.iter f n pms; + f (iterate g (Array.length (fst p)) n) (snd p); + iter_invert (f n) iv; + f n c; + Array.Fun1.iter (fun n (ctx, b) -> f (iterate g (Array.length ctx) n) b) n bl | Proj (_p,c) -> f n c | Fix (_,(_,tl,bl)) -> Array.Fun1.iter f n tl; @@ -560,7 +577,11 @@ let fold_constr_with_binders g f n acc c = | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_p,c) -> f n acc c | Evar (_,l) -> List.fold_left (f n) acc l - | Case (_,p,iv,c,bl) -> Array.fold_left (f n) (f n (fold_invert (f n) (f n acc p) iv) c) bl + | Case (_,_,pms,p,iv,c,bl) -> + let fold_ctx n accu (nas, c) = + f (iterate g (Array.length nas) n) accu c + in + Array.fold_left (fold_ctx n) (f n (fold_invert (f n) (fold_ctx n (Array.fold_left (f n) acc pms) p) iv) c) bl | Fix (_,(_,tl,bl)) -> let n' = iterate g (Array.length tl) n in let fd = Array.map2 (fun t b -> (t,b)) tl bl in @@ -576,62 +597,39 @@ let fold_constr_with_binders g f n acc c = not recursive and the order with which subterms are processed is not specified *) -let rec map_under_context f n d = - if n = 0 then f d else - match kind d with - | LetIn (na,b,t,c) -> - let b' = f b in - let t' = f t in - let c' = map_under_context f (n-1) c in - if b' == b && t' == t && c' == c then d - else mkLetIn (na,b',t',c') - | Lambda (na,t,b) -> - let t' = f t in - let b' = map_under_context f (n-1) b in - if t' == t && b' == b then d - else mkLambda (na,t',b') - | _ -> CErrors.anomaly (Pp.str "Ill-formed context") - -let map_branches f ci bl = - let nl = Array.map List.length ci.ci_pp_info.cstr_tags in - let bl' = Array.map2 (map_under_context f) nl bl in +let map_under_context f d = + let (nas, p) = d in + let p' = f p in + if p' == p then d else (nas, p') + +let map_branches f bl = + let bl' = Array.map (map_under_context f) bl in if Array.for_all2 (==) bl' bl then bl else bl' -let map_return_predicate f ci p = - map_under_context f (List.length ci.ci_pp_info.ind_tags) p - -let rec map_under_context_with_binders g f l n d = - if n = 0 then f l d else - match kind d with - | LetIn (na,b,t,c) -> - let b' = f l b in - let t' = f l t in - let c' = map_under_context_with_binders g f (g l) (n-1) c in - if b' == b && t' == t && c' == c then d - else mkLetIn (na,b',t',c') - | Lambda (na,t,b) -> - let t' = f l t in - let b' = map_under_context_with_binders g f (g l) (n-1) b in - if t' == t && b' == b then d - else mkLambda (na,t',b') - | _ -> CErrors.anomaly (Pp.str "Ill-formed context") - -let map_branches_with_binders g f l ci bl = - let tags = Array.map List.length ci.ci_pp_info.cstr_tags in - let bl' = Array.map2 (map_under_context_with_binders g f l) tags bl in +let map_return_predicate f p = + map_under_context f p + +let map_under_context_with_binders g f l d = + let (nas, p) = d in + let l = iterate g (Array.length nas) l in + let p' = f l p in + if p' == p then d else (nas, p') + +let map_branches_with_binders g f l bl = + let bl' = Array.map (map_under_context_with_binders g f l) bl in if Array.for_all2 (==) bl' bl then bl else bl' -let map_return_predicate_with_binders g f l ci p = - map_under_context_with_binders g f l (List.length ci.ci_pp_info.ind_tags) p +let map_return_predicate_with_binders g f l p = + map_under_context_with_binders g f l p let map_invert f = function | NoInvert -> NoInvert - | CaseInvert {univs;args;} as orig -> - let args' = Array.Smart.map f args in - if args == args' then orig - else CaseInvert {univs;args=args';} + | CaseInvert {indices;} as orig -> + let indices' = Array.Smart.map f indices in + if indices == indices' then orig + else CaseInvert {indices=indices';} -let map_gen userview f c = match kind c with +let map f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _) -> c | Cast (b,k,t) -> @@ -668,20 +666,14 @@ let map_gen userview f c = match kind c with let l' = List.Smart.map f l in if l'==l then c else mkEvar (e, l') - | Case (ci,p,iv,b,bl) when userview -> + | Case (ci,u,pms,p,iv,b,bl) -> + let pms' = Array.Smart.map f pms in let b' = f b in let iv' = map_invert f iv in - let p' = map_return_predicate f ci p in - let bl' = map_branches f ci bl in - if b'==b && iv'==iv && p'==p && bl'==bl then c - else mkCase (ci, p', iv', b', bl') - | Case (ci,p,iv,b,bl) -> - let b' = f b in - let iv' = map_invert f iv in - let p' = f p in - let bl' = Array.Smart.map f bl in - if b'==b && iv'==iv && p'==p && bl'==bl then c - else mkCase (ci, p', iv', b', bl') + let p' = map_return_predicate f p in + let bl' = map_branches f bl in + if b'==b && iv'==iv && p'==p && bl'==bl && pms'==pms then c + else mkCase (ci, u, pms', p', iv', b', bl') | Fix (ln,(lna,tl,bl)) -> let tl' = Array.Smart.map f tl in let bl' = Array.Smart.map f bl in @@ -699,17 +691,26 @@ let map_gen userview f c = match kind c with if def'==def && t==t' && ty==ty' then c else mkArray(u,t',def',ty') -let map_user_view = map_gen true -let map = map_gen false - (* Like {!map} but with an accumulator. *) let fold_map_invert f acc = function | NoInvert -> acc, NoInvert - | CaseInvert {univs;args;} as orig -> - let acc, args' = Array.fold_left_map f acc args in - if args==args' then acc, orig - else acc, CaseInvert {univs;args=args';} + | CaseInvert {indices;} as orig -> + let acc, indices' = Array.fold_left_map f acc indices in + if indices==indices' then acc, orig + else acc, CaseInvert {indices=indices';} + +let fold_map_under_context f accu d = + let (nas, p) = d in + let accu, p' = f accu p in + if p' == p then accu, d else accu, (nas, p') + +let fold_map_branches f accu bl = + let accu, bl' = Array.Smart.fold_left_map (fold_map_under_context f) accu bl in + if Array.for_all2 (==) bl' bl then accu, bl else accu, bl' + +let fold_map_return_predicate f accu p = + fold_map_under_context f accu p let fold_map f accu c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -749,13 +750,14 @@ let fold_map f accu c = match kind c with let accu, l' = List.fold_left_map f accu l in if l'==l then accu, c else accu, mkEvar (e, l') - | Case (ci,p,iv,b,bl) -> - let accu, b' = f accu b in + | Case (ci,u,pms,p,iv,b,bl) -> + let accu, pms' = Array.Smart.fold_left_map f accu pms in + let accu, p' = fold_map_return_predicate f accu p in let accu, iv' = fold_map_invert f accu iv in - let accu, p' = f accu p in - let accu, bl' = Array.Smart.fold_left_map f accu bl in - if b'==b && iv'==iv && p'==p && bl'==bl then accu, c - else accu, mkCase (ci, p', iv', b', bl') + let accu, b' = f accu b in + let accu, bl' = fold_map_branches f accu bl in + if pms'==pms && p'==p && iv'==iv && b'==b && bl'==bl then accu, c + else accu, mkCase (ci, u, pms', p', iv', b', bl') | Fix (ln,(lna,tl,bl)) -> let accu, tl' = Array.Smart.fold_left_map f accu tl in let accu, bl' = Array.Smart.fold_left_map f accu bl in @@ -816,13 +818,14 @@ let map_with_binders g f l c0 = match kind c0 with let al' = List.Smart.map (fun c -> f l c) al in if al' == al then c0 else mkEvar (e, al') - | Case (ci, p, iv, c, bl) -> - let p' = f l p in + | Case (ci, u, pms, p, iv, c, bl) -> + let pms' = Array.Fun1.Smart.map f l pms in + let p' = map_return_predicate_with_binders g f l p in let iv' = map_invert (f l) iv in let c' = f l c in - let bl' = Array.Fun1.Smart.map f l bl in - if p' == p && iv' == iv && c' == c && bl' == bl then c0 - else mkCase (ci, p', iv', c', bl') + let bl' = map_branches_with_binders g f l bl in + if pms' == pms && p' == p && iv' == iv && c' == c && bl' == bl then c0 + else mkCase (ci, u, pms', p', iv', c', bl') | Fix (ln, (lna, tl, bl)) -> let tl' = Array.Fun1.Smart.map f l tl in let l' = iterate g (Array.length tl) l in @@ -878,13 +881,15 @@ type 'constr constr_compare_fn = int -> 'constr -> 'constr -> bool optimisation that physically equal arrays are equals (hence the calls to {!Array.equal_norefl}). *) -let eq_invert eq leq_universes iv1 iv2 = +let eq_invert eq iv1 iv2 = match iv1, iv2 with | NoInvert, NoInvert -> true | NoInvert, CaseInvert _ | CaseInvert _, NoInvert -> false - | CaseInvert {univs;args}, CaseInvert iv2 -> - leq_universes univs iv2.univs - && Array.equal eq args iv2.args + | CaseInvert {indices}, CaseInvert iv2 -> + Array.equal eq indices iv2.indices + +let eq_under_context eq (_nas1, p1) (_nas2, p2) = + eq p1 p2 let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t1 t2 = match kind_nocast_gen kind1 t1, kind_nocast_gen kind2 t2 with @@ -911,8 +916,12 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t | Ind (c1,u1), Ind (c2,u2) -> Ind.CanOrd.equal c1 c2 && leq_universes (Some (GlobRef.IndRef c1, nargs)) u1 u2 | Construct (c1,u1), Construct (c2,u2) -> Construct.CanOrd.equal c1 c2 && leq_universes (Some (GlobRef.ConstructRef c1, nargs)) u1 u2 - | Case (_,p1,iv1,c1,bl1), Case (_,p2,iv2,c2,bl2) -> - eq 0 p1 p2 && eq_invert (eq 0) (leq_universes None) iv1 iv2 && eq 0 c1 c2 && Array.equal (eq 0) bl1 bl2 + | Case (ci1,u1,pms1,p1,iv1,c1,bl1), Case (ci2,u2,pms2,p2,iv2,c2,bl2) -> + (** FIXME: what are we doing with u1 = u2 ? *) + Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind && leq_universes (Some (GlobRef.IndRef ci1.ci_ind, 0)) u1 u2 && + Array.equal (eq 0) pms1 pms2 && eq_under_context (eq 0) p1 p2 && + eq_invert (eq 0) iv1 iv2 && + eq 0 c1 c2 && Array.equal (eq_under_context (eq 0)) bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 && Array.equal_norefl (eq 0) tl1 tl2 && Array.equal_norefl (eq 0) bl1 bl2 @@ -1050,8 +1059,7 @@ let compare_invert f iv1 iv2 = | NoInvert, CaseInvert _ -> -1 | CaseInvert _, NoInvert -> 1 | CaseInvert iv1, CaseInvert iv2 -> - (* univs ignored deliberately *) - Array.compare f iv1.args iv2.args + Array.compare f iv1.indices iv2.indices let constr_ord_int f t1 t2 = let (=?) f g i1 i2 j1 j2= @@ -1063,6 +1071,9 @@ let constr_ord_int f t1 t2 = let fix_cmp (a1, i1) (a2, i2) = ((Array.compare Int.compare) =? Int.compare) a1 a2 i1 i2 in + let ctx_cmp f (_n1, p1) (_n2, p2) = + f p1 p2 + in match kind t1, kind t2 with | Cast (c1,_,_), _ -> f c1 t2 | _, Cast (c2,_,_) -> f t1 c2 @@ -1096,12 +1107,13 @@ let constr_ord_int f t1 t2 = | Ind _, _ -> -1 | _, Ind _ -> 1 | Construct (ct1,_u1), Construct (ct2,_u2) -> Construct.CanOrd.compare ct1 ct2 | Construct _, _ -> -1 | _, Construct _ -> 1 - | Case (_,p1,iv1,c1,bl1), Case (_,p2,iv2,c2,bl2) -> - let c = f p1 p2 in + | Case (_,_u1,pms1,p1,iv1,c1,bl1), Case (_,_u2,pms2,p2,iv2,c2,bl2) -> + let c = Array.compare f pms1 pms2 in + if Int.equal c 0 then let c = ctx_cmp f p1 p2 in if Int.equal c 0 then let c = compare_invert f iv1 iv2 in if Int.equal c 0 then let c = f c1 c2 in - if Int.equal c 0 then Array.compare f bl1 bl2 - else c else c else c + if Int.equal c 0 then Array.compare (ctx_cmp f) bl1 bl2 + else c else c else c else c | Case _, _ -> -1 | _, Case _ -> 1 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> ((fix_cmp =? (Array.compare f)) ==? (Array.compare f)) @@ -1176,9 +1188,11 @@ let invert_eqeq iv1 iv2 = match iv1, iv2 with | NoInvert, NoInvert -> true | NoInvert, CaseInvert _ | CaseInvert _, NoInvert -> false - | CaseInvert iv1, CaseInvert iv2 -> - iv1.univs == iv2.univs - && iv1.args == iv2.args + | CaseInvert {indices=i1}, CaseInvert {indices=i2} -> + i1 == i2 + +let hasheq_ctx (nas1, c1) (nas2, c2) = + array_eqeq nas1 nas2 && c1 == c2 let hasheq t1 t2 = match t1, t2 with @@ -1197,8 +1211,11 @@ let hasheq t1 t2 = | Const (c1,u1), Const (c2,u2) -> c1 == c2 && u1 == u2 | Ind (ind1,u1), Ind (ind2,u2) -> ind1 == ind2 && u1 == u2 | Construct (cstr1,u1), Construct (cstr2,u2) -> cstr1 == cstr2 && u1 == u2 - | Case (ci1,p1,iv1,c1,bl1), Case (ci2,p2,iv2,c2,bl2) -> - ci1 == ci2 && p1 == p2 && invert_eqeq iv1 iv2 && c1 == c2 && array_eqeq bl1 bl2 + | Case (ci1,u1,pms1,p1,iv1,c1,bl1), Case (ci2,u2,pms2,p2,iv2,c2,bl2) -> + (** FIXME: use deeper equality for contexts *) + u1 == u2 && array_eqeq pms1 pms2 && + ci1 == ci2 && hasheq_ctx p1 p2 && + invert_eqeq iv1 iv2 && c1 == c2 && Array.equal hasheq_ctx bl1 bl2 | Fix ((ln1, i1),(lna1,tl1,bl1)), Fix ((ln2, i2),(lna2,tl2,bl2)) -> Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 @@ -1247,7 +1264,7 @@ let sh_instance = Univ.Instance.share representation for [constr] using [hash_consing_functions] on leaves. *) let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = - let rec hash_term t = + let rec hash_term (t : t) = match t with | Var i -> (Var (sh_id i), combinesmall 1 (Id.hash i)) @@ -1289,13 +1306,27 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let u', hu = sh_instance u in (Construct (sh_construct c, u'), combinesmall 11 (combine (Construct.SyntacticOrd.hash c) hu)) - | Case (ci,p,iv,c,bl) -> - let p, hp = sh_rec p - and iv, hiv = sh_invert iv - and c, hc = sh_rec c in - let bl,hbl = hash_term_array bl in - let hbl = combine4 hc hp hiv hbl in - (Case (sh_ci ci, p, iv, c, bl), combinesmall 12 hbl) + | Case (ci,u,pms,p,iv,c,bl) -> + (** FIXME: use a dedicated hashconsing structure *) + let hcons_ctx (lna, c) = + let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in + let fold accu na = combine (hash_annot Name.hash na) accu in + let hna = Array.fold_left fold 0 lna in + let c, hc = sh_rec c in + (lna, c), combine hna hc + in + let u, hu = sh_instance u in + let pms,hpms = hash_term_array pms in + let p, hp = hcons_ctx p in + let iv, hiv = sh_invert iv in + let c, hc = sh_rec c in + let fold accu c = + let c, h = hcons_ctx c in + combine accu h, c + in + let hbl, bl = Array.fold_left_map fold 0 bl in + let hbl = combine (combine hc (combine hiv (combine hpms (combine hu hp)))) hbl in + (Case (sh_ci ci, u, pms, p, iv, c, bl), combinesmall 12 hbl) | Fix (ln,(lna,tl,bl)) -> let bl,hbl = hash_term_array bl in let tl,htl = hash_term_array tl in @@ -1334,10 +1365,9 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = and sh_invert = function | NoInvert -> NoInvert, 0 - | CaseInvert {univs;args;} -> - let univs, hu = sh_instance univs in - let args, ha = hash_term_array args in - CaseInvert {univs;args;}, combinesmall 1 (combine hu ha) + | CaseInvert {indices;} -> + let indices, ha = hash_term_array indices in + CaseInvert {indices;}, combinesmall 1 ha and sh_rec t = let (y, h) = hash_term t in @@ -1400,8 +1430,8 @@ let rec hash t = combinesmall 10 (combine (Ind.CanOrd.hash ind) (Instance.hash u)) | Construct (c,u) -> combinesmall 11 (combine (Construct.CanOrd.hash c) (Instance.hash u)) - | Case (_ , p, iv, c, bl) -> - combinesmall 12 (combine4 (hash c) (hash p) (hash_invert iv) (hash_term_array bl)) + | Case (_ , u, pms, p, iv, c, bl) -> + combinesmall 12 (combine (combine (hash c) (combine (hash_invert iv) (combine (hash_term_array pms) (combine (Instance.hash u) (hash_under_context p))))) (hash_branches bl)) | Fix (_ln ,(_, tl, bl)) -> combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl)) | CoFix(_ln, (_, tl, bl)) -> @@ -1417,8 +1447,8 @@ let rec hash t = and hash_invert = function | NoInvert -> 0 - | CaseInvert {univs;args;} -> - combinesmall 1 (combine (Instance.hash univs) (hash_term_array args)) + | CaseInvert {indices;} -> + combinesmall 1 (hash_term_array indices) and hash_term_array t = Array.fold_left (fun acc t -> combine acc (hash t)) 0 t @@ -1426,6 +1456,11 @@ and hash_term_array t = and hash_term_list t = List.fold_left (fun acc t -> combine (hash t) acc) 0 t +and hash_under_context (_, t) = hash t + +and hash_branches bl = + Array.fold_left (fun acc t -> combine acc (hash_under_context t)) 0 bl + module CaseinfoHash = struct type t = case_info @@ -1551,10 +1586,15 @@ let rec debug_print c = | Construct (((sp,i),j),u) -> str"Constr(" ++ pr_puniverses (MutInd.print sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")" | Proj (p,c) -> str"Proj(" ++ Constant.debug_print (Projection.constant p) ++ str"," ++ bool (Projection.unfolded p) ++ debug_print c ++ str")" - | Case (_ci,p,iv,c,bl) -> v 0 - (hv 0 (str"<"++debug_print p++str">"++ cut() ++ str"Case " ++ - debug_print c ++ debug_invert iv ++ str"of") ++ cut() ++ - prlist_with_sep (fun _ -> brk(1,2)) debug_print (Array.to_list bl) ++ + | Case (_ci,_u,pms,p,iv,c,bl) -> + let pr_ctx (nas, c) = + prvect_with_sep spc (fun na -> Name.print na.binder_name) nas ++ spc () ++ str "|-" ++ spc () ++ + debug_print c + in + v 0 (hv 0 (str"Case " ++ + debug_print c ++ cut () ++ str "as" ++ cut () ++ prlist_with_sep cut debug_print (Array.to_list pms) ++ + cut () ++ str"return"++ cut () ++ pr_ctx p ++ debug_invert iv ++ cut () ++ str"with") ++ cut() ++ + prlist_with_sep (fun _ -> brk(1,2)) pr_ctx (Array.to_list bl) ++ cut() ++ str"end") | Fix f -> debug_print_fix debug_print f | CoFix(i,(lna,tl,bl)) -> @@ -1573,6 +1613,6 @@ let rec debug_print c = and debug_invert = let open Pp in function | NoInvert -> mt() - | CaseInvert {univs;args;} -> - spc() ++ str"Invert {univs=" ++ Instance.pr Level.pr univs ++ - str "; args=" ++ prlist_with_sep spc debug_print (Array.to_list args) ++ str "} " + | CaseInvert {indices;} -> + spc() ++ str"Invert {indices=" ++ + prlist_with_sep spc debug_print (Array.to_list indices) ++ str "} " diff --git a/kernel/constr.mli b/kernel/constr.mli index ed63ac507c..57dd850ee7 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -49,11 +49,11 @@ type case_info = ci_pp_info : case_printing (* not interpreted by the kernel *) } -type ('constr, 'univs) case_invert = +type 'constr pcase_invert = | NoInvert (** Normal reduction: match when the scrutinee is a constructor. *) - | CaseInvert of { univs : 'univs; args : 'constr array; } + | CaseInvert of { indices : 'constr array; } (** Reduce when the indices match those of the unique constructor. (SProp to non SProp only) *) @@ -152,14 +152,30 @@ val mkRef : GlobRef.t Univ.puniverses -> constr (** Constructs a destructor of inductive type. - [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] + [mkCase ci params p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] presented as describe in [ci]. - [p] structure is [fun args x -> "return clause"] + + [p] structure is [args x |- "return clause"] [ac]{^ ith} element is ith constructor case presented as - {e lambda construct_args (without params). case_term } *) -val mkCase : case_info * constr * (constr,Univ.Instance.t) case_invert * constr * constr array -> constr + {e construct_args |- case_term } *) + +type 'constr pcase_branch = Name.t Context.binder_annot array * 'constr +(** Names of the indices + name of self *) + +type 'types pcase_return = Name.t Context.binder_annot array * 'types +(** Names of the branches *) + +type ('constr, 'types, 'univs) pcase = + case_info * 'univs * 'constr array * 'types pcase_return * 'constr pcase_invert * 'constr * 'constr pcase_branch array + +type case_invert = constr pcase_invert +type case_return = types pcase_return +type case_branch = constr pcase_branch +type case = (constr, types, Univ.Instance.t) pcase + +val mkCase : case -> constr (** If [recindxs = [|i1,...in|]] [funnames = [|f1,.....fn|]] @@ -243,7 +259,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Ind of (inductive * 'univs) (** A name of an inductive type defined by [Variant], [Inductive] or [Record] Vernacular-commands. *) | Construct of (constructor * 'univs) (** A constructor of an inductive type defined by [Variant], [Inductive] or [Record] Vernacular-commands. *) - | Case of case_info * 'constr * ('constr,'univs) case_invert * 'constr * 'constr array + | Case of case_info * 'univs * 'constr array * 'types pcase_return * 'constr pcase_invert * 'constr * 'constr pcase_branch array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr @@ -351,7 +367,7 @@ Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args return P in t1], or [if c then t1 else t2]) @return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] where [info] is pretty-printing information *) -val destCase : constr -> case_info * constr * (constr,Univ.Instance.t) case_invert * constr * constr array +val destCase : constr -> case (** Destructs a projection *) val destProj : constr -> Projection.t * constr @@ -421,12 +437,6 @@ val lift : int -> constr -> constr (** {6 Functionals working on expressions canonically abstracted over a local context (possibly with let-ins)} *) -(** [map_under_context f l c] maps [f] on the immediate subterms of a - term abstracted over a context of length [n] (local definitions - are counted) *) - -val map_under_context : (constr -> constr) -> int -> constr -> constr - (** [map_branches f br] maps [f] on the immediate subterms of an array of "match" branches [br] in canonical eta-let-expanded form; it is not recursive and the order with which subterms are processed is @@ -434,7 +444,7 @@ val map_under_context : (constr -> constr) -> int -> constr -> constr types and possibly terms occurring in the context of each branch as well as the body of each branch *) -val map_branches : (constr -> constr) -> case_info -> constr array -> constr array +val map_branches : (constr -> constr) -> case_branch array -> case_branch array (** [map_return_predicate f p] maps [f] on the immediate subterms of a return predicate of a "match" in canonical eta-let-expanded form; @@ -443,16 +453,7 @@ val map_branches : (constr -> constr) -> case_info -> constr array -> constr arr the types and possibly terms occurring in the context of each branch as well as the body of the predicate *) -val map_return_predicate : (constr -> constr) -> case_info -> constr -> constr - -(** [map_under_context_with_binders g f n l c] maps [f] on the - immediate subterms of a term abstracted over a context of length - [n] (local definitions are counted); it preserves sharing; it - carries an extra data [n] (typically a lift index) which is - processed by [g] (which typically add 1 to [n]) at each binder - traversal *) - -val map_under_context_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> int -> constr -> constr +val map_return_predicate : (constr -> constr) -> case_return -> case_return (** [map_branches_with_binders f br] maps [f] on the immediate subterms of an array of "match" branches [br] in canonical @@ -464,7 +465,7 @@ val map_under_context_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> ' occurring in the context of the branch as well as the body of the branch *) -val map_branches_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_info -> constr array -> constr array +val map_branches_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_branch array -> case_branch array (** [map_return_predicate_with_binders f p] maps [f] on the immediate subterms of a return predicate of a "match" in canonical @@ -476,7 +477,7 @@ val map_branches_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> occurring in the context of each branch as well as the body of the predicate *) -val map_return_predicate_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_info -> constr -> constr +val map_return_predicate_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_return -> case_return (** {6 Functionals working on the immediate subterm of a construction } *) @@ -486,7 +487,7 @@ val map_return_predicate_with_binders : ('a -> 'a) -> ('a -> constr -> constr) - val fold : ('a -> constr -> 'a) -> 'a -> constr -> 'a -val fold_invert : ('a -> 'b -> 'a) -> 'a -> ('b, 'c) case_invert -> 'a +val fold_invert : ('a -> 'b -> 'a) -> 'a -> 'b pcase_invert -> 'a (** [map f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is @@ -494,21 +495,14 @@ val fold_invert : ('a -> 'b -> 'a) -> 'a -> ('b, 'c) case_invert -> 'a val map : (constr -> constr) -> constr -> constr -val map_invert : ('a -> 'a) -> ('a, 'b) case_invert -> ('a, 'b) case_invert - -(** [map_user_view f c] maps [f] on the immediate subterms of [c]; it - differs from [map f c] in that the typing context and body of the - return predicate and of the branches of a [match] are considered as - immediate subterm of a [match] *) - -val map_user_view : (constr -> constr) -> constr -> constr +val map_invert : ('a -> 'a) -> 'a pcase_invert -> 'a pcase_invert (** Like {!map}, but also has an additional accumulator. *) val fold_map : ('a -> constr -> 'a * constr) -> 'a -> constr -> 'a * constr val fold_map_invert : ('a -> 'b -> 'a * 'b) -> - 'a -> ('b, 'c) case_invert -> 'a * ('b, 'c) case_invert + 'a -> 'b pcase_invert -> 'a * 'b pcase_invert (** [map_with_binders g f n c] maps [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift @@ -525,7 +519,7 @@ val map_with_binders : val iter : (constr -> unit) -> constr -> unit -val iter_invert : ('a -> unit) -> ('a, 'b) case_invert -> unit +val iter_invert : ('a -> unit) -> 'a pcase_invert -> unit (** [iter_with_binders g f n c] iters [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift @@ -603,8 +597,8 @@ val compare_head_gen_leq : Univ.Instance.t instance_compare_fn -> constr constr_compare_fn -> constr constr_compare_fn -val eq_invert : ('a -> 'a -> bool) -> ('b -> 'b -> bool) - -> ('a, 'b) case_invert -> ('a, 'b) case_invert -> bool +val eq_invert : ('a -> 'a -> bool) + -> 'a pcase_invert -> 'a pcase_invert -> bool (** {6 Hashconsing} *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 3707a75157..f82b754c59 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -75,30 +75,23 @@ let share_univs cache r u l = let (u', args) = share cache r l in mkApp (instantiate_my_gr r (Instance.append u' u), args) -let update_case cache ci iv modlist = - match share cache (IndRef ci.ci_ind) modlist with - | exception Not_found -> ci, iv - | u, l -> - let iv = match iv with - | NoInvert -> NoInvert - | CaseInvert {univs; args;} -> - let univs = Instance.append u univs in - let args = Array.append l args in - CaseInvert {univs; args;} - in - { ci with ci_npar = ci.ci_npar + Array.length l }, iv - let is_empty_modlist (cm, mm) = Cmap.is_empty cm && Mindmap.is_empty mm let expmod_constr cache modlist c = let share_univs = share_univs cache in - let update_case = update_case cache in let rec substrec c = match kind c with - | Case (ci,p,iv,t,br) -> - let ci,iv = update_case ci iv modlist in - Constr.map substrec (mkCase (ci,p,iv,t,br)) + | Case (ci, u, pms, p, iv, t, br) -> + begin match share cache (IndRef ci.ci_ind) modlist with + | (u', prefix) -> + let u = Instance.append u' u in + let pms = Array.append prefix pms in + let ci = { ci with ci_npar = ci.ci_npar + Array.length prefix } in + Constr.map substrec (mkCase (ci,u,pms,p,iv,t,br)) + | exception Not_found -> + Constr.map substrec c + end | Ind (ind,u) -> (try diff --git a/kernel/esubst.ml b/kernel/esubst.ml index afd8e3ef67..1c8575ef05 100644 --- a/kernel/esubst.ml +++ b/kernel/esubst.ml @@ -245,3 +245,38 @@ let rec lift_subst mk e s = match s with let t, e = tree_map mk e t in let rem = lift_subst mk e rem in Cons (h, t, rem) + +module Internal = +struct + +type 'a or_rel = REL of int | VAL of int * 'a + +let to_rel shift = function +| Var i -> REL (i + shift) +| Arg v -> VAL (shift, v) + +let rec get_tree_subst shift accu = function +| Leaf (w, x) -> + to_rel (shift + w) x :: accu +| Node (w, x, l, r, _) -> + let accu = get_tree_subst (shift + w + eval l) accu r in + let accu = get_tree_subst (shift + w) accu l in + to_rel (shift + w) x :: accu + +let rec get_subst shift accu = function +| Nil (w, n) -> + List.init n (fun i -> REL (w + i + shift + 1)) +| Cons (_, t, s) -> + let accu = get_subst (shift + eval t) accu s in + get_tree_subst shift accu t + +let rec get_shift accu = function +| Nil (w, n) -> accu + w + n +| Cons (_, t, s) -> get_shift (eval t + accu) s + +let repr (s : 'a subs) = + let shift = get_shift 0 s in + let subs = get_subst 0 [] s in + subs, shift + +end diff --git a/kernel/esubst.mli b/kernel/esubst.mli index 8ff29ab07a..b0fbe680c3 100644 --- a/kernel/esubst.mli +++ b/kernel/esubst.mli @@ -94,3 +94,15 @@ val is_lift_id : lift -> bool That is, if Γ ⊢ e : Δ and Δ ⊢ σ : Ξ, then Γ ⊢ lift_subst mk e σ : Ξ. *) val lift_subst : (lift -> 'a -> 'b) -> lift -> 'a subs -> 'b subs + +(** Debugging utilities *) +module Internal : +sig +type 'a or_rel = REL of int | VAL of int * 'a + +(** High-level representation of a substitution. The first component is a list + that associates a value to an index, and the second component is the + relocation shift that must be applied to any variable pointing outside of + the substitution. *) +val repr : 'a subs -> 'a or_rel list * int +end diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml index dc2cd349ce..0e1cd0c56a 100644 --- a/kernel/genOpcodeFiles.ml +++ b/kernel/genOpcodeFiles.ml @@ -28,7 +28,6 @@ let opcodes = "ACC7"; "ACC"; "PUSH"; - "PUSHACC0"; "PUSHACC1"; "PUSHACC2"; "PUSHACC3"; @@ -83,8 +82,6 @@ let opcodes = "GETFIELD0"; "GETFIELD1"; "GETFIELD"; - "SETFIELD0"; - "SETFIELD1"; "SETFIELD"; "PROJ"; "ENSURESTACKCAPACITY"; @@ -101,7 +98,6 @@ let opcodes = "ACCUMULATE"; "MAKESWITCHBLOCK"; "MAKEACCU"; - "MAKEPROD"; "BRANCH"; "CHECKADDINT63"; "CHECKADDCINT63"; @@ -121,8 +117,6 @@ let opcodes = "CHECKLSLINT63"; "CHECKLSRINT63"; "CHECKADDMULDIVINT63"; - "CHECKLSLINT63CONST1"; - "CHECKLSRINT63CONST1"; "CHECKEQINT63"; "CHECKLTINT63"; "CHECKLEINT63"; diff --git a/kernel/inductive.ml b/kernel/inductive.ml index ce12d65614..eb18d4b90e 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -72,7 +72,7 @@ let constructor_instantiate mind u mib c = let s = ind_subst mind mib u in substl s (subst_instance_constr u c) -let instantiate_params full t u args sign = +let instantiate_params t u args sign = let fail () = anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch.") in let (rem_args, subs, ty) = @@ -81,8 +81,7 @@ let instantiate_params full t u args sign = match (decl, largs, kind ty) with | (LocalAssum _, a::args, Prod(_,_,t)) -> (args, a::subs, t) | (LocalDef (_,b,_), _, LetIn(_,_,_,t)) -> - (largs, (substl subs (subst_instance_constr u b))::subs, t) - | (_,[],_) -> if full then fail() else ([], subs, ty) + (largs, (substl subs (subst_instance_constr u b))::subs, t) | _ -> fail ()) sign ~init:(args,[],t) @@ -93,11 +92,11 @@ let instantiate_params full t u args sign = let full_inductive_instantiate mib u params sign = let dummy = Sorts.prop in let t = Term.mkArity (Vars.subst_instance_context u sign,dummy) in - fst (Term.destArity (instantiate_params true t u params mib.mind_params_ctxt)) + fst (Term.destArity (instantiate_params t u params mib.mind_params_ctxt)) let full_constructor_instantiate ((mind,_),u,(mib,_),params) t = let inst_ind = constructor_instantiate mind u mib t in - instantiate_params true inst_ind u params mib.mind_params_ctxt + instantiate_params inst_ind u params mib.mind_params_ctxt (************************************************************************) (************************************************************************) @@ -372,6 +371,91 @@ let check_correct_arity env c pj ind specif params = with LocalArity kinds -> error_elim_arity env ind c pj kinds +(** {6 Changes of representation of Case nodes} *) + +(** Provided: + - a universe instance [u] + - a term substitution [subst] + - name replacements [nas] + [instantiate_context u subst nas ctx] applies both [u] and [subst] to [ctx] + while replacing names using [nas] (order reversed) +*) +let instantiate_context u subst nas ctx = + let rec instantiate i ctx = match ctx with + | [] -> assert (Int.equal i (-1)); [] + | LocalAssum (_, ty) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + LocalAssum (nas.(i), ty) :: ctx + | LocalDef (_, ty, bdy) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + let bdy = substnl subst i (subst_instance_constr u bdy) in + LocalDef (nas.(i), ty, bdy) :: ctx + in + instantiate (Array.length nas - 1) ctx + +let expand_case_specif mib (ci, u, params, p, iv, c, br) = + (* Γ ⊢ c : I@{u} params args *) + (* Γ, indices, self : I@{u} params indices ⊢ p : Type *) + let mip = mib.mind_packets.(snd ci.ci_ind) in + let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsubst = Vars.subst_of_rel_context_instance paramdecl (Array.to_list params) in + (* Expand the return clause *) + let ep = + let (nas, p) = p in + let realdecls, _ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in + let self = + let args = Context.Rel.to_extended_vect mkRel 0 mip.mind_arity_ctxt in + let inst = Instance.of_array (Array.init (Instance.length u) Level.var) in + mkApp (mkIndU (ci.ci_ind, inst), args) + in + let realdecls = LocalAssum (Context.anonR, self) :: realdecls in + let realdecls = instantiate_context u paramsubst nas realdecls in + Term.it_mkLambda_or_LetIn p realdecls + in + (* Expand the branches *) + let subst = paramsubst @ ind_subst (fst ci.ci_ind) mib u in + let ebr = + let build_one_branch i (nas, br) (ctx, _) = + let ctx, _ = List.chop mip.mind_consnrealdecls.(i) ctx in + let ctx = instantiate_context u subst nas ctx in + Term.it_mkLambda_or_LetIn br ctx + in + Array.map2_i build_one_branch br mip.mind_nf_lc + in + (ci, ep, iv, c, ebr) + +let expand_case env (ci, _, _, _, _, _, _ as case) = + let specif = Environ.lookup_mind (fst ci.ci_ind) env in + expand_case_specif specif case + +let contract_case env (ci, p, iv, c, br) = + let (mib, mip) = lookup_mind_specif env ci.ci_ind in + let (arity, p) = Term.decompose_lam_n_decls (mip.mind_nrealdecls + 1) p in + let (u, pms) = match arity with + | LocalAssum (_, ty) :: _ -> + (** Last binder is the self binder for the term being eliminated *) + let (ind, args) = decompose_appvect ty in + let (ind, u) = destInd ind in + let () = assert (Ind.CanOrd.equal ind ci.ci_ind) in + let pms = Array.sub args 0 mib.mind_nparams in + (** Unlift the parameters from under the index binders *) + let dummy = List.make mip.mind_nrealdecls mkProp in + let pms = Array.map (fun c -> Vars.substl dummy c) pms in + (u, pms) + | _ -> assert false + in + let p = + let nas = Array.of_list (List.rev_map get_annot arity) in + (nas, p) + in + let map i br = + let (ctx, br) = Term.decompose_lam_n_decls mip.mind_consnrealdecls.(i) br in + let nas = Array.of_list (List.rev_map get_annot ctx) in + (nas, br) + in + (ci, u, pms, p, iv, c, Array.mapi map br) (************************************************************************) (* Type of case branches *) @@ -793,7 +877,8 @@ let rec subterm_specif renv stack t = let f,l = decompose_app (whd_all renv.env t) in match kind f with | Rel k -> subterm_var k renv - | Case (ci,p,_iv,c,lbr) -> (* iv ignored: it's just a cache *) + | Case (ci, u, pms, p, iv, c, lbr) -> (* iv ignored: it's just a cache *) + let (ci, p, _iv, c, lbr) = expand_case renv.env (ci, u, pms, p, iv, c, lbr) in let stack' = push_stack_closures renv l stack in let cases_spec = branches_specif renv (lazy_subterm_specif renv [] c) ci @@ -1018,7 +1103,8 @@ let check_one_fix renv recpos trees def = check_rec_call renv stack (Term.applist(lift p c,l)) end - | Case (ci,p,iv,c_0,lrest) -> (* iv ignored: it's just a cache *) + | Case (ci, u, pms, ret, iv, c_0, br) -> (* iv ignored: it's just a cache *) + let (ci, p, _iv, c_0, lrest) = expand_case renv.env (ci, u, pms, ret, iv, c_0, br) in begin try List.iter (check_rec_call renv []) (c_0::p::l); (* compute the recarg info for the arguments of each branch *) @@ -1040,7 +1126,7 @@ let check_one_fix renv recpos trees def = (* the call to whd_betaiotazeta will reduce the apparent iota redex away *) check_rec_call renv [] - (Term.applist (mkCase (ci,p,iv,c_0,lrest), l)) + (Term.applist (mkCase (ci, u, pms, ret, iv, c_0, br), l)) | _ -> Exninfo.iraise exn end @@ -1324,13 +1410,14 @@ let check_one_cofix env nbfix def deftype = else raise (CoFixGuardError (env,UnguardedRecursiveCall c)) - | Case (_,p,_,tm,vrest) -> (* iv ignored: just a cache *) - begin - let tree = match restrict_spec env (Subterm (Strict, tree)) p with - | Dead_code -> assert false - | Subterm (_, tree') -> tree' - | _ -> raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c)) - in + | Case (ci, u, pms, p, iv, tm, br) -> (* iv ignored: just a cache *) + begin + let (_, p, _iv, tm, vrest) = expand_case env (ci, u, pms, p, iv, tm, br) in + let tree = match restrict_spec env (Subterm (Strict, tree)) p with + | Dead_code -> assert false + | Subterm (_, tree') -> tree' + | _ -> raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c)) + in if (noccur_with_meta n nbfix p) then if (noccur_with_meta n nbfix tm) then if (List.for_all (noccur_with_meta n nbfix) args) then diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 78658dc4de..5808a3fa65 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -79,6 +79,23 @@ val arities_of_specif : MutInd.t puniverses -> mind_specif -> types array val inductive_params : mind_specif -> int +(** Given a pattern-matching represented compactly, expands it so as to produce + lambda and let abstractions in front of the return clause and the pattern + branches. *) +val expand_case : env -> case -> (case_info * constr * case_invert * constr * constr array) + +val expand_case_specif : mutual_inductive_body -> case -> (case_info * constr * case_invert * constr * constr array) + +(** Dual operation of the above. Fails if the return clause or branch has not + the expected form. *) +val contract_case : env -> (case_info * constr * case_invert * constr * constr array) -> case + +(** [instantiate_context u subst nas ctx] applies both [u] and [subst] + to [ctx] while replacing names using [nas] (order reversed). In particular, + assumes that [ctx] and [nas] have the same length. *) +val instantiate_context : Instance.t -> Vars.substl -> Name.t Context.binder_annot array -> + rel_context -> rel_context + (** [type_case_branches env (I,args) (p:A) c] computes useful types about the following Cases expression: <p>Cases (c :: (I args)) of b1..bn end diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml index d02f92ef26..50c3ba1cc6 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -198,7 +198,9 @@ let rec infer_fterm cv_pb infos variances hd stk = let variances = infer_vect infos variances elems in infer_stack infos variances stk - | FCaseInvert (_,p,_,_,br,e) -> + | FCaseInvert (ci, u, pms, p, _, _, br, e) -> + let mib = Environ.lookup_mind (fst ci.ci_ind) (info_env (fst infos)) in + let (_, p, _, _, br) = Inductive.expand_case_specif mib (ci, u, pms, p, NoInvert, mkProp, br) in let infer c variances = infer_fterm CONV infos variances (mk_clos e c) [] in let variances = infer p variances in Array.fold_right infer br variances @@ -217,7 +219,10 @@ and infer_stack infos variances (stk:CClosure.stack) = | Zfix (fx,a) -> let variances = infer_fterm CONV infos variances fx [] in infer_stack infos variances a - | ZcaseT (_, p, br, e) -> + | ZcaseT (ci,u,pms,p,br,e) -> + let dummy = mkProp in + let case = (ci, u, pms, p, NoInvert, dummy, br) in + let (_, p, _, _, br) = Inductive.expand_case (info_env (fst infos)) case in let variances = infer_fterm CONV infos variances (mk_clos e p) [] in infer_vect infos variances (Array.map (mk_clos e) br) | Zshift _ -> variances diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 5b2a7bd9c2..75fd70d923 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -31,6 +31,8 @@ Primred CClosure Relevanceops Reduction +Type_errors +Inductive Vmlambda Nativelambda Vmbytegen @@ -40,9 +42,7 @@ Vmsymtable Vm Vconv Nativeconv -Type_errors Modops -Inductive Typeops InferCumulativity IndTyping diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 4778bf1121..c5ac57a2cd 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -355,21 +355,26 @@ let rec map_kn f f' c = | Construct (((kn,i),j),u) -> let kn' = f kn in if kn'==kn then c else mkConstructU (((kn',i),j),u) - | Case (ci,p,iv,ct,l) -> + | Case (ci,u,pms,p,iv,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in let kn' = f kn in if kn'==kn then ci.ci_ind else kn',i in - let p' = func p in + let f_ctx (nas, c as d) = + let c' = func c in + if c' == c then d else (nas, c') + in + let pms' = Array.Smart.map func pms in + let p' = f_ctx p in let iv' = map_invert func iv in let ct' = func ct in - let l' = Array.Smart.map func l in - if (ci.ci_ind==ci_ind && p'==p && iv'==iv + let l' = Array.Smart.map f_ctx l in + if (ci.ci_ind==ci_ind && pms'==pms && p'==p && iv'==iv && l'==l && ct'==ct)then c else - mkCase ({ci with ci_ind = ci_ind}, - p',iv',ct', l') + mkCase ({ci with ci_ind = ci_ind}, u, + pms',p',iv',ct', l') | Cast (ct,k,t) -> let ct' = func ct in let t'= func t in diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 09db29d222..c19b883e3d 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -2101,7 +2101,7 @@ let compile_deps env sigma prefix init t = | Proj (p,c) -> let init = compile_mind_deps env prefix init (Projection.mind p) in aux env lvl init c - | Case (ci, _p, _iv, _c, _ac) -> + | Case (ci, _u, _pms, _p, _iv, _c, _ac) -> let mind = fst ci.ci_ind in let init = compile_mind_deps env prefix init mind in fold_constr_with_binders succ (aux env) lvl init t diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index b27c53ef0f..f3b483467d 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -535,7 +535,8 @@ let rec lambda_of_constr cache env sigma c = let prefix = get_mind_prefix env (fst ind) in mkLapp (Lproj (prefix, ind, Projection.arg p)) [|lambda_of_constr cache env sigma c|] - | Case(ci,t,_iv,a,branches) -> (* XXX handle iv *) + | Case (ci, u, pms, t, iv, a, br) -> (* XXX handle iv *) + let (ci, t, _iv, a, branches) = Inductive.expand_case env (ci, u, pms, t, iv, a, br) in let (mind,i as ind) = ci.ci_ind in let mib = lookup_mind mind env in let oib = mib.mind_packets.(i) in diff --git a/kernel/reduction.ml b/kernel/reduction.ml index cf40263f61..1e39756d47 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -56,7 +56,7 @@ let compare_stack_shape stk1 stk2 = | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 | (Zproj _p1::s1, Zproj _p2::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 - | (ZcaseT(_c1,_,_,_)::s1, ZcaseT(_c2,_,_,_)::s2) -> + | (ZcaseT(_c1,_,_,_,_,_)::s1, ZcaseT(_c2,_,_,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 @@ -74,7 +74,7 @@ type lft_constr_stack_elt = Zlapp of (lift * fconstr) array | Zlproj of Projection.Repr.t * lift | Zlfix of (lift * fconstr) * lft_constr_stack - | Zlcase of case_info * lift * constr * constr array * fconstr subs + | Zlcase of case_info * lift * Univ.Instance.t * constr array * case_return * case_branch array * fconstr subs | Zlprimitive of CPrimitives.t * pconstant * lft_fconstr list * lft_fconstr next_native_args and lft_constr_stack = lft_constr_stack_elt list @@ -109,8 +109,8 @@ let pure_stack lfts stk = | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) - | (ZcaseT(ci,p,br,e),(l,pstk)) -> - (l,Zlcase(ci,l,p,br,e)::pstk) + | (ZcaseT(ci,u,pms,p,br,e),(l,pstk)) -> + (l,Zlcase(ci,l,u,pms,p,br,e)::pstk) | (Zprimitive(op,c,rargs,kargs),(l,pstk)) -> (l,Zlprimitive(op,c,List.map (fun t -> (l,t)) rargs, List.map (fun (k,t) -> (k,(l,t))) kargs)::pstk)) @@ -233,6 +233,9 @@ let convert_instances ~flex u u' (s, check) = exception MustExpand +let convert_instances_cumul pb var u u' (s, check) = + (check.compare_cumul_instances pb var u u' s, check) + let get_cumulativity_constraints cv_pb variance u u' = match cv_pb with | CONV -> @@ -294,8 +297,6 @@ let conv_table_key infos ~nargs k1 k2 cuniv = | RelKey n, RelKey n' when Int.equal n n' -> cuniv | _ -> raise NotConvertible -exception IrregularPatternShape - let unfold_ref_with_args infos tab fl v = match unfold_reference infos tab fl with | Def def -> Some (def, v) @@ -327,17 +328,6 @@ let push_relevance infos r = let push_relevances infos nas = { infos with cnv_inf = CClosure.push_relevances infos.cnv_inf nas } -let rec skip_pattern infos relevances n c1 c2 = - if Int.equal n 0 then {infos with cnv_inf = CClosure.set_info_relevances infos.cnv_inf relevances}, c1, c2 - else match kind c1, kind c2 with - | Lambda (x, _, c1), Lambda (_, _, c2) -> - skip_pattern infos (Range.cons x.Context.binder_relevance relevances) (pred n) c1 c2 - | _ -> raise IrregularPatternShape - -let skip_pattern infos n c1 c2 = - if Int.equal n 0 then infos, c1, c2 - else skip_pattern infos (info_relevances infos.cnv_inf) n c1 c2 - let is_irrelevant infos lft c = let env = info_env infos.cnv_inf in try Relevanceops.relevance_of_fterm env (info_relevances infos.cnv_inf) lft c == Sorts.Irrelevant with _ -> false @@ -364,6 +354,39 @@ let eta_expand_constructor env ((ind,ctor),u as pctor) = let c = Term.it_mkLambda_or_LetIn c ctx in inject c +let inductive_subst (mind, _) mib u pms = + let open Context.Rel.Declaration in + let ntypes = mib.mind_ntypes in + let rec self i accu = + if Int.equal i ntypes then accu + else self (i + 1) (subs_cons (inject (mkIndU ((mind, i), u))) accu) + in + let accu = self 0 (subs_id 0) in + let rec mk_pms pms ctx = match ctx, pms with + | [], [] -> accu + | LocalAssum _ :: ctx, c :: pms -> + let subs = mk_pms pms ctx in + subs_cons c subs + | LocalDef (_, c, _) :: ctx, pms -> + let c = Vars.subst_instance_constr u c in + let subs = mk_pms pms ctx in + subs_cons (mk_clos subs c) subs + | LocalAssum _ :: _, [] | [], _ :: _ -> assert false + in + mk_pms (List.rev pms) mib.mind_params_ctxt + +let esubst_of_rel_context_instance ctx u args e = + let open Context.Rel.Declaration in + let rec aux lft e args ctx = match ctx with + | [] -> lft, e + | LocalAssum _ :: ctx -> aux (lft + 1) (subs_lift e) (subs_lift args) ctx + | LocalDef (_, c, _) :: ctx -> + let c = Vars.subst_instance_constr u c in + let c = mk_clos args c in + aux lft (subs_cons c e) (subs_cons c args) ctx + in + aux 0 e args (List.rev ctx) + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = try eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv @@ -672,13 +695,23 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = if Float64.equal f1 f2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible - | FCaseInvert (ci1,p1,_,_,br1,e1), FCaseInvert (ci2,p2,_,_,br2,e2) -> + | FCaseInvert (ci1,u1,pms1,p1,_,_,br1,e1), FCaseInvert (ci2,u2,pms2,p2,_,_,br2,e2) -> (if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then raise NotConvertible); let el1 = el_stack lft1 v1 and el2 = el_stack lft2 v2 in - let ccnv = ccnv CONV l2r infos el1 el2 in - let cuniv = ccnv (mk_clos e1 p1) (mk_clos e2 p2) cuniv in - Array.fold_right2 (fun b1 b2 cuniv -> ccnv (mk_clos e1 b1) (mk_clos e2 b2) cuniv) - br1 br2 cuniv + let fold c1 c2 cuniv = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in + (** FIXME: cache the presence of let-bindings in the case_info *) + let mind = Environ.lookup_mind (fst ci1.ci_ind) (info_env infos.cnv_inf) in + let mip = mind.Declarations.mind_packets.(snd ci1.ci_ind) in + let cuniv = + let ind = (mind,snd ci1.ci_ind) in + let nargs = inductive_cumulativity_arguments ind in + convert_inductives CONV ind nargs u1 u2 cuniv + in + let pms1 = Array.map_to_list (fun c -> mk_clos e1 c) pms1 in + let pms2 = Array.map_to_list (fun c -> mk_clos e2 c) pms2 in + let cuniv = List.fold_right2 fold pms1 pms2 cuniv in + let cuniv = convert_return_clause ci1.ci_ind mind mip l2r infos e1 e2 el1 el2 u1 u2 pms1 pms2 p1 p2 cuniv in + convert_branches ci1.ci_ind mind mip l2r infos e1 e2 el1 el2 u1 u2 pms1 pms2 br1 br2 cuniv | FArray (u1,t1,ty1), FArray (u2,t2,ty2) -> let len = Parray.length_int t1 in @@ -714,11 +747,27 @@ and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> let cu2 = f fx1 fx2 cu1 in cmp_rec a1 a2 cu2 - | (Zlcase(ci1,l1,p1,br1,e1),Zlcase(ci2,l2,p2,br2,e2)) -> + | (Zlcase(ci1,l1,u1,pms1,p1,br1,e1),Zlcase(ci2,l2,u2,pms2,p2,br2,e2)) -> if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then raise NotConvertible; - let cu2 = f (l1, mk_clos e1 p1) (l2, mk_clos e2 p2) cu1 in - convert_branches l2r infos ci1 e1 e2 l1 l2 br1 br2 cu2 + let cu = cu1 in + (** FIXME: cache the presence of let-bindings in the case_info *) + let mind = Environ.lookup_mind (fst ci1.ci_ind) (info_env infos.cnv_inf) in + let mip = mind.Declarations.mind_packets.(snd ci1.ci_ind) in + let cu = + if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then + convert_instances ~flex:false u1 u2 cu + else + match mind.Declarations.mind_variance with + | None -> convert_instances ~flex:false u1 u2 cu + | Some variances -> convert_instances_cumul CONV variances u1 u2 cu + in + let pms1 = Array.map_to_list (fun c -> mk_clos e1 c) pms1 in + let pms2 = Array.map_to_list (fun c -> mk_clos e2 c) pms2 in + let fold_params c1 c2 accu = f (l1, c1) (l2, c2) accu in + let cu = List.fold_right2 fold_params pms1 pms2 cu in + let cu = convert_return_clause ci1.ci_ind mind mip l2r infos e1 e2 l1 l2 u1 u2 pms1 pms2 p1 p2 cu in + convert_branches ci1.ci_ind mind mip l2r infos e1 e2 l1 l2 u1 u2 pms1 pms2 br1 br2 cu | (Zlprimitive(op1,_,rargs1,kargs1),Zlprimitive(op2,_,rargs2,kargs2)) -> if not (CPrimitives.equal op1 op2) then raise NotConvertible else let cu2 = List.fold_right2 f rargs1 rargs2 cu1 in @@ -743,21 +792,55 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = fold 0 cuniv else raise NotConvertible -and convert_branches l2r infos ci e1 e2 lft1 lft2 br1 br2 cuniv = - (** Skip comparison of the pattern types. We know that the two terms are - living in a common type, thus this check is useless. *) - let fold n c1 c2 cuniv = match skip_pattern infos n c1 c2 with - | (infos, c1, c2) -> - let lft1 = el_liftn n lft1 in - let lft2 = el_liftn n lft2 in +and convert_under_context l2r infos e1 e2 lft1 lft2 ctx (nas1, c1) (nas2, c2) cu = + let n = Array.length nas1 in + let () = assert (Int.equal n (Array.length nas2)) in + let n, e1, e2 = match ctx with + | None -> (* nolet *) let e1 = subs_liftn n e1 in let e2 = subs_liftn n e2 in - ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cuniv - | exception IrregularPatternShape -> - (** Might happen due to a shape invariant that is not enforced *) - ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cuniv + (n, e1, e2) + | Some (ctx, u1, u2, args1, args2) -> + let n1, e1 = esubst_of_rel_context_instance ctx u1 args1 e1 in + let n2, e2 = esubst_of_rel_context_instance ctx u2 args2 e2 in + let () = assert (Int.equal n1 n2) in + n1, e1, e2 + in + let lft1 = el_liftn n lft1 in + let lft2 = el_liftn n lft2 in + let infos = push_relevances infos nas1 in + ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cu + +and convert_return_clause ind mib mip l2r infos e1 e2 l1 l2 u1 u2 pms1 pms2 p1 p2 cu = + let ctx = + if Int.equal mip.mind_nrealargs mip.mind_nrealdecls then None + else + let ctx, _ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in + let pms1 = inductive_subst ind mib u1 pms1 in + let pms2 = inductive_subst ind mib u1 pms2 in + let open Context.Rel.Declaration in + (* Add the inductive binder *) + let dummy = mkProp in + let ctx = LocalAssum (Context.anonR, dummy) :: ctx in + Some (ctx, u1, u2, pms1, pms2) + in + convert_under_context l2r infos e1 e2 l1 l2 ctx p1 p2 cu + +and convert_branches ind mib mip l2r infos e1 e2 lft1 lft2 u1 u2 pms1 pms2 br1 br2 cuniv = + let fold i (ctx, _) cuniv = + let ctx = + if Int.equal mip.mind_consnrealdecls.(i) mip.mind_consnrealargs.(i) then None + else + let ctx, _ = List.chop mip.mind_consnrealdecls.(i) ctx in + let pms1 = inductive_subst ind mib u1 pms1 in + let pms2 = inductive_subst ind mib u2 pms2 in + Some (ctx, u1, u2, pms1, pms2) + in + let c1 = br1.(i) in + let c2 = br2.(i) in + convert_under_context l2r infos e1 e2 lft1 lft2 ctx c1 c2 cuniv in - Array.fold_right3 fold ci.ci_cstr_nargs br1 br2 cuniv + Array.fold_right_i fold mip.mind_nf_lc cuniv and convert_list l2r infos lft1 lft2 v1 v2 cuniv = match v1, v2 with | [], [] -> cuniv diff --git a/kernel/relevanceops.ml b/kernel/relevanceops.ml index f12b8cba37..986fc685d1 100644 --- a/kernel/relevanceops.ml +++ b/kernel/relevanceops.ml @@ -61,7 +61,7 @@ let rec relevance_of_fterm env extra lft f = | FProj (p, _) -> relevance_of_projection env p | FFix (((_,i),(lna,_,_)), _) -> (lna.(i)).binder_relevance | FCoFix ((i,(lna,_,_)), _) -> (lna.(i)).binder_relevance - | FCaseT (ci, _, _, _, _) | FCaseInvert (ci, _, _, _, _, _) -> ci.ci_relevance + | FCaseT (ci, _, _, _, _, _, _) | FCaseInvert (ci, _, _, _, _, _, _, _) -> ci.ci_relevance | FLambda (len, tys, bdy, e) -> let extra = List.fold_left (fun accu (x, _) -> Range.cons (binder_relevance x) accu) extra tys in let lft = Esubst.el_liftn len lft in @@ -97,7 +97,7 @@ and relevance_of_term_extra env extra lft subs c = | App (c, _) -> relevance_of_term_extra env extra lft subs c | Const (c,_) -> relevance_of_constant env c | Construct (c,_) -> relevance_of_constructor env c - | Case (ci, _, _, _, _) -> ci.ci_relevance + | Case (ci, _, _, _, _, _, _) -> ci.ci_relevance | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance | Proj (p, _) -> relevance_of_projection env p diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 802a32b0e7..741491c917 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -548,22 +548,26 @@ let rec execute env cstr = | Construct c -> cstr, type_of_constructor env c - | Case (ci,p,iv,c,lf) -> + | Case (ci, u, pms, p, iv, c, lf) -> + (** FIXME: change type_of_case to handle the compact form *) + let (ci, p, iv, c, lf) = expand_case env (ci, u, pms, p, iv, c, lf) in let c', ct = execute env c in let iv' = match iv with | NoInvert -> NoInvert - | CaseInvert {univs;args} -> - let ct' = mkApp (mkIndU (ci.ci_ind,univs), args) in + | CaseInvert {indices} -> + let args = Array.append pms indices in + let ct' = mkApp (mkIndU (ci.ci_ind,u), args) in let (ct', _) : constr * Sorts.t = execute_is_type env ct' in let () = conv_leq false env ct ct' in let _, args' = decompose_appvect ct' in - if args == args' then iv else CaseInvert {univs;args=args'} + if args == args' then iv + else CaseInvert {indices=Array.sub args' (Array.length pms) (Array.length indices)} in let p', pt = execute env p in let lf', lft = execute_array env lf in let ci', t = type_of_case env ci p' pt iv' c' ct lf' lft in let cstr = if ci == ci' && c == c' && p == p' && iv == iv' && lf == lf' then cstr - else mkCase(ci',p',iv',c',lf') + else mkCase (Inductive.contract_case env (ci',p',iv',c',lf')) in cstr, t @@ -720,11 +724,6 @@ let judge_of_inductive env indu = let judge_of_constructor env cu = make_judge (mkConstructU cu) (type_of_constructor env cu) -let judge_of_case env ci pj iv cj lfj = - let lf, lft = dest_judgev lfj in - let ci, t = type_of_case env ci pj.uj_val pj.uj_type iv cj.uj_val cj.uj_type lf lft in - make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, iv, cj.uj_val, lft)) t - (* Building type of primitive operators and type *) let type_of_prim_const env _u c = diff --git a/kernel/typeops.mli b/kernel/typeops.mli index d381e55dd6..5ea7163f72 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -92,12 +92,6 @@ val judge_of_cast : val judge_of_inductive : env -> inductive puniverses -> unsafe_judgment val judge_of_constructor : env -> constructor puniverses -> unsafe_judgment -(** {6 Type of Cases. } *) -val judge_of_case : env -> case_info - -> unsafe_judgment -> (constr,Instance.t) case_invert -> unsafe_judgment - -> unsafe_judgment array - -> unsafe_judgment - (** {6 Type of global references. } *) val type_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 096e458ec4..b988ec40a7 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -222,15 +222,35 @@ let choose p g u = if Level.is_sprop u then if p u then Some u else None else G.choose p g.graph u -let dump_universes f g = G.dump f g.graph - let check_universes_invariants g = G.check_invariants ~required_canonical:Level.is_small g.graph -let pr_universes prl g = G.pr prl g.graph - -let dummy_mp = Names.DirPath.make [Names.Id.of_string "Type"] -let make_dummy i = Level.(make (UGlobal.make dummy_mp i)) -let sort_universes g = g_map (G.sort make_dummy [Level.prop;Level.set]) g +(** Pretty-printing *) + +let pr_pmap sep pr map = + let cmp (u,_) (v,_) = Level.compare u v in + Pp.prlist_with_sep sep pr (List.sort cmp (LMap.bindings map)) + +let pr_arc prl = let open Pp in + function + | u, G.Node ltle -> + if LMap.is_empty ltle then mt () + else + prl u ++ str " " ++ + v 0 + (pr_pmap spc (fun (v, strict) -> + (if strict then str "< " else str "<= ") ++ prl v) + ltle) ++ + fnl () + | u, G.Alias v -> + prl u ++ str " = " ++ prl v ++ fnl () + +type node = G.node = +| Alias of Level.t +| Node of bool LMap.t + +let repr g = G.repr g.graph + +let pr_universes prl g = pr_pmap Pp.mt (pr_arc prl) g (** Profiling *) diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 87b3634e28..9ac29f5139 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -77,15 +77,9 @@ exception UndeclaredLevel of Univ.Level.t val check_declared_universes : t -> Univ.LSet.t -> unit -(** {6 Pretty-printing of universes. } *) - -val pr_universes : (Level.t -> Pp.t) -> t -> Pp.t - (** The empty graph of universes *) val empty_universes : t -val sort_universes : t -> t - (** [constraints_of_universes g] returns [csts] and [partition] where [csts] are the non-Eq constraints and [partition] is the partition of the universes into equivalence classes. *) @@ -108,10 +102,17 @@ val check_subtype : lbound:Bound.t -> AUContext.t check_function (** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of [ctx1]. *) -(** {6 Dumping to a file } *) +(** {6 Dumping} *) + +type node = +| Alias of Level.t +| Node of bool LMap.t (** Nodes v s.t. u < v (true) or u <= v (false) *) + +val repr : t -> node LMap.t + +(** {6 Pretty-printing of universes. } *) -val dump_universes : - (constraint_type -> Level.t -> Level.t -> unit) -> t -> unit +val pr_universes : (Level.t -> Pp.t) -> node LMap.t -> Pp.t (** {6 Debugging} *) val check_universes_invariants : t -> unit diff --git a/kernel/uint63_31.ml b/kernel/uint63_31.ml index 988611df3e..4f2cbc4262 100644 --- a/kernel/uint63_31.ml +++ b/kernel/uint63_31.ml @@ -206,9 +206,7 @@ let () = Callback.register "uint63 leq" le; Callback.register "uint63 lor" l_or; Callback.register "uint63 lsl" l_sl; - Callback.register "uint63 lsl1" (fun x -> l_sl x Int64.one); Callback.register "uint63 lsr" l_sr; - Callback.register "uint63 lsr1" (fun x -> l_sr x Int64.one); Callback.register "uint63 lt" lt; Callback.register "uint63 lxor" l_xor; Callback.register "uint63 mod" rem; diff --git a/kernel/vars.ml b/kernel/vars.ml index a446fa413c..b09577d4db 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -253,12 +253,20 @@ let subst_univs_level_constr subst c = if u' == u then t else (changed := true; mkSort (Sorts.sort_of_univ u')) - | Case (ci,p,CaseInvert {univs;args},c,br) -> - if Univ.Instance.is_empty univs then Constr.map aux t + | Case (ci, u, pms, p, CaseInvert {indices}, c, br) -> + if Univ.Instance.is_empty u then Constr.map aux t else - let univs' = f univs in - if univs' == univs then Constr.map aux t - else (changed:=true; Constr.map aux (mkCase (ci,p,CaseInvert {univs=univs';args},c,br))) + let u' = f u in + if u' == u then Constr.map aux t + else (changed:=true; Constr.map aux (mkCase (ci,u',pms,p,CaseInvert {indices},c,br))) + + | Case (ci, u, pms, p, NoInvert, c, br) -> + if Univ.Instance.is_empty u then Constr.map aux t + else + let u' = f u in + if u' == u then Constr.map aux t + else + (changed := true; Constr.map aux (mkCase (ci, u', pms, p, NoInvert, c, br))) | Array (u,elems,def,ty) -> let u' = f u in @@ -305,10 +313,18 @@ let subst_instance_constr subst c = if u' == u then t else (mkSort (Sorts.sort_of_univ u')) - | Case (ci,p,CaseInvert {univs;args},c,br) -> - let univs' = f univs in - if univs' == univs then Constr.map aux t - else Constr.map aux (mkCase (ci,p,CaseInvert {univs=univs';args},c,br)) + | Case (ci, u, pms, p, CaseInvert {indices}, c, br) -> + let u' = f u in + if u' == u then Constr.map aux t + else Constr.map aux (mkCase (ci,u',pms,p,CaseInvert {indices},c,br)) + + | Case (ci, u, pms, p, NoInvert, c, br) -> + if Univ.Instance.is_empty u then Constr.map aux t + else + let u' = f u in + if u' == u then Constr.map aux t + else + Constr.map aux (mkCase (ci, u', pms, p, NoInvert, c, br)) | Array (u,elems,def,ty) -> let u' = f u in @@ -348,8 +364,8 @@ let universes_of_constr c = | Array (u,_,_,_) -> let s = LSet.fold LSet.add (Instance.levels u) s in Constr.fold aux s c - | Case (_,_,CaseInvert {univs;args=_},_,_) -> - let s = LSet.fold LSet.add (Instance.levels univs) s in + | Case (_, u, _, _, _,_ ,_) -> + let s = LSet.fold LSet.add (Instance.levels u) s in Constr.fold aux s c | _ -> Constr.fold aux s c in aux LSet.empty c diff --git a/kernel/vmbytecodes.ml b/kernel/vmbytecodes.ml index 4977aec00a..c2b087f061 100644 --- a/kernel/vmbytecodes.ml +++ b/kernel/vmbytecodes.ml @@ -49,7 +49,6 @@ type instruction = | Kgetglobal of Constant.t | Kconst of structured_constant | Kmakeblock of int * tag - | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array | Kpushfields of int @@ -123,7 +122,6 @@ let rec pp_instr i = str "const " ++ pp_struct_const sc | Kmakeblock(n, m) -> str "makeblock " ++ int n ++ str ", " ++ int m - | Kmakeprod -> str "makeprod" | Kmakeswitchblock(lblt,lbls,_,sz) -> str "makeswitchblock " ++ pp_lbl lblt ++ str ", " ++ pp_lbl lbls ++ str ", " ++ int sz diff --git a/kernel/vmbytecodes.mli b/kernel/vmbytecodes.mli index 003a77ab78..eeca0d2ad1 100644 --- a/kernel/vmbytecodes.mli +++ b/kernel/vmbytecodes.mli @@ -47,7 +47,6 @@ type instruction = | Kmakeblock of (* size: *) int * tag (** allocate an ocaml block. Index 0 ** is accu, all others are popped from ** the top of the stack *) - | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array (** consts,blocks *) | Kpushfields of int diff --git a/kernel/vmbytegen.ml b/kernel/vmbytegen.ml index 70c92fd8f0..20de4bc81b 100644 --- a/kernel/vmbytegen.ml +++ b/kernel/vmbytegen.ml @@ -569,7 +569,7 @@ let rec compile_lam env cenv lam sz cont = | Lprod (dom,codom) -> let cont1 = - Kpush :: compile_lam env cenv dom (sz+1) (Kmakeprod :: cont) in + Kpush :: compile_lam env cenv dom (sz+1) (Kmakeblock (2,0) :: cont) in compile_lam env cenv codom sz cont1 | Llam (ids,body) -> diff --git a/kernel/vmemitcodes.ml b/kernel/vmemitcodes.ml index c1d8fcb855..d3af8bf09b 100644 --- a/kernel/vmemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -135,6 +135,16 @@ let out env opcode = let is_immed i = Uint63.le (Uint63.of_int i) Uint63.maxuint31 +(* Detect whether the current value of the accu register is no longer + needed (i.e., the register is written before being read). If so, the + register can be used freely; no need to save and restore it. *) +let is_accu_dead = function + | [] -> false + | c :: _ -> + match c with + | Kacc _ | Kenvacc _ | Kconst _ | Koffsetclosure _ | Kgetglobal _ -> true + | _ -> false + let out_int env n = out_word env n (n asr 8) (n asr 16) (n asr 24) @@ -327,8 +337,6 @@ let emit_instr env = function if Int.equal n 0 then invalid_arg "emit_instr : block size = 0" else if n < 4 then (out env(opMAKEBLOCK1 + n - 1); out_int env t) else (out env opMAKEBLOCK; out_int env n; out_int env t) - | Kmakeprod -> - out env opMAKEPROD | Kmakeswitchblock(typlbl,swlbl,annot,sz) -> out env opMAKESWITCHBLOCK; out_label env typlbl; out_label env swlbl; @@ -349,8 +357,7 @@ let emit_instr env = function if n <= 1 then out env (opGETFIELD0+n) else (out env opGETFIELD;out_int env n) | Ksetfield n -> - if n <= 1 then out env (opSETFIELD0+n) - else (out env opSETFIELD;out_int env n) + out env opSETFIELD; out_int env n | Ksequence _ -> invalid_arg "Vmemitcodes.emit_instr" | Kproj p -> out env opPROJ; out_int env (Projection.Repr.arg p); slot_for_proj_name env p | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size @@ -375,7 +382,9 @@ let rec emit env insns remaining = match insns with | (first::rest) -> emit env first rest) (* Peephole optimizations *) | Kpush :: Kacc n :: c -> - if n < 8 then out env(opPUSHACC0 + n) else (out env opPUSHACC; out_int env n); + if n = 0 then out env opPUSH + else if n < 8 then out env (opPUSHACC1 + n - 1) + else (out env opPUSHACC; out_int env n); emit env c remaining | Kpush :: Kenvacc n :: c -> if n >= 0 && n <= 3 @@ -397,6 +406,9 @@ let rec emit env insns remaining = match insns with | Kpush :: Kconst const :: c -> out env opPUSHGETGLOBAL; slot_for_const env const; emit env c remaining + | Kpushfields 1 :: c when is_accu_dead c -> + out env opGETFIELD0; + emit env (Kpush :: c) remaining | Kpop n :: Kjump :: c -> out env opRETURN; out_int env n; emit env c remaining | Ksequence c1 :: c -> diff --git a/kernel/vmlambda.ml b/kernel/vmlambda.ml index 390fa58883..91de58b0e6 100644 --- a/kernel/vmlambda.ml +++ b/kernel/vmlambda.ml @@ -674,7 +674,8 @@ let rec lambda_of_constr env c = | Construct _ -> lambda_of_app env c empty_args - | Case(ci,t,_iv,a,branches) -> (* XXX handle iv *) + | Case (ci, u, pms, t, iv, a, br) -> (* XXX handle iv *) + let (ci, t, _iv, a, branches) = Inductive.expand_case env.global_env (ci, u, pms, t, iv, a, br) in let ind = ci.ci_ind in let mib = lookup_mind (fst ind) env.global_env in let oib = mib.mind_packets.(snd ind) in diff --git a/lib/acyclicGraph.ml b/lib/acyclicGraph.ml index 8da09dc98a..17299c72eb 100644 --- a/lib/acyclicGraph.ml +++ b/lib/acyclicGraph.ml @@ -58,15 +58,59 @@ module Make (Point:Point) = struct *) - module PMap = Point.Map - module PSet = Point.Set + module Index : + sig + type t + val equal : t -> t -> bool + module Set : CSig.SetS with type elt = t + module Map : CMap.ExtS with type key = t and module Set := Set + type table + val empty : table + val fresh : Point.t -> table -> t * table + val mem : Point.t -> table -> bool + val find : Point.t -> table -> t + val repr : t -> table -> Point.t + end = + struct + type t = int + let equal = Int.equal + module Set = Int.Set + module Map = Int.Map + + type table = { + tab_len : int; + tab_fwd : Point.t Int.Map.t; + tab_bwd : int Point.Map.t + } + + let empty = { + tab_len = 0; + tab_fwd = Int.Map.empty; + tab_bwd = Point.Map.empty; + } + let mem x t = Point.Map.mem x t.tab_bwd + let find x t = Point.Map.find x t.tab_bwd + let repr n t = Int.Map.find n t.tab_fwd + + let fresh x t = + let () = assert (not @@ mem x t) in + let n = t.tab_len in + n, { + tab_len = n + 1; + tab_fwd = Int.Map.add n x t.tab_fwd; + tab_bwd = Point.Map.add x n t.tab_bwd; + } + end + + module PMap = Index.Map + module PSet = Index.Set module Constraint = Point.Constraint type status = NoMark | Visited | WeakVisited | ToMerge (* Comparison on this type is pointer equality *) type canonical_node = - { canon: Point.t; + { canon: Index.t; ltle: bool PMap.t; (* true: strict (lt) constraint. false: weak (le) constraint. *) gtge: PSet.t; @@ -76,19 +120,18 @@ module Make (Point:Point) = struct mutable status: status } - let big_rank = 1000000 - (* A Point.t is either an alias for another one, or a canonical one, for which we know the points that are above *) type entry = | Canonical of canonical_node - | Equiv of Point.t + | Equiv of Index.t type t = { entries : entry PMap.t; index : int; - n_nodes : int; n_edges : int } + n_nodes : int; n_edges : int; + table : Index.table } (** Used to cleanup mutable marks if a traversal function is interrupted before it has the opportunity to do it itself. *) @@ -123,7 +166,8 @@ module Make (Point:Point) = struct | _ -> assert false) g.entries; index = g.index; n_nodes = g.n_nodes - 1; - n_edges = g.n_edges } + n_edges = g.n_edges; + table = g.table } (* Low-level function : changes data associated with a canonical node. Resets the mutable fields in the old record, in order to avoid breaking @@ -147,7 +191,10 @@ module Make (Point:Point) = struct | Canonical arc -> arc | exception Not_found -> CErrors.anomaly ~label:"Univ.repr" - Pp.(str"Universe " ++ Point.pr u ++ str" undefined.") + Pp.(str"Universe " ++ Point.pr (Index.repr u g.table) ++ str" undefined.") + + let repr_node g u = + repr g (Index.find u g.table) exception AlreadyDeclared @@ -158,30 +205,6 @@ module Make (Point:Point) = struct assert (g.index > min_int); { g with index = g.index - 1 } - (* [safe_repr] is like [repr] but if the graph doesn't contain the - searched point, we add it. *) - let safe_repr g u = - let rec safe_repr_rec entries u = - match PMap.find u entries with - | Equiv v -> safe_repr_rec entries v - | Canonical arc -> arc - in - try g, safe_repr_rec g.entries u - with Not_found -> - let can = - { canon = u; - ltle = PMap.empty; gtge = PSet.empty; - rank = 0; - klvl = 0; ilvl = 0; - status = NoMark } - in - let g = { g with - entries = PMap.add u (Canonical can) g.entries; - n_nodes = g.n_nodes + 1 } - in - let g = use_index g u in - g, repr g u - (* Returns 1 if u is higher than v in topological order. -1 lower 0 if u = v *) @@ -194,6 +217,7 @@ module Make (Point:Point) = struct (* Checks most of the invariants of the graph. For debugging purposes. *) let check_invariants ~required_canonical g = + let required_canonical u = required_canonical (Index.repr u g.table) in let n_edges = ref 0 in let n_nodes = ref 0 in PMap.iter (fun l u -> @@ -214,7 +238,7 @@ module Make (Point:Point) = struct PMap.exists (fun l _ -> u == repr g l) v.ltle)) ) u.gtge; assert (u.status = NoMark); - assert (Point.equal l u.canon); + assert (Index.equal l u.canon); assert (u.ilvl > g.index); assert (not (PMap.mem u.canon u.ltle)); incr n_nodes @@ -226,7 +250,7 @@ module Make (Point:Point) = struct let clean_ltle g ltle = PMap.fold (fun u strict acc -> let uu = (repr g u).canon in - if Point.equal uu u then acc + if Index.equal uu u then acc else ( let acc = PMap.remove u (fst acc) in if not strict && PMap.mem uu acc then (acc, true) @@ -236,7 +260,7 @@ module Make (Point:Point) = struct let clean_gtge g gtge = PSet.fold (fun u acc -> let uu = (repr g u).canon in - if Point.equal uu u then acc + if Index.equal uu u then acc else PSet.add uu (PSet.remove u (fst acc)), true) gtge (gtge, false) @@ -340,7 +364,7 @@ module Make (Point:Point) = struct | Visited -> false, to_revert | ToMerge -> true, to_revert | NoMark -> let to_revert = x::to_revert in - if Point.equal x.canon v then + if Index.equal x.canon v then begin x.status <- ToMerge; true, to_revert end else begin @@ -451,7 +475,7 @@ module Make (Point:Point) = struct (* Inserting shortcuts for old nodes. *) let g = List.fold_left (fun g n -> - if Point.equal n.canon root.canon then g else enter_equiv g n.canon root.canon) + if Index.equal n.canon root.canon then g else enter_equiv g n.canon root.canon) g to_merge in @@ -507,11 +531,10 @@ module Make (Point:Point) = struct raise e let add ?(rank=0) v g = - try - let _arcv = PMap.find v g.entries in - raise AlreadyDeclared - with Not_found -> - assert (g.index > min_int); + if Index.mem v g.table then raise AlreadyDeclared + else + let () = assert (g.index > min_int) in + let v, table = Index.fresh v g.table in let node = { canon = v; ltle = PMap.empty; @@ -523,17 +546,18 @@ module Make (Point:Point) = struct } in let entries = PMap.add v (Canonical node) g.entries in - { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } + { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges; table } exception Undeclared of Point.t let check_declared g us = - let check l = if not (PMap.mem l g.entries) then raise (Undeclared l) in - PSet.iter check us + let check l = if not (Index.mem l g.table) then raise (Undeclared l) in + Point.Set.iter check us exception Found_explanation of (constraint_type * Point.t) list let get_explanation strict u v g = - let v = repr g v in + let u = Index.find u g.table in + let v = repr_node g v in let visited_strict = ref PMap.empty in let rec traverse strict u = if u == v then @@ -553,6 +577,7 @@ module Make (Point:Point) = struct | None -> () | Some exp -> let typ = if strictu' then Lt else Le in + let u' = Index.repr u' g.table in raise (Found_explanation ((typ, u') :: exp))) u.ltle; None @@ -560,7 +585,7 @@ module Make (Point:Point) = struct end in let u = repr g u in - if u == v then [(Eq, v.canon)] + if u == v then [(Eq, Index.repr v.canon g.table)] else match traverse strict u with Some exp -> exp | None -> assert false let get_explanation strict u v g = @@ -634,21 +659,27 @@ module Make (Point:Point) = struct let check_eq g u v = u == v || - let arcu = repr g u and arcv = repr g v in + let arcu = repr_node g u and arcv = repr_node g v in arcu == arcv let check_smaller g strict u v = - search_path strict (repr g u) (repr g v) g + search_path strict (repr_node g u) (repr_node g v) g let check_leq g u v = check_smaller g false u v let check_lt g u v = check_smaller g true u v (* enforce_eq g u v will force u=v if possible, will fail otherwise *) - let rec enforce_eq u v g = - let ucan = repr g u in - let vcan = repr g v in - if topo_compare ucan vcan = 1 then enforce_eq v u g + let enforce_eq u v g = + let ucan = repr_node g u in + let vcan = repr_node g v in + if ucan == vcan then g + else if topo_compare ucan vcan = 1 then + let ucan = vcan and vcan = ucan in + let g = insert_edge false ucan vcan g in (* Cannot fail *) + try insert_edge false vcan ucan g + with CycleDetected -> + Point.error_inconsistency Eq v u (get_explanation true v u g) else let g = insert_edge false ucan vcan g in (* Cannot fail *) try insert_edge false vcan ucan g @@ -657,58 +688,40 @@ module Make (Point:Point) = struct (* enforce_leq g u v will force u<=v if possible, will fail otherwise *) let enforce_leq u v g = - let ucan = repr g u in - let vcan = repr g v in + let ucan = repr_node g u in + let vcan = repr_node g v in try insert_edge false ucan vcan g with CycleDetected -> Point.error_inconsistency Le u v (get_explanation true v u g) (* enforce_lt u v will force u<v if possible, will fail otherwise *) let enforce_lt u v g = - let ucan = repr g u in - let vcan = repr g v in + let ucan = repr_node g u in + let vcan = repr_node g v in try insert_edge true ucan vcan g with CycleDetected -> Point.error_inconsistency Lt u v (get_explanation false v u g) let empty = - { entries = PMap.empty; index = 0; n_nodes = 0; n_edges = 0 } + { entries = PMap.empty; index = 0; n_nodes = 0; n_edges = 0; table = Index.empty } (* Normalization *) - (** [normalize g] returns a graph where all edges point - directly to the canonical representent of their target. The output - graph should be equivalent to the input graph from a logical point - of view, but optimized. We maintain the invariant that the key of - a [Canonical] element is its own name, by keeping [Equiv] edges. *) - let normalize g = - let g = - { g with - entries = PMap.map (fun entry -> - match entry with - | Equiv u -> Equiv ((repr g u).canon) - | Canonical ucan -> Canonical { ucan with rank = 1 }) - g.entries } - in - PMap.fold (fun _ u g -> - match u with - | Equiv _u -> g - | Canonical u -> - let _, u, g = get_ltle g u in - let _, _, g = get_gtge g u in - g) - g.entries g - let constraints_of g = - let module UF = Unionfind.Make (PSet) (PMap) in + let module UF = Unionfind.Make (Point.Set) (Point.Map) in let uf = UF.create () in let constraints_of u v acc = match v with | Canonical {canon=u; ltle; _} -> PMap.fold (fun v strict acc-> let typ = if strict then Lt else Le in + let u = Index.repr u g.table in + let v = Index.repr v g.table in Constraint.add (u,typ,v) acc) ltle acc - | Equiv v -> UF.union u v uf; acc + | Equiv v -> + let u = Index.repr u g.table in + let v = Index.repr v g.table in + UF.union u v uf; acc in let csts = PMap.fold constraints_of g.entries Constraint.empty in csts, UF.partition uf @@ -716,16 +729,20 @@ module Make (Point:Point) = struct (* domain g.entries = kept + removed *) let constraints_for ~kept g = (* rmap: partial map from canonical points to kept points *) + let add_cst u knd v cst = + Constraint.add (Index.repr u g.table, knd, Index.repr v g.table) cst + in + let kept = Point.Set.fold (fun u accu -> PSet.add (Index.find u g.table) accu) kept PSet.empty in let rmap, csts = PSet.fold (fun u (rmap,csts) -> let arcu = repr g u in if PSet.mem arcu.canon kept then - let csts = if Point.equal u arcu.canon then csts - else Constraint.add (u,Eq,arcu.canon) csts + let csts = if Index.equal u arcu.canon then csts + else add_cst u Eq arcu.canon csts in PMap.add arcu.canon arcu.canon rmap, csts else match PMap.find arcu.canon rmap with - | v -> rmap, Constraint.add (u,Eq,v) csts + | v -> rmap, add_cst u Eq v csts | exception Not_found -> PMap.add arcu.canon u rmap, csts) kept (PMap.empty,Constraint.empty) in @@ -736,7 +753,7 @@ module Make (Point:Point) = struct (match PMap.find v.canon rmap with | v -> let d = if strict then Lt else Le in - let csts = Constraint.add (u,d,v) csts in + let csts = add_cst u d v csts in add_from u csts todo | exception Not_found -> (* v is not equal to any kept point *) @@ -752,102 +769,42 @@ module Make (Point:Point) = struct arc.ltle csts) kept csts - let domain g = PMap.domain g.entries + let domain g = + let fold u _ accu = Point.Set.add (Index.repr u g.table) accu in + PMap.fold fold g.entries Point.Set.empty let choose p g u = let exception Found of Point.t in - let ru = (repr g u).canon in - if p ru then Some ru + let ru = (repr_node g u).canon in + let ruv = Index.repr ru g.table in + if p ruv then Some ruv else try PMap.iter (fun v -> function | Canonical _ -> () (* we already tried [p ru] *) | Equiv v' -> let rv = (repr g v').canon in - if rv == ru && p v then raise (Found v) + if rv == ru then + let v = Index.repr v g.table in + if p v then raise (Found v) (* NB: we could also try [p v'] but it will come up in the rest of the iteration regardless. *) ) g.entries; None with Found v -> Some v - let sort make_dummy first g = - let cans = - PMap.fold (fun _ u l -> - match u with - | Equiv _ -> l - | Canonical can -> can :: l - ) g.entries [] - in - let cans = List.sort topo_compare cans in - let lowest = - PMap.mapi (fun u _ -> if CList.mem_f Point.equal u first then 0 else 2) - (PMap.filter - (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true) - g.entries) - in - let lowest = - List.fold_left (fun lowest can -> - let lvl = PMap.find can.canon lowest in - PMap.fold (fun u' strict lowest -> - let cost = if strict then 1 else 0 in - let u' = (repr g u').canon in - PMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest) - can.ltle lowest) - lowest cans - in - let max_lvl = PMap.fold (fun _ a b -> max a b) lowest 0 in - let types = Array.init (max_lvl + 1) (fun i -> - match List.nth_opt first i with - | Some u -> u - | None -> make_dummy (i-2)) - in - let g = Array.fold_left (fun g u -> - let g, u = safe_repr g u in - change_node g { u with rank = big_rank }) g types - in - let g = if max_lvl > List.length first && not (CList.is_empty first) then - enforce_lt (CList.last first) types.(List.length first) g - else g - in - let g = - PMap.fold (fun u lvl g -> enforce_eq u (types.(lvl)) g) - lowest g - in - normalize g - - (** Pretty-printing *) - - let pr_pmap sep pr map = - let cmp (u,_) (v,_) = Point.compare u v in - Pp.prlist_with_sep sep pr (List.sort cmp (PMap.bindings map)) - - let pr_arc prl = let open Pp in - function - | _, Canonical {canon=u; ltle; _} -> - if PMap.is_empty ltle then mt () - else - prl u ++ str " " ++ - v 0 - (pr_pmap spc (fun (v, strict) -> - (if strict then str "< " else str "<= ") ++ prl v) - ltle) ++ - fnl () - | u, Equiv v -> - prl u ++ str " = " ++ prl v ++ fnl () - - let pr prl g = - pr_pmap Pp.mt (pr_arc prl) g.entries - - (* Dumping constraints to a file *) - - let dump output g = - let dump_arc u = function - | Canonical {canon=u; ltle; _} -> - PMap.iter (fun v strict -> - let typ = if strict then Lt else Le in - output typ u v) ltle; - | Equiv v -> - output Eq u v + type node = Alias of Point.t | Node of bool Point.Map.t + type repr = node Point.Map.t + + let repr g = + let fold u n accu = + let n = match n with + | Canonical n -> + let fold u lt accu = Point.Map.add (Index.repr u g.table) lt accu in + let ltle = PMap.fold fold n.ltle Point.Map.empty in + Node ltle + | Equiv u -> Alias (Index.repr u g.table) + in + Point.Map.add (Index.repr u g.table) n accu in - PMap.iter dump_arc g.entries + PMap.fold fold g.entries Point.Map.empty end diff --git a/lib/acyclicGraph.mli b/lib/acyclicGraph.mli index e9f05ed74d..8c9d2e6461 100644 --- a/lib/acyclicGraph.mli +++ b/lib/acyclicGraph.mli @@ -65,18 +65,12 @@ module Make (Point:Point) : sig val choose : (Point.t -> bool) -> t -> Point.t -> Point.t option - val sort : (int -> Point.t) -> Point.t list -> t -> t - (** [sort mk first g] builds a totally ordered graph. The output - graph should imply the input graph (and the implication will be - strict most of the time), but is not necessarily minimal. The - lowest points in the result are identified with [first]. - Moreover, it adds levels [Type.n] to identify the points (not in - [first]) at level n. An artificial constraint (last first < mk - (length first)) is added to ensure that they are not merged. - Note: the result is unspecified if the input graph already - contains [mk n] nodes. *) - - val pr : (Point.t -> Pp.t) -> t -> Pp.t - - val dump : (constraint_type -> Point.t -> Point.t -> unit) -> t -> unit + (** {5 High-level representation} *) + + type node = + | Alias of Point.t + | Node of bool Point.Map.t (** Nodes v s.t. u < v (true) or u <= v (false) *) + type repr = node Point.Map.t + val repr : t -> repr + end diff --git a/lib/control.ml b/lib/control.ml index 7da95ff3dd..ea94bda064 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -30,11 +30,12 @@ let check_for_interrupt () = (** This function does not work on windows, sigh... *) let unix_timeout n f x = + let open Unix in let timeout_handler _ = raise Timeout in let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in - let _ = Unix.alarm n in + let _ = setitimer ITIMER_REAL {it_interval = 0.; it_value = n} in let restore_timeout () = - let _ = Unix.alarm 0 in + let _ = setitimer ITIMER_REAL { it_interval = 0.; it_value = 0. } in Sys.set_signal Sys.sigalrm psh in try @@ -52,7 +53,7 @@ let windows_timeout n f x = let thread init = while not !killed do let cur = Unix.gettimeofday () in - if float_of_int n <= cur -. init then begin + if n <= cur -. init then begin interrupt := true; exited := true; Thread.exit () @@ -68,7 +69,7 @@ let windows_timeout n f x = let cur = Unix.gettimeofday () in (* The thread did not interrupt, but the computation took longer than expected. *) - let () = if float_of_int n <= cur -. init then begin + let () = if n <= cur -. init then begin exited := true; raise Sys.Break end in @@ -83,7 +84,7 @@ let windows_timeout n f x = let () = killed := true in Exninfo.iraise e -type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> 'b option } +type timeout = { timeout : 'a 'b. float -> ('a -> 'b) -> 'a -> 'b option } let timeout_fun = match Sys.os_type with | "Unix" | "Cygwin" -> { timeout = unix_timeout } diff --git a/lib/control.mli b/lib/control.mli index 9465d8f0d5..f992d8e8d0 100644 --- a/lib/control.mli +++ b/lib/control.mli @@ -24,13 +24,13 @@ val check_for_interrupt : unit -> unit (** Use this function as a potential yield function. If {!interrupt} has been set, il will raise [Sys.Break]. *) -val timeout : int -> ('a -> 'b) -> 'a -> 'b option +val timeout : float -> ('a -> 'b) -> 'a -> 'b option (** [timeout n f x] tries to compute [Some (f x)], and if it fails to do so before [n] seconds, returns [None] instead. *) (** Set a particular timeout function; warning, this is an internal API and it is scheduled to go away. *) -type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> 'b option } +type timeout = { timeout : 'a 'b. float -> ('a -> 'b) -> 'a -> 'b option } val set_timeout : timeout -> unit (** [protect_sigalrm f x] computes [f x], but if SIGALRM is received during that diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index ac2058ba1b..343fb0b1fe 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -112,13 +112,13 @@ module Bool = struct else if head === negb && Array.length args = 1 then Negb (aux args.(0)) else Var (Env.add env c) - | Case (info, r, _iv, arg, pats) -> + | Case (info, _, _, _, _, arg, pats) -> let is_bool = let i = info.ci_ind in Names.Ind.CanOrd.equal i (Lazy.force ind) in if is_bool then - Ifb ((aux arg), (aux pats.(0)), (aux pats.(1))) + Ifb ((aux arg), (aux (snd pats.(0))), (aux (snd pats.(1)))) else Var (Env.add env c) | _ -> diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 6869f9c47e..0cad192332 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -672,9 +672,11 @@ let rec extract_term env sg mle mlt c args = (* we unify it with an fresh copy of the stored type of [Rel n]. *) let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n) in extract_app env sg mle mlt extract_rel args - | Case ({ci_ind=ip},_,iv,c0,br) -> - (* If invert_case then this is a match that will get erased later, but right now we don't care. *) - extract_app env sg mle mlt (extract_case env sg mle (ip,c0,br)) args + | Case (ci, u, pms, r, iv, c0, br) -> + (* If invert_case then this is a match that will get erased later, but right now we don't care. *) + let (ip, r, iv, c0, br) = EConstr.expand_case env sg (ci, u, pms, r, iv, c0, br) in + let ip = ci.ci_ind in + extract_app env sg mle mlt (extract_case env sg mle (ip,c0,br)) args | Fix ((_,i),recd) -> extract_app env sg mle mlt (extract_fix env sg mle i recd) args | CoFix (i,recd) -> @@ -1078,9 +1080,13 @@ let fake_match_projection env p = let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:arg lab in fold (arg+1) (j+1) (mkProj (Projection.make kn false, mkRel 1)::subst) rem else - let p = mkLambda (x, lift 1 indty, liftn 1 2 ty) in - let branch = lift 1 (it_mkLambda_or_LetIn (mkRel (List.length ctx - (j-1))) ctx) in - let body = mkCase (ci, p, NoInvert, mkRel 1, [|branch|]) in + let p = ([|x|], liftn 1 2 ty) in + let branch = + let nas = Array.of_list (List.rev_map Context.Rel.Declaration.get_annot ctx) in + (nas, mkRel (List.length ctx - (j - 1))) + in + let params = Context.Rel.to_extended_vect mkRel 1 paramslet in + let body = mkCase (ci, u, params, p, NoInvert, mkRel 1, [|branch|]) in it_mkLambda_or_LetIn (mkLambda (x,indty,body)) mib.mind_params_ctxt | LocalDef (_,c,t) :: rem -> let c = liftn 1 j c in diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index c62bc73e41..e208ba9a5c 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -67,10 +67,13 @@ let unif env evd t1 t2= | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast evd nt2) bige | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> Queue.add (a,c) bige;Queue.add (pop b,pop d) bige - | Case (_,pa,_,ca,va),Case (_,pb,_,cb,vb)-> - Queue.add (pa,pb) bige; - Queue.add (ca,cb) bige; - let l=Array.length va in + | Case (cia,ua,pmsa,pa,iva,ca,va),Case (cib,ub,pmsb,pb,ivb,cb,vb)-> + let env = Global.env () in + let (cia,pa,iva,ca,va) = EConstr.expand_case env evd (cia,ua,pmsa,pa,iva,ca,va) in + let (cib,pb,iva,cb,vb) = EConstr.expand_case env evd (cib,ub,pmsb,pb,ivb,cb,vb) in + Queue.add (pa,pb) bige; + Queue.add (ca,cb) bige; + let l=Array.length va in if not (Int.equal l (Array.length vb)) then raise (UFAIL (nt1,nt2)) else diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 67b6839b6e..3234d40f73 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -598,12 +598,12 @@ let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos let sigma = Proofview.Goal.sigma g in (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) match EConstr.kind sigma dyn_infos.info with - | Case (ci, ct, iv, t, cb) -> + | Case (ci, u, pms, ct, iv, t, cb) -> let do_finalize_t dyn_info' = Proofview.Goal.enter (fun g -> let t = dyn_info'.info in let dyn_infos = - {dyn_info' with info = mkCase (ci, ct, iv, t, cb)} + {dyn_info' with info = mkCase (ci, u, pms, ct, iv, t, cb)} in let g_nb_prod = nb_prod (Proofview.Goal.sigma g) (Proofview.Goal.concl g) diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index c344fdd611..cbdebb7bbc 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -972,7 +972,7 @@ and intros_with_rewrite_aux () : unit Proofview.tactic = ( UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type" )) -> tauto - | Case (_, _, _, v, _) -> + | Case (_, _, _, _, _, v, _) -> tclTHENLIST [simplest_case v; intros_with_rewrite ()] | LetIn _ -> tclTHENLIST @@ -1005,7 +1005,7 @@ let rec reflexivity_with_destruct_cases () = (snd (destApp (Proofview.Goal.sigma g) (Proofview.Goal.concl g))).( 2) with - | Case (_, _, _, v, _) -> + | Case (_, _, _, _, _, v, _) -> tclTHENLIST [ simplest_case v ; intros diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 9d896e9182..9e9444951f 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -301,10 +301,11 @@ let check_not_nested env sigma forbidden e = | Const _ -> () | Ind _ -> () | Construct _ -> () - | Case (_, t, _, e, a) -> + | Case (_, _, pms, (_, t), _, e, a) -> + Array.iter check_not_nested pms; check_not_nested t; check_not_nested e; - Array.iter check_not_nested a + Array.iter (fun (_, c) -> check_not_nested c) a | Fix _ -> user_err Pp.(str "check_not_nested : Fix") | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") in @@ -367,7 +368,7 @@ type journey_info = -> unit Proofview.tactic) -> ( case_info * constr - * (constr, EInstance.t) case_invert + * case_invert * constr * constr array , constr ) @@ -472,7 +473,8 @@ let rec travel_aux jinfo continuation_tac (expr_info : constr infos) = ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id ) ) - | Case (ci, t, iv, a, l) -> + | Case (ci, u, pms, t, iv, a, l) -> + let (ci, t, iv, a, l) = EConstr.expand_case env sigma (ci, u, pms, t, iv, a, l) in let continuation_tac_a = jinfo.casE (travel jinfo) (ci, t, iv, a, l) expr_info continuation_tac in @@ -776,7 +778,7 @@ let terminate_case next_step (ci, a, iv, t, l) expr_info continuation_tac infos let a' = infos.info in let new_info = { infos with - info = mkCase (ci, a, iv, a', l) + info = mkCase (EConstr.contract_case env sigma (ci, a, iv, a', l)) ; is_main_branch = expr_info.is_main_branch ; is_final = expr_info.is_final } in diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 4a2c298caa..90c366ed63 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -774,7 +774,7 @@ let rec find_a_destructable_match sigma t = let cl = [cl, (None, None), None], None in let dest = TacAtom (CAst.make @@ TacInductionDestruct(false, false, cl)) in match EConstr.kind sigma t with - | Case (_,_,_,x,_) when closed0 sigma x -> + | Case (_,_,_,_,_,x,_) when closed0 sigma x -> if isVar sigma x then (* TODO check there is no rel n. *) raise (Found (Tacinterp.eval_tactic dest)) diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index b1b96ea9a7..3da5b2bfc4 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -147,7 +147,7 @@ GRAMMAR EXTEND Gram | IDENT "solve" ; "["; l = LIST0 ltac_expr SEP "|"; "]" -> { TacSolve l } | IDENT "idtac"; l = LIST0 message_token -> { TacId l } - | g=failkw; n = [ n = int_or_var -> { n } | -> { fail_default_value } ]; + | g=failkw; n = [ n = nat_or_var -> { n } | -> { fail_default_value } ]; l = LIST0 message_token -> { TacFail (g,n,l) } | st = simple_tactic -> { st } | a = tactic_value -> { TacArg(CAst.make ~loc a) } diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 43957bbde5..cb430efb40 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -182,6 +182,11 @@ let merge_occurrences loc cl = function in (Some p, ans) +let deprecated_conversion_at_with = + CWarnings.create + ~name:"conversion_at_with" ~category:"deprecated" + (fun () -> Pp.str "The syntax [at ... with ...] is deprecated. Use [with ... at ...] instead.") + (* Auxiliary grammar rules *) open Pvernac.Vernac_ @@ -230,7 +235,8 @@ GRAMMAR EXTEND Gram [ [ c = constr -> { (None, c) } | c1 = constr; "with"; c2 = constr -> { (Some (AllOccurrences,c1),c2) } | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr -> - { (Some (occs,c1), c2) } ] ] + { deprecated_conversion_at_with (); (* 8.14 *) + (Some (occs,c1), c2) } ] ] ; occs_nums: [ [ nl = LIST1 nat_or_var -> { OnlyOccurrences nl } diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 59533eb3e3..6d0e0c36b3 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -918,7 +918,8 @@ let reset_env env = Environ.push_rel_context (Environ.rel_context env) env' let fold_match ?(force=false) env sigma c = - let (ci, p, iv, c, brs) = destCase sigma c in + let case = destCase sigma c in + let (ci, p, iv, c, brs) = EConstr.expand_case env sigma case in let cty = Retyping.get_type_of env sigma c in let dep, pred, exists, sk = let env', ctx, body = @@ -986,7 +987,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let argty = Retyping.get_type_of env (goalevars evars) arg in let state, res = s.strategy { state ; env ; unfresh ; - term1 = arg ; ty1 = argty ; + term1 = arg ; ty1 = argty ; cstr = (prop,None) ; evars } in let res' = @@ -1153,7 +1154,8 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | Fail | Identity -> b' in state, res - | Case (ci, p, iv, c, brs) -> + | Case (ci, u, pms, p, iv, c, brs) -> + let (ci, p, iv, c, brs) = EConstr.expand_case env (goalevars evars) (ci, u, pms, p, iv, c, brs) in let cty = Retyping.get_type_of env (goalevars evars) c in let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in let cstr' = Some eqty in @@ -1163,7 +1165,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let state, res = match c' with | Success r -> - let case = mkCase (ci, lift 1 p, map_invert (lift 1) iv, mkRel 1, Array.map (lift 1) brs) in + let case = mkCase (EConstr.contract_case env (goalevars evars) (ci, lift 1 p, map_invert (lift 1) iv, mkRel 1, Array.map (lift 1) brs)) in let res = make_leibniz_proof env case ty r in state, Success (coerce env (prop,cstr) res) | Fail | Identity -> @@ -1185,7 +1187,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = in match found with | Some r -> - let ctxc = mkCase (ci, lift 1 p, map_invert (lift 1) iv, lift 1 c, Array.of_list (List.rev (brs' c'))) in + let ctxc = mkCase (EConstr.contract_case env (goalevars evars) (ci, lift 1 p, map_invert (lift 1) iv, lift 1 c, Array.of_list (List.rev (brs' c')))) in state, Success (make_leibniz_proof env ctxc ty r) | None -> state, c' else @@ -1386,7 +1388,7 @@ module Strategies = let fold_glob c : 'a pure_strategy = { strategy = fun { state ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> -(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) +(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in let unfolded = try Tacred.try_red_product env sigma c diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index e119ceb241..5e138fa3d1 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -930,7 +930,8 @@ let is_prop env sigma term = Sorts.is_prop sort type formula_op = - { op_and : EConstr.t + { op_impl : EConstr.t option (* only for booleans *) + ; op_and : EConstr.t ; op_or : EConstr.t ; op_iff : EConstr.t ; op_not : EConstr.t @@ -939,7 +940,8 @@ type formula_op = let prop_op = lazy - { op_and = Lazy.force coq_and + { op_impl = None (* implication is Prod *) + ; op_and = Lazy.force coq_and ; op_or = Lazy.force coq_or ; op_iff = Lazy.force coq_iff ; op_not = Lazy.force coq_not @@ -948,13 +950,17 @@ let prop_op = let bool_op = lazy - { op_and = Lazy.force coq_andb + { op_impl = Some (Lazy.force coq_implb) + ; op_and = Lazy.force coq_andb ; op_or = Lazy.force coq_orb ; op_iff = Lazy.force coq_eqb ; op_not = Lazy.force coq_negb ; op_tt = Lazy.force coq_true ; op_ff = Lazy.force coq_false } +let is_implb sigma l o = + match o with None -> false | Some c -> EConstr.eq_constr sigma l c + let parse_formula (genv, sigma) parse_atom env tg term = let parse_atom b env tg t = try @@ -970,6 +976,10 @@ let parse_formula (genv, sigma) parse_atom env tg term = match EConstr.kind sigma term with | App (l, rst) -> ( match rst with + | [|a; b|] when is_implb sigma l op.op_impl -> + let f, env, tg = xparse_formula op k env tg a in + let g, env, tg = xparse_formula op k env tg b in + (mkformula_binary k (mkIMPL k) term f g, env, tg) | [|a; b|] when EConstr.eq_constr sigma l op.op_and -> let f, env, tg = xparse_formula op k env tg a in let g, env, tg = xparse_formula op k env tg b in @@ -2075,12 +2085,11 @@ module MakeCache (T : sig val hash_coeff : int -> coeff -> int val eq_prover_option : prover_option -> prover_option -> bool val eq_coeff : coeff -> coeff -> bool -end) : -sig +end) : sig type key = T.prover_option * (T.coeff Mc.pol * Mc.op1) list + val memo_opt : (unit -> bool) -> string -> (key -> 'a) -> key -> 'a -end = -struct +end = struct module E = struct type t = T.prover_option * (T.coeff Mc.pol * Mc.op1) list diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 2a21049c6e..7774258fca 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -285,7 +285,8 @@ let iter_constr_LR f c = match kind c with | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b | LetIn (_, v, t, b) -> f v; f t; f b | App (cf, a) -> f cf; Array.iter f a - | Case (_, p, iv, v, b) -> f v; iter_invert f iv; f p; Array.iter f b + | Case (_, _, pms, (_, p), iv, v, b) -> + f v; Array.iter f pms; f p; iter_invert f iv; Array.iter (fun (_, c) -> f c) b | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done | Proj(_,a) -> f a @@ -749,7 +750,7 @@ let rec uniquize = function EConstr.push_rel ctx_item env, h' + 1 in let self acc c = EConstr.of_constr (subst_loop acc (EConstr.Unsafe.to_constr c)) in let f = EConstr.of_constr f in - let f' = map_constr_with_binders_left_to_right sigma inc_h self acc f in + let f' = map_constr_with_binders_left_to_right env sigma inc_h self acc f in let f' = EConstr.Unsafe.to_constr f' in mkApp (f', Array.map_left (subst_loop acc) a) in subst_loop (env,h) c) : find_P), diff --git a/plugins/syntax/number.ml b/plugins/syntax/number.ml index 89d757a72a..0e7640f430 100644 --- a/plugins/syntax/number.ml +++ b/plugins/syntax/number.ml @@ -387,10 +387,10 @@ let locate_global_inductive allow_params qid = | Globnames.TrueGlobal _ -> raise Not_found | Globnames.SynDef kn -> match Syntax_def.search_syntactic_definition kn with - | [], Notation_term.(NApp (NRef (GlobRef.IndRef i), l)) when allow_params -> + | [], Notation_term.(NApp (NRef (GlobRef.IndRef i,None), l)) when allow_params -> i, List.map (function - | Notation_term.NRef r -> Some r + | Notation_term.NRef (r,None) -> Some r | Notation_term.NHole _ -> None | _ -> raise Not_found) l | _ -> raise Not_found in diff --git a/pretyping/cases.ml b/pretyping/cases.ml index d2859b1b4e..6370bd4f9a 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1165,17 +1165,16 @@ let rec ungeneralize sigma n ng body = | LetIn (na,b,t,c) -> (* We traverse an alias *) mkLetIn (na,b,t,ungeneralize sigma (n+1) ng c) - | Case (ci,p,iv,c,brs) -> + | Case (ci,u,pms,p,iv,c,brs) -> (* We traverse a split *) let p = - let sign,p = decompose_lam_assum sigma p in + let (nas, p) = p in let sign2,p = decompose_prod_n_assum sigma ng p in - let p = prod_applist sigma p [mkRel (n+List.length sign+ng)] in - it_mkLambda_or_LetIn (it_mkProd_or_LetIn p sign2) sign in - mkCase (ci,p,iv,c,Array.map2 (fun q c -> - let sign,b = decompose_lam_n_decls sigma q c in - it_mkLambda_or_LetIn (ungeneralize sigma (n+q) ng b) sign) - ci.ci_cstr_ndecls brs) + let p = prod_applist sigma p [mkRel (n+Array.length nas+ng)] in + nas, it_mkProd_or_LetIn p sign2 + in + let map (nas, br) = nas, ungeneralize sigma (n + Array.length nas) ng br in + mkCase (ci, u, pms, p, iv, c, Array.map map brs) | App (f,args) -> (* We traverse an inner generalization *) assert (isCase sigma f); @@ -1195,12 +1194,9 @@ let rec is_dependent_generalization sigma ng body = | LetIn (na,b,t,c) -> (* We traverse an alias *) is_dependent_generalization sigma ng c - | Case (ci,p,iv,c,brs) -> + | Case (ci,u,pms,p,iv,c,brs) -> (* We traverse a split *) - Array.exists2 (fun q c -> - let _,b = decompose_lam_n_decls sigma q c in - is_dependent_generalization sigma ng b) - ci.ci_cstr_ndecls brs + Array.exists (fun (_, b) -> is_dependent_generalization sigma ng b) brs | App (g,args) -> (* We traverse an inner generalization *) assert (isCase sigma g); @@ -1759,7 +1755,7 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = let good = List.filter (fun (_,u,_) -> is_conv_leq !!env sigma t u) subst in match good with | [] -> - map_constr_with_full_binders sigma (push_binder sigma) aux x t + map_constr_with_full_binders !!env sigma (push_binder sigma) aux x t | (_, _, u) :: _ -> (* u is in extenv *) let vl = List.map pi1 good in let ty = diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index bada2c3a60..7930c3d634 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -76,8 +76,7 @@ type cbv_value = and cbv_stack = | TOP | APP of cbv_value array * cbv_stack - | CASE of constr * constr array * (constr,Univ.Instance.t) case_invert - * case_info * cbv_value subs * cbv_stack + | CASE of Univ.Instance.t * constr array * case_return * case_branch array * Constr.case_invert * case_info * cbv_value subs * cbv_stack | PROJ of Projection.t * cbv_stack (* les vars pourraient etre des constr, @@ -143,7 +142,7 @@ let rec stack_concat stk1 stk2 = match stk1 with TOP -> stk2 | APP(v,stk1') -> APP(v,stack_concat stk1' stk2) - | CASE(c,b,iv,i,s,stk1') -> CASE(c,b,iv,i,s,stack_concat stk1' stk2) + | CASE(u,pms,c,b,iv,i,s,stk1') -> CASE(u,pms,c,b,iv,i,s,stack_concat stk1' stk2) | PROJ (p,stk1') -> PROJ (p,stack_concat stk1' stk2) (* merge stacks when there is no shifts in between *) @@ -357,9 +356,9 @@ let rec reify_stack t = function | TOP -> t | APP (args,st) -> reify_stack (mkApp(t,Array.map reify_value args)) st - | CASE (ty,br,iv,ci,env,st) -> + | CASE (u,pms,ty,br,iv,ci,env,st) -> reify_stack - (mkCase (ci, ty, iv, t, br)) + (mkCase (ci, u, pms, ty, iv, t,br)) st | PROJ (p, st) -> reify_stack (mkProj (p, t)) st @@ -410,6 +409,29 @@ let rec subs_consn v i n s = if Int.equal i n then s else subs_consn v (i + 1) n (subs_cons v.(i) s) +(* TODO: share the common parts with EConstr *) +let expand_branch env u pms (ind, i) br = + let open Declarations in + let nas, _br = br.(i - 1) in + let (mib, mip) = Inductive.lookup_mind_specif env ind in + let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsubst = Vars.subst_of_rel_context_instance paramdecl (Array.to_list pms) in + let subst = paramsubst @ Inductive.ind_subst (fst ind) mib u in + let (ctx, _) = mip.mind_nf_lc.(i - 1) in + let (ctx, _) = List.chop mip.mind_consnrealdecls.(i - 1) ctx in + Inductive.instantiate_context u subst nas ctx + +let cbv_subst_of_rel_context_instance mkclos sign args env = + let rec aux subst sign l = + let open Context.Rel.Declaration in + match sign, l with + | LocalAssum _ :: sign', a::args' -> aux (subs_cons a subst) sign' args' + | LocalDef (_,c,_)::sign', args' -> + aux (subs_cons (mkclos subst c) subst) sign' args' + | [], [] -> subst + | _ -> CErrors.anomaly (Pp.str "Instance and signature do not match.") + in aux env (List.rev sign) (Array.to_list args) + (* The main recursive functions * * Go under applications and cases/projections (pushed in the stack), @@ -429,7 +451,7 @@ let rec norm_head info env t stack = they could be computed when getting out of the stack *) let nargs = Array.map (cbv_stack_term info TOP env) args in norm_head info env head (stack_app nargs stack) - | Case (ci,p,iv,c,v) -> norm_head info env c (CASE(p,v,iv,ci,env,stack)) + | Case (ci,u,pms,p,iv,c,v) -> norm_head info env c (CASE(u,pms,p,v,iv,ci,env,stack)) | Cast (ct,_,_) -> norm_head info env ct stack | Proj (p, c) -> @@ -557,16 +579,33 @@ and cbv_stack_value info env = function cbv_stack_term info stk envf redfix (* constructor in a Case -> IOTA *) - | (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,iv,ci,env,stk))) + | (CONSTR(((sp,n),_),[||]), APP(args,CASE(u,pms,_p,br,iv,ci,env,stk))) when red_set info.reds fMATCH -> + let nargs = Array.length args - ci.ci_npar in let cargs = - Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in - cbv_stack_term info (stack_app cargs stk) env br.(n-1) + Array.sub args ci.ci_npar nargs in + let env = + if (Int.equal ci.ci_cstr_ndecls.(n - 1) ci.ci_cstr_nargs.(n - 1)) then (* no lets *) + subs_consn cargs 0 nargs env + else + let mkclos env c = cbv_stack_term info TOP env c in + let ctx = expand_branch info.env u pms (sp, n) br in + cbv_subst_of_rel_context_instance mkclos ctx cargs env + in + cbv_stack_term info stk env (snd br.(n-1)) (* constructor of arity 0 in a Case -> IOTA *) - | (CONSTR(((_,n),u),[||]), CASE(_,br,_,_,env,stk)) + | (CONSTR(((sp, n), _),[||]), CASE(u,pms,_,br,_,ci,env,stk)) when red_set info.reds fMATCH -> - cbv_stack_term info stk env br.(n-1) + let env = + if (Int.equal ci.ci_cstr_ndecls.(n - 1) ci.ci_cstr_nargs.(n - 1)) then (* no lets *) + env + else + let mkclos env c = cbv_stack_term info TOP env c in + let ctx = expand_branch info.env u pms (sp, n) br in + cbv_subst_of_rel_context_instance mkclos ctx [||] env + in + cbv_stack_term info stk env (snd br.(n-1)) (* constructor in a Projection -> IOTA *) | (CONSTR(((sp,n),u),[||]), APP(args,PROJ(p,stk))) @@ -640,10 +679,31 @@ let rec apply_stack info t = function | TOP -> t | APP (args,st) -> apply_stack info (mkApp(t,Array.map (cbv_norm_value info) args)) st - | CASE (ty,br,iv,ci,env,st) -> + | CASE (u,pms,ty,br,iv,ci,env,st) -> + (* FIXME: Prevent this expansion by caching whether an inductive contains let-bindings *) + let (_, ty, _, _, br) = Inductive.expand_case info.env (ci, u, pms, ty, iv, mkProp, br) in + let ty = + let (_, mip) = Inductive.lookup_mind_specif info.env ci.ci_ind in + Term.decompose_lam_n_decls (mip.Declarations.mind_nrealdecls + 1) ty + in + let mk_br c n = Term.decompose_lam_n_decls n c in + let br = Array.map2 mk_br br ci.ci_cstr_ndecls in + let map_ctx (nas, c) = + let open Context.Rel.Declaration in + let fold decl e = match decl with + | LocalAssum _ -> subs_lift e + | LocalDef (_, b, _) -> + let b = cbv_stack_term info TOP e b in + (* The let-binding persists, so we have to shift *) + subs_shft (1, subs_cons b e) + in + let env = List.fold_right fold nas env in + let nas = Array.of_list (List.rev_map get_annot nas) in + (nas, cbv_norm_term info env c) + in apply_stack info - (mkCase (ci, cbv_norm_term info env ty, iv, t, - Array.map (cbv_norm_term info env) br)) + (mkCase (ci, u, Array.map (cbv_norm_term info env) pms, map_ctx ty, iv, t, + Array.map map_ctx br)) st | PROJ (p, st) -> apply_stack info (mkProj (p, t)) st diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 409f4c0f70..4d81678200 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -42,8 +42,7 @@ type cbv_value = and cbv_stack = | TOP | APP of cbv_value array * cbv_stack - | CASE of constr * constr array * (constr,Univ.Instance.t) case_invert - * case_info * cbv_value subs * cbv_stack + | CASE of Univ.Instance.t * constr array * case_return * case_branch array * Constr.case_invert * case_info * cbv_value subs * cbv_stack | PROJ of Projection.t * cbv_stack val shift_value : int -> cbv_value -> cbv_value diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 0e69b814c7..c77feeafbb 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -351,7 +351,9 @@ let matches_core env sigma allow_bound_rels sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 - | PIf (a1,b1,b1'), Case (ci,_,_,a2,[|b2;b2'|]) -> + | PIf (a1,b1,b1'), Case (ci, u2, pms2, p2, iv, a2, ([|b2;b2'|] as br2)) -> + let (ci2, p2, _, a2, br2) = EConstr.expand_case env sigma (ci, u2, pms2, p2, iv, a2, br2) in + let b2, b2' = match br2 with [|b2; b2'|] -> b2, b2' | _ -> assert false in let ctx_b2,b2 = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(0) b2 in let ctx_b2',b2' = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(1) b2' in let n = Context.Rel.length ctx_b2 in @@ -367,7 +369,8 @@ let matches_core env sigma allow_bound_rels else raise PatternMatchingFailure - | PCase (ci1,p1,a1,br1), Case (ci2,p2,_,a2,br2) -> + | PCase (ci1, p1, a1, br1), Case (ci2, u2, pms2, p2, iv, a2, br2) -> + let (ci2, p2, _, a2, br2) = EConstr.expand_case env sigma (ci2, u2, pms2, p2, iv, a2, br2) in let n2 = Array.length br2 in let () = match ci1.cip_ind with | None -> () @@ -504,12 +507,30 @@ let sub_match ?(closed=true) env sigma pat c = | [app';c] -> mk_ctx (mkApp (app',[|c|])) | _ -> assert false in try_aux [(env, app); (env, Array.last lc)] mk_ctx next - | Case (ci,hd,iv,c1,lc) -> + | Case (ci,u,pms,hd0,iv,c1,lc0) -> + let (mib, mip) = Inductive.lookup_mind_specif env ci.ci_ind in + let (_, hd, _, _, br) = expand_case env sigma (ci, u, pms, hd0, iv, c1, lc0) in + let hd = + let (ctx, hd) = decompose_lam_assum sigma hd in + (push_rel_context ctx env, hd) + in + let map i br = + let decls = mip.Declarations.mind_consnrealdecls.(i) in + let (ctx, c) = decompose_lam_n_decls sigma decls br in + (push_rel_context ctx env, c) + in + let lc = Array.to_list (Array.mapi map br) in let next_mk_ctx = function - | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,iv,c1,Array.of_list lc)) + | c1 :: rem -> + let pms, rem = List.chop (Array.length pms) rem in + let pms = Array.of_list pms in + let hd, lc = match rem with [] -> assert false | x :: l -> (x, l) in + let hd = (fst hd0, hd) in + let map_br (nas, _) br = (nas, br) in + mk_ctx (mkCase (ci,u,pms,hd,iv,c1,Array.map2 map_br lc0 (Array.of_list lc))) | _ -> assert false in - let sub = (env, c1) :: (env, hd) :: subargs env lc in + let sub = (env, c1) :: Array.fold_right (fun c accu -> (env, c) :: accu) pms (hd :: lc) in try_aux sub next_mk_ctx next | Fix (indx,(names,types,bodies as recdefs)) -> let nb_fix = Array.length types in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 402a6f6ed3..bb5125f5ed 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -8,6 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +module CVars = Vars + open Pp open CErrors open Util @@ -33,6 +35,78 @@ type detyping_flags = { flg_isgoal : bool; } +(** Reimplementation of kernel case expansion functions in more lenient way *) +module RobustExpand : +sig +val return_clause : Environ.env -> Evd.evar_map -> Ind.t -> + EInstance.t -> EConstr.t array -> EConstr.case_return -> rel_context * EConstr.t +val branch : Environ.env -> Evd.evar_map -> Construct.t -> + EInstance.t -> EConstr.t array -> EConstr.case_branch -> rel_context * EConstr.t +end = +struct +open CVars +open Declarations +open Univ +open Constr + +let instantiate_context u subst nas ctx = + let rec instantiate i ctx = match ctx with + | [] -> [] + | LocalAssum (_, ty) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + LocalAssum (nas.(i), ty) :: ctx + | LocalDef (_, ty, bdy) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + let bdy = substnl subst i (subst_instance_constr u bdy) in + LocalDef (nas.(i), ty, bdy) :: ctx + in + let () = if not (Int.equal (Array.length nas) (List.length ctx)) then raise Exit in + instantiate (Array.length nas - 1) ctx + +let return_clause env sigma ind u params (nas, p) = + try + let u = EConstr.Unsafe.to_instance u in + let params = EConstr.Unsafe.to_constr_array params in + let () = if not @@ Environ.mem_mind (fst ind) env then raise Exit in + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + let paramdecl = subst_instance_context u mib.mind_params_ctxt in + let paramsubst = subst_of_rel_context_instance paramdecl (Array.to_list params) in + let realdecls, _ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in + let self = + let args = Context.Rel.to_extended_vect mkRel 0 mip.mind_arity_ctxt in + let inst = Instance.of_array (Array.init (Instance.length u) Level.var) in + mkApp (mkIndU (ind, inst), args) + in + let realdecls = LocalAssum (Context.anonR, self) :: realdecls in + let realdecls = instantiate_context u paramsubst nas realdecls in + List.map EConstr.of_rel_decl realdecls, p + with e when CErrors.noncritical e -> + let dummy na = LocalAssum (na, EConstr.mkProp) in + List.rev (Array.map_to_list dummy nas), p + +let branch env sigma (ind, i) u params (nas, br) = + try + let u = EConstr.Unsafe.to_instance u in + let params = EConstr.Unsafe.to_constr_array params in + let () = if not @@ Environ.mem_mind (fst ind) env then raise Exit in + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + let paramdecl = subst_instance_context u mib.mind_params_ctxt in + let paramsubst = subst_of_rel_context_instance paramdecl (Array.to_list params) in + let subst = paramsubst @ Inductive.ind_subst (fst ind) mib u in + let (ctx, _) = mip.mind_nf_lc.(i - 1) in + let ctx, _ = List.chop mip.mind_consnrealdecls.(i - 1) ctx in + let ctx = instantiate_context u subst nas ctx in + List.map EConstr.of_rel_decl ctx, br + with e when CErrors.noncritical e -> + let dummy na = LocalAssum (na, EConstr.mkProp) in + List.rev (Array.map_to_list dummy nas), br + +end + module Avoid : sig type t @@ -241,16 +315,9 @@ let print_primproj_params = (* Auxiliary function for MutCase printing *) (* [computable] tries to tell if the predicate typing the result is inferable*) -let computable sigma p k = +let computable sigma (nas, ccl) = (* We first remove as many lambda as the arity, then we look - if it remains a lambda for a dependent elimination. This function - works for normal eta-expanded term. For non eta-expanded or - non-normal terms, it may affirm the pred is synthetisable - because of an undetected ultimate dependent variable in the second - clause, or else, it may affirm the pred non synthetisable - because of a non normal term in the fourth clause. - A solution could be to store, in the MutCase, the eta-expanded - normal form of pred to decide if it depends on its variables + if it remains a lambda for a dependent elimination. Lorsque le prédicat est dépendant de manière certaine, on ne déclare pas le prédicat synthétisable (même si la @@ -258,10 +325,7 @@ let computable sigma p k = sinon on perd la réciprocité de la synthèse (qui, lui, engendrera un prédicat non dépendant) *) - let sign,ccl = decompose_lam_assum sigma p in - Int.equal (Context.Rel.length sign) (k + 1) - && - noccur_between sigma 1 (k+1) ccl + noccur_between sigma 1 (Array.length nas) ccl let lookup_name_as_displayed env sigma t s = let rec lookup avoid n c = match EConstr.kind sigma c with @@ -393,30 +457,27 @@ let update_name sigma na ((_,(e,_)),c) = | _ -> na -let get_domain env sigma c = - let (_,t,_) = EConstr.destProd sigma (Reductionops.whd_all env sigma (Retyping.get_type_of env sigma c)) in - t - -let rec decomp_branch tags nal flags (avoid,env as e) sigma c = - match tags with - | [] -> (List.rev nal,(e,c)) - | b::tags -> +let decomp_branch flags e sigma (ctx, c) = + let n = List.length ctx in + let rec aux i nal (avoid, env as e) c = + if Int.equal i 0 then (List.rev nal,(e,c)) + else let decl, c, let_in = - match EConstr.kind sigma (strip_outer_cast sigma c), b with - | Lambda (na,t,c),false -> LocalAssum (na,t), c, true - | LetIn (na,b,t,c),true -> LocalDef (na,b,t), c, false - | _, false -> - let na = make_annot (Name default_dependent_ident) Sorts.Relevant (* dummy *) in - LocalAssum (na, get_domain (snd env) sigma c), applist (lift 1 c, [mkRel 1]), false - | _, true -> - let na = make_annot Anonymous Sorts.Relevant (* dummy *) in - LocalDef (na, mkProp (* dummy *), type1), lift 1 c, false + match EConstr.kind sigma c with + | Lambda (na,t,c) -> LocalAssum (na,t), c, true + | LetIn (na,b,t,c) -> LocalDef (na,b,t), c, false + | _ -> assert false in let na',avoid' = compute_name sigma ~let_in ~pattern:true flags avoid env (get_name decl) c in - decomp_branch tags (na'::nal) flags - (avoid', add_name (set_name na' decl) env) sigma c + aux (i - 1) (na'::nal) (avoid', add_name (set_name na' decl) env) c + in + aux n [] e (EConstr.it_mkLambda_or_LetIn c ctx) -let rec build_tree na isgoal e sigma ci cl = +let rec build_tree na isgoal e sigma (ci, u, pms, cl) = + let map i br = + RobustExpand.branch (snd (snd e)) sigma (ci.ci_ind, i + 1) u pms br + in + let cl = Array.mapi map cl in let mkpat n rhs pl = let na = update_name sigma na rhs in na, DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,na) in @@ -429,12 +490,12 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with | [] -> [Id.Set.empty,[],rhs] | na::nal -> match EConstr.kind sigma c with - | Case (ci,p,iv,c,cl) when + | Case (ci,u,pms,p,iv,c,cl) when eq_constr sigma c (mkRel (List.index Name.equal na (fst (snd e)))) && not (Int.equal (Array.length cl) 0) && (* don't contract if p dependent *) - computable sigma p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> - let clauses = build_tree na isgoal e sigma ci cl in + computable sigma p (* FIXME: can do better *) -> + let clauses = build_tree na isgoal e sigma (ci, u, pms, cl) in List.flatten (List.map (fun (ids,pat,rhs) -> let lines = align_tree nal isgoal rhs sigma in @@ -447,7 +508,7 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with List.map (fun (ids,hd,rest) -> Nameops.Name.fold_right Id.Set.add na ids,pat::hd,rest) mat and contract_branch isgoal e sigma (cdn,mkpat,rhs) = - let nal,rhs = decomp_branch cdn [] isgoal e sigma rhs in + let nal,rhs = decomp_branch isgoal e sigma rhs in let mat = align_tree nal isgoal rhs sigma in List.map (fun (ids,hd,rhs) -> let na, pat = mkpat rhs hd in @@ -457,15 +518,10 @@ and contract_branch isgoal e sigma (cdn,mkpat,rhs) = (* Transform internal representation of pattern-matching into list of *) (* clauses *) -let is_nondep_branch sigma c l = - try - (* FIXME: do better using tags from l *) - let sign,ccl = decompose_lam_n_decls sigma (List.length l) c in - noccur_between sigma 1 (Context.Rel.length sign) ccl - with e when CErrors.noncritical e -> (* Not eta-expanded or not reduced *) - false +let is_nondep_branch sigma (nas, ccl) = + noccur_between sigma 1 (Array.length nas) ccl -let extract_nondep_branches test c b l = +let extract_nondep_branches b l = let rec strip l r = match DAst.get r, l with | r', [] -> r @@ -473,7 +529,7 @@ let extract_nondep_branches test c b l = | GLetIn (_,_,_,t), true::l -> strip l t (* FIXME: do we need adjustment? *) | _,_ -> assert false in - if test c l then Some (strip l b) else None + strip l b let it_destRLambda_or_LetIn_names l c = let rec aux l nal c = @@ -498,13 +554,14 @@ let it_destRLambda_or_LetIn_names l c = | _ -> DAst.make @@ GApp (c,[a])) in aux l [] c -let detype_case computable detype detype_eqns testdep avoid ci p iv c bl = +let detype_case computable detype detype_eqns avoid env sigma (ci, univs, params, p, iv, c, bl) = let synth_type = synthetize_type () in let tomatch = detype c in let tomatch = match iv with | NoInvert -> tomatch - | CaseInvert {univs;args} -> - let t = mkApp (mkIndU (ci.ci_ind,univs), args) in + | CaseInvert {indices} -> + (* XXX use holes instead of params? *) + let t = mkApp (mkIndU (ci.ci_ind,univs), Array.append params indices) in DAst.make @@ GCast (tomatch, CastConv (detype t)) in let alias, aliastyp, pred= @@ -512,6 +569,8 @@ let detype_case computable detype detype_eqns testdep avoid ci p iv c bl = then Anonymous, None, None else + let (ctx, p) = RobustExpand.return_clause (snd env) sigma ci.ci_ind univs params p in + let p = EConstr.it_mkLambda_or_LetIn p ctx in let p = detype p in let nl,typ = it_destRLambda_or_LetIn_names ci.ci_pp_info.ind_tags p in let n,typ = match DAst.get typ with @@ -540,21 +599,29 @@ let detype_case computable detype detype_eqns testdep avoid ci p iv c bl = let constagsl = ci.ci_pp_info.cstr_tags in match tag, aliastyp with | LetStyle, None -> + let map i br = + let (ctx, body) = RobustExpand.branch (snd env) sigma (ci.ci_ind, i + 1) univs params br in + EConstr.it_mkLambda_or_LetIn body ctx + in + let bl = Array.mapi map bl in let bl' = Array.map detype bl in let (nal,d) = it_destRLambda_or_LetIn_names constagsl.(0) bl'.(0) in GLetTuple (nal,(alias,pred),tomatch,d) | IfStyle, None -> - let bl' = Array.map detype bl in - let nondepbrs = - Array.map3 (extract_nondep_branches testdep) bl bl' constagsl in - if Array.for_all ((!=) None) nondepbrs then - GIf (tomatch,(alias,pred), - Option.get nondepbrs.(0),Option.get nondepbrs.(1)) + if Array.for_all (fun br -> is_nondep_branch sigma br) bl then + let map i br = + let ctx, body = RobustExpand.branch (snd env) sigma (ci.ci_ind, i + 1) univs params br in + EConstr.it_mkLambda_or_LetIn body ctx + in + let bl = Array.mapi map bl in + let bl' = Array.map detype bl in + let nondepbrs = Array.map2 extract_nondep_branches bl' constagsl in + GIf (tomatch,(alias,pred), nondepbrs.(0), nondepbrs.(1)) else - let eqnl = detype_eqns constructs constagsl bl in + let eqnl = detype_eqns constructs constagsl (ci, univs, params, bl) in GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) | _ -> - let eqnl = detype_eqns constructs constagsl bl in + let eqnl = detype_eqns constructs constagsl (ci, univs, params, bl) in GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) let rec share_names detype flags n l avoid env sigma c t = @@ -788,12 +855,12 @@ and detype_r d flags avoid env sigma t = GRef (GlobRef.IndRef ind_sp, detype_instance sigma u) | Construct (cstr_sp,u) -> GRef (GlobRef.ConstructRef cstr_sp, detype_instance sigma u) - | Case (ci,p,iv,c,bl) -> - let comp = computable sigma p (List.length (ci.ci_pp_info.ind_tags)) in + | Case (ci,u,pms,p,iv,c,bl) -> + let comp = computable sigma p in + let case = (ci, u, pms, p, iv, c, bl) in detype_case comp (detype d flags avoid env sigma) - (detype_eqns d flags avoid env sigma ci comp) - (is_nondep_branch sigma) avoid - ci p iv c bl + (detype_eqns d flags avoid env sigma comp) + avoid env sigma case | Fix (nvn,recdef) -> detype_fix (detype d) flags avoid env sigma nvn recdef | CoFix (n,recdef) -> detype_cofix (detype d) flags avoid env sigma n recdef | Int i -> GInt i @@ -805,18 +872,21 @@ and detype_r d flags avoid env sigma t = let u = detype_instance sigma u in GArray(u, t, def, ty) -and detype_eqns d flags avoid env sigma ci computable constructs consnargsl bl = +and detype_eqns d flags avoid env sigma computable constructs consnargsl bl = try if !Flags.raw_print || not (reverse_matching ()) then raise Exit; - let mat = build_tree Anonymous flags (avoid,env) sigma ci bl in + let mat = build_tree Anonymous flags (avoid,env) sigma bl in List.map (fun (ids,pat,((avoid,env),c)) -> CAst.make (Id.Set.elements ids,[pat],detype d flags avoid env sigma c)) mat with e when CErrors.noncritical e -> + let (ci, u, pms, bl) = bl in Array.to_list - (Array.map3 (detype_eqn d flags avoid env sigma) constructs consnargsl bl) + (Array.map3 (detype_eqn d flags avoid env sigma u pms) constructs consnargsl bl) -and detype_eqn d flags avoid env sigma constr construct_nargs branch = +and detype_eqn d flags avoid env sigma u pms constr construct_nargs br = + let ctx, body = RobustExpand.branch (snd env) sigma constr u pms br in + let branch = EConstr.it_mkLambda_or_LetIn body ctx in let make_pat decl avoid env b ids = if force_wildcard () && noccurn sigma 1 b then DAst.make @@ PatVar Anonymous,avoid,(add_name (set_name Anonymous decl) env),ids @@ -824,39 +894,24 @@ and detype_eqn d flags avoid env sigma constr construct_nargs branch = let na,avoid' = compute_name sigma ~let_in:false ~pattern:true flags avoid env (get_name decl) b in DAst.make (PatVar na),avoid',(add_name (set_name na decl) env),add_vname ids na in - let rec buildrec ids patlist avoid env l b = - match EConstr.kind sigma b, l with - | _, [] -> CAst.make @@ + let rec buildrec ids patlist avoid env n b = + if Int.equal n 0 then + CAst.make @@ (Id.Set.elements ids, [DAst.make @@ PatCstr(constr, List.rev patlist,Anonymous)], detype d flags avoid env sigma b) - | Lambda (x,t,b), false::l -> + else match EConstr.kind sigma b with + | Lambda (x,t,b) -> let pat,new_avoid,new_env,new_ids = make_pat (LocalAssum (x,t)) avoid env b ids in - buildrec new_ids (pat::patlist) new_avoid new_env l b + buildrec new_ids (pat::patlist) new_avoid new_env (pred n) b - | LetIn (x,b,t,b'), true::l -> + | LetIn (x,b,t,b') -> let pat,new_avoid,new_env,new_ids = make_pat (LocalDef (x,b,t)) avoid env b' ids in - buildrec new_ids (pat::patlist) new_avoid new_env l b' - - | Cast (c,_,_), l -> (* Oui, il y a parfois des cast *) - buildrec ids patlist avoid env l c - - | _, true::l -> - let pat = DAst.make @@ PatVar Anonymous in - buildrec ids (pat::patlist) avoid env l b - - | _, false::l -> - (* eta-expansion : n'arrivera plus lorsque tous les - termes seront construits à partir de la syntaxe Cases *) - (* nommage de la nouvelle variable *) - let new_b = applist (lift 1 b, [mkRel 1]) in - let typ = get_domain (snd env) sigma b in - let pat,new_avoid,new_env,new_ids = - make_pat (LocalAssum (make_annot Anonymous Sorts.Relevant (* dummy *),typ)) avoid env new_b ids in - buildrec new_ids (pat::patlist) new_avoid new_env l new_b + buildrec new_ids (pat::patlist) new_avoid new_env (pred n) b' + | _ -> assert false in - buildrec Id.Set.empty [] avoid env construct_nargs branch + buildrec Id.Set.empty [] avoid env (List.length ctx) branch and detype_binder d flags bk avoid env sigma decl c = let na = get_name decl in diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 4b0974ae03..990e84e5a7 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -206,7 +206,7 @@ let occur_rigidly flags env evd (evk,_) t = if rigid_normal_occ b' || rigid_normal_occ t' then Rigid true else Reducible | Rel _ | Var _ -> Reducible - | Case (_,_,_,c,_) -> + | Case (_,_,_,_,_,c,_) -> (match aux c with | Rigid b -> Rigid b | _ -> Reducible) @@ -381,7 +381,10 @@ let rec ise_stack2 no_app env evd f sk1 sk2 = else None, x in match revsk1, revsk2 with | [], [] -> None, Success i - | Stack.Case (_,t1,_,c1)::q1, Stack.Case (_,t2,_,c2)::q2 -> + | Stack.Case (ci1,u1,pms1,t1,iv1,c1)::q1, Stack.Case (ci2,u2,pms2,t2,iv2,c2)::q2 -> + let dummy = mkProp in + let (_, t1, _, _, c1) = EConstr.expand_case env evd (ci1,u1,pms1,t1,iv1,dummy,c1) in + let (_, t2, _, _, c2) = EConstr.expand_case env evd (ci2,u2,pms2,t2,iv2,dummy,c2) in begin match ise_and i [ (fun i -> f env i CONV t1 t2); @@ -418,7 +421,10 @@ let rec exact_ise_stack2 env evd f sk1 sk2 = let rec ise_rev_stack2 i revsk1 revsk2 = match revsk1, revsk2 with | [], [] -> Success i - | Stack.Case (_,t1,_,c1)::q1, Stack.Case (_,t2,_,c2)::q2 -> + | Stack.Case (ci1,u1,pms1,t1,iv1,c1)::q1, Stack.Case (ci2,u2,pms2,t2,iv2,c2)::q2 -> + let dummy = mkProp in + let (_, t1, _, _, c1) = EConstr.expand_case env evd (ci1,u1,pms1,t1,iv1,dummy,c1) in + let (_, t2, _, _, c2) = EConstr.expand_case env evd (ci2,u2,pms2,t2,iv2,dummy,c2) in ise_and i [ (fun i -> ise_rev_stack2 i q1 q2); (fun i -> ise_array2 i (fun ii -> f env ii CONV) c1 c2); @@ -1278,7 +1284,7 @@ let apply_on_subterm env evd fixed f test c t = if occur_evars !evdref !fixedref t then match EConstr.kind !evdref t with | Evar (ev, args) when Evar.Set.mem ev !fixedref -> t - | _ -> map_constr_with_binders_left_to_right !evdref + | _ -> map_constr_with_binders_left_to_right env !evdref (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t else @@ -1293,7 +1299,7 @@ let apply_on_subterm env evd fixed f test c t = evdref := evd'; t') else ( if debug_ho_unification () then Feedback.msg_debug (Pp.str "failed"); - map_constr_with_binders_left_to_right !evdref + map_constr_with_binders_left_to_right env !evdref (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t)) in @@ -1383,7 +1389,7 @@ let thin_evars env sigma sign c = if not (Id.Set.mem id ctx) then raise (TypingFailed !sigma) else t | _ -> - map_constr_with_binders_left_to_right !sigma + map_constr_with_binders_left_to_right env !sigma (fun d (env,acc) -> (push_rel d env, acc+1)) applyrec (env,acc) t in diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index f9f6f74a66..cb3eef9df0 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -232,7 +232,7 @@ let recheck_applications unify flags env evdref t = else () in aux 0 fty | _ -> - iter_with_full_binders !evdref (fun d env -> push_rel d env) aux env t + iter_with_full_binders env !evdref (fun d env -> push_rel d env) aux env t in aux env t @@ -304,7 +304,7 @@ let noccur_evar env evd evk c = | LocalAssum _ -> () | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i (EConstr.of_constr b))) | Proj (p,c) -> occur_rec true acc c - | _ -> iter_with_full_binders evd (fun rd (k,env) -> (succ k, push_rel rd env)) + | _ -> iter_with_full_binders env evd (fun rd (k,env) -> (succ k, push_rel rd env)) (occur_rec check_types) acc c in try occur_rec false (0,env) c; true with Occur -> false @@ -490,14 +490,14 @@ let expansion_of_var sigma aliases x = | Some a, _ -> (true, Alias.repr sigma a) | None, a :: _ -> (true, Some a) -let rec expand_vars_in_term_using sigma aliases t = match EConstr.kind sigma t with +let rec expand_vars_in_term_using env sigma aliases t = match EConstr.kind sigma t with | Rel n -> of_alias (normalize_alias sigma aliases (RelAlias n)) | Var id -> of_alias (normalize_alias sigma aliases (VarAlias id)) | _ -> - let self aliases c = expand_vars_in_term_using sigma aliases c in - map_constr_with_full_binders sigma (extend_alias sigma) self aliases t + let self aliases c = expand_vars_in_term_using env sigma aliases c in + map_constr_with_full_binders env sigma (extend_alias sigma) self aliases t -let expand_vars_in_term env sigma = expand_vars_in_term_using sigma (make_alias_map env sigma) +let expand_vars_in_term env sigma = expand_vars_in_term_using env sigma (make_alias_map env sigma) let free_vars_and_rels_up_alias_expansion env sigma aliases c = let acc1 = ref Int.Set.empty and acc2 = ref Id.Set.empty in @@ -533,7 +533,7 @@ let free_vars_and_rels_up_alias_expansion env sigma aliases c = | Const _ | Ind _ | Construct _ -> acc2 := Id.Set.union (vars_of_global env (fst @@ EConstr.destRef sigma c)) !acc2 | _ -> - iter_with_full_binders sigma + iter_with_full_binders env sigma (fun d (aliases,depth) -> (extend_alias sigma d aliases,depth+1)) frec (aliases,depth) c in @@ -1645,7 +1645,7 @@ let rec invert_definition unify flags choose imitate_defs let candidates = try let t = - map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) + map_constr_with_full_binders env' !evdref (fun d (env,k) -> push_rel d env, k+1) imitate envk t in (* Less dependent solutions come last *) l@[t] @@ -1659,7 +1659,7 @@ let rec invert_definition unify flags choose imitate_defs evar'') | None -> (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *) - map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) + map_constr_with_full_binders env' !evdref (fun d (env,k) -> push_rel d env, k+1) imitate envk t in let rhs = whd_beta env evd rhs (* heuristic *) in diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 52e3364109..9f84b7683f 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -73,7 +73,7 @@ type 'a testing_function = { (b,l), b=true means no occurrence except the ones in l and b=false, means all occurrences except the ones in l *) -let replace_term_occ_gen_modulo sigma occs like_first test bywhat cl occ t = +let replace_term_occ_gen_modulo env sigma occs like_first test bywhat cl occ t = let count = ref (Locusops.initialize_occurrence_counter occs) in let nested = ref false in let add_subst pos t subst = @@ -107,23 +107,23 @@ let replace_term_occ_gen_modulo sigma occs like_first test bywhat cl occ t = with NotUnifiable _ -> subst_below k t and subst_below k t = - map_constr_with_binders_left_to_right sigma (fun d k -> k+1) substrec k t + map_constr_with_binders_left_to_right env sigma (fun d k -> k+1) substrec k t in let t' = substrec 0 t in (!count, t') -let replace_term_occ_modulo evd occs test bywhat t = +let replace_term_occ_modulo env evd occs test bywhat t = let occs',like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> AllOccurrences,true in proceed_with_occurrences - (replace_term_occ_gen_modulo evd occs' like_first test bywhat None) occs' t + (replace_term_occ_gen_modulo env evd occs' like_first test bywhat None) occs' t -let replace_term_occ_decl_modulo evd occs test bywhat d = +let replace_term_occ_decl_modulo env evd occs test bywhat d = let (plocs,hyploc),like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in proceed_with_occurrences (map_named_declaration_with_hyploc - (replace_term_occ_gen_modulo evd plocs like_first test bywhat) + (replace_term_occ_gen_modulo env evd plocs like_first test bywhat) hyploc) plocs d @@ -145,7 +145,7 @@ let make_eq_univs_test env evd c = let subst_closed_term_occ env evd occs c t = let test = make_eq_univs_test env evd c in let bywhat () = mkRel 1 in - let t' = replace_term_occ_modulo evd occs test bywhat t in + let t' = replace_term_occ_modulo env evd occs test bywhat t in t', test.testing_state let subst_closed_term_occ_decl env evd occs c d = @@ -155,6 +155,6 @@ let subst_closed_term_occ_decl env evd occs c d = let bywhat () = mkRel 1 in proceed_with_occurrences (map_named_declaration_with_hyploc - (fun _ -> replace_term_occ_gen_modulo evd plocs like_first test bywhat None) + (fun _ -> replace_term_occ_gen_modulo env evd plocs like_first test bywhat None) hyploc) plocs d, test.testing_state diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 1ddae01e2b..c71cb207ab 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -43,13 +43,13 @@ val make_eq_univs_test : env -> evar_map -> constr -> evar_map testing_function matching subterms at the indicated occurrences [occl] with [mk ()]; it turns a NotUnifiable exception raised by the testing function into a SubtermUnificationError. *) -val replace_term_occ_modulo : evar_map -> occurrences or_like_first -> +val replace_term_occ_modulo : env -> evar_map -> occurrences or_like_first -> 'a testing_function -> (unit -> constr) -> constr -> constr (** [replace_term_occ_decl_modulo] is similar to [replace_term_occ_modulo] but for a named_declaration. *) val replace_term_occ_decl_modulo : - evar_map -> + env -> evar_map -> (occurrences * hyp_location_flag) or_like_first -> 'a testing_function -> (unit -> constr) -> named_declaration -> named_declaration diff --git a/pretyping/heads.ml b/pretyping/heads.ml index a012f1cb15..f6e45613e1 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -76,7 +76,7 @@ and kind_of_head env t = | App (c,al) -> aux k (Array.to_list al @ l) c b | Proj (p,c) -> RigidHead RigidOther - | Case (_,_,_,c,_) -> aux k [] c true + | Case (_,_,_,_,_,c,_) -> aux k [] c true | Int _ | Float _ | Array _ -> ConstructorHead | Fix ((i,j),_) -> let n = i.(j) in diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 5ffd919312..dd7cf8abaa 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -122,12 +122,24 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = | None -> let iv = make_case_invert env (find_rectype env sigma (EConstr.of_constr (lift 1 depind))) ci in let iv = EConstr.Unsafe.to_case_invert iv in - mkCase (ci, lift ndepar p, iv, mkRel 1, Termops.rel_vect ndepar k) + let ncons = Array.length mip.mind_consnames in + let mk_branch i = + (* eta-expansion to please branch contraction *) + let ft = get_type (lookup_rel (ncons - i) env) in + (* we need that to get the generated names for the branch *) + let (ctx, _) = decompose_prod_assum ft in + let n = mkRel (List.length ctx + 1) in + let args = Context.Rel.to_extended_vect mkRel 0 ctx in + let br = it_mkLambda_or_LetIn (mkApp (n, args)) ctx in + lift (ndepar + ncons - i - 1) br + in + let br = Array.init ncons mk_branch in + mkCase (Inductive.contract_case env (ci, lift ndepar p, iv, mkRel 1, br)) | Some ps -> let term = mkApp (mkRel 2, - Array.map - (fun p -> mkProj (Projection.make p true, mkRel 1)) ps) in + Array.map + (fun p -> mkProj (Projection.make p true, mkRel 1)) ps) in if dep then let ty = mkApp (mkRel 3, [| mkRel 1 |]) in mkCast (term, DEFAULTcast, ty) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index bd875cf68b..d02b015604 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -344,11 +344,7 @@ let get_projections = Environ.get_projections let make_case_invert env (IndType (((ind,u),params),indices)) ci = if Typeops.should_invert_case env ci - then - let univs = EConstr.EInstance.make u in - let params = Array.map_of_list EConstr.of_constr params in - let args = Array.append params (Array.of_list indices) in - CaseInvert {univs;args} + then CaseInvert {indices=Array.of_list indices} else NoInvert let make_case_or_project env sigma indt ci pred c branches = @@ -356,8 +352,7 @@ let make_case_or_project env sigma indt ci pred c branches = let IndType (((ind,_),_),_) = indt in let projs = get_projections env ind in match projs with - | None -> - mkCase (ci, pred, make_case_invert env indt ci, c, branches) + | None -> (mkCase (EConstr.contract_case env sigma (ci, pred, make_case_invert env indt ci, c, branches))) | Some ps -> assert(Array.length branches == 1); let na, ty, t = destLambda sigma pred in @@ -749,6 +744,6 @@ let control_only_guard env sigma c = in let rec iter env c = check_fix_cofix env c; - EConstr.iter_with_full_binders sigma EConstr.push_rel iter env c + EConstr.iter_with_full_binders env sigma EConstr.push_rel iter env c in iter env c diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 3705d39280..8e83814fa0 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -213,7 +213,7 @@ val make_case_or_project : (* pred *) EConstr.constr -> (* term *) EConstr.constr -> (* branches *) EConstr.constr array -> EConstr.constr val make_case_invert : env -> inductive_type -> case_info - -> (EConstr.constr,EConstr.EInstance.t) case_invert + -> EConstr.case_invert (*i Compatibility val make_default_case_info : env -> case_style -> inductive -> case_info diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index d06d6e01d1..92e412a537 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -320,13 +320,13 @@ and nf_atom_type env sigma atom = | 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 - let iv = if Typeops.should_invert_case env ans.asw_ci then - CaseInvert {univs=u; args=allargs} - else NoInvert - in let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let params,realargs = Array.chop nparams allargs in + let iv = if Typeops.should_invert_case env ans.asw_ci then + CaseInvert {indices=realargs} + else NoInvert + in let nparamdecls = Context.Rel.length (Inductive.inductive_paramdecls (mib,u)) in let pT = hnf_prod_applist_assum env nparamdecls @@ -343,7 +343,8 @@ and nf_atom_type env sigma atom = in let branchs = Array.mapi mkbranch bsw in let tcase = build_case_type p realargs a in - mkCase(ans.asw_ci, p, iv, a, branchs), tcase + let ci = ans.asw_ci in + mkCase (Inductive.contract_case env (ci, p, iv, a, branchs)), tcase | Afix(tt,ft,rp,s) -> let tt = Array.map (fun t -> nf_type_sort env sigma t) tt in let tt = Array.map fst tt and rt = Array.map snd tt in diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index b259945d9e..47097a0e32 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -202,7 +202,8 @@ let pattern_of_constr env sigma t = | Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar ido) -> assert false | _ -> PMeta None) - | Case (ci,p,_,a,br) -> + | Case (ci, u, pms, p, iv, a, br) -> + let (ci, p, iv, a, br) = Inductive.expand_case env (ci, u, pms, p, iv, a, br) in let cip = { cip_style = ci.ci_pp_info.style; cip_ind = Some ci.ci_ind; @@ -213,7 +214,7 @@ let pattern_of_constr env sigma t = (i, ci.ci_pp_info.cstr_tags.(i), pattern_of_constr env c) in PCase (cip, pattern_of_constr env p, pattern_of_constr env a, - Array.to_list (Array.mapi branch_of_constr br)) + Array.to_list (Array.mapi branch_of_constr br)) | Fix (lni,(lna,tl,bl)) -> let push env na2 c2 = push_rel (LocalAssum (na2,c2)) env in let env' = Array.fold_left2 push env lna tl in diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 9dbded75ba..e86a8a28c9 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -1043,7 +1043,7 @@ struct if not record then let f = it_mkLambda_or_LetIn f fsign in let ci = make_case_info !!env (ind_of_ind_type indt) rci LetStyle in - mkCase (ci, p, make_case_invert !!env indt ci, cj.uj_val,[|f|]) + mkCase (EConstr.contract_case !!env sigma (ci, p, make_case_invert !!env indt ci, cj.uj_val,[|f|])) else it_mkLambda_or_LetIn f fsign in (* Make dependencies from arity signature impossible *) @@ -1159,7 +1159,7 @@ struct let pred = nf_evar sigma pred in let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val pred in let ci = make_case_info !!env (fst ind) rci IfStyle in - mkCase (ci, pred, make_case_invert !!env indty ci, cj.uj_val, [|b1;b2|]) + mkCase (EConstr.contract_case !!env sigma (ci, pred, make_case_invert !!env indty ci, cj.uj_val, [|b1;b2|])) in let cj = { uj_val = v; uj_type = p } in discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma cj tycon diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 52f60fbc5e..3da75f67b9 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -177,9 +177,12 @@ sig type 'a app_node val pr_app_node : ('a -> Pp.t) -> 'a app_node -> Pp.t + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array + type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array + | Case of 'a case_stk | Proj of Projection.t | Fix of ('a, 'a) pfixpoint * 'a t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red @@ -230,9 +233,12 @@ struct ) + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array + type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array + | Case of 'a case_stk | Proj of Projection.t | Fix of ('a, 'a) pfixpoint * 'a t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red @@ -245,9 +251,9 @@ struct let pr_c x = hov 1 (pr_c x) in match member with | App app -> str "ZApp" ++ pr_app_node pr_c app - | Case (_,_,_,br) -> + | Case (_,_,_,_,_,br) -> str "ZCase(" ++ - prvect_with_sep (pr_bar) pr_c br + prvect_with_sep (pr_bar) (fun (_, c) -> pr_c c) br ++ str ")" | Proj p -> str "ZProj(" ++ Constant.debug_print (Projection.constant p) ++ str ")" @@ -284,7 +290,7 @@ struct ([],[]) -> Int.equal bal 0 | (App (i,_,j)::s1, _) -> compare_rec (bal + j + 1 - i) s1 stk2 | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 - | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> + | (Case _ :: s1, Case _::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Proj (p)::s1, Proj(p2)::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 @@ -304,8 +310,9 @@ struct let t1,l1 = decomp_node_last n1 q1 in let t2,l2 = decomp_node_last n2 q2 in aux (f o t1 t2) l1 l2 - | Case (_,t1,_,a1) :: q1, Case (_,t2,_,a2) :: q2 -> - aux (Array.fold_left2 f (f o t1 t2) a1 a2) q1 q2 + | Case ((_,_,pms1,(_, t1),_,a1)) :: q1, Case ((_,_,pms2, (_, t2),_,a2)) :: q2 -> + let f' o (_, t1) (_, t2) = f o t1 t2 in + aux (Array.fold_left2 f' (f (Array.fold_left2 f o pms1 pms2) t1 t2) a1 a2) q1 q2 | Proj (p1) :: q1, Proj (p2) :: q2 -> aux o q1 q2 | Fix ((_,(_,a1,b1)),s1) :: q1, Fix ((_,(_,a2,b2)),s2) :: q2 -> @@ -320,8 +327,8 @@ struct | App (i,a,j) -> let le = j - i + 1 in App (0,Array.map f (Array.sub a i le), le-1) - | Case (info,ty,iv,br) -> - Case (info, f ty, map_invert f iv, Array.map f br) + | Case (info,u,pms,ty,iv,br) -> + Case (info, u, Array.map f pms, on_snd f ty, iv, Array.map (on_snd f) br) | Fix ((r,(na,ty,bo)),arg) -> Fix ((r,(na,Array.map f ty, Array.map f bo)),map f arg) | Primitive (p,c,args,kargs) -> @@ -408,7 +415,7 @@ struct then a else Array.sub a i (j - i + 1) in zip (mkApp (f, a'), s) - | f, (Case (ci,rt,iv,br)::s) -> zip (mkCase (ci,rt,iv,f,br), s) + | f, (Case (ci,u,pms,rt,iv,br)::s) -> zip (mkCase (ci,u,pms,rt,iv,f,br), s) | f, (Fix (fix,st)::s) -> zip (mkFix fix, st @ (append_app [|f|] s)) | f, (Proj (p)::s) -> zip (mkProj (p,f),s) @@ -469,13 +476,13 @@ let strong_with_flags whdfun flags env sigma t = | d -> d in push_rel d env in let rec strongrec env t = - map_constr_with_full_binders sigma + map_constr_with_full_binders env sigma push_rel_check_zeta strongrec env (whdfun flags env sigma t) in strongrec env t let strong whdfun env sigma t = let rec strongrec env t = - map_constr_with_full_binders sigma push_rel strongrec env (whdfun env sigma t) in + map_constr_with_full_binders env sigma push_rel strongrec env (whdfun env sigma t) in strongrec env t (*************************************) @@ -702,6 +709,20 @@ let debug_RAKAM = ~key:["Debug";"RAKAM"] ~value:false +let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = + let args = Stack.tail ci.ci_npar args in + let args = Option.get (Stack.list_of_app_stack args) in + let br = lf.(i - 1) in + if Int.equal ci.ci_cstr_nargs.(i - 1) ci.ci_cstr_ndecls.(i - 1) then + (* No let-bindings *) + let subst = List.rev args in + Vars.substl subst (snd br) + else + (* For backwards compat with unification, we do not reduce the let-bindings + upfront. *) + let ctx = expand_branch env sigma u pms (ind, i) br in + applist (it_mkLambda_or_LetIn (snd br) ctx, args) + let rec whd_state_gen flags env sigma = let open Context.Named.Declaration in let rec whrec (x, stack) : state = @@ -785,8 +806,8 @@ let rec whd_state_gen flags env sigma = | _ -> fold ()) | _ -> fold ()) - | Case (ci,p,iv,d,lf) -> - whrec (d, Stack.Case (ci,p,iv,lf) :: stack) + | Case (ci,u,pms,p,iv,d,lf) -> + whrec (d, Stack.Case (ci,u,pms,p,iv,lf) :: stack) | Fix ((ri,n),_ as f) -> (match Stack.strip_n_app ri.(n) stack with @@ -794,13 +815,14 @@ let rec whd_state_gen flags env sigma = |Some (bef,arg,s') -> whrec (arg, Stack.Fix(f,bef)::s')) - | Construct ((ind,c),u) -> + | Construct (cstr ,u) -> let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, _, lf)::s') when use_match -> - whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Case case::s') when use_match -> + let r = apply_branch env sigma cstr args case in + whrec (r, s') |args, (Stack.Proj (p)::s') when use_match -> whrec (Stack.nth args (Projection.npars p + Projection.arg p), s') |args, (Stack.Fix (f,s')::s'') when use_fix -> @@ -850,7 +872,7 @@ let rec whd_state_gen flags env sigma = whrec (** reduction machine without global env and refold machinery *) -let local_whd_state_gen flags _env sigma = +let local_whd_state_gen flags env sigma = let rec whrec (x, stack) = let c0 = EConstr.kind sigma x in let s = (EConstr.of_kind c0, stack) in @@ -882,8 +904,8 @@ let local_whd_state_gen flags _env sigma = | Proj (p,c) when CClosure.RedFlags.red_projection flags p -> (whrec (c, Stack.Proj (p) :: stack)) - | Case (ci,p,iv,d,lf) -> - whrec (d, Stack.Case (ci,p,iv,lf) :: stack) + | Case (ci,u,pms,p,iv,d,lf) -> + whrec (d, Stack.Case (ci,u,pms,p,iv,lf) :: stack) | Fix ((ri,n),_ as f) -> (match Stack.strip_n_app ri.(n) stack with @@ -896,13 +918,14 @@ let local_whd_state_gen flags _env sigma = Some c -> whrec (c,stack) | None -> s) - | Construct ((ind,c),u) -> + | Construct (cstr, u) -> let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, _, lf)::s') when use_match -> - whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Case case :: s') when use_match -> + let r = apply_branch env sigma cstr args case in + whrec (r, s') |args, (Stack.Proj (p) :: s') when use_match -> whrec (Stack.nth args (Projection.npars p + Projection.arg p), s') |args, (Stack.Fix (f,s')::s'') when use_fix -> diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index ae93eb48b4..59bc4a8b72 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -57,9 +57,12 @@ module Stack : sig val pr_app_node : ('a -> Pp.t) -> 'a app_node -> Pp.t + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array + type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array + | Case of 'a case_stk | Proj of Projection.t | Fix of ('a, 'a) pfixpoint * 'a t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 34bcd0982c..064990f6bf 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -129,7 +129,8 @@ let retype ?(polyprop=true) sigma = | Evar ev -> existential_type sigma ev | Ind (ind, u) -> EConstr.of_constr (rename_type_of_inductive env (ind, EInstance.kind sigma u)) | Construct (cstr, u) -> EConstr.of_constr (rename_type_of_constructor env (cstr, EInstance.kind sigma u)) - | Case (_,p,_iv,c,lf) -> + | Case (ci,u,pms,p,iv,c,lf) -> + let (_,p,iv,c,lf) = EConstr.expand_case env sigma (ci,u,pms,p,iv,c,lf) in let Inductiveops.IndType(indf,realargs) = let t = type_of env c in try Inductiveops.find_rectype env sigma t @@ -309,7 +310,7 @@ let relevance_of_term env sigma c = | Const (c,_) -> Relevanceops.relevance_of_constant env c | Ind _ -> Sorts.Relevant | Construct (c,_) -> Relevanceops.relevance_of_constructor env c - | Case (ci, _, _, _, _) -> ci.ci_relevance + | Case (ci, _, _, _, _, _, _) -> ci.ci_relevance | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance | Proj (p, _) -> Relevanceops.relevance_of_projection env p diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 411fb0cd89..01819a650b 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -296,8 +296,8 @@ let compute_consteval_direct env sigma ref = | Fix fix when not onlyproj -> (try check_fix_reversibility sigma labs l fix with Elimconst -> NotAnElimination) - | Case (_,_,_,d,_) when isRel sigma d && not onlyproj -> EliminationCases n - | Case (_,_,_,d,_) -> srec env n labs true d + | Case (_,_,_,_,_,d,_) when isRel sigma d && not onlyproj -> EliminationCases n + | Case (_,_,_,_,_,d,_) -> srec env n labs true d | Proj (p, d) when isRel sigma d -> EliminationProj n | _ -> NotAnElimination in @@ -478,29 +478,36 @@ let contract_cofix_use_function env sigma f sigma (nf_beta env sigma bodies.(bodynum)) type 'a miota_args = { - mP : constr; (** the result type *) + mU : EInstance.t; (* Universe instance of the return clause *) + mParams : constr array; (* Parameters of the inductive *) + mP : case_return; (* the result type *) mconstr : constr; (** the constructor *) mci : case_info; (** special info to re-build pattern *) mcargs : 'a list; (** the constructor's arguments *) - mlf : 'a array } (** the branch code vector *) + mlf : 'a pcase_branch array } (** the branch code vector *) -let reduce_mind_case sigma mia = +let reduce_mind_case env sigma mia = match EConstr.kind sigma mia.mconstr with - | Construct ((ind_sp,i),u) -> -(* let ncargs = (fst mia.mci).(i-1) in*) + | Construct ((_, i as cstr), u) -> let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in - applist (mia.mlf.(i-1),real_cargs) + let br = mia.mlf.(i - 1) in + let ctx = EConstr.expand_branch env sigma mia.mU mia.mParams cstr br in + let br = it_mkLambda_or_LetIn (snd br) ctx in + applist (br, real_cargs) | CoFix cofix -> let cofix_def = contract_cofix sigma cofix in (* XXX Is NoInvert OK here? *) - mkCase (mia.mci, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) + mkCase (mia.mci, mia.mU, mia.mParams, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false let reduce_mind_case_use_function func env sigma mia = match EConstr.kind sigma mia.mconstr with - | Construct ((ind_sp,i),u) -> + | Construct ((_, i as cstr),u) -> let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in - applist (mia.mlf.(i-1), real_cargs) + let br = mia.mlf.(i - 1) in + let ctx = EConstr.expand_branch env sigma mia.mU mia.mParams cstr br in + let br = it_mkLambda_or_LetIn (snd br) ctx in + applist (br, real_cargs) | CoFix (bodynum,(names,_,_) as cofix) -> let build_cofix_name = if isConst sigma func then @@ -526,8 +533,7 @@ let reduce_mind_case_use_function func env sigma mia = fun _ -> None in let cofix_def = contract_cofix_use_function env sigma build_cofix_name cofix in - (* Is NoInvert OK here? *) - mkCase (mia.mci, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) + mkCase (mia.mci, mia.mU, mia.mParams, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false @@ -728,9 +734,9 @@ and whd_simpl_stack env sigma = | LetIn (n,b,t,c) -> redrec (Vars.substl [b] c, stack) | App (f,cl) -> assert false (* see push_app above *) | Cast (c,_,_) -> redrec (c, stack) - | Case (ci,p,iv,c,lf) -> + | Case (ci,u,pms,p,iv,c,lf) -> (try - redrec (special_red_case env sigma (ci,p,iv,c,lf), stack) + redrec (special_red_case env sigma (ci,u,pms,p,iv,c,lf), stack) with Redelimination -> s') | Fix fix -> @@ -842,15 +848,15 @@ and reduce_proj env sigma c = let proj_narg = Projection.npars proj + Projection.arg proj in List.nth cargs proj_narg | _ -> raise Redelimination) - | Case (n,p,iv,c,brs) -> + | Case (n,u,pms,p,iv,c,brs) -> let c' = redrec c in - let p = (n,p,iv,c',brs) in + let p = (n,u,pms,p,iv,c',brs) in (try special_red_case env sigma p with Redelimination -> mkCase p) | _ -> raise Redelimination in redrec c -and special_red_case env sigma (ci, p, iv, c, lf) = +and special_red_case env sigma (ci, u, pms, p, iv, c, lf) = let rec redrec s = let (constr, cargs) = whd_simpl_stack env sigma s in match match_eval_ref env sigma constr cargs with @@ -860,14 +866,14 @@ and special_red_case env sigma (ci, p, iv, c, lf) = | Some gvalue -> if reducible_mind_case sigma gvalue then reduce_mind_case_use_function constr env sigma - {mP=p; mconstr=gvalue; mcargs=cargs; + {mP=p; mU = u; mParams = pms; mconstr=gvalue; mcargs=cargs; mci=ci; mlf=lf} else redrec (gvalue, cargs)) | None -> if reducible_mind_case sigma constr then - reduce_mind_case sigma - {mP=p; mconstr=constr; mcargs=cargs; + reduce_mind_case env sigma + {mP=p; mU = u; mParams = pms; mconstr=constr; mcargs=cargs; mci=ci; mlf=lf} else raise Redelimination @@ -915,7 +921,7 @@ let try_red_product env sigma c = let open Context.Rel.Declaration in mkProd (x, a, redrec (push_rel (LocalAssum (x, a)) env) b) | LetIn (x,a,b,t) -> redrec env (Vars.subst1 a t) - | Case (ci,p,iv,d,lf) -> simpfun (mkCase (ci,p,iv,redrec env d,lf)) + | Case (ci,u,pms,p,iv,d,lf) -> simpfun (mkCase (ci,u,pms,p,iv,redrec env d,lf)) | Proj (p, c) -> let c' = match EConstr.kind sigma c with @@ -1062,7 +1068,7 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = (* Still the same projection, we ignore the change in parameters *) mkProj (p, a') else mkApp (app', [| a' |]) - | _ -> map_constr_with_binders_left_to_right sigma g f acc c + | _ -> map_constr_with_binders_left_to_right env sigma g f acc c let e_contextually byhead (occs,c) f = begin fun env sigma t -> let count = ref (Locusops.initialize_occurrence_counter occs) in @@ -1131,7 +1137,7 @@ let substlin env sigma evalref occs c = count := count'; if ok then value u else c | None -> - map_constr_with_binders_left_to_right sigma + map_constr_with_binders_left_to_right env sigma (fun _ () -> ()) substrec () c in @@ -1295,9 +1301,9 @@ let one_step_reduce env sigma c = | App (f,cl) -> redrec (f, (Array.to_list cl)@stack) | LetIn (_,f,_,cl) -> (Vars.subst1 f cl,stack) | Cast (c,_,_) -> redrec (c,stack) - | Case (ci,p,iv,c,lf) -> + | Case (ci,u,pms,p,iv,c,lf) -> (try - (special_red_case env sigma (ci,p,iv,c,lf), stack) + (special_red_case env sigma (ci,u,pms,p,iv,c,lf), stack) with Redelimination -> raise NotStepReducible) | Fix fix -> (try match reduce_fix env sigma fix stack with diff --git a/pretyping/typing.ml b/pretyping/typing.ml index e3e5244a8c..5b8b367ff2 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -178,7 +178,7 @@ let type_case_branches env sigma (ind,largs) pj c = let ty = whd_betaiota env sigma (lambda_applist_assum sigma (n+1) p (realargs@[c])) in sigma, (lc, ty, Sorts.relevance_of_sort ps) -let judge_of_case env sigma ci pj iv cj lfj = +let judge_of_case env sigma case ci pj iv cj lfj = let ((ind, u), spec) = try find_mrectype env sigma cj.uj_type with Not_found -> error_case_not_inductive env sigma cj in @@ -189,7 +189,7 @@ let judge_of_case env sigma ci pj iv cj lfj = let () = if (match iv with | NoInvert -> false | CaseInvert _ -> true) != should_invert_case env ci then Type_errors.error_bad_invert env in - sigma, { uj_val = mkCase (ci, pj.uj_val, iv, cj.uj_val, Array.map j_val lfj); + sigma, { uj_val = mkCase case; uj_type = rslty } let check_type_fixpoint ?loc env sigma lna lar vdefj = @@ -383,20 +383,23 @@ let rec execute env sigma cstr = let sigma, ty = type_of_constructor env sigma ctor in sigma, make_judge cstr ty - | Case (ci,p,iv,c,lf) -> + | Case (ci, u, pms, p, iv, c, lf) -> + let case = (ci, u, pms, p, iv, c, lf) in + let (ci, p, iv, c, lf) = EConstr.expand_case env sigma case in let sigma, cj = execute env sigma c in let sigma, pj = execute env sigma p in let sigma, lfj = execute_array env sigma lf in let sigma = match iv with | NoInvert -> sigma - | CaseInvert {univs;args} -> - let t = mkApp (mkIndU (ci.ci_ind,univs), args) in + | CaseInvert {indices} -> + let args = Array.append pms indices in + let t = mkApp (mkIndU (ci.ci_ind,u), args) in let sigma, tj = execute env sigma t in let sigma, tj = type_judgment env sigma tj in let sigma = check_actual_type env sigma cj tj.utj_val in sigma in - judge_of_case env sigma ci pj iv cj lfj + judge_of_case env sigma case ci pj iv cj lfj | Fix ((vn,i as vni),recdef) -> let sigma, (_,tys,_ as recdef') = execute_recdef env sigma recdef in diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 3d3010d1a4..83e46e3295 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -563,7 +563,7 @@ let is_rigid_head sigma flags t = | Construct _ | Int _ | Float _ | Array _ -> true | Fix _ | CoFix _ -> true | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast (_, _, _) | Prod _ - | Lambda _ | LetIn _ | App (_, _) | Case (_, _, _, _, _) + | Lambda _ | LetIn _ | App (_, _) | Case _ | Proj (_, _) -> false (* Why aren't Prod, Sort rigid heads ? *) let force_eqs c = @@ -652,7 +652,7 @@ let rec is_neutral env sigma ts t = not (TransparentState.is_transparent_variable ts id) | Rel n -> true | Evar _ | Meta _ -> true - | Case (_, p, _, c, _) -> is_neutral env sigma ts c + | Case (_, _, _, _, _, c, _) -> is_neutral env sigma ts c | Proj (p, c) -> is_neutral env sigma ts c | Lambda _ | LetIn _ | Construct _ | CoFix _ | Int _ | Float _ | Array _ -> false | Sort _ | Cast (_, _, _) | Prod (_, _, _) | Ind _ -> false (* Really? *) @@ -698,6 +698,16 @@ let careful_infer_conv ~pb ~ts env sigma m n = (fun sigma -> infer_conv ~pb ~ts env sigma m n) else infer_conv ~pb ~ts env sigma m n +type maybe_ground = Ground | NotGround | Unknown + +let error_cannot_unify_local env sigma (m, n, p) = + error_cannot_unify_local env sigma (fst m, fst n, p) + +let fast_occur_meta_or_undefined_evar sigma (c, gnd) = match gnd with +| Unknown -> occur_meta_or_undefined_evar sigma c +| Ground -> false +| NotGround -> true + let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top env cv_pb flags m n = let rec unirec_rec (curenv,nb as curenvnb) pb opt ((sigma,metasubst,evarsubst) as substn : subst0) curm curn = let cM = Evarutil.whd_head_evar sigma curm @@ -795,7 +805,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e else Evd.set_eq_sort curenv sigma s1 s2 in (sigma', metasubst, evarsubst) with e when CErrors.noncritical e -> - error_cannot_unify curenv sigma (m,n)) + error_cannot_unify curenv sigma (fst m,fst n)) | Lambda (na,t1,c1), Lambda (__,t2,c2) -> unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} @@ -853,7 +863,9 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN f2 l2 | _ -> raise ex) - | Case (ci1,p1,_,c1,cl1), Case (ci2,p2,_,c2,cl2) -> + | Case (ci1, u1, pms1, p1, iv1, c1, cl1), Case (ci2, u2, pms2, p2, iv2, c2, cl2) -> + let (ci1, p1, iv1, c1, cl1) = EConstr.expand_case env sigma (ci1, u1, pms1, p1, iv1, c1, cl1) in + let (ci2, p2, iv2, c2, cl2) = EConstr.expand_case env sigma (ci2, u2, pms2, p2, iv2, c2, cl2) in (try if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then error_cannot_unify curenv sigma (cM,cN); let opt' = {opt with at_top = true; with_types = false} in @@ -963,7 +975,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e modulo_delta = TransparentState.full; modulo_eta = true; modulo_betaiota = true } - ty1 ty2 + (ty1, Unknown) (ty2, Unknown) with RetypeError _ -> substn and unify_not_same_head curenvnb pb opt (sigma, metas, evars as substn : subst0) cM cN = @@ -1131,10 +1143,12 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e try let res = if subterm_restriction opt flags || - occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n + fast_occur_meta_or_undefined_evar sigma m || fast_occur_meta_or_undefined_evar sigma n then None else + let (m, _) = m in + let (n, _) = n in let ans = match flags.modulo_conv_on_closed_terms with | Some convflags -> careful_infer_conv ~pb:cv_pb ~ts:convflags env sigma m n | _ -> constr_cmp cv_pb env sigma flags m n in @@ -1150,7 +1164,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e in let a = match res with | Some sigma -> sigma, ms, es - | None -> unirec_rec (env,0) cv_pb opt subst m n in + | None -> unirec_rec (env,0) cv_pb opt subst (fst m) (fst n) in if debug_unification () then Feedback.msg_debug (str "Leaving unification with success"); a with e -> @@ -1158,7 +1172,8 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e if debug_unification () then Feedback.msg_debug (str "Leaving unification with failure"); Exninfo.iraise e -let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env +let unify_0 env sigma pb flags c1 c2 = + unify_0_with_initial_metas (sigma,[],[]) true env pb flags (c1, Unknown) (c2, Unknown) let left = true let right = false @@ -1492,13 +1507,13 @@ let check_types env flags (sigma,_,_ as subst) m n = if isEvar_or_Meta sigma (head_app env sigma m) then unify_0_with_initial_metas subst true env CUMUL flags - (get_type_of env sigma n) - (get_type_of env sigma m) + (get_type_of env sigma n, Unknown) + (get_type_of env sigma m, Unknown) else if isEvar_or_Meta sigma (head_app env sigma n) then unify_0_with_initial_metas subst true env CUMUL flags - (get_type_of env sigma m) - (get_type_of env sigma n) + (get_type_of env sigma m, Unknown) + (get_type_of env sigma n, Unknown) else subst let try_resolve_typeclasses env evd flag m n = @@ -1509,7 +1524,7 @@ let try_resolve_typeclasses env evd flag m n = let w_unify_core_0 env evd with_types cv_pb flags m n = let (mc1,evd') = retract_coercible_metas evd in - let (sigma,ms,es) = check_types env (set_flags_for_type flags.core_unify_flags) (evd',mc1,[]) m n in + let (sigma,ms,es) = check_types env (set_flags_for_type flags.core_unify_flags) (evd',mc1,[]) (fst m) (fst n) in let subst2 = unify_0_with_initial_metas (sigma,ms,es) false env cv_pb flags.core_unify_flags m n @@ -1522,7 +1537,7 @@ let w_typed_unify env evd = w_unify_core_0 env evd true let w_typed_unify_array env evd flags f1 l1 f2 l2 = let f1,l1,f2,l2 = adjust_app_array_size f1 l1 f2 l2 in let (mc1,evd') = retract_coercible_metas evd in - let fold_subst subst m n = unify_0_with_initial_metas subst true env CONV flags.core_unify_flags m n in + let fold_subst subst m n = unify_0_with_initial_metas subst true env CONV flags.core_unify_flags (m, Unknown) (n, Unknown) in let subst = fold_subst (evd', [], []) f1 f2 in let subst = Array.fold_left2 fold_subst subst l1 l2 in let evd = w_merge env true flags.merge_unify_flags subst in @@ -1609,6 +1624,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = restrict_conv_on_strict_subterms = true } } else default_matching_flags pending in let n = Array.length (snd (decompose_app_vect sigma c)) in + let cgnd = if occur_meta_or_undefined_evar sigma c then NotGround else Ground in let matching_fun _ t = try let t',l2 = @@ -1622,7 +1638,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = else applist (t,l1), l2 else t, [] in - let sigma = w_typed_unify env sigma Reduction.CONV flags c t' in + let sigma = w_typed_unify env sigma Reduction.CONV flags (c, cgnd) (t', Unknown) in let ty = Retyping.get_type_of env sigma t in if not (is_correct_type ty) then raise (NotUnifiable None); Some(sigma, t, l2) @@ -1678,7 +1694,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = (push_named_context_val d sign,depdecls) | (AllOccurrences | AtLeastOneOccurrence), InHyp as occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - let newdecl = replace_term_occ_decl_modulo sigma occ test mkvarid d in + let newdecl = replace_term_occ_decl_modulo env sigma occ test mkvarid d in if Context.Named.Declaration.equal (EConstr.eq_constr sigma) d newdecl && not (indirectly_dependent sigma c d depdecls) then @@ -1689,7 +1705,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = (push_named_context_val newdecl sign, newdecl :: depdecls) | occ -> (* There are specific occurrences, hence not like first *) - let newdecl = replace_term_occ_decl_modulo sigma (AtOccs occ) test mkvarid d in + let newdecl = replace_term_occ_decl_modulo env sigma (AtOccs occ) test mkvarid d in (push_named_context_val newdecl sign, newdecl :: depdecls) in try let sign,depdecls = @@ -1699,7 +1715,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = | NoOccurrences -> concl | occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - replace_term_occ_modulo sigma occ test mkvarid concl + replace_term_occ_modulo env sigma occ test mkvarid concl in let lastlhyp = if List.is_empty depdecls then None else Some (NamedDecl.get_id (List.last depdecls)) in @@ -1763,6 +1779,7 @@ let keyed_unify env evd kop = let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let bestexn = ref None in let kop = Keys.constr_key (fun c -> EConstr.kind evd c) op in + let opgnd = if occur_meta_or_undefined_evar evd op then NotGround else Ground in let rec matchrec cl = let cl = strip_outer_cast evd cl in (try @@ -1772,7 +1789,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let f1, l1 = decompose_app_vect evd op in let f2, l2 = decompose_app_vect evd cl in w_typed_unify_array env evd flags f1 l1 f2 l2,cl - else w_typed_unify env evd CONV flags op cl,cl + else w_typed_unify env evd CONV flags (op, opgnd) (cl, Unknown),cl with ex when Pretype_errors.unsatisfiable_exception ex -> bestexn := Some ex; user_err Pp.(str "Unsat")) else user_err Pp.(str "Bound 1") @@ -1787,11 +1804,11 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = matchrec c1 with ex when precatchable_exception ex -> matchrec c2) - | Case(_,_,_,c,lf) -> (* does not search in the predicate *) + | Case(_,_,_,_,_,c,lf) -> (* does not search in the predicate *) (try matchrec c with ex when precatchable_exception ex -> - iter_fail matchrec lf) + iter_fail matchrec (Array.map snd lf)) | LetIn(_,c1,_,c2) -> (try matchrec c1 @@ -1867,11 +1884,12 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = else bind (f a.(i)) (ffail (i+1)) in ffail 0 in + let opgnd = if occur_meta_or_undefined_evar evd op then NotGround else Ground in let rec matchrec cl = let cl = strip_outer_cast evd cl in (bind (if closed0 evd cl - then return (fun () -> w_typed_unify env evd CONV flags op cl,cl) + then return (fun () -> w_typed_unify env evd CONV flags (op, opgnd) (cl, Unknown),cl) else fail "Bound 1") (match EConstr.kind evd cl with | App (f,args) -> @@ -1881,8 +1899,8 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = let c2 = args.(n-1) in bind (matchrec c1) (matchrec c2) - | Case(_,_,_,c,lf) -> (* does not search in the predicate *) - bind (matchrec c) (bind_iter matchrec lf) + | Case(_,_,_,_,_,c,lf) -> (* does not search in the predicate *) + bind (matchrec c) (bind_iter matchrec (Array.map snd lf)) | Proj (p,c) -> matchrec c @@ -2050,7 +2068,7 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = raise ex) (* General case: try first order *) - | _ -> w_typed_unify env evd cv_pb flags ty1 ty2 + | _ -> w_typed_unify env evd cv_pb flags (ty1, Unknown) (ty2, Unknown) (* Profiling *) diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 077597c278..c4de353d18 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -116,13 +116,3 @@ val unify_0 : Environ.env -> types -> types -> subst0 - -val unify_0_with_initial_metas : - subst0 -> - bool -> - Environ.env -> - Evd.conv_pb -> - core_unify_flags -> - types -> - types -> - subst0 diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 1420401875..cf6d581066 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -284,10 +284,10 @@ and nf_stk ?from:(from=0) env sigma c t stk = let tcase = build_case_type p realargs c in let ci = Inductiveops.make_case_info env ind relevance RegularStyle in let iv = if Typeops.should_invert_case env ci then - CaseInvert {univs=u; args=allargs} + CaseInvert {indices=realargs} else NoInvert in - nf_stk env sigma (mkCase(ci, p, iv, c, branchs)) tcase stk + nf_stk env sigma (mkCase (Inductive.contract_case env (ci, p, iv, c, branchs))) tcase stk | Zproj p :: stk -> assert (from = 0) ; let p' = Projection.make p true in diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 00ac5a0624..44d3b44077 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -268,7 +268,7 @@ let meta_reducible_instance env evd b = let rec irec u = let u = whd_betaiota env Evd.empty u (* FIXME *) in match EConstr.kind evd u with - | Case (ci,p,iv,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> + | Case (ci,u,pms,p,iv,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> let m = destMeta evd (strip_outer_cast evd c) in (match try @@ -277,8 +277,10 @@ let meta_reducible_instance env evd b = if isConstruct evd g || not is_coerce then Some g else None with Not_found -> None with - | Some g -> irec (mkCase (ci,p,iv,g,bl)) - | None -> mkCase (ci,irec p,iv,c,Array.map irec bl)) + | Some g -> irec (mkCase (ci,u,pms,p,iv,g,bl)) + | None -> + let on_ctx (na, c) = (na, irec c) in + mkCase (ci,u,Array.map irec pms,on_ctx p,iv,c,Array.map on_ctx bl)) | App (f,l) when EConstr.isMeta evd (strip_outer_cast evd f) -> let m = destMeta evd (strip_outer_cast evd f) in (match @@ -627,8 +629,10 @@ let clenv_cast_meta clenv = else mkCast (mkMeta mv, DEFAULTcast, b) with Not_found -> u) | App(f,args) -> mkApp (crec_hd f, Array.map crec args) - | Case(ci,p,iv,c,br) -> - mkCase (ci, crec_hd p, map_invert crec_hd iv, crec_hd c, Array.map crec br) + | Case(ci,u,pms,p,iv,c,br) -> + (* FIXME: we only change c because [p] is always a lambda and [br] is + most of the time??? *) + mkCase (ci, u, pms, p, iv, crec_hd c, br) | Proj (p, c) -> mkProj (p, crec_hd c) | _ -> u in diff --git a/proofs/logic.ml b/proofs/logic.ml index f159395177..8b31c07f5e 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -265,15 +265,12 @@ let collect_meta_variables c = let rec collrec deep acc c = match kind c with | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc | Cast(c,_,_) -> collrec deep acc c - | Case(ci,p,iv,c,br) -> - (* Hack assuming only two situations: the legacy one that branches, - if with Metas, are Meta, and the new one with eta-let-expanded - branches *) - let br = Array.map2 (fun n b -> try snd (Term.decompose_lam_n_decls n b) with UserError _ -> b) ci.ci_cstr_ndecls br in - let acc = Constr.fold (collrec deep) acc p in + | Case(ci,u,pms,p,iv,c,br) -> + let acc = Array.fold_left (collrec deep) acc pms in + let acc = Constr.fold (collrec deep) acc (snd p) in let acc = Constr.fold_invert (collrec deep) acc iv in let acc = Constr.fold (collrec deep) acc c in - Array.fold_left (collrec deep) acc br + Array.fold_left (fun accu (_, br) -> collrec deep accu br) acc br | App _ -> Constr.fold (collrec deep) acc c | Proj (_, c) -> collrec deep acc c | _ -> Constr.fold (collrec true) acc c @@ -369,15 +366,16 @@ let rec mk_refgoals ~check env sigma goalacc conclty trm = let ty = EConstr.Unsafe.to_constr ty in (acc',ty,sigma,c) - | Case (ci,p,iv,c,lf) -> + | Case (ci, u, pms, p, iv, c, lf) -> (* XXX Is ignoring iv OK? *) + let (ci, p, iv, c, lf) = Inductive.expand_case env (ci, u, pms, p, iv, c, lf) in let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals ~check env sigma goalacc p c in let sigma = check_conv_leq_goal ~check env sigma trm conclty' conclty in let (acc'',sigma,rbranches) = treat_case ~check env sigma ci lbrty lf acc' in let lf' = Array.rev_of_list rbranches in let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm - else mkCase (ci,p',iv,c',lf') + else mkCase (Inductive.contract_case env (ci,p',iv,c',lf')) in (acc'',conclty',sigma, ans) @@ -418,14 +416,15 @@ and mk_hdgoals ~check env sigma goalacc trm = let ans = if applicand == f && args == l then trm else mkApp (applicand, args) in (acc'',conclty',sigma, ans) - | Case (ci,p,iv,c,lf) -> + | Case (ci, u, pms, p, iv, c, lf) -> (* XXX is ignoring iv OK? *) + let (ci, p, iv, c, lf) = Inductive.expand_case env (ci, u, pms, p, iv, c, lf) in let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals ~check env sigma goalacc p c in let (acc'',sigma,rbranches) = treat_case ~check env sigma ci lbrty lf acc' in let lf' = Array.rev_of_list rbranches in let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm - else mkCase (ci,p',iv,c',lf') + else mkCase (Inductive.contract_case env (ci,p',iv,c',lf')) in (acc'',conclty',sigma, ans) @@ -479,13 +478,7 @@ and treat_case ~check env sigma ci lbrty lf acc' = | App (f,cl) -> (f, cl) | _ -> (c,[||]) in Array.fold_left3 - (fun (lacc,sigma,bacc) ty fi l -> - if isMeta (strip_outer_cast fi) then - (* Support for non-eta-let-expanded Meta as found in *) - (* destruct/case with an non eta-let expanded elimination scheme *) - let (r,_,s,fi') = mk_refgoals ~check env sigma lacc ty fi in - r,s,(fi'::bacc) - else + (fun (lacc,sigma,bacc) ty fi n -> (* Deal with a branch in expanded form of the form Case(ci,p,c,[|eta-let-exp(Meta);...;eta-let-exp(Meta)|]) as if it were not so, so as to preserve compatibility with when @@ -494,7 +487,6 @@ and treat_case ~check env sigma ci lbrty lf acc' = CAUTION: it does not deal with the general case of eta-zeta reduced branches having a form different from Meta, as it would be theoretically the case with third-party code *) - let n = List.length l in let ctx, body = Term.decompose_lam_n_decls n fi in let head, args = decompose_app_vect body in (* Strip cast because clenv_cast_meta adds a cast when the branch is @@ -503,8 +495,7 @@ and treat_case ~check env sigma ci lbrty lf acc' = let head = strip_outer_cast head in if isMeta head then begin assert (args = Context.Rel.to_extended_vect mkRel 0 ctx); - let head' = lift (-n) head in - let (r,_,s,head'') = mk_refgoals ~check env sigma lacc ty head' in + let (r,_,s,head'') = mk_refgoals ~check env sigma lacc ty head in let fi' = it_mkLambda_or_LetIn (mkApp (head'',args)) ctx in (r,s,fi'::bacc) end @@ -513,7 +504,7 @@ and treat_case ~check env sigma ci lbrty lf acc' = let sigma, t'ty = goal_type_of ~check env sigma fi in let sigma = check_conv_leq_goal ~check env sigma fi t'ty ty in (lacc,sigma,fi::bacc)) - (acc',sigma,[]) lbrty lf ci.ci_pp_info.cstr_tags + (acc',sigma,[]) lbrty lf ci.ci_cstr_ndecls let convert_hyp ~check ~reorder env sigma d = let id = NamedDecl.get_id d in diff --git a/tactics/cbn.ml b/tactics/cbn.ml index 31873ea6b0..39959d6fb8 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -104,9 +104,11 @@ sig | Cst_const of pconstant | Cst_proj of Projection.t + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array * Cst_stack.t + | Case of 'a case_stk * Cst_stack.t | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t @@ -121,7 +123,7 @@ sig val append_app : 'a array -> 'a t -> 'a t val decomp : 'a t -> ('a * 'a t) option val equal : ('a -> 'a -> bool) -> (('a, 'a) pfixpoint -> ('a, 'a) pfixpoint -> bool) - -> 'a t -> 'a t -> bool + -> ('a case_stk -> 'a case_stk -> bool) -> 'a t -> 'a t -> bool val strip_app : 'a t -> 'a t * 'a t val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option val will_expose_iota : 'a t -> bool @@ -156,9 +158,11 @@ struct | Cst_const of pconstant | Cst_proj of Projection.t + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array * Cst_stack.t + | Case of 'a case_stk * Cst_stack.t | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t @@ -172,9 +176,9 @@ struct let pr_c x = hov 1 (pr_c x) in match member with | App app -> str "ZApp" ++ pr_app_node pr_c app - | Case (_,_,_,br,cst) -> + | Case ((_,_,_,_,_,br),cst) -> str "ZCase(" ++ - prvect_with_sep (pr_bar) pr_c br + prvect_with_sep (pr_bar) (fun (_, b) -> pr_c b) br ++ str ")" | Proj (p,cst) -> str "ZProj(" ++ Constant.debug_print (Projection.constant p) ++ str ")" @@ -221,7 +225,7 @@ struct if i < j then (l.(j), App (i,l,pred j) :: sk) else (l.(j), sk) - let equal f f_fix sk1 sk2 = + let equal f f_fix f_case sk1 sk2 = let equal_cst_member x y = match x, y with | Cst_const (c1,u1), Cst_const (c2, u2) -> @@ -236,8 +240,8 @@ struct let t1,s1' = decomp_node_last a1 s1 in let t2,s2' = decomp_node_last a2 s2 in (f t1 t2) && (equal_rec s1' s2') - | Case (_,t1,_,a1,_) :: s1, Case (_,t2,_,a2,_) :: s2 -> - f t1 t2 && CArray.equal (fun x y -> f x y) a1 a2 && equal_rec s1 s2 + | Case ((ci1,pms1,p1,t1,iv1,a1),_) :: s1, Case ((ci2,pms2,p2,iv2,t2,a2),_) :: s2 -> + f_case (ci1,pms1,p1,t1,iv1,a1) (ci2,pms2,p2,iv2,t2,a2) && equal_rec s1 s2 | (Proj (p,_)::s1, Proj(p2,_)::s2) -> Projection.Repr.CanOrd.equal (Projection.repr p) (Projection.repr p2) && equal_rec s1 s2 @@ -284,7 +288,7 @@ struct let will_expose_iota args = List.exists - (function (Fix (_,_,l) | Case (_,_,_,_,l) | + (function (Fix (_,_,l) | Case (_,l) | Proj (_,l) | Cst (_,_,_,_,l)) when Cst_stack.is_empty l -> true | _ -> false) args @@ -346,9 +350,9 @@ struct then a else Array.sub a i (j - i + 1) in zip (mkApp (f, a'), s) - | f, (Case (ci,rt,iv,br,cst_l)::s) when refold -> - zip (best_state sigma (mkCase (ci,rt,iv,f,br), s) cst_l) - | f, (Case (ci,rt,iv,br,_)::s) -> zip (mkCase (ci,rt,iv,f,br), s) + | f, (Case ((ci,u,pms,rt,iv,br),cst_l)::s) when refold -> + zip (best_state sigma (mkCase (ci,u,pms,rt,iv,f,br), s) cst_l) + | f, (Case ((ci,u,pms,rt,iv,br),_)::s) -> zip (mkCase (ci,u,pms,rt,iv,f,br), s) | f, (Fix (fix,st,cst_l)::s) when refold -> zip (best_state sigma (mkFix fix, st @ (append_app [|f|] s)) cst_l) | f, (Fix (fix,st,_)::s) -> zip @@ -533,7 +537,26 @@ let debug_RAKAM = Reductionops.debug_RAKAM let equal_stacks sigma (x, l) (y, l') = let f_equal x y = eq_constr sigma x y in let eq_fix a b = f_equal (mkFix a) (mkFix b) in - Stack.equal f_equal eq_fix l l' && f_equal x y + let eq_case (ci1, u1, pms1, p1, _, br1) (ci2, u2, pms2, p2, _, br2) = + Array.equal f_equal pms1 pms2 && + f_equal (snd p1) (snd p2) && + Array.equal (fun (_, c1) (_, c2) -> f_equal c1 c2) br1 br2 + in + Stack.equal f_equal eq_fix eq_case l l' && f_equal x y + +let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = + let args = Stack.tail ci.ci_npar args in + let args = Option.get (Stack.list_of_app_stack args) in + let br = lf.(i - 1) in + let subst = + if Int.equal ci.ci_cstr_nargs.(i - 1) ci.ci_cstr_ndecls.(i - 1) then + (* No let-bindings *) + List.rev args + else + let ctx = expand_branch env sigma u pms (ind, i) br in + subst_of_rel_context_instance ctx args + in + Vars.substl subst (snd br) let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let open Context.Named.Declaration in @@ -699,8 +722,8 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | _ -> fold ()) | _ -> fold ()) - | Case (ci,p,iv,d,lf) -> - whrec Cst_stack.empty (d, Stack.Case (ci,p,iv,lf,cst_l) :: stack) + | Case (ci,u,pms,p,iv,d,lf) -> + whrec Cst_stack.empty (d, Stack.Case ((ci,u,pms,p,iv,lf),cst_l) :: stack) | Fix ((ri,n),_ as f) -> (match Stack.strip_n_app ri.(n) stack with @@ -708,13 +731,14 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = |Some (bef,arg,s') -> whrec Cst_stack.empty (arg, Stack.Fix(f,bef,cst_l)::s')) - | Construct ((ind,c),u) -> + | Construct (cstr ,u) -> let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, _, lf,_)::s') when use_match -> - whrec Cst_stack.empty (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Case(case,_)::s') when use_match -> + let r = apply_branch env sigma cstr args case in + whrec Cst_stack.empty (r, s') |args, (Stack.Proj (p,_)::s') when use_match -> whrec Cst_stack.empty (Stack.nth args (Projection.npars p + Projection.arg p), s') |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix -> diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 9e66e8668f..d93501eea6 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1014,10 +1014,11 @@ let deps_of_constraints cstrs evm p = cstrs let evar_dependencies pred evm p = + let cache = Evarutil.create_undefined_evars_cache () in Evd.fold_undefined (fun ev evi _ -> if Evd.is_typeclass_evar evm ev && pred evm ev evi then - let evars = Evar.Set.add ev (Evarutil.undefined_evars_of_evar_info evm evi) + let evars = Evar.Set.add ev (Evarutil.filtered_undefined_evars_of_evar_info ~cache evm evi) in Intpart.union_set evars p else ()) evm () diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index f90c143a1a..54e9a87c96 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -216,7 +216,7 @@ let build_sym_scheme env ind = let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind - (mkCase (ci, + (mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) (mkApp (mkIndU indu,Array.concat @@ -225,7 +225,7 @@ let build_sym_scheme env ind = rel_vect (2*nrealargs+2) nrealargs])), NoInvert, mkRel 1 (* varH *), - [|cstr (nrealargs+1)|])))) + [|cstr (nrealargs+1)|]))))) in c, UState.of_context_set ctx let sym_scheme_kind = @@ -279,13 +279,13 @@ let build_sym_involutive_scheme env ind = let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind - (mkCase (ci, - my_it_mkLambda_or_LetIn_name - (lift_rel_context (nrealargs+1) realsign_ind) - (mkApp (eq,[| - mkApp - (mkIndU indu, Array.concat - [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; + (mkCase (Inductive.contract_case env (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+1) realsign_ind) + (mkApp (eq,[| + mkApp + (mkIndU indu, Array.concat + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; rel_vect (2*nrealargs+2) nrealargs; rel_vect 1 nrealargs]); mkApp (sym,Array.concat @@ -300,7 +300,7 @@ let build_sym_involutive_scheme env ind = mkRel 1|])), NoInvert, mkRel 1 (* varH *), - [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))) + [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|]))))) in (c, UState.of_context_set ctx) let sym_involutive_scheme_kind = @@ -437,11 +437,11 @@ let build_l2r_rew_scheme dep env ind kind = rel_vect 4 nrealargs; [|mkRel 2|]])|]]) in let main_body = - mkCase (ci, + mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG, NoInvert, applied_sym_C 3, - [|mkVar varHC|]) + [|mkVar varHC|])) in let c = (my_it_mkLambda_or_LetIn paramsctxt @@ -451,7 +451,7 @@ let build_l2r_rew_scheme dep env ind kind = (mkNamedLambda (make_annot varHC indr) applied_PC (mkNamedLambda (make_annot varH indr) (lift 2 applied_ind) (if dep then (* we need a coercion *) - mkCase (cieq, + mkCase (Inductive.contract_case env (cieq, mkLambda (make_annot (Name varH) indr,lift 3 applied_ind, mkLambda (make_annot Anonymous indr, mkApp (eq,[|lift 4 applied_ind;applied_sym_sym;mkRel 1|]), @@ -459,7 +459,7 @@ let build_l2r_rew_scheme dep env ind kind = NoInvert, mkApp (sym_involutive, Array.append (Context.Rel.to_extended_vect mkRel 3 mip.mind_arity_ctxt) [|mkVar varH|]), - [|main_body|]) + [|main_body|])) else main_body)))))) in (c, UState.of_context_set ctx) @@ -540,7 +540,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda (make_annot varH indr) applied_ind - (mkCase (ci, + (mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) (mkNamedProd (make_annot varP indr) @@ -553,7 +553,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = (my_it_mkProd_or_LetIn (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s) (mkNamedLambda (make_annot varHC indr) applied_PC' - (mkVar varHC))|]))))) + (mkVar varHC))|])))))) in c, UState.of_context_set ctx (**********************************************************************) @@ -620,7 +620,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = (if dep then realsign_ind else realsign)) s) (mkNamedLambda (make_annot varHC indr) (lift 1 applied_PG) (mkApp - (mkCase (ci, + (mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+3) realsign_ind) (mkArrow applied_PG indr (lift (2*nrealargs+5) applied_PC)), @@ -629,7 +629,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = [|mkLambda (make_annot (Name varHC) indr, lift (nrealargs+3) applied_PC, - mkRel 1)|]), + mkRel 1)|])), [|mkVar varHC|])))))) in c, UState.of_context_set ctx @@ -825,7 +825,7 @@ let build_congr env (eq,refl,ctx) ind = (mkIndU indu, Context.Rel.to_extended_list mkRel (mip.mind_nrealargs+2) paramsctxt @ Context.Rel.to_extended_list mkRel 0 realsign)) - (mkCase (ci, + (mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (mip.mind_nrealargs+3) realsign) (mkLambda @@ -843,7 +843,7 @@ let build_congr env (eq,refl,ctx) ind = mkVar varH, [|mkApp (refl, [|mkVar varB; - mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|])))))) + mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|]))))))) in c, UState.of_context_set ctx let congr_scheme_kind = declare_individual_scheme_object "_congr" diff --git a/tactics/hints.ml b/tactics/hints.ml index ace51c40d4..0cc8becd8f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -46,7 +46,7 @@ let rec head_bound sigma t = match EConstr.kind sigma t with | Prod (_, _, b) -> head_bound sigma b | LetIn (_, _, _, b) -> head_bound sigma b | App (c, _) -> head_bound sigma c -| Case (_, _, _, c, _) -> head_bound sigma c +| Case (_, _, _, _, _, c, _) -> head_bound sigma c | Ind (ind, _) -> GlobRef.IndRef ind | Const (c, _) -> GlobRef.ConstRef c | Construct (c, _) -> GlobRef.ConstructRef c @@ -591,7 +591,7 @@ struct let head_evar sigma c = let rec hrec c = match EConstr.kind sigma c with | Evar (evk,_) -> evk - | Case (_,_,_,c,_) -> hrec c + | Case (_,_,_,_,_,c,_) -> hrec c | App (c,_) -> hrec c | Cast (c,_,_) -> hrec c | Proj (p, c) -> hrec c diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 39c5c9562f..b40bdbc25e 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -3293,7 +3293,7 @@ let expand_projections env sigma c = let rec aux env c = match EConstr.kind sigma c with | Proj (p, c) -> Retyping.expand_projection env sigma p (aux env c) [] - | _ -> map_constr_with_full_binders sigma push_rel aux env c + | _ -> map_constr_with_full_binders env sigma push_rel aux env c in aux env c diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index df07dcbca7..f12d4e5de5 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -335,8 +335,9 @@ struct meta in Meta meta - | Case (ci,c1,_iv,c2,ca) -> - Term(DCase(ci,pat_of_constr c1,pat_of_constr c2,Array.map pat_of_constr ca)) + | Case (ci,u1,pms1,c1,_iv,c2,ca) -> + let f_ctx (_, p) = pat_of_constr p in + Term(DCase(ci,f_ctx c1,pat_of_constr c2,Array.map f_ctx ca)) | Fix ((ia,i),(_,ta,ca)) -> Term(DFix(ia,i,Array.map pat_of_constr ta, Array.map pat_of_constr ca)) | CoFix (i,(_,ta,ca)) -> diff --git a/test-suite/bugs/opened/bug_3166.v b/test-suite/bugs/closed/bug_3166.v index baf87631f0..3b3375fdd8 100644 --- a/test-suite/bugs/opened/bug_3166.v +++ b/test-suite/bugs/closed/bug_3166.v @@ -80,5 +80,5 @@ Goal forall T (x y : T) (p : x = y), True. ) as H0. compute in H0. change (fun (x' : T) (_ : y = x') => x' = y) with ((fun y => fun (x' : T) (_ : y = x') => x' = y) y) in H0. - Fail pose proof (fun k => @eq_trans _ _ _ k H0). + pose proof (fun k => @eq_trans _ _ _ k H0). Abort. diff --git a/test-suite/bugs/closed/bug_6157.v b/test-suite/bugs/closed/bug_6157.v new file mode 100644 index 0000000000..cd24e4c7ee --- /dev/null +++ b/test-suite/bugs/closed/bug_6157.v @@ -0,0 +1,15 @@ +(* Check that universe instances of refs are preserved *) + +Section U. +Set Universe Polymorphism. +Definition U@{i} := Type@{i}. + +Section foo. +Universe i. +Fail Check U@{i} : U@{i}. +Notation Ui := U@{i}. (* syndef path *) +Fail Check Ui : Type@{i}. +Notation "#" := U@{i}. (* non-syndef path *) +Fail Check # : Type@{i}. +End foo. +End U. diff --git a/test-suite/micromega/reify_bool.v b/test-suite/micromega/reify_bool.v new file mode 100644 index 0000000000..501fafc0b3 --- /dev/null +++ b/test-suite/micromega/reify_bool.v @@ -0,0 +1,18 @@ +Require Import ZArith. +Require Import Lia. +Import Z. +Unset Lia Cache. + +Goal forall (x y : Z), + implb (Z.eqb x y) (Z.eqb y x) = true. +Proof. + intros. + lia. +Qed. + +Goal forall (x y :Z), implb (Z.eqb x 0) (Z.eqb y 0) = true <-> + orb (negb (Z.eqb x 0))(Z.eqb y 0) = true. +Proof. + intro. + lia. +Qed. diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 984ac4e527..6fd4d37ab4 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -50,10 +50,11 @@ f = fun H : B => match H with | AC x => - let b0 := b in - (if b0 as b return (P b -> True) - then fun _ : P true => Logic.I - else fun _ : P false => Logic.I) x + (fun x0 : P b => + let b0 := b in + (if b0 as b return (P b -> True) + then fun _ : P true => Logic.I + else fun _ : P false => Logic.I) x0) x end : B -> True The command has indeed failed with message: diff --git a/test-suite/success/case_let_conversion.v b/test-suite/success/case_let_conversion.v new file mode 100644 index 0000000000..3f1ab96fe1 --- /dev/null +++ b/test-suite/success/case_let_conversion.v @@ -0,0 +1,39 @@ +Axiom checker_flags : Set. + +Inductive Box (R : Type) : Type := box : Box R. + +Inductive typing (H : checker_flags) : Type := +| type_Rel : typing H -> typing H +| type_Case : let i := tt in Box (typing H) -> typing H. + +Definition unbox (P : Type) (b : Box P) := match b with box _ => 0 end. + +Definition size (H : checker_flags) (d : typing H) : nat. +Proof. +revert d. +fix size 1. +destruct 1. +- exact (size d). +- exact (unbox _ b). +Defined. + +Definition foo (H : checker_flags) (a : typing H) : + size H (type_Rel H a) = size H a. +Proof. +simpl. +reflexivity. +Qed. + +Definition bar (H : checker_flags) (a : typing H) : + size H (type_Rel H a) = size H a. +Proof. +vm_compute. +reflexivity. +Qed. + +Definition qux (H : checker_flags) (a : typing H) : + size H (type_Rel H a) = size H a. +Proof. +native_compute. +reflexivity. +Qed. diff --git a/test-suite/success/case_let_param.v b/test-suite/success/case_let_param.v new file mode 100644 index 0000000000..46d8c26e83 --- /dev/null +++ b/test-suite/success/case_let_param.v @@ -0,0 +1,15 @@ +Inductive foo (x := tt) := Foo : forall (y := x), foo. + +Definition get (t : foo) := match t with Foo _ y => y end. + +Goal get Foo = tt. +Proof. +reflexivity. +Qed. + +Goal forall x : foo, + match x with Foo _ y => y end = match x with Foo _ _ => tt end. +Proof. +intros. +reflexivity. +Qed. diff --git a/test-suite/success/change.v b/test-suite/success/change.v index 2f676cf9ad..053429a5a9 100644 --- a/test-suite/success/change.v +++ b/test-suite/success/change.v @@ -14,8 +14,8 @@ Abort. (* Check the combination of at, with and in (see bug #2146) *) Goal 3=3 -> 3=3. intro H. -change 3 at 2 with (1+2). -change 3 at 2 with (1+2) in H |-. +change 3 with (1+2) at 2. +change 3 with (1+2) in H at 2 |-. change 3 with (1+2) in H at 1 |- * at 1. (* Now check that there are no more 3's *) change 3 with (1+2) in * || reflexivity. diff --git a/test-suite/success/let_pattern_mismatch.v b/test-suite/success/let_pattern_mismatch.v new file mode 100644 index 0000000000..a56a8fff4f --- /dev/null +++ b/test-suite/success/let_pattern_mismatch.v @@ -0,0 +1,18 @@ +(* Weird corner case accepted by the pattern-matching algorithm. Destructuring + let-bindings in patterns can actually be shorter than the case they match. *) + +Inductive ascii : Set := +| Ascii : bool -> bool -> bool -> bool -> bool -> bool -> bool -> bool -> ascii. + +Definition dummy (a : ascii) : unit := + let (a0,a1,a2,a3,a4,a5,a6,a7) := a in tt. + +Goal forall (a : ascii) (H : tt = dummy a), True. +Proof. +intros a H. +unfold dummy in *. +(* Two bound variables in the pattern, eight in the term. *) +match goal with +| H:context [ let (x, y) := ?X in _ ] |- _ => destruct X eqn:? +end. +Abort. diff --git a/test-suite/success/match_case_pattern_variables.v b/test-suite/success/match_case_pattern_variables.v new file mode 100644 index 0000000000..bb9117d033 --- /dev/null +++ b/test-suite/success/match_case_pattern_variables.v @@ -0,0 +1,34 @@ +(** Check that bound variables in case patterns are handled correctly. *) + +Goal forall (ch : unit) (t : list unit) (s : list unit), + match s with + | nil => False + | cons a l => ch = a /\ l = t + end. +Proof. +intros. +match goal with +| |- match ?e with + | nil => ?N + | cons a b => ?P + end => + let f := + constr:((fun (e' : list unit) => match e' with + | nil => N + | cons a b => P + end)) + in + change (f e) +end. +Abort. + +Goal forall (ch : unit) (n : nat) (s : prod unit nat), + let (a, l) := s in ch = a /\ l = n. +Proof. +intros. +match goal with +| [ |- let (a, b) := ?e in ?P ] => + let f := constr:((fun (e' : prod unit nat) => match e' with pair a b => P end)) in + change (f e) +end. +Abort. diff --git a/theories/Numbers/DecimalPos.v b/theories/Numbers/DecimalPos.v index 5611329b12..f86246d3c2 100644 --- a/theories/Numbers/DecimalPos.v +++ b/theories/Numbers/DecimalPos.v @@ -216,7 +216,7 @@ Proof. - trivial. - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). rewrite N.mul_succ_r. - change 10 at 2 with (Nat.iter 10%nat N.succ 0). + change 10 with (Nat.iter 10%nat N.succ 0) at 2. rewrite ?nat_iter_S, nat_iter_0. rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. destruct (to_lu (N.pos p)); simpl; auto. diff --git a/theories/Numbers/HexadecimalPos.v b/theories/Numbers/HexadecimalPos.v index 47f6d983b7..29029cb839 100644 --- a/theories/Numbers/HexadecimalPos.v +++ b/theories/Numbers/HexadecimalPos.v @@ -235,7 +235,7 @@ Proof. - trivial. - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). rewrite N.mul_succ_r. - change 0x10 at 2 with (Nat.iter 0x10%nat N.succ 0). + change 0x10 with (Nat.iter 0x10%nat N.succ 0) at 2. rewrite ?nat_iter_S, nat_iter_0. rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. destruct (to_lu (N.pos p)); simpl; auto. diff --git a/user-contrib/Ltac2/Constr.v b/user-contrib/Ltac2/Constr.v index 4cc9d99c64..72cac900cd 100644 --- a/user-contrib/Ltac2/Constr.v +++ b/user-contrib/Ltac2/Constr.v @@ -24,7 +24,7 @@ Ltac2 Type case. Ltac2 Type case_invert := [ | NoInvert -| CaseInvert (instance,constr array) +| CaseInvert (constr array) ]. Ltac2 Type kind := [ diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 8663691c0a..64a2b24404 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -109,15 +109,14 @@ let to_rec_declaration (nas, cs) = let of_case_invert = let open Constr in function | NoInvert -> ValInt 0 - | CaseInvert {univs;args} -> - v_blk 0 [|of_instance univs; of_array of_constr args|] + | CaseInvert {indices} -> + v_blk 0 [|of_array of_constr indices|] let to_case_invert = let open Constr in function | ValInt 0 -> NoInvert - | ValBlk (0, [|univs;args|]) -> - let univs = to_instance univs in - let args = to_array to_constr args in - CaseInvert {univs;args} + | ValBlk (0, [|indices|]) -> + let indices = to_array to_constr indices in + CaseInvert {indices} | _ -> CErrors.anomaly Pp.(str "unexpected value shape") let of_result f = function @@ -378,6 +377,7 @@ end let () = define1 "constr_kind" constr begin fun c -> let open Constr in Proofview.tclEVARMAP >>= fun sigma -> + Proofview.tclENV >>= fun env -> return begin match EConstr.kind sigma c with | Rel n -> v_blk 0 [|Value.of_int n|] @@ -434,7 +434,9 @@ let () = define1 "constr_kind" constr begin fun c -> Value.of_ext Value.val_constructor cstr; of_instance u; |] - | Case (ci, c, iv, t, bl) -> + | Case (ci, u, pms, c, iv, t, bl) -> + (* FIXME: also change representation Ltac2-side? *) + let (ci, c, iv, t, bl) = EConstr.expand_case env sigma (ci, u, pms, c, iv, t, bl) in v_blk 13 [| Value.of_ext Value.val_case ci; Value.of_constr c; @@ -472,6 +474,8 @@ let () = define1 "constr_kind" constr begin fun c -> end let () = define1 "constr_make" valexpr begin fun knd -> + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.tclENV >>= fun env -> let c = match Tac2ffi.to_block knd with | (0, [|n|]) -> let n = Value.to_int n in @@ -529,7 +533,7 @@ let () = define1 "constr_make" valexpr begin fun knd -> let iv = to_case_invert iv in let t = Value.to_constr t in let bl = Value.to_array Value.to_constr bl in - EConstr.mkCase (ci, c, iv, t, bl) + EConstr.mkCase (EConstr.contract_case env sigma (ci, c, iv, t, bl)) | (14, [|recs; i; nas; cs|]) -> let recs = Value.to_array Value.to_int recs in let i = Value.to_int i in diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 792f07bb89..9c5f111e28 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -176,7 +176,10 @@ let fold_with_full_binders g f n acc c = | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_,c) -> f n acc c | Evar (_,l) -> List.fold_left (f n) acc l - | Case (_,p,iv,c,bl) -> Array.fold_left (f n) (f n (fold_invert (f n) (f n acc p) iv) c) bl + | Case (ci, u, pms, p, iv, c, bl) -> + let mib = lookup_mind (fst ci.ci_ind) in + let (ci, p, iv, c, bl) = Inductive.expand_case_specif mib (ci, u, pms, p, iv, c, bl) in + Array.fold_left (f n) (f n (fold_invert (f n) (f n acc p) iv) c) bl | Fix (_,(lna,tl,bl)) -> let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in @@ -201,12 +204,11 @@ let rec traverse current ctx accu t = | Construct (((mind, _), _) as cst, _) -> traverse_inductive accu mind (ConstructRef cst) | Meta _ | Evar _ -> assert false -| Case (_,oty,_,c,[||]) -> +| Case (_, _, _, ([|_|], oty), _, c, [||]) when Vars.noccurn 1 oty -> (* non dependent match on an inductive with no constructors *) - begin match Constr.(kind oty, kind c) with - | Lambda(_,_,oty), Const (kn, _) - when Vars.noccurn 1 oty && - not (Declareops.constant_has_body (lookup_constant kn)) -> + begin match Constr.kind c with + | Const (kn, _) + when not (Declareops.constant_has_body (lookup_constant kn)) -> let body () = Option.map pi1 (Global.body_of_constant_body Library.indirect_accessor (lookup_constant kn)) in traverse_object ~inhabits:(current,ctx,Vars.subst1 mkProp oty) accu body (ConstRef kn) diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index f715459616..cc59a96834 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -351,13 +351,13 @@ let build_beq_scheme mode kn = done; ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) - (mkCase (ci,do_predicate rel_list nb_cstr_args,NoInvert, - mkVar (Id.of_string "Y") ,ar2)) + (mkCase (Inductive.contract_case env ((ci,do_predicate rel_list nb_cstr_args, + NoInvert, mkVar (Id.of_string "Y") ,ar2)))) (constrsi.(i).cs_args)) done; mkNamedLambda (make_annot (Id.of_string "X") Sorts.Relevant) (mkFullInd ind (nb_ind-1+1)) ( mkNamedLambda (make_annot (Id.of_string "Y") Sorts.Relevant) (mkFullInd ind (nb_ind-1+2)) ( - mkCase (ci, do_predicate rel_list 0,NoInvert,mkVar (Id.of_string "X"),ar))) + mkCase (Inductive.contract_case env (ci, do_predicate rel_list 0,NoInvert,mkVar (Id.of_string "X"),ar)))) in (* build_beq_scheme *) let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and types = Array.make nb_ind mkSet and diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index c54adb45f9..b3ffb864f2 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -69,9 +69,10 @@ let protect_pattern_in_binder bl c ctypopt = | LetIn (x,b,t,c) -> let evd,c = aux (push_rel (LocalDef (x,b,t)) env) evd c in evd, mkLetIn (x,t,b,c) - | Case (ci,p,iv,a,bl) -> + | Case (ci,u,pms,p,iv,a,bl) -> + let (ci, p, iv, a, bl) = EConstr.expand_case env evd (ci, u, pms, p, iv, a, bl) in let evd,bl = Array.fold_left_map (aux env) evd bl in - evd, mkCase (ci,p,iv,a,bl) + evd, mkCase (EConstr.contract_case env evd (ci, p, iv, a, bl)) | Cast (c,_,_) -> f env evd c (* we remove the cast we had set *) (* This last case may happen when reaching the proof of an impossible case, as when pattern-matching on a vector of length 1 *) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 2be6097184..a91771f22d 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -492,7 +492,7 @@ let maybe_unify_params_in env_ar_par sigma ~ninds ~nparams ~binders:k c = end) sigma args | _ -> Termops.fold_constr_with_full_binders - sigma + env sigma (fun d (env,k) -> EConstr.push_rel d env, k+1) aux envk sigma c in diff --git a/vernac/declareUniv.ml b/vernac/declareUniv.ml index 834ef0d29a..91ab17575d 100644 --- a/vernac/declareUniv.ml +++ b/vernac/declareUniv.ml @@ -74,6 +74,10 @@ let input_univ_names : universe_name_decl -> Libobject.obj = subst_function = (fun (subst, a) -> (* Actually the name is generated once and for all. *) a); classify_function = (fun a -> Substitute a) } +let input_univ_names (src, l) = + if CList.is_empty l then () + else Lib.add_anonymous_leaf (input_univ_names (src, l)) + let invent_name (named,cnt) u = let rec aux i = let na = Id.of_string ("u"^(string_of_int i)) in @@ -120,7 +124,7 @@ let declare_univ_binders gr pl = aux, (id,univ) :: univs) (LSet.diff levels named) ((pl,0),univs) in - Lib.add_anonymous_leaf (input_univ_names (QualifiedUniv l, univs)) + input_univ_names (QualifiedUniv l, univs) let do_universe ~poly l = let in_section = Global.sections_are_opened () in @@ -134,7 +138,7 @@ let do_universe ~poly l = Univ.LSet.empty l, Univ.Constraint.empty in let src = if poly then BoundUniv else UnqualifiedUniv in - let () = Lib.add_anonymous_leaf (input_univ_names (src, l)) in + let () = input_univ_names (src, l) in DeclareUctx.declare_universe_context ~poly ctx let do_constraint ~poly l = diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index e6244ee3b5..2fe402ff08 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1793,15 +1793,9 @@ let remove_delimiters local scope = let add_class_scope local scope cl = Lib.add_anonymous_leaf (inScopeCommand(local,scope,ScopeClasses cl)) -(* Check if abbreviation to a name and avoid early insertion of - maximal implicit arguments *) -let try_interp_name_alias = function - | [], { CAst.v = CRef (ref,_) } -> intern_reference ref - | _ -> raise Not_found - let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing } = let acvars,pat,reversibility = - try Id.Map.empty, NRef (try_interp_name_alias (vars,c)), APrioriReversible + try Id.Map.empty, try_interp_name_alias (vars,c), APrioriReversible with Not_found -> let fold accu id = Id.Map.add id NtnInternTypeAny accu in let i_vars = List.fold_left fold Id.Map.empty vars in diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index 0fc6c7f87b..79a0cdf8d1 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -947,7 +947,7 @@ let print_about_any ?loc env sigma k udecl = [hov 0 (str "Expands to: " ++ pr_located_qualid k)]) | Syntactic kn -> let () = match Syntax_def.search_syntactic_definition kn with - | [],Notation_term.NRef ref -> Dumpglob.add_glob ?loc ref + | [],Notation_term.NRef (ref,_) -> Dumpglob.add_glob ?loc ref | _ -> () in v 0 ( print_syntactic_def env kn ++ fnl () ++ diff --git a/vernac/record.ml b/vernac/record.ml index 68219603b4..96e4a47d2d 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -366,7 +366,7 @@ let build_named_proj ~primitive ~flags ~poly ~univs ~uinstance ~kind env paramde let ci = Inductiveops.make_case_info env indsp rci LetStyle in (* Record projections are always NoInvert because they're at constant relevance *) - mkCase (ci, p, NoInvert, mkRel 1, [|branch|]), None + mkCase (Inductive.contract_case env (ci, p, NoInvert, mkRel 1, [|branch|])), None in let proj = it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index e8cb1d65a9..4f3fc46c12 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -309,6 +309,17 @@ let print_registered () = in hov 0 (prlist_with_sep fnl pr_lib_ref @@ Coqlib.get_lib_refs ()) +let dump_universes output g = + let open Univ in + let dump_arc u = function + | UGraph.Node ltle -> + Univ.LMap.iter (fun v strict -> + let typ = if strict then Lt else Le in + output typ u v) ltle; + | UGraph.Alias v -> + output Eq u v + in + Univ.LMap.iter dump_arc g let dump_universes_gen prl g s = let output = open_out s in @@ -342,7 +353,7 @@ let dump_universes_gen prl g s = in let output_constraint k l r = output_constraint k (prl l) (prl r) in try - UGraph.dump_universes output_constraint g; + dump_universes output_constraint g; close (); str "Universes written to file \"" ++ str s ++ str "\"." with reraise -> @@ -367,13 +378,66 @@ let universe_subgraph ?loc kept univ = let univ = LSet.fold add kept UGraph.initial_universes in UGraph.merge_constraints csts univ +let sort_universes g = + let open Univ in + let rec normalize u = match LMap.find u g with + | UGraph.Alias u -> normalize u + | UGraph.Node _ -> u + in + let get_next u = match LMap.find u g with + | UGraph.Alias u -> assert false (* nodes are normalized *) + | UGraph.Node ltle -> ltle + in + (* Compute the longest chain of Lt constraints from Set to any universe *) + let rec traverse accu todo = match todo with + | [] -> accu + | (u, n) :: todo -> + let () = assert (Level.equal (normalize u) u) in + let n = match LMap.find u accu with + | m -> if m < n then Some n else None + | exception Not_found -> Some n + in + match n with + | None -> traverse accu todo + | Some n -> + let accu = LMap.add u n accu in + let next = get_next u in + let fold v lt todo = + let v = normalize v in + if lt then (v, n + 1) :: todo else (v, n) :: todo + in + let todo = LMap.fold fold next todo in + traverse accu todo + in + (* Only contains normalized nodes *) + let levels = traverse LMap.empty [normalize Level.set, 0] in + let max_level = LMap.fold (fun _ n accu -> max n accu) levels 0 in + let dummy_mp = Names.DirPath.make [Names.Id.of_string "Type"] in + let ulevels = Array.init max_level (fun i -> Level.(make (UGlobal.make dummy_mp i))) in + let ulevels = Array.cons Level.set ulevels in + (* Add the normal universes *) + let fold (cur, ans) u = + let ans = LMap.add cur (UGraph.Node (LMap.singleton u true)) ans in + (u, ans) + in + let _, ans = Array.fold_left fold (Level.prop, LMap.empty) ulevels in + (* Add alias pointers *) + let fold u _ ans = + if Level.is_small u then ans + else + let n = LMap.find (normalize u) levels in + LMap.add u (UGraph.Alias ulevels.(n)) ans + in + LMap.fold fold g ans + let print_universes ?loc ~sort ~subgraph dst = let univ = Global.universes () in let univ = match subgraph with | None -> univ | Some g -> universe_subgraph ?loc g univ in - let univ = if sort then UGraph.sort_universes univ else univ in + let univ = UGraph.repr univ in + let univ = if sort then sort_universes univ else univ in let pr_remaining = if Global.is_joined_environment () then mt () else str"There may remain asynchronous universe constraints" diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index e5971e1aaa..3a8a80d25a 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -82,7 +82,7 @@ let vernac_timeout ?timeout (f : 'a -> 'b) (x : 'a) : 'b = match !default_timeout, timeout with | _, Some n | Some n, None -> - (match Control.timeout n f x with + (match Control.timeout (float_of_int n) f x with | None -> Exninfo.iraise (Exninfo.capture CErrors.Timeout) | Some x -> x) | None, None -> |