diff options
273 files changed, 3057 insertions, 8784 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-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/ci/user-overlays/13512-herbelin-master+fix13413-apply-on-intro-pattern-fresh-names.sh b/dev/ci/user-overlays/13512-herbelin-master+fix13413-apply-on-intro-pattern-fresh-names.sh new file mode 100644 index 0000000000..4c8cdbbb45 --- /dev/null +++ b/dev/ci/user-overlays/13512-herbelin-master+fix13413-apply-on-intro-pattern-fresh-names.sh @@ -0,0 +1,5 @@ +if [ "$CI_PULL_REQUEST" = "13415" ] || [ "$CI_BRANCH" = "intern-univs" ]; then + + overlay perennial https://github.com/herbelin/perennial master+adapt13512-fresness-names-apply-in-introduction-pattern + +fi diff --git a/dev/ci/user-overlays/13725-SkySkimmer-hint-rw-local.sh b/dev/ci/user-overlays/13725-SkySkimmer-hint-rw-local.sh new file mode 100644 index 0000000000..69bd038b78 --- /dev/null +++ b/dev/ci/user-overlays/13725-SkySkimmer-hint-rw-local.sh @@ -0,0 +1 @@ +overlay equations https://github.com/SkySkimmer/Coq-Equations hint-rw-local 13725 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/13512-master+fix13413-apply-on-intro-pattern-fresh-names.rst b/doc/changelog/04-tactics/13512-master+fix13413-apply-on-intro-pattern-fresh-names.rst new file mode 100644 index 0000000000..aaacb2aadf --- /dev/null +++ b/doc/changelog/04-tactics/13512-master+fix13413-apply-on-intro-pattern-fresh-names.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Possible collision between a user-level name and an internal name when + using the :n:`%` introduction pattern + (`#13512 <https://github.com/coq/coq/pull/13512>`_, + fixes `#13413 <https://github.com/coq/coq/issues/13413>`_, + by Hugo Herbelin). 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/13699-fix13579.rst b/doc/changelog/04-tactics/13699-fix13579.rst new file mode 100644 index 0000000000..9cf62fb595 --- /dev/null +++ b/doc/changelog/04-tactics/13699-fix13579.rst @@ -0,0 +1,6 @@ +- **Fixed:** + :tacn:`simpl` and :tacn:`hnf` now reduce primitive functions + on primitive integers, floats and arrays + (`#13699 <https://github.com/coq/coq/pull/13699>`_, + fixes `#13579 <https://github.com/coq/coq/issues/13579>`_, + by Pierre Roux). 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/04-tactics/13761-remove_convert_concl_nc.rst b/doc/changelog/04-tactics/13761-remove_convert_concl_nc.rst new file mode 100644 index 0000000000..1aa57ff8b1 --- /dev/null +++ b/doc/changelog/04-tactics/13761-remove_convert_concl_nc.rst @@ -0,0 +1,4 @@ +- **Removed:** + convert_concl_no_check. Use :tacn:`change_no_check` instead + (`#13761 <https://github.com/coq/coq/pull/13761>`_, + by Jim Fehrle). 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/changelog/07-vernac-commands-and-options/13725-hint-rw-local.rst b/doc/changelog/07-vernac-commands-and-options/13725-hint-rw-local.rst new file mode 100644 index 0000000000..653e9cd0cd --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13725-hint-rw-local.rst @@ -0,0 +1,5 @@ +- **Changed:** + :cmd:`Hint Rewrite` now supports locality attributes (including :attr:`export`) like other :ref:`Hint <creating_hints>` commands + (`#13725 <https://github.com/coq/coq/pull/13725>`_, + fixes `#13724 <https://github.com/coq/coq/issues/13724>`_, + by Gaëtan Gilbert). diff --git a/doc/changelog/07-vernac-commands-and-options/13764-remove_add_injtyp.rst b/doc/changelog/07-vernac-commands-and-options/13764-remove_add_injtyp.rst new file mode 100644 index 0000000000..fc6c88eab6 --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13764-remove_add_injtyp.rst @@ -0,0 +1,6 @@ +- **Removed:** + `Show Zify Spec`, `Add InjTyp` and 11 similar `Add *` commands. + For `Show Zify Spec`, use `Show Zify UnOpSpec` or `Show Zify BinOpSpec` instead. + For `Add *`, `Use Add Zify *` intead of `Add *` + (`#13764 <https://github.com/coq/coq/pull/13764>`_, + by Jim Fehrle). diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index c54db36691..9ac05fab2e 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -726,6 +726,30 @@ declare your constant as rigid for proof search using the command Strategies for rewriting ------------------------ +Usage +~~~~~ + +.. tacn:: rewrite_strat @rewstrategy {? in @ident } + :name: rewrite_strat + + Rewrite using :n:`@rewstrategy` in the conclusion or in the hypothesis :n:`@ident`. + + .. exn:: Nothing to rewrite. + + The strategy didn't find any matches. + + .. exn:: No progress made. + + If the strategy succeeded but made no progress. + + .. exn:: Unable to satisfy the rewriting constraints. + + If the strategy succeeded and made progress but the + corresponding rewriting constraints are not satisfied. + + :tacn:`setoid_rewrite` :n:`@one_term` is basically equivalent to + :n:`rewrite_strat outermost @one_term`. + Definitions ~~~~~~~~~~~ @@ -773,7 +797,7 @@ are applied using the tactic :n:`rewrite_strat @rewstrategy`. failure :n:`id` - identity + identity :n:`refl` reflexivity @@ -803,10 +827,16 @@ are applied using the tactic :n:`rewrite_strat @rewstrategy`. all subterms :n:`innermost @rewstrategy` - innermost first + Innermost first. + When there are multiple nested matches in a subterm, the innermost subterm + is rewritten. For :ref:`example <rewrite_strat_innermost_outermost>`, + rewriting :n:`(a + b) + c` with Nat.add_comm gives :n:`(b + a) + c`. :n:`outermost @rewstrategy` - outermost first + Outermost first. + When there are multiple nested matches in a subterm, the outermost subterm + is rewritten. For :ref:`example <rewrite_strat_innermost_outermost>`, + rewriting :n:`(a + b) + c` with Nat.add_comm gives :n:`c + (a + b)`. :n:`bottomup @rewstrategy` bottom-up @@ -833,8 +863,8 @@ are applied using the tactic :n:`rewrite_strat @rewstrategy`. to be documented -A few of these are defined in terms of the others using a -primitive fixpoint operator: +Conceptually, a few of these are defined in terms of the others using a +primitive fixpoint operator `fix`, which the tactic doesn't currently support: - :n:`try @rewstrategy := choice @rewstrategy id` - :n:`any @rewstrategy := fix @ident. try (@rewstrategy ; @ident)` @@ -876,30 +906,30 @@ if it reduces the subterm under consideration. The ``fold`` strategy takes a :token:`term` and tries to *unify* it to the current subterm, converting it to :token:`term` on success. It is stronger than the tactic ``fold``. +.. _rewrite_strat_innermost_outermost: -Usage -~~~~~ - - -.. tacn:: rewrite_strat @rewstrategy {? in @ident } - :name: rewrite_strat +.. example:: :n:`innermost` and :n:`outermost` - Rewrite using the strategy s in hypothesis ident or the conclusion. + The type of `Nat.add_comm` is `forall n m : nat, n + m = m + n`. - .. exn:: Nothing to rewrite. + .. coqtop:: all - If the strategy failed. + Require Import Coq.Arith.Arith. + Set Printing Parentheses. + Goal forall a b c: nat, a + b + c = 0. + rewrite_strat innermost Nat.add_comm. - .. exn:: No progress made. + .. coqtop:: none - If the strategy succeeded but made no progress. + Abort. + Goal forall a b c: nat, a + b + c = 0. - .. exn:: Unable to satisfy the rewriting constraints. + Using :n:`outermost` instead gives this result: - If the strategy succeeded and made progress but the - corresponding rewriting constraints are not satisfied. + .. coqtop:: all + rewrite_strat outermost Nat.add_comm. - The ``setoid_rewrite c`` tactic is basically equivalent to - ``rewrite_strat (outermost c)``. + .. coqtop:: none + Abort. diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index 38c4886e0f..3bd85d29c8 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -315,68 +315,6 @@ obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. prints the list of types that supported by :tacn:`zify` i.e., :g:`Z`, :g:`nat`, :g:`positive` and :g:`N`. -.. cmd:: Show Zify Spec - - .. deprecated:: 8.13 - Use :cmd:`Show Zify` ``UnOpSpec`` or :cmd:`Show Zify` ``BinOpSpec`` instead. - -.. cmd:: Add InjTyp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``InjTyp`` instead. - -.. cmd:: Add BinOp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``BinOp`` instead. - -.. cmd:: Add BinOpSpec @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``BinOpSpec`` instead. - -.. cmd:: Add UnOp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``UnOp`` instead. - -.. cmd:: Add UnOpSpec @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``UnOpSpec`` instead. - -.. cmd:: Add CstOp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``CstOp`` instead. - -.. cmd:: Add BinRel @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``BinRel`` instead. - -.. cmd:: Add PropOp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``PropOp`` instead. - -.. cmd:: Add PropBinOp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``PropBinOp`` instead. - -.. cmd:: Add PropUOp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``PropUOp`` instead. - -.. cmd:: Add Saturate @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``Saturate`` instead. - - - .. [#csdp] Sources and binaries can be found at https://projects.coin-or.org/Csdp .. [#fnpsatz] Variants deal with equalities and strict inequalities. diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index b9a3c1973c..a08a110930 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -531,11 +531,11 @@ Commands and options .. _813HintWarning: - **Deprecated:** - The default value for hint locality is currently :attr:`local` in a section and - :attr:`global` otherwise, but is scheduled to change in a future release. For the - time being, adding hints outside of sections without specifying an explicit - locality is therefore triggering a deprecation warning. It is recommended to - use :attr:`export` whenever possible + Hint locality currently defaults to :attr:`local` in a section and + :attr:`global` otherwise, but this will change in a future release. + Hints added outside of sections without an explicit + locality now generate a deprecation warning. We recommend + using :attr:`export` where possible (`#13384 <https://github.com/coq/coq/pull/13384>`_, by Pierre-Marie Pédrot). - **Deprecated:** @@ -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 ------------ @@ -3180,7 +3191,7 @@ Other changes in 8.10+beta1 by Maxime Dénès, review by Pierre-Marie Pédrot). - New variant :tacn:`change_no_check` of :tacn:`change`, usable as a - documented replacement of :tacn:`convert_concl_no_check` + documented replacement of `convert_concl_no_check` (`#10012 <https://github.com/coq/coq/pull/10012>`_, `#10017 <https://github.com/coq/coq/pull/10017>`_, `#10053 <https://github.com/coq/coq/pull/10053>`_, and diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index e2e37ec438..edbc89aad8 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -490,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/proof-engine/detailed-tactic-examples.rst b/doc/sphinx/proof-engine/detailed-tactic-examples.rst index b63ae32311..2046788ef3 100644 --- a/doc/sphinx/proof-engine/detailed-tactic-examples.rst +++ b/doc/sphinx/proof-engine/detailed-tactic-examples.rst @@ -339,7 +339,7 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: in - Hint Rewrite Ack0 Ack1 Ack2 : base0. + Global Hint Rewrite Ack0 Ack1 Ack2 : base0. .. coqtop:: all @@ -367,7 +367,7 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: in - Hint Rewrite g0 g1 g2 using lia : base1. + Global Hint Rewrite g0 g1 g2 using lia : base1. .. coqtop:: in diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 8b627c29a4..013ff0a83f 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -879,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 @@ -900,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 diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 3646a32a79..1bb4216e4f 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -554,7 +554,7 @@ Built-in quotations ltac2_quotations ::= ident : ( @lident ) | constr : ( @term ) | open_constr : ( @term ) - | pattern : ( @cpattern ) + | pat : ( @cpattern ) | reference : ( {| & @ident | @qualid } ) | ltac1 : ( @ltac1_expr_in_env ) | ltac1val : ( @ltac1_expr_in_env ) @@ -568,7 +568,7 @@ The current implementation recognizes the following built-in quotations: (type ``Init.constr``). - ``open_constr``, which parses Coq terms and produces a term potentially with holes at runtime (type ``Init.constr`` as well). -- ``pattern``, which parses Coq patterns and produces a pattern used for term +- ``pat``, which parses Coq patterns and produces a pattern used for term matching (type ``Init.pattern``). - ``reference`` Qualified names are globalized at internalization into the corresponding global reference, diff --git a/doc/sphinx/proofs/automatic-tactics/auto.rst b/doc/sphinx/proofs/automatic-tactics/auto.rst index d7228a3907..30f7be5f13 100644 --- a/doc/sphinx/proofs/automatic-tactics/auto.rst +++ b/doc/sphinx/proofs/automatic-tactics/auto.rst @@ -273,18 +273,21 @@ Creating Hints :cmd:`Import` or :cmd:`Require` the current module. + :attr:`export` hints are visible from other modules when they :cmd:`Import` the current - module, but not when they only :cmd:`Require` it. This attribute is supported by - all `Hint` commands except for :cmd:`Hint Rewrite`. + module, but not when they only :cmd:`Require` it. + :attr:`global` hints are visible from other modules when they :cmd:`Import` or :cmd:`Require` the current module. + .. versionadded:: 8.14 + + The :cmd:`Hint Rewrite` now supports locality attributes like other `Hint` commands. + .. deprecated:: 8.13 The default value for hint locality will change in a future - release. For the time being, adding hints outside of sections without - specifying an explicit locality will trigger a deprecation - warning. We recommend you use :attr:`export` whenever possible. + release. Hints added outside of sections without an explicit + locality are now deprecated. We recommend using :attr:`export` + where possible. The `Hint` commands are: diff --git a/doc/sphinx/proofs/writing-proofs/rewriting.rst b/doc/sphinx/proofs/writing-proofs/rewriting.rst index 874c3a8f4d..663337bc64 100644 --- a/doc/sphinx/proofs/writing-proofs/rewriting.rst +++ b/doc/sphinx/proofs/writing-proofs/rewriting.rst @@ -283,6 +283,9 @@ Rewriting with definitional equality 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 @@ -338,13 +341,6 @@ Rewriting with definitional equality 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: Performing computations @@ -890,10 +886,8 @@ the conversion in hypotheses :n:`{+ @ident}`. Conversion tactics applied to hypotheses ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. tacn:: @tactic in {+, @ident} - - Applies :token:`tactic` (any of the conversion tactics listed in this - section) to the hypotheses :n:`{+ @ident}`. + The form :n:`@tactic in {+, @ident }` applies :token:`tactic` (any of the + conversion tactics listed in this section) to the hypotheses :n:`{+ @ident}`. If :token:`ident` is a local definition, then :token:`ident` can be replaced by :n:`type of @ident` to address not the body but the type of the local diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index f267cdb697..8aeb2e564d 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 @@ -2066,7 +2066,7 @@ ltac2_tactic_atom: [ | MOVETO ltac2_quotations "constr" ":" "(" lconstr ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "open_constr" ":" "(" lconstr ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "ident" ":" "(" lident ")" (* Ltac2 plugin *) -| MOVETO ltac2_quotations "pattern" ":" "(" cpattern ")" (* Ltac2 plugin *) +| MOVETO ltac2_quotations "pat" ":" "(" cpattern ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "reference" ":" "(" globref ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "ltac1" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "ltac1val" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index ccf38d2c15..ec23ffe83e 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 @@ -3370,7 +3370,7 @@ G_LTAC2_tactic_atom: [ | "constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) | "open_constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) | "ident" ":" "(" lident ")" (* Ltac2 plugin *) -| "pattern" ":" "(" Constr.cpattern ")" (* Ltac2 plugin *) +| "pat" ":" "(" Constr.cpattern ")" (* Ltac2 plugin *) | "reference" ":" "(" globref ")" (* Ltac2 plugin *) | "ltac1" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) | "ltac1val" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 72e101446c..75b32a5800 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -1653,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 @@ -2378,7 +2378,7 @@ ltac2_quotations: [ | "ident" ":" "(" lident ")" | "constr" ":" "(" term ")" | "open_constr" ":" "(" term ")" -| "pattern" ":" "(" cpattern ")" +| "pat" ":" "(" cpattern ")" | "reference" ":" "(" [ "&" ident | qualid ] ")" | "ltac1" ":" "(" ltac1_expr_in_env ")" | "ltac1val" ":" "(" ltac1_expr_in_env ")" 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.ml b/engine/evd.ml index 706e51d4b3..ed40b63d14 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -525,7 +525,7 @@ end = struct let principal = if principal then match fgl.principal with - | Some _ -> CErrors.user_err Pp.(str "Only one main subgoal per instantiation.") + | Some _ -> CErrors.user_err Pp.(str "Only one main goal per instantiation.") | None -> Some evk else fgl.principal in 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/ide/coqide/wg_ProofView.ml b/ide/coqide/wg_ProofView.ml index 01dfed0067..fa37edd82b 100644 --- a/ide/coqide/wg_ProofView.ml +++ b/ide/coqide/wg_ProofView.ml @@ -66,7 +66,7 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals ~unfoc_goals hints = mat in let goals_cnt = List.length rem_goals + 1 in let head_str = Printf.sprintf - "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "s" else "") + "%d goal%s\n" goals_cnt (if 1 < goals_cnt then "s" else "") in let goal_str ?(shownum=false) index total id = let annot = @@ -148,10 +148,10 @@ let display mode (view : #GText.view_skel) goals hints evars = let evars = match evars with None -> [] | Some evs -> evs in begin match (bg, shelved_goals,given_up_goals, evars) with | [], [], [], [] -> - view#buffer#insert "No more subgoals." + view#buffer#insert "No more goals." | [], [], [], _ :: _ -> (* A proof has been finished, but not concluded *) - view#buffer#insert "No more subgoals, but there are non-instantiated existential variables:\n\n"; + view#buffer#insert "No more goals, but there are non-instantiated existential variables:\n\n"; let iter evar = let msg = Printf.sprintf "%s\n" evar.Interface.evar_info in view#buffer#insert msg @@ -160,7 +160,7 @@ let display mode (view : #GText.view_skel) goals hints evars = view#buffer#insert "\nYou can use Grab Existential Variables." | [], [], _, _ -> (* The proof is finished, with the exception of given up goals. *) - view#buffer#insert "No more subgoals, but there are some goals you gave up:\n\n"; + view#buffer#insert "No more goals, but there are some goals you gave up:\n\n"; let iter goal = insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl); view#buffer#insert "\n" diff --git a/interp/constrextern.ml b/interp/constrextern.ml index f3ba884856..8138b4c6d9 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -1463,23 +1463,33 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with | PIf (c,b1,b2) -> GIf (glob_of_pat avoid env sigma c, (Anonymous,None), glob_of_pat avoid env sigma b1, glob_of_pat avoid env sigma b2) - | PCase ({cip_style=Constr.LetStyle; cip_ind_tags=None},PMeta None,tm,[(0,n,b)]) -> - let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat avoid env sigma b) in + | PCase ({cip_style=Constr.LetStyle},None,tm,[(0,n,b)]) -> + let n, b = glob_of_pat_under_context avoid env sigma (n, b) in + let nal = Array.to_list n in GLetTuple (nal,(Anonymous,None),glob_of_pat avoid env sigma tm,b) | PCase (info,p,tm,bl) -> let mat = match bl, info.cip_ind with | [], _ -> [] | _, Some ind -> - let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat avoid env sigma c)) bl in - simple_cases_matrix_of_branches ind bl' + let map (i, n, c) = + let n, c = glob_of_pat_under_context avoid env sigma (n, c) in + let nal = Array.to_list n in + let mkPatVar na = DAst.make @@ PatVar na in + let p = DAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in + let ids = List.map_filter Nameops.Name.to_option nal in + CAst.make @@ (ids,[p],c) + in + List.map map bl | _, None -> anomaly (Pp.str "PCase with some branches but unknown inductive.") in let mat = if info.cip_extensible then mat @ [any_any_branch] else mat in - let indnames,rtn = match p, info.cip_ind, info.cip_ind_tags with - | PMeta None, _, _ -> (Anonymous,None),None - | _, Some ind, Some nargs -> - return_type_of_predicate ind nargs (glob_of_pat avoid env sigma p) + let indnames,rtn = match p, info.cip_ind with + | None, _ -> (Anonymous,None),None + | Some p, Some ind -> + let nas, p = glob_of_pat_under_context avoid env sigma p in + let nas = Array.rev_to_list nas in + ((List.hd nas, Some (CAst.make (ind, List.tl nas))), Some p) | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.") in GCases (Constr.RegularStyle,rtn,[glob_of_pat avoid env sigma tm,indnames],mat) @@ -1523,6 +1533,18 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with let glob_of = glob_of_pat avoid env sigma in GArray (None, Array.map glob_of t, glob_of def, glob_of ty) +and glob_of_pat_under_context avoid env sigma (nas, pat) = + let fold (avoid, env, nas, epat) na = + let na, avoid = compute_displayed_name_in_pattern sigma avoid na epat in + let env = Termops.add_name na env in + let epat = match epat with PLambda (_, _, p) -> p | _ -> assert false in + (avoid, env, na :: nas, epat) + in + let epat = Array.fold_right (fun na p -> PLambda (na, PMeta None, p)) nas pat in + let (avoid', env', nas, _) = Array.fold_left fold (avoid, env, [], epat) nas in + let pat = glob_of_pat avoid' env' sigma pat in + (Array.rev_of_list nas, pat) + let extern_constr_pattern env sigma pat = extern true (InConstrEntrySomeLevel,(None,[])) (* XXX no vars? *) 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..d6002d71b5 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') @@ -1357,6 +1357,7 @@ let find_with_delimiters = function match (String.Map.find scope !scope_map).delimiters with | Some key -> Some (Some scope, Some key) | None -> None + | exception Not_found -> None let rec find_without_delimiters find (ntn_scope,ntn) = function | OpenScopeItem scope :: scopes -> @@ -2353,8 +2354,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..8edf916a7a 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 @@ -1092,16 +1171,6 @@ module FNativeEntries = fNInf := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cNInf) }; fNaN := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cNaN) }; | None -> defined_f_class := false - let defined_refl = ref false - - let frefl = ref dummy - - let init_refl retro = - match retro.Retroknowledge.retro_refl with - | Some crefl -> - defined_refl := true; - frefl := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs crefl) } - | None -> defined_refl := false let defined_array = ref false @@ -1118,7 +1187,6 @@ module FNativeEntries = init_cmp !current_retro; init_f_cmp !current_retro; init_f_class !current_retro; - init_refl !current_retro; init_array !current_retro let check_env env = @@ -1269,7 +1337,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 +1357,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 +1415,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 +1467,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 +1486,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 +1505,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 +1521,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/environ.ml b/kernel/environ.ml index 6f2aeab203..63fbaa6a3b 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -571,6 +571,12 @@ let is_primitive env c = | Declarations.Primitive _ -> true | _ -> false +let get_primitive env c = + let cb = lookup_constant c env in + match cb.Declarations.const_body with + | Declarations.Primitive p -> Some p + | _ -> None + let is_int63_type env c = match env.retroknowledge.Retroknowledge.retro_int63 with | None -> false diff --git a/kernel/environ.mli b/kernel/environ.mli index dfd9173d10..414ef2b4d7 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -248,6 +248,7 @@ val constant_type_in : env -> Constant.t puniverses -> types val constant_opt_value_in : env -> Constant.t puniverses -> constr option val is_primitive : env -> Constant.t -> bool +val get_primitive : env -> Constant.t -> CPrimitives.t option val is_array_type : env -> Constant.t -> bool val is_int63_type : env -> Constant.t -> bool 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/retroknowledge.ml b/kernel/retroknowledge.ml index f7c4b62d1f..505f6c648d 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -35,7 +35,6 @@ type retroknowledge = { (* PNormal, NNormal, PSubn, NSubn, PZero, NZero, PInf, NInf, NaN *) - retro_refl : constructor option } let empty = { @@ -48,7 +47,6 @@ let empty = { retro_cmp = None; retro_f_cmp = None; retro_f_class = None; - retro_refl = None; } type action = diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index fd412cdd0a..80c0baaf95 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -29,7 +29,6 @@ type retroknowledge = { (* PNormal, NNormal, PSubn, NSubn, PZero, NZero, PInf, NInf, NaN *) - retro_refl : constructor option } val empty : retroknowledge 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/cc/cctac.ml b/plugins/cc/cctac.ml index 499c9684b2..72f77508d8 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -420,7 +420,7 @@ let cc_tactic depth additionnal_terms = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in Coqlib.(check_required_library logic_module_name); - let _ = debug (fun () -> Pp.str "Reading subgoal ...") in + let _ = debug (fun () -> Pp.str "Reading goal ...") in let state = make_prb gl depth additionnal_terms in let _ = debug (fun () -> Pp.str "Problem built, solving ...") in let sol = execute true state in 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..d9da47134d 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -299,7 +299,7 @@ TACTIC EXTEND rewrite_star { -let add_rewrite_hint ~poly bases ort t lcsr = +let add_rewrite_hint ~locality ~poly bases ort t lcsr = let env = Global.env() in let sigma = Evd.from_env env in let f ce = @@ -315,7 +315,7 @@ let add_rewrite_hint ~poly bases ort t lcsr = in CAst.make ?loc:(Constrexpr_ops.constr_loc ce) ((c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t) in let eqs = List.map f lcsr in - let add_hints base = add_rew_rules base eqs in + let add_hints base = add_rew_rules ~locality base eqs in List.iter add_hints bases let classify_hint _ = VtSideff ([], VtLater) @@ -323,15 +323,15 @@ let classify_hint _ = VtSideff ([], VtLater) } VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY { classify_hint } -| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> - { add_rewrite_hint ~poly:polymorphic bl o None l } -| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) +| #[ polymorphic; locality = option_locality; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> + { add_rewrite_hint ~locality ~poly:polymorphic bl o None l } +| #[ polymorphic; locality = option_locality; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ":" preident_list(bl) ] -> - { add_rewrite_hint ~poly:polymorphic bl o (Some t) l } -| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> - { add_rewrite_hint ~poly:polymorphic ["core"] o None l } -| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> - { add_rewrite_hint ~poly:polymorphic ["core"] o (Some t) l } + { add_rewrite_hint ~locality ~poly:polymorphic bl o (Some t) l } +| #[ polymorphic; locality = option_locality; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> + { add_rewrite_hint ~locality ~poly:polymorphic ["core"] o None l } +| #[ polymorphic; locality = option_locality; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> + { add_rewrite_hint ~locality ~poly:polymorphic ["core"] o (Some t) l } END (**********************************************************************) @@ -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_auto.mlg b/plugins/ltac/g_auto.mlg index 069a342b2a..82b41e41bd 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -11,7 +11,6 @@ { open Pp -open Constr open Stdarg open Pcoq.Prim open Pcoq.Constr @@ -199,20 +198,6 @@ TACTIC EXTEND unify END { -let deprecated_convert_concl_no_check = - CWarnings.create - ~name:"convert_concl_no_check" ~category:"deprecated" - (fun () -> Pp.str "The syntax [convert_concl_no_check] is deprecated. Use [change_no_check] instead.") -} - -TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> { - deprecated_convert_concl_no_check (); - Tactics.convert_concl ~check:false x DEFAULTcast - } -END - -{ let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_qualid let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global 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/micromega/g_zify.mlg b/plugins/micromega/g_zify.mlg index 0e5cac2d4a..74b0708743 100644 --- a/plugins/micromega/g_zify.mlg +++ b/plugins/micromega/g_zify.mlg @@ -19,12 +19,6 @@ let warn_deprecated_Spec = (fun () -> Pp.strbrk ("Show Zify Spec is deprecated. Use either \"Show Zify BinOpSpec\" or \"Show Zify UnOpSpec\".")) -let warn_deprecated_Add = - CWarnings.create ~name:"deprecated-Zify-Add" ~category:"deprecated" - (fun () -> - Pp.strbrk ("Add <X> is deprecated. Use instead Add Zify <X>.")) - - } DECLARE PLUGIN "zify_plugin" @@ -41,17 +35,6 @@ VERNAC COMMAND EXTEND DECLAREINJECTION CLASSIFIED AS SIDEFF | ["Add" "Zify" "BinOpSpec" constr(t) ] -> { Zify.BinOpSpec.register t } | ["Add" "Zify" "UnOpSpec" constr(t) ] -> { Zify.UnOpSpec.register t } | ["Add" "Zify" "Saturate" constr(t) ] -> { Zify.Saturate.register t } -| ["Add" "InjTyp" constr(t) ] -> { warn_deprecated_Add (); Zify.InjTable.register t } -| ["Add" "BinOp" constr(t) ] -> { warn_deprecated_Add (); Zify.BinOp.register t } -| ["Add" "UnOp" constr(t) ] -> { warn_deprecated_Add (); Zify.UnOp.register t } -| ["Add" "CstOp" constr(t) ] -> { warn_deprecated_Add (); Zify.CstOp.register t } -| ["Add" "BinRel" constr(t) ] -> { warn_deprecated_Add (); Zify.BinRel.register t } -| ["Add" "PropOp" constr(t) ] -> { warn_deprecated_Add (); Zify.PropBinOp.register t } -| ["Add" "PropBinOp" constr(t) ] -> { warn_deprecated_Add (); Zify.PropBinOp.register t } -| ["Add" "PropUOp" constr(t) ] -> { warn_deprecated_Add (); Zify.PropUnOp.register t } -| ["Add" "BinOpSpec" constr(t) ] -> { warn_deprecated_Add (); Zify.BinOpSpec.register t } -| ["Add" "UnOpSpec" constr(t) ] -> { warn_deprecated_Add (); Zify.UnOpSpec.register t } -| ["Add" "Saturate" constr(t) ] -> { warn_deprecated_Add (); Zify.Saturate.register t } END TACTIC EXTEND ITER @@ -73,7 +56,4 @@ VERNAC COMMAND EXTEND ZifyPrint CLASSIFIED AS SIDEFF |[ "Show" "Zify" "BinRel"] -> { Zify.BinRel.print () } |[ "Show" "Zify" "UnOpSpec"] -> { Zify.UnOpSpec.print() } |[ "Show" "Zify" "BinOpSpec"] -> { Zify.BinOpSpec.print() } -|[ "Show" "Zify" "Spec"] -> { - warn_deprecated_Spec () ; - Zify.UnOpSpec.print() ; Zify.BinOpSpec.print ()} END diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index cbc352126e..c822675589 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -40,7 +40,7 @@ let tclPERM perm tac = let rot_hyps dir i hyps = let n = List.length hyps in if i = 0 then List.rev hyps else - if i > n then CErrors.user_err (Pp.str "Not enough subgoals") else + if i > n then CErrors.user_err (Pp.str "Not enough goals") else let rec rot i l_hyps = function | hyp :: hyps' when i > 0 -> rot (i - 1) (hyp :: l_hyps) hyps' | hyps' -> hyps' @ (List.rev l_hyps) in 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..15d1ddb4ec 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -351,9 +351,10 @@ 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'|]) -> - 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 + | PIf (a1,b1,b1'), Case (ci, u2, pms2, p2, iv, a2, ([|b2;b2'|] as br2)) -> + let (_, _, _, p2, _, _, br2) = EConstr.annotate_case env sigma (ci, u2, pms2, p2, iv, a2, br2) in + let ctx_b2,b2 = br2.(0) in + let ctx_b2',b2' = br2.(1) in let n = Context.Rel.length ctx_b2 in let n' = Context.Rel.length ctx_b2' in if Vars.noccur_between sigma 1 n b2 && Vars.noccur_between sigma 1 n' b2' then @@ -367,7 +368,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 (_, _, _, p2, _, _, br2) = EConstr.annotate_case env sigma (ci2, u2, pms2, p2, iv, a2, br2) in let n2 = Array.length br2 in let () = match ci1.cip_ind with | None -> () @@ -380,14 +382,37 @@ let matches_core env sigma allow_bound_rels if not ci1.cip_extensible && not (Int.equal (List.length br1) n2) then raise PatternMatchingFailure in + let sorec_under_ctx subst (n, c1) (decls, c2) = + let env = push_rel_context decls env in + let rec fold (ctx, subst) nas decls = match nas, decls with + | [], _ -> + (* Historical corner case: less bound variables are allowed in + destructuring let-bindings. See #13735. *) + (ctx, subst) + | na1 :: nas, d :: decls -> + let na2 = Context.Rel.Declaration.get_annot d in + let t = Context.Rel.Declaration.get_type d in + let ctx = push_binder na1 na2 t ctx in + let subst = add_binders na1 na2 binding_vars subst in + fold (ctx, subst) nas decls + | _, [] -> + assert false + in + let ctx, subst = fold (ctx, subst) (Array.to_list n) (List.rev decls) in + sorec ctx env subst c1 c2 + in let chk_branch subst (j,n,c) = (* (ind,j+1) is normally known to be a correct constructor and br2 a correct match over the same inductive *) assert (j < n2); - sorec ctx env subst c br2.(j) + sorec_under_ctx subst (n, c) br2.(j) + in + let subst = sorec ctx env subst a1 a2 in + let subst = match p1 with + | None -> subst + | Some p1 -> sorec_under_ctx subst p1 p2 in - let chk_head = sorec ctx env (sorec ctx env subst a1 a2) p1 p2 in - List.fold_left chk_branch chk_head br1 + List.fold_left chk_branch subst br1 | PFix ((ln1,i1),(lna1,tl1,bl1)), Fix ((ln2,i2),(lna2,tl2,bl2)) when Array.equal Int.equal ln1 ln2 && i1 = i2 -> @@ -504,12 +529,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..722a0a2048 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 @@ -1105,18 +1160,3 @@ let rec subst_glob_constr env subst = DAst.map (function GArray(u,t',def',ty') ) - -(* Utilities to transform kernel cases to simple pattern-matching problem *) - -let simple_cases_matrix_of_branches ind brs = - List.map (fun (i,n,b) -> - let nal,c = it_destRLambda_or_LetIn_names n b in - let mkPatVar na = DAst.make @@ PatVar na in - let p = DAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in - let ids = List.map_filter Nameops.Name.to_option nal in - CAst.make @@ (ids,[p],c)) - brs - -let return_type_of_predicate ind nrealargs_tags pred = - let nal,p = it_destRLambda_or_LetIn_names (nrealargs_tags@[false]) pred in - (List.hd nal, Some (CAst.make (ind, List.tl nal))), Some p diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 254f772ff8..6d6f7fa97b 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -72,14 +72,6 @@ val lookup_index_as_renamed : env -> evar_map -> constr -> int -> int option val force_wildcard : unit -> bool val synthetize_type : unit -> bool -(** Utilities to transform kernel cases to simple pattern-matching problem *) - -val it_destRLambda_or_LetIn_names : bool list -> glob_constr -> Name.t list * glob_constr -val simple_cases_matrix_of_branches : - inductive -> (int * bool list * glob_constr) list -> cases_clauses -val return_type_of_predicate : - inductive -> bool list -> glob_constr -> predicate_pattern * glob_constr option - val subst_genarg_hook : (substitution -> Genarg.glob_generic_argument -> Genarg.glob_generic_argument) Hook.t 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/pattern.ml b/pretyping/pattern.ml index f6d61f4892..553511f1bf 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -18,7 +18,6 @@ type patvar = Id.t type case_info_pattern = { cip_style : Constr.case_style; cip_ind : inductive option; - cip_ind_tags : bool list option; (** indicates LetIn/Lambda in arity *) cip_extensible : bool (** does this match end with _ => _ ? *) } type constr_pattern = @@ -35,8 +34,8 @@ type constr_pattern = | PSort of Sorts.family | PMeta of patvar option | PIf of constr_pattern * constr_pattern * constr_pattern - | PCase of case_info_pattern * constr_pattern * constr_pattern * - (int * bool list * constr_pattern) list (** index of constructor, nb of args *) + | PCase of case_info_pattern * (Name.t array * constr_pattern) option * constr_pattern * + (int * Name.t array * constr_pattern) list (** index of constructor, nb of args *) | PFix of (int array * int) * (Name.t array * constr_pattern array * constr_pattern array) | PCoFix of int * (Name.t array * constr_pattern array * constr_pattern array) | PInt of Uint63.t diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index b259945d9e..0c4bbf71e2 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -24,7 +24,6 @@ open Environ let case_info_pattern_eq i1 i2 = i1.cip_style == i2.cip_style && Option.equal Ind.CanOrd.equal i1.cip_ind i2.cip_ind && - Option.equal (List.equal (==)) i1.cip_ind_tags i2.cip_ind_tags && i1.cip_extensible == i2.cip_extensible let rec constr_pattern_eq p1 p2 = match p1, p2 with @@ -51,7 +50,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with constr_pattern_eq t1 t2 && constr_pattern_eq l1 l2 && constr_pattern_eq r1 r2 | PCase (info1, p1, r1, l1), PCase (info2, p2, r2, l2) -> case_info_pattern_eq info1 info2 && - constr_pattern_eq p1 p2 && + Option.equal (fun (nas1, p1) (nas2, p2) -> Array.equal Name.equal nas1 nas2 && constr_pattern_eq p1 p2) p1 p2 && constr_pattern_eq r1 r2 && List.equal pattern_eq l1 l2 | PFix ((ln1,i1),f1), PFix ((ln2,i2),f2) -> @@ -74,7 +73,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with (** FIXME: fixpoint and cofixpoint should be relativized to pattern *) and pattern_eq (i1, j1, p1) (i2, j2, p2) = - Int.equal i1 i2 && List.equal (==) j1 j2 && constr_pattern_eq p1 p2 + Int.equal i1 i2 && Array.equal Name.equal j1 j2 && constr_pattern_eq p1 p2 and rec_declaration_eq (n1, c1, r1) (n2, c2, r2) = Array.equal Name.equal n1 n2 && @@ -92,8 +91,8 @@ let rec occur_meta_pattern = function | PIf (c,c1,c2) -> (occur_meta_pattern c) || (occur_meta_pattern c1) || (occur_meta_pattern c2) - | PCase(_,p,c,br) -> - (occur_meta_pattern p) || + | PCase(_, p,c,br) -> + Option.cata (fun (_, p) -> occur_meta_pattern p) false p || (occur_meta_pattern c) || (List.exists (fun (_,_,p) -> occur_meta_pattern p) br) | PArray (t,def,ty) -> @@ -115,10 +114,10 @@ let rec occurn_pattern n = function | PIf (c,c1,c2) -> (occurn_pattern n c) || (occurn_pattern n c1) || (occurn_pattern n c2) - | PCase(_,p,c,br) -> - (occurn_pattern n p) || + | PCase(_, p, c, br) -> + Option.cata (fun (nas, p) -> occurn_pattern (Array.length nas + n) p) false p || (occurn_pattern n c) || - (List.exists (fun (_,_,p) -> occurn_pattern n p) br) + (List.exists (fun (_, nas, p) -> occurn_pattern (Array.length nas + n) p) br) | PMeta _ | PSoApp _ -> true | PEvar (_,args) -> List.exists (occurn_pattern n) args | PVar _ | PRef _ | PSort _ | PInt _ | PFloat _ -> false @@ -202,18 +201,26 @@ 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, p0, iv, a, br0) -> + let (ci, p, iv, a, br) = Inductive.expand_case env (ci, u, pms, p0, iv, a, br0) in + let pattern_of_ctx c (nas, c0) = + let ctx, c = Term.decompose_lam_n_decls (Array.length nas) c in + let env = push_rel_context ctx env in + let c = pattern_of_constr env c in + (Array.map Context.binder_name nas, c) + in + let p = pattern_of_ctx p p0 in let cip = { cip_style = ci.ci_pp_info.style; cip_ind = Some ci.ci_ind; - cip_ind_tags = Some ci.ci_pp_info.ind_tags; cip_extensible = false } in let branch_of_constr i c = - (i, ci.ci_pp_info.cstr_tags.(i), pattern_of_constr env c) + let nas, c = pattern_of_ctx c br0.(i) in + (i, nas, c) in - PCase (cip, pattern_of_constr env p, pattern_of_constr env a, - Array.to_list (Array.mapi branch_of_constr br)) + PCase (cip, Some p, pattern_of_constr env a, + 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 @@ -241,7 +248,10 @@ let map_pattern_with_binders g f l = function | PLetIn (n,a,t,b) -> PLetIn (n,f l a,Option.map (f l) t,f (g n l) b) | PIf (c,b1,b2) -> PIf (f l c,f l b1,f l b2) | PCase (ci,po,p,pl) -> - PCase (ci,f l po,f l p, List.map (fun (i,n,c) -> (i,n,f l c)) pl) + let fold nas l = Array.fold_left (fun l na -> g na l) l nas in + let map_branch (i, n, c) = (i, n, f (fold n l) c) in + let po = Option.map (fun (nas, po) -> nas, (f (fold nas l) po)) po in + PCase (ci,po,f l p, List.map map_branch pl) | PProj (p,pc) -> PProj (p, f l pc) | PFix (lni,(lna,tl,bl)) -> let l' = Array.fold_left (fun l na -> g na l) l lna in @@ -351,7 +361,11 @@ let rec subst_pattern env sigma subst pat = let ind = cip.cip_ind in let ind' = Option.Smart.map (subst_ind subst) ind in let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in - let typ' = subst_pattern env sigma subst typ in + let map ((nas, typ) as t) = + let typ' = subst_pattern env sigma subst typ in + if typ' == typ then t else (nas, typ') + in + let typ' = Option.Smart.map map typ in let c' = subst_pattern env sigma subst c in let subst_branch ((i,n,c) as br) = let c' = subst_pattern env sigma subst c in @@ -381,8 +395,6 @@ let rec subst_pattern env sigma subst pat = let mkPLetIn na b t c = PLetIn(na,b,t,c) let mkPProd na t u = PProd(na,t,u) let mkPLambda na t b = PLambda(na,t,b) -let mkPLambdaUntyped na b = PLambda(na,PMeta None,b) -let rev_it_mkPLambdaUntyped = List.fold_right mkPLambdaUntyped let mkPProd_or_LetIn (na,_,bo,t) c = match bo with @@ -445,18 +457,14 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function PIf (pat_of_raw metas vars c, pat_of_raw metas vars b1,pat_of_raw metas vars b2) | GLetTuple (nal,(_,None),b,c) -> - let mkGLambda na c = DAst.make ?loc @@ - GLambda (na,Explicit, DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None),c) in - let c = List.fold_right mkGLambda nal c in let cip = { cip_style = LetStyle; cip_ind = None; - cip_ind_tags = None; cip_extensible = false } in - let tags = List.map (fun _ -> false) nal (* Approximation which can be without let-ins... *) in - PCase (cip, PMeta None, pat_of_raw metas vars b, - [0,tags,pat_of_raw metas vars c]) + let tags = Array.of_list nal (* Approximation which can be without let-ins... *) in + PCase (cip, None, pat_of_raw metas vars b, + [0,tags,pat_of_raw metas (List.rev_append (Array.to_list tags) vars) c]) | GCases (sty,p,[c,(na,indnames)],brs) -> let get_ind p = match DAst.get p with | PatCstr((ind,_),_,_) -> Some ind @@ -475,18 +483,17 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function let pred = match p,indnames with | Some p, Some {CAst.v=(_,nal)} -> let nvars = na :: List.rev nal @ vars in - rev_it_mkPLambdaUntyped nal (mkPLambdaUntyped na (pat_of_raw metas nvars p)) - | None, _ -> PMeta None + Some (Array.rev_of_list (na :: List.rev nal), pat_of_raw metas nvars p) + | None, _ -> None | Some p, None -> match DAst.get p with - | GHole _ -> PMeta None + | GHole _ -> None | _ -> user_err ?loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") in let info = { cip_style = sty; cip_ind = ind; - cip_ind_tags = None; cip_extensible = ext } in (* Nota : when we have a non-trivial predicate, @@ -555,10 +562,10 @@ and pats_of_glob_branches loc metas vars ind brs = err ?loc (str "No unique branch for " ++ int j ++ str"-th constructor."); let lna = List.map get_arg lv in - let vars' = List.rev lna @ vars in - let pat = rev_it_mkPLambdaUntyped lna (pat_of_raw metas vars' br) in + let vars' = List.rev_append lna vars in + let tags = Array.of_list lna in + let pat = pat_of_raw metas vars' br in let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in - let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in ext, ((j-1, tags, pat) :: pats) | _ -> err ?loc:loc' (Pp.str "Non supported pattern.") 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..54a47a252d 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) @@ -461,23 +468,6 @@ let safe_meta_value sigma ev = try Some (Evd.meta_value sigma ev) with Not_found -> None -let strong_with_flags whdfun flags env sigma t = - let push_rel_check_zeta d env = - let open CClosure.RedFlags in - let d = match d with - | LocalDef (na,c,t) when not (red_set flags fZETA) -> LocalAssum (na,t) - | d -> d in - push_rel d env in - let rec strongrec env t = - map_constr_with_full_binders 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 - strongrec env t - (*************************************) (*** Reduction using bindingss ***) (*************************************) @@ -702,6 +692,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 +789,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 +798,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 +855,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 +887,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 +901,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 -> @@ -955,6 +961,9 @@ let whd_betalet = red_of_state_red whd_betalet_state (* 2. Delta Reduction Functions *) +let whd_const_state c e = raw_whd_state_gen CClosure.RedFlags.(mkflags [fCONST c]) e +let whd_const c = red_of_state_red (whd_const_state c) + let whd_delta_state e = raw_whd_state_gen CClosure.delta e let whd_delta_stack = stack_red_of_state_red whd_delta_state let whd_delta = red_of_state_red whd_delta_state @@ -1258,7 +1267,9 @@ let plain_instance sigma s c = match s with let instance env sigma s c = (* if s = [] then c else *) - strong whd_betaiota env sigma (plain_instance sigma s c) + (* No need to compute contexts under binders as whd_betaiota is local *) + let rec strongrec t = EConstr.map sigma strongrec (whd_betaiota env sigma t) in + strongrec (plain_instance sigma s c) (* pseudo-reduction rule: * [hnf_prod_app env s (Prod(_,B)) N --> B[N] diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index ae93eb48b4..41d16f1c3c 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 @@ -140,13 +143,6 @@ type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type stack_reduction_function = env -> evar_map -> constr -> constr * constr list -(** {6 Reduction Function Operators } *) - -val strong_with_flags : - (CClosure.RedFlags.reds -> reduction_function) -> - (CClosure.RedFlags.reds -> reduction_function) -val strong : reduction_function -> reduction_function - (** {6 Generic Optimized Reduction Function using Closures } *) val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function @@ -182,6 +178,7 @@ val whd_betalet_stack : stack_reduction_function (** {6 Head normal forms } *) +val whd_const : Constant.t -> reduction_function val whd_delta_stack : stack_reduction_function val whd_delta : reduction_function val whd_betadeltazeta_stack : stack_reduction_function 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..a103699716 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -68,8 +68,7 @@ let error_not_evaluable r = spc () ++ str "to an evaluable reference.") let is_evaluable_const env cst = - is_transparent env (ConstKey cst) && - (evaluable_constant cst env || is_primitive env cst) + is_transparent env (ConstKey cst) && evaluable_constant cst env let is_evaluable_var env id = is_transparent env (VarKey id) && evaluable_named id env @@ -163,6 +162,10 @@ let reference_value env sigma c u = | None -> raise NotEvaluable | Some d -> d +let is_primitive_val sigma c = match EConstr.kind sigma c with + | Int _ | Float _ | Array _ -> true + | _ -> false + (************************************************************************) (* Reduction of constants hiding a fixpoint (e.g. for "simpl" tactic). *) (* One reuses the name of the function after reduction of the fixpoint *) @@ -296,8 +299,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 +481,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 +536,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 @@ -708,7 +717,8 @@ and reduce_params env sigma stack l = let arg = List.nth stack i in let rarg = whd_construct_stack env sigma arg in match EConstr.kind sigma (fst rarg) with - | Construct _ -> List.assign stack i (applist rarg) + | Construct _ | Int _ | Float _ | Array _ -> + List.assign stack i (applist rarg) | _ -> raise Redelimination) stack l @@ -728,9 +738,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 -> @@ -764,6 +774,16 @@ and whd_simpl_stack env sigma = else s' with Redelimination -> s') + | Const (cst, _) when is_primitive env cst -> + (try + let args = + List.map_filter_i (fun i a -> + match a with CPrimitives.Kwhnf -> Some i | _ -> None) + (CPrimitives.kind (Option.get (get_primitive env cst))) in + let stack = reduce_params env sigma stack args in + whd_const cst env sigma (applist (x, stack)), [] + with Redelimination -> s') + | _ -> match match_eval_ref env sigma x stack with | Some (ref, u) -> @@ -842,15 +862,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,25 +880,25 @@ 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 in redrec (push_app sigma (c, [])) -(* reduce until finding an applied constructor or fail *) +(* reduce until finding an applied constructor (or primitive value) or fail *) and whd_construct_stack env sigma s = let (constr, cargs as s') = whd_simpl_stack env sigma (s, []) in - if reducible_mind_case sigma constr then s' + if reducible_mind_case sigma constr || is_primitive_val sigma constr then s' else match match_eval_ref env sigma constr cargs with | Some (ref, u) -> (match reference_opt_value env sigma ref u with @@ -915,7 +935,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 @@ -1034,7 +1054,10 @@ let hnf_constr env sigma c = whd_simpl_orelse_delta_but_fix env sigma (c, []) let whd_simpl env sigma c = applist (whd_simpl_stack env sigma (c, [])) -let simpl env sigma c = strong whd_simpl env sigma c +let simpl env sigma c = + let rec strongrec env t = + map_constr_with_full_binders env sigma push_rel strongrec env (whd_simpl env sigma t) in + strongrec env c (* Reduction at specific subterms *) @@ -1062,7 +1085,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 +1154,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 +1318,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/printing/printer.ml b/printing/printer.ml index 1425cebafc..ca9dee2df6 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -480,7 +480,7 @@ let pr_goal_name sigma g = let pr_goal_header nme sigma g = let (g,sigma) = Goal.V82.nf_evar sigma g in - str "subgoal " ++ nme ++ (if should_tag() then pr_goal_tag g else str"") + str "goal " ++ nme ++ (if should_tag() then pr_goal_tag g else str"") ++ (if should_gname() then str " " ++ Pp.surround (pr_existential_key sigma g) else mt ()) (* display the conclusion of a goal *) @@ -753,10 +753,10 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map | [] -> let exl = Evd.undefined_map sigma in if Evar.Map.is_empty exl then - v 0 (str "No more subgoals." ++ pr_evar_info None sigma seeds) + v 0 (str "No more goals." ++ pr_evar_info None sigma seeds) else let pei = pr_evars_int sigma ~shelf ~given_up:[] 1 exl in - v 0 ((str "No more subgoals," + v 0 ((str "No more goals," ++ str " but there are non-instantiated existential variables:" ++ cut () ++ (hov 0 pei) ++ pr_evar_info None sigma seeds @@ -765,9 +765,9 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map let goals = print_multiple_goals g1 rest in let ngoals = List.length rest+1 in v 0 ( - int ngoals ++ focused_if_needed ++ str(String.plural ngoals "subgoal") + int ngoals ++ focused_if_needed ++ str(String.plural ngoals "goal") ++ print_extra - ++ str (if pr_first && (should_gname()) && ngoals > 1 then ", subgoal 1" else "") + ++ str (if pr_first && (should_gname()) && ngoals > 1 then ", goal 1" else "") ++ (if pr_first && should_tag() then pr_goal_tag g1 else str"") ++ (if pr_first then pr_goal_name sigma g1 else mt()) ++ cut () ++ goals ++ (if unfocused=[] then str "" @@ -792,7 +792,7 @@ let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?oproof proof = begin match bgoals,shelf,given_up with | [] , [] , g when Evar.Set.is_empty g -> pr_subgoals None sigma ~seeds ~shelf ~stack ~unfocused:[] ~goals | [] , [] , _ -> - Feedback.msg_info (str "No more subgoals, but there are some goals you gave up:"); + Feedback.msg_info (str "No more goals, but there are some goals you gave up:"); fnl () ++ pr_subgoals ~pr_first:false None bsigma ~seeds ~shelf:[] ~stack:[] ~unfocused:[] ~goals:(Evar.Set.elements given_up) ++ fnl () ++ str "You need to go back and solve them." 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/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index 41cb7399da..dc5a1b0ac2 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -68,7 +68,7 @@ module Strict = struct match sugg with | NeedClosingBrace -> Pp.(str"Try unfocusing with \"}\".") | NoBulletInUse -> assert false (* This should never raise an error. *) - | ProofFinished -> Pp.(str"No more subgoals.") + | ProofFinished -> Pp.(str"No more goals.") | Suggest b -> Pp.(str"Expecting " ++ pr_bullet b ++ str".") | Unfinished b -> Pp.(str"Current bullet " ++ pr_bullet b ++ str" is not finished.") diff --git a/stm/partac.ml b/stm/partac.ml index 8232b017f9..6143ac450b 100644 --- a/stm/partac.ml +++ b/stm/partac.ml @@ -125,7 +125,7 @@ end = struct (* {{{ *) str" existentials remain unsolved: " ++ prlist (Termops.pr_existential_key sigma) (Evar.Set.elements evars)) ) with e when CErrors.noncritical e -> - RespError (CErrors.print e ++ spc() ++ str "(for subgoal "++int r_goalno ++ str ")") + RespError (CErrors.print e ++ spc() ++ str "(for goal "++int r_goalno ++ str ")") let name_of_task { t_name } = t_name let name_of_request { r_name } = r_name @@ -163,7 +163,7 @@ let enable_par ~nworkers = ComTactic.set_par_implementation let open TacTask in let results = (Proof.data p).Proof.goals |> CList.map_i (fun i g -> let g_solution, t_assign = - Future.create_delegate ~name:(Printf.sprintf "subgoal %d" i) + Future.create_delegate ~name:(Printf.sprintf "goal %d" i) (fun x -> x) in TaskQueue.enqueue_task queue ~cancel_switch:(ref false) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index cc56de066d..1d876537ef 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -206,9 +206,15 @@ let subst_hintrewrite (subst,(rbase,list as node)) = (rbase,list') (* Declaration of the Hint Rewrite library object *) -let inHintRewrite : string * HintDN.t -> Libobject.obj = +let inGlobalHintRewrite : string * HintDN.t -> Libobject.obj = let open Libobject in - declare_object @@ superglobal_object_nodischarge "HINT_REWRITE" + declare_object @@ superglobal_object_nodischarge "HINT_REWRITE_GLOBAL" + ~cache:cache_hintrewrite + ~subst:(Some subst_hintrewrite) + +let inExportHintRewrite : string * HintDN.t -> Libobject.obj = + let open Libobject in + declare_object @@ global_object_nodischarge "HINT_REWRITE_EXPORT" ~cache:cache_hintrewrite ~subst:(Some subst_hintrewrite) @@ -250,7 +256,8 @@ let find_applied_relation ?loc env sigma c left2right = spc () ++ str"of this term does not end with an applied relation.") (* To add rewriting rules to a base *) -let add_rew_rules base lrul = +let add_rew_rules ~locality base lrul = + let () = Hints.check_hint_locality locality in let counter = ref 0 in let env = Global.env () in let sigma = Evd.from_env env in @@ -267,5 +274,9 @@ let add_rew_rules base lrul = rew_tac = Option.map intern t} in incr counter; HintDN.add pat (!counter, rul) dn) HintDN.empty lrul - in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) - + in + let open Goptions in + match locality with + | OptLocal -> cache_hintrewrite ((),(base,lrul)) + | OptDefault | OptGlobal -> Lib.add_anonymous_leaf (inGlobalHintRewrite (base,lrul)) + | OptExport -> Lib.add_anonymous_leaf (inExportHintRewrite (base,lrul)) diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index 974aef8e8f..dec6cc5ef4 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -17,7 +17,7 @@ open Equality type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) CAst.t (** To add rewriting rules to a base *) -val add_rew_rules : string -> raw_rew_rule list -> unit +val add_rew_rules : locality:Goptions.option_locality -> string -> raw_rew_rule list -> unit (** The AutoRewrite tactic. The optional conditions tell rewrite how to handle matching and side-condition solving. diff --git a/tactics/cbn.ml b/tactics/cbn.ml index 31873ea6b0..6fb6cff04f 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 -> @@ -796,3 +820,15 @@ let whd_cbn flags env sigma t = (whd_state_gen ~refold:true ~tactic_mode:true flags env sigma (t, Stack.empty)) in Stack.zip ~refold:true sigma state + +let norm_cbn flags env sigma t = + let push_rel_check_zeta d env = + let open CClosure.RedFlags in + let d = match d with + | LocalDef (na,c,t) when not (red_set flags fZETA) -> LocalAssum (na,t) + | d -> d in + push_rel d env in + let rec strongrec env t = + map_constr_with_full_binders env sigma + push_rel_check_zeta strongrec env (whd_cbn flags env sigma t) in + strongrec env t diff --git a/tactics/cbn.mli b/tactics/cbn.mli index af54771382..a02a74f9e4 100644 --- a/tactics/cbn.mli +++ b/tactics/cbn.mli @@ -8,6 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(** Weak-head cbn reduction. Despite the name, the cbn reduction is a complex + reduction distinct from call-by-name or call-by-need. *) val whd_cbn : CClosure.RedFlags.reds -> Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr + +(** Strong variant of cbn reduction. *) +val norm_cbn : + CClosure.RedFlags.reds -> + Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr 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..058602acfd 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 @@ -1187,6 +1187,28 @@ let create_hint_db l n st b = let hint = make_hint ~local:l n (CreateDB (b, st)) in Lib.add_anonymous_leaf (inAutoHint hint) +let warn_deprecated_hint_without_locality = + CWarnings.create ~name:"deprecated-hint-without-locality" ~category:"deprecated" + (fun () -> strbrk "The default value for hint locality is currently \ + \"local\" in a section and \"global\" otherwise, but is scheduled to change \ + in a future release. For the time being, adding hints outside of sections \ + without specifying an explicit locality is therefore deprecated. It is \ + recommended to use \"export\" whenever possible.") + +let check_hint_locality = let open Goptions in function +| OptGlobal -> + if Global.sections_are_opened () then + CErrors.user_err Pp.(str + "This command does not support the global attribute in sections."); +| OptExport -> + if Global.sections_are_opened () then + CErrors.user_err Pp.(str + "This command does not support the export attribute in sections."); +| OptDefault -> + if not @@ Global.sections_are_opened () then + warn_deprecated_hint_without_locality () +| OptLocal -> () + let interp_locality = function | Goptions.OptDefault | Goptions.OptGlobal -> false, true | Goptions.OptExport -> false, false diff --git a/tactics/hints.mli b/tactics/hints.mli index f5947bb946..381c7a1951 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -182,6 +182,8 @@ val searchtable_map : hint_db_name -> hint_db val searchtable_add : (hint_db_name * hint_db) -> unit +val check_hint_locality : Goptions.option_locality -> unit + (** [create_hint_db local name st use_dn]. [st] is a transparency state for unification using this db [use_dn] switches the use of the discrimination net for all hints diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml index b415b30de8..87cae3abe5 100644 --- a/tactics/redexpr.ml +++ b/tactics/redexpr.ml @@ -46,9 +46,6 @@ let cbv_native env sigma c = let whd_cbn = Cbn.whd_cbn -let strong_cbn flags = - strong_with_flags whd_cbn flags - let simplIsCbn = Goptions.declare_bool_option_and_ref ~depr:false ~key:["SimplIsCbn"] ~value:false @@ -248,11 +245,11 @@ let reduction_of_red_expr_val = function | Hnf -> (e_red hnf_constr,DEFAULTcast) | Simpl (f,o) -> let whd_am = if simplIsCbn () then whd_cbn f else whd_simpl in - let am = if simplIsCbn () then strong_cbn f else simpl in + let am = if simplIsCbn () then Cbn.norm_cbn f else simpl in (contextualize (if head_style then whd_am else am) am o,DEFAULTcast) | Cbv f -> (e_red (cbv_norm_flags f),DEFAULTcast) | Cbn f -> - (e_red (strong_cbn f), DEFAULTcast) + (e_red (Cbn.norm_cbn f), DEFAULTcast) | Lazy f -> (e_red (clos_norm_flags f),DEFAULTcast) | Unfold ubinds -> (e_red (unfoldn (List.map out_with_occurrences ubinds)),DEFAULTcast) | Fold cl -> (e_red (fold_commands cl),DEFAULTcast) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 39c5c9562f..cbf12ac22f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -156,9 +156,6 @@ let convert_hyp ~check ~reorder d = end end -let convert_concl_no_check = convert_concl ~check:false -let convert_hyp_no_check = convert_hyp ~check:false ~reorder:false - let convert_gen pb x y = Proofview.Goal.enter begin fun gl -> match Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y with @@ -1244,8 +1241,6 @@ let force_destruction_arg with_evars env sigma c = (* tactic "cut" (actually modus ponens) *) (****************************************) -let normalize_cut = false - let cut c = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -1260,8 +1255,6 @@ let cut c = | sigma, s -> let r = Sorts.relevance_of_sort s in let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_set_of_hyps gl) in - (* Backward compat: normalize [c]. *) - let c = if normalize_cut then strong whd_betaiota env sigma c else c in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Refine.refine ~typecheck:false begin fun h -> let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c r (Vars.lift 1 concl)) in @@ -1299,7 +1292,7 @@ let do_replace id = function [Ti] and the first one (resp last one) being [G] whose hypothesis [id] is replaced by P using the proof given by [tac] *) -let clenv_refine_in ?err with_evars targetid id sigma0 clenv tac = +let clenv_refine_in ?err with_evars targetid replace sigma0 clenv tac = let clenv = Clenv.clenv_pose_dependent_evars ~with_evars clenv in let evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd in let clenv = Clenv.update_clenv_evd clenv evd in @@ -1310,11 +1303,10 @@ let clenv_refine_in ?err with_evars targetid id sigma0 clenv tac = let new_hyp_prf = clenv_value clenv in let exact_tac = Logic.refiner ~check:false EConstr.Unsafe.(to_constr new_hyp_prf) in let naming = NamingMustBe (CAst.make targetid) in - let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS (clear_metas evd)) (Tacticals.New.tclTHENLAST - (assert_after_then_gen ?err with_clear naming new_hyp_typ tac) exact_tac) + (assert_after_then_gen ?err replace naming new_hyp_typ tac) exact_tac) (********************************************) (* Elimination tactics *) @@ -1365,7 +1357,7 @@ let elimination_in_clause_scheme env sigma with_evars ~flags if EConstr.eq_constr sigma hyp_typ new_hyp_typ then user_err ~hdr:"general_rewrite_in" (str "Nothing to rewrite in " ++ Id.print id ++ str"."); - clenv_refine_in with_evars id id sigma elimclause'' + clenv_refine_in with_evars id true sigma elimclause'' (fun id -> Proofview.tclUNIT ()) (* @@ -1814,6 +1806,7 @@ let apply_in_once ?(respect_opaque = false) with_delta let t' = Tacmach.New.pf_get_hyp_typ id gl in let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in let targetid = find_name true (LocalAssum (make_annot Anonymous Sorts.Relevant,t')) naming gl in + let replace = Id.equal id targetid in let rec aux ?err idstoclear with_destruct c = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -1826,7 +1819,7 @@ let apply_in_once ?(respect_opaque = false) with_delta if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in try let clause = apply_in_once_main flags innerclause env sigma (loc,c,lbind) in - clenv_refine_in ?err with_evars targetid id sigma clause + clenv_refine_in ?err with_evars targetid replace sigma clause (fun id -> replace_error_option err ( apply_clear_request clear_flag false c <*> @@ -2324,26 +2317,31 @@ let rewrite_hyp_then with_evars thin l2r id tac = tclEVARSTHEN sigma (Tacticals.New.tclTHENFIRST eqtac (tac thin)) end -let prepare_naming ?loc = function - | IntroIdentifier id -> NamingMustBe (CAst.make ?loc id) - | IntroAnonymous -> NamingAvoid Id.Set.empty - | IntroFresh id -> NamingBasedOn (id, Id.Set.empty) - -let rec explicit_intro_names = let open CAst in function -| {v=IntroForthcoming _} :: l -> explicit_intro_names l -| {v=IntroNaming (IntroIdentifier id)} :: l -> Id.Set.add id (explicit_intro_names l) +let rec collect_intro_names = let open CAst in function +| {v=IntroForthcoming _} :: l -> collect_intro_names l +| {v=IntroNaming (IntroIdentifier id)} :: l -> + let ids1, ids2 = collect_intro_names l in Id.Set.add id ids1, ids2 | {v=IntroAction (IntroOrAndPattern l)} :: l' -> let ll = match l with IntroAndPattern l -> [l] | IntroOrPattern ll -> ll in - let fold accu l = Id.Set.union accu (explicit_intro_names (l@l')) in - List.fold_left fold Id.Set.empty ll + let fold (ids1',ids2') l = + let ids1, ids2 = collect_intro_names (l@l') in + Id.Set.union ids1 ids1', Id.Set.union ids2 ids2' in + List.fold_left fold (Id.Set.empty,Id.Set.empty) ll | {v=IntroAction (IntroInjection l)} :: l' -> - explicit_intro_names (l@l') + collect_intro_names (l@l') | {v=IntroAction (IntroApplyOn (c,pat))} :: l' -> - explicit_intro_names (pat::l') -| {v=(IntroNaming (IntroAnonymous | IntroFresh _) + collect_intro_names (pat::l') +| {v=IntroNaming (IntroFresh id)} :: l -> + let ids1, ids2 = collect_intro_names l in ids1, Id.Set.add id ids2 +| {v=(IntroNaming IntroAnonymous | IntroAction (IntroWildcard | IntroRewrite _))} :: l -> - explicit_intro_names l -| [] -> Id.Set.empty + collect_intro_names l +| [] -> Id.Set.empty, Id.Set.empty + +let explicit_intro_names l = fst (collect_intro_names l) + +let explicit_all_intro_names l = + let ids1,ids2 = collect_intro_names l in Id.Set.union ids1 ids2 let rec check_name_unicity env ok seen = let open CAst in function | {v=IntroForthcoming _} :: l -> check_name_unicity env ok seen l @@ -2368,30 +2366,33 @@ let rec check_name_unicity env ok seen = let open CAst in function check_name_unicity env ok seen l | [] -> () -let wild_id = Id.of_string "_tmp" - -let rec list_mem_assoc_right id = function - | [] -> false - | {CAst.v=id'}::l -> Id.equal id id' || list_mem_assoc_right id l +let fresh_wild ids = + let rec aux s = + if Id.Set.exists (fun id -> String.is_prefix s (Id.to_string id)) ids + then aux (s ^ "'") + else Id.of_string s in + aux "_H" -let check_thin_clash_then id thin avoid tac = - if list_mem_assoc_right id thin then - let newid = next_ident_away (add_suffix id "'") avoid in - let thin = - List.map CAst.(map (fun id' -> if Id.equal id id' then newid else id')) thin in - Tacticals.New.tclTHEN (rename_hyp [id,newid]) (tac thin) - else - tac thin +let make_naming ?loc avoid l = function + | IntroIdentifier id -> NamingMustBe (CAst.make ?loc id) + | IntroAnonymous -> NamingAvoid (Id.Set.union avoid (explicit_intro_names l)) + | IntroFresh id -> NamingBasedOn (id, Id.Set.union avoid (explicit_intro_names l)) -let make_tmp_naming avoid l = function +let rec make_naming_action avoid l = function (* In theory, we could use a tmp id like "wild_id" for all actions but we prefer to avoid it to avoid this kind of "ugly" names *) - (* Alternatively, we could have called check_thin_clash_then on - IntroAnonymous, but at the cost of a "renaming"; Note that in the - case of IntroFresh, we should use check_thin_clash_then anyway to - prevent the case of an IntroFresh precisely using the wild_id *) - | IntroWildcard -> NamingBasedOn (wild_id, Id.Set.union avoid (explicit_intro_names l)) - | pat -> NamingAvoid(Id.Set.union avoid (explicit_intro_names ((CAst.make @@ IntroAction pat)::l))) + | IntroWildcard -> + NamingBasedOn (fresh_wild (Id.Set.union avoid (explicit_all_intro_names l)), Id.Set.empty) + | IntroApplyOn (_,{CAst.v=pat;loc}) -> make_naming_pattern avoid ?loc l pat + | (IntroOrAndPattern _ | IntroInjection _ | IntroRewrite _) as pat -> + NamingAvoid(Id.Set.union avoid (explicit_intro_names ((CAst.make @@ IntroAction pat)::l))) + +and make_naming_pattern ?loc avoid l = function + | IntroNaming pat -> make_naming ?loc avoid l pat + | IntroAction pat -> make_naming_action avoid l pat + | IntroForthcoming _ -> NamingAvoid (Id.Set.union avoid (explicit_intro_names l)) + +let prepare_naming ?loc pat = make_naming ?loc Id.Set.empty [] pat let fit_bound n = function | None -> true @@ -2430,38 +2431,21 @@ let rec intro_patterns_core with_evars avoid ids thin destopt bound n tac = [CAst.make @@ IntroNaming IntroAnonymous] | {CAst.loc;v=pat} :: l -> if exceed_bound n bound then error_unexpected_extra_pattern loc bound pat else + let naming = make_naming_pattern avoid l pat in match pat with | IntroForthcoming onlydeps -> - intro_forthcoming_then_gen (NamingAvoid (Id.Set.union avoid (explicit_intro_names l))) - destopt onlydeps bound n + intro_forthcoming_then_gen naming destopt onlydeps bound n (fun ids -> intro_patterns_core with_evars avoid ids thin destopt bound (n+List.length ids) tac l) | IntroAction pat -> - intro_then_gen (make_tmp_naming avoid l pat) - destopt true false + intro_then_gen naming destopt true false (intro_pattern_action ?loc with_evars pat thin destopt (fun thin bound' -> intro_patterns_core with_evars avoid ids thin destopt bound' 0 (fun ids thin -> intro_patterns_core with_evars avoid ids thin destopt bound (n+1) tac l))) | IntroNaming pat -> - intro_pattern_naming loc with_evars avoid ids pat thin destopt bound (n+1) tac l - - (* Pi-introduction rule, used backwards *) -and intro_pattern_naming loc with_evars avoid ids pat thin destopt bound n tac l = - match pat with - | IntroIdentifier id -> - check_thin_clash_then id thin avoid (fun thin -> - intro_then_gen (NamingMustBe CAst.(make ?loc id)) destopt true false - (fun id -> intro_patterns_core with_evars avoid (id::ids) thin destopt bound n tac l)) - | IntroAnonymous -> - intro_then_gen (NamingAvoid (Id.Set.union avoid (explicit_intro_names l))) - destopt true false - (fun id -> intro_patterns_core with_evars avoid (id::ids) thin destopt bound n tac l) - | IntroFresh id -> - (* todo: avoid thinned names to interfere with generation of fresh name *) - intro_then_gen (NamingBasedOn (id, Id.Set.union avoid (explicit_intro_names l))) - destopt true false - (fun id -> intro_patterns_core with_evars avoid (id::ids) thin destopt bound n tac l) + intro_then_gen naming destopt true false + (fun id -> intro_patterns_core with_evars avoid (id::ids) thin destopt bound (n+1) tac l) and intro_pattern_action ?loc with_evars pat thin destopt tac id = match pat with @@ -2474,24 +2458,16 @@ and intro_pattern_action ?loc with_evars pat thin destopt tac id = | IntroRewrite l2r -> rewrite_hyp_then with_evars thin l2r id (fun thin -> tac thin None []) | IntroApplyOn ({CAst.loc=loc';v=f},{CAst.loc;v=pat}) -> - let naming,tac_ipat = - prepare_intros ?loc with_evars (IntroIdentifier id) destopt pat in - let doclear = - if naming = NamingMustBe (CAst.make ?loc id) then - Proofview.tclUNIT () (* apply_in_once do a replacement *) - else - clear [id] in - let f env sigma = let (sigma, c) = f env sigma in (sigma,(c, NoBindings)) - in + let naming = NamingMustBe (CAst.make ?loc id) in + let tac_ipat = prepare_action ?loc with_evars destopt pat in + let f env sigma = let (sigma, c) = f env sigma in (sigma,(c, NoBindings)) in apply_in_delayed_once true true with_evars naming id (None,CAst.make ?loc:loc' f) - (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) + (fun id -> Tacticals.New.tclTHENLIST [tac_ipat id; tac thin None []]) -and prepare_intros ?loc with_evars dft destopt = function +and prepare_action ?loc with_evars destopt = function | IntroNaming ipat -> - prepare_naming ?loc ipat, - (fun id -> move_hyp id destopt) + (fun _ -> Proofview.tclUNIT ()) | IntroAction ipat -> - prepare_naming ?loc dft, (let tac thin bound = intro_patterns_core with_evars Id.Set.empty [] thin destopt bound 0 (fun _ l -> clear_wildcards l) in @@ -2528,9 +2504,19 @@ let intros_patterns with_evars = function (* Forward reasoning *) (**************************) -let prepare_intros_opt with_evars dft destopt = function - | None -> prepare_naming dft, (fun _id -> Proofview.tclUNIT ()) - | Some {CAst.loc;v=ipat} -> prepare_intros ?loc with_evars dft destopt ipat +let prepare_intros_opt with_evars dft destopt ipat = + let naming, loc, ipat = match ipat with + | None -> + let pat = IntroNaming dft in make_naming_pattern Id.Set.empty [] pat, None, pat + | Some {CAst.loc;v=(IntroNaming pat as ipat)} -> + (* "apply ... in H as id" needs to use id and H is kept iff id<>H *) + prepare_naming ?loc pat, loc, ipat + | Some {CAst.loc;v=(IntroAction pat as ipat)} -> + (* "apply ... in H as pat" reuses H so that old H is always cleared *) + (match dft with IntroIdentifier _ -> prepare_naming ?loc dft | _ -> make_naming_action Id.Set.empty [] pat), + loc, ipat + | Some {CAst.loc;v=(IntroForthcoming _)} -> assert false in + naming, prepare_action ?loc with_evars destopt ipat let ipat_of_name = function | Anonymous -> None @@ -3045,8 +3031,7 @@ let specialize (c,lbind) ipat = match EConstr.kind sigma (fst(EConstr.decompose_app sigma (snd(EConstr.decompose_lam_assum sigma c)))) with | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> (* Like assert (id:=id args) but with the concept of specialization *) - let naming,tac = - prepare_intros_opt false (IntroIdentifier id) MoveLast ipat in + let naming,tac = prepare_intros_opt false (IntroIdentifier id) MoveLast ipat in let repl = do_replace (Some id) naming in Tacticals.New.tclTHENFIRST (assert_before_then_gen repl naming typ tac) @@ -3059,10 +3044,10 @@ let specialize (c,lbind) ipat = (* TODO: add intro to be more homogeneous. It will break scripts but will be easy to fix *) (Tacticals.New.tclTHENLAST (cut typ) (exact_no_check term)) - | Some {CAst.loc;v=ipat} -> + | Some _ as ipat -> (* Like pose proof with extra support for "with" bindings *) (* even though the "with" bindings forces full application *) - let naming,tac = prepare_intros ?loc false IntroAnonymous MoveLast ipat in + let naming, tac = prepare_intros_opt false IntroAnonymous MoveLast ipat in Tacticals.New.tclTHENFIRST (assert_before_then_gen false naming typ tac) (exact_no_check term) @@ -3293,7 +3278,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/tactics.mli b/tactics/tactics.mli index a6471be549..d93f3bc434 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -35,10 +35,6 @@ val is_quantified_hypothesis : Id.t -> Proofview.Goal.t -> bool val introduction : Id.t -> unit Proofview.tactic val convert_concl : check:bool -> types -> cast_kind -> unit Proofview.tactic val convert_hyp : check:bool -> reorder:bool -> named_declaration -> unit Proofview.tactic -val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic -[@@ocaml.deprecated "use [Tactics.convert_concl]"] -val convert_hyp_no_check : named_declaration -> unit Proofview.tactic -[@@ocaml.deprecated "use [Tactics.convert_hyp]"] val mutual_fix : Id.t -> int -> (Id.t * int * constr) list -> int -> unit Proofview.tactic val fix : Id.t -> int -> unit Proofview.tactic 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/closed/bug_13413.v b/test-suite/bugs/closed/bug_13413.v new file mode 100644 index 0000000000..b4414a6a1d --- /dev/null +++ b/test-suite/bugs/closed/bug_13413.v @@ -0,0 +1,20 @@ +Goal forall (A B : Prop) (H : A -> B), A -> A -> B. +intros A B H ?%H H0. +exact H1. +Qed. + +Goal forall (A B : Prop) (H : A -> B), A -> A -> B. +intros A B H ?H%H H0. +exact H1. +Qed. + +Goal forall (A B : Prop) (H : A -> B), A -> A -> B. +intros A B H J%H H0. +exact J. +Qed. + +Set Mangle Names. +Goal forall (A B : Prop) (H : A -> B), A -> A -> B. +intros A B H ?%H _0. +assumption. +Qed. 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-coqtop/DependentEvars.out b/test-suite/output-coqtop/DependentEvars.out index 2e69b94505..11d1ca0bdb 100644 --- a/test-suite/output-coqtop/DependentEvars.out +++ b/test-suite/output-coqtop/DependentEvars.out @@ -1,6 +1,6 @@ Coq < -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal ============================ forall P Q R : Prop, (Q -> R) -> (P -> Q) -> (P -> Q) -> P -> R @@ -8,12 +8,12 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) strange_imp_trans < -strange_imp_trans < No more subgoals. +strange_imp_trans < No more goals. (dependent evars: ; in current goal:) strange_imp_trans < -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal ============================ forall P Q : Prop, (P -> Q) /\ P -> Q @@ -21,7 +21,7 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) modpon < -modpon < No more subgoals. +modpon < No more goals. (dependent evars: ; in current goal:) @@ -38,7 +38,7 @@ Coq < p123 is declared Coq < p34 is declared -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal P1, P2, P3, P4 : Prop p12 : P1 -> P2 @@ -50,7 +50,7 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) p14 < -p14 < 4 focused subgoals +p14 < 4 focused goals (shelved: 2) P1, P2, P3, P4 : Prop @@ -60,16 +60,16 @@ p14 < 4 focused subgoals ============================ ?Q -> P4 -subgoal 2 is: +goal 2 is: ?P -> ?Q -subgoal 3 is: +goal 3 is: ?P -> ?Q -subgoal 4 is: +goal 4 is: ?P (dependent evars: ?X4:?P, ?X5:?Q; in current goal: ?X5) -p14 < 3 focused subgoals +p14 < 3 focused goals (shelved: 2) P1, P2, P3, P4 : Prop @@ -79,9 +79,9 @@ p14 < 3 focused subgoals ============================ ?P -> (?P0 -> P4) /\ ?P0 -subgoal 2 is: +goal 2 is: ?P -> (?P0 -> P4) /\ ?P0 -subgoal 3 is: +goal 3 is: ?P (dependent evars: ?X4:?P, ?X5 using ?X10 ?X11, ?X10 using ?X11, ?X11:?P0; in current goal: ?X4 ?X5 ?X10 ?X11) diff --git a/test-suite/output-coqtop/DependentEvars2.out b/test-suite/output-coqtop/DependentEvars2.out index 63bfafa88d..6bf2c35ad4 100644 --- a/test-suite/output-coqtop/DependentEvars2.out +++ b/test-suite/output-coqtop/DependentEvars2.out @@ -1,6 +1,6 @@ Coq < -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal ============================ forall P Q R : Prop, (Q -> R) -> (P -> Q) -> (P -> Q) -> P -> R @@ -8,12 +8,12 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) strange_imp_trans < -strange_imp_trans < No more subgoals. +strange_imp_trans < No more goals. (dependent evars: ; in current goal:) strange_imp_trans < -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal ============================ forall P Q : Prop, (P -> Q) /\ P -> Q @@ -21,7 +21,7 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) modpon < -modpon < No more subgoals. +modpon < No more goals. (dependent evars: ; in current goal:) @@ -38,7 +38,7 @@ Coq < p123 is declared Coq < p34 is declared -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal P1, P2, P3, P4 : Prop p12 : P1 -> P2 @@ -52,7 +52,7 @@ Coq < Coq < 1 subgoal p14 < p14 < Second proof: -p14 < 4 focused subgoals +p14 < 4 focused goals (shelved: 2) P1, P2, P3, P4 : Prop @@ -62,16 +62,16 @@ p14 < 4 focused subgoals ============================ ?Q -> P4 -subgoal 2 is: +goal 2 is: ?P -> ?Q -subgoal 3 is: +goal 3 is: ?P -> ?Q -subgoal 4 is: +goal 4 is: ?P (dependent evars: ?X4:?P, ?X5:?Q; in current goal: ?X5) -p14 < 1 focused subgoal +p14 < 1 focused goal (shelved: 2) P1, P2, P3, P4 : Prop @@ -86,19 +86,19 @@ p14 < 1 focused subgoal p14 < This subproof is complete, but there are some unfocused goals. Try unfocusing with "}". -3 subgoals +3 goals (shelved: 2) -subgoal 1 is: +goal 1 is: ?P -> (?P0 -> P4) /\ ?P0 -subgoal 2 is: +goal 2 is: ?P -> (?P0 -> P4) /\ ?P0 -subgoal 3 is: +goal 3 is: ?P (dependent evars: ?X4:?P, ?X5 using ?X10 ?X11, ?X10 using ?X11, ?X11:?P0; in current goal:) -p14 < 3 focused subgoals +p14 < 3 focused goals (shelved: 2) P1, P2, P3, P4 : Prop @@ -108,9 +108,9 @@ p14 < 3 focused subgoals ============================ ?P -> (?P0 -> P4) /\ ?P0 -subgoal 2 is: +goal 2 is: ?P -> (?P0 -> P4) /\ ?P0 -subgoal 3 is: +goal 3 is: ?P (dependent evars: ?X4:?P, ?X5 using ?X10 ?X11, ?X10 using ?X11, ?X11:?P0; in current goal: ?X4 ?X5 ?X10 ?X11) diff --git a/test-suite/output-coqtop/ShowGoal.out b/test-suite/output-coqtop/ShowGoal.out index 42d9ff31e9..467112f153 100644 --- a/test-suite/output-coqtop/ShowGoal.out +++ b/test-suite/output-coqtop/ShowGoal.out @@ -1,52 +1,52 @@ -Coq < 1 subgoal
+Coq < 1 goal
============================
forall i : nat, exists j k : nat, i = j /\ j = k /\ i = k
x <
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 1)
i : nat
============================
exists k : nat, i = ?j /\ ?j = k /\ i = k
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 2)
i : nat
============================
i = ?j /\ ?j = ?k /\ i = ?k
-x < 2 focused subgoals
+x < 2 focused goals
(shelved: 2)
i : nat
============================
i = ?j
-subgoal 2 is:
+goal 2 is:
?j = ?k /\ i = ?k
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 1)
i : nat
============================
i = ?k /\ i = ?k
-x < 2 focused subgoals
+x < 2 focused goals
(shelved: 1)
i : nat
============================
i = ?k
-subgoal 2 is:
+goal 2 is:
i = ?k
-x < 1 subgoal
+x < 1 goal
i : nat
============================
diff --git a/test-suite/output-coqtop/ShowProofDiffs.out b/test-suite/output-coqtop/ShowProofDiffs.out index 285a3bcd89..a37e3e5af4 100644 --- a/test-suite/output-coqtop/ShowProofDiffs.out +++ b/test-suite/output-coqtop/ShowProofDiffs.out @@ -1,11 +1,11 @@ -Coq < Coq < 1 subgoal
+Coq < Coq < 1 goal
============================
[48;2;0;91;0m[48;2;0;141;0;4m[1mforall[22m i : nat, [37mexists[39m j k : nat[37m,[39m i[37m =[39m j[37m /\[39m j[37m =[39m k[37m /\[39m i[37m =[39m k[48;2;0;91;0;24m[0m
x <
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 1)
[48;2;0;91;0m[48;2;0;141;0;4mi : nat[48;2;0;91;0;24m[0m
============================
@@ -14,7 +14,7 @@ x < 1 focused subgoal [48;2;0;91;0m[48;2;0;141;0;4m([1mfun[22m i : nat =>[49;24m
[48;2;0;141;0;4mex_intro ([1mfun[22m j : nat => [37mexists[39m k : nat[37m,[39m i[37m =[39m j[37m /\[39m j[37m =[39m k[37m /\[39m i[37m =[39m k) [94m?[39m[94mj[39m[48;2;0;91;0;24m ?Goal[48;2;0;141;0;4m)[48;2;0;91;0;24m[0m
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 2)
i : nat
============================
@@ -24,13 +24,13 @@ x < 1 focused subgoal [48;2;0;91;0mex_intro ([1mfun[22m j : nat => [37mexists[39m k : nat[37m,[39m i[37m =[39m j[37m /\[39m j[37m =[39m k[37m /\[39m i[37m =[39m k) [49m
[48;2;0;91;0m[48;2;0;141;0;4m[94m?[39m[94mj[39m (ex_intro ([1mfun[22m k : nat => i[37m =[39m ?j[37m /\[39m[48;2;0;91;0;24m ?j[37m [39m[48;2;0;141;0;4m[37m=[39m k[37m /\[39m i[37m =[39m k) [94m?[39m[94mk[39m[48;2;0;91;0;24m ?Goal[48;2;0;141;0;4m)[48;2;0;91;0;24m)[0m
-x < 2 focused subgoals
+x < 2 focused goals
(shelved: 2)
i : nat
============================
[48;2;0;91;0mi[37m =[39m ?j[0m
-subgoal 2 is:
+goal 2 is:
[48;2;0;91;0m?j[37m =[39m ?k[37m /\[39m i[37m =[39m ?k[0m
[48;2;0;91;0m([1mfun[22m i : nat =>[49m
diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index e46774f68a..9fd846ac16 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -11,7 +11,7 @@ eq_refl : ?y = ?y where ?y : [ |- nat] -Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x. Arguments eq {A}%type_scope _ _ Arguments eq_refl {B}%type_scope {y}, [_] _ @@ -22,7 +22,7 @@ eq_refl is not universe polymorphic Arguments eq_refl {B}%type_scope {y}, [_] _ (where some original arguments have been renamed) Expands to: Constructor Coq.Init.Logic.eq_refl -Inductive myEq (B : Type) (x : A) : A -> Prop := myrefl : B -> myEq B x x +Inductive myEq (B : Type) (x : A) : A -> Prop := myrefl : B -> myEq B x x. Arguments myEq _%type_scope _ _ Arguments myrefl {C}%type_scope x _ @@ -55,7 +55,7 @@ Expands to: Constant Arguments_renaming.Test1.myplus @myplus : forall Z : Type, Z -> nat -> nat -> nat Inductive myEq (A B : Type) (x : A) : A -> Prop := - myrefl : B -> myEq A B x x + myrefl : B -> myEq A B x x. Arguments myEq (_ _)%type_scope _ _ Arguments myrefl A%type_scope {C}%type_scope x _ diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 984ac4e527..ea647a990a 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: @@ -88,7 +89,7 @@ Arguments lem2 _%bool_scope lem3 = fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl : forall k : nat * nat, k = k -1 subgoal +1 goal x : nat n, n0 := match x + 0 with @@ -108,7 +109,7 @@ fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl end : x = x ============================ x + 0 = 0 -1 subgoal +1 goal p : nat a, diff --git a/test-suite/output/CompactContexts.out b/test-suite/output/CompactContexts.out index 9d1d19877e..f0a8019b67 100644 --- a/test-suite/output/CompactContexts.out +++ b/test-suite/output/CompactContexts.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal hP1 : True a : nat b : list nat h : forall x : nat, {y : nat | y > x} diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out index 8e10107673..fc3b6fbd99 100644 --- a/test-suite/output/Inductive.out +++ b/test-suite/output/Inductive.out @@ -5,7 +5,7 @@ A : Set a : A l : list' A Unable to unify "list' (A * A)%type" with "list' A". -Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x +Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x. Arguments foo _%type_scope _ Arguments Foo _%type_scope _ diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out index 02e58775b5..fdd609f5b2 100644 --- a/test-suite/output/InitSyntax.out +++ b/test-suite/output/InitSyntax.out @@ -1,5 +1,5 @@ Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := - exist2 : forall x : A, P x -> Q x -> {x : A | P x & Q x} + exist2 : forall x : A, P x -> Q x -> {x : A | P x & Q x}. Arguments sig2 [A]%type_scope (_ _)%type_scope Arguments exist2 [A]%type_scope (_ _)%function_scope _ _ _ diff --git a/test-suite/output/Int63Syntax.out b/test-suite/output/Int63Syntax.out index ca8e1b58a8..7ca4de1e46 100644 --- a/test-suite/output/Int63Syntax.out +++ b/test-suite/output/Int63Syntax.out @@ -56,3 +56,21 @@ t = 2%i63 : int = 37151199385380486 : int + = 4 + : int + = 4 + : int + = 4 + : int + = add + : int -> int -> int + = 12 + : int + = 12 + : int + = 12 + : int + = 3 + x + : int + = 1 + 2 + x + : int diff --git a/test-suite/output/Int63Syntax.v b/test-suite/output/Int63Syntax.v index 6f1046f7a5..50910264f2 100644 --- a/test-suite/output/Int63Syntax.v +++ b/test-suite/output/Int63Syntax.v @@ -40,3 +40,18 @@ Open Scope int63_scope. Check (2+2). Eval vm_compute in 2+2. Eval vm_compute in 65675757 * 565675998. + +Eval simpl in 2+2. +Eval hnf in 2+2. +Eval cbn in 2+2. +Eval hnf in PrimInt63.add. + +Eval simpl in (2 * 3) + (2 * 3). +Eval hnf in (2 * 3) + (2 * 3). +Eval cbn in (2 * 3) + (2 * 3). + +Section TestNoSimpl. +Variable x : int. +Eval simpl in 1 + 2 + x. +Eval hnf in 1 + 2 + x. +End TestNoSimpl. diff --git a/test-suite/output/Intuition.out b/test-suite/output/Intuition.out index f2bf25ca65..e273307d75 100644 --- a/test-suite/output/Intuition.out +++ b/test-suite/output/Intuition.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal m, n : Z H : (m >= n)%Z diff --git a/test-suite/output/Naming.out b/test-suite/output/Naming.out index 0a989646cf..2daa5a6bb5 100644 --- a/test-suite/output/Naming.out +++ b/test-suite/output/Naming.out @@ -1,23 +1,23 @@ -1 subgoal +1 goal x3 : nat ============================ forall x x1 x4 x0 : nat, (forall x2 x5 : nat, x2 + x1 = x4 + x5) -> x + x1 = x4 + x0 -1 subgoal +1 goal x3, x, x1, x4, x0 : nat H : forall x x3 : nat, x + x1 = x4 + x3 ============================ x + x1 = x4 + x0 -1 subgoal +1 goal x3 : nat ============================ forall x x1 x4 x0 : nat, (forall x2 x5 : nat, x2 + x1 = x4 + x5 -> foo (S x2 + x1)) -> x + x1 = x4 + x0 -> foo (S x) -1 subgoal +1 goal x3 : nat ============================ @@ -27,7 +27,7 @@ forall x6 x7 x8 S0 : nat, x6 + S0 = x7 + x8 + (S x2 + x1)) -> x + x1 = x4 + x0 -> forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x -1 subgoal +1 goal x3, x, x1, x4, x0 : nat ============================ @@ -36,7 +36,7 @@ forall x6 x7 x8 S0 : nat, x6 + S0 = x7 + x8 + (S x2 + x1)) -> x + x1 = x4 + x0 -> forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x -1 subgoal +1 goal x3, x, x1, x4, x0 : nat H : forall x x3 : nat, @@ -45,7 +45,7 @@ H0 : x + x1 = x4 + x0 ============================ forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x -1 subgoal +1 goal x3, x, x1, x4, x0 : nat H : forall x x3 : nat, @@ -55,7 +55,7 @@ x5, x6, x7, S : nat ============================ x5 + S = x6 + x7 + Datatypes.S x -1 subgoal +1 goal x3, a : nat H : a = 0 -> forall a : nat, a = 0 diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index a9bed49922..60213cab0c 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -238,7 +238,7 @@ Notation "'exists' ! x .. y , p" := (default interpretation) Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope (default interpretation) -1 subgoal +1 goal ============================ ##@% diff --git a/test-suite/output/Partac.out b/test-suite/output/Partac.out index 889e698fa2..ce5dbdedb4 100644 --- a/test-suite/output/Partac.out +++ b/test-suite/output/Partac.out @@ -1,6 +1,6 @@ The command has indeed failed with message: The term "false" has type "bool" while it is expected to have type "nat". -(for subgoal 1) +(for goal 1) The command has indeed failed with message: The term "0" has type "nat" while it is expected to have type "bool". -(for subgoal 2) +(for goal 2) diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index fe16dba496..03b9e3b527 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -4,14 +4,14 @@ existT is template universe polymorphic on sigT.u0 sigT.u1 Arguments existT [A]%type_scope _%function_scope _ _ Expands to: Constructor Coq.Init.Specif.existT Inductive sigT (A : Type) (P : A -> Type) : Type := - existT : forall x : A, P x -> {x : A & P x} + existT : forall x : A, P x -> {x : A & P x}. Arguments sigT [A]%type_scope _%type_scope Arguments existT [A]%type_scope _%function_scope _ _ existT : forall [A : Type] (P : A -> Type) (x : A), P x -> {x : A & P x} Argument A is implicit -Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x. Arguments eq {A}%type_scope _ _ Arguments eq_refl {A}%type_scope {x}, [_] _ @@ -50,7 +50,7 @@ Arguments plus_n_O _%nat_scope plus_n_O is opaque Expands to: Constant Coq.Init.Peano.plus_n_O Inductive le (n : nat) : nat -> Prop := - le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m + le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m. Arguments le (_ _)%nat_scope Arguments le_n _%nat_scope @@ -60,7 +60,7 @@ comparison : Set comparison is not universe polymorphic Expands to: Inductive Coq.Init.Datatypes.comparison Inductive comparison : Set := - Eq : comparison | Lt : comparison | Gt : comparison + Eq : comparison | Lt : comparison | Gt : comparison. bar : foo bar is not universe polymorphic @@ -78,7 +78,7 @@ Arguments bar {x} Module Coq.Init.Peano Notation sym_eq := eq_sym Expands to: Notation Coq.Init.Logic.sym_eq -Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x. Arguments eq {A}%type_scope _ _ Arguments eq_refl {A}%type_scope {x}, {_} _ diff --git a/test-suite/output/PrintModule.out b/test-suite/output/PrintModule.out index 1a9bc068c5..7c7600b786 100644 --- a/test-suite/output/PrintModule.out +++ b/test-suite/output/PrintModule.out @@ -7,3 +7,11 @@ Module N : S with Module T := K := M Module N : S with Module T := M Module Type Func = Funsig (T0:Test) Sig Parameter x : T0.t. End +Module +A +:= Struct + Variant I : Set := C : nat -> I. + Record R : Set := Build_R { n : nat }. + Definition n : R -> nat. + End + diff --git a/test-suite/output/PrintModule.v b/test-suite/output/PrintModule.v index 54ef305be4..b4de03b556 100644 --- a/test-suite/output/PrintModule.v +++ b/test-suite/output/PrintModule.v @@ -60,3 +60,10 @@ Print Func. End Shortest_path. End QUX. + +Module A. +Variant I := C : nat -> I. +Record R := { n : nat }. +End A. + +Print Module A. diff --git a/test-suite/output/Show.out b/test-suite/output/Show.out index f02e442be5..3db00be048 100644 --- a/test-suite/output/Show.out +++ b/test-suite/output/Show.out @@ -1,10 +1,10 @@ -3 subgoals (ID 29) +3 goals (ID 29) H : 0 = 0 ============================ 1 = 1 -subgoal 2 (ID 33) is: +goal 2 (ID 33) is: 1 = S (S m') -subgoal 3 (ID 20) is: +goal 3 (ID 20) is: S (S n') = S m diff --git a/test-suite/output/Unicode.out b/test-suite/output/Unicode.out index a57b3bbad5..abe6c39e8f 100644 --- a/test-suite/output/Unicode.out +++ b/test-suite/output/Unicode.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal very_very_long_type_name1 : Type very_very_long_type_name2 : Type @@ -8,7 +8,7 @@ → True → ∀ (x : very_very_long_type_name1) (y : very_very_long_type_name2), f x y ∧ f x y ∧ f x y ∧ f x y ∧ f x y ∧ f x y -1 subgoal +1 goal very_very_long_type_name1 : Type very_very_long_type_name2 : Type @@ -18,7 +18,7 @@ → True → ∀ (x : very_very_long_type_name2) (y : very_very_long_type_name1) (z : very_very_long_type_name2), f y x ∧ f y z -1 subgoal +1 goal very_very_long_type_name1 : Type very_very_long_type_name2 : Type @@ -29,7 +29,7 @@ → ∀ (x : very_very_long_type_name2) (y : very_very_long_type_name1) (z : very_very_long_type_name2), f y x ∧ f y z ∧ f y x ∧ f y z ∧ f y x ∧ f y z -1 subgoal +1 goal very_very_long_type_name1 : Type very_very_long_type_name2 : Type diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 95b6c6ee95..4993b747fa 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -1,6 +1,7 @@ -Inductive Empty@{uu} : Type@{uu} := +Inductive Empty@{uu} : Type@{uu} := . (* uu |= *) -Record PWrap (A : Type@{uu}) : Type@{uu} := pwrap { punwrap : A } +Record PWrap (A : Type@{uu}) : Type@{uu} := pwrap + { punwrap : A }. (* uu |= *) PWrap has primitive projections with eta conversion. @@ -12,7 +13,8 @@ fun (A : Type@{uu}) (p : PWrap@{uu} A) => punwrap _ p (* uu |= *) Arguments punwrap _%type_scope _ -Record RWrap (A : Type@{uu}) : Type@{uu} := rwrap { runwrap : A } +Record RWrap (A : Type@{uu}) : Type@{uu} := rwrap + { runwrap : A }. (* uu |= *) Arguments RWrap _%type_scope @@ -80,9 +82,9 @@ foo@{uu u v} = Type@{u} -> Type@{v} -> Type@{uu} : Type@{max(uu+1,u+1,v+1)} (* uu u v |= *) -Inductive Empty@{E} : Type@{E} := +Inductive Empty@{E} : Type@{E} := . (* E |= *) -Record PWrap (A : Type@{E}) : Type@{E} := pwrap { punwrap : A } +Record PWrap (A : Type@{E}) : Type@{E} := pwrap { punwrap : A }. (* E |= *) PWrap has primitive projections with eta conversion. @@ -107,7 +109,7 @@ insec@{v} = Type@{uu} -> Type@{v} : Type@{max(uu+1,v+1)} (* v |= *) Inductive insecind@{k} : Type@{k+1} := - inseccstr : Type@{k} -> insecind@{k} + inseccstr : Type@{k} -> insecind@{k}. (* k |= *) Arguments inseccstr _%type_scope @@ -115,7 +117,7 @@ insec@{uu v} = Type@{uu} -> Type@{v} : Type@{max(uu+1,v+1)} (* uu v |= *) Inductive insecind@{uu k} : Type@{k+1} := - inseccstr : Type@{k} -> insecind@{uu k} + inseccstr : Type@{k} -> insecind@{uu k}. (* uu k |= *) Arguments inseccstr _%type_scope diff --git a/test-suite/output/bug_9370.out b/test-suite/output/bug_9370.out index 0ff151c8b4..8d34b7143a 100644 --- a/test-suite/output/bug_9370.out +++ b/test-suite/output/bug_9370.out @@ -1,12 +1,12 @@ -1 subgoal +1 goal ============================ 1 = 1 -1 subgoal +1 goal ============================ 1 = 1 -1 subgoal +1 goal ============================ 1 = 1 diff --git a/test-suite/output/bug_9403.out b/test-suite/output/bug_9403.out index 850760d5ed..cd1030bd2e 100644 --- a/test-suite/output/bug_9403.out +++ b/test-suite/output/bug_9403.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal X : tele α, β, γ1, γ2 : X → Prop diff --git a/test-suite/output/bug_9569.out b/test-suite/output/bug_9569.out index 2d474e4933..e49449679f 100644 --- a/test-suite/output/bug_9569.out +++ b/test-suite/output/bug_9569.out @@ -1,16 +1,16 @@ -1 subgoal +1 goal ============================ exists I : True, I = Logic.I -1 subgoal +1 goal ============================ f True False True False (Logic.True /\ Logic.False) -1 subgoal +1 goal ============================ [I | I = Logic.I; I = Logic.I] = [I | I = Logic.I; I = Logic.I] -1 subgoal +1 goal ============================ [I & I = Logic.I | I = Logic.I; Logic.I = I] diff --git a/test-suite/output/clear.out b/test-suite/output/clear.out index 42e3abf26f..ea01ac50d7 100644 --- a/test-suite/output/clear.out +++ b/test-suite/output/clear.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal z := 0 : nat ============================ diff --git a/test-suite/output/goal_output.out b/test-suite/output/goal_output.out index 17c1aaa55b..453f6ee615 100644 --- a/test-suite/output/goal_output.out +++ b/test-suite/output/goal_output.out @@ -2,79 +2,79 @@ Nat.t = nat : Set Nat.t = nat : Set -2 subgoals +2 goals ============================ True -subgoal 2 is: +goal 2 is: True -2 subgoals, subgoal 1 (?Goal) +2 goals, goal 1 (?Goal) ============================ True -subgoal 2 (?Goal0) is: +goal 2 (?Goal0) is: True -1 subgoal +1 goal ============================ True -1 subgoal (?Goal0) +1 goal (?Goal0) ============================ True -1 subgoal (?Goal0) +1 goal (?Goal0) ============================ True *** Unfocused goals: -subgoal 2 (?Goal1) is: +goal 2 (?Goal1) is: True -subgoal 3 (?Goal) is: +goal 3 (?Goal) is: True -1 subgoal +1 goal ============================ True *** Unfocused goals: -subgoal 2 is: +goal 2 is: True -subgoal 3 is: +goal 3 is: True This subproof is complete, but there are some unfocused goals. Focus next goal with bullet -. -2 subgoals +2 goals -subgoal 1 is: +goal 1 is: True -subgoal 2 is: +goal 2 is: True This subproof is complete, but there are some unfocused goals. Focus next goal with bullet -. -2 subgoals +2 goals -subgoal 1 (?Goal0) is: +goal 1 (?Goal0) is: True -subgoal 2 (?Goal) is: +goal 2 (?Goal) is: True This subproof is complete, but there are some unfocused goals. Focus next goal with bullet -. -1 subgoal +1 goal -subgoal 1 is: +goal 1 is: True This subproof is complete, but there are some unfocused goals. Focus next goal with bullet -. -1 subgoal +1 goal -subgoal 1 (?Goal) is: +goal 1 (?Goal) is: True diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index efdc94fb1e..ed42429f85 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -38,7 +38,7 @@ Ltac foo := let w := () in let z := 1 in pose v -2 subgoals +2 goals n : nat ============================ @@ -47,5 +47,5 @@ Ltac foo := | S n1 => a n1 end) n = n -subgoal 2 is: +goal 2 is: forall a : nat, a = 0 diff --git a/test-suite/output/names.out b/test-suite/output/names.out index 48be63a46a..051bce7701 100644 --- a/test-suite/output/names.out +++ b/test-suite/output/names.out @@ -3,7 +3,7 @@ In environment y : nat The term "a y" has type "{y0 : nat | y = y0}" while it is expected to have type "{x : nat | x = y}". -1 focused subgoal +1 focused goal (shelved: 1) H : ?n <= 3 -> 3 <= ?n -> ?n = 3 diff --git a/test-suite/output/optimize_heap.out b/test-suite/output/optimize_heap.out index 94a0b19118..b6ee61a971 100644 --- a/test-suite/output/optimize_heap.out +++ b/test-suite/output/optimize_heap.out @@ -1,8 +1,8 @@ -1 subgoal +1 goal ============================ True -1 subgoal +1 goal ============================ True diff --git a/test-suite/output/set.out b/test-suite/output/set.out index 4b72d73eb3..61f3c52656 100644 --- a/test-suite/output/set.out +++ b/test-suite/output/set.out @@ -1,16 +1,16 @@ -1 subgoal +1 goal y1 := 0 : nat x := 0 + 0 : nat ============================ x = x -1 subgoal +1 goal y1, y2 := 0 : nat x := y2 + 0 : nat ============================ x = x -1 subgoal +1 goal y1, y2, y3 := 0 : nat x := y2 + y3 : nat diff --git a/test-suite/output/simpl.out b/test-suite/output/simpl.out index 526e468f5b..fd35c5e339 100644 --- a/test-suite/output/simpl.out +++ b/test-suite/output/simpl.out @@ -1,14 +1,14 @@ -1 subgoal +1 goal x : nat ============================ x = S x -1 subgoal +1 goal x : nat ============================ 0 + x = S x -1 subgoal +1 goal x : nat ============================ diff --git a/test-suite/output/subst.out b/test-suite/output/subst.out index 209b2bc26f..9cc515b7ba 100644 --- a/test-suite/output/subst.out +++ b/test-suite/output/subst.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal y, z : nat Hy : y = 0 @@ -11,7 +11,7 @@ H4 : z = 4 ============================ True -1 subgoal +1 goal x, z : nat Hx : x = 0 @@ -24,7 +24,7 @@ H4 : z = 4 ============================ True -1 subgoal +1 goal x, y : nat Hx : x = 0 @@ -37,7 +37,7 @@ H4 : 0 = 4 ============================ True -1 subgoal +1 goal H1 : 0 = 1 HA : True @@ -47,7 +47,7 @@ H4 : 0 = 4 ============================ True -1 subgoal +1 goal y, z : nat Hy : y = 0 @@ -60,7 +60,7 @@ H2 : 0 = 2 ============================ True -1 subgoal +1 goal x, z : nat Hx : x = 0 @@ -73,7 +73,7 @@ H3 : 0 = 3 ============================ True -1 subgoal +1 goal x, y : nat Hx : x = 0 @@ -86,7 +86,7 @@ H4 : 0 = 4 ============================ True -1 subgoal +1 goal HA, HB : True H4 : 0 = 4 diff --git a/test-suite/output/unifconstraints.out b/test-suite/output/unifconstraints.out index 2fadd747b7..abcb8d7e0c 100644 --- a/test-suite/output/unifconstraints.out +++ b/test-suite/output/unifconstraints.out @@ -1,44 +1,44 @@ -3 focused subgoals +3 focused goals (shelved: 1) ============================ ?Goal 0 -subgoal 2 is: +goal 2 is: forall n : nat, ?Goal n -> ?Goal (S n) -subgoal 3 is: +goal 3 is: nat unification constraint: ?Goal ?Goal2 <= True /\ True /\ True \/ veeryyyyyyyyyyyyloooooooooooooonggidentifier = veeryyyyyyyyyyyyloooooooooooooonggidentifier -3 focused subgoals +3 focused goals (shelved: 1) n, m : nat ============================ ?Goal@{n:=n; m:=m} 0 -subgoal 2 is: +goal 2 is: forall n0 : nat, ?Goal@{n:=n; m:=m} n0 -> ?Goal@{n:=n; m:=m} (S n0) -subgoal 3 is: +goal 3 is: nat unification constraint: ?Goal@{n:=n; m:=m} ?Goal2@{n:=n; m:=m} <= True /\ True /\ True \/ veeryyyyyyyyyyyyloooooooooooooonggidentifier = veeryyyyyyyyyyyyloooooooooooooonggidentifier -3 focused subgoals +3 focused goals (shelved: 1) m : nat ============================ ?Goal1@{m:=m} 0 -subgoal 2 is: +goal 2 is: forall n0 : nat, ?Goal1@{m:=m} n0 -> ?Goal1@{m:=m} (S n0) -subgoal 3 is: +goal 3 is: nat unification constraint: @@ -46,16 +46,16 @@ unification constraint: True /\ True /\ True \/ veeryyyyyyyyyyyyloooooooooooooonggidentifier = veeryyyyyyyyyyyyloooooooooooooonggidentifier -3 focused subgoals +3 focused goals (shelved: 1) m : nat ============================ ?Goal0@{m:=m} 0 -subgoal 2 is: +goal 2 is: forall n0 : nat, ?Goal0@{m:=m} n0 -> ?Goal0@{m:=m} (S n0) -subgoal 3 is: +goal 3 is: nat unification constraint: diff --git a/test-suite/output/unification.out b/test-suite/output/unification.out index cf31871e5a..4db5c2d161 100644 --- a/test-suite/output/unification.out +++ b/test-suite/output/unification.out @@ -9,25 +9,25 @@ Unable to unify "T" with "?X@{x0:=x; x:=C a}" (cannot instantiate The command has indeed failed with message: The term "id" has type "ID" while it is expected to have type "Type -> ?T" (cannot instantiate "?T" because "A" is not in its scope). -1 focused subgoal +1 focused goal (shelved: 1) H : forall x : nat, S (S (S x)) = x ============================ ?x = 0 -1 focused subgoal +1 focused goal (shelved: 1) H : forall x : nat, S (S (S x)) = x ============================ ?x = 0 -1 focused subgoal +1 focused goal (shelved: 1) H : forall x : nat, S (S (S x)) = x ============================ ?x = 0 -1 focused subgoal +1 focused goal (shelved: 1) H : forall x : nat, S x = x diff --git a/test-suite/success/autorewrite.v b/test-suite/success/autorewrite.v index 71d333d439..0ac62fcdc9 100644 --- a/test-suite/success/autorewrite.v +++ b/test-suite/success/autorewrite.v @@ -4,25 +4,35 @@ Axiom Ack0 : forall m : nat, Ack 0 m = S m. Axiom Ack1 : forall n : nat, Ack (S n) 0 = Ack n 1. Axiom Ack2 : forall n m : nat, Ack (S n) (S m) = Ack n (Ack (S n) m). -Hint Rewrite Ack0 Ack1 Ack2 : base0. +Module M. + #[export] Hint Rewrite Ack0 Ack1 Ack2 : base0. -Lemma ResAck0 : (Ack 2 2 = 7 -> False) -> False. + Lemma ResAck0 : (Ack 2 2 = 7 -> False) -> False. + Proof. + intros. + autorewrite with base0 in H using try (apply H; reflexivity). + Qed. +End M. + +Lemma ResAck1 : forall H:(Ack 2 2 = 7 -> False), True -> False. Proof. intros. - autorewrite with base0 in H using try (apply H; reflexivity). -Qed. + Fail autorewrite with base0 in *. +Abort. + +Import M. Lemma ResAck1 : forall H:(Ack 2 2 = 7 -> False), True -> False. Proof. intros. autorewrite with base0 in *. - apply H;reflexivity. + apply H;reflexivity. Qed. (* Check autorewrite does not solve existing evars *) (* See discussion started by A. Chargueraud in Oct 2010 on coqdev *) -Hint Rewrite <- plus_n_O : base1. +Global Hint Rewrite <- plus_n_O : base1. Goal forall y, exists x, y+x = y. eexists. autorewrite with base1. Fail reflexivity. 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/forward.v b/test-suite/success/forward.v index 4e36dec15b..62c788e910 100644 --- a/test-suite/success/forward.v +++ b/test-suite/success/forward.v @@ -27,3 +27,7 @@ Fail match goal with |- (?f ?a) => idtac end. (* should be beta-iota reduced *) 2:match goal with _: (?f ?a) |- _ => idtac end. (* should not be beta-iota reduced *) Abort. +Goal nat. +assert nat as J%S by exact 0. +exact J. +Qed. diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index d37ad9f528..b8fbff05c6 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -152,3 +152,15 @@ Definition d := ltac:(intro x; exact (x*x)). Definition d' : nat -> _ := ltac:(intros;exact 0). End Evar. + +Module Wildcard. + +(* We check that the wildcard internal name does not interfere with + user fresh names (currently the prefix is "_H") *) + +Goal nat -> bool -> nat -> bool. +intros _ ?_H ?_H. +exact _H. +Qed. + +End Wildcard. 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/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index d597c0404a..5fe2cade3b 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -489,7 +489,7 @@ the above form: variables. We are going to use them with [autorewrite]. *) - Hint Rewrite + Global Hint Rewrite F.empty_iff F.singleton_iff F.add_iff F.remove_iff F.union_iff F.inter_iff F.diff_iff : set_simpl. @@ -499,7 +499,7 @@ the above form: now split. Qed. - Hint Rewrite eq_refl_iff : set_eq_simpl. + Global Hint Rewrite eq_refl_iff : set_eq_simpl. (** ** Decidability of FSet Propositions *) diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 115c7cb365..d6277b3bb5 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -3327,7 +3327,7 @@ Ltac invlist f := (** * Exporting hints and tactics *) -Hint Rewrite +Global Hint Rewrite rev_involutive (* rev (rev l) = l *) rev_unit (* rev (l ++ a :: nil) = a :: rev l *) map_nth (* nth n (map f l) (f d) = f (nth n l d) *) diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v index aa0c419f0e..579e5e9630 100644 --- a/theories/MSets/MSetDecide.v +++ b/theories/MSets/MSetDecide.v @@ -489,7 +489,7 @@ the above form: variables. We are going to use them with [autorewrite]. *) - Hint Rewrite + Global Hint Rewrite F.empty_iff F.singleton_iff F.add_iff F.remove_iff F.union_iff F.inter_iff F.diff_iff : set_simpl. @@ -499,7 +499,7 @@ the above form: now split. Qed. - Hint Rewrite eq_refl_iff : set_eq_simpl. + Global Hint Rewrite eq_refl_iff : set_eq_simpl. (** ** Decidability of MSet Propositions *) diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v index f80929e320..2d210e24a6 100644 --- a/theories/MSets/MSetRBT.v +++ b/theories/MSets/MSetRBT.v @@ -651,7 +651,7 @@ Proof. destruct (rbal'_match l x r); ok. Qed. -Hint Rewrite In_node_iff In_leaf_iff +Global Hint Rewrite In_node_iff In_leaf_iff makeRed_spec makeBlack_spec lbal_spec rbal_spec rbal'_spec : rb. Ltac descolor := destruct_all Color.t. @@ -670,7 +670,7 @@ Proof. - descolor; autorew; rewrite IHl; intuition_in. - descolor; autorew; rewrite IHr; intuition_in. Qed. -Hint Rewrite ins_spec : rb. +Global Hint Rewrite ins_spec : rb. Instance ins_ok s x `{Ok s} : Ok (ins x s). Proof. @@ -685,7 +685,7 @@ Proof. unfold add. now autorew. Qed. -Hint Rewrite add_spec' : rb. +Global Hint Rewrite add_spec' : rb. Lemma add_spec s x y `{Ok s} : InT y (add x s) <-> X.eq y x \/ InT y s. @@ -754,7 +754,7 @@ Proof. * ok. apply lbal_ok; ok. Qed. -Hint Rewrite lbalS_spec rbalS_spec : rb. +Global Hint Rewrite lbalS_spec rbalS_spec : rb. (** ** Append for deletion *) @@ -807,7 +807,7 @@ Proof. [intros a y b | intros t Ht]; autorew; tauto. Qed. -Hint Rewrite append_spec : rb. +Global Hint Rewrite append_spec : rb. Lemma append_ok : forall x l r `{Ok l, Ok r}, lt_tree x l -> gt_tree x r -> Ok (append l r). @@ -861,7 +861,7 @@ induct s x. rewrite ?IHr by trivial; intuition_in; order. Qed. -Hint Rewrite del_spec : rb. +Global Hint Rewrite del_spec : rb. Instance del_ok s x `{Ok s} : Ok (del x s). Proof. @@ -882,7 +882,7 @@ Proof. unfold remove. now autorew. Qed. -Hint Rewrite remove_spec : rb. +Global Hint Rewrite remove_spec : rb. Instance remove_ok s x `{Ok s} : Ok (remove x s). Proof. diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v index 48df5fe884..420c17c9a4 100644 --- a/theories/NArith/Nnat.v +++ b/theories/NArith/Nnat.v @@ -127,7 +127,7 @@ Qed. End N2Nat. -Hint Rewrite N2Nat.inj_double N2Nat.inj_succ_double +Global Hint Rewrite N2Nat.inj_double N2Nat.inj_succ_double N2Nat.inj_succ N2Nat.inj_add N2Nat.inj_mul N2Nat.inj_sub N2Nat.inj_pred N2Nat.inj_div2 N2Nat.inj_max N2Nat.inj_min N2Nat.id @@ -147,7 +147,7 @@ Proof. induction n; simpl; trivial. apply SuccNat2Pos.id_succ. Qed. -Hint Rewrite id : Nnat. +Global Hint Rewrite id : Nnat. Ltac nat2N := apply N2Nat.inj; now autorewrite with Nnat. (** [N.of_nat] is hence injective *) @@ -206,7 +206,7 @@ Proof. now rewrite N2Nat.inj_iter, !id. Qed. End Nat2N. -Hint Rewrite Nat2N.id : Nnat. +Global Hint Rewrite Nat2N.id : Nnat. (** Compatibility notations *) diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index e3e8f532b3..374af6de63 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -348,7 +348,7 @@ Local Notation "- x" := (ZnZ.opp x). Local Infix "*" := ZnZ.mul. Local Notation wB := (base ZnZ.digits). -Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_add ZnZ.spec_mul +Global Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_add ZnZ.spec_mul ZnZ.spec_opp ZnZ.spec_sub : cyclic. diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v index 7c5b43096a..f74a78e876 100644 --- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -51,7 +51,7 @@ Local Infix "+" := add. Local Infix "-" := sub. Local Infix "*" := mul. -Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_succ ZnZ.spec_pred +Global Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_succ ZnZ.spec_pred ZnZ.spec_add ZnZ.spec_mul ZnZ.spec_sub : cyclic. Ltac zify := unfold eq, zero, one, two, succ, pred, add, sub, mul in *; diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index f324bbf52b..7bb725538b 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -954,6 +954,7 @@ Proof. intros _ HH; generalize (HH H1); discriminate. clear H. generalize (ltb_spec j i); case Int63.ltb; intros H2; unfold bit; simpl. + change 62%int63 with (digits - 1)%int63. assert (F2: (φ j < φ i)%Z) by (case H2; auto); clear H2. replace (is_zero (((x << i) >> j) << (digits - 1))) with true; auto. case (to_Z_bounded j); intros H1j H2j. 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/HexadecimalNat.v b/theories/Numbers/HexadecimalNat.v index 94a14b90bd..696e89bd8e 100644 --- a/theories/Numbers/HexadecimalNat.v +++ b/theories/Numbers/HexadecimalNat.v @@ -230,7 +230,7 @@ Proof. simpl_of_lu; rewrite ?Nat.add_succ_l, Nat.add_0_l, ?to_lu_succ, to_of_lu_sixteenfold by assumption; - unfold lnorm; simpl; now destruct nztail. + unfold lnorm; cbn; now destruct nztail. Qed. (** Second bijection result *) 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/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v index 0c097b6773..9d9244eefb 100644 --- a/theories/Numbers/Integer/Abstract/ZAdd.v +++ b/theories/Numbers/Integer/Abstract/ZAdd.v @@ -18,7 +18,7 @@ Include ZBaseProp Z. (** Theorems that are either not valid on N or have different proofs on N and Z *) -Hint Rewrite opp_0 : nz. +Global Hint Rewrite opp_0 : nz. Theorem add_pred_l n m : P n + m == P (n + m). Proof. diff --git a/theories/Numbers/Integer/Abstract/ZBits.v b/theories/Numbers/Integer/Abstract/ZBits.v index 4d2361689d..832931e5ef 100644 --- a/theories/Numbers/Integer/Abstract/ZBits.v +++ b/theories/Numbers/Integer/Abstract/ZBits.v @@ -26,7 +26,7 @@ Include BoolEqualityFacts A. Ltac order_nz := try apply pow_nonzero; order'. Ltac order_pos' := try apply abs_nonneg; order_pos. -Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. +Global Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. (** Some properties of power and division *) @@ -566,7 +566,7 @@ Tactic Notation "bitwise" "as" simple_intropattern(m) simple_intropattern(Hm) Ltac bitwise := bitwise as ?m ?Hm. -Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. +Global Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. (** The streams of bits that correspond to a numbers are exactly the ones which are stationary after some point. *) diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v index 66cbba9e08..2ad8dfcedb 100644 --- a/theories/Numbers/NatInt/NZAdd.v +++ b/theories/Numbers/NatInt/NZAdd.v @@ -14,9 +14,9 @@ Require Import NZAxioms NZBase. Module Type NZAddProp (Import NZ : NZAxiomsSig')(Import NZBase : NZBaseProp NZ). -Hint Rewrite +Global Hint Rewrite pred_succ add_0_l add_succ_l mul_0_l mul_succ_l sub_0_r sub_succ_r : nz. -Hint Rewrite one_succ two_succ : nz'. +Global Hint Rewrite one_succ two_succ : nz'. Ltac nzsimpl := autorewrite with nz. Ltac nzsimpl' := autorewrite with nz nz'. @@ -39,7 +39,7 @@ Proof. intros n m. now rewrite add_succ_r, add_succ_l. Qed. -Hint Rewrite add_0_r add_succ_r : nz. +Global Hint Rewrite add_0_r add_succ_r : nz. Theorem add_comm : forall n m, n + m == m + n. Proof. @@ -58,7 +58,7 @@ Proof. intro n; now nzsimpl'. Qed. -Hint Rewrite add_1_l add_1_r : nz. +Global Hint Rewrite add_1_l add_1_r : nz. Theorem add_assoc : forall n m p, n + (m + p) == (n + m) + p. Proof. @@ -104,6 +104,6 @@ Proof. intro n; now nzsimpl'. Qed. -Hint Rewrite sub_1_r : nz. +Global Hint Rewrite sub_1_r : nz. End NZAddProp. diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v index 3d6465191d..14728eaf40 100644 --- a/theories/Numbers/NatInt/NZMul.v +++ b/theories/Numbers/NatInt/NZMul.v @@ -28,7 +28,7 @@ Proof. now rewrite add_cancel_r. Qed. -Hint Rewrite mul_0_r mul_succ_r : nz. +Global Hint Rewrite mul_0_r mul_succ_r : nz. Theorem mul_comm : forall n m, n * m == m * n. Proof. @@ -69,7 +69,7 @@ Proof. intro n. now nzsimpl'. Qed. -Hint Rewrite mul_1_l mul_1_r : nz. +Global Hint Rewrite mul_1_l mul_1_r : nz. Theorem mul_shuffle0 : forall n m p, n*m*p == n*p*m. Proof. diff --git a/theories/Numbers/NatInt/NZPow.v b/theories/Numbers/NatInt/NZPow.v index 3b2a496229..00edcd641f 100644 --- a/theories/Numbers/NatInt/NZPow.v +++ b/theories/Numbers/NatInt/NZPow.v @@ -45,7 +45,7 @@ Module Type NZPowProp (Import B : NZPow' A) (Import C : NZMulOrderProp A). -Hint Rewrite pow_0_r pow_succ_r : nz. +Global Hint Rewrite pow_0_r pow_succ_r : nz. (** Power and basic constants *) @@ -76,14 +76,14 @@ Proof. - now nzsimpl. Qed. -Hint Rewrite pow_1_r pow_1_l : nz. +Global Hint Rewrite pow_1_r pow_1_l : nz. Lemma pow_2_r : forall a, a^2 == a*a. Proof. intros. rewrite two_succ. nzsimpl; order'. Qed. -Hint Rewrite pow_2_r : nz. +Global Hint Rewrite pow_2_r : nz. (** Power and nullity *) diff --git a/theories/Numbers/Natural/Abstract/NBits.v b/theories/Numbers/Natural/Abstract/NBits.v index 313b9adfd1..427a18d4ae 100644 --- a/theories/Numbers/Natural/Abstract/NBits.v +++ b/theories/Numbers/Natural/Abstract/NBits.v @@ -23,7 +23,7 @@ Module Type NBitsProp Include BoolEqualityFacts A. Ltac order_nz := try apply pow_nonzero; order'. -Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. +Global Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. (** Some properties of power and division *) @@ -368,7 +368,7 @@ Proof. split. apply bits_inj. intros EQ; now rewrite EQ. Qed. -Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. +Global Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. Tactic Notation "bitwise" "as" simple_intropattern(m) := apply bits_inj; intros m; autorewrite with bitwise. diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index e97f2dc748..7d50bdacad 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -876,7 +876,7 @@ Lemma compare_xO_xI p q : (p~0 ?= q~1) = switch_Eq Lt (p ?= q). Proof. exact (compare_cont_spec p q Lt). Qed. -Hint Rewrite compare_xO_xO compare_xI_xI compare_xI_xO compare_xO_xI : compare. +Global Hint Rewrite compare_xO_xO compare_xI_xI compare_xI_xO compare_xO_xI : compare. Ltac simpl_compare := autorewrite with compare. Ltac simpl_compare_in H := autorewrite with compare in H. diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v index 8813131d7b..18e55aefc6 100644 --- a/theories/Program/Combinators.v +++ b/theories/Program/Combinators.v @@ -40,8 +40,8 @@ Proof. reflexivity. Qed. -Hint Rewrite @compose_id_left @compose_id_right : core. -Hint Rewrite <- @compose_assoc : core. +Global Hint Rewrite @compose_id_left @compose_id_right : core. +Global Hint Rewrite <- @compose_assoc : core. (** [flip] is involutive. *) diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index 25af2d5ffb..090322054e 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -162,7 +162,7 @@ Ltac pi_eq_proofs := repeat pi_eq_proof. Ltac clear_eq_proofs := abstract_eq_proofs ; pi_eq_proofs. -Hint Rewrite <- eq_rect_eq : refl_id. +Global Hint Rewrite <- eq_rect_eq : refl_id. (** The [refl_id] database should be populated with lemmas of the form [coerce_* t eq_refl = t]. *) @@ -178,7 +178,7 @@ Lemma inj_pairT2_refl A (x : A) (P : A -> Type) (p : P x) : Eqdep.EqdepTheory.inj_pairT2 A P x p p eq_refl = eq_refl. Proof. apply UIP_refl. Qed. -Hint Rewrite @JMeq_eq_refl @UIP_refl_refl @inj_pairT2_refl : refl_id. +Global Hint Rewrite @JMeq_eq_refl @UIP_refl_refl @inj_pairT2_refl : refl_id. Ltac rewrite_refl_id := autorewrite with refl_id. diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index 5a23a20811..620ed6b5b7 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -180,4 +180,4 @@ intros; rewrite Q2R_mult. rewrite Q2R_inv; auto. Qed. -Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl. +Global Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 4ac54d280a..c3e67b9d5a 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -53,7 +53,7 @@ Module Type CompareFacts (Import O:DecStrOrder'). rewrite compare_gt_iff; intuition. Qed. - Hint Rewrite compare_eq_iff compare_lt_iff compare_gt_iff : order. + Global Hint Rewrite compare_eq_iff compare_lt_iff compare_gt_iff : order. Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare. Proof. diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index abf7f681b0..c709149109 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -146,7 +146,7 @@ Module MoreInt (Import I:Int). (** A magic (but costly) tactic that goes from [int] back to the [Z] friendly world ... *) - Hint Rewrite -> + Global Hint Rewrite -> i2z_0 i2z_1 i2z_2 i2z_3 i2z_add i2z_opp i2z_sub i2z_mul i2z_max i2z_eqb i2z_ltb i2z_leb : i2z. diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 10edb0b4db..50aa658128 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -48,7 +48,7 @@ let is_keyword = "Delimit"; "Bind"; "Open"; "Scope"; "Inline"; "Implicit Arguments"; "Add"; "Strict"; "Typeclasses"; "Instance"; "Global Instance"; "Class"; "Instantiation"; - "subgoal"; "subgoals"; "vm_compute"; + "goal"; "goals"; "vm_compute"; "Opaque"; "Transparent"; "Time"; "Extraction"; "Extract"; "Variant"; 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/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 65b61a0d93..548e12d611 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -213,7 +213,7 @@ GRAMMAR EXTEND Gram | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_constr c } | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_open_constr c } | IDENT "ident"; ":"; "("; c = lident; ")" -> { Tac2quote.of_ident c } - | IDENT "pattern"; ":"; "("; c = Constr.cpattern; ")" -> { inj_pattern loc c } + | IDENT "pat"; ":"; "("; c = Constr.cpattern; ")" -> { inj_pattern loc c } | IDENT "reference"; ":"; "("; c = globref; ")" -> { inj_reference loc c } | IDENT "ltac1"; ":"; "("; qid = ltac1_expr_in_env; ")" -> { inj_ltac1 loc qid } | IDENT "ltac1val"; ":"; "("; qid = ltac1_expr_in_env; ")" -> { inj_ltac1val loc qid } diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 8663691c0a..241ca7ad66 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 @@ -1147,7 +1151,7 @@ let () = let sigma = Evd.from_env env in Patternops.subst_pattern env sigma subst c in - let print env sigma pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env sigma pat ++ str ")" in + let print env sigma pat = str "pat:(" ++ Printer.pr_lconstr_pattern_env env sigma pat ++ str ")" in let interp _ c = return (Value.of_pattern c) in let obj = { ml_intern = intern; diff --git a/user-contrib/Ltac2/tac2print.ml b/user-contrib/Ltac2/tac2print.ml index fe62de1fb3..a54eb45f61 100644 --- a/user-contrib/Ltac2/tac2print.ml +++ b/user-contrib/Ltac2/tac2print.ml @@ -466,7 +466,7 @@ end let () = register_init "pattern" begin fun env sigma c -> let c = to_pattern c in let c = try Printer.pr_lconstr_pattern_env env sigma c with _ -> str "..." in - str "pattern:(" ++ c ++ str ")" + str "pat:(" ++ c ++ str ")" end let () = register_init "message" begin fun _ _ pp -> 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/printmod.ml b/vernac/printmod.ml index fdf7f6c74a..ba4a7857e7 100644 --- a/vernac/printmod.ml +++ b/vernac/printmod.ml @@ -124,7 +124,7 @@ let print_mutual_inductive env mind mib udecl = let sigma = Evd.from_ctx (UState.of_binders bl) in hov 0 (def keyword ++ spc () ++ prlist_with_sep (fun () -> fnl () ++ str" with ") - (print_one_inductive env sigma mib) inds ++ + (print_one_inductive env sigma mib) inds ++ str "." ++ Printer.pr_universes sigma ?variance:mib.mind_variance mib.mind_universes) let get_fields = @@ -173,7 +173,7 @@ let print_record env mind mib udecl = prlist_with_sep (fun () -> str ";" ++ brk(2,0)) (fun (id,b,c) -> Id.print id ++ str (if b then " : " else " := ") ++ - Printer.pr_lconstr_env envpar sigma c) fields) ++ str" }" ++ + Printer.pr_lconstr_env envpar sigma c) fields) ++ str" }." ++ Printer.pr_universes sigma ?variance:mib.mind_variance mib.mind_universes ) 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..1c774a35bf 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" @@ -1337,31 +1401,9 @@ let warn_implicit_core_hint_db = (fun () -> strbrk "Adding and removing hints in the core database implicitly is deprecated. " ++ strbrk"Please specify a hint database.") -let warn_deprecated_hint_without_locality = - CWarnings.create ~name:"deprecated-hint-without-locality" ~category:"deprecated" - (fun () -> strbrk "The default value for hint locality is currently \ - \"local\" in a section and \"global\" otherwise, but is scheduled to change \ - in a future release. For the time being, adding hints outside of sections \ - without specifying an explicit locality is therefore deprecated. It is \ - recommended to use \"export\" whenever possible.") - -let check_hint_locality = function -| OptGlobal -> - if Global.sections_are_opened () then - CErrors.user_err Pp.(str - "This command does not support the global attribute in sections."); -| OptExport -> - if Global.sections_are_opened () then - CErrors.user_err Pp.(str - "This command does not support the export attribute in sections."); -| OptDefault -> - if not @@ Global.sections_are_opened () then - warn_deprecated_hint_without_locality () -| OptLocal -> () - let vernac_remove_hints ~atts dbnames ids = let locality = Attributes.(parse option_locality atts) in - let () = check_hint_locality locality in + let () = Hints.check_hint_locality locality in let dbnames = if List.is_empty dbnames then (warn_implicit_core_hint_db (); ["core"]) @@ -1376,7 +1418,7 @@ let vernac_hints ~atts dbnames h = else dbnames in let locality, poly = Attributes.(parse Notations.(option_locality ++ polymorphic) atts) in - let () = check_hint_locality locality in + let () = Hints.check_hint_locality locality in Hints.add_hints ~locality dbnames (ComHints.interp_hints ~poly h) let vernac_syntactic_definition ~atts lid x only_parsing = 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 -> |