diff options
416 files changed, 10582 insertions, 9629 deletions
diff --git a/.gitignore b/.gitignore index 371136fc73..98d9741970 100644 --- a/.gitignore +++ b/.gitignore @@ -60,6 +60,18 @@ test-suite/.nra.cache test-suite/trace test-suite/misc/universes/all_stdlib.v test-suite/misc/universes/universes.txt +test-suite/coq-makefile/*/actual +test-suite/coq-makefile/*/desired +test-suite/coq-makefile/*/Makefile +test-suite/coq-makefile/*/Makefile.conf +test-suite/coq-makefile/*/src +test-suite/coq-makefile/*/theories +test-suite/coq-makefile/*/theories2 +test-suite/coq-makefile/*/html +test-suite/coq-makefile/*/mlihtml +test-suite/coq-makefile/*/subdir/done +test-suite/coq-makefile/latex1/all.pdf +test-suite/coq-makefile/merlin1/.merlin # documentation @@ -120,7 +132,7 @@ ide/xml_lexer.ml g_*.ml -ide/project_file.ml +lib/coqProject_file.ml parsing/cLexer.ml plugins/ltac/coretactics.ml plugins/ltac/extratactics.ml diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml new file mode 100644 index 0000000000..9ba39abdbd --- /dev/null +++ b/.gitlab-ci.yml @@ -0,0 +1,312 @@ +image: ocaml/opam:ubuntu + +# this doesn't seem to work +cache: + paths: + - .opamcache + +stages: + - build + - test + +variables: + # some default values + NJOBS: "2" + COMPILER: "system" + CAMLP5_VER: "6.14" + + # some useful values + COMPILER_32BIT: "4.02.3+32bit" + + COMPILER_BLEEDING_EDGE: "4.04.1" + CAMLP5_VER_BLEEDING_EDGE: "6.17" + + COQIDE_PACKAGES: "libgtk2.0-dev libgtksourceview2.0-dev" + #COQIDE_PACKAGES_32BIT: "libgtk2.0-dev:i386 libgtksourceview2.0-dev:i386" + COQIDE_OPAM: "lablgtk-extras" + COQDOC_PACKAGES: "texlive-latex-base texlive-latex-recommended texlive-latex-extra texlive-math-extra texlive-fonts-recommended texlive-fonts-extra latex-xcolor ghostscript transfig imagemagick tipa" + COQDOC_OPAM: "hevea" + + +before_script: + - ls # figure out if artifacts are around + - printenv +# - if [ "$COMPILER" = "$COMPILER_32BIT" ]; then sudo dpkg --add-architecture i386; fi + - if [ -n "${EXTRA_PACKAGES}" ]; then sudo apt-get update -qq && sudo apt-get install -y -qq ${EXTRA_PACKAGES}; fi + + # setup cache + - if [ ! "(" -d .opamcache ")" ]; then mv ~/.opam .opamcache; else mv ~/.opam ~/.opam-old; fi + - ln -s $(readlink -f .opamcache) ~/.opam + + - opam switch ${COMPILER} + - eval $(opam config env) + - opam config list + - opam install -j ${NJOBS} -y camlp5.${CAMLP5_VER} ocamlfind ${EXTRA_OPAM} + - rm -rf ~/.opam/log/ + - opam list + +# TODO figure out how to build doc for installed coq +.build-template: &build-template + stage: build + artifacts: + name: "$CI_JOB_NAME" + paths: + - install + - config/Makefile + expire_in: 1 week + script: + - set -e + + - echo 'start:coq.config' + - ./configure -prefix "$(pwd)/install" ${EXTRA_CONF} + - echo 'end:coq.config' + + - echo 'start:coq.build' + - make -j ${NJOBS} + - echo 'end:coq:build' + + - echo 'start:coq.install' + - make install + - cp bin/fake_ide install/bin/ + - echo 'end:coq.install' + + - set +e + variables: &build-variables + EXTRA_CONF: "-native-compiler yes -coqide opt" + EXTRA_PACKAGES: "$COQIDE_PACKAGES" + EXTRA_OPAM: "$COQIDE_OPAM" + +.warnings-template: &warnings-template + # keep warnings in test stage so we can test things even when warnings occur + stage: test + dependencies: [] + script: + - set -e + + - echo 'start:coq.config' + - ./configure -local ${EXTRA_CONF} + - echo 'end:coq.config' + + - echo 'start:coq.build' + - make -j ${NJOBS} coqocaml + - echo 'end:coq:build' + + - set +e + variables: &warnings-variables + EXTRA_CONF: "-native-compiler yes -coqide opt" + EXTRA_PACKAGES: "$COQIDE_PACKAGES" + EXTRA_OPAM: "$COQIDE_OPAM" + +.test-suite-template: &test-suite-template + stage: test + script: + - set -e + - cd test-suite + - make clean + # careful with the ending / + - make -j ${NJOBS} BIN=$(readlink -f ../install/bin)/ LIB=$(readlink -f ../install/lib/coq)/ all + - cat summary.log + - set +e + +.validate-template: &validate-template + stage: test + script: + - cd install + - find lib/coq/ -name '*.vo' -print0 > vofiles + - for regexp in 's/.vo//' 's:lib/coq/plugins:Coq:' 's:lib/coq/theories:Coq:' 's:/:.:g'; do sed -z -i "$regexp" vofiles; done + - xargs -0 --arg-file=vofiles bin/coqchk -boot -silent -o -m -coqlib lib/coq/ + +.documentation-template: &documentation-template + stage: test + script: + - ./configure -prefix "$(pwd)/install" ${EXTRA_CONF} + - cp install/lib/coq/tools/coqdoc/coqdoc.sty . + + - INSTALLDIR=$(readlink -f install) + - LIB="$INSTALLDIR/lib/coq" + # WTF using a newline makes make sigsev + # see https://gitlab.com/SkySkimmer/coq/builds/17313312 + - DOCVFILES=$(find "$LIB/" -name '*.v' -printf "%p ") + - DOCLIGHTDIRS="$LIB/theories/Init/ $LIB/theories/Logic/ $LIB/theories/Unicode/ $LIB/theories/Arith/" + - DOCLIGHTVOFILES=$(find $DOCLIGHTDIRS -name '*.vo' -printf "%p ") + + - make doc QUICK=true COQDOC_NOBOOT=true COQTEX="$INSTALLDIR/bin/coq-tex" COQDOC="$INSTALLDIR/bin/coqdoc" VFILES="$DOCVFILES" THEORIESLIGHTVO="$DOCLIGHTVOFILES" + + - make install-doc + artifacts: + name: "$CI_JOB_NAME" + paths: + - install/share/doc + expire_in: 1 week + +.ci-template: &ci-template + stage: test + script: + - set -e + - echo 'start:coq.test' + - make -f Makefile.ci -j ${NJOBS} ${TEST_TARGET} + - echo 'end:coq.test' + - set +e + dependencies: + - build + variables: &ci-template-vars + TEST_TARGET: "$CI_JOB_NAME" + +build: + <<: *build-template + +# no coqide for 32bit: libgtk installation problems +build:32bit: + <<: *build-template + variables: + EXTRA_CONF: "-native-compiler yes" + EXTRA_PACKAGES: "gcc-multilib" + COMPILER: "$COMPILER_32BIT" + +build:bleeding-edge: + <<: *build-template + variables: + <<: *build-variables + COMPILER: "$COMPILER_BLEEDING_EDGE" + CAMLP5_VER: "$CAMLP5_VER_BLEEDING_EDGE" + +warnings: + <<: *warnings-template + +# warnings:32bit: +# <<: *warnings-template +# variables: +# <<: *warnings-variables +# EXTRA_PACKAGES: "$gcc-multilib COQIDE_PACKAGES_32BIT" +# COMPILER: "$COMPILER_32BIT" + +warnings:bleeding-edge: + <<: *warnings-template + variables: + <<: *warnings-variables + COMPILER: "$COMPILER_BLEEDING_EDGE" + CAMLP5_VER: "$CAMLP5_VER_BLEEDING_EDGE" + +test-suite: + <<: *test-suite-template + dependencies: + - build + +test-suite:32bit: + <<: *test-suite-template + dependencies: + - build:32bit + variables: + COMPILER: "$COMPILER_32BIT" + EXTRA_PACKAGES: "gcc-multilib" + +test-suite:bleeding-edge: + <<: *test-suite-template + dependencies: + - build:bleeding-edge + variables: + COMPILER: "$COMPILER_BLEEDING_EDGE" + CAMLP5_VER: "$CAMLP5_VER_BLEEDING_EDGE" + +documentation: + <<: *documentation-template + dependencies: + - build + variables: + EXTRA_PACKAGES: "$COQDOC_PACKAGES" + EXTRA_OPAM: "$COQDOC_OPAM" + +documentation:bleeding-edge: + <<: *documentation-template + dependencies: + - build:bleeding-edge + variables: + COMPILER: "$COMPILER_BLEEDING_EDGE" + CAMLP5_VER: "$CAMLP5_VER_BLEEDING_EDGE" + EXTRA_PACKAGES: "$COQDOC_PACKAGES" + EXTRA_OPAM: "$COQDOC_OPAM" + +validate: + <<: *validate-template + dependencies: + - build + +validate:32bit: + <<: *validate-template + dependencies: + - build:32bit + variables: + COMPILER: "$COMPILER_32BIT" + EXTRA_PACKAGES: "gcc-multilib" + +ci-bedrock-src: + <<: *ci-template + +ci-bedrock-facade: + <<: *ci-template + +ci-color: + <<: *ci-template + variables: + <<: *ci-template-vars + EXTRA_PACKAGES: "subversion" + +ci-compcert: + <<: *ci-template + +ci-coquelicot: + <<: *ci-template + variables: + <<: *ci-template-vars + EXTRA_PACKAGES: "autoconf" + +ci-geocoq: + <<: *ci-template + allow_failure: true + +# ci-fiat-crypto: +# <<: *ci-template +# # out of memory error +# allow_failure: true + +ci-fiat-parsers: + <<: *ci-template + variables: + <<: *ci-template-vars + EXTRA_PACKAGES: "python" + +ci-flocq: + <<: *ci-template + variables: + <<: *ci-template-vars + EXTRA_PACKAGES: "autoconf" + +ci-formal-topology: + <<: *ci-template + +ci-hott: + <<: *ci-template + variables: + <<: *ci-template-vars + EXTRA_PACKAGES: "autoconf" + +ci-iris-coq: + <<: *ci-template + +ci-math-classes: + <<: *ci-template + +ci-math-comp: + <<: *ci-template + +ci-sf: + <<: *ci-template + variables: + <<: *ci-template-vars + EXTRA_PACKAGES: "wget" + +ci-unimath: + <<: *ci-template + +ci-vst: + <<: *ci-template @@ -36,6 +36,8 @@ S toplevel B toplevel S vernac B vernac +S plugins/ltac +B plugins/ltac S tools B tools diff --git a/.travis.yml b/.travis.yml index a959fbf961..14bafd3456 100644 --- a/.travis.yml +++ b/.travis.yml @@ -88,6 +88,7 @@ matrix: - ghostscript - transfig - imagemagick + - tipa - env: - TEST_TARGET="test-suite" @@ -22,12 +22,22 @@ Tactics beta-iota-reduced after type-checking. This has an impact on the type of the variables that the tactic "refine" introduces in the context, producing types a priori closer to the expectations. +- In "Tactic Notation" or "TACTIC EXTEND", entry "constr_with_bindings" + now uses type classes and rejects terms with unresolved holes, like + entry "constr" does. To get the former behavior use + "open_constr_with_bindings" (possible source of incompatibility. +- New e-variants eassert, eenough, epose proof, eset, eremember, epose + which behave like the corresponding variants with no "e" but turn + unresolved implicit arguments into existential variables, on the + shelf, rather than failing. Vernacular Commands - Goals context can be printed in a more compact way when "Set Printing Compact Contexts" is activated. +- The deprecated `Save` vernacular and its form `Save Theorem id` to + close proofs have been removed from the syntax. Please use `Qed`. Standard Library @@ -52,6 +62,22 @@ Dependencies - Support for camlp4 has been removed. +Tools + +- coq_makefile was completely redesigned to improve its maintainability and + the extensibility of generated Makefiles, and to make _CoqProject files + more palatable to IDEs. Overview: + * _CoqProject files contain only Coq specific data (i.e. the list of + files, -R options, ...) + * coq_makefile translates _CoqProject to Makefile.conf and copies in the + desired location a standard Makefile (that reads Makefile.conf) + * Makefile extensions can be implemented in a Makefile.local file (read + by the main Makefile) by installing a hook in the extension points + provided by the standard Makefile + The current version contains code for retro compatibility that prints + warnings when a deprecated feature is used. Please upgrade your _CoqProject + accordingly. + Changes from V8.6beta1 to V8.6 ============================== @@ -53,7 +53,9 @@ FIND_VCS_CLAUSE:='(' \ -name 'debian' -o \ -name "$${GIT_DIR}" -o \ -name '_build' -o \ - -name '_build_ci' \ + -name '_build_ci' -o \ + -name 'coq-makefile' -o \ + -name '.opamcache' \ ')' -prune -o define find diff --git a/Makefile.build b/Makefile.build index 56f1fb8b49..8aedd9ceca 100644 --- a/Makefile.build +++ b/Makefile.build @@ -377,7 +377,7 @@ $(GALLINA): $(call bestobj, tools/gallina_lexer.cmo tools/gallina.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,) -COQMAKEFILECMO:=lib/clib.cma ide/project_file.cmo tools/coq_makefile.cmo +COQMAKEFILECMO:=lib/clib.cma tools/coq_makefile.cmo $(COQMAKEFILE): $(call bestobj,$(COQMAKEFILECMO)) $(SHOW)'OCAMLBEST -o $@' diff --git a/Makefile.dev b/Makefile.dev index 1803cc8ffe..fde92ec949 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -98,7 +98,7 @@ pluginsopt: $(PLUGINSOPT) pluginsbyte: $(PLUGINS) # This should build all the ocaml code but not (most of) the .v files -coqocaml: tools coqbinaries pluginsopt coqide printers +coqocaml: tools coqbinaries pluginsopt coqide printers bin/votour .PHONY: coqlight states miniopt minibyte pluginsopt pluginsbyte coqocaml diff --git a/Makefile.doc b/Makefile.doc index 39c3255f5c..c31d81c8bc 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -38,7 +38,11 @@ HEVEAOPTS:=-fix -exec xxdate.exe HEVEALIB:=/usr/local/lib/hevea:/usr/lib/hevea HTMLSTYLE:=simple export TEXINPUTS:=$(HEVEALIB): +ifdef COQDOC_NOBOOT +COQTEXOPTS:=-n 72 -sl -small +else COQTEXOPTS:=-boot -n 72 -sl -small +endif DOCCOMMON:=doc/common/version.tex doc/common/title.tex doc/common/macros.tex diff --git a/Makefile.install b/Makefile.install index bde0355519..33f881c11d 100644 --- a/Makefile.install +++ b/Makefile.install @@ -96,6 +96,7 @@ install-devfiles: $(MKDIR) $(FULLCOQLIB) $(INSTALLSH) $(FULLCOQLIB) $(LINKCMO) $(GRAMMARCMA) $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) + $(INSTALLSH) $(FULLCOQLIB) tools/CoqMakefile.in ifeq ($(BEST),opt) $(INSTALLSH) $(FULLCOQLIB) $(LINKCMX) $(CORECMA:.cma=.a) $(STATICPLUGINS:.cma=.a) endif @@ -6,15 +6,16 @@ Introduction The Coq Travis CI infrastructure is meant to provide lightweight automatics testing of pull requests. +If you are on GitLab, their integrated CI is also set up. More comprehensive testing is the responsability of Coq's [Jenkins CI server](https://ci.inria.fr/coq/) see, [XXX: add document] for instructions on how to add your development to Jenkins. -How to submit your development for Coq Travis CI -================================================ +How to submit your development for Coq CI +========================================= -Travis CI provides a convenient way to perform testing of Coq changes +CI provides a convenient way to perform testing of Coq changes versus a set of curated libraries. Are you an author of a Coq library who would be interested in having @@ -25,7 +26,7 @@ is easy, all that you need to do is: 1.- Put you development in a public repository tracking coq trunk. 2.- Make sure that your development builds in less than 35 minutes. -3.- Submit a PR adding you development. +3.- Submit a PR adding your development. 4.- ? 5.- Profit! Your library is now part of Coq's continous integration! @@ -39,8 +40,8 @@ have. Maintaining your contribution manually [current method] ====================================== -To add your contribution to the Coq Travis CI set, add a script for -building your library to `dev/ci/`, update `.travis.yml` and +To add your contribution to the Coq CI set, add a script for building +your library to `dev/ci/`, update `.travis.yml`, `.gitlab-ci.yml` and `Makefile.ci`. Then, submit a PR. Maintaining your contribution as an OPAM package [work in progress] [to be implemented] @@ -75,3 +76,29 @@ The `.overlay` file will contain a set of variables that will be used to do the corresponding `opam pin` or to overload the corresponding git repositories, etc... +Since pull requests only happen on GitHub there is no need to test the +corresponding GitLab CI variables. + +Travis specific information +=========================== + +Travis rebuilds all of Coq's executables and stdlib for each job. Coq +is built with `./configure -local`, then used for the job's test. + +GitLab specific information +=========================== + +GitLab is set up to use the "build artifact" feature to avoid +rebuilding Coq. In one job, Coq is built with `./configure -prefix +install` and `make install` is run, then the `install` directory +persists to and is used by the next jobs. + +Artifacts can also be downloaded from the GitLab repository. +Currently, available artifacts are: +- the Coq executables and stdlib, in three copies varying in + architecture and Ocaml version used to build Coq. +- the Coq documentation, in two different copies varying in the OCaml + version used to build Coq + +As an exception to the above, jobs testing that compilation triggers +no Ocaml warnings build Coq in parallel with other tests. diff --git a/checker/analyze.ml b/checker/analyze.ml index c48b830119..df75d5b93c 100644 --- a/checker/analyze.ml +++ b/checker/analyze.ml @@ -4,6 +4,7 @@ let prefix_small_block = 0x80 let prefix_small_int = 0x40 let prefix_small_string = 0x20 +[@@@ocaml.warning "-32"] let code_int8 = 0x00 let code_int16 = 0x01 let code_int32 = 0x02 @@ -25,6 +26,7 @@ let code_infixpointer = 0x11 let code_custom = 0x12 let code_block64 = 0x13 +[@@@ocaml.warning "-37"] type code_descr = | CODE_INT8 | CODE_INT16 @@ -101,11 +103,11 @@ let input_binary_int chan = input_binary_int chan let input_char chan = Char.chr (input_byte chan) +let input_string len chan = String.init len (fun _ -> input_char chan) let parse_header chan = let () = current_offset := 0 in - let magic = String.create 4 in - let () = for i = 0 to 3 do magic.[i] <- input_char chan done in + let magic = input_string 4 chan in let length = input_binary_int chan in let objects = input_binary_int chan in let size32 = input_binary_int chan in @@ -204,13 +206,6 @@ let input_header64 chan = in (tag, len) -let input_string len chan = - let ans = String.create len in - for i = 0 to pred len do - ans.[i] <- input_char chan; - done; - ans - let parse_object chan = let data = input_byte chan in if prefix_small_block <= data then @@ -251,7 +246,7 @@ let parse_object chan = RString (input_string len chan) | CODE_CODEPOINTER -> let addr = input_int32u chan in - for i = 0 to 15 do ignore (input_byte chan); done; + for _i = 0 to 15 do ignore (input_byte chan); done; RCode addr | CODE_DOUBLE_ARRAY32_LITTLE | CODE_DOUBLE_BIG diff --git a/checker/check.ml b/checker/check.ml index 11678fa6bb..6d93c11eac 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -72,7 +72,7 @@ let find_library dir = let try_find_library dir = try find_library dir with Not_found -> - error ("Unknown library " ^ (DirPath.to_string dir)) + user_err Pp.(str ("Unknown library " ^ (DirPath.to_string dir))) let library_full_filename dir = (find_library dir).library_filename diff --git a/checker/checker.ml b/checker/checker.ml index 5cadfe7b94..e00f47a540 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -335,7 +335,7 @@ let parse_args argv = | "-debug" :: rem -> set_debug (); parse rem | "-where" :: _ -> - Envars.set_coqlib ~fail:CErrors.error; + Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); print_endline (Envars.coqlib ()); exit 0 @@ -373,7 +373,7 @@ let init_with_argv argv = try parse_args argv; if !Flags.debug then Printexc.record_backtrace true; - Envars.set_coqlib ~fail:CErrors.error; + Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); if_verbose print_header (); init_load_path (); engage (); diff --git a/checker/environ.ml b/checker/environ.ml index 7b59c6b986..bce40861cf 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -45,7 +45,7 @@ let set_engagement (impr_set as c) env = env.env_stratification.env_engagement in begin match impr_set,expected_impr_set with - | PredicativeSet, ImpredicativeSet -> error "Incompatible engagement" + | PredicativeSet, ImpredicativeSet -> user_err Pp.(str "Incompatible engagement") | _ -> () end; { env with env_stratification = diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 27f79e7963..0482912b0a 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -535,13 +535,13 @@ let check_inductive env kn mib = (* check mind_finite : always OK *) (* check mind_ntypes *) if Array.length mib.mind_packets <> mib.mind_ntypes then - error "not the right number of packets"; + user_err Pp.(str "not the right number of packets"); (* check mind_params_ctxt *) let params = mib.mind_params_ctxt in let _ = check_ctxt env params in (* check mind_nparams *) if rel_context_nhyps params <> mib.mind_nparams then - error "number the right number of parameters"; + user_err Pp.(str "number the right number of parameters"); (* mind_packets *) (* - check arities *) let env_ar = typecheck_arity env params mib.mind_packets in diff --git a/checker/inductive.ml b/checker/inductive.ml index 8f23a38afc..9e417a8eb5 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -27,7 +27,7 @@ type mind_specif = mutual_inductive_body * one_inductive_body let lookup_mind_specif env (kn,tyi) = let mib = lookup_mind kn env in if tyi >= Array.length mib.mind_packets then - error "Inductive.lookup_mind_specif: invalid inductive index"; + user_err Pp.(str "Inductive.lookup_mind_specif: invalid inductive index"); (mib, mib.mind_packets.(tyi)) let find_rectype env c = @@ -232,7 +232,7 @@ let type_of_constructor_subst cstr u (mib,mip) = let specif = mip.mind_user_lc in let i = index_of_constructor cstr in let nconstr = Array.length mip.mind_consnames in - if i > nconstr then error "Not enough constructors in the type."; + if i > nconstr then user_err Pp.(str "Not enough constructors in the type."); constructor_instantiate (fst ind) u mib specif.(i-1) let type_of_constructor_gen (cstr,u) (mib,mip as mspec) = diff --git a/checker/modops.ml b/checker/modops.ml index aba9da2fef..bed31143bf 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -16,29 +16,29 @@ open Declarations (*i*) let error_not_a_constant l = - error ("\""^(Label.to_string l)^"\" is not a constant") + user_err Pp.(str ("\""^(Label.to_string l)^"\" is not a constant")) -let error_not_a_functor () = error "Application of not a functor" +let error_not_a_functor () = user_err Pp.(str "Application of not a functor") -let error_incompatible_modtypes _ _ = error "Incompatible module types" +let error_incompatible_modtypes _ _ = user_err Pp.(str "Incompatible module types") let error_not_match l _ = - error ("Signature components for label "^Label.to_string l^" do not match") + user_err Pp.(str ("Signature components for label "^Label.to_string l^" do not match")) -let error_no_such_label l = error ("No such label "^Label.to_string l) +let error_no_such_label l = user_err Pp.(str ("No such label "^Label.to_string l)) let error_no_such_label_sub l l1 = let l1 = ModPath.to_string l1 in - error ("The field "^ - Label.to_string l^" is missing in "^l1^".") + user_err Pp.(str ("The field "^ + Label.to_string l^" is missing in "^l1^".")) -let error_not_a_module_loc loc s = - user_err ~loc (str ("\""^Label.to_string s^"\" is not a module")) +let error_not_a_module_loc ?loc s = + user_err ?loc (str ("\""^Label.to_string s^"\" is not a module")) -let error_not_a_module s = error_not_a_module_loc Loc.ghost s +let error_not_a_module s = error_not_a_module_loc s let error_with_module () = - error "Unsupported 'with' constraint in module implementation" + user_err Pp.(str "Unsupported 'with' constraint in module implementation") let is_functor = function | MoreFunctor _ -> true diff --git a/checker/reduction.ml b/checker/reduction.ml index 28c0126b41..82f09cf4b0 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -536,5 +536,5 @@ let dest_arity env c = let l, c = dest_prod_assum env c in match c with | Sort s -> l,s - | _ -> error "not an arity" + | _ -> user_err Pp.(str "not an arity") diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index 53d80c6d55..c70cd5c8ce 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -40,7 +40,7 @@ let check_engagement env expected_impredicative_set = begin match impredicative_set, expected_impredicative_set with | PredicativeSet, ImpredicativeSet -> - CErrors.error "Needs option -impredicative-set." + CErrors.user_err Pp.(str "Needs option -impredicative-set.") | _ -> () end; () @@ -61,7 +61,7 @@ let check_imports f caller env needed = let actual_stamp = lookup_digest env dp in if stamp <> actual_stamp then report_clash f caller dp with Not_found -> - error ("Reference to unknown module " ^ (DirPath.to_string dp)) + user_err Pp.(str ("Reference to unknown module " ^ (DirPath.to_string dp))) in Array.iter check needed diff --git a/checker/subtyping.ml b/checker/subtyping.ml index a290b240d8..2d04b77e46 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -302,22 +302,22 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = let c2 = force_constr lc2 in check_conv conv env c1 c2)) | IndType ((kn,i),mind1) -> - ignore (CErrors.error ( + ignore (CErrors.user_err (Pp.str ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by an inductive type. Hint: you can rename the " ^ "inductive type and give a definition to map the old name to the new " ^ - "name.")); + "name."))); if constant_has_body cb2 then error () ; let u = inductive_instance mind1 in let arity1 = type_of_inductive env ((mind1,mind1.mind_packets.(i)),u) in let typ2 = Typeops.type_of_constant_type env cb2.const_type in check_conv conv_leq env arity1 typ2 | IndConstr (((kn,i),j) as cstr,mind1) -> - ignore (CErrors.error ( + ignore (CErrors.user_err (Pp.str ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by a constructor. Hint: you can rename the " ^ "constructor and give a definition to map the old name to the new " ^ - "name.")); + "name."))); if constant_has_body cb2 then error () ; let u1 = inductive_instance mind1 in let ty1 = type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in diff --git a/checker/term.ml b/checker/term.ml index 24e6008d34..8cac783753 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -273,14 +273,14 @@ let decompose_lam = abstractions *) let decompose_lam_n_assum n = if n < 0 then - error "decompose_lam_n_assum: integer parameter must be positive"; + user_err Pp.(str "decompose_lam_n_assum: integer parameter must be positive"); let rec lamdec_rec l n c = if Int.equal n 0 then l,c else match c with | Lambda (x,t,c) -> lamdec_rec (LocalAssum (x,t) :: l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (LocalDef (x,b,t) :: l) n c | Cast (c,_,_) -> lamdec_rec l n c - | c -> error "decompose_lam_n_assum: not enough abstractions" + | c -> user_err Pp.(str "decompose_lam_n_assum: not enough abstractions") in lamdec_rec empty_rel_context n @@ -306,14 +306,14 @@ let decompose_prod_assum = let decompose_prod_n_assum n = if n < 0 then - error "decompose_prod_n_assum: integer parameter must be positive"; + user_err Pp.(str "decompose_prod_n_assum: integer parameter must be positive"); let rec prodec_rec l n c = if Int.equal n 0 then l,c else match c with | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c - | c -> error "decompose_prod_n_assum: not enough assumptions" + | c -> user_err Pp.(str "decompose_prod_n_assum: not enough assumptions") in prodec_rec empty_rel_context n diff --git a/checker/votour.ml b/checker/votour.ml index 48f9f45e7e..c255e5cdb2 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -19,14 +19,14 @@ let rec read_num max = if l = "u" then None else if l = "x" then quit () else - try - let v = int_of_string l in + match int_of_string l with + | v -> if v < 0 || v >= max then let () = Printf.printf "Out-of-range input! (only %d children)\n%!" max in read_num max else Some v - with Failure "int_of_string" -> + | exception Failure _ -> Printf.printf "Unrecognized input! <n> enters the <n>-th child, u goes up 1 level, x exits\n%!"; read_num max @@ -149,16 +149,17 @@ let rec get_name ?(extra=false) = function (** For tuples, its quite handy to display the inner 1st string (if any). Cf. [structure_body] for instance *) +exception TupleString of string let get_string_in_tuple o = try for i = 0 to Array.length o - 1 do match Repr.repr o.(i) with | STRING s -> - failwith (Printf.sprintf " [..%s..]" s) + raise (TupleString (Printf.sprintf " [..%s..]" s)) | _ -> () done; "" - with Failure s -> s + with TupleString s -> s (** Some details : tags, integer value for non-block, etc etc *) @@ -205,6 +206,7 @@ let access_block o = match Repr.repr o with let access_int o = match Repr.repr o with INT i -> i | _ -> raise Exit (** raises Exit if the object has not the expected structure *) +exception Forbidden let rec get_children v o pos = match v with |Tuple (_, v) -> let (_, os) = access_block o in @@ -236,7 +238,7 @@ let rec get_children v o pos = match v with [|(Int, id, 0 :: pos); (tpe, o, 1 :: pos)|] | _ -> raise Exit end - |Fail s -> failwith "forbidden" + |Fail s -> raise Forbidden let get_children v o pos = try get_children v o pos @@ -257,9 +259,10 @@ let init () = stk := [] let push name v o p = stk := { nam = name; typ = v; obj = o; pos = p } :: !stk +exception EmptyStack let pop () = match !stk with | i::s -> stk := s; i - | _ -> failwith "empty stack" + | _ -> raise EmptyStack let rec visit v o pos = Printf.printf "\nDepth %d Pos %s Context %s\n" @@ -283,8 +286,8 @@ let rec visit v o pos = push (get_name v) v o pos; visit v' o' pos' with - | Failure "empty stack" -> () - | Failure "forbidden" -> let info = pop () in visit info.typ info.obj info.pos + | EmptyStack -> () + | Forbidden -> let info = pop () in visit info.typ info.obj info.pos | Failure _ | Invalid_argument _ -> visit v o pos end @@ -313,8 +316,7 @@ let dummy_header = { } let parse_header chan = - let magic = String.create 4 in - let () = for i = 0 to 3 do magic.[i] <- input_char chan done in + let magic = really_input_string chan 4 in let length = input_binary_int chan in let objects = input_binary_int chan in let size32 = input_binary_int chan in diff --git a/config/coq_config.mli b/config/coq_config.mli index c171bd3553..2b3bc2c25b 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -8,11 +8,19 @@ val local : bool (* local use (no installation) *) -val coqlib : string option (* where the std library is installed *) -val configdir : string option (* where configuration files are installed *) -val datadir : string option (* where extra data files are installed *) +(* The fields below are absolute paths *) +val coqlib : string (* where the std library is installed *) +val configdir : string (* where configuration files are installed *) +val datadir : string (* where extra data files are installed *) val docdir : string (* where the doc is installed *) +(* The fields below are paths relative to the installation prefix *) +(* However, if an absolute path, it means discarding the actual prefix *) +val coqlibsuffix : string (* std library relative to installation prefix *) +val configdirsuffix : string (* config files relative to installation prefix *) +val datadirsuffix : string (* data files relative to installation prefix *) +val docdirsuffix : string (* doc directory relative to installation prefix *) + val ocaml : string (* names of ocaml binaries *) val ocamlfind : string val ocamllex : string @@ -26,7 +26,7 @@ done ## We check that $cmd is ok before the real exec $cmd -`$cmd -version > /dev/null 2>&1` && exec $cmd -w "-3" $script "$@" +`$cmd -version > /dev/null 2>&1` && exec $cmd $script "$@" ## If we're still here, something is wrong with $cmd diff --git a/configure.ml b/configure.ml index 679f524179..a5204d5b57 100644 --- a/configure.ml +++ b/configure.ml @@ -425,11 +425,11 @@ let arch = match !Prefs.arch with else if arch <> "" then arch else try_archs arch_progs -(** NB: [arch_win32] is broader than [os_type_win32], cf. cygwin *) +(** NB: [arch_is_win32] is broader than [os_type_win32], cf. cygwin *) -let arch_win32 = (arch = "win32") +let arch_is_win32 = (arch = "win32") -let exe = exe := if arch_win32 then ".exe" else ""; !exe +let exe = exe := if arch_is_win32 then ".exe" else ""; !exe let dll = if os_type_win32 then ".dll" else ".so" (** * VCS @@ -449,7 +449,7 @@ let vcs = let browser = match !Prefs.browser with | Some b -> b - | None when arch_win32 -> "start %s" + | None when arch_is_win32 -> "start %s" | None when arch = "Darwin" -> "open %s" | _ -> "firefox -remote \"OpenURL(%s,new-tab)\" || firefox %s &" @@ -515,7 +515,6 @@ let camltag = match caml_version_list with | _ -> assert false (** Explanation of disabled warnings: - 3: deprecated warning (not error for non minimum supported ocaml) 4: fragile pattern matching: too common in the code and too annoying to avoid in general 9: missing fields in a record pattern: too common in the code and not worth the bother 27: innocuous unused variable: innocuous @@ -533,7 +532,7 @@ let coq_warn_flags = if !Prefs.warn_error then "-warn-error +a" ^ (if caml_version_nums > [4;2;3] - then "-3-56" + then "-56" else "") else "" in @@ -598,9 +597,11 @@ let config_camlpX () = let camlp5mod = "gramlib" in let camlp5libdir, camlp5o = check_camlp5 (camlp5mod^".cma") in let camlp5_version = check_camlp5_version camlp5o in - "camlp5", camlp5o, Filename.dirname camlp5o, camlp5libdir, camlp5mod, camlp5_version + "camlp5", "Camlp5", camlp5o, Filename.dirname camlp5o, camlp5libdir, camlp5mod, camlp5_version -let camlpX, camlpXo, camlpXbindir, fullcamlpXlibdir, camlpXmod, camlpX_version = config_camlpX () +let camlpX, capitalized_camlpX, camlpXo, + camlpXbindir, fullcamlpXlibdir, + camlpXmod, camlpX_version = config_camlpX () let shorten_camllib s = if starts_with s (camllib^"/") then @@ -854,73 +855,91 @@ let withdoc = check_doc () let coqtop = Sys.getcwd () -let unix = os_type_cygwin || not arch_win32 +let unix = os_type_cygwin || not arch_is_win32 (** Variable name, description, ref in Prefs, default dir, prefix-relative *) +type path_style = + | Absolute of string (* Should start with a "/" *) + | Relative of string (* Should not start with a "/" *) + let install = [ "BINDIR", "the Coq binaries", Prefs.bindir, - (if unix then "/usr/local/bin" else "C:/coq/bin"), - "/bin"; + Relative "bin", Relative "bin", Relative "bin"; "COQLIBINSTALL", "the Coq library", Prefs.libdir, - (if unix then "/usr/local/lib/coq" else "C:/coq/lib"), - (if arch_win32 then "" else "/lib/coq"); + Relative "lib", Relative "lib/coq", Relative ""; "CONFIGDIR", "the Coqide configuration files", Prefs.configdir, - (if unix then "/etc/xdg/coq" else "C:/coq/config"), - (if arch_win32 then "/config" else "/etc/xdg/coq"); + Relative "config", Absolute "/etc/xdg/coq", Relative "ide"; "DATADIR", "the Coqide data files", Prefs.datadir, - (if unix then "/usr/local/share/coq" else "C:/coq/share"), - "/share/coq"; + Relative "share", Relative "share/coq", Relative "ide"; "MANDIR", "the Coq man pages", Prefs.mandir, - (if unix then "/usr/local/share/man" else "C:/coq/man"), - "/share/man"; + Relative "man", Relative "share/man", Relative "man"; "DOCDIR", "the Coq documentation", Prefs.docdir, - (if unix then "/usr/local/share/doc/coq" else "C:/coq/doc"), - "/share/doc/coq"; + Relative "doc", Relative "share/doc/coq", Relative "doc"; "EMACSLIB", "the Coq Emacs mode", Prefs.emacslib, - (if unix then "/usr/local/share/emacs/site-lisp" else "C:/coq/emacs"), - (if arch_win32 then "/emacs" else "/share/emacs/site-lisp"); + Relative "emacs", Relative "share/emacs/site-lisp", Relative "tools"; "COQDOCDIR", "the Coqdoc LaTeX files", Prefs.coqdocdir, - (if unix then "/usr/local/share/texmf/tex/latex/misc" else "C:/coq/latex"), - (if arch_win32 then "/latex" else "/share/emacs/site-lisp"); + Relative "latex", Relative "share/texmf/tex/latex/misc", Relative "tools/coqdoc"; ] -let do_one_instdir (var,msg,r,dflt,suff) = - let dir = match !r, !Prefs.prefix with - | Some d, _ -> d - | _, Some p -> p^suff - | _ -> +let strip_trailing_slash_if_any p = + if p.[String.length p - 1] = '/' then String.sub p 0 (String.length p - 1) else p + +let use_suffix prefix = function + | Relative "" -> prefix + | Relative suff -> prefix ^ "/" ^ suff + | Absolute path -> path + +let relativize = function + (* Turn a global layout based on some prefix to a relative layout *) + | Relative _ as suffix -> suffix + | Absolute path -> Relative (String.sub path 1 (String.length path - 1)) + +let find_suffix prefix path = match prefix with + | None -> Absolute path + | Some p -> + let p = strip_trailing_slash_if_any p in + let lpath = String.length path in + let lp = String.length p in + if lpath > lp && String.sub path 0 lp = p then + Relative (String.sub path (lp+1) (lpath - lp - 1)) + else + Absolute path + +let do_one_instdir (var,msg,uservalue,selfcontainedlayout,unixlayout,locallayout) = + let dir,suffix = + if !Prefs.local then (use_suffix coqtop locallayout,locallayout) + else match !uservalue, !Prefs.prefix with + | Some d, p -> d,find_suffix p d + | _, Some p -> + let suffix = if arch_is_win32 then selfcontainedlayout else relativize unixlayout in + use_suffix p suffix, suffix + | _, p -> + let suffix = if unix then unixlayout else selfcontainedlayout in + let base = if unix then "/usr/local" else "C:/coq" in + let dflt = use_suffix base suffix in let () = printf "Where should I install %s [%s]? " msg dflt in let line = read_line () in - if line = "" then dflt else line - in (var,msg,dir,dir<>dflt) - -let do_one_noinst (var,msg,_,_,_) = - if var="CONFIGDIR" || var="DATADIR" then (var,msg,coqtop^"/ide",true) - else (var,msg,"",false) + if line = "" then (dflt,suffix) else (line,find_suffix p line) + in (var,msg,dir,suffix) -let install_dirs = - let f = if !Prefs.local then do_one_noinst else do_one_instdir in - List.map f install +let install_dirs = List.map do_one_instdir install let select var = List.find (fun (v,_,_,_) -> v=var) install_dirs -let libdir = let (_,_,d,_) = select "COQLIBINSTALL" in d - -let docdir = let (_,_,d,_) = select "DOCDIR" in d +let coqlib,coqlibsuffix = let (_,_,d,s) = select "COQLIBINSTALL" in d,s -let configdir = - let (_,_,d,b) = select "CONFIGDIR" in if b then Some d else None +let docdir,docdirsuffix = let (_,_,d,s) = select "DOCDIR" in d,s -let datadir = - let (_,_,d,b) = select "DATADIR" in if b then Some d else None +let configdir,configdirsuffix = let (_,_,d,s) = select "CONFIGDIR" in d,s +let datadir,datadirsuffix = let (_,_,d,s) = select "DATADIR" in d,s (** * OCaml runtime flags *) (** Do we use -custom (yes by default on Windows and MacOS) *) -let custom_os = arch_win32 || arch = "Darwin" +let custom_os = arch_is_win32 || arch = "Darwin" let use_custom = match !Prefs.custom with | Some b -> b @@ -940,7 +959,7 @@ let config_runtime () = | _ -> let ld="CAML_LD_LIBRARY_PATH" in build_loadpath := sprintf "export %s:='%s/kernel/byterun':$(%s)" ld coqtop ld; - ["-dllib";"-lcoqrun";"-dllpath";libdir/"kernel/byterun"] + ["-dllib";"-lcoqrun";"-dllpath";coqlib/"kernel/byterun"] let vmbyteflags = config_runtime () @@ -959,9 +978,9 @@ let print_summary () = pr " OCaml version : %s\n" caml_version; pr " OCaml binaries in : %s\n" camlbin; pr " OCaml library in : %s\n" camllib; - pr " %s version : %s\n" (String.capitalize camlpX) camlpX_version; - pr " %s binaries in : %s\n" (String.capitalize camlpX) camlpXbindir; - pr " %s library in : %s\n" (String.capitalize camlpX) camlpXlibdir; + pr " %s version : %s\n" capitalized_camlpX camlpX_version; + pr " %s binaries in : %s\n" capitalized_camlpX camlpXbindir; + pr " %s library in : %s\n" capitalized_camlpX camlpXlibdir; if best_compiler = "opt" then pr " Native dynamic link support : %B\n" hasnatdynlink; if coqide <> "no" then @@ -1018,18 +1037,22 @@ let write_configml f = let pr_s = pr "let %s = %S\n" in let pr_b = pr "let %s = %B\n" in let pr_i = pr "let %s = %d\n" in - let pr_o s o = pr "let %s = %s\n" s - (match o with None -> "None" | Some d -> sprintf "Some %S" d) + let pr_p s o = pr "let %s = %S\n" s + (match o with Relative s -> s | Absolute s -> s) in pr "(* DO NOT EDIT THIS FILE: automatically generated by ../configure *)\n"; pr "(* Exact command that generated this file: *)\n"; pr "(* %s *)\n\n" (String.concat " " (Array.to_list Sys.argv)); pr_b "local" !Prefs.local; pr "let vmbyteflags = ["; List.iter (pr "%S;") vmbyteflags; pr "]\n"; - pr_o "coqlib" (if !Prefs.local then None else Some libdir); - pr_o "configdir" configdir; - pr_o "datadir" datadir; + pr_s "coqlib" coqlib; + pr_s "configdir" configdir; + pr_s "datadir" datadir; pr_s "docdir" docdir; + pr_p "coqlibsuffix" coqlibsuffix; + pr_p "configdirsuffix" configdirsuffix; + pr_p "datadirsuffix" datadirsuffix; + pr_p "docdirsuffix" docdirsuffix; pr_s "ocaml" camlexec.top; pr_s "ocamlfind" camlexec.find; pr_s "ocamllex" camlexec.lex; @@ -1048,7 +1071,7 @@ let write_configml f = pr_s "date" short_date; pr_s "compile_date" full_date; pr_s "arch" arch; - pr_b "arch_is_win32" arch_win32; + pr_b "arch_is_win32" arch_is_win32; pr_s "exec_extension" exe; pr_s "coqideincl" !lablgtkincludes; pr_s "has_coqide" coqide; diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 1dfade261f..a6972c9500 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -13,8 +13,8 @@ ######################################################################## # UniMath ######################################################################## -: ${UniMath_CI_BRANCH:=master} -: ${UniMath_CI_GITURL:=https://github.com/UniMath/UniMath.git} +: ${UniMath_CI_BRANCH:=coq_makefile2-fix} +: ${UniMath_CI_GITURL:=https://github.com/maximedenes/UniMath.git} ######################################################################## # Unicoq + Metacoq diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 2711b7ecaa..f1e1515d41 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -2,11 +2,18 @@ set -xe +if [ -n "${GITLAB_CI}" ]; +then + export COQBIN=`pwd`/install/bin +else + export COQBIN=`pwd`/bin +fi +export PATH="$COQBIN:$PATH" + # Coq's tools need an ending slash :S, we should fix them. -export COQBIN=`pwd`/bin/ -export PATH=`pwd`/bin:$PATH +export COQBIN="$COQBIN/" -ls `pwd`/bin +ls "$COQBIN" # Where we clone and build external developments CI_BUILD_DIR=`pwd`/_build_ci diff --git a/dev/ci/ci-user-overlay.sh b/dev/ci/ci-user-overlay.sh index fad6472911..bfa43cde1d 100644 --- a/dev/ci/ci-user-overlay.sh +++ b/dev/ci/ci-user-overlay.sh @@ -25,7 +25,10 @@ echo $TRAVIS_PULL_REQUEST echo $TRAVIS_BRANCH echo $TRAVIS_COMMIT -if [ $TRAVIS_PULL_REQUEST == "568" ] || [ $TRAVIS_BRANCH == "remove-tactic-compat" ]; then - fiat_parsers_CI_BRANCH=fix-ml - fiat_parsers_CI_GITURL=https://github.com/ppedrot/fiat.git +if [ $TRAVIS_PULL_REQUEST == "678" ] || [ $TRAVIS_BRANCH == "coqlib-part-02" ]; then + + mathcomp_CI_BRANCH=coqlib-part-02 + mathcomp_CI_GITURL=https://github.com/ejgallego/math-comp.git + fi + diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 8ea1638c99..bcda4ff50a 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -51,12 +51,96 @@ In Constrexpr_ops: interpreting "(x y z:_)" as "(x:_) (y:_) (z:_)" while the second ones were preserving the original sharing of the type. +In Nameops: + + The API has been made more uniform. New combinators added in the + "Name" space name. Function "out_name" now fails with IsAnonymous + rather than with Failure "Nameops.out_name". + +Location handling and AST attributes: + + Location handling has been reworked. First, Loc.ghost has been + removed in favor of an option type, all objects carrying an optional + source code location have been switched to use `Loc.t option`. + + Storage of location information has been also refactored. The main + datatypes representing Coq AST (constrexpr, glob_expr) have been + switched to a generic "node with attributes" representation `'a + CAst.ast`, which is a record of the form: + +```ocaml +type 'a ast = private { + v : 'a; + loc : Loc.t option; + ... +} +``` + consumers of AST nodes are recommended to use accessor-based pattern + matching `{ v; loc }` to destruct `ast` object. Creation is done + with `CAst.make ?loc obj`, where the attributes are optional. Some + convenient combinators are provided in the module. A typical match: +``` +| CCase(loc, a1) -> CCase(loc, f a1) +``` + is now done as: +``` +| { v = CCase(a1); loc } -> CAst.make ?loc @@ CCase(f a1) +``` + or even better, if plan to preserve the attributes you can wrap your + top-level function in `CAst.map` to have: + +``` +| CCase(a1) -> CCase(f a1) +``` + + This scheme based on records enables easy extensibility of the AST + node type without breaking compatibility. + + Not all objects carrying a location have been converted to the + generic node representation, some of them may be converted in the + future, for some others the abstraction is not just worth it. + + Thus, we still maintain a `'a Loc.located == Loc.t option * a'`, + tuple type which should be treated as private datatype (ok to match + against, but forbidden to manually build), and it is mandatory to + use it for objects that carry a location. This policy has been + implemented in the whole code base. Matching a located object hasn't + changed, however, `Loc.tag ?loc obj` must be used to build one. + +In GOption: + + Support for non-synchronous options has been removed. Now all + options are handled as a piece of normal document state, and thus + passed to workers, etc... As a consequence, the field + `Goptions.optsync` has been removed. + +In Coqlib / reference location: + + We have removed from Coqlib functions returning `constr` from + names. Now it is only possible to obtain references, that must be + processed wrt the particular needs of the client. + We have changed in constrintern the functions returnin `constr` as + well to return global references instead. + + Users of `coq_constant/gen_constant` can do + `Universes.constr_of_global (find_reference dir r)` _however_ note + the warnings in the `Universes.constr_of_global` in the + documentation. It is very likely that you were previously suffering + from problems with polymorphic universes due to using + `Coqlib.coq_constant` that used to do this. You must rather use + `pf_constr_of_global` in tactics and `Evarutil.new_global` variants + when constructing terms in ML (see univpoly.txt for more information). + ** Tactic API ** - pf_constr_of_global now returns a tactic instead of taking a continuation. Thus it only generates one instance of the global reference, and it is the caller's responsibility to perform a focus on the goal. +- pf_global, construct_reference, global_reference, + global_reference_in_absolute_module now return a global_reference + instead of a constr. + - The tclWEAK_PROGRESS and tclNOTSAMEGOAL tacticals were removed. Their usecase was very specific. Use tclPROGRESS instead. @@ -93,13 +177,19 @@ alternative solution would be to fully qualify Ltac modules, e.g. turning any call to Tacinterp into Ltac_plugin.Tacinterp. Note that this solution does not work for EXTEND macros though. +** Additional changes in tactic extensions ** + +Entry "constr_with_bindings" has been renamed into +"open_constr_with_bindings". New entry "constr_with_bindings" now +uses type classes and rejects terms with unresolved holes. + ** Error handling ** - All error functions now take an optional parameter `?loc:Loc.t`. For functions that used to carry a suffix `_loc`, such suffix has been dropped. -- `errorlabstrm` has been removed in favor of `user_err`. +- `errorlabstrm` and `error` has been removed in favor of `user_err`. - The header parameter to `user_err` has been made optional. diff --git a/dev/top_printers.ml b/dev/top_printers.ml index ce6d5dff05..07a47c8b7a 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -26,7 +26,7 @@ open Clenv let _ = Detyping.print_evar_arguments := true let _ = Detyping.print_universes := true let _ = set_bool_option_value ["Printing";"Matching"] false -let _ = Detyping.set_detype_anonymous (fun _ _ -> raise Not_found) +let _ = Detyping.set_detype_anonymous (fun ?loc _ -> raise Not_found) (* std_ppcmds *) let pp x = Pp.pp_with !Topfmt.std_ft x @@ -510,7 +510,7 @@ let _ = extend_vernac_command_grammar ("PrintConstr", 0) None [GramTerminal "PrintConstr"; GramNonTerminal - (Loc.ghost,Some (rawwit wit_constr),Extend.Aentry Pcoq.Constr.constr)] + (Loc.tag (Some (rawwit wit_constr),Extend.Aentry Pcoq.Constr.constr))] let _ = try @@ -526,46 +526,46 @@ let _ = extend_vernac_command_grammar ("PrintPureConstr", 0) None [GramTerminal "PrintPureConstr"; GramNonTerminal - (Loc.ghost,Some (rawwit wit_constr),Extend.Aentry Pcoq.Constr.constr)] + (Loc.tag (Some (rawwit wit_constr),Extend.Aentry Pcoq.Constr.constr))] (* Setting printer of unbound global reference *) open Names open Libnames -let encode_path loc prefix mpdir suffix id = +let encode_path ?loc prefix mpdir suffix id = let dir = match mpdir with | None -> [] | Some (mp,dir) -> (DirPath.repr (dirpath_of_string (string_of_mp mp))@ DirPath.repr dir) in - Qualid (loc, make_qualid + Qualid (Loc.tag ?loc @@ make_qualid (DirPath.make (List.rev (Id.of_string prefix::dir@suffix))) id) -let raw_string_of_ref loc _ = function +let raw_string_of_ref ?loc _ = function | ConstRef cst -> let (mp,dir,id) = repr_con cst in - encode_path loc "CST" (Some (mp,dir)) [] (Label.to_id id) + encode_path ?loc "CST" (Some (mp,dir)) [] (Label.to_id id) | IndRef (kn,i) -> let (mp,dir,id) = repr_mind kn in - encode_path loc "IND" (Some (mp,dir)) [Label.to_id id] + encode_path ?loc "IND" (Some (mp,dir)) [Label.to_id id] (Id.of_string ("_"^string_of_int i)) | ConstructRef ((kn,i),j) -> let (mp,dir,id) = repr_mind kn in - encode_path loc "CSTR" (Some (mp,dir)) + encode_path ?loc "CSTR" (Some (mp,dir)) [Label.to_id id;Id.of_string ("_"^string_of_int i)] (Id.of_string ("_"^string_of_int j)) | VarRef id -> - encode_path loc "SECVAR" None [] id + encode_path ?loc "SECVAR" None [] id -let short_string_of_ref loc _ = function - | VarRef id -> Ident (loc,id) - | ConstRef cst -> Ident (loc,Label.to_id (pi3 (repr_con cst))) - | IndRef (kn,0) -> Ident (loc,Label.to_id (pi3 (repr_mind kn))) +let short_string_of_ref ?loc _ = function + | VarRef id -> Ident (Loc.tag ?loc id) + | ConstRef cst -> Ident (Loc.tag ?loc @@ Label.to_id (pi3 (repr_con cst))) + | IndRef (kn,0) -> Ident (Loc.tag ?loc @@ Label.to_id (pi3 (repr_mind kn))) | IndRef (kn,i) -> - encode_path loc "IND" None [Label.to_id (pi3 (repr_mind kn))] + encode_path ?loc "IND" None [Label.to_id (pi3 (repr_mind kn))] (Id.of_string ("_"^string_of_int i)) | ConstructRef ((kn,i),j) -> - encode_path loc "CSTR" None + encode_path ?loc "CSTR" None [Label.to_id (pi3 (repr_mind kn));Id.of_string ("_"^string_of_int i)] (Id.of_string ("_"^string_of_int j)) diff --git a/dev/v8-syntax/syntax-v8.tex b/dev/v8-syntax/syntax-v8.tex index 64431ea161..fa2864cec9 100644 --- a/dev/v8-syntax/syntax-v8.tex +++ b/dev/v8-syntax/syntax-v8.tex @@ -1158,7 +1158,7 @@ $$ \nlsep \TERM{Abort}~\NT{ident} \nlsep \TERM{Existential}~\NT{num}~\KWD{:=}~\NT{constr-body} \nlsep \TERM{Qed} -\nlsep \TERM{Save}~\OPTGR{\NT{thm-token}~\NT{ident}} +\nlsep \TERM{Save}~\NT{ident}} \nlsep \TERM{Defined}~\OPT{\NT{ident}} \nlsep \TERM{Suspend} \nlsep \TERM{Resume}~\OPT{\NT{ident}} diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index 0346c4a555..bb679ecba7 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -522,6 +522,19 @@ to have \emph{at least} one success. \ErrMsg \errindex{No applicable tactic} +\variant {\tt first {\tacexpr}} + +This is an Ltac alias that gives a primitive access to the {\tt first} tactical +as a Ltac definition without going through a parsing rule. It expects to be +given a list of tactics through a {\tt Tactic Notation}, allowing to write +notations of the following form. + +\Example + +\begin{quote} +{\tt Tactic Notation "{foo}" tactic\_list(tacs) := first tacs.} +\end{quote} + \subsubsection[Left-biased branching]{Left-biased branching\tacindex{$\mid\mid$} \index{Tacticals!orelse@{\tt $\mid\mid$}}} @@ -600,6 +613,11 @@ $v_2$ and so on. It fails if there is no solving tactic. \ErrMsg \errindex{Cannot solve the goal} +\variant {\tt solve {\tacexpr}} + +This is an Ltac alias that gives a primitive access to the {\tt solve} tactical. +See the {\tt first} tactical for more information. + \subsubsection[Identity]{Identity\label{ltac:idtac}\tacindex{idtac} \index{Tacticals!idtac@{\tt idtac}}} diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index 8ba28b32f1..0760d716e3 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -90,25 +90,12 @@ memory overflow. Defines the proved term as a transparent constant. -\item {\tt Save.} -\comindex{Save} - - This is a deprecated equivalent to {\tt Qed}. - \item {\tt Save {\ident}.} Forces the name of the original goal to be {\ident}. This command (and the following ones) can only be used if the original goal has been opened using the {\tt Goal} command. -\item {\tt Save Theorem {\ident}.} \\ - {\tt Save Lemma {\ident}.} \\ - {\tt Save Remark {\ident}.}\\ - {\tt Save Fact {\ident}.} - {\tt Save Corollary {\ident}.} - {\tt Save Proposition {\ident}.} - - Are equivalent to {\tt Save {\ident}.} \end{Variants} \subsection[\tt Admitted.]{\tt Admitted.\comindex{Admitted}\label{Admitted}} diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index fc3fdd0025..def42955ff 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -1155,6 +1155,15 @@ Section~\ref{Occurrences_clauses}. These are the general forms that combine the previous possibilities. +\item {\tt eset ( {\ident$_0$} \nelistnosep{\binder} := {\term} ) in {\occgoalset}}\tacindex{eset}\\ + {\tt eset {\term} in {\occgoalset}} + + While the different variants of \texttt{set} expect that no + existential variables are generated by the tactic, \texttt{eset} + removes this constraint. In practice, this is relevant only when + \texttt{eset} is used as a synonym of \texttt{epose}, i.e. when the + term does not occur in the goal. + \item {\tt remember {\term} as {\ident}}\tacindex{remember} This behaves as {\tt set ( {\ident} := {\term} ) in *} and using a @@ -1170,6 +1179,15 @@ Section~\ref{Occurrences_clauses}. This is a more general form of {\tt remember} that remembers the occurrences of {\term} specified by an occurrences set. +\item + {\tt eremember {\term} as {\ident}}\tacindex{eremember}\\ + {\tt eremember {\term} as {\ident} in {\occgoalset}}\\ + {\tt eremember {\term} as {\ident} eqn:{\ident}} + + While the different variants of \texttt{remember} expect that no + existential variables are generated by the tactic, \texttt{eremember} + removes this constraint. + \item {\tt pose ( {\ident} := {\term} )}\tacindex{pose} This adds the local definition {\ident} := {\term} to the current @@ -1187,6 +1205,14 @@ Section~\ref{Occurrences_clauses}. This behaves as {\tt pose ( {\ident} := {\term} )} but {\ident} is generated by {\Coq}. +\item {\tt epose ( {\ident} := {\term} )}\tacindex{epose}\\ + {\tt epose ( {\ident} \nelistnosep{\binder} := {\term} )}\\ + {\tt epose {\term}} + + While the different variants of \texttt{pose} expect that no + existential variables are generated by the tactic, \texttt{epose} + removes this constraint. + \end{Variants} \subsection{\tt decompose [ {\qualid$_1$} \dots\ {\qualid$_n$} ] \term} @@ -1284,6 +1310,14 @@ in the list of subgoals remaining to prove. \ErrMsg \errindex{Variable {\ident} is already declared} +\item \texttt{eassert {\form} as {\intropattern} by {\tac}}\tacindex{eassert}\tacindex{eassert as}\tacindex{eassert by}\\ + {\tt assert ( {\ident} := {\term} )} + + While the different variants of \texttt{assert} expect that no + existential variables are generated by the tactic, \texttt{eassert} + removes this constraint. This allows not to specify the asserted + statement completely before starting to prove it. + \item \texttt{pose proof {\term} \zeroone{as {\intropattern}}\tacindex{pose proof}} This tactic behaves like \texttt{assert T \zeroone{as {\intropattern}} by @@ -1294,6 +1328,11 @@ in the list of subgoals remaining to prove. as {\intropattern}} is the same as applying the {\intropattern} to {\term}. +\item \texttt{epose proof {\term} \zeroone{as {\intropattern}}\tacindex{epose proof}} + + While \texttt{pose proof} expects that no existential variables are generated by the tactic, + \texttt{epose proof} removes this constraint. + \item \texttt{enough ({\ident} :\ {\form})}\tacindex{enough} This adds a new hypothesis of name {\ident} asserting {\form} to the @@ -1320,6 +1359,14 @@ in the list of subgoals remaining to prove. destructed. If the \texttt{as} {\intropattern} clause generates more than one subgoal, {\tac} is applied to all of them. +\item \texttt{eenough ({\ident} :\ {\form}) by {\tac}}\tacindex{eenough}\tacindex{eenough as}\tacindex{eenough by}\\ + \texttt{eenough {\form} by {\tac}}\tacindex{enough by}\\ + \texttt{eenough {\form} as {\intropattern} by {\tac}} + + While the different variants of \texttt{enough} expect that no + existential variables are generated by the tactic, \texttt{eenough} + removes this constraint. + \item {\tt cut {\form}}\tacindex{cut} This tactic applies to any goal. It implements the non-dependent diff --git a/doc/refman/RefMan-tus.tex b/doc/refman/RefMan-tus.tex index 017de6d484..7e5bb81a90 100644 --- a/doc/refman/RefMan-tus.tex +++ b/doc/refman/RefMan-tus.tex @@ -707,7 +707,7 @@ Once all the existential variables have been defined the derivation is completed, and a construction can be generated from the proof tree, replacing each of the existential variables by its definition. This is exactly what happens when one of the commands -\texttt{Qed}, \texttt{Save} or \texttt{Defined} is invoked +\texttt{Qed} or \texttt{Defined} is invoked (see Section~\ref{Qed}). The saved theorem becomes a defined constant, whose body is the proof object generated. diff --git a/doc/refman/RefMan-uti.tex b/doc/refman/RefMan-uti.tex index 9962ce9961..08cdbee503 100644 --- a/doc/refman/RefMan-uti.tex +++ b/doc/refman/RefMan-uti.tex @@ -51,6 +51,95 @@ arguments. In other cases, the debugger is simply called without additional arguments. Such a wrapper can be found in the \texttt{dev/} subdirectory of the sources. +\section[Building a \Coq\ project with {\tt coq\_makefile}] +{Building a \Coq\ project with {\tt coq\_makefile} +\label{Makefile} +\ttindex{Makefile} +\ttindex{coq\_Makefile} +\ttindex{\_CoqProject}} + +The majority of \Coq\ projects are very similar: a collection of {\tt .v} +files and eventually some {\tt .ml} ones (a \Coq\ plugin). The main piece +of metadata needed in order to build the project are the command +line options to {\tt coqc} (e.g. {\tt -R, -I}, +\SeeAlso Section~\ref{coqoptions}). Collecting the list of files and +options is the job of the {\tt \_CoqProject} file. + +A simple example of a {\tt \_CoqProject} file follows: + +\begin{verbatim} +-R theories/ MyCode +theories/foo.v +theories/bar.v +-I src/ +src/baz.ml4 +src/bazaux.ml +src/qux_plugin.mlpack +\end{verbatim} + +Currently, both \CoqIDE{} and Proof General (version $\geq$ 4.3pre) understand +{\tt \_CoqProject} files and invoke \Coq\ with the desired options. + +The {\tt coq\_makefile} utility can be used to set up a build infrastructure +for the \Coq\ project based on makefiles. The recommended way of +invoking {\tt coq\_makefile} is the following one: + +\begin{verbatim} +coq_makefile -f _CoqProject -o CoqMakefile +\end{verbatim} + +Such command generates the following files: +\begin{description} + \item[{\tt CoqMakefile}] is a generic makefile for GNU Make that provides targets to build the project (both {\tt .v} and {\tt .ml*} files), to install it system-wide in the {\tt coq-contrib} directory (i.e. where \Coq\ is installed) as well as to invoke {\tt coqdoc} to generate html documentation. + + \item[{\tt CoqMakefile.conf}] contains make variables assignments that reflect the contents of the {\tt \_CoqProject} file as well as the path relevant to \Coq{}. +\end{description} + +An optional file {\bf {\tt CoqMakefile.local}} can be provided by the user in order to extend {\tt CoqMakefile}. In particular one can declare custom actions to be performed before or after the build process. Similarly one can customize the install target or even provide new targets. Extension points are documented in the {\tt CoqMakefile} file. + +The extensions of the files listed in {\tt \_CoqProject} is +used in order to decide how to build them In particular: + +\begin{itemize} +\item {\Coq} files must use the \texttt{.v} extension +\item {\ocaml} files must use the \texttt{.ml} or \texttt{.mli} extension +\item {\ocaml} files that require pre processing for syntax extensions (like {\tt VERNAC EXTEND}) must use the \texttt{.ml4} extension +\item In order to generate a plugin one has to list all {\ocaml} modules (i.e. ``Baz'' for ``baz.ml'') in a \texttt{.mlpack} file (or \texttt{.mllib} file). +\end{itemize} + +The use of \texttt{.mlpack} files has to be preferred over \texttt{.mllib} +files, since it results in a ``packed'' plugin: All auxiliary +modules (as {\tt Baz} and {\tt Bazaux}) are hidden inside +the plugin's ``name space'' ({\tt Qux\_plugin}). +This reduces the chances of begin unable to load two distinct plugins +because of a clash in their auxiliary module names. + +\paragraph{Notes about including the generated Makefile} + +This practice is discouraged. The contents of this file, including variable names +and status of rules shall change in the future. Users are advised to +include {\tt Makefile.conf} or call a target of the generated Makefile +as in {\tt make -f Makefile target} from another Makefile. + +\paragraph{Notes for users of {\tt coq\_makefile} with version $<$ 8.7} + +\begin{itemize} +\item Support for ``sub-directory'' is deprecated. To perform actions before + or after the build (like invoking make on a subdirectory) one can + hook in {\tt pre-all} and {\tt post-all} extension points +\item \texttt{-extra-phony} and \texttt{-extra} are deprecated. To provide + additional target ({\tt .PHONY} or not) please use + {\tt CoqMakefile.local} +\end{itemize} + +\paragraph{Note: building a subset of the targets with -j} + +To build, say, two targets \texttt{foo.vo} and \texttt{bar.vo} +in parallel one can use \texttt{make only TGTS="foo.vo bar.vo" -j}. + +Note that \texttt{make foo.vo bar.vo -j} has a different meaning for +the make utility, in particular it may build a shared prerequisite twice. + \section[Modules dependencies]{Modules dependencies\label{Dependencies}\index{Dependencies} \ttindex{coqdep}} @@ -73,110 +162,9 @@ instead for the \ocaml\ modules dependencies. See the man page of {\tt coqdep} for more details and options. - -\section[Creating a {\tt Makefile} for \Coq\ modules] -{Creating a {\tt Makefile} for \Coq\ modules -\label{Makefile} -\ttindex{Makefile} -\ttindex{coq\_Makefile} -\ttindex{\_CoqProject}} - -A project is a proof development split into several files, possibly -including the sources of some {\ocaml} plugins, that are located (in -various sub-directories of) a certain directory. The -\texttt{coq\_makefile} command allows to generate generic and complete -\texttt{Makefile} files, that can be used to compile the different -components of the project. A \_CoqProject file -specifies both the list of target files relevant to the project -and the common options that should be passed to each executable at -compilation times, for the IDE, etc. - -\paragraph{\_CoqProject file as an argument to coq\_Makefile.} -In particular, a \_CoqProject file contains the relevant -arguments to be passed to the \texttt{coq\_makefile} makefile -generator using for instance the command: - -\begin{quotation} -\texttt{\% coq\_makefile -f \_CoqProject -o Makefile} -\end{quotation} - -This command generates a file \texttt{Makefile} that can be used to -compile all the sources of the current project. It follows the -syntax described by the output of \texttt{\% coq\_makefile -{}-help}. -Once the \texttt{Makefile} file has been generated a first time, it -can be used by the \texttt{make} command to compile part or all of -the project. Note that once it has been generated once, as soon as -\texttt{\_CoqProject} file is updated, the \texttt{Makefile} file is -automatically regenerated by an invocation of \texttt{make}. - -The following command generates a minimal example of -\texttt{\_CoqProject} file: -\begin{quotation} -\texttt{\% ( echo "-R .\ }\textit{MyFancyLib}\texttt{" ; find .\ -name - "*.v" -print ) > \_CoqProject} -\end{quotation} -when executed at the root of the directory containing the -project. Here the \texttt{\_CoqProject} lists all the \texttt{.v} files -that are present in the current directory and its sub-directories. But no -plugin sources is listed. If a \texttt{Makefile} is generated from -this \texttt{\_CoqProject}, the command \texttt{make install} will -install the compiled project in a sub-directory \texttt{MyFancyLib} of -the \texttt{user-contrib} directory (of the user's {\Coq} libraries -location). This sub-directory is created if it does not already exist. - -\paragraph{\_CoqProject file as a configuration for IDEs.} - -A \texttt{\_CoqProject} file can also be used to configure the options -of the \texttt{coqtop} process executed by a user interface. This -allows to import the libraries of the project under a correct name, -both as a developer of the project, working in the directory -containing its sources, and as a user, using the project after -the installation of its libraries. Currently, both \CoqIDE{} and Proof -General (version $\geq$ 4.3pre) support configuration via -\texttt{\_CoqProject} files. - -\paragraph{Remarks.} - -\begin{itemize} -\item Every {\Coq} files must use a \texttt{.v} file extension. - The {\ocaml} modules must use a \texttt{.ml4} file extension - if they require camlp preprocessing (and in \texttt{.ml} otherwise). - The {\ocaml} module signatures, library - description and packing files must use respectively \texttt{.mli}, - \texttt{.mllib} and \texttt{.mlpack} file extension. - -\item Any argument that is not a valid option is considered as a - sub-directory. Any sub-directory specified in the list of targets must - itself contain a \texttt{Makefile}. - -\item The phony targets \texttt{all} and \texttt{clean} recursively - call their target in every sub-directory. - -\item \texttt{-R} and \texttt{-Q} options are for {\Coq} files, \texttt{-I} - for {\ocaml} ones. A same directory can be passed to both nature of - options, in the same \texttt{\_CoqProject}. - -\item Using \texttt{-R} or \texttt{-Q} is the appropriate way to - obtain both a correct logical path and a correct installation location to - the libraries of a given project. - -\item Dependencies on external libraries to the project must be - declared with care. If in the \texttt{\_CoqProject} file an external - library \texttt{foo} is passed to a \texttt{-Q} option, like in - \texttt{-Q foo}, the subsequent \textit{make clean} command can - erase \textit{foo}. It is hence safer to customize the - \texttt{COQPATH} variable (see \ref{envars}), to include the - location of the required external libraries. - -\item Using \texttt{-extra-phony} with no command adds extra - dependencies on already defined rules. For example the following - skeleton appends ``something'' to the \texttt{install} rule: -\begin{quotation} -\texttt{-extra-phony "install" "install-my-stuff" "" - -extra-phony "install-my-stuff" "" "something"} -\end{quotation} -\end{itemize} - +The build infrastructure generated by {\tt coq\_makefile} +uses {\tt coqdep} to automatically compute the dependencies +among the files part of the project. \section[Documenting \Coq\ files with coqdoc]{Documenting \Coq\ files with coqdoc\label{coqdoc} \ttindex{coqdoc}} diff --git a/doc/tutorial/Tutorial.tex b/doc/tutorial/Tutorial.tex index 0d537256bb..30b6304c16 100644 --- a/doc/tutorial/Tutorial.tex +++ b/doc/tutorial/Tutorial.tex @@ -385,13 +385,11 @@ apply H; [ assumption | apply H0; assumption ]. Let us now save lemma \verb:distr_impl:: \begin{coq_example} -Save. +Qed. \end{coq_example} -Here \verb:Save: needs no argument, since we gave the name \verb:distr_impl: -in advance; -it is however possible to override the given name by giving a different -argument to command \verb:Save:. +Here \verb:Qed: needs no argument, since we gave the name \verb:distr_impl: +in advance. Actually, such an easy combination of tactics \verb:intro:, \verb:apply: and \verb:assumption: may be found completely automatically by an automatic diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 54d3ce6cf7..5a05150d44 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -295,7 +295,7 @@ let decompose_lam_assum sigma c = let decompose_lam_n_assum sigma n c = let open Rel.Declaration in if n < 0 then - error "decompose_lam_n_assum: integer parameter must be positive"; + user_err Pp.(str "decompose_lam_n_assum: integer parameter must be positive"); let rec lamdec_rec l n c = if Int.equal n 0 then l,c else @@ -303,14 +303,14 @@ let decompose_lam_n_assum sigma n c = | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) n c | Cast (c,_,_) -> lamdec_rec l n c - | c -> error "decompose_lam_n_assum: not enough abstractions" + | c -> user_err Pp.(str "decompose_lam_n_assum: not enough abstractions") in lamdec_rec Context.Rel.empty n c let decompose_lam_n_decls sigma n = let open Rel.Declaration in if n < 0 then - error "decompose_lam_n_decls: integer parameter must be positive"; + user_err Pp.(str "decompose_lam_n_decls: integer parameter must be positive"); let rec lamdec_rec l n c = if Int.equal n 0 then l,c else @@ -318,7 +318,7 @@ let decompose_lam_n_decls sigma n = | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c - | c -> error "decompose_lam_n_decls: not enough abstractions" + | c -> user_err Pp.(str "decompose_lam_n_decls: not enough abstractions") in lamdec_rec Context.Rel.empty n @@ -363,7 +363,7 @@ let decompose_prod_assum sigma c = let decompose_prod_n_assum sigma n c = let open Rel.Declaration in if n < 0 then - error "decompose_prod_n_assum: integer parameter must be positive"; + user_err Pp.(str "decompose_prod_n_assum: integer parameter must be positive"); let rec prodec_rec l n c = if Int.equal n 0 then l,c else @@ -371,7 +371,7 @@ let decompose_prod_n_assum sigma n c = | Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c - | c -> error "decompose_prod_n_assum: not enough assumptions" + | c -> user_err Pp.(str "decompose_prod_n_assum: not enough assumptions") in prodec_rec Context.Rel.empty n c @@ -638,22 +638,54 @@ let eq_constr_universes_proj env sigma m n = let res = eq_constr' (unsafe_to_constr m) (unsafe_to_constr n) in if res then Some !cstrs else None +open Context +open Environ + +let cast_list : type a b. (a,b) eq -> a list -> b list = + fun Refl x -> x + +let cast_list_snd : type a b. (a,b) eq -> ('c * a) list -> ('c * b) list = + fun Refl x -> x + +let cast_rel_decl : + type a b. (a,b) eq -> (a, a) Rel.Declaration.pt -> (b, b) Rel.Declaration.pt = + fun Refl x -> x + +let cast_rel_context : + type a b. (a,b) eq -> (a, a) Rel.pt -> (b, b) Rel.pt = + fun Refl x -> x + +let cast_named_decl : + type a b. (a,b) eq -> (a, a) Named.Declaration.pt -> (b, b) Named.Declaration.pt = + fun Refl x -> x + +let cast_named_context : + type a b. (a,b) eq -> (a, a) Named.pt -> (b, b) Named.pt = + fun Refl x -> x + + module Vars = struct exception LocalOccur let to_constr = unsafe_to_constr +let to_rel_decl = unsafe_to_rel_decl + +type substl = t list (** Operations that commute with evar-normalization *) let lift n c = of_constr (Vars.lift n (to_constr c)) let liftn n m c = of_constr (Vars.liftn n m (to_constr c)) -let substnl subst n c = of_constr (Vars.substnl (List.map to_constr subst) n (to_constr c)) -let substl subst c = of_constr (Vars.substl (List.map to_constr subst) (to_constr c)) +let substnl subst n c = of_constr (Vars.substnl (cast_list unsafe_eq subst) n (to_constr c)) +let substl subst c = of_constr (Vars.substl (cast_list unsafe_eq subst) (to_constr c)) let subst1 c r = of_constr (Vars.subst1 (to_constr c) (to_constr r)) +let substnl_decl subst n d = of_rel_decl (Vars.substnl_decl (cast_list unsafe_eq subst) n (to_rel_decl d)) +let substl_decl subst d = of_rel_decl (Vars.substl_decl (cast_list unsafe_eq subst) (to_rel_decl d)) +let subst1_decl c d = of_rel_decl (Vars.subst1_decl (to_constr c) (to_rel_decl d)) + let replace_vars subst c = - let map (id, c) = (id, to_constr c) in - of_constr (Vars.replace_vars (List.map map subst) (to_constr c)) + of_constr (Vars.replace_vars (cast_list_snd unsafe_eq subst) (to_constr c)) let substn_vars n subst c = of_constr (Vars.substn_vars n subst (to_constr c)) let subst_vars subst c = of_constr (Vars.subst_vars subst (to_constr c)) let subst_var subst c = of_constr (Vars.subst_var subst (to_constr c)) @@ -685,7 +717,8 @@ let closedn sigma n c = let closed0 sigma c = closedn sigma 0 c let subst_of_rel_context_instance ctx subst = - List.map of_constr (Vars.subst_of_rel_context_instance (List.map unsafe_to_rel_decl ctx) (List.map to_constr subst)) + cast_list (sym unsafe_eq) + (Vars.subst_of_rel_context_instance (cast_rel_context unsafe_eq ctx) (cast_list unsafe_eq subst)) end @@ -728,27 +761,6 @@ let mkNamedLambda_or_LetIn decl c = let it_mkProd_or_LetIn t ctx = List.fold_left (fun c d -> mkProd_or_LetIn d c) t ctx let it_mkLambda_or_LetIn t ctx = List.fold_left (fun c d -> mkLambda_or_LetIn d c) t ctx -open Context -open Environ - -let sym : type a b. (a, b) eq -> (b, a) eq = fun Refl -> Refl - -let cast_rel_decl : - type a b. (a,b) eq -> (a, a) Rel.Declaration.pt -> (b, b) Rel.Declaration.pt = - fun Refl x -> x - -let cast_rel_context : - type a b. (a,b) eq -> (a, a) Rel.pt -> (b, b) Rel.pt = - fun Refl x -> x - -let cast_named_decl : - type a b. (a,b) eq -> (a, a) Named.Declaration.pt -> (b, b) Named.Declaration.pt = - fun Refl x -> x - -let cast_named_context : - type a b. (a,b) eq -> (a, a) Named.pt -> (b, b) Named.pt = - fun Refl x -> x - let push_rel d e = push_rel (cast_rel_decl unsafe_eq d) e let push_rel_context d e = push_rel_context (cast_rel_context unsafe_eq d) e let push_named d e = push_named (cast_named_decl unsafe_eq d) e @@ -770,6 +782,9 @@ let fresh_global ?loc ?rigid ?names env sigma reference = Sigma.fresh_global ?loc ?rigid ?names env sigma reference in Sigma.Sigma (of_constr t,sigma,p) +let is_global sigma gr c = + Globnames.is_global gr (to_constr sigma c) + module Unsafe = struct let to_sorts = ESorts.unsafe_to_sorts diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 693b592fd4..9f45187cff 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -205,12 +205,21 @@ val fold : Evd.evar_map -> ('a -> t -> 'a) -> 'a -> t -> 'a module Vars : sig + +(** See vars.mli for the documentation of the functions below *) + +type substl = t list + val lift : int -> t -> t val liftn : int -> int -> t -> t -val substnl : t list -> int -> t -> t -val substl : t list -> t -> t +val substnl : substl -> int -> t -> t +val substl : substl -> t -> t val subst1 : t -> t -> t +val substnl_decl : substl -> int -> rel_declaration -> rel_declaration +val substl_decl : substl -> rel_declaration -> rel_declaration +val subst1_decl : t -> rel_declaration -> rel_declaration + val replace_vars : (Id.t * t) list -> t -> t val substn_vars : int -> Id.t list -> t -> t val subst_vars : Id.t list -> t -> t @@ -252,6 +261,8 @@ val fresh_global : ?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> 'r Sigma.t -> Globnames.global_reference -> (t, 'r) Sigma.sigma +val is_global : Evd.evar_map -> Globnames.global_reference -> t -> bool + (** {5 Extra} *) val of_named_decl : (Constr.t, Constr.types) Context.Named.Declaration.pt -> (t, types) Context.Named.Declaration.pt diff --git a/engine/evarutil.ml b/engine/evarutil.ml index e85c1f6fd8..3ef725cbbd 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -365,12 +365,12 @@ let push_rel_context_to_named_context env sigma typ = * Entry points to define new evars * *------------------------------------*) -let default_source = (Loc.ghost,Evar_kinds.InternalHole) +let default_source = Loc.tag @@ Evar_kinds.InternalHole -let restrict_evar evd evk filter candidates = +let restrict_evar evd evk filter ?src candidates = let evd = Sigma.to_evar_map evd in let candidates = Option.map (fun l -> List.map EConstr.Unsafe.to_constr l) candidates in - let evd, evk' = Evd.restrict evk filter ?candidates evd in + let evd, evk' = Evd.restrict evk filter ?candidates ?src evd in Sigma.Unsafe.of_pair (evk', Evd.declare_future_goal evk' evd) let new_pure_evar_full evd evi = diff --git a/engine/evarutil.mli b/engine/evarutil.mli index ca9591e71b..496ec5bc43 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -22,13 +22,13 @@ val mk_new_meta : unit -> constr (** {6 Creating a fresh evar given their type and context} *) val new_evar : - env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + env -> 'r Sigma.t -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> types -> (constr, 'r) Sigma.sigma val new_pure_evar : - named_context_val -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + named_context_val -> 'r Sigma.t -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> types -> (evar, 'r) Sigma.sigma @@ -37,7 +37,7 @@ val new_pure_evar_full : 'r Sigma.t -> evar_info -> (evar, 'r) Sigma.sigma (** the same with side-effects *) val e_new_evar : - env -> evar_map ref -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + env -> evar_map ref -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> types -> constr @@ -45,19 +45,19 @@ val e_new_evar : (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : - env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + env -> 'r Sigma.t -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> (constr * sorts, 'r) Sigma.sigma val e_new_type_evar : env -> evar_map ref -> - ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts val new_Type : ?rigid:rigid -> env -> 'r Sigma.t -> (constr, 'r) Sigma.sigma val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr val restrict_evar : 'r Sigma.t -> existential_key -> Filter.t -> - constr list option -> (existential_key, 'r) Sigma.sigma + ?src:Evar_kinds.t Loc.located -> constr list option -> (existential_key, 'r) Sigma.sigma (** Polymorphic constants *) @@ -72,7 +72,7 @@ val e_new_global : evar_map ref -> Globnames.global_reference -> constr as a telescope) is [sign] *) val new_evar_instance : named_context_val -> 'r Sigma.t -> types -> - ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> + ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> constr list -> (constr, 'r) Sigma.sigma diff --git a/engine/evd.ml b/engine/evd.ml index db048bbd6e..48fceae9ec 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -149,7 +149,7 @@ let make_evar hyps ccl = { evar_hyps = hyps; evar_body = Evar_empty; evar_filter = Filter.identity; - evar_source = (Loc.ghost,Evar_kinds.InternalHole); + evar_source = Loc.tag @@ Evar_kinds.InternalHole; evar_candidates = None; evar_extra = Store.empty } @@ -653,12 +653,13 @@ let define evk body evd = let evar_names = EvNames.remove_name_defined evk evd.evar_names in { evd with defn_evars; undf_evars; last_mods; evar_names } -let restrict evk filter ?candidates evd = +let restrict evk filter ?candidates ?src evd = let evk' = new_untyped_evar () in let evar_info = EvMap.find evk evd.undf_evars in let evar_info' = { evar_info with evar_filter = filter; evar_candidates = candidates; + evar_source = (match src with None -> evar_info.evar_source | Some src -> src); evar_extra = Store.empty } in let last_mods = match evd.conv_pbs with | [] -> evd.last_mods @@ -704,7 +705,7 @@ let loc_of_conv_pb evd (pbty,env,t1,t2) = | _ -> match kind_of_term (fst (decompose_app t2)) with | Evar (evk2,_) -> fst (evar_source evk2 evd) - | _ -> Loc.ghost + | _ -> None (** The following functions return the set of evars immediately contained in the object *) @@ -790,7 +791,7 @@ let make_evar_universe_context e l = | Some us -> List.fold_left (fun uctx (loc,id) -> - fst (UState.new_univ_variable ~loc univ_rigid (Some (Id.to_string id)) uctx)) + fst (UState.new_univ_variable ?loc univ_rigid (Some (Id.to_string id)) uctx)) uctx us (****************************************) @@ -952,7 +953,7 @@ let declare_principal_goal evk evd = | None -> { evd with future_goals = evk::evd.future_goals; principal_future_goal=Some evk; } - | Some _ -> CErrors.error "Only one main subgoal per instantiation." + | Some _ -> CErrors.user_err Pp.(str "Only one main subgoal per instantiation.") let future_goals evd = evd.future_goals @@ -1082,8 +1083,8 @@ let retract_coercible_metas evd = let evar_source_of_meta mv evd = match meta_name evd mv with - | Anonymous -> (Loc.ghost,Evar_kinds.GoalEvar) - | Name id -> (Loc.ghost,Evar_kinds.VarInstance id) + | Anonymous -> Loc.tag Evar_kinds.GoalEvar + | Name id -> Loc.tag @@ Evar_kinds.VarInstance id let dependent_evar_ident ev evd = let evi = find evd ev in diff --git a/engine/evd.mli b/engine/evd.mli index 9c40c8b715..86755c360b 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -240,7 +240,7 @@ val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> (** {6 Misc} *) val restrict : evar -> Filter.t -> ?candidates:constr list -> - evar_map -> evar_map * evar + ?src:Evar_kinds.t located -> evar_map -> evar_map * evar (** Restrict an undefined evar into a new evar by filtering context and possibly limiting the instances to a set of candidates *) @@ -414,7 +414,7 @@ val extract_changed_conv_pbs : evar_map -> (Evar.Set.t -> evar_constraint -> bool) -> evar_map * evar_constraint list val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list -val loc_of_conv_pb : evar_map -> evar_constraint -> Loc.t +val loc_of_conv_pb : evar_map -> evar_constraint -> Loc.t option (** The following functions return the set of evars immediately contained in the object; need the term to be evar-normal otherwise diff --git a/engine/namegen.ml b/engine/namegen.ml index 3b979f206e..5bd62273c8 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -418,8 +418,7 @@ let use_h_based_elimination_names () = open Goptions let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "use of \"H\"-based proposition names in elimination tactics"; optkey = ["Standard";"Proposition";"Elimination";"Names"]; optread = (fun () -> !h_based_elimination_names); diff --git a/engine/proofview.ml b/engine/proofview.ml index 99bd4bc4ff..29bb1ef397 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -66,7 +66,7 @@ let dependent_init = for type classes. *) let store = Evd.Store.set Evd.Store.empty typeclass_resolvable () in (* Goals don't have a source location. *) - let src = (Loc.ghost,Evar_kinds.GoalEvar) in + let src = Loc.tag @@ Evar_kinds.GoalEvar in (* Main routine *) let rec aux = function | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] } @@ -289,7 +289,7 @@ let tclONCE = Proof.once exception MoreThanOneSuccess let _ = CErrors.register_handler begin function - | MoreThanOneSuccess -> CErrors.error "This tactic has more than one success." + | MoreThanOneSuccess -> CErrors.user_err Pp.(str "This tactic has more than one success.") | _ -> raise CErrors.Unhandled end @@ -696,6 +696,12 @@ let mark_in_evm ~goal evd content = let info = if goal then { info with Evd.evar_source = match info.Evd.evar_source with + (* Two kinds for goal evars: + - GoalEvar (morally not dependent) + - VarInstance (morally dependent of some name). + This is a heuristic for naming these evars. *) + | loc, (Evar_kinds.QuestionMark (_,Names.Name id) | + Evar_kinds.ImplicitArg (_,(_,Some id),_)) -> loc, Evar_kinds.VarInstance id | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x | loc,_ -> loc,Evar_kinds.GoalEvar } else info diff --git a/engine/termops.ml b/engine/termops.ml index 19e62f8e62..cbb0f0779f 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -31,10 +31,6 @@ let pr_sort_family = function | InProp -> (str "Prop") | InType -> (str "Type") -let pr_name = function - | Name id -> pr_id id - | Anonymous -> str "_" - let pr_con sp = str(string_of_con sp) let pr_fix pr_constr ((t,i),(lna,tl,bl)) = @@ -42,7 +38,7 @@ let pr_fix pr_constr ((t,i),(lna,tl,bl)) = hov 1 (str"fix " ++ int i ++ spc() ++ str"{" ++ v 0 (prlist_with_sep spc (fun (na,i,ty,bd) -> - pr_name na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++ + Name.print na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++ cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ str"}") @@ -65,10 +61,10 @@ let rec pr_constr c = match kind_of_term c with (str"(" ++ pr_constr t ++ str " ->" ++ spc() ++ pr_constr c ++ str")") | Lambda (na,t,c) -> hov 1 - (str"fun " ++ pr_name na ++ str":" ++ + (str"fun " ++ Name.print na ++ str":" ++ pr_constr t ++ str" =>" ++ spc() ++ pr_constr c) | LetIn (na,b,t,c) -> hov 0 - (str"let " ++ pr_name na ++ str":=" ++ pr_constr b ++ + (str"let " ++ Name.print na ++ str":=" ++ pr_constr b ++ str":" ++ brk(1,2) ++ pr_constr t ++ cut() ++ pr_constr c) | App (c,l) -> hov 1 @@ -93,7 +89,7 @@ let rec pr_constr c = match kind_of_term c with hov 1 (str"cofix " ++ int i ++ spc() ++ str"{" ++ v 0 (prlist_with_sep spc (fun (na,ty,bd) -> - pr_name na ++ str":" ++ pr_constr ty ++ + Name.print na ++ str":" ++ pr_constr ty ++ cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ str"}") @@ -112,6 +108,7 @@ let pr_evar_suggested_name evk sigma = | None -> match evi.evar_source with | _,Evar_kinds.ImplicitArg (c,(n,Some id),b) -> id | _,Evar_kinds.VarInstance id -> id + | _,Evar_kinds.QuestionMark (_,Name id) -> id | _,Evar_kinds.GoalEvar -> Id.of_string "Goal" | _ -> let env = reset_with_named_context evi.evar_hyps (Global.env()) in @@ -308,8 +305,8 @@ let pr_evar_universe_context ctx = let print_env_short env = let print_constr = print_kconstr in let pr_rel_decl = function - | RelDecl.LocalAssum (n,_) -> pr_name n - | RelDecl.LocalDef (n,b,_) -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" + | RelDecl.LocalAssum (n,_) -> Name.print n + | RelDecl.LocalDef (n,b,_) -> str "(" ++ Name.print n ++ str " := " ++ print_constr b ++ str ")" in let pr_named_decl = NamedDecl.to_rel_decl %> pr_rel_decl in let nc = List.rev (named_context env) in @@ -1468,25 +1465,3 @@ let env_rel_context_chop k env = let ctx1,ctx2 = List.chop k rels in push_rel_context ctx2 (reset_with_named_context (named_context_val env) env), ctx1 - -(*******************************************) -(* Functions to deal with impossible cases *) -(*******************************************) -let impossible_default_case = ref None - -let set_impossible_default_clause c = impossible_default_case := Some c - -let coq_unit_judge = - let make_judge c t = make_judge (EConstr.of_constr c) (EConstr.of_constr t) in - let na1 = Name (Id.of_string "A") in - let na2 = Name (Id.of_string "H") in - fun () -> - match !impossible_default_case with - | Some fn -> - let (id,type_of_id), ctx = fn () in - make_judge id type_of_id, ctx - | None -> - (* In case the constants id/ID are not defined *) - make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1))) - (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))), - Univ.ContextSet.empty diff --git a/engine/termops.mli b/engine/termops.mli index fe6dfb0ce1..58837ba033 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -275,10 +275,6 @@ val on_judgment : ('a -> 'b) -> ('a, 'a) punsafe_judgment -> ('b, 'b) puns val on_judgment_value : ('c -> 'c) -> ('c, 't) punsafe_judgment -> ('c, 't) punsafe_judgment val on_judgment_type : ('t -> 't) -> ('c, 't) punsafe_judgment -> ('c, 't) punsafe_judgment -(** {6 Functions to deal with impossible cases } *) -val set_impossible_default_clause : (unit -> (Constr.constr * Constr.types) Univ.in_universe_context_set) -> unit -val coq_unit_judge : unit -> unsafe_judgment Univ.in_universe_context_set - (** {5 Debug pretty-printers} *) open Evd diff --git a/engine/uState.ml b/engine/uState.ml index e27d0536d6..acef901432 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -188,7 +188,7 @@ let process_universe_constraints ctx cstrs = | _ -> local else begin match Univ.Universe.level r with - | None -> error ("Algebraic universe on the right") + | None -> user_err Pp.(str "Algebraic universe on the right") | Some r' -> if Univ.Level.is_small r' then let levels = Univ.Universe.levels l in @@ -258,7 +258,7 @@ let universe_context ?names ctx = let l = try UNameMap.find (Id.to_string id) (fst ctx.uctx_names) with Not_found -> - user_err ~loc ~hdr:"universe_context" + user_err ?loc ~hdr:"universe_context" (str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc)) pl ([], [], levels) @@ -269,10 +269,10 @@ let universe_context ?names ctx = try let info = Univ.LMap.find (Univ.LSet.choose left) (snd ctx.uctx_names) in - Option.default Loc.ghost info.uloc - with Not_found -> Loc.ghost + info.uloc + with Not_found -> None in - user_err ~loc ~hdr:"universe_context" + user_err ?loc ~hdr:"universe_context" ((str(CString.plural n "Universe") ++ spc () ++ Univ.LSet.pr (pr_uctx_level ctx) left ++ spc () ++ str (CString.conjugate_verb_to_be n) ++ diff --git a/grammar/argextend.mlp b/grammar/argextend.mlp index 5cfcc6fd22..c736e1a746 100644 --- a/grammar/argextend.mlp +++ b/grammar/argextend.mlp @@ -9,7 +9,6 @@ open Q_util let loc = Ploc.dummy -let default_loc = <:expr< Loc.ghost >> IFDEF STRICT THEN let ploc_vala x = Ploc.VaVal x diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index 3057ee58ca..8e3dccf47e 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -20,8 +20,6 @@ let make_fun loc cl = let l = cl @ [default_patt loc] in MLast.ExFun (loc, ploc_vala l) (* correspond to <:expr< fun [ $list:l$ ] >> *) -let dloc = <:expr< Loc.ghost >> - let plugin_name = <:expr< __coq_plugin_name >> let mlexpr_of_ident id = @@ -75,7 +73,7 @@ let rec mlexpr_of_symbol = function let make_prod_item = function | ExtTerminal s -> <:expr< Tacentries.TacTerm $str:s$ >> | ExtNonTerminal (g, id) -> - <:expr< Tacentries.TacNonTerm $default_loc$ $mlexpr_of_symbol g$ $mlexpr_of_option mlexpr_of_ident id$ >> + <:expr< Tacentries.TacNonTerm (Loc.tag ( $mlexpr_of_symbol g$ , $mlexpr_of_option mlexpr_of_ident id$ ) ) >> let mlexpr_of_clause cl = mlexpr_of_list (fun (a,_,_) -> mlexpr_of_list make_prod_item a) cl @@ -114,7 +112,7 @@ let declare_tactic loc tacname ~level classification clause = match clause with (** Arguments are not passed directly to the ML tactic in the TacML node, the ML tactic retrieves its arguments in the [ist] environment instead. This is the rôle of the [lift_constr_tac_to_ml_tac] function. *) - let body = <:expr< Tacexpr.TacFun ($vars$, Tacexpr.TacML ($dloc$, $ml$, [])) >> in + let body = <:expr< Tacexpr.TacFun ($vars$, Tacexpr.TacML (Loc.tag ( $ml$ , []))) >> in let name = <:expr< Names.Id.of_string $name$ >> in declare_str_items loc [ <:str_item< do { diff --git a/grammar/vernacextend.mlp b/grammar/vernacextend.mlp index 7c99b52e85..4f9a7c75cf 100644 --- a/grammar/vernacextend.mlp +++ b/grammar/vernacextend.mlp @@ -105,8 +105,8 @@ let make_prod_item = function let nt = type_of_user_symbol g in let base s = <:expr< Pcoq.genarg_grammar ($mk_extraarg loc s$) >> in let typ = match ido with None -> None | Some _ -> Some nt in - <:expr< Egramml.GramNonTerminal $default_loc$ $mlexpr_of_option (make_rawwit loc) typ$ - $mlexpr_of_prod_entry_key base g$ >> + <:expr< Egramml.GramNonTerminal ( Loc.tag ( $mlexpr_of_option (make_rawwit loc) typ$ , + $mlexpr_of_prod_entry_key base g$ ) ) >> let mlexpr_of_clause cl = let mkexpr { r_head = a; r_patt = b; } = match a with diff --git a/ide/coqOps.ml b/ide/coqOps.ml index b180aa5569..d30d7ab5e0 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -14,7 +14,7 @@ open Feedback let b2c = byte_offset_to_char_offset -type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of Loc.t * string | `WARNING of Loc.t * string ] +type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of string Loc.located | `WARNING of string Loc.located ] type mem_flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR | `WARNING ] let mem_flag_of_flag : flag -> mem_flag = function | `ERROR _ -> `ERROR @@ -462,20 +462,18 @@ object(self) self#attach_tooltip ~loc sentence (Printf.sprintf "%s %s %s" filepath ident ty) | Message(Error, loc, msg), Some (id,sentence) -> - let uloc = Option.default Loc.ghost loc in log_pp ?id Pp.(str "ErrorMsg" ++ msg); remove_flag sentence `PROCESSING; - let rmsg = Pp.string_of_ppcmds msg in - add_flag sentence (`ERROR (uloc, rmsg)); + let rmsg = Pp.string_of_ppcmds msg in + add_flag sentence (`ERROR (loc, rmsg)); self#mark_as_needed sentence; - self#attach_tooltip sentence ?loc rmsg; + self#attach_tooltip ?loc sentence rmsg; self#position_tag_at_sentence ?loc Tags.Script.error sentence | Message(Warning, loc, msg), Some (id,sentence) -> - let uloc = Option.default Loc.ghost loc in log_pp ?id Pp.(str "WarningMsg" ++ msg); let rmsg = Pp.string_of_ppcmds msg in - add_flag sentence (`WARNING (uloc, rmsg)); - self#attach_tooltip sentence ?loc rmsg; + add_flag sentence (`WARNING (loc, rmsg)); + self#attach_tooltip ?loc sentence rmsg; self#position_tag_at_sentence ?loc Tags.Script.warning sentence; messages#push Warning msg | Message(lvl, loc, msg), Some (id,sentence) -> @@ -525,14 +523,14 @@ object(self) let start, stop, phrase = self#get_sentence sentence in self#position_tag_at_iter ?loc start stop tag phrase - method private process_interp_error queue sentence loc msg tip id = + method private process_interp_error ?loc queue sentence msg tip id = Coq.bind (Coq.return ()) (function () -> let start, stop, phrase = self#get_sentence sentence in buffer#remove_tag Tags.Script.to_process ~start ~stop; self#discard_command_queue queue; pop_info (); if Stateid.equal id tip || Stateid.equal id Stateid.dummy then begin - self#position_tag_at_iter ~loc start stop Tags.Script.error phrase; + self#position_tag_at_iter ?loc start stop Tags.Script.error phrase; buffer#place_cursor ~where:stop; messages#clear; messages#push Feedback.Error msg; @@ -646,9 +644,9 @@ object(self) if Queue.is_empty queue then loop tip [] else loop tip (List.rev topstack) | Fail (id, loc, msg) -> - let loc = Option.cata Loc.make_loc Loc.ghost loc in + let loc = Option.map Loc.make_loc loc in let sentence = Doc.pop document in - self#process_interp_error queue sentence loc msg tip id in + self#process_interp_error ?loc queue sentence msg tip id in Coq.bind coq_query handle_answer in let tip = @@ -678,14 +676,13 @@ object(self) let extract_error s = match List.find (function `ERROR _ -> true | _ -> false) s.flags with | `ERROR (loc, msg) -> - let iter = - if Loc.is_ghost loc then - buffer#get_iter_at_mark s.start - else + let iter = begin match loc with + | None -> buffer#get_iter_at_mark s.start + | Some loc -> let (iter, _, phrase) = self#get_sentence s in let (start, _) = Loc.unloc loc in - iter#forward_chars (b2c phrase start) in - iter#line + 1, msg + iter#forward_chars (b2c phrase start) + end in iter#line + 1, msg | _ -> assert false in List.rev (Doc.fold_all document [] (fun acc _ _ s -> diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index d55e7f9dd7..5912bec357 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -105,8 +105,7 @@ let commands = [ "Reset Extraction Inline"; "Restore State"; ]; - [ "Save."; - "Scheme"; + [ "Scheme"; "Section"; "Set Extraction AutoInline"; "Set Extraction Optimize"; diff --git a/ide/coqide.ml b/ide/coqide.ml index 0b7567a5ae..a1e78ee3c9 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -46,7 +46,7 @@ open Session (** The arguments that will be passed to coqtop. No quoting here, since no /bin/sh when using create_process instead of open_process. *) -let custom_project_files = ref [] +let custom_project_file = ref None let sup_args = ref [] let logfile = ref None @@ -81,17 +81,27 @@ let pr_exit_status = function | Unix.WEXITED 0 -> " succeeded" | _ -> " failed" -let make_coqtop_args = function - |None -> "", !sup_args - |Some the_file -> - let get_args f = Project_file.args_from_project f - !custom_project_files project_file_name#get - in - match read_project#get with - |Ignore_args -> "", !sup_args - |Append_args -> - let fname, args = get_args the_file in fname, args @ !sup_args - |Subst_args -> get_args the_file +let make_coqtop_args fname = + let open CoqProject_file in + let base_args = match read_project#get with + | Ignore_args -> !sup_args + | Append_args -> !sup_args + | Subst_args -> [] in + if read_project#get = Ignore_args then "", base_args + else + match !custom_project_file, fname with + | Some (d,proj), _ -> d, coqtop_args_from_project proj @ base_args + | None, None -> "", base_args + | None, Some the_file -> + match + CoqProject_file.find_project_file + ~from:(Filename.dirname the_file) + ~projfile_name:project_file_name#get + with + | None -> "", base_args + | Some proj -> + proj, coqtop_args_from_project (read_project_file proj) @ base_args +;; (** Setting drag & drop on widgets *) @@ -1103,8 +1113,8 @@ let build_ui () = menu templates_menu [ item "Templates" ~label:"Te_mplates"; - template_item ("Lemma new_lemma : .\nProof.\n\nSave.\n", 6,9, "J"); - template_item ("Theorem new_theorem : .\nProof.\n\nSave.\n", 8,11, "T"); + template_item ("Lemma new_lemma : .\nProof.\n\nQed.\n", 6,9, "J"); + template_item ("Theorem new_theorem : .\nProof.\n\nQed.\n", 8,11, "T"); template_item ("Definition ident := .\n", 11,5, "E"); template_item ("Inductive ident : :=\n | : .\n", 10,5, "I"); template_item ("Fixpoint ident (_ : _) {struct _} : _ :=\n.\n", 9,5, "F"); @@ -1345,9 +1355,11 @@ let read_coqide_args argv = if coqtop = None then filter_coqtop (Some prog) project_files out args else (output_string stderr "Error: multiple -coqtop options"; exit 1) |"-f" :: file :: args -> + if project_files <> None then + (output_string stderr "Error: multiple -f options"; exit 1); let d = CUnix.canonical_path_name (Filename.dirname file) in - let p = Project_file.read_project_file file in - filter_coqtop coqtop ((d,p) :: project_files) out args + let p = CoqProject_file.read_project_file file in + filter_coqtop coqtop (Some (d,p)) out args |"-f" :: [] -> output_string stderr "Error: missing project file name"; exit 1 |"-coqtop" :: [] -> @@ -1364,11 +1376,11 @@ let read_coqide_args argv = (* argument added by MacOS during .app launch *) filter_coqtop coqtop project_files out args |arg::args -> filter_coqtop coqtop project_files (arg::out) args - |[] -> (coqtop,List.rev project_files,List.rev out) + |[] -> (coqtop,project_files,List.rev out) in - let coqtop,project_files,argv = filter_coqtop None [] [] argv in + let coqtop,project_files,argv = filter_coqtop None None [] argv in Ideutils.custom_coqtop := coqtop; - custom_project_files := project_files; + custom_project_file := project_files; argv diff --git a/ide/ide.mllib b/ide/ide.mllib index 78b4c01e8c..57e9fe5adc 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -9,6 +9,8 @@ Config_lexer Utf8_convert Preferences Project_file +Serialize +Richprinter Xml_lexer Xml_parser Xml_printer diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index dbca959eae..4e613f163e 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -65,8 +65,8 @@ let is_known_option cmd = match cmd with (** Check whether a command is forbidden in the IDE *) let ide_cmd_checks ~id (loc,ast) = - let user_error s = CErrors.user_err ~loc ~hdr:"CoqIde" (str s) in - let warn msg = Feedback.(feedback ~id (Message (Warning, Some loc, strbrk msg))) in + let user_error s = CErrors.user_err ?loc ~hdr:"CoqIde" (str s) in + let warn msg = Feedback.(feedback ~id (Message (Warning, loc, strbrk msg))) in if is_debug ast then user_error "Debug mode not available in the IDE"; if is_known_option ast then @@ -312,7 +312,7 @@ let import_option_value = function | Interface.StringOptValue s -> Goptions.StringOptValue s let export_option_state s = { - Interface.opt_sync = s.Goptions.opt_sync; + Interface.opt_sync = true; Interface.opt_depr = s.Goptions.opt_depr; Interface.opt_name = s.Goptions.opt_name; Interface.opt_value = export_option_value s.Goptions.opt_value; @@ -343,8 +343,8 @@ let about () = { let handle_exn (e, info) = let dummy = Stateid.dummy in let loc_of e = match Loc.get_loc e with - | Some loc when not (Loc.is_ghost loc) -> Some (Loc.unloc loc) - | _ -> None in + | Some loc -> Some (Loc.unloc loc) + | _ -> None in let mk_msg () = CErrors.print ~info e in match e with | CErrors.Drop -> dummy, None, Pp.str "Drop is not allowed by coqide!" diff --git a/ide/ideutils.ml b/ide/ideutils.ml index a08ab07b5f..8a0e507c0b 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -422,7 +422,7 @@ let browse prerr url = let doc_url () = if doc_url#get = use_default_doc_url || doc_url#get = "" then - let addr = List.fold_left Filename.concat (Coq_config.docdir) + let addr = List.fold_left Filename.concat (Envars.docdir ()) ["html";"refman";"index.html"] in if Sys.file_exists addr then "file://"^addr else Coq_config.wwwrefman diff --git a/ide/minilib.ml b/ide/minilib.ml index 2c24e46f8f..2b278fac69 100644 --- a/ide/minilib.ml +++ b/ide/minilib.ml @@ -54,12 +54,12 @@ let coqide_config_home () = let coqide_data_dirs () = coqify (Glib.get_user_data_dir ()) :: List.map coqify (Glib.get_system_data_dirs ()) - @ Option.List.cons Coq_config.datadir [] + @ [Envars.datadir ()] let coqide_config_dirs () = coqide_config_home () :: List.map coqify (Glib.get_system_config_dirs ()) - @ Option.List.cons Coq_config.configdir [] + @ [Envars.configdir ()] let is_prefix_of pre s = let i = ref 0 in diff --git a/ide/preferences.ml b/ide/preferences.ml index 9fe9c6337d..08739d013e 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -643,6 +643,10 @@ let pmodifiers ?(all = false) name p = modifiers name (str_to_mod_list p#get) +[@@@ocaml.warning "-3"] (* String.uppercase_ascii since 4.03.0 GPR#124 *) +let uppercase = String.uppercase +[@@@ocaml.warning "+3"] + let configure ?(apply=(fun () -> ())) () = let cmd_coqtop = string @@ -918,7 +922,7 @@ let configure ?(apply=(fun () -> ())) () = in let doc_url = let predefined = [ - "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["refman";"html"]); + "file://"^(List.fold_left Filename.concat (Envars.docdir ()) ["refman";"html"]); Coq_config.wwwrefman; use_default_doc_url ] in @@ -931,7 +935,7 @@ let configure ?(apply=(fun () -> ())) () = doc_url#get in let library_url = let predefined = [ - "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["stdlib";"html"]); + "file://"^(List.fold_left Filename.concat (Envars.docdir ()) ["stdlib";"html"]); Coq_config.wwwstdlib ] in combo @@ -969,7 +973,7 @@ let configure ?(apply=(fun () -> ())) () = let k = if Int.equal (CString.length k) 1 && Util.is_letter k.[0] then k else "" in - let k = CString.uppercase k in + let k = uppercase k in [q, k] in diff --git a/ide/project_file.ml4 b/ide/project_file.ml4 deleted file mode 100644 index de0720e033..0000000000 --- a/ide/project_file.ml4 +++ /dev/null @@ -1,202 +0,0 @@ -type target = - | ML of string (* ML file : foo.ml -> (ML "foo.ml") *) - | MLI of string (* MLI file : foo.mli -> (MLI "foo.mli") *) - | ML4 of string (* ML4 file : foo.ml4 -> (ML4 "foo.ml4") *) - | MLLIB of string (* MLLIB file : foo.mllib -> (MLLIB "foo.mllib") *) - | MLPACK of string (* MLLIB file : foo.mlpack -> (MLLIB "foo.mlpack") *) - | V of string (* V file : foo.v -> (V "foo") *) - | Arg of string - | Special of string * string * bool * string - (* file, dependencies, is_phony, command *) - | Subdir of string - | Def of string * string (* X=foo -> Def ("X","foo") *) - | MLInclude of string (* -I physicalpath *) - | Include of string * string (* -Q physicalpath logicalpath *) - | RInclude of string * string (* -R physicalpath logicalpath *) - -type install = - | NoInstall - | TraditionalInstall - | UserInstall - | UnspecInstall - -exception Parsing_error -let rec parse_string = parser - | [< '' ' | '\n' | '\t' >] -> "" - | [< 'c; s >] -> (String.make 1 c)^(parse_string s) - | [< >] -> "" -and parse_string2 = parser - | [< ''"' >] -> "" - | [< 'c; s >] -> (String.make 1 c)^(parse_string2 s) - | [< >] -> raise Parsing_error -and parse_skip_comment = parser - | [< ''\n'; s >] -> s - | [< 'c; s >] -> parse_skip_comment s - | [< >] -> [< >] -and parse_args = parser - | [< '' ' | '\n' | '\t'; s >] -> parse_args s - | [< ''#'; s >] -> parse_args (parse_skip_comment s) - | [< ''"'; str = parse_string2; s >] -> ("" ^ str) :: parse_args s - | [< 'c; str = parse_string; s >] -> ((String.make 1 c) ^ str) :: (parse_args s) - | [< >] -> [] - - -let parse f = - let c = open_in f in - let res = parse_args (Stream.of_channel c) in - close_in c; - res - -let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) l = function - | [] -> opts, l - | ("-h"|"--help") :: _ -> - raise Parsing_error - | ("-no-opt"|"-byte") :: r -> - process_cmd_line orig_dir (project_file,makefile,install,false) l r - | ("-full"|"-opt") :: r -> - process_cmd_line orig_dir (project_file,makefile,install,true) l r - | "-impredicative-set" :: r -> - Feedback.msg_warning (Pp.str "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform."); - process_cmd_line orig_dir opts (Arg "-impredicative-set" :: l) r - | "-no-install" :: r -> - Feedback.msg_warning (Pp.(++) (Pp.str "Option -no-install is deprecated.") (Pp.(++) (Pp.spc ()) (Pp.str "Use \"-install none\" instead"))); - process_cmd_line orig_dir (project_file,makefile,NoInstall,opt) l r - | "-install" :: d :: r -> - if install <> UnspecInstall then Feedback.msg_warning (Pp.str "-install sets more than once."); - let install = - match d with - | "user" -> UserInstall - | "none" -> NoInstall - | "global" -> TraditionalInstall - | _ -> Feedback.msg_warning (Pp.(++) (Pp.str "invalid option '") (Pp.(++) (Pp.str d) (Pp.str "' passed to -install."))); - install - in - process_cmd_line orig_dir (project_file,makefile,install,opt) l r - | "-custom" :: com :: dependencies :: file :: r -> - Feedback.msg_warning (Pp.app - (Pp.str "Please now use \"-extra[-phony] result deps command\" instead of \"-custom command deps result\".") - (Pp.pr_arg Pp.str "It follows makefile target declaration order and has a clearer semantic.") - ); - process_cmd_line orig_dir opts (Special (file,dependencies,false,com) :: l) r - | "-extra" :: file :: dependencies :: com :: r -> - process_cmd_line orig_dir opts (Special (file,dependencies,false,com) :: l) r - | "-extra-phony" :: target :: dependencies :: com :: r -> - process_cmd_line orig_dir opts (Special (target,dependencies,true,com) :: l) r - | "-Q" :: d :: lp :: r -> - process_cmd_line orig_dir opts ((Include (CUnix.correct_path d orig_dir, lp)) :: l) r - | "-I" :: d :: r -> - process_cmd_line orig_dir opts ((MLInclude (CUnix.correct_path d orig_dir)) :: l) r - | "-R" :: p :: lp :: r -> - process_cmd_line orig_dir opts (RInclude (CUnix.correct_path p orig_dir,lp) :: l) r - | ("-Q"|"-R"|"-I"|"-custom"|"-extra"|"-extra-phony") :: _ -> - raise Parsing_error - | "-f" :: file :: r -> - let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in - let () = match project_file with - | None -> () - | Some _ -> Feedback.msg_warning (Pp.str - "Several features will not work with multiple project files.") - in - let (opts',l') = process_cmd_line (Filename.dirname file) (Some file,makefile,install,opt) l (parse file) in - process_cmd_line orig_dir opts' l' r - | ["-f"] -> - raise Parsing_error - | "-o" :: file :: r -> - begin try - let _ = String.index file '/' in - raise Parsing_error - with Not_found -> - let () = match makefile with - |None -> () - |Some f -> - Feedback.msg_warning (Pp.(++) (Pp.str "Only one output file is genererated. ") (Pp.(++) (Pp.str f) (Pp.str " will not be."))) - in process_cmd_line orig_dir (project_file,Some file,install,opt) l r - end - | v :: "=" :: def :: r -> - process_cmd_line orig_dir opts (Def (v,def) :: l) r - | "-arg" :: a :: r -> - process_cmd_line orig_dir opts (Arg a :: l) r - | f :: r -> - let f = CUnix.correct_path f orig_dir in - process_cmd_line orig_dir opts (( - if Filename.check_suffix f ".v" then V f - else if (Filename.check_suffix f ".ml") then ML f - else if (Filename.check_suffix f ".ml4") then ML4 f - else if (Filename.check_suffix f ".mli") then MLI f - else if (Filename.check_suffix f ".mllib") then MLLIB f - else if (Filename.check_suffix f ".mlpack") then MLPACK f - else Subdir f) :: l) r - -let process_cmd_line orig_dir opts l args = - let (opts, l) = process_cmd_line orig_dir opts l args in - opts, List.rev l - -let rec post_canonize f = - if Filename.basename f = Filename.current_dir_name - then let dir = Filename.dirname f in - if dir = Filename.current_dir_name then f else post_canonize dir - else f - -(* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(ml_inc,q_inc,r_inc),(args,defs)) *) -let split_arguments args = - List.fold_right - (fun a ((v,(mli,ml4,ml,mllib,mlpack as m),o,s as t), - (ml_inc,q_inc,r_inc as i),(args,defs as d)) -> - match a with - | V n -> - ((CUnix.remove_path_dot n::v,m,o,s),i,d) - | ML n -> - ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d) - | MLI n -> - ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d) - | ML4 n -> - ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d) - | MLLIB n -> - ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d) - | MLPACK n -> - ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d) - | Special (n,dep,is_phony,c) -> - ((v,m,(n,dep,is_phony,c)::o,s),i,d) - | Subdir n -> - ((v,m,o,n::s),i,d) - | MLInclude p -> - let ml_new = (CUnix.remove_path_dot (post_canonize p), - CUnix.canonical_path_name p) in - (t,(ml_new::ml_inc,q_inc,r_inc),d) - | Include (p,l) -> - let q_new = (CUnix.remove_path_dot (post_canonize p),l, - CUnix.canonical_path_name p) in - (t,(ml_inc,q_new::q_inc,r_inc),d) - | RInclude (p,l) -> - let r_new = (CUnix.remove_path_dot (post_canonize p),l, - CUnix.canonical_path_name p) in - (t,(ml_inc,q_inc,r_new::r_inc),d) - | Def (v,def) -> - (t,i,(args,(v,def)::defs)) - | Arg a -> - (t,i,(a::args,defs))) - args (([],([],[],[],[],[]),[],[]),([],[],[]),([],[])) - -let read_project_file f = - split_arguments - (snd (process_cmd_line (Filename.dirname f) (Some f, None, NoInstall, true) [] (parse f))) - -let args_from_project file project_files default_name = - let build_cmd_line ml_inc i_inc r_inc args = - List.fold_right (fun (_,i) o -> "-I" :: i :: o) ml_inc - (List.fold_right (fun (_,l,i) o -> "-Q" :: i :: l :: o) i_inc - (List.fold_right (fun (_,l,p) o -> "-R" :: p :: l :: o) r_inc - (List.fold_right (fun a o -> parse_args (Stream.of_string a) @ o) args []))) - in try - let (fname,(_,(ml_inc,i_inc,r_inc),(args,_))) = List.hd project_files in - fname, build_cmd_line ml_inc i_inc r_inc args - with Failure _ -> - let rec find_project_file dir = try - let fname = Filename.concat dir default_name in - let ((v_files,_,_,_),(ml_inc,i_inc,r_inc),(args,_)) = - read_project_file fname in - fname, build_cmd_line ml_inc i_inc r_inc args - with Sys_error s -> - let newdir = Filename.dirname dir in - if dir = newdir then "",[] else find_project_file newdir - in find_project_file (Filename.dirname file) diff --git a/ide/texmacspp.ml b/ide/texmacspp.ml new file mode 100644 index 0000000000..ddb62313ff --- /dev/null +++ b/ide/texmacspp.ml @@ -0,0 +1,769 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Xml_datatype +open Vernacexpr +open Constrexpr +open Names +open Misctypes +open Bigint +open Decl_kinds +open Extend +open Libnames +open Constrexpr_ops + +let unlock ?loc = + let start, stop = Option.cata Loc.unloc (0,0) loc in + (string_of_int start, string_of_int stop) + +let xmlWithLoc ?loc ename attr xml = + let start, stop = unlock ?loc in + Element(ename, [ "begin", start; "end", stop ] @ attr, xml) + +let get_fst_attr_in_xml_list attr xml_list = + let attrs_list = + List.map (function + | Element (_, attrs, _) -> (List.filter (fun (a,_) -> a = attr) attrs) + | _ -> []) + xml_list in + match List.flatten attrs_list with + | [] -> (attr, "") + | l -> (List.hd l) + +let backstep_loc xmllist = + let start_att = get_fst_attr_in_xml_list "begin" xmllist in + let stop_att = get_fst_attr_in_xml_list "end" (List.rev xmllist) in + [start_att ; stop_att] + +let compare_begin_att xml1 xml2 = + let att1 = get_fst_attr_in_xml_list "begin" [xml1] in + let att2 = get_fst_attr_in_xml_list "begin" [xml2] in + match att1, att2 with + | (_, s1), (_, s2) when s1 == "" || s2 == "" -> 0 + | (_, s1), (_, s2) when int_of_string s1 > int_of_string s2 -> 1 + | (_, s1), (_, s2) when int_of_string s1 < int_of_string s2 -> -1 + | _ -> 0 + +let xmlBeginSection ?loc name = xmlWithLoc ?loc "beginsection" ["name", name] [] + +let xmlEndSegment ?loc name = xmlWithLoc ?loc "endsegment" ["name", name] [] + +let xmlThm ?loc typ name xml = + xmlWithLoc ?loc "theorem" ["type", typ; "name", name] xml + +let xmlDef ?loc typ name xml = + xmlWithLoc ?loc "definition" ["type", typ; "name", name] xml + +let xmlNotation ?loc attr name xml = + xmlWithLoc ?loc "notation" (("name", name) :: attr) xml + +let xmlReservedNotation ?loc attr name = + xmlWithLoc ?loc "reservednotation" (("name", name) :: attr) [] + +let xmlCst ?loc ?(attr=[]) name = + xmlWithLoc ?loc "constant" (("name", name) :: attr) [] + +let xmlOperator ?loc ?(attr=[]) ?(pprules=[]) name = + xmlWithLoc ?loc "operator" + (("name", name) :: List.map (fun (a,b) -> "format"^a,b) pprules @ attr) [] + +let xmlApply ?loc ?(attr=[]) xml = xmlWithLoc ?loc "apply" attr xml + +let xmlToken ?loc ?(attr=[]) xml = xmlWithLoc ?loc "token" attr xml + +let xmlTyped xml = Element("typed", (backstep_loc xml), xml) + +let xmlReturn ?(attr=[]) xml = Element("return", attr, xml) + +let xmlCase xml = Element("case", [], xml) + +let xmlScrutinee ?(attr=[]) xml = Element("scrutinee", attr, xml) + +let xmlWith xml = Element("with", [], xml) + +let xmlAssign id xml = Element("assign", ["target",string_of_id id], [xml]) + +let xmlInductive ?loc kind xml = xmlWithLoc ?loc "inductive" ["kind",kind] xml + +let xmlCoFixpoint xml = Element("cofixpoint", [], xml) + +let xmlFixpoint xml = Element("fixpoint", [], xml) + +let xmlCheck ?loc xml = xmlWithLoc ?loc "check" [] xml + +let xmlAssumption ?loc kind xml = xmlWithLoc ?loc "assumption" ["kind",kind] xml + +let xmlComment ?loc xml = xmlWithLoc ?loc "comment" [] xml + +let xmlCanonicalStructure ?loc attr = xmlWithLoc ?loc "canonicalstructure" attr [] + +let xmlQed ?loc ?(attr=[]) = xmlWithLoc ?loc "qed" attr [] + +let xmlPatvar ?loc id = xmlWithLoc ?loc "patvar" ["id", id] [] + +let xmlReference ref = + let name = Libnames.string_of_reference ref in + let i, j = Option.cata Loc.unloc (0,0) (Libnames.loc_of_reference ref) in + let b, e = string_of_int i, string_of_int j in + Element("reference",["name", name; "begin", b; "end", e] ,[]) + +let xmlRequire ?loc ?(attr=[]) xml = xmlWithLoc ?loc "require" attr xml +let xmlImport ?loc ?(attr=[]) xml = xmlWithLoc ?loc "import" attr xml + +let xmlAddLoadPath ?loc ?(attr=[]) xml = xmlWithLoc ?loc "addloadpath" attr xml +let xmlRemoveLoadPath ?loc ?(attr=[]) = xmlWithLoc ?loc "removeloadpath" attr +let xmlAddMLPath ?loc ?(attr=[]) = xmlWithLoc ?loc "addmlpath" attr + +let xmlExtend ?loc xml = xmlWithLoc ?loc "extend" [] xml + +let xmlScope ?loc ?(attr=[]) action name xml = + xmlWithLoc ?loc "scope" (["name",name;"action",action] @ attr) xml + +let xmlProofMode ?loc name = xmlWithLoc ?loc "proofmode" ["name",name] [] + +let xmlProof ?loc xml = xmlWithLoc ?loc "proof" [] xml + +let xmlSectionSubsetDescr name ssd = + Element("sectionsubsetdescr",["name",name], + [PCData (Proof_using.to_string ssd)]) + +let xmlDeclareMLModule ?loc s = + xmlWithLoc ?loc "declarexmlmodule" [] + (List.map (fun x -> Element("path",["value",x],[])) s) + +(* tactics *) +let xmlLtac ?loc xml = xmlWithLoc ?loc "ltac" [] xml + +(* toplevel commands *) +let xmlGallina ?loc xml = xmlWithLoc ?loc "gallina" [] xml + +let xmlTODO ?loc x = + xmlWithLoc ?loc "todo" [] [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] + +let string_of_name n = + match n with + | Anonymous -> "_" + | Name id -> Id.to_string id + +let string_of_glob_sort s = + match s with + | GProp -> "Prop" + | GSet -> "Set" + | GType _ -> "Type" + +let string_of_cast_sort c = + match c with + | CastConv _ -> "CastConv" + | CastVM _ -> "CastVM" + | CastNative _ -> "CastNative" + | CastCoerce -> "CastCoerce" + +let string_of_case_style s = + match s with + | LetStyle -> "Let" + | IfStyle -> "If" + | LetPatternStyle -> "LetPattern" + | MatchStyle -> "Match" + | RegularStyle -> "Regular" + +let attribute_of_syntax_modifier sm = +match sm with + | SetItemLevel (sl, NumLevel n) -> + List.map (fun s -> ("itemlevel", s)) sl @ ["level", string_of_int n] + | SetItemLevel (sl, NextLevel) -> + List.map (fun s -> ("itemlevel", s)) sl @ ["level", "next"] + | SetLevel i -> ["level", string_of_int i] + | SetAssoc a -> + begin match a with + | NonA -> ["",""] + | RightA -> ["associativity", "right"] + | LeftA -> ["associativity", "left"] + end + | SetEntryType (s, _) -> ["entrytype", s] + | SetOnlyPrinting -> ["onlyprinting", ""] + | SetOnlyParsing -> ["onlyparsing", ""] + | SetCompatVersion v -> ["compat", Flags.pr_version v] + | SetFormat (system, (loc, s)) -> + let start, stop = unlock ?loc in + ["format-"^system, s; "begin", start; "end", stop] + +let string_of_assumption_kind l a many = + match l, a, many with + | (Discharge, Logical, true) -> "Hypotheses" + | (Discharge, Logical, false) -> "Hypothesis" + | (Discharge, Definitional, true) -> "Variables" + | (Discharge, Definitional, false) -> "Variable" + | (Global, Logical, true) -> "Axioms" + | (Global, Logical, false) -> "Axiom" + | (Global, Definitional, true) -> "Parameters" + | (Global, Definitional, false) -> "Parameter" + | (Local, Logical, true) -> "Local Axioms" + | (Local, Logical, false) -> "Local Axiom" + | (Local, Definitional, true) -> "Local Parameters" + | (Local, Definitional, false) -> "Local Parameter" + | (Global, Conjectural, _) -> "Conjecture" + | ((Discharge | Local), Conjectural, _) -> assert false + +let rec pp_bindlist bl = + let tlist = + List.flatten + (List.map + (fun (loc_names, _, e) -> + let names = + (List.map + (fun (loc, name) -> + xmlCst ?loc (string_of_name name)) loc_names) in + match e.CAst.v with + | CHole _ -> names + | _ -> names @ [pp_expr e]) + bl) in + match tlist with + | [e] -> e + | l -> xmlTyped l +and pp_decl_notation ((_, s), ce, sc) = (* don't know what it is for now *) + Element ("decl_notation", ["name", s], [pp_expr ce]) +and pp_local_binder lb = (* don't know what it is for now *) + match lb with + | CLocalDef ((loc, nam), ce, ty) -> + let attrs = ["name", string_of_name nam] in + let value = match ty with + Some t -> CAst.make ?loc:(Loc.merge_opt (constr_loc ce) (constr_loc t)) @@ CCast (ce, CastConv t) + | None -> ce in + pp_expr ~attr:attrs value + | CLocalAssum (namll, _, ce) -> + let ppl = + List.map (fun (loc, nam) -> (xmlCst ?loc (string_of_name nam))) namll in + xmlTyped (ppl @ [pp_expr ce]) + | CLocalPattern _ -> + assert false +and pp_local_decl_expr lde = (* don't know what it is for now *) + match lde with + | AssumExpr (_, ce) -> pp_expr ce + | DefExpr (_, ce, _) -> pp_expr ce +and pp_inductive_expr ((_, ((l, id),_)), lbl, ceo, _, cl_or_rdexpr) = + (* inductive_expr *) + let b,e = Option.cata Loc.unloc (0,0) l in + let location = ["begin", string_of_int b; "end", string_of_int e] in + [Element ("lident", ["name", Id.to_string id] @ location, [])] @ (* inductive name *) + begin match cl_or_rdexpr with + | Constructors coel -> List.map (fun (_, (_, ce)) -> pp_expr ce) coel + | RecordDecl (_, ldewwwl) -> + List.map (fun (((_, x), _), _) -> pp_local_decl_expr x) ldewwwl + end @ + begin match ceo with (* don't know what it is for now *) + | Some ce -> [pp_expr ce] + | None -> [] + end @ + (List.map pp_local_binder lbl) +and pp_recursion_order_expr optid roe = (* don't know what it is for now *) + let attrs = + match optid with + | None -> [] + | Some (loc, id) -> + let start, stop = unlock ?loc in + ["begin", start; "end", stop ; "name", Id.to_string id] in + let kind, expr = + match roe with + | CStructRec -> "struct", [] + | CWfRec e -> "rec", [pp_expr e] + | CMeasureRec (e, None) -> "mesrec", [pp_expr e] + | CMeasureRec (e, Some rel) -> "mesrec", [pp_expr e] @ [pp_expr rel] in + Element ("recursion_order", ["kind", kind] @ attrs, expr) +and pp_fixpoint_expr (((loc, id), pl), (optid, roe), lbl, ce, ceo) = + (* fixpoint_expr *) + let start, stop = unlock ?loc in + let id = Id.to_string id in + [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @ + (* fixpoint name *) + [pp_recursion_order_expr optid roe] @ + (List.map pp_local_binder lbl) @ + [pp_expr ce] @ + begin match ceo with (* don't know what it is for now *) + | Some ce -> [pp_expr ce] + | None -> [] + end +and pp_cofixpoint_expr (((loc, id), pl), lbl, ce, ceo) = (* cofixpoint_expr *) + (* Nota: it is like fixpoint_expr without (optid, roe) + * so could be merged if there is no more differences *) + let start, stop = unlock ?loc in + let id = Id.to_string id in + [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @ + (* cofixpoint name *) + (List.map pp_local_binder lbl) @ + [pp_expr ce] @ + begin match ceo with (* don't know what it is for now *) + | Some ce -> [pp_expr ce] + | None -> [] + end +and pp_lident (loc, id) = xmlCst ?loc (Id.to_string id) +and pp_simple_binder (idl, ce) = List.map pp_lident idl @ [pp_expr ce] +and pp_cases_pattern_expr {loc ; CAst.v = cpe} = + match cpe with + | CPatAlias (cpe, id) -> + xmlApply ?loc + (xmlOperator ?loc ~attr:["name", string_of_id id] "alias" :: + [pp_cases_pattern_expr cpe]) + | CPatCstr (ref, None, cpel2) -> + xmlApply ?loc + (xmlOperator ?loc "reference" + ~attr:["name", Libnames.string_of_reference ref] :: + [Element ("impargs", [], []); + Element ("args", [], (List.map pp_cases_pattern_expr cpel2))]) + | CPatCstr (ref, Some cpel1, cpel2) -> + xmlApply ?loc + (xmlOperator ?loc "reference" + ~attr:["name", Libnames.string_of_reference ref] :: + [Element ("impargs", [], (List.map pp_cases_pattern_expr cpel1)); + Element ("args", [], (List.map pp_cases_pattern_expr cpel2))]) + | CPatAtom optr -> + let attrs = match optr with + | None -> [] + | Some r -> ["name", Libnames.string_of_reference r] in + xmlApply ?loc (xmlOperator ?loc "atom" ~attr:attrs :: []) + | CPatOr cpel -> + xmlApply ?loc (xmlOperator ?loc "or" :: List.map pp_cases_pattern_expr cpel) + | CPatNotation (n, (subst_constr, subst_rec), cpel) -> + xmlApply ?loc + (xmlOperator ?loc "notation" :: + [xmlOperator ?loc n; + Element ("subst", [], + [Element ("subterms", [], + List.map pp_cases_pattern_expr subst_constr); + Element ("recsubterms", [], + List.map + (fun (cpel) -> + Element ("recsubterm", [], + List.map pp_cases_pattern_expr cpel)) + subst_rec)]); + Element ("args", [], (List.map pp_cases_pattern_expr cpel))]) + | CPatPrim tok -> pp_token ?loc tok + | CPatRecord rcl -> + xmlApply ?loc + (xmlOperator ?loc "record" :: + List.map (fun (r, cpe) -> + Element ("field", + ["reference", Libnames.string_of_reference r], + [pp_cases_pattern_expr cpe])) + rcl) + | CPatDelimiters (delim, cpe) -> + xmlApply ?loc + (xmlOperator ?loc "delimiter" ~attr:["name", delim] :: + [pp_cases_pattern_expr cpe]) + | CPatCast _ -> assert false +and pp_case_expr (e, name, pat) = + match name, pat with + | None, None -> xmlScrutinee [pp_expr e] + | Some (loc, name), None -> + let start, stop= unlock ?loc in + xmlScrutinee ~attr:["name", string_of_name name; + "begin", start; "end", stop] [pp_expr e] + | Some (loc, name), Some p -> + let start, stop= unlock ?loc in + xmlScrutinee ~attr:["name", string_of_name name; + "begin", start; "end", stop] + [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e] + | None, Some p -> + xmlScrutinee [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e] +and pp_branch_expr_list bel = + xmlWith + (List.map + (fun (_, (cpel, e)) -> + let ppcepl = + List.map pp_cases_pattern_expr (List.flatten (List.map snd cpel)) in + let ppe = [pp_expr e] in + xmlCase (ppcepl @ ppe)) + bel) +and pp_token ?loc tok = + let tokstr = + match tok with + | String s -> PCData s + | Numeral n -> PCData (to_string n) in + xmlToken ?loc [tokstr] +and pp_local_binder_list lbl = + let l = (List.map pp_local_binder lbl) in + Element ("recurse", (backstep_loc l), l) +and pp_const_expr_list cel = + let l = List.map pp_expr cel in + Element ("recurse", (backstep_loc l), l) +and pp_expr ?(attr=[]) { loc; CAst.v = e } = + match e with + | CRef (r, _) -> + xmlCst ?loc:(Libnames.loc_of_reference r) ~attr (Libnames.string_of_reference r) + | CProdN (bl, e) -> + xmlApply ?loc + (xmlOperator ?loc "forall" :: [pp_bindlist bl] @ [pp_expr e]) + | CApp ((_, hd), args) -> + xmlApply ?loc ~attr (pp_expr hd :: List.map (fun (e,_) -> pp_expr e) args) + | CAppExpl ((_, r, _), args) -> + xmlApply ?loc ~attr + (xmlCst ?loc:(Libnames.loc_of_reference r) (Libnames.string_of_reference r) + :: List.map pp_expr args) + | CNotation (notation, ([],[],[])) -> + xmlOperator ?loc notation + | CNotation (notation, (args, cell, lbll)) -> + let fmts = Notation.find_notation_extra_printing_rules notation in + let oper = xmlOperator ?loc notation ~pprules:fmts in + let cels = List.map pp_const_expr_list cell in + let lbls = List.map pp_local_binder_list lbll in + let args = List.map pp_expr args in + xmlApply ?loc (oper :: (List.sort compare_begin_att (args @ cels @ lbls))) + | CSort(s) -> + xmlOperator ?loc (string_of_glob_sort s) + | CDelimiters (scope, ce) -> + xmlApply ?loc (xmlOperator ?loc "delimiter" ~attr:["name", scope] :: + [pp_expr ce]) + | CPrim tok -> pp_token ?loc tok + | CGeneralization (kind, _, e) -> + let kind= match kind with + | Explicit -> "explicit" + | Implicit -> "implicit" in + xmlApply ?loc + (xmlOperator ?loc ~attr:["kind", kind] "generalization" :: [pp_expr e]) + | CCast (e, tc) -> + begin match tc with + | CastConv t | CastVM t |CastNative t -> + xmlApply ?loc + (xmlOperator ?loc ":" ~attr:["kind", (string_of_cast_sort tc)] :: + [pp_expr e; pp_expr t]) + | CastCoerce -> + xmlApply ?loc + (xmlOperator ?loc ":" ~attr:["kind", "CastCoerce"] :: + [pp_expr e]) + end + | CEvar (ek, cel) -> + let ppcel = List.map (fun (id,e) -> xmlAssign id (pp_expr e)) cel in + xmlApply ?loc + (xmlOperator ?loc "evar" ~attr:["id", string_of_id ek] :: + ppcel) + | CPatVar id -> xmlPatvar ?loc (string_of_id id) + | CHole (_, _, _) -> xmlCst ?loc ~attr "_" + | CIf (test, (_, ret), th, el) -> + let return = match ret with + | None -> [] + | Some r -> [xmlReturn [pp_expr r]] in + xmlApply ?loc + (xmlOperator ?loc "if" :: + return @ [pp_expr th] @ [pp_expr el]) + | CLetTuple (names, (_, ret), value, body) -> + let return = match ret with + | None -> [] + | Some r -> [xmlReturn [pp_expr r]] in + xmlApply ?loc + (xmlOperator ?loc "lettuple" :: + return @ + (List.map (fun (loc, var) -> xmlCst ?loc (string_of_name var)) names) @ + [pp_expr value; pp_expr body]) + | CCases (sty, ret, cel, bel) -> + let return = match ret with + | None -> [] + | Some r -> [xmlReturn [pp_expr r]] in + xmlApply ?loc + (xmlOperator ?loc ~attr:["style", (string_of_case_style sty)] "match" :: + (return @ + [Element ("scrutinees", [], List.map pp_case_expr cel)] @ + [pp_branch_expr_list bel])) + | CRecord _ -> assert false + | CLetIn ((varloc, var), value, typ, body) -> + let value = match typ with + | Some t -> + CAst.make ?loc:(Loc.merge_opt (constr_loc value) (constr_loc t)) (CCast (value, CastConv t)) + | None -> value in + xmlApply ?loc + (xmlOperator ?loc "let" :: + [xmlCst ?loc:varloc (string_of_name var) ; pp_expr value; pp_expr body]) + | CLambdaN (bl, e) -> + xmlApply ?loc + (xmlOperator ?loc "lambda" :: [pp_bindlist bl] @ [pp_expr e]) + | CCoFix (_, _) -> assert false + | CFix (lid, fel) -> + xmlApply ?loc + (xmlOperator ?loc "fix" :: + List.flatten (List.map + (fun (a,b,cl,c,d) -> pp_fixpoint_expr ((a,None),b,cl,c,Some d)) + fel)) + +let pp_comment c = + match c with + | CommentConstr e -> [pp_expr e] + | CommentString s -> [Element ("string", [], [PCData s])] + | CommentInt i -> [PCData (string_of_int i)] + +let rec tmpp ?loc v = + match v with + (* Control *) + | VernacLoad (verbose,f) -> + xmlWithLoc ?loc "load" ["verbose",string_of_bool verbose;"file",f] [] + | VernacTime (loc,e) -> + xmlApply ?loc (Element("time",[],[]) :: + [tmpp ?loc e]) + | VernacRedirect (s, (loc,e)) -> + xmlApply ?loc (Element("redirect",["path", s],[]) :: + [tmpp ?loc e]) + | VernacTimeout (s,e) -> + xmlApply ?loc (Element("timeout",["val",string_of_int s],[]) :: + [tmpp ?loc e]) + | VernacFail e -> xmlApply ?loc (Element("fail",[],[]) :: [tmpp ?loc e]) + + (* Syntax *) + | VernacSyntaxExtension (_, ((_, name), sml)) -> + let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in + xmlReservedNotation ?loc attrs name + + | VernacOpenCloseScope (_,(true,name)) -> xmlScope ?loc "open" name [] + | VernacOpenCloseScope (_,(false,name)) -> xmlScope ?loc "close" name [] + | VernacDelimiters (name,Some tag) -> + xmlScope ?loc "delimit" name ~attr:["delimiter",tag] [] + | VernacDelimiters (name,None) -> + xmlScope ?loc "undelimit" name ~attr:[] [] + | VernacInfix (_,((_,name),sml),ce,sn) -> + let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in + let sc_attr = + match sn with + | Some scope -> ["scope", scope] + | None -> [] in + xmlNotation ?loc (sc_attr @ attrs) name [pp_expr ce] + | VernacNotation (_, ce, (lstr, sml), sn) -> + let name = snd lstr in + let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in + let sc_attr = + match sn with + | Some scope -> ["scope", scope] + | None -> [] in + xmlNotation ?loc (sc_attr @ attrs) name [pp_expr ce] + | VernacBindScope _ as x -> xmlTODO ?loc x + | VernacNotationAddFormat _ as x -> xmlTODO ?loc x + | VernacUniverse _ + | VernacConstraint _ + | VernacPolymorphic (_, _) as x -> xmlTODO ?loc x + (* Gallina *) + | VernacDefinition (ldk, ((_,id),_), de) -> + let l, dk = + match ldk with + | Some l, dk -> (l, dk) + | None, dk -> (Global, dk) in (* Like in ppvernac.ml, l 585 *) + let e = + match de with + | ProveBody (_, ce) -> ce + | DefineBody (_, Some _, ce, None) -> ce + | DefineBody (_, None , ce, None) -> ce + | DefineBody (_, Some _, ce, Some _) -> ce + | DefineBody (_, None , ce, Some _) -> ce in + let str_dk = Kindops.string_of_definition_kind (l, false, dk) in + let str_id = Id.to_string id in + (xmlDef ?loc str_dk str_id [pp_expr e]) + | VernacStartTheoremProof (tk, [ Some ((_,id),_), ([], statement, None) ], b) -> + let str_tk = Kindops.string_of_theorem_kind tk in + let str_id = Id.to_string id in + (xmlThm ?loc str_tk str_id [pp_expr statement]) + | VernacStartTheoremProof _ as x -> xmlTODO ?loc x + | VernacEndProof pe -> + begin + match pe with + | Admitted -> xmlQed ?loc ?attr:None + | Proved (_, Some ((_, id), Some tk)) -> + let nam = Id.to_string id in + let typ = Kindops.string_of_theorem_kind tk in + xmlQed ?loc ~attr:["name", nam; "type", typ] + | Proved (_, Some ((_, id), None)) -> + let nam = Id.to_string id in + xmlQed ?loc ~attr:["name", nam] + | Proved _ -> xmlQed ?loc ?attr:None + end + | VernacExactProof _ as x -> xmlTODO ?loc x + | VernacAssumption ((l, a), _, sbwcl) -> + let binders = List.map (fun (_, (id, c)) -> (List.map fst id, c)) sbwcl in + let many = + List.length (List.flatten (List.map fst binders)) > 1 in + let exprs = + List.flatten (List.map pp_simple_binder binders) in + let l = match l with Some x -> x | None -> Decl_kinds.Global in + let kind = string_of_assumption_kind l a many in + xmlAssumption ?loc kind exprs + | VernacInductive (_, _, iednll) -> + let kind = + let (_, _, _, k, _), _ = List.hd iednll in + begin + match k with + | Record -> "Record" + | Structure -> "Structure" + | Inductive_kw -> "Inductive" + | CoInductive -> "CoInductive" + | Class _ -> "Class" + | Variant -> "Variant" + end in + let exprs = + List.flatten (* should probably not be flattened *) + (List.map + (fun (ie, dnl) -> (pp_inductive_expr ie) @ + (List.map pp_decl_notation dnl)) iednll) in + xmlInductive ?loc kind exprs + | VernacFixpoint (_, fednll) -> + let exprs = + List.flatten (* should probably not be flattened *) + (List.map + (fun (fe, dnl) -> (pp_fixpoint_expr fe) @ + (List.map pp_decl_notation dnl)) fednll) in + xmlFixpoint exprs + | VernacCoFixpoint (_, cfednll) -> + (* Nota: it is like VernacFixpoint without so could be merged *) + let exprs = + List.flatten (* should probably not be flattened *) + (List.map + (fun (cfe, dnl) -> (pp_cofixpoint_expr cfe) @ + (List.map pp_decl_notation dnl)) cfednll) in + xmlCoFixpoint exprs + | VernacScheme _ as x -> xmlTODO ?loc x + | VernacCombinedScheme _ as x -> xmlTODO ?loc x + + (* Gallina extensions *) + | VernacBeginSection (_, id) -> xmlBeginSection ?loc (Id.to_string id) + | VernacEndSegment (_, id) -> xmlEndSegment ?loc (Id.to_string id) + | VernacNameSectionHypSet _ as x -> xmlTODO ?loc x + | VernacRequire (from, import, l) -> + let import = match import with + | None -> [] + | Some true -> ["export","true"] + | Some false -> ["import","true"] + in + let from = match from with + | None -> [] + | Some r -> ["from", Libnames.string_of_reference r] + in + xmlRequire ?loc ~attr:(from @ import) (List.map (fun ref -> + xmlReference ref) l) + | VernacImport (true,l) -> + xmlImport ?loc ~attr:["export","true"] (List.map (fun ref -> + xmlReference ref) l) + | VernacImport (false,l) -> + xmlImport ?loc (List.map (fun ref -> xmlReference ref) l) + | VernacCanonical r -> + let attr = + match r with + | AN (Qualid (_, q)) -> ["qualid", string_of_qualid q] + | AN (Ident (_, id)) -> ["id", Id.to_string id] + | ByNotation (_, (s, _)) -> ["notation", s] in + xmlCanonicalStructure ?loc attr + | VernacCoercion _ as x -> xmlTODO ?loc x + | VernacIdentityCoercion _ as x -> xmlTODO ?loc x + + (* Type classes *) + | VernacInstance _ as x -> xmlTODO ?loc x + + | VernacContext _ as x -> xmlTODO ?loc x + + | VernacDeclareInstances _ as x -> xmlTODO ?loc x + + | VernacDeclareClass _ as x -> xmlTODO ?loc x + + (* Modules and Module Types *) + | VernacDeclareModule _ as x -> xmlTODO ?loc x + | VernacDefineModule _ as x -> xmlTODO ?loc x + | VernacDeclareModuleType _ as x -> xmlTODO ?loc x + | VernacInclude _ as x -> xmlTODO ?loc x + + (* Solving *) + + | (VernacSolveExistential _) as x -> + xmlLtac ?loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] + + (* Auxiliary file and library management *) + | VernacAddLoadPath (recf,name,None) -> + xmlAddLoadPath ?loc ~attr:["rec",string_of_bool recf;"path",name] [] + | VernacAddLoadPath (recf,name,Some dp) -> + xmlAddLoadPath ?loc ~attr:["rec",string_of_bool recf;"path",name] + [PCData (Names.DirPath.to_string dp)] + | VernacRemoveLoadPath name -> xmlRemoveLoadPath ?loc ~attr:["path",name] [] + | VernacAddMLPath (recf,name) -> + xmlAddMLPath ?loc ~attr:["rec",string_of_bool recf;"path",name] [] + | VernacDeclareMLModule sl -> xmlDeclareMLModule ?loc sl + | VernacChdir _ as x -> xmlTODO ?loc x + + (* State management *) + | VernacWriteState _ as x -> xmlTODO ?loc x + | VernacRestoreState _ as x -> xmlTODO ?loc x + + (* Resetting *) + | VernacResetName _ as x -> xmlTODO ?loc x + | VernacResetInitial as x -> xmlTODO ?loc x + | VernacBack _ as x -> xmlTODO ?loc x + | VernacBackTo _ -> PCData "VernacBackTo" + + (* Commands *) + | VernacCreateHintDb _ as x -> xmlTODO ?loc x + | VernacRemoveHints _ as x -> xmlTODO ?loc x + | VernacHints _ as x -> xmlTODO ?loc x + | VernacSyntacticDefinition ((_, name), (idl, ce), _, _) -> + let name = Id.to_string name in + let attrs = List.map (fun id -> ("id", Id.to_string id)) idl in + xmlNotation ?loc attrs name [pp_expr ce] + | VernacDeclareImplicits _ as x -> xmlTODO ?loc x + | VernacArguments _ as x -> xmlTODO ?loc x + | VernacArgumentsScope _ as x -> xmlTODO ?loc x + | VernacReserve _ as x -> xmlTODO ?loc x + | VernacGeneralizable _ as x -> xmlTODO ?loc x + | VernacSetOpacity _ as x -> xmlTODO ?loc x + | VernacSetStrategy _ as x -> xmlTODO ?loc x + | VernacUnsetOption _ as x -> xmlTODO ?loc x + | VernacSetOption _ as x -> xmlTODO ?loc x + | VernacSetAppendOption _ as x -> xmlTODO ?loc x + | VernacAddOption _ as x -> xmlTODO ?loc x + | VernacRemoveOption _ as x -> xmlTODO ?loc x + | VernacMemOption _ as x -> xmlTODO ?loc x + | VernacPrintOption _ as x -> xmlTODO ?loc x + | VernacCheckMayEval (_,_,e) -> xmlCheck ?loc [pp_expr e] + | VernacGlobalCheck _ as x -> xmlTODO ?loc x + | VernacDeclareReduction _ as x -> xmlTODO ?loc x + | VernacPrint _ as x -> xmlTODO ?loc x + | VernacSearch _ as x -> xmlTODO ?loc x + | VernacLocate _ as x -> xmlTODO ?loc x + | VernacRegister _ as x -> xmlTODO ?loc x + | VernacComments (cl) -> + xmlComment ?loc (List.flatten (List.map pp_comment cl)) + + (* Stm backdoor *) + | VernacStm _ as x -> xmlTODO ?loc x + + (* Proof management *) + | VernacGoal _ as x -> xmlTODO ?loc x + | VernacAbort _ as x -> xmlTODO ?loc x + | VernacAbortAll -> PCData "VernacAbortAll" + | VernacRestart as x -> xmlTODO ?loc x + | VernacUndo _ as x -> xmlTODO ?loc x + | VernacUndoTo _ as x -> xmlTODO ?loc x + | VernacBacktrack _ as x -> xmlTODO ?loc x + | VernacFocus _ as x -> xmlTODO ?loc x + | VernacUnfocus as x -> xmlTODO ?loc x + | VernacUnfocused as x -> xmlTODO ?loc x + | VernacBullet _ as x -> xmlTODO ?loc x + | VernacSubproof _ as x -> xmlTODO ?loc x + | VernacEndSubproof as x -> xmlTODO ?loc x + | VernacShow _ as x -> xmlTODO ?loc x + | VernacCheckGuard as x -> xmlTODO ?loc x + | VernacProof (tac,using) -> + let tac = None (** FIXME *) in + let using = Option.map (xmlSectionSubsetDescr "using") using in + xmlProof ?loc (Option.List.(cons tac (cons using []))) + | VernacProofMode name -> xmlProofMode ?loc name + + (* Toplevel control *) + | VernacToplevelControl _ as x -> xmlTODO ?loc x + + (* For extension *) + | VernacExtend _ as x -> + xmlExtend ?loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] + + (* Flags *) + | VernacProgram e -> xmlApply ?loc (Element("program",[],[]) :: [tmpp ?loc e]) + | VernacLocal (b,e) -> + xmlApply ?loc (Element("local",["flag",string_of_bool b],[]) :: + [tmpp ?loc e]) + +let tmpp ?loc v = + match tmpp ?loc v with + | Element("ltac",_,_) as x -> x + | xml -> xmlGallina ?loc [xml] diff --git a/ide/texmacspp.mli b/ide/texmacspp.mli new file mode 100644 index 0000000000..c1086a6339 --- /dev/null +++ b/ide/texmacspp.mli @@ -0,0 +1,12 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Xml_datatype +open Vernacexpr + +val tmpp : ?loc:Loc.t -> vernac_expr -> xml diff --git a/ide/xml_lexer.mll b/ide/xml_lexer.mll index 290f2c89ab..4a52147e17 100644 --- a/ide/xml_lexer.mll +++ b/ide/xml_lexer.mll @@ -83,6 +83,9 @@ let error lexbuf e = last_pos := lexeme_start lexbuf; raise (Error e) +[@@@ocaml.warning "-3"] (* String.lowercase_ascii since 4.03.0 GPR#124 *) +let lowercase = String.lowercase +[@@@ocaml.warning "+3"] } let newline = ['\n'] @@ -219,7 +222,7 @@ and entity = parse { let ident = lexeme lexbuf in try - Hashtbl.find idents (String.lowercase ident) + Hashtbl.find idents (lowercase ident) with Not_found -> "&" ^ ident } diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index bf52b0b52b..53eb1a95ff 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -863,7 +863,7 @@ let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with | "workerstatus", [ns] -> let n, s = to_pair to_string to_string ns in WorkerStatus(n,s) - | "custom", [loc;name;x]-> Custom (to_loc loc, to_string name, x) + | "custom", [loc;name;x]-> Custom (to_option to_loc loc, to_string name, x) | "filedependency", [from; dep] -> FileDependency (to_option to_string from, to_string dep) | "fileloaded", [dirpath; filename] -> @@ -896,7 +896,7 @@ let of_feedback_content = function constructor "feedback_content" "workerstatus" [of_pair of_string of_string (n,s)] | Custom (loc, name, x) -> - constructor "feedback_content" "custom" [of_loc loc; of_string name; x] + constructor "feedback_content" "custom" [of_option of_loc loc; of_string name; x] | FileDependency (from, depends_on) -> constructor "feedback_content" "filedependency" [ of_option of_string from; diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 542f9feaf6..79e0e61646 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -60,30 +60,30 @@ let explicitation_eq ex1 ex2 = match ex1, ex2 with let eq_located f (_, x) (_, y) = f x y let rec cases_pattern_expr_eq p1 p2 = - if p1 == p2 then true - else match p1, p2 with - | CPatAlias(_,a1,i1), CPatAlias(_,a2,i2) -> + if CAst.(p1.v == p2.v) then true + else match CAst.(p1.v, p2.v) with + | CPatAlias(a1,i1), CPatAlias(a2,i2) -> Id.equal i1 i2 && cases_pattern_expr_eq a1 a2 - | CPatCstr(_,c1,a1,b1), CPatCstr(_,c2,a2,b2) -> + | CPatCstr(c1,a1,b1), CPatCstr(c2,a2,b2) -> eq_reference c1 c2 && Option.equal (List.equal cases_pattern_expr_eq) a1 a2 && List.equal cases_pattern_expr_eq b1 b2 - | CPatAtom(_,r1), CPatAtom(_,r2) -> + | CPatAtom(r1), CPatAtom(r2) -> Option.equal eq_reference r1 r2 - | CPatOr (_, a1), CPatOr (_, a2) -> + | CPatOr a1, CPatOr a2 -> List.equal cases_pattern_expr_eq a1 a2 - | CPatNotation (_, n1, s1, l1), CPatNotation (_, n2, s2, l2) -> + | CPatNotation (n1, s1, l1), CPatNotation (n2, s2, l2) -> String.equal n1 n2 && cases_pattern_notation_substitution_eq s1 s2 && List.equal cases_pattern_expr_eq l1 l2 - | CPatPrim(_,i1), CPatPrim(_,i2) -> + | CPatPrim i1, CPatPrim i2 -> prim_token_eq i1 i2 - | CPatRecord (_, l1), CPatRecord (_, l2) -> + | CPatRecord l1, CPatRecord l2 -> let equal (r1, e1) (r2, e2) = eq_reference r1 r2 && cases_pattern_expr_eq e1 e2 in List.equal equal l1 l2 - | CPatDelimiters(_,s1,e1), CPatDelimiters(_,s2,e2) -> + | CPatDelimiters(s1,e1), CPatDelimiters(s2,e2) -> String.equal s1 s2 && cases_pattern_expr_eq e1 e2 | _ -> false @@ -98,78 +98,78 @@ let eq_universes u1 u2 = | _, _ -> false let rec constr_expr_eq e1 e2 = - if e1 == e2 then true - else match e1, e2 with + if CAst.(e1.v == e2.v) then true + else match CAst.(e1.v, e2.v) with | CRef (r1,u1), CRef (r2,u2) -> eq_reference r1 r2 && eq_universes u1 u2 - | CFix(_,id1,fl1), CFix(_,id2,fl2) -> + | CFix(id1,fl1), CFix(id2,fl2) -> eq_located Id.equal id1 id2 && List.equal fix_expr_eq fl1 fl2 - | CCoFix(_,id1,fl1), CCoFix(_,id2,fl2) -> + | CCoFix(id1,fl1), CCoFix(id2,fl2) -> eq_located Id.equal id1 id2 && List.equal cofix_expr_eq fl1 fl2 - | CProdN(_,bl1,a1), CProdN(_,bl2,a2) -> + | CProdN(bl1,a1), CProdN(bl2,a2) -> List.equal binder_expr_eq bl1 bl2 && constr_expr_eq a1 a2 - | CLambdaN(_,bl1,a1), CLambdaN(_,bl2,a2) -> + | CLambdaN(bl1,a1), CLambdaN(bl2,a2) -> List.equal binder_expr_eq bl1 bl2 && constr_expr_eq a1 a2 - | CLetIn(_,(_,na1),a1,t1,b1), CLetIn(_,(_,na2),a2,t2,b2) -> + | CLetIn((_,na1),a1,t1,b1), CLetIn((_,na2),a2,t2,b2) -> Name.equal na1 na2 && constr_expr_eq a1 a2 && Option.equal constr_expr_eq t1 t2 && constr_expr_eq b1 b2 - | CAppExpl(_,(proj1,r1,_),al1), CAppExpl(_,(proj2,r2,_),al2) -> + | CAppExpl((proj1,r1,_),al1), CAppExpl((proj2,r2,_),al2) -> Option.equal Int.equal proj1 proj2 && eq_reference r1 r2 && List.equal constr_expr_eq al1 al2 - | CApp(_,(proj1,e1),al1), CApp(_,(proj2,e2),al2) -> + | CApp((proj1,e1),al1), CApp((proj2,e2),al2) -> Option.equal Int.equal proj1 proj2 && constr_expr_eq e1 e2 && List.equal args_eq al1 al2 - | CRecord (_, l1), CRecord (_, l2) -> + | CRecord l1, CRecord l2 -> let field_eq (r1, e1) (r2, e2) = eq_reference r1 r2 && constr_expr_eq e1 e2 in List.equal field_eq l1 l2 - | CCases(_,_,r1,a1,brl1), CCases(_,_,r2,a2,brl2) -> + | CCases(_,r1,a1,brl1), CCases(_,r2,a2,brl2) -> (** Don't care about the case_style *) Option.equal constr_expr_eq r1 r2 && List.equal case_expr_eq a1 a2 && List.equal branch_expr_eq brl1 brl2 - | CLetTuple (_, n1, (m1, e1), t1, b1), CLetTuple (_, n2, (m2, e2), t2, b2) -> + | CLetTuple (n1, (m1, e1), t1, b1), CLetTuple (n2, (m2, e2), t2, b2) -> List.equal (eq_located Name.equal) n1 n2 && Option.equal (eq_located Name.equal) m1 m2 && Option.equal constr_expr_eq e1 e2 && constr_expr_eq t1 t2 && constr_expr_eq b1 b2 - | CIf (_, e1, (n1, r1), t1, f1), CIf (_, e2, (n2, r2), t2, f2) -> + | CIf (e1, (n1, r1), t1, f1), CIf (e2, (n2, r2), t2, f2) -> constr_expr_eq e1 e2 && Option.equal (eq_located Name.equal) n1 n2 && Option.equal constr_expr_eq r1 r2 && constr_expr_eq t1 t2 && constr_expr_eq f1 f2 | CHole _, CHole _ -> true - | CPatVar(_,i1), CPatVar(_,i2) -> + | CPatVar i1, CPatVar i2 -> Id.equal i1 i2 - | CEvar (_, id1, c1), CEvar (_, id2, c2) -> + | CEvar (id1, c1), CEvar (id2, c2) -> Id.equal id1 id2 && List.equal instance_eq c1 c2 - | CSort(_,s1), CSort(_,s2) -> + | CSort s1, CSort s2 -> Miscops.glob_sort_eq s1 s2 - | CCast(_,a1,(CastConv b1|CastVM b1)), CCast(_,a2,(CastConv b2|CastVM b2)) -> + | CCast(a1,(CastConv b1|CastVM b1)), CCast(a2,(CastConv b2|CastVM b2)) -> constr_expr_eq a1 a2 && constr_expr_eq b1 b2 - | CCast(_,a1,CastCoerce), CCast(_,a2, CastCoerce) -> + | CCast(a1,CastCoerce), CCast(a2, CastCoerce) -> constr_expr_eq a1 a2 - | CNotation(_, n1, s1), CNotation(_, n2, s2) -> + | CNotation(n1, s1), CNotation(n2, s2) -> String.equal n1 n2 && constr_notation_substitution_eq s1 s2 - | CPrim(_,i1), CPrim(_,i2) -> + | CPrim i1, CPrim i2 -> prim_token_eq i1 i2 - | CGeneralization (_, bk1, ak1, e1), CGeneralization (_, bk2, ak2, e2) -> + | CGeneralization (bk1, ak1, e1), CGeneralization (bk2, ak2, e2) -> binding_kind_eq bk1 bk2 && Option.equal abstraction_kind_eq ak1 ak2 && constr_expr_eq e1 e2 - | CDelimiters(_,s1,e1), CDelimiters(_,s2,e2) -> + | CDelimiters(s1,e1), CDelimiters(s2,e2) -> String.equal s1 s2 && constr_expr_eq e1 e2 | _ -> false @@ -183,7 +183,7 @@ and case_expr_eq (e1, n1, p1) (e2, n2, p2) = Option.equal (eq_located Name.equal) n1 n2 && Option.equal cases_pattern_expr_eq p1 p2 -and branch_expr_eq (_, p1, e1) (_, p2, e2) = +and branch_expr_eq (_, (p1, e1)) (_, (p2, e2)) = List.equal (eq_located (List.equal cases_pattern_expr_eq)) p1 p2 && constr_expr_eq e1 e2 @@ -228,67 +228,34 @@ and constr_notation_substitution_eq (e1, el1, bl1) (e2, el2, bl2) = and instance_eq (x1,c1) (x2,c2) = Id.equal x1 x2 && constr_expr_eq c1 c2 -let constr_loc = function - | CRef (Ident (loc,_),_) -> loc - | CRef (Qualid (loc,_),_) -> loc - | CFix (loc,_,_) -> loc - | CCoFix (loc,_,_) -> loc - | CProdN (loc,_,_) -> loc - | CLambdaN (loc,_,_) -> loc - | CLetIn (loc,_,_,_,_) -> loc - | CAppExpl (loc,_,_) -> loc - | CApp (loc,_,_) -> loc - | CRecord (loc,_) -> loc - | CCases (loc,_,_,_,_) -> loc - | CLetTuple (loc,_,_,_,_) -> loc - | CIf (loc,_,_,_,_) -> loc - | CHole (loc,_,_,_) -> loc - | CPatVar (loc,_) -> loc - | CEvar (loc,_,_) -> loc - | CSort (loc,_) -> loc - | CCast (loc,_,_) -> loc - | CNotation (loc,_,_) -> loc - | CGeneralization (loc,_,_,_) -> loc - | CPrim (loc,_) -> loc - | CDelimiters (loc,_,_) -> loc - -let cases_pattern_expr_loc = function - | CPatAlias (loc,_,_) -> loc - | CPatCstr (loc,_,_,_) -> loc - | CPatAtom (loc,_) -> loc - | CPatOr (loc,_) -> loc - | CPatNotation (loc,_,_,_) -> loc - | CPatRecord (loc, _) -> loc - | CPatPrim (loc,_) -> loc - | CPatDelimiters (loc,_,_) -> loc - | CPatCast(loc,_,_) -> loc +let constr_loc c = CAst.(c.loc) +let cases_pattern_expr_loc cp = CAst.(cp.loc) let local_binder_loc = function | CLocalAssum ((loc,_)::_,_,t) - | CLocalDef ((loc,_),t,None) -> Loc.merge loc (constr_loc t) - | CLocalDef ((loc,_),b,Some t) -> Loc.merge loc (Loc.merge (constr_loc b) (constr_loc t)) + | CLocalDef ((loc,_),t,None) -> Loc.merge_opt loc (constr_loc t) + | CLocalDef ((loc,_),b,Some t) -> Loc.merge_opt loc (Loc.merge_opt (constr_loc b) (constr_loc t)) | CLocalAssum ([],_,_) -> assert false - | CLocalPattern (loc,_,_) -> loc + | CLocalPattern (loc,_) -> loc let local_binders_loc bll = match bll with - | [] -> Loc.ghost - | h :: l -> - Loc.merge (local_binder_loc h) (local_binder_loc (List.last bll)) + | [] -> None + | h :: l -> Loc.merge_opt (local_binder_loc h) (local_binder_loc (List.last bll)) (** Pseudo-constructors *) -let mkIdentC id = CRef (Ident (Loc.ghost, id),None) -let mkRefC r = CRef (r,None) -let mkCastC (a,k) = CCast (Loc.ghost,a,k) -let mkLambdaC (idl,bk,a,b) = CLambdaN (Loc.ghost,[idl,bk,a],b) -let mkLetInC (id,a,t,b) = CLetIn (Loc.ghost,id,a,t,b) -let mkProdC (idl,bk,a,b) = CProdN (Loc.ghost,[idl,bk,a],b) +let mkIdentC id = CAst.make @@ CRef (Ident (Loc.tag id),None) +let mkRefC r = CAst.make @@ CRef (r,None) +let mkCastC (a,k) = CAst.make @@ CCast (a,k) +let mkLambdaC (idl,bk,a,b) = CAst.make @@ CLambdaN ([idl,bk,a],b) +let mkLetInC (id,a,t,b) = CAst.make @@ CLetIn (id,a,t,b) +let mkProdC (idl,bk,a,b) = CAst.make @@ CProdN ([idl,bk,a],b) let mkAppC (f,l) = let l = List.map (fun x -> (x,None)) l in - match f with - | CApp (_,g,l') -> CApp (Loc.ghost, g, l' @ l) - | _ -> CApp (Loc.ghost, (None, f), l) + match CAst.(f.v) with + | CApp (g,l') -> CAst.make @@ CApp (g, l' @ l) + | _ -> CAst.make @@ CApp ((None, f), l) let add_name_in_env env n = match snd n with @@ -297,67 +264,66 @@ let add_name_in_env env n = let (fresh_var, fresh_var_hook) = Hook.make ~default:(fun _ _ -> assert false) () -let expand_binders mkC loc bl c = - let rec loop loc bl c = +let expand_binders ?loc mkC bl c = + let rec loop ?loc bl c = match bl with | [] -> ([], c) | b :: bl -> match b with | CLocalDef ((loc1,_) as n, oty, b) -> - let env, c = loop (Loc.merge loc1 loc) bl c in + let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in let env = add_name_in_env env n in - (env, CLetIn (loc,n,oty,b,c)) + (env, CAst.make ?loc @@ CLetIn (n,oty,b,c)) | CLocalAssum ((loc1,_)::_ as nl, bk, t) -> - let env, c = loop (Loc.merge loc1 loc) bl c in + let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in let env = List.fold_left add_name_in_env env nl in - (env, mkC loc (nl,bk,t) c) - | CLocalAssum ([],_,_) -> loop loc bl c - | CLocalPattern (loc1, p, ty) -> - let env, c = loop (Loc.merge loc1 loc) bl c in + (env, mkC ?loc (nl,bk,t) c) + | CLocalAssum ([],_,_) -> loop ?loc bl c + | CLocalPattern (loc1, (p, ty)) -> + let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in let ni = Hook.get fresh_var env c in let id = (loc1, Name ni) in let ty = match ty with | Some ty -> ty - | None -> CHole (loc1, None, IntroAnonymous, None) + | None -> CAst.make ?loc:loc1 @@ CHole (None, IntroAnonymous, None) in - let e = CRef (Libnames.Ident (loc1, ni), None) in - let c = + let e = CAst.make @@ CRef (Libnames.Ident (loc1, ni), None) in + let c = CAst.make ?loc @@ CCases - (loc, LetPatternStyle, None, [(e,None,None)], - [(loc1, [(loc1,[p])], c)]) + (LetPatternStyle, None, [(e,None,None)], + [(Loc.tag ?loc:loc1 ([(loc1,[p])], c))]) in - (ni :: env, mkC loc ([id],Default Explicit,ty) c) + (ni :: env, mkC ?loc ([id],Default Explicit,ty) c) in - let (_, c) = loop loc bl c in + let (_, c) = loop ?loc bl c in c -let mkCProdN loc bll c = - let mk loc b c = CProdN (loc,[b],c) in - expand_binders mk loc bll c +let mkCProdN ?loc bll c = + let mk ?loc b c = CAst.make ?loc @@ CProdN ([b],c) in + expand_binders ?loc mk bll c -let mkCLambdaN loc bll c = - let mk loc b c = CLambdaN (loc,[b],c) in - expand_binders mk loc bll c +let mkCLambdaN ?loc bll c = + let mk ?loc b c = CAst.make ?loc @@ CLambdaN ([b],c) in + expand_binders ?loc mk bll c (* Deprecated *) -let abstract_constr_expr c bl = mkCLambdaN (local_binders_loc bl) bl c -let prod_constr_expr c bl = mkCProdN (local_binders_loc bl) bl c +let abstract_constr_expr c bl = mkCLambdaN ?loc:(local_binders_loc bl) bl c +let prod_constr_expr c bl = mkCProdN ?loc:(local_binders_loc bl) bl c let coerce_reference_to_id = function | Ident (_,id) -> id | Qualid (loc,_) -> - CErrors.user_err ~loc ~hdr:"coerce_reference_to_id" + CErrors.user_err ?loc ~hdr:"coerce_reference_to_id" (str "This expression should be a simple identifier.") let coerce_to_id = function - | CRef (Ident (loc,id),_) -> (loc,id) - | a -> CErrors.user_err ~loc:(constr_loc a) + | { CAst.v = CRef (Ident (loc,id),_); _ } -> (loc,id) + | { CAst.loc; _ } -> CErrors.user_err ?loc ~hdr:"coerce_to_id" (str "This expression should be a simple identifier.") let coerce_to_name = function - | CRef (Ident (loc,id),_) -> (loc,Name id) - | CHole (loc,_,_,_) -> (loc,Anonymous) - | a -> CErrors.user_err - ~loc:(constr_loc a) ~hdr:"coerce_to_name" - (str "This expression should be a name.") + | { CAst.v = CRef (Ident (loc,id),_) } -> (loc,Name id) + | { CAst.loc; CAst.v = CHole (_,_,_) } -> (loc,Anonymous) + | { CAst.loc; _ } -> CErrors.user_err ?loc ~hdr:"coerce_to_name" + (str "This expression should be a name.") diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index b547288e3f..0ff51b060f 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -34,9 +34,9 @@ val binder_kind_eq : binder_kind -> binder_kind -> bool (** {6 Retrieving locations} *) -val constr_loc : constr_expr -> Loc.t -val cases_pattern_expr_loc : cases_pattern_expr -> Loc.t -val local_binders_loc : local_binder_expr list -> Loc.t +val constr_loc : constr_expr -> Loc.t option +val cases_pattern_expr_loc : cases_pattern_expr -> Loc.t option +val local_binders_loc : local_binder_expr list -> Loc.t option (** {6 Constructors}*) @@ -48,10 +48,10 @@ val mkLambdaC : Name.t located list * binder_kind * constr_expr * constr_expr -> val mkLetInC : Name.t located * constr_expr * constr_expr option * constr_expr -> constr_expr val mkProdC : Name.t located list * binder_kind * constr_expr * constr_expr -> constr_expr -val mkCLambdaN : Loc.t -> local_binder_expr list -> constr_expr -> constr_expr +val mkCLambdaN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_expr (** Same as [abstract_constr_expr], with location *) -val mkCProdN : Loc.t -> local_binder_expr list -> constr_expr -> constr_expr +val mkCProdN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_expr (** Same as [prod_constr_expr], with location *) (** @deprecated variant of mkCLambdaN *) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 59b8b4e5b9..f6da10c961 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -17,6 +17,7 @@ open Termops open Libnames open Globnames open Impargs +open CAst open Constrexpr open Constrexpr_ops open Notation_ops @@ -91,8 +92,7 @@ let record_print = ref true let _ = let open Goptions in declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "record printing"; optkey = ["Printing";"Records"]; optread = (fun () -> !record_print); @@ -108,7 +108,7 @@ let is_record indsp = let encode_record r = let indsp = global_inductive r in if not (is_record indsp) then - user_err ~loc:(loc_of_reference r) ~hdr:"encode_record" + user_err ?loc:(loc_of_reference r) ~hdr:"encode_record" (str "This type is not a structure type."); indsp @@ -144,45 +144,45 @@ module PrintingConstructor = Goptions.MakeRefTable(PrintingRecordConstructor) let insert_delimiters e = function | None -> e - | Some sc -> CDelimiters (Loc.ghost,sc,e) + | Some sc -> CAst.make @@ CDelimiters (sc,e) -let insert_pat_delimiters loc p = function +let insert_pat_delimiters ?loc p = function | None -> p - | Some sc -> CPatDelimiters (loc,sc,p) + | Some sc -> CAst.make ?loc @@ CPatDelimiters (sc,p) -let insert_pat_alias loc p = function +let insert_pat_alias ?loc p = function | Anonymous -> p - | Name id -> CPatAlias (loc,p,id) + | Name id -> CAst.make ?loc @@ CPatAlias (p,id) (**********************************************************************) (* conversion of references *) -let extern_evar loc n l = CEvar (loc,n,l) +let extern_evar n l = CEvar (n,l) (** We allow customization of the global_reference printer. For instance, in the debugger the tables of global references may be inaccurate *) -let default_extern_reference loc vars r = - Qualid (loc,shortest_qualid_of_global vars r) +let default_extern_reference ?loc vars r = + Qualid (Loc.tag ?loc @@ shortest_qualid_of_global vars r) let my_extern_reference = ref default_extern_reference let set_extern_reference f = my_extern_reference := f let get_extern_reference () = !my_extern_reference -let extern_reference loc vars l = !my_extern_reference loc vars l +let extern_reference ?loc vars l = !my_extern_reference ?loc vars l (**********************************************************************) (* mapping patterns to cases_pattern_expr *) let add_patt_for_params ind l = if !Flags.in_debugger then l else - Util.List.addn (Inductiveops.inductive_nparamdecls ind) (CPatAtom (Loc.ghost,None)) l + Util.List.addn (Inductiveops.inductive_nparamdecls ind) (CAst.make @@ CPatAtom None) l let add_cpatt_for_params ind l = if !Flags.in_debugger then l else - Util.List.addn (Inductiveops.inductive_nparamdecls ind) (PatVar (Loc.ghost,Anonymous)) l + Util.List.addn (Inductiveops.inductive_nparamdecls ind) (CAst.make @@ PatVar Anonymous) l let drop_implicits_in_patt cst nb_expl args = let impl_st = (implicits_of_global cst) in @@ -190,7 +190,7 @@ let drop_implicits_in_patt cst nb_expl args = let rec impls_fit l = function |[],t -> Some (List.rev_append l t) |_,[] -> None - |h::t,CPatAtom(_,None)::tt when is_status_implicit h -> impls_fit l (t,tt) + |h::t, { CAst.v = CPatAtom None }::tt when is_status_implicit h -> impls_fit l (t,tt) |h::_,_ when is_status_implicit h -> None |_::t,hh::tt -> impls_fit (hh::l) (t,tt) in let rec aux = function @@ -236,8 +236,8 @@ let expand_curly_brackets loc mknot ntn l = (* side effect *) mknot (loc,!ntn',l) -let destPrim = function CPrim(_,t) -> Some t | _ -> None -let destPatPrim = function CPatPrim(_,t) -> Some t | _ -> None +let destPrim = function { CAst.v = CPrim t } -> Some t | _ -> None +let destPatPrim = function { CAst.v = CPatPrim t } -> Some t | _ -> None let make_notation_gen loc ntn mknot mkprim destprim l = if has_curly_brackets ntn @@ -259,23 +259,23 @@ let make_notation_gen loc ntn mknot mkprim destprim l = let make_notation loc ntn (terms,termlists,binders as subst) = if not (List.is_empty termlists) || not (List.is_empty binders) then - CNotation (loc,ntn,subst) + CAst.make ?loc @@ CNotation (ntn,subst) else make_notation_gen loc ntn - (fun (loc,ntn,l) -> CNotation (loc,ntn,(l,[],[]))) - (fun (loc,p) -> CPrim (loc,p)) + (fun (loc,ntn,l) -> CAst.make ?loc @@ CNotation (ntn,(l,[],[]))) + (fun (loc,p) -> CAst.make ?loc @@ CPrim p) destPrim terms -let make_pat_notation loc ntn (terms,termlists as subst) args = - if not (List.is_empty termlists) then CPatNotation (loc,ntn,subst,args) else +let make_pat_notation ?loc ntn (terms,termlists as subst) args = + if not (List.is_empty termlists) then (CAst.make ?loc @@ CPatNotation (ntn,subst,args)) else make_notation_gen loc ntn - (fun (loc,ntn,l) -> CPatNotation (loc,ntn,(l,[]),args)) - (fun (loc,p) -> CPatPrim (loc,p)) + (fun (loc,ntn,l) -> CAst.make ?loc @@ CPatNotation (ntn,(l,[]),args)) + (fun (loc,p) -> CAst.make ?loc @@ CPatPrim p) destPatPrim terms -let mkPat loc qid l = +let mkPat ?loc qid l = CAst.make ?loc @@ (* Normally irrelevant test with v8 syntax, but let's do it anyway *) - if List.is_empty l then CPatAtom (loc,Some qid) else CPatCstr (loc,qid,None,l) + if List.is_empty l then CPatAtom (Some qid) else CPatCstr (qid,None,l) let pattern_printable_in_both_syntax (ind,_ as c) = let impl_st = extract_impargs_data (implicits_of_global (ConstructRef c)) in @@ -291,11 +291,11 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = (* pboutill: There are letins in pat which is incompatible with notations and not explicit application. *) match pat with - | PatCstr(loc,cstrsp,args,na) + | { loc; v = PatCstr(cstrsp,args,na) } when !Flags.in_debugger||Inductiveops.constructor_has_local_defs cstrsp -> - let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in + let c = extern_reference ?loc Id.Set.empty (ConstructRef cstrsp) in let args = List.map (extern_cases_pattern_in_scope scopes vars) args in - CPatCstr (loc, c, Some (add_patt_for_params (fst cstrsp) args), []) + CAst.make ?loc @@ CPatCstr (c, Some (add_patt_for_params (fst cstrsp) args), []) | _ -> try if !Flags.raw_print || !print_no_symbol then raise No_match; @@ -304,17 +304,17 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = | None -> raise No_match | Some key -> let loc = cases_pattern_loc pat in - insert_pat_alias loc (insert_pat_delimiters loc (CPatPrim(loc,p)) key) na + insert_pat_alias ?loc (insert_pat_delimiters ?loc (CAst.make ?loc @@ CPatPrim p) key) na with No_match -> try if !Flags.raw_print || !print_no_symbol then raise No_match; extern_notation_pattern scopes vars pat (uninterp_cases_pattern_notations pat) with No_match -> - match pat with - | PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,id))) - | PatVar (loc,Anonymous) -> CPatAtom (loc, None) - | PatCstr(loc,cstrsp,args,na) -> + CAst.map_with_loc (fun ?loc -> function + | PatVar (Name id) -> CPatAtom (Some (Ident (loc,id))) + | PatVar (Anonymous) -> CPatAtom None + | PatCstr(cstrsp,args,na) -> let args = List.map (extern_cases_pattern_in_scope scopes vars) args in let p = try @@ -327,26 +327,32 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = | Some c :: q -> match args with | [] -> raise No_match - | CPatAtom(_, None) :: tail -> ip q tail acc + + + + + + | { CAst.v = CPatAtom None } :: tail -> ip q tail acc (* we don't want to have 'x = _' in our patterns *) | head :: tail -> ip q tail - ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc) + ((extern_reference ?loc Id.Set.empty (ConstRef c), head) :: acc) in - CPatRecord(loc, List.rev (ip projs args [])) + CPatRecord(List.rev (ip projs args [])) with Not_found | No_match | Exit -> - let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in + let c = extern_reference ?loc Id.Set.empty (ConstructRef cstrsp) in if !Topconstr.asymmetric_patterns then if pattern_printable_in_both_syntax cstrsp - then CPatCstr (loc, c, None, args) - else CPatCstr (loc, c, Some (add_patt_for_params (fst cstrsp) args), []) + then CPatCstr (c, None, args) + else CPatCstr (c, Some (add_patt_for_params (fst cstrsp) args), []) else let full_args = add_patt_for_params (fst cstrsp) args in match drop_implicits_in_patt (ConstructRef cstrsp) 0 full_args with - |Some true_args -> CPatCstr (loc, c, None, true_args) - |None -> CPatCstr (loc, c, Some full_args, []) - in insert_pat_alias loc p na -and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args)) + | Some true_args -> CPatCstr (c, None, true_args) + | None -> CPatCstr (c, Some full_args, []) + in (insert_pat_alias ?loc (CAst.make ?loc p) na).v + ) pat +and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) (tmp_scope, scopes as allscopes) vars = function | NotationRule (sc,ntn) -> @@ -373,11 +379,11 @@ and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args)) |Some true_args -> true_args |None -> raise No_match in - insert_pat_delimiters loc - (make_pat_notation loc ntn (l,ll) l2') key + insert_pat_delimiters ?loc + (make_pat_notation ?loc ntn (l,ll) l2') key end | SynDefRule kn -> - let qid = Qualid (loc, shortest_qualid_of_syndef vars kn) in + let qid = Qualid (Loc.tag ?loc @@ shortest_qualid_of_syndef vars kn) in let l1 = List.rev_map (fun (c,(scopt,scl)) -> extern_cases_pattern_in_scope (scopt,scl@scopes) vars c) @@ -390,19 +396,20 @@ and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args)) |None -> raise No_match in assert (List.is_empty substlist); - mkPat loc qid (List.rev_append l1 l2') + mkPat ?loc qid (List.rev_append l1 l2') and extern_notation_pattern (tmp_scope,scopes as allscopes) vars t = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> try if List.mem keyrule !print_non_active_notations then raise No_match; - match t with - | PatCstr (loc,cstr,_,na) -> - let p = apply_notation_to_pattern loc (ConstructRef cstr) + let loc = t.loc in + match t.v with + | PatCstr (cstr,_,na) -> + let p = apply_notation_to_pattern ?loc (ConstructRef cstr) (match_notation_constr_cases_pattern t pat) allscopes vars keyrule in - insert_pat_alias loc p na - | PatVar (loc,Anonymous) -> CPatAtom (loc, None) - | PatVar (loc,Name id) -> CPatAtom (loc, Some (Ident (loc,id))) + insert_pat_alias ?loc p na + | PatVar Anonymous -> CAst.make ?loc @@ CPatAtom None + | PatVar (Name id) -> CAst.make ?loc @@ CPatAtom (Some (Ident (loc,id))) with No_match -> extern_notation_pattern allscopes vars t rules @@ -411,7 +418,7 @@ let rec extern_notation_ind_pattern allscopes vars ind args = function | (keyrule,pat,n as _rule)::rules -> try if List.mem keyrule !print_non_active_notations then raise No_match; - apply_notation_to_pattern Loc.ghost (IndRef ind) + apply_notation_to_pattern (IndRef ind) (match_notation_constr_ind_pattern ind args pat) allscopes vars keyrule with No_match -> extern_notation_ind_pattern allscopes vars ind args rules @@ -420,9 +427,9 @@ let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args = (* pboutill: There are letins in pat which is incompatible with notations and not explicit application. *) if !Flags.in_debugger||Inductiveops.inductive_has_local_defs ind then - let c = extern_reference Loc.ghost vars (IndRef ind) in + let c = extern_reference vars (IndRef ind) in let args = List.map (extern_cases_pattern_in_scope scopes vars) args in - CPatCstr (Loc.ghost, c, Some (add_patt_for_params ind args), []) + CAst.make @@ CPatCstr (c, Some (add_patt_for_params ind args), []) else try if !Flags.raw_print || !print_no_symbol then raise No_match; @@ -430,18 +437,18 @@ let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args = match availability_of_prim_token p sc scopes with | None -> raise No_match | Some key -> - insert_pat_delimiters Loc.ghost (CPatPrim(Loc.ghost,p)) key + insert_pat_delimiters (CAst.make @@ CPatPrim p) key with No_match -> try if !Flags.raw_print || !print_no_symbol then raise No_match; extern_notation_ind_pattern scopes vars ind args (uninterp_ind_pattern_notations ind) with No_match -> - let c = extern_reference Loc.ghost vars (IndRef ind) in + let c = extern_reference vars (IndRef ind) in let args = List.map (extern_cases_pattern_in_scope scopes vars) args in match drop_implicits_in_patt (IndRef ind) 0 args with - |Some true_args -> CPatCstr (Loc.ghost, c, None, true_args) - |None -> CPatCstr (Loc.ghost, c, Some args, []) + |Some true_args -> CAst.make @@ CPatCstr (c, None, true_args) + |None -> CAst.make @@ CPatCstr (c, Some args, []) let extern_cases_pattern vars p = extern_cases_pattern_in_scope (None,[]) vars p @@ -462,11 +469,11 @@ let is_projection nargs = function else None with Not_found -> None) | _ -> None - + let is_hole = function CHole _ | CEvar _ -> true | _ -> false let is_significant_implicit a = - not (is_hole a) + not (is_hole (a.CAst.v)) let is_needed_for_correct_partial_application tail imp = List.is_empty tail && not (maximal_insertion_of imp) @@ -475,7 +482,7 @@ exception Expl (* Implicit args indexes are in ascending order *) (* inctx is useful only if there is a last argument to be deduced from ctxt *) -let explicitize loc inctx impl (cf,f) args = +let explicitize inctx impl (cf,f) args = let impl = if !Constrintern.parsing_explicit then [] else impl in let n = List.length args in let rec exprec q = function @@ -490,7 +497,7 @@ let explicitize loc inctx impl (cf,f) args = is_significant_implicit (Lazy.force a)) in if visible then - (Lazy.force a,Some (Loc.ghost, ExplByName (name_of_implicit imp))) :: tail + (Lazy.force a,Some (Loc.tag @@ ExplByName (name_of_implicit imp))) :: tail else tail | a::args, _::impl -> (Lazy.force a,None) :: exprec (q+1) (args,impl) @@ -512,41 +519,41 @@ let explicitize loc inctx impl (cf,f) args = let args1 = exprec 1 (args1,impl1) in let args2 = exprec (i+1) (args2,impl2) in let ip = Some (List.length args1) in - CApp (loc,(ip,f),args1@args2) + CApp ((ip,f),args1@args2) | None -> let args = exprec 1 (args,impl) in - if List.is_empty args then f else CApp (loc, (None, f), args) + if List.is_empty args then f.CAst.v else CApp ((None, f), args) in try expl () with Expl -> - let f',us = match f with CRef (f,us) -> f,us | _ -> assert false in + let f',us = match f with { CAst.v = CRef (f,us) } -> f,us | _ -> assert false in let ip = if !print_projections then ip else None in - CAppExpl (loc, (ip, f', us), List.map Lazy.force args) + CAppExpl ((ip, f', us), List.map Lazy.force args) let is_start_implicit = function | imp :: _ -> is_status_implicit imp && maximal_insertion_of imp | [] -> false -let extern_global loc impl f us = +let extern_global impl f us = if not !Constrintern.parsing_explicit && is_start_implicit impl then - CAppExpl (loc, (None, f, us), []) + CAppExpl ((None, f, us), []) else CRef (f,us) -let extern_app loc inctx impl (cf,f) us args = +let extern_app inctx impl (cf,f) us args = if List.is_empty args then (* If coming from a notation "Notation a := @b" *) - CAppExpl (loc, (None, f, us), []) + CAppExpl ((None, f, us), []) else if not !Constrintern.parsing_explicit && ((!Flags.raw_print || (!print_implicits && not !print_implicits_explicit_args)) && List.exists is_status_implicit impl) then let args = List.map Lazy.force args in - CAppExpl (loc, (is_projection (List.length args) cf,f,us), args) + CAppExpl ((is_projection (List.length args) cf,f,us), args) else - explicitize loc inctx impl (cf,CRef (f,us)) args + explicitize inctx impl (cf, CAst.make @@ CRef (f,us)) args let rec fill_arg_scopes args subscopes scopes = match args, subscopes with | [], _ -> [] @@ -560,7 +567,7 @@ let extern_args extern env args = List.map map args let match_coercion_app = function - | GApp (loc,GRef (_,r,_),args) -> Some (loc, r, 0, args) + | {loc; v = GApp ({ v = GRef (r,_) },args)} -> Some (loc, r, 0, args) | _ -> None let rec remove_coercions inctx c = @@ -582,13 +589,13 @@ let rec remove_coercions inctx c = been confused with ordinary application or would have need a surrounding context and the coercion to funclass would have been made explicit to match *) - if List.is_empty l then a' else GApp (loc,a',l) + if List.is_empty l then a' else CAst.make ?loc @@ GApp (a',l) | _ -> c with Not_found -> c) | _ -> c let rec flatten_application = function - | GApp (loc,GApp(_,a,l'),l) -> flatten_application (GApp (loc,a,l'@l)) + | {loc; v = GApp ({ v = GApp(a,l')},l)} -> flatten_application (CAst.make ?loc @@ GApp (a,l'@l)) | a -> a (**********************************************************************) @@ -600,7 +607,7 @@ let extern_possible_prim_token scopes r = let (sc,n) = uninterp_prim_token r in match availability_of_prim_token n sc scopes with | None -> None - | Some key -> Some (insert_delimiters (CPrim (loc_of_glob_constr r,n)) key) + | Some key -> Some (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key) with No_match -> None @@ -608,16 +615,18 @@ let extern_optimal_prim_token scopes r r' = let c = extern_possible_prim_token scopes r in let c' = if r==r' then None else extern_possible_prim_token scopes r' in match c,c' with - | Some n, (Some (CDelimiters _) | None) | _, Some n -> n + | Some n, (Some ({ CAst.v = CDelimiters _}) | None) | _, Some n -> n | _ -> raise No_match (**********************************************************************) (* mapping decl *) let extended_glob_local_binder_of_decl loc = function - | (p,bk,None,t) -> GLocalAssum (loc,p,bk,t) - | (p,bk,Some x,GHole (_, _, Misctypes.IntroAnonymous, None)) -> GLocalDef (loc,p,bk,x,None) - | (p,bk,Some x,t) -> GLocalDef (loc,p,bk,x,Some t) + | (p,bk,None,t) -> GLocalAssum (p,bk,t) + | (p,bk,Some x, { v = GHole ( _, Misctypes.IntroAnonymous, None) } ) -> GLocalDef (p,bk,x,None) + | (p,bk,Some x,t) -> GLocalDef (p,bk,x,Some t) + +let extended_glob_local_binder_of_decl ?loc u = CAst.make ?loc (extended_glob_local_binder_of_decl loc u) (**********************************************************************) (* mapping glob_constr to constr_expr *) @@ -642,25 +651,25 @@ let rec extern inctx scopes vars r = let r'' = flatten_application r' in if !Flags.raw_print || !print_no_symbol then raise No_match; extern_notation scopes vars r'' (uninterp_notations r'') - with No_match -> match r' with - | GRef (loc,ref,us) -> - extern_global loc (select_stronger_impargs (implicits_of_global ref)) - (extern_reference loc vars ref) (extern_universes us) + with No_match -> CAst.map_with_loc (fun ?loc -> function + | GRef (ref,us) -> + extern_global (select_stronger_impargs (implicits_of_global ref)) + (extern_reference ?loc vars ref) (extern_universes us) - | GVar (loc,id) -> CRef (Ident (loc,id),None) + | GVar id -> CRef (Ident (loc,id),None) - | GEvar (loc,n,[]) when !print_meta_as_hole -> CHole (loc, None, Misctypes.IntroAnonymous, None) + | GEvar (n,[]) when !print_meta_as_hole -> CHole (None, Misctypes.IntroAnonymous, None) - | GEvar (loc,n,l) -> - extern_evar loc n (List.map (on_snd (extern false scopes vars)) l) + | GEvar (n,l) -> + extern_evar n (List.map (on_snd (extern false scopes vars)) l) - | GPatVar (loc,(b,n)) -> - if !print_meta_as_hole then CHole (loc, None, Misctypes.IntroAnonymous, None) else - if b then CPatVar (loc,n) else CEvar (loc,n,[]) + | GPatVar (b,n) -> + if !print_meta_as_hole then CHole (None, Misctypes.IntroAnonymous, None) else + if b then CPatVar n else CEvar (n,[]) - | GApp (loc,f,args) -> + | GApp (f,args) -> (match f with - | GRef (rloc,ref,us) -> + | {loc = rloc; v = GRef (ref,us) } -> let subscopes = find_arguments_scope ref in let args = fill_arg_scopes args subscopes (snd scopes) in begin @@ -699,119 +708,120 @@ let rec extern inctx scopes vars r = (* we give up since the constructor is not complete *) | (arg, scopes) :: tail -> let head = extern true scopes vars arg in - ip q locs' tail ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc) + ip q locs' tail ((extern_reference ?loc Id.Set.empty (ConstRef c), head) :: acc) in - CRecord (loc, List.rev (ip projs locals args [])) + CRecord (List.rev (ip projs locals args [])) with | Not_found | No_match | Exit -> let args = extern_args (extern true) vars args in - extern_app loc inctx + extern_app inctx (select_stronger_impargs (implicits_of_global ref)) - (Some ref,extern_reference rloc vars ref) (extern_universes us) args + (Some ref,extern_reference ?loc:rloc vars ref) (extern_universes us) args end - + | _ -> - explicitize loc inctx [] (None,sub_extern false scopes vars f) + explicitize inctx [] (None,sub_extern false scopes vars f) (List.map (fun c -> lazy (sub_extern true scopes vars c)) args)) - | GLetIn (loc,na,b,t,c) -> - CLetIn (loc,(loc,na),sub_extern false scopes vars b, + | GLetIn (na,b,t,c) -> + CLetIn ((loc,na),sub_extern false scopes vars b, Option.map (extern_typ scopes vars) t, extern inctx scopes (add_vname vars na) c) - | GProd (loc,na,bk,t,c) -> + | GProd (na,bk,t,c) -> let t = extern_typ scopes vars t in let (idl,c) = factorize_prod scopes (add_vname vars na) na bk t c in - CProdN (loc,[(Loc.ghost,na)::idl,Default bk,t],c) + CProdN ([(Loc.tag na)::idl,Default bk,t],c) - | GLambda (loc,na,bk,t,c) -> + | GLambda (na,bk,t,c) -> let t = extern_typ scopes vars t in let (idl,c) = factorize_lambda inctx scopes (add_vname vars na) na bk t c in - CLambdaN (loc,[(Loc.ghost,na)::idl,Default bk,t],c) + CLambdaN ([(Loc.tag na)::idl,Default bk,t],c) - | GCases (loc,sty,rtntypopt,tml,eqns) -> + | GCases (sty,rtntypopt,tml,eqns) -> let vars' = - List.fold_right (name_fold Id.Set.add) + List.fold_right (Name.fold_right Id.Set.add) (cases_predicate_names tml) vars in let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in let tml = List.map (fun (tm,(na,x)) -> let na' = match na,tm with - | Anonymous, GVar (_, id) -> + | Anonymous, { v = GVar id } -> begin match rtntypopt with | None -> None | Some ntn -> if occur_glob_constr id ntn then - Some (Loc.ghost, Anonymous) + Some (Loc.tag Anonymous) else None end | Anonymous, _ -> None - | Name id, GVar (_,id') when Id.equal id id' -> None - | Name _, _ -> Some (Loc.ghost,na) in + | Name id, { v = GVar id' } when Id.equal id id' -> None + | Name _, _ -> Some (Loc.tag na) in (sub_extern false scopes vars tm, na', - Option.map (fun (loc,ind,nal) -> - let args = List.map (fun x -> PatVar (Loc.ghost, x)) nal in + Option.map (fun (loc,(ind,nal)) -> + let args = List.map (fun x -> CAst.make @@ PatVar x) nal in let fullargs = add_cpatt_for_params ind args in extern_ind_pattern_in_scope scopes vars ind fullargs ) x)) tml in let eqns = List.map (extern_eqn inctx scopes vars) eqns in - CCases (loc,sty,rtntypopt',tml,eqns) + CCases (sty,rtntypopt',tml,eqns) - | GLetTuple (loc,nal,(na,typopt),tm,b) -> - CLetTuple (loc,List.map (fun na -> (Loc.ghost,na)) nal, - (Option.map (fun _ -> (Loc.ghost,na)) typopt, + | GLetTuple (nal,(na,typopt),tm,b) -> + CLetTuple (List.map (fun na -> (Loc.tag na)) nal, + (Option.map (fun _ -> (Loc.tag na)) typopt, Option.map (extern_typ scopes (add_vname vars na)) typopt), sub_extern false scopes vars tm, extern inctx scopes (List.fold_left add_vname vars nal) b) - | GIf (loc,c,(na,typopt),b1,b2) -> - CIf (loc,sub_extern false scopes vars c, - (Option.map (fun _ -> (Loc.ghost,na)) typopt, + | GIf (c,(na,typopt),b1,b2) -> + CIf (sub_extern false scopes vars c, + (Option.map (fun _ -> (Loc.tag na)) typopt, Option.map (extern_typ scopes (add_vname vars na)) typopt), sub_extern inctx scopes vars b1, sub_extern inctx scopes vars b2) - | GRec (loc,fk,idv,blv,tyv,bv) -> + | GRec (fk,idv,blv,tyv,bv) -> let vars' = Array.fold_right Id.Set.add idv vars in (match fk with | GFix (nv,n) -> let listdecl = Array.mapi (fun i fi -> let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in - let bl = List.map (extended_glob_local_binder_of_decl loc) bl in + let bl = List.map (extended_glob_local_binder_of_decl ?loc) bl in let (assums,ids,bl) = extern_local_binder scopes vars bl in - let vars0 = List.fold_right (name_fold Id.Set.add) ids vars in - let vars1 = List.fold_right (name_fold Id.Set.add) ids vars' in + let vars0 = List.fold_right (Name.fold_right Id.Set.add) ids vars in + let vars1 = List.fold_right (Name.fold_right Id.Set.add) ids vars' in let n = match fst nv.(i) with | None -> None - | Some x -> Some (Loc.ghost, out_name (List.nth assums x)) + | Some x -> Some (Loc.tag @@ Name.get_id (List.nth assums x)) in let ro = extern_recursion_order scopes vars (snd nv.(i)) in - ((Loc.ghost, fi), (n, ro), bl, extern_typ scopes vars0 ty, + ((Loc.tag fi), (n, ro), bl, extern_typ scopes vars0 ty, extern false scopes vars1 def)) idv in - CFix (loc,(loc,idv.(n)),Array.to_list listdecl) + CFix ((loc,idv.(n)),Array.to_list listdecl) | GCoFix n -> let listdecl = Array.mapi (fun i fi -> - let bl = List.map (extended_glob_local_binder_of_decl loc) blv.(i) in + let bl = List.map (extended_glob_local_binder_of_decl ?loc) blv.(i) in let (_,ids,bl) = extern_local_binder scopes vars bl in - let vars0 = List.fold_right (name_fold Id.Set.add) ids vars in - let vars1 = List.fold_right (name_fold Id.Set.add) ids vars' in - ((Loc.ghost, fi),bl,extern_typ scopes vars0 tyv.(i), + let vars0 = List.fold_right (Name.fold_right Id.Set.add) ids vars in + let vars1 = List.fold_right (Name.fold_right Id.Set.add) ids vars' in + ((Loc.tag fi),bl,extern_typ scopes vars0 tyv.(i), sub_extern false scopes vars1 bv.(i))) idv in - CCoFix (loc,(loc,idv.(n)),Array.to_list listdecl)) + CCoFix ((loc,idv.(n)),Array.to_list listdecl)) - | GSort (loc,s) -> CSort (loc,extern_glob_sort s) + | GSort s -> CSort (extern_glob_sort s) - | GHole (loc,e,naming,_) -> CHole (loc, Some e, naming, None) (** TODO: extern tactics. *) + | GHole (e,naming,_) -> CHole (Some e, naming, None) (** TODO: extern tactics. *) - | GCast (loc,c, c') -> - CCast (loc,sub_extern true scopes vars c, + | GCast (c, c') -> + CCast (sub_extern true scopes vars c, Miscops.map_cast_type (extern_typ scopes vars) c') + ) r' and extern_typ (_,scopes) = extern true (Notation.current_type_scope_name (),scopes) @@ -821,7 +831,7 @@ and sub_extern inctx (_,scopes) = extern inctx (None,scopes) and factorize_prod scopes vars na bk aty c = let c = extern_typ scopes vars c in match na, c with - | Name id, CProdN (loc,[nal,Default bk',ty],c) + | Name id, { CAst.loc ; v = CProdN ([nal,Default bk',ty],c) } when binding_kind_eq bk bk' && constr_expr_eq aty ty && not (occur_var_constr_expr id ty) (* avoid na in ty escapes scope *) -> nal,c @@ -831,7 +841,7 @@ and factorize_prod scopes vars na bk aty c = and factorize_lambda inctx scopes vars na bk aty c = let c = sub_extern inctx scopes vars c in match c with - | CLambdaN (loc,[nal,Default bk',ty],c) + | { CAst.loc; v = CLambdaN ([nal,Default bk',ty],c) } when binding_kind_eq bk bk' && constr_expr_eq aty ty && not (occur_name na ty) (* avoid na in ty escapes scope *) -> nal,c @@ -840,35 +850,35 @@ and factorize_lambda inctx scopes vars na bk aty c = and extern_local_binder scopes vars = function [] -> ([],[],[]) - | GLocalDef (_,na,bk,bd,ty)::l -> + | { v = GLocalDef (na,bk,bd,ty)}::l -> let (assums,ids,l) = - extern_local_binder scopes (name_fold Id.Set.add na vars) l in + extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l in (assums,na::ids, - CLocalDef((Loc.ghost,na), extern false scopes vars bd, + CLocalDef((Loc.tag na), extern false scopes vars bd, Option.map (extern false scopes vars) ty) :: l) - | GLocalAssum (_,na,bk,ty)::l -> + | { v = GLocalAssum (na,bk,ty)}::l -> let ty = extern_typ scopes vars ty in - (match extern_local_binder scopes (name_fold Id.Set.add na vars) l with + (match extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l with (assums,ids,CLocalAssum(nal,k,ty')::l) when constr_expr_eq ty ty' && match na with Name id -> not (occur_var_constr_expr id ty') | _ -> true -> (na::assums,na::ids, - CLocalAssum((Loc.ghost,na)::nal,k,ty')::l) + CLocalAssum((Loc.tag na)::nal,k,ty')::l) | (assums,ids,l) -> (na::assums,na::ids, - CLocalAssum([(Loc.ghost,na)],Default bk,ty) :: l)) + CLocalAssum([(Loc.tag na)],Default bk,ty) :: l)) - | GLocalPattern (_,(p,_),_,bk,ty)::l -> + | { v = GLocalPattern ((p,_),_,bk,ty)}::l -> let ty = if !Flags.raw_print then Some (extern_typ scopes vars ty) else None in let p = extern_cases_pattern vars p in let (assums,ids,l) = extern_local_binder scopes vars l in - (assums,ids, CLocalPattern(Loc.ghost,p,ty) :: l) + (assums,ids, CLocalPattern(Loc.tag @@ (p,ty)) :: l) -and extern_eqn inctx scopes vars (loc,ids,pl,c) = - (loc,[loc,List.map (extern_cases_pattern_in_scope scopes vars) pl], +and extern_eqn inctx scopes vars (loc,(ids,pl,c)) = + Loc.tag ?loc ([loc,List.map (extern_cases_pattern_in_scope scopes vars) pl], extern inctx scopes vars c) and extern_notation (tmp_scope,scopes as allscopes) vars t = function @@ -878,13 +888,13 @@ and extern_notation (tmp_scope,scopes as allscopes) vars t = function try if List.mem keyrule !print_non_active_notations then raise No_match; (* Adjusts to the number of arguments expected by the notation *) - let (t,args,argsscopes,argsimpls) = match t,n with - | GApp (_,f,args), Some n + let (t,args,argsscopes,argsimpls) = match t.v ,n with + | GApp (f,args), Some n when List.length args >= n -> let args1, args2 = List.chop n args in let subscopes, impls = - match f with - | GRef (_,ref,us) -> + match f.v with + | GRef (ref,us) -> let subscopes = try List.skipn n (find_arguments_scope ref) with Failure _ -> [] in @@ -896,15 +906,15 @@ and extern_notation (tmp_scope,scopes as allscopes) vars t = function subscopes,impls | _ -> [], [] in - (if Int.equal n 0 then f else GApp (Loc.ghost,f,args1)), + (if Int.equal n 0 then f else CAst.make @@ GApp (f,args1)), args2, subscopes, impls - | GApp (_,(GRef (_,ref,us) as f),args), None -> + | GApp ({ v = GRef (ref,us) } as f, args), None -> let subscopes = find_arguments_scope ref in let impls = select_impargs_size (List.length args) (implicits_of_global ref) in f, args, subscopes, impls - | GRef (_,ref,us), Some 0 -> GApp (Loc.ghost,t,[]), [], [], [] + | GRef (ref,us), Some 0 -> CAst.make @@ GApp (t,[]), [], [], [] | _, None -> t, [], [], [] | _ -> raise No_match in (* Try matching ... *) @@ -940,12 +950,12 @@ and extern_notation (tmp_scope,scopes as allscopes) vars t = function extern true (scopt,scl@scopes) vars c, None) terms in let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn),None) in - if List.is_empty l then a else CApp (loc,(None,a),l) in + CAst.make ?loc @@ if List.is_empty l then a else CApp ((None, CAst.make a),l) in if List.is_empty args then e else let args = fill_arg_scopes args argsscopes scopes in let args = extern_args (extern true) vars args in - explicitize loc false argsimpls (None,e) args + CAst.make ?loc @@ explicitize false argsimpls (None,e) args with No_match -> extern_notation allscopes vars t rules @@ -965,8 +975,6 @@ let extern_glob_type vars c = (******************************************************************) (* Main translation function from constr -> constr_expr *) -let loc = Loc.ghost (* for constr and pattern, locations are lost *) - let extern_constr_gen lax goal_concl_style scopt env sigma t = (* "goal_concl_style" means do alpha-conversion using the "goal" convention *) (* i.e.: avoid using the names of goal/section/rel variables and the short *) @@ -1008,11 +1016,11 @@ let extern_closed_glob ?lax goal_concl_style env sigma t = let any_any_branch = (* | _ => _ *) - (loc,[],[PatVar (loc,Anonymous)],GHole (loc,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None)) + Loc.tag ([],[CAst.make @@ PatVar Anonymous], CAst.make @@ GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None)) -let rec glob_of_pat env sigma = function - | PRef ref -> GRef (loc,ref,None) - | PVar id -> GVar (loc,id) +let rec glob_of_pat env sigma pat = CAst.make @@ match pat with + | PRef ref -> GRef (ref,None) + | PVar id -> GVar id | PEvar (evk,l) -> let test decl = function PVar id' -> Id.equal (NamedDecl.get_id decl) id' | _ -> false in let l = Evd.evar_instance_array test (Evd.find sigma evk) l in @@ -1020,36 +1028,36 @@ let rec glob_of_pat env sigma = function | None -> Id.of_string "__" | Some id -> id in - GEvar (loc,id,List.map (on_snd (glob_of_pat env sigma)) l) + GEvar (id,List.map (on_snd (glob_of_pat env sigma)) l) | PRel n -> let id = try match lookup_name_of_rel n env with | Name id -> id | Anonymous -> anomaly ~label:"glob_constr_of_pattern" (Pp.str "index to an anonymous variable") with Not_found -> Id.of_string ("_UNBOUND_REL_"^(string_of_int n)) in - GVar (loc,id) - | PMeta None -> GHole (loc,Evar_kinds.InternalHole, Misctypes.IntroAnonymous,None) - | PMeta (Some n) -> GPatVar (loc,(false,n)) - | PProj (p,c) -> GApp (loc,GRef (loc, ConstRef (Projection.constant p),None), + GVar id + | PMeta None -> GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous,None) + | PMeta (Some n) -> GPatVar (false,n) + | PProj (p,c) -> GApp (CAst.make @@ GRef (ConstRef (Projection.constant p),None), [glob_of_pat env sigma c]) | PApp (f,args) -> - GApp (loc,glob_of_pat env sigma f,Array.map_to_list (glob_of_pat env sigma) args) + GApp (glob_of_pat env sigma f,Array.map_to_list (glob_of_pat env sigma) args) | PSoApp (n,args) -> - GApp (loc,GPatVar (loc,(true,n)), + GApp (CAst.make @@ GPatVar (true,n), List.map (glob_of_pat env sigma) args) | PProd (na,t,c) -> - GProd (loc,na,Explicit,glob_of_pat env sigma t,glob_of_pat (na::env) sigma c) + GProd (na,Explicit,glob_of_pat env sigma t,glob_of_pat (na::env) sigma c) | PLetIn (na,b,t,c) -> - GLetIn (loc,na,glob_of_pat env sigma b, Option.map (glob_of_pat env sigma) t, + GLetIn (na,glob_of_pat env sigma b, Option.map (glob_of_pat env sigma) t, glob_of_pat (na::env) sigma c) | PLambda (na,t,c) -> - GLambda (loc,na,Explicit,glob_of_pat env sigma t, glob_of_pat (na::env) sigma c) + GLambda (na,Explicit,glob_of_pat env sigma t, glob_of_pat (na::env) sigma c) | PIf (c,b1,b2) -> - GIf (loc, glob_of_pat env sigma c, (Anonymous,None), + GIf (glob_of_pat env sigma c, (Anonymous,None), glob_of_pat env sigma b1, glob_of_pat env sigma b2) | PCase ({cip_style=LetStyle; cip_ind_tags=None},PMeta None,tm,[(0,n,b)]) -> let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat env sigma b) in - GLetTuple (loc,nal,(Anonymous,None),glob_of_pat env sigma tm,b) + GLetTuple (nal,(Anonymous,None),glob_of_pat env sigma tm,b) | PCase (info,p,tm,bl) -> let mat = match bl, info.cip_ind with | [], _ -> [] @@ -1066,10 +1074,10 @@ let rec glob_of_pat env sigma = function return_type_of_predicate ind nargs (glob_of_pat env sigma p) | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive") in - GCases (loc,RegularStyle,rtn,[glob_of_pat env sigma tm,indnames],mat) - | PFix f -> Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkFix f)) (** FIXME bad env *) - | PCoFix c -> Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkCoFix c)) - | PSort s -> GSort (loc,s) + GCases (RegularStyle,rtn,[glob_of_pat env sigma tm,indnames],mat) + | PFix f -> (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkFix f))).v (** FIXME bad env *) + | PCoFix c -> (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkCoFix c))).v + | PSort s -> GSort s let extern_constr_pattern env sigma pat = extern true (None,[]) Id.Set.empty (glob_of_pat env sigma pat) @@ -1079,5 +1087,5 @@ let extern_rel_context where env sigma sign = let where = Option.map EConstr.of_constr where in let a = detype_rel_context where [] (names_of_rel_context env,env) sigma sign in let vars = vars_of_env env in - let a = List.map (extended_glob_local_binder_of_decl Loc.ghost) a in + let a = List.map (extended_glob_local_binder_of_decl) a in pi3 (extern_local_binder (None,[]) vars a) diff --git a/interp/constrextern.mli b/interp/constrextern.mli index b39339450a..ea627cff11 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -37,7 +37,7 @@ val extern_closed_glob : ?lax:bool -> bool -> env -> Evd.evar_map -> closed_glob val extern_constr : ?lax:bool -> bool -> env -> Evd.evar_map -> constr -> constr_expr val extern_constr_in_scope : bool -> scope_name -> env -> Evd.evar_map -> constr -> constr_expr -val extern_reference : Loc.t -> Id.Set.t -> global_reference -> reference +val extern_reference : ?loc:Loc.t -> Id.Set.t -> global_reference -> reference val extern_type : bool -> env -> Evd.evar_map -> types -> constr_expr val extern_sort : Evd.evar_map -> sorts -> glob_sort val extern_rel_context : constr option -> env -> Evd.evar_map -> @@ -55,9 +55,9 @@ val print_projections : bool ref (** Customization of the global_reference printer *) val set_extern_reference : - (Loc.t -> Id.Set.t -> global_reference -> reference) -> unit + (?loc:Loc.t -> Id.Set.t -> global_reference -> reference) -> unit val get_extern_reference : - unit -> (Loc.t -> Id.Set.t -> global_reference -> reference) + unit -> (?loc:Loc.t -> Id.Set.t -> global_reference -> reference) (** This governs printing of implicit arguments. If [with_implicits] is on and not [with_arguments] then implicit args are printed prefixed diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 2426366c62..190369e8fa 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -15,6 +15,7 @@ open Namegen open Libnames open Globnames open Impargs +open CAst open Glob_term open Glob_ops open Patternops @@ -68,6 +69,7 @@ type internalization_env = type ltac_sign = { ltac_vars : Id.Set.t; ltac_bound : Id.Set.t; + ltac_extra : Genintern.Store.t; } let interning_grammar = ref false @@ -96,16 +98,16 @@ let global_reference_of_reference ref = locate_reference (snd (qualid_of_reference ref)) let global_reference id = - Universes.constr_of_global (locate_reference (qualid_of_ident id)) + locate_reference (qualid_of_ident id) let construct_reference ctx id = try - Term.mkVar (let _ = Context.Named.lookup id ctx in id) + VarRef (let _ = Context.Named.lookup id ctx in id) with Not_found -> global_reference id let global_reference_in_absolute_module dir id = - Universes.constr_of_global (Nametab.global_of_path (Libnames.make_path dir id)) + Nametab.global_of_path (Libnames.make_path dir id) (**********************************************************************) (* Internalization errors *) @@ -118,7 +120,7 @@ type internalization_error = | NonLinearPattern of Id.t | BadPatternsNumber of int * int -exception InternalizationError of Loc.t * internalization_error +exception InternalizationError of internalization_error Loc.located let explain_variable_capture id id' = pr_id id ++ str " is dependent in the type of " ++ pr_id id' ++ @@ -217,7 +219,7 @@ let contract_notation ntn (l,ll,bll) = let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] - | CNotation (_,"{ _ }",([a],[],[])) :: l -> + | { CAst.v = CNotation ("{ _ }",([a],[],[])) } :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> @@ -230,7 +232,7 @@ let contract_pat_notation ntn (l,ll) = let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] - | CPatNotation (_,"{ _ }",([a],[]),[]) :: l -> + | { CAst.v = CPatNotation ("{ _ }",([a],[]),[]) } :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> @@ -271,7 +273,7 @@ let error_expect_binder_notation_type ?loc id = (pr_id id ++ str " is expected to occur in binding position in the right-hand side.") -let set_var_scope loc id istermvar env ntnvars = +let set_var_scope ?loc id istermvar env ntnvars = try let isonlybinding,idscopes,typ = Id.Map.find id ntnvars in if istermvar then isonlybinding := false; @@ -282,12 +284,12 @@ let set_var_scope loc id istermvar env ntnvars = | Some (tmp, scope) -> let s1 = make_current_scope tmp scope in let s2 = make_current_scope env.tmp_scope env.scopes in - if not (List.equal String.equal s1 s2) then error_inconsistent_scope ~loc id s1 s2 + if not (List.equal String.equal s1 s2) then error_inconsistent_scope ?loc id s1 s2 end in match typ with | NtnInternTypeBinder -> - if istermvar then error_expect_binder_notation_type ~loc id + if istermvar then error_expect_binder_notation_type ?loc id | NtnInternTypeConstr -> (* We need sometimes to parse idents at a constr level for factorization and we cannot enforce this constraint: @@ -302,14 +304,14 @@ let set_type_scope env = {env with tmp_scope = Notation.current_type_scope_name let reset_tmp_scope env = {env with tmp_scope = None} -let rec it_mkGProd loc2 env body = +let rec it_mkGProd ?loc env body = match env with - (loc1, (na, bk, t)) :: tl -> it_mkGProd loc2 tl (GProd (Loc.merge loc1 loc2, na, bk, t, body)) + (loc2, (na, bk, t)) :: tl -> it_mkGProd ?loc:loc2 tl (CAst.make ?loc:(Loc.merge_opt loc loc2) @@ GProd (na, bk, t, body)) | [] -> body -let rec it_mkGLambda loc2 env body = +let rec it_mkGLambda ?loc env body = match env with - (loc1, (na, bk, t)) :: tl -> it_mkGLambda loc2 tl (GLambda (Loc.merge loc1 loc2, na, bk, t, body)) + (loc2, (na, bk, t)) :: tl -> it_mkGLambda ?loc:loc2 tl (CAst.make ?loc:(Loc.merge_opt loc loc2) @@ GLambda (na, bk, t, body)) | [] -> body (**********************************************************************) @@ -322,14 +324,14 @@ let build_impls = function let impls_type_list ?(args = []) = let rec aux acc = function - |GProd (_,na,bk,_,c) -> aux ((build_impls bk na)::acc) c - |_ -> (Variable,[],List.append args (List.rev acc),[]) + | { v = GProd (na,bk,_,c) } -> aux ((build_impls bk na)::acc) c + | _ -> (Variable,[],List.append args (List.rev acc),[]) in aux [] let impls_term_list ?(args = []) = let rec aux acc = function - |GLambda (_,na,bk,_,c) -> aux ((build_impls bk na)::acc) c - |GRec (_, fix_kind, nas, args, tys, bds) -> + | { v = GLambda (na,bk,_,c) } -> aux ((build_impls bk na)::acc) c + | { v = GRec (fix_kind, nas, args, tys, bds) } -> let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in let acc' = List.fold_left (fun a (na, bk, _, _) -> (build_impls bk na)::a) acc args.(nb) in aux acc' bds.(nb) @@ -345,13 +347,13 @@ let rec check_capture ty = function | [] -> () -let locate_if_hole loc na = function - | GHole (_,_,naming,arg) -> +let locate_if_hole ?loc na = function + | { v = GHole (_,naming,arg) } -> (try match na with - | Name id -> glob_constr_of_notation_constr loc + | Name id -> glob_constr_of_notation_constr ?loc (Reserve.find_reserved_type id) | Anonymous -> raise Not_found - with Not_found -> GHole (loc, Evar_kinds.BinderType na, naming, arg)) + with Not_found -> CAst.make ?loc @@ GHole (Evar_kinds.BinderType na, naming, arg)) | x -> x let reset_hidden_inductive_implicit_test env = @@ -371,15 +373,15 @@ let push_name_env ?(global_level=false) ntnvars implargs env = function | loc,Anonymous -> if global_level then - user_err ~loc (str "Anonymous variables not allowed"); + user_err ?loc (str "Anonymous variables not allowed"); env | loc,Name id -> check_hidden_implicit_parameters id env.impls ; if Id.Map.is_empty ntnvars && Id.equal id ldots_var - then error_ldots_var ~loc; - set_var_scope loc id false env ntnvars; + then error_ldots_var ?loc; + set_var_scope ?loc id false env ntnvars; if global_level then Dumpglob.dump_definition (loc,id) true "var" - else Dumpglob.dump_binding loc id; + else Dumpglob.dump_binding ?loc id; {env with ids = Id.Set.add id env.ids; impls = Id.Map.add id implargs env.impls} let intern_generalized_binder ?(global_level=false) intern_type lvar @@ -393,11 +395,11 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar let ty' = intern_type {env with ids = ids; unb = true} ty in let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:ids ~allowed:ids' ty' in let env' = List.fold_left - (fun env (x, l) -> push_name_env ~global_level lvar (Variable,[],[],[])(*?*) env (l, Name x)) + (fun env (l, x) -> push_name_env ~global_level lvar (Variable,[],[],[])(*?*) env (l, Name x)) env fvs in let bl = List.map - (fun (id, loc) -> - (loc, (Name id, b, GHole (loc, Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None)))) + (fun (loc, id) -> + (loc, (Name id, b, CAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None)))) fvs in let na = match na with @@ -407,7 +409,7 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar let name = let id = match ty with - | CApp (_, (_, CRef (Ident (loc,id),_)), _) -> id + | { CAst.v = CApp ((_, { CAst.v = CRef (Ident (loc,id),_) } ), _) } -> id | _ -> default_non_dependent_ident in Implicit_quantifiers.make_fresh ids' (Global.env ()) id in Name name @@ -424,44 +426,45 @@ let intern_assumption intern lvar env nal bk ty = List.fold_left (fun (env, bl) (loc, na as locna) -> (push_name_env lvar impls env locna, - (loc,(na,k,locate_if_hole loc na ty))::bl)) + (Loc.tag ?loc (na,k,locate_if_hole ?loc na ty))::bl)) (env, []) nal | Generalized (b,b',t) -> let env, b = intern_generalized_binder intern_type lvar env (List.hd nal) b b' t ty in env, b -let glob_local_binder_of_extended = function - | GLocalAssum (loc,na,bk,t) -> (na,bk,None,t) - | GLocalDef (loc,na,bk,c,Some t) -> (na,bk,Some c,t) - | GLocalDef (loc,na,bk,c,None) -> - let t = GHole(loc,Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None) in +let glob_local_binder_of_extended = CAst.with_loc_val (fun ?loc -> function + | GLocalAssum (na,bk,t) -> (na,bk,None,t) + | GLocalDef (na,bk,c,Some t) -> (na,bk,Some c,t) + | GLocalDef (na,bk,c,None) -> + let t = CAst.make ?loc @@ GHole(Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None) in (na,bk,Some c,t) - | GLocalPattern (loc,_,_,_,_) -> - Loc.raise ~loc (Stream.Error "pattern with quote not allowed here.") + | GLocalPattern (_,_,_,_) -> + Loc.raise ?loc (Stream.Error "pattern with quote not allowed here.") + ) let intern_cases_pattern_fwd = ref (fun _ -> failwith "intern_cases_pattern_fwd") let intern_local_binder_aux ?(global_level=false) intern lvar (env,bl) = function | CLocalAssum(nal,bk,ty) -> let env, bl' = intern_assumption intern lvar env nal bk ty in - let bl' = List.map (fun (loc,(na,c,t)) -> GLocalAssum (loc,na,c,t)) bl' in + let bl' = List.map (fun (loc,(na,c,t)) -> CAst.make ?loc @@ GLocalAssum (na,c,t)) bl' in env, bl' @ bl | CLocalDef((loc,na as locna),def,ty) -> let term = intern env def in let ty = Option.map (intern env) ty in (push_name_env lvar (impls_term_list term) env locna, - GLocalDef (loc,na,Explicit,term,ty) :: bl) - | CLocalPattern (loc,p,ty) -> + (CAst.make ?loc @@ GLocalDef (na,Explicit,term,ty)) :: bl) + | CLocalPattern (loc,(p,ty)) -> let tyc = match ty with | Some ty -> ty - | None -> CHole(loc,None,Misctypes.IntroAnonymous,None) + | None -> CAst.make ?loc @@ CHole(None,Misctypes.IntroAnonymous,None) in let il,cp = match !intern_cases_pattern_fwd (None,env.scopes) p with | (il, [(subst,cp)]) -> if not (Id.Map.equal Id.equal subst Id.Map.empty) then - user_err ~loc (str "Unsupported nested \"as\" clause."); + user_err ?loc (str "Unsupported nested \"as\" clause."); il,cp | _ -> assert false in @@ -472,7 +475,7 @@ let intern_local_binder_aux ?(global_level=false) intern lvar (env,bl) = functio let bk = Default Explicit in let _, bl' = intern_assumption intern lvar env [na] bk tyc in let _,(_,bk,t) = List.hd bl' in - (env, GLocalPattern(loc,(cp,il),id,bk,t) :: bl) + (env, (CAst.make ?loc @@ GLocalPattern((cp,il),id,bk,t)) :: bl) let intern_generalization intern env lvar loc bk ak c = let c = intern {env with unb = true} c in @@ -494,13 +497,15 @@ let intern_generalization intern env lvar loc bk ak c = | None -> false in if pi then - (fun (id, loc') acc -> - GProd (Loc.merge loc' loc, Name id, bk, GHole (loc', Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) + (fun (loc', id) acc -> + CAst.make ?loc:(Loc.merge_opt loc' loc) @@ + GProd (Name id, bk, CAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) else - (fun (id, loc') acc -> - GLambda (Loc.merge loc' loc, Name id, bk, GHole (loc', Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) + (fun (loc', id) acc -> + CAst.make ?loc:(Loc.merge_opt loc' loc) @@ + GLambda (Name id, bk, CAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) in - List.fold_right (fun (id, loc as lid) (env, acc) -> + List.fold_right (fun (loc, id as lid) (env, acc) -> let env' = push_name_env lvar (Variable,[],[],[]) env (loc, Name id) in (env', abs lid acc)) fvs (env,c) in c' @@ -531,7 +536,7 @@ let traverse_binder (terms,_,_ as subst) avoid (renaming,env) = function try (* Binders bound in the notation are considered first-order objects *) let _,na = coerce_to_name (fst (Id.Map.find id terms)) in - (renaming,{env with ids = name_fold Id.Set.add na env.ids}), na + (renaming,{env with ids = Name.fold_right Id.Set.add na env.ids}), na with Not_found -> (* Binders not bound in the notation do not capture variables *) (* outside the notation (i.e. in the substitution) *) @@ -541,48 +546,51 @@ let traverse_binder (terms,_,_ as subst) avoid (renaming,env) = function in (renaming',env), Name id' -type letin_param = - | LPLetIn of Loc.t * (Name.t * glob_constr * glob_constr option) - | LPCases of Loc.t * (cases_pattern * Id.t list) * Id.t +type letin_param_r = + | LPLetIn of Name.t * glob_constr * glob_constr option + | LPCases of (cases_pattern * Id.t list) * Id.t +(* Unused thus fatal warning *) +(* and letin_param = letin_param_r Loc.located *) let make_letins = List.fold_right (fun a c -> match a with - | LPLetIn (loc,(na,b,t)) -> - GLetIn(loc,na,b,t,c) - | LPCases (loc,(cp,il),id) -> - let tt = (GVar(loc,id),(Name id,None)) in - GCases(loc,Misctypes.LetPatternStyle,None,[tt],[(loc,il,[cp],c)])) + | loc, LPLetIn (na,b,t) -> + CAst.make ?loc @@ GLetIn(na,b,t,c) + | loc, LPCases ((cp,il),id) -> + let tt = (CAst.make ?loc @@ GVar id, (Name id,None)) in + CAst.make ?loc @@ GCases(Misctypes.LetPatternStyle,None,[tt],[(loc,(il,[cp],c))])) let rec subordinate_letins letins = function (* binders come in reverse order; the non-let are returned in reverse order together *) (* with the subordinated let-in in writing order *) - | GLocalDef (loc,na,_,b,t)::l -> - subordinate_letins (LPLetIn (loc,(na,b,t))::letins) l - | GLocalAssum (loc,na,bk,t)::l -> + | { loc; v = GLocalDef (na,_,b,t) }::l -> + subordinate_letins ((Loc.tag ?loc @@ LPLetIn (na,b,t))::letins) l + | { loc; v = GLocalAssum (na,bk,t)}::l -> let letins',rest = subordinate_letins [] l in letins',((loc,(na,bk,t)),letins)::rest - | GLocalPattern (loc,u,id,bk,t) :: l -> - subordinate_letins (LPCases (loc,u,id)::letins) ([GLocalAssum (loc,Name id,bk,t)] @ l) + | { loc; v = GLocalPattern (u,id,bk,t)} :: l -> + subordinate_letins ((Loc.tag ?loc @@ LPCases (u,id))::letins) + ([CAst.make ?loc @@ GLocalAssum (Name id,bk,t)] @ l) | [] -> letins,[] let terms_of_binders bl = - let rec term_of_pat = function - | PatVar (loc,Name id) -> CRef (Ident (loc,id), None) - | PatVar (loc,Anonymous) -> error "Cannot turn \"_\" into a term." - | PatCstr (loc,c,l,_) -> + let rec term_of_pat pt = CAst.map_with_loc (fun ?loc -> function + | PatVar (Name id) -> CRef (Ident (loc,id), None) + | PatVar (Anonymous) -> user_err Pp.(str "Cannot turn \"_\" into a term.") + | PatCstr (c,l,_) -> let r = Qualid (loc,qualid_of_path (path_of_global (ConstructRef c))) in - let hole = CHole (loc,None,Misctypes.IntroAnonymous,None) in + let hole = CAst.make ?loc @@ CHole (None,Misctypes.IntroAnonymous,None) in let params = List.make (Inductiveops.inductive_nparams (fst c)) hole in - CAppExpl (loc,(None,r,None),params @ List.map term_of_pat l) in + CAppExpl ((None,r,None),params @ List.map term_of_pat l)) pt in let rec extract_variables = function - | GLocalAssum (loc,Name id,_,_)::l -> CRef (Ident (loc,id), None) :: extract_variables l - | GLocalDef (loc,Name id,_,_,_)::l -> extract_variables l - | GLocalDef (loc,Anonymous,_,_,_)::l - | GLocalAssum (loc,Anonymous,_,_)::l -> error "Cannot turn \"_\" into a term." - | GLocalPattern (loc,(u,_),_,_,_) :: l -> term_of_pat u :: extract_variables l + | {loc; v = GLocalAssum (Name id,_,_)}::l -> (CAst.make ?loc @@ CRef (Ident (loc,id), None)) :: extract_variables l + | {loc; v = GLocalDef (Name id,_,_,_)}::l -> extract_variables l + | {loc; v = GLocalDef (Anonymous,_,_,_)}::l + | {loc; v = GLocalAssum (Anonymous,_,_)}::l -> user_err Pp.(str "Cannot turn \"_\" into a term.") + | {loc; v = GLocalPattern ((u,_),_,_,_)}::l -> term_of_pat u :: extract_variables l | [] -> [] in extract_variables bl @@ -638,7 +646,7 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = let bindings = Id.Map.map mk_env terms in Some (Genintern.generic_substitute_notation bindings arg) in - GHole (loc, knd, naming, arg) + CAst.make ?loc @@ GHole (knd, naming, arg) | NBinderList (x,y,iter,terminator) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) @@ -656,24 +664,24 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = let a,letins = snd (Option.get binderopt) in let e = make_letins letins (aux subst' infos c') in let (loc,(na,bk,t)) = a in - GProd (loc,na,bk,t,e) + CAst.make ?loc @@ GProd (na,bk,t,e) | NLambda (Name id,NHole _,c') when option_mem_assoc id binderopt -> let a,letins = snd (Option.get binderopt) in let (loc,(na,bk,t)) = a in - GLambda (loc,na,bk,t,make_letins letins (aux subst' infos c')) + CAst.make ?loc @@ GLambda (na,bk,t,make_letins letins (aux subst' infos c')) (* Two special cases to keep binder name synchronous with BinderType *) | NProd (na,NHole(Evar_kinds.BinderType na',naming,arg),c') when Name.equal na na' -> let subinfos,na = traverse_binder subst avoid subinfos na in - let ty = GHole (loc,Evar_kinds.BinderType na,naming,arg) in - GProd (loc,na,Explicit,ty,aux subst' subinfos c') + let ty = CAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in + CAst.make ?loc @@ GProd (na,Explicit,ty,aux subst' subinfos c') | NLambda (na,NHole(Evar_kinds.BinderType na',naming,arg),c') when Name.equal na na' -> let subinfos,na = traverse_binder subst avoid subinfos na in - let ty = GHole (loc,Evar_kinds.BinderType na,naming,arg) in - GLambda (loc,na,Explicit,ty,aux subst' subinfos c') + let ty = CAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in + CAst.make ?loc @@ GLambda (na,Explicit,ty,aux subst' subinfos c') | t -> - glob_constr_of_notation_constr_with_binders loc + glob_constr_of_notation_constr_with_binders ?loc (traverse_binder subst avoid) (aux subst') subinfos t and subst_var (terms, _binderopt, _terminopt) (renaming, env) id = (* subst remembers the delimiters stack in the interpretation *) @@ -683,11 +691,12 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = intern {env with tmp_scope = scopt; scopes = subscopes @ env.scopes} a with Not_found -> + CAst.make ?loc ( try - GVar (loc, Id.Map.find id renaming) + GVar (Id.Map.find id renaming) with Not_found -> (* Happens for local notation joint with inductive/fixpoint defs *) - GVar (loc,id) + GVar id) in aux (terms,None,None) infos c let split_by_type ids = @@ -703,8 +712,8 @@ let make_subst ids l = let intern_notation intern env lvar loc ntn fullargs = let ntn,(args,argslist,bll as fullargs) = contract_notation ntn fullargs in - let ((ids,c),df) = interp_notation loc ntn (env.tmp_scope,env.scopes) in - Dumpglob.dump_notation_location (ntn_loc loc fullargs ntn) ntn df; + let ((ids,c),df) = interp_notation ?loc ntn (env.tmp_scope,env.scopes) in + Dumpglob.dump_notation_location (ntn_loc ?loc fullargs ntn) ntn df; let ids,idsl,idsbl = split_by_type ids in let terms = make_subst ids args in let termlists = make_subst idsl argslist in @@ -722,9 +731,9 @@ let string_of_ty = function | Variable -> "var" let gvar (loc, id) us = match us with -| None -> GVar (loc, id) +| None -> CAst.make ?loc @@ GVar id | Some _ -> - user_err ~loc (str "Variable " ++ pr_id id ++ + user_err ?loc (str "Variable " ++ pr_id id ++ str " cannot have a universe instance") let intern_var genv (ltacvars,ntnvars) namedctx loc id us = @@ -732,9 +741,9 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id us = try let ty,expl_impls,impls,argsc = Id.Map.find id genv.impls in let expl_impls = List.map - (fun id -> CRef (Ident (loc,id),None), Some (loc,ExplByName id)) expl_impls in + (fun id -> CAst.make ?loc @@ CRef (Ident (loc,id),None), Some (loc,ExplByName id)) expl_impls in let tys = string_of_ty ty in - Dumpglob.dump_reference loc "<>" (Id.to_string id) tys; + Dumpglob.dump_reference ?loc "<>" (Id.to_string id) tys; gvar (loc,id) us, make_implicits_list impls, argsc, expl_impls with Not_found -> (* Is [id] bound in current term or is an ltac var bound to constr *) @@ -744,15 +753,15 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id us = (* Is [id] a notation variable *) else if Id.Map.mem id ntnvars then - (set_var_scope loc id true genv ntnvars; gvar (loc,id) us, [], [], []) + (set_var_scope ?loc id true genv ntnvars; gvar (loc,id) us, [], [], []) (* Is [id] the special variable for recursive notations *) else if Id.equal id ldots_var then if Id.Map.is_empty ntnvars - then error_ldots_var ~loc + then error_ldots_var ?loc else gvar (loc,id) us, [], [], [] else if Id.Set.mem id ltacvars.ltac_bound then (* Is [id] bound to a free name in ltac (this is an ltac error message) *) - user_err ~loc ~hdr:"intern_var" + user_err ?loc ~hdr:"intern_var" (str "variable " ++ pr_id id ++ str " should be bound to a term.") else (* Is [id] a goal or section variable *) @@ -763,29 +772,29 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id us = let ref = VarRef id in let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in - Dumpglob.dump_reference loc "<>" (string_of_qualid (Decls.variable_secpath id)) "var"; - GRef (loc, ref, us), impls, scopes, [] + Dumpglob.dump_reference ?loc "<>" (string_of_qualid (Decls.variable_secpath id)) "var"; + CAst.make ?loc @@ GRef (ref, us), impls, scopes, [] with e when CErrors.noncritical e -> (* [id] a goal variable *) gvar (loc,id) us, [], [], [] let find_appl_head_data c = - match c with - | GRef (loc,ref,_) as x -> + match c.v with + | GRef (ref,_) -> let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in - x, impls, scopes, [] - | GApp (_,GRef (_,ref,_),l) as x + c, impls, scopes, [] + | GApp ({ v = GRef (ref,_) },l) when l != [] && Flags.version_strictly_greater Flags.V8_2 -> let n = List.length l in let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in - x, List.map (drop_first_implicits n) impls, + c, List.map (drop_first_implicits n) impls, List.skipn_at_least n scopes,[] - | x -> x,[],[],[] + | _ -> c,[],[],[] -let error_not_enough_arguments loc = - user_err ~loc (str "Abbreviation is not applied enough.") +let error_not_enough_arguments ?loc = + user_err ?loc (str "Abbreviation is not applied enough.") let check_no_explicitation l = let is_unset (a, b) = match b with None -> false | Some _ -> true in @@ -794,11 +803,11 @@ let check_no_explicitation l = | [] -> () | (_, None) :: _ -> assert false | (_, Some (loc, _)) :: _ -> - user_err ~loc (str"Unexpected explicitation of the argument of an abbreviation.") + user_err ?loc (str"Unexpected explicitation of the argument of an abbreviation.") let dump_extended_global loc = function - | TrueGlobal ref -> (*feedback_global loc ref;*) Dumpglob.add_glob loc ref - | SynDef sp -> Dumpglob.add_glob_kn loc sp + | TrueGlobal ref -> (*feedback_global loc ref;*) Dumpglob.add_glob ?loc ref + | SynDef sp -> Dumpglob.add_glob_kn ?loc sp let intern_extended_global_of_qualid (loc,qid) = let r = Nametab.locate_extended qid in dump_extended_global loc r; r @@ -807,18 +816,18 @@ let intern_reference ref = let qid = qualid_of_reference ref in let r = try intern_extended_global_of_qualid qid - with Not_found -> error_global_not_found ~loc:(fst qid) (snd qid) + with Not_found -> error_global_not_found ?loc:(fst qid) (snd qid) in Smartlocate.global_of_extended_global r (* Is it a global reference or a syntactic definition? *) let intern_qualid loc qid intern env lvar us args = match intern_extended_global_of_qualid (loc,qid) with - | TrueGlobal ref -> GRef (loc, ref, us), true, args + | TrueGlobal ref -> (CAst.make ?loc @@ GRef (ref, us)), true, args | SynDef sp -> let (ids,c) = Syntax_def.search_syntactic_definition sp in let nids = List.length ids in - if List.length args < nids then error_not_enough_arguments loc; + if List.length args < nids then error_not_enough_arguments ?loc; let args1,args2 = List.chop nids args in check_no_explicitation args1; let terms = make_subst ids (List.map fst args1) in @@ -828,11 +837,11 @@ let intern_qualid loc qid intern env lvar us args = let c = instantiate_notation_constr loc intern lvar subst infos c in let c = match us, c with | None, _ -> c - | Some _, GRef (loc, ref, None) -> GRef (loc, ref, us) - | Some _, GApp (loc, GRef (loc', ref, None), arg) -> - GApp (loc, GRef (loc', ref, us), arg) + | Some _, { loc; v = GRef (ref, None) } -> CAst.make ?loc @@ GRef (ref, us) + | Some _, { loc; v = GApp ({ loc = loc' ; v = GRef (ref, None) }, arg) } -> + CAst.make ?loc @@ GApp (CAst.make ?loc:loc' @@ GRef (ref, us), arg) | Some _, _ -> - user_err ~loc (str "Notation " ++ pr_qualid qid + user_err ?loc (str "Notation " ++ pr_qualid qid ++ str " cannot have a universe instance," ++ str " its expanded head does not start with a reference") in @@ -841,14 +850,14 @@ let intern_qualid loc qid intern env lvar us args = (* Rule out section vars since these should have been found by intern_var *) let intern_non_secvar_qualid loc qid intern env lvar us args = match intern_qualid loc qid intern env lvar us args with - | GRef (_, VarRef _, _),_,_ -> raise Not_found + | { v = GRef (VarRef _, _) },_,_ -> raise Not_found | r -> r let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args = function | Qualid (loc, qid) -> let r,projapp,args2 = try intern_qualid loc qid intern env ntnvars us args - with Not_found -> error_global_not_found ~loc qid + with Not_found -> error_global_not_found ?loc qid in let x, imp, scopes, l = find_appl_head_data r in (x,imp,scopes,l), args2 @@ -864,11 +873,11 @@ let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args = (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then (gvar (loc,id) us, [], [], []), args - else error_global_not_found ~loc qid + else error_global_not_found ?loc qid let interp_reference vars r = let (r,_,_,_),_ = - intern_applied_reference (fun _ -> error_not_enough_arguments Loc.ghost) + intern_applied_reference (fun _ -> error_not_enough_arguments ?loc:None) {ids = Id.Set.empty; unb = false ; tmp_scope = None; scopes = []; impls = empty_internalization_env} [] (vars, Id.Map.empty) None [] r @@ -878,19 +887,14 @@ let interp_reference vars r = (** {5 Cases } *) (** Private internalization patterns *) -type raw_cases_pattern_expr = - | RCPatAlias of Loc.t * raw_cases_pattern_expr * Id.t - | RCPatCstr of Loc.t * Globnames.global_reference +type raw_cases_pattern_expr_r = + | RCPatAlias of raw_cases_pattern_expr * Id.t + | RCPatCstr of Globnames.global_reference * raw_cases_pattern_expr list * raw_cases_pattern_expr list (** [RCPatCstr (loc, c, l1, l2)] represents ((@c l1) l2) *) - | RCPatAtom of Loc.t * Id.t option - | RCPatOr of Loc.t * raw_cases_pattern_expr list - -let raw_cases_pattern_expr_loc = function - | RCPatAlias (loc,_,_) -> loc - | RCPatCstr (loc,_,_,_) -> loc - | RCPatAtom (loc,_) -> loc - | RCPatOr (loc,_) -> loc + | RCPatAtom of Id.t option + | RCPatOr of raw_cases_pattern_expr list +and raw_cases_pattern_expr = raw_cases_pattern_expr_r CAst.t (** {6 Elementary bricks } *) let apply_scope_env env = function @@ -930,7 +934,7 @@ let rec has_duplicate = function | x::l -> if Id.List.mem x l then (Some x) else has_duplicate l let loc_of_lhs lhs = - Loc.merge (fst (List.hd lhs)) (fst (List.last lhs)) + Loc.merge_opt (fst (List.hd lhs)) (fst (List.last lhs)) let check_linearity lhs ids = match has_duplicate ids with @@ -946,7 +950,7 @@ let check_number_of_pattern loc n l = let check_or_pat_variables loc ids idsl = if List.exists (fun ids' -> not (List.eq_set Id.equal ids ids')) idsl then - user_err ~loc (str + user_err ?loc (str "The components of this disjunctive pattern must bind the same variables.") (** Use only when params were NOT asked to the user. @@ -955,7 +959,7 @@ let check_constructor_length env loc cstr len_pl pl0 = let n = len_pl + List.length pl0 in if Int.equal n (Inductiveops.constructor_nallargs cstr) then false else (Int.equal n (Inductiveops.constructor_nalldecls cstr) || - (error_wrong_numarg_constructor ~loc env cstr + (error_wrong_numarg_constructor ?loc env cstr (Inductiveops.constructor_nrealargs cstr))) let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 = @@ -969,10 +973,10 @@ let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 else Int.equal args_len nargs_with_letin || (fst (fail (nargs - List.length impl_list + i)))) ,l) |imp::q as il,[] -> if is_status_implicit imp && maximal_insertion_of imp - then let (b,out) = aux i (q,[]) in (b,RCPatAtom(Loc.ghost,None)::out) + then let (b,out) = aux i (q,[]) in (b,(CAst.make @@ RCPatAtom None)::out) else fail (remaining_args (len_pl1+i) il) |imp::q,(hh::tt as l) -> if is_status_implicit imp - then let (b,out) = aux i (q,l) in (b,RCPatAtom(Loc.ghost,None)::out) + then let (b,out) = aux i (q,l) in (b,(CAst.make @@ RCPatAtom(None))::out) else let (b,out) = aux (succ i) (q,tt) in (b,hh::out) in aux 0 (impl_list,pl2) @@ -980,14 +984,14 @@ let add_implicits_check_constructor_length env loc c len_pl1 pl2 = let nargs = Inductiveops.constructor_nallargs c in let nargs' = Inductiveops.constructor_nalldecls c in let impls_st = implicits_of_global (ConstructRef c) in - add_implicits_check_length (error_wrong_numarg_constructor ~loc env c) + add_implicits_check_length (error_wrong_numarg_constructor ?loc env c) nargs nargs' impls_st len_pl1 pl2 let add_implicits_check_ind_length env loc c len_pl1 pl2 = let nallargs = inductive_nallargs_env env c in let nalldecls = inductive_nalldecls_env env c in let impls_st = implicits_of_global (IndRef c) in - add_implicits_check_length (error_wrong_numarg_inductive ~loc env c) + add_implicits_check_length (error_wrong_numarg_inductive ?loc env c) nallargs nalldecls impls_st len_pl1 pl2 (** Do not raise NotEnoughArguments thanks to preconditions*) @@ -997,8 +1001,8 @@ let chop_params_pattern loc ind args with_letin = else Inductiveops.inductive_nparams ind in assert (nparams <= List.length args); let params,args = List.chop nparams args in - List.iter (function PatVar(_,Anonymous) -> () - | PatVar (loc',_) | PatCstr(loc',_,_,_) -> error_parameter_not_implicit ~loc:loc') params; + List.iter (function { v = PatVar Anonymous } -> () + | { loc; v = PatVar _ } | { loc; v = PatCstr(_,_,_) } -> error_parameter_not_implicit ?loc) params; args let find_constructor loc add_params ref = @@ -1006,10 +1010,10 @@ let find_constructor loc add_params ref = | ConstructRef cstr -> cstr | IndRef _ -> let error = str "There is an inductive name deep in a \"in\" clause." in - user_err ~loc ~hdr:"find_constructor" error + user_err ?loc ~hdr:"find_constructor" error | ConstRef _ | VarRef _ -> let error = str "This reference is not a constructor." in - user_err ~loc ~hdr:"find_constructor" error + user_err ?loc ~hdr:"find_constructor" error in cstr, match add_params with | Some nb_args -> @@ -1018,7 +1022,7 @@ let find_constructor loc add_params ref = then Inductiveops.inductive_nparamdecls ind else Inductiveops.inductive_nparams ind in - List.make nb ([], [(Id.Map.empty, PatVar(Loc.ghost,Anonymous))]) + List.make nb ([], [(Id.Map.empty, CAst.make @@ PatVar Anonymous)]) | None -> [] let find_pattern_variable = function @@ -1031,7 +1035,7 @@ let check_duplicate loc fields = match dups with | [] -> () | (r, _) :: _ -> - user_err ~loc (str "This record defines several times the field " ++ + user_err ?loc (str "This record defines several times the field " ++ pr_reference r ++ str ".") (** [sort_fields ~complete loc fields completer] expects a list @@ -1056,7 +1060,7 @@ let sort_fields ~complete loc fields completer = let gr = global_reference_of_reference first_field_ref in (gr, Recordops.find_projection gr) with Not_found -> - user_err ~loc:(loc_of_reference first_field_ref) ~hdr:"intern" + user_err ?loc:(loc_of_reference first_field_ref) ~hdr:"intern" (pr_reference first_field_ref ++ str": Not a projection") in (* the number of parameters *) @@ -1077,8 +1081,8 @@ let sort_fields ~complete loc fields completer = let rec build_proj_list projs proj_kinds idx ~acc_first_idx acc = match projs with | [] -> (idx, acc_first_idx, acc) - | (Some name) :: projs -> - let field_glob_ref = ConstRef name in + | (Some field_glob_id) :: projs -> + let field_glob_ref = ConstRef field_glob_id in let first_field = eq_gr field_glob_ref first_field_glob_ref in begin match proj_kinds with | [] -> anomaly (Pp.str "Number of projections mismatch") @@ -1087,7 +1091,7 @@ let sort_fields ~complete loc fields completer = by a let-in in the record declaration (its value is fixed from other fields). *) if first_field && not regular && complete then - user_err ~loc (str "No local fields allowed in a record construction.") + user_err ?loc (str "No local fields allowed in a record construction.") else if first_field then build_proj_list projs proj_kinds (idx+1) ~acc_first_idx:idx acc else if not regular && complete then @@ -1095,12 +1099,12 @@ let sort_fields ~complete loc fields completer = build_proj_list projs proj_kinds idx ~acc_first_idx acc else build_proj_list projs proj_kinds (idx+1) ~acc_first_idx - ((idx, field_glob_ref) :: acc) + ((idx, field_glob_id) :: acc) end | None :: projs -> if complete then (* we don't want anonymous fields *) - user_err ~loc (str "This record contains anonymous fields.") + user_err ?loc (str "This record contains anonymous fields.") else (* anonymous arguments don't appear in proj_kinds *) build_proj_list projs proj_kinds (idx+1) ~acc_first_idx acc @@ -1114,13 +1118,13 @@ let sort_fields ~complete loc fields completer = | (field_ref, field_value) :: fields -> let field_glob_ref = try global_reference_of_reference field_ref with Not_found -> - user_err ~loc:(loc_of_reference field_ref) ~hdr:"intern" + user_err ?loc:(loc_of_reference field_ref) ~hdr:"intern" (str "The field \"" ++ pr_reference field_ref ++ str "\" does not exist.") in let remaining_projs, (field_index, _) = - let the_proj (idx, glob_ref) = eq_gr field_glob_ref glob_ref in + let the_proj (idx, glob_id) = eq_gr field_glob_ref (ConstRef glob_id) in try CList.extract_first the_proj remaining_projs with Not_found -> - user_err ~loc + user_err ?loc (str "This record contains fields of different records.") in index_fields fields remaining_projs ((field_index, field_value) :: acc) @@ -1186,14 +1190,14 @@ let product_of_cases_patterns aliases idspl = List.map (fun (subst',ptail) -> (merge_subst subst subst',p::ptail)) ptaill) pl))) idspl (aliases.alias_ids,[aliases.alias_map,[]]) -let rec subst_pat_iterator y t p = match p with - | RCPatAtom (_,id) -> - begin match id with Some x when Id.equal x y -> t | _ -> p end - | RCPatCstr (loc,id,l1,l2) -> - RCPatCstr (loc,id,List.map (subst_pat_iterator y t) l1, +let rec subst_pat_iterator y t = CAst.(map (function + | RCPatAtom id as p -> + begin match id with Some x when Id.equal x y -> t.v | _ -> p end + | RCPatCstr (id,l1,l2) -> + RCPatCstr (id,List.map (subst_pat_iterator y t) l1, List.map (subst_pat_iterator y t) l2) - | RCPatAlias (l,p,a) -> RCPatAlias (l,subst_pat_iterator y t p,a) - | RCPatOr (l,pl) -> RCPatOr (l,List.map (subst_pat_iterator y t) pl) + | RCPatAlias (p,a) -> RCPatAlias (subst_pat_iterator y t p,a) + | RCPatOr pl -> RCPatOr (List.map (subst_pat_iterator y t) pl))) let drop_notations_pattern looked_for = (* At toplevel, Constructors and Inductives are accepted, in recursive calls @@ -1203,18 +1207,18 @@ let drop_notations_pattern looked_for = if top then looked_for g else match g with ConstructRef _ -> () | _ -> raise Not_found with Not_found -> - error_invalid_pattern_notation ~loc () + error_invalid_pattern_notation ?loc () in let test_kind top = if top then looked_for else function ConstructRef _ -> () | _ -> raise Not_found in (** [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *) - let rec rcp_of_glob = function - | GVar (loc,id) -> RCPatAtom (loc,Some id) - | GHole (loc,_,_,_) -> RCPatAtom (loc,None) - | GRef (loc,g,_) -> RCPatCstr (loc, g,[],[]) - | GApp (loc,GRef (_,g,_),l) -> RCPatCstr (loc, g, List.map rcp_of_glob l,[]) - | _ -> CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr ") + let rec rcp_of_glob x = CAst.(map (function + | GVar id -> RCPatAtom (Some id) + | GHole (_,_,_) -> RCPatAtom (None) + | GRef (g,_) -> RCPatCstr (g,[],[]) + | GApp ({ v = GRef (g,_) }, l) -> RCPatCstr (g, List.map rcp_of_glob l,[]) + | _ -> CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr "))) x in let rec drop_syndef top scopes re pats = let (loc,qid) = qualid_of_reference re in @@ -1237,7 +1241,7 @@ let drop_notations_pattern looked_for = (* Convention: do not deactivate implicit arguments and scopes for further arguments *) test_kind top g; let nvars = List.length vars in - if List.length pats < nvars then error_not_enough_arguments loc; + if List.length pats < nvars then error_not_enough_arguments ?loc; let pats1,pats2 = List.chop nvars pats in let subst = make_subst vars pats1 in let idspl1 = List.map (in_not false loc scopes (subst, Id.Map.empty) []) args in @@ -1246,73 +1250,75 @@ let drop_notations_pattern looked_for = | _ -> raise Not_found) | TrueGlobal g -> test_kind top g; - Dumpglob.add_glob loc g; + Dumpglob.add_glob ?loc g; let (_,argscs) = find_remaining_scopes [] pats g in Some (g,[],List.map2 (fun x -> in_pat false (x,snd scopes)) argscs pats) with Not_found -> None - and in_pat top scopes = function - | CPatAlias (loc, p, id) -> RCPatAlias (loc, in_pat top scopes p, id) - | CPatRecord (loc, l) -> + and in_pat top scopes pt = + let open CAst in + let loc = pt.loc in + match pt.v with + | CPatAlias (p, id) -> CAst.make ?loc @@ RCPatAlias (in_pat top scopes p, id) + | CPatRecord l -> let sorted_fields = - sort_fields ~complete:false loc l (fun _idx -> (CPatAtom (loc, None))) in + sort_fields ~complete:false loc l (fun _idx -> CAst.make ?loc @@ CPatAtom None) in begin match sorted_fields with - | None -> RCPatAtom (loc, None) + | None -> CAst.make ?loc @@ RCPatAtom None | Some (n, head, pl) -> let pl = if !asymmetric_patterns then pl else - let pars = List.make n (CPatAtom (loc, None)) in + let pars = List.make n (CAst.make ?loc @@ CPatAtom None) in List.rev_append pars pl in match drop_syndef top scopes head pl with - |Some (a,b,c) -> RCPatCstr(loc, a, b, c) - |None -> raise (InternalizationError (loc,NotAConstructor head)) + | Some (a,b,c) -> CAst.make ?loc @@ RCPatCstr(a, b, c) + | None -> raise (InternalizationError (loc,NotAConstructor head)) end - | CPatCstr (loc, head, None, pl) -> + | CPatCstr (head, None, pl) -> begin match drop_syndef top scopes head pl with - | Some (a,b,c) -> RCPatCstr(loc, a, b, c) + | Some (a,b,c) -> CAst.make ?loc @@ RCPatCstr(a, b, c) | None -> raise (InternalizationError (loc,NotAConstructor head)) end - | CPatCstr (loc, r, Some expl_pl, pl) -> + | CPatCstr (r, Some expl_pl, pl) -> let g = try locate (snd (qualid_of_reference r)) with Not_found -> raise (InternalizationError (loc,NotAConstructor r)) in if expl_pl == [] then (* Convention: (@r) deactivates all further implicit arguments and scopes *) - RCPatCstr (loc, g, List.map (in_pat false scopes) pl, []) + CAst.make ?loc @@ RCPatCstr (g, List.map (in_pat false scopes) pl, []) else (* Convention: (@r expl_pl) deactivates implicit arguments in expl_pl and in pl *) (* but not scopes in expl_pl *) let (argscs1,_) = find_remaining_scopes expl_pl pl g in - RCPatCstr (loc, g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) pl, []) - | CPatNotation (loc,"- _",([CPatPrim(_,Numeral p)],[]),[]) - when Bigint.is_strictly_pos p -> - let (pat, _df) = Notation.interp_prim_token_cases_pattern_expr loc (ensure_kind false loc) (Numeral (Bigint.neg p)) scopes in + CAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) pl, []) + | CPatNotation ("- _",([{ CAst.v = CPatPrim(Numeral p) }],[]),[]) + when Bigint.is_strictly_pos p -> + let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Numeral (Bigint.neg p)) scopes in rcp_of_glob pat - | CPatNotation (_,"( _ )",([a],[]),[]) -> + | CPatNotation ("( _ )",([a],[]),[]) -> in_pat top scopes a - | CPatNotation (loc, ntn, fullargs,extrargs) -> + | CPatNotation (ntn, fullargs,extrargs) -> let ntn,(args,argsl as fullargs) = contract_pat_notation ntn fullargs in - let ((ids',c),df) = Notation.interp_notation loc ntn scopes in + let ((ids',c),df) = Notation.interp_notation ?loc ntn scopes in let (ids',idsl',_) = split_by_type ids' in - Dumpglob.dump_notation_location (patntn_loc loc fullargs ntn) ntn df; + Dumpglob.dump_notation_location (patntn_loc ?loc fullargs ntn) ntn df; let substlist = make_subst idsl' argsl in let subst = make_subst ids' args in in_not top loc scopes (subst,substlist) extrargs c - | CPatDelimiters (loc, key, e) -> - in_pat top (None,find_delimiters_scope loc key::snd scopes) e - | CPatPrim (loc,p) -> - let (pat, _df) = Notation.interp_prim_token_cases_pattern_expr loc (test_kind false) p scopes in + | CPatDelimiters (key, e) -> + in_pat top (None,find_delimiters_scope ?loc key::snd scopes) e + | CPatPrim p -> + let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (test_kind false) p scopes in rcp_of_glob pat - | CPatAtom (loc, Some id) -> + | CPatAtom Some id -> begin match drop_syndef top scopes id [] with - |Some (a,b,c) -> RCPatCstr (loc, a, b, c) - |None -> RCPatAtom (loc, Some (find_pattern_variable id)) + | Some (a,b,c) -> CAst.make ?loc @@ RCPatCstr (a, b, c) + | None -> CAst.make ?loc @@ RCPatAtom (Some (find_pattern_variable id)) end - | CPatAtom (loc,None) -> RCPatAtom (loc,None) - | CPatOr (loc, pl) -> - RCPatOr (loc,List.map (in_pat top scopes) pl) - | CPatCast (loc,_,_) -> + | CPatAtom None -> CAst.make ?loc @@ RCPatAtom None + | CPatOr pl -> CAst.make ?loc @@ RCPatOr (List.map (in_pat top scopes) pl) + | CPatCast (_,_) -> (* We raise an error if the pattern contains a cast, due to current restrictions on casts in patterns. Cast in patterns are supportted only in local binders and only at top @@ -1325,7 +1331,7 @@ let drop_notations_pattern looked_for = lambdas in the encoding of match in constr. This check is here and not in the parser because it would require duplicating the levels of the [pattern] rule. *) - CErrors.user_err ~loc ~hdr:"drop_notations_pattern" + CErrors.user_err ?loc ~hdr:"drop_notations_pattern" (Pp.strbrk "Casts are not supported in this pattern.") and in_pat_sc scopes x = in_pat false (x,snd scopes) and in_not top loc scopes (subst,substlist as fullsubst) args = function @@ -1338,21 +1344,21 @@ let drop_notations_pattern looked_for = let (a,(scopt,subscopes)) = Id.Map.find id subst in in_pat top (scopt,subscopes@snd scopes) a with Not_found -> - if Id.equal id ldots_var then RCPatAtom (loc,Some id) else + if Id.equal id ldots_var then CAst.make ?loc @@ RCPatAtom (Some id) else anomaly (str "Unbound pattern notation variable: " ++ Id.print id) end | NRef g -> ensure_kind top loc g; let (_,argscs) = find_remaining_scopes [] args g in - RCPatCstr (loc, g, [], List.map2 (in_pat_sc scopes) argscs args) + CAst.make ?loc @@ RCPatCstr (g, [], List.map2 (in_pat_sc scopes) argscs args) | NApp (NRef g,pl) -> ensure_kind top loc g; let (argscs1,argscs2) = find_remaining_scopes pl args g in - RCPatCstr (loc, g, + CAst.make ?loc @@ RCPatCstr (g, List.map2 (fun x -> in_not false loc (x,snd scopes) fullsubst []) argscs1 pl @ List.map (in_pat false scopes) args, []) | NList (x,y,iter,terminator,lassoc) -> - if not (List.is_empty args) then user_err ~loc + if not (List.is_empty args) then user_err ?loc (strbrk "Application of arguments to a recursive notation not supported in patterns."); (try (* All elements of the list are in scopes (scopt,subscopes) *) @@ -1367,8 +1373,8 @@ let drop_notations_pattern looked_for = anomaly (Pp.str "Inconsistent substitution of recursive notation")) | NHole _ -> let () = assert (List.is_empty args) in - RCPatAtom (loc, None) - | t -> error_invalid_pattern_notation ~loc () + CAst.make ?loc @@ RCPatAtom None + | t -> error_invalid_pattern_notation ?loc () in in_pat true let rec intern_pat genv aliases pat = @@ -1376,13 +1382,14 @@ let rec intern_pat genv aliases pat = let idslpl2 = List.map (intern_pat genv empty_alias) pl2 in let (ids',pll) = product_of_cases_patterns aliases (idslpl1@idslpl2) in let pl' = List.map (fun (asubst,pl) -> - (asubst, PatCstr (loc,c,chop_params_pattern loc (fst c) pl with_letin,alias_of aliases))) pll in + (asubst, CAst.make ?loc @@ PatCstr (c,chop_params_pattern loc (fst c) pl with_letin,alias_of aliases))) pll in ids',pl' in - match pat with - | RCPatAlias (loc, p, id) -> + let loc = CAst.(pat.loc) in + match CAst.(pat.v) with + | RCPatAlias (p, id) -> let aliases' = merge_aliases aliases id in intern_pat genv aliases' p - | RCPatCstr (loc, head, expl_pl, pl) -> + | RCPatCstr (head, expl_pl, pl) -> if !asymmetric_patterns then let len = if List.is_empty expl_pl then Some (List.length pl) else None in let c,idslpl1 = find_constructor loc len head in @@ -1394,13 +1401,13 @@ let rec intern_pat genv aliases pat = let with_letin, pl2 = add_implicits_check_constructor_length genv loc c (List.length idslpl1 + List.length expl_pl) pl in intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl2) - | RCPatAtom (loc, Some id) -> + | RCPatAtom (Some id) -> let aliases = merge_aliases aliases id in - (aliases.alias_ids,[aliases.alias_map, PatVar (loc, alias_of aliases)]) - | RCPatAtom (loc, None) -> + (aliases.alias_ids,[aliases.alias_map, CAst.make ?loc @@ PatVar (alias_of aliases)]) + | RCPatAtom (None) -> let { alias_ids = ids; alias_map = asubst; } = aliases in - (ids, [asubst, PatVar (loc, alias_of aliases)]) - | RCPatOr (loc, pl) -> + (ids, [asubst, CAst.make ?loc @@ PatVar (alias_of aliases)]) + | RCPatOr pl -> assert (not (List.is_empty pl)); let pl' = List.map (intern_pat genv aliases) pl in let (idsl,pl') = List.split pl' in @@ -1420,11 +1427,12 @@ let intern_ind_pattern genv scopes pat = let no_not = try drop_notations_pattern (function (IndRef _ | ConstructRef _) -> () | _ -> raise Not_found) scopes pat - with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type ~loc + with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type ?loc in - match no_not with - | RCPatCstr (loc, head, expl_pl, pl) -> - let c = (function IndRef ind -> ind | _ -> error_bad_inductive_type ~loc) head in + let loc = no_not.CAst.loc in + match no_not.CAst.v with + | RCPatCstr (head, expl_pl, pl) -> + let c = (function IndRef ind -> ind | _ -> error_bad_inductive_type ?loc) head in let with_letin, pl2 = add_implicits_check_ind_length genv loc c (List.length expl_pl) pl in let idslpl1 = List.rev_map (intern_pat genv empty_alias) expl_pl in @@ -1432,8 +1440,8 @@ let intern_ind_pattern genv scopes pat = (with_letin, match product_of_cases_patterns empty_alias (List.rev_append idslpl1 idslpl2) with | _,[_,pl] -> (c,chop_params_pattern loc c pl with_letin) - | _ -> error_bad_inductive_type ~loc) - | x -> error_bad_inductive_type ~loc:(raw_cases_pattern_expr_loc x) + | _ -> error_bad_inductive_type ?loc) + | x -> error_bad_inductive_type ?loc (**********************************************************************) (* Utilities for application *) @@ -1454,8 +1462,8 @@ let get_implicit_name n imps = Some (Impargs.name_of_implicit (List.nth imps (n-1))) let set_hole_implicit i b = function - | GRef (loc,r,_) | GApp (_,GRef (loc,r,_),_) -> (loc,Evar_kinds.ImplicitArg (r,i,b),Misctypes.IntroAnonymous,None) - | GVar (loc,id) -> (loc,Evar_kinds.ImplicitArg (VarRef id,i,b),Misctypes.IntroAnonymous,None) + | {loc; v = GRef (r,_) } | { v = GApp ({loc; v = GRef (r,_)},_) } -> Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),Misctypes.IntroAnonymous,None) + | {loc; v = GVar id } -> Loc.tag ?loc (Evar_kinds.ImplicitArg (VarRef id,i,b),Misctypes.IntroAnonymous,None) | _ -> anomaly (Pp.str "Only refs have implicits") let exists_implicit_name id = @@ -1472,10 +1480,10 @@ let extract_explicit_arg imps args = let id = match pos with | ExplByName id -> if not (exists_implicit_name id imps) then - user_err ~loc + user_err ?loc (str "Wrong argument name: " ++ pr_id id ++ str "."); if Id.Map.mem id eargs then - user_err ~loc (str "Argument name " ++ pr_id id + user_err ?loc (str "Argument name " ++ pr_id id ++ str " occurs more than once."); id | ExplByPos (p,_id) -> @@ -1485,11 +1493,11 @@ let extract_explicit_arg imps args = if not (is_status_implicit imp) then failwith "imp"; name_of_implicit imp with Failure _ (* "nth" | "imp" *) -> - user_err ~loc + user_err ?loc (str"Wrong argument position: " ++ int p ++ str ".") in if Id.Map.mem id eargs then - user_err ~loc (str"Argument at position " ++ int p ++ + user_err ?loc (str"Argument at position " ++ int p ++ str " is mentioned more than once."); id in (Id.Map.add id (loc, a) eargs, rargs) @@ -1499,15 +1507,15 @@ let extract_explicit_arg imps args = (* Main loop *) let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = - let rec intern env = function - | CRef (ref,us) as x -> + let rec intern env = CAst.with_loc_val (fun ?loc -> function + | CRef (ref,us) -> let (c,imp,subscopes,l),_ = - intern_applied_reference intern env (Environ.named_context globalenv) - lvar us [] ref + intern_applied_reference intern env (Environ.named_context globalenv) + lvar us [] ref in - apply_impargs c env imp subscopes l (constr_loc x) + apply_impargs c env imp subscopes l loc - | CFix (loc, (locid,iddef), dl) -> + | CFix ((locid,iddef), dl) -> let lf = List.map (fun ((_, id),_,_,_,_) -> id) dl in let dl = Array.of_list dl in let n = @@ -1521,7 +1529,9 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = let before, after = split_at_annot bl n in let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in let ro = f (intern env') in - let n' = Option.map (fun _ -> List.count (function GLocalAssum _ -> true | _ -> false (* remove let-ins *)) rbefore) n in + let n' = Option.map (fun _ -> List.count (function | { v = GLocalAssum _ } -> true + | _ -> false (* remove let-ins *)) + rbefore) n in n', ro, List.fold_left intern_local_binder (env',rbefore) after in let n, ro, (env',rbl) = @@ -1540,15 +1550,16 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = let (_,bli,tyi,_) = idl_temp.(i) in let fix_args = (List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli) in push_name_env ntnvars (impls_type_list ~args:fix_args tyi) - en (Loc.ghost, Name name)) 0 env' lf in + en (Loc.tag @@ Name name)) 0 env' lf in (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in - GRec (loc,GFix + CAst.make ?loc @@ + GRec (GFix (Array.map (fun (ro,_,_,_) -> ro) idl,n), Array.of_list lf, Array.map (fun (_,bl,_,_) -> bl) idl, Array.map (fun (_,_,ty,_) -> ty) idl, Array.map (fun (_,_,_,bd) -> bd) idl) - | CCoFix (loc, (locid,iddef), dl) -> + | CCoFix ((locid,iddef), dl) -> let lf = List.map (fun ((_, id),_,_,_) -> id) dl in let dl = Array.of_list dl in let n = @@ -1566,87 +1577,90 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = let (bli,tyi,_) = idl_tmp.(i) in let cofix_args = List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli in push_name_env ntnvars (impls_type_list ~args:cofix_args tyi) - en (Loc.ghost, Name name)) 0 env' lf in + en (Loc.tag @@ Name name)) 0 env' lf in (b,c,intern {env'' with tmp_scope = None} bd)) dl idl_tmp in - GRec (loc,GCoFix n, + CAst.make ?loc @@ + GRec (GCoFix n, Array.of_list lf, Array.map (fun (bl,_,_) -> bl) idl, Array.map (fun (_,ty,_) -> ty) idl, Array.map (fun (_,_,bd) -> bd) idl) - | CProdN (loc,[],c2) -> + | CProdN ([],c2) -> intern_type env c2 - | CProdN (loc,(nal,bk,ty)::bll,c2) -> - iterate_prod loc env bk ty (CProdN (loc, bll, c2)) nal - | CLambdaN (loc,[],c2) -> + | CProdN ((nal,bk,ty)::bll,c2) -> + iterate_prod ?loc env bk ty (CAst.make ?loc @@ CProdN (bll, c2)) nal + | CLambdaN ([],c2) -> intern env c2 - | CLambdaN (loc,(nal,bk,ty)::bll,c2) -> - iterate_lam loc (reset_tmp_scope env) bk ty (CLambdaN (loc, bll, c2)) nal - | CLetIn (loc,na,c1,t,c2) -> + | CLambdaN ((nal,bk,ty)::bll,c2) -> + iterate_lam loc (reset_tmp_scope env) bk ty (CAst.make ?loc @@ CLambdaN (bll, c2)) nal + | CLetIn (na,c1,t,c2) -> let inc1 = intern (reset_tmp_scope env) c1 in let int = Option.map (intern_type env) t in - GLetIn (loc, snd na, inc1, int, + CAst.make ?loc @@ + GLetIn (snd na, inc1, int, intern (push_name_env ntnvars (impls_term_list inc1) env na) c2) - | CNotation (loc,"- _",([CPrim (_,Numeral p)],[],[])) + | CNotation ("- _",([{ CAst.v = CPrim (Numeral p) }],[],[])) when Bigint.is_strictly_pos p -> - intern env (CPrim (loc,Numeral (Bigint.neg p))) - | CNotation (_,"( _ )",([a],[],[])) -> intern env a - | CNotation (loc,ntn,args) -> + intern env (CAst.make ?loc @@ CPrim (Numeral (Bigint.neg p))) + | CNotation ("( _ )",([a],[],[])) -> intern env a + | CNotation (ntn,args) -> intern_notation intern env ntnvars loc ntn args - | CGeneralization (loc,b,a,c) -> + | CGeneralization (b,a,c) -> intern_generalization intern env ntnvars loc b a c - | CPrim (loc, p) -> - fst (Notation.interp_prim_token loc p (env.tmp_scope,env.scopes)) - | CDelimiters (loc, key, e) -> + | CPrim p -> + fst (Notation.interp_prim_token ?loc p (env.tmp_scope,env.scopes)) + | CDelimiters (key, e) -> intern {env with tmp_scope = None; - scopes = find_delimiters_scope loc key :: env.scopes} e - | CAppExpl (loc, (isproj,ref,us), args) -> + scopes = find_delimiters_scope ?loc key :: env.scopes} e + | CAppExpl ((isproj,ref,us), args) -> let (f,_,args_scopes,_),args = let args = List.map (fun a -> (a,None)) args in intern_applied_reference intern env (Environ.named_context globalenv) lvar us args ref in (* Rem: GApp(_,f,[]) stands for @f *) - GApp (loc, f, intern_args env args_scopes (List.map fst args)) + CAst.make ?loc @@ + GApp (f, intern_args env args_scopes (List.map fst args)) - | CApp (loc, (isproj,f), args) -> + | CApp ((isproj,f), args) -> let f,args = match f with (* Compact notations like "t.(f args') args" *) - | CApp (_,(Some _,f), args') when not (Option.has_some isproj) -> + | { CAst.v = CApp ((Some _,f), args') } when not (Option.has_some isproj) -> f,args'@args (* Don't compact "(f args') args" to resolve implicits separately *) | _ -> f,args in let (c,impargs,args_scopes,l),args = - match f with + match f.CAst.v with | CRef (ref,us) -> intern_applied_reference intern env (Environ.named_context globalenv) lvar us args ref - | CNotation (loc,ntn,([],[],[])) -> + | CNotation (ntn,([],[],[])) -> let c = intern_notation intern env ntnvars loc ntn ([],[],[]) in let x, impl, scopes, l = find_appl_head_data c in (x,impl,scopes,l), args - | x -> (intern env f,[],[],[]), args in - apply_impargs c env impargs args_scopes + | _ -> (intern env f,[],[],[]), args in + apply_impargs c env impargs args_scopes (merge_impargs l args) loc - | CRecord (loc, fs) -> + | CRecord fs -> let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in let fields = sort_fields ~complete:true loc fs - (fun _idx -> CHole (loc, Some (Evar_kinds.QuestionMark st), - Misctypes.IntroAnonymous, None)) + (fun _idx -> CAst.make ?loc @@ CHole (Some (Evar_kinds.QuestionMark (st,Anonymous)), + Misctypes.IntroAnonymous, None)) in begin match fields with - | None -> user_err ~loc ~hdr:"intern" (str"No constructor inference.") + | None -> user_err ?loc ~hdr:"intern" (str"No constructor inference.") | Some (n, constrname, args) -> - let pars = List.make n (CHole (loc, None, Misctypes.IntroAnonymous, None)) in - let app = CAppExpl (loc, (None, constrname,None), List.rev_append pars args) in + let pars = List.make n (CAst.make ?loc @@ CHole (None, Misctypes.IntroAnonymous, None)) in + let app = CAst.make ?loc @@ CAppExpl ((None, constrname,None), List.rev_append pars args) in intern env app end - | CCases (loc, sty, rtnpo, tms, eqns) -> + | CCases (sty, rtnpo, tms, eqns) -> let as_in_vars = List.fold_left (fun acc (_,na,inb) -> Option.fold_left (fun acc tt -> Id.Set.union (ids_of_cases_indtype tt) acc) - (Option.fold_left (fun acc (_,y) -> name_fold Id.Set.add y acc) acc na) + (Option.fold_left (fun acc (_,y) -> Name.fold_right Id.Set.add y acc) acc na) inb) Id.Set.empty tms in (* as, in & return vars *) let forbidden_vars = Option.cata free_vars_of_constr_expr as_in_vars rtnpo in @@ -1656,60 +1670,63 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = (tm,ind)::inds, Option.fold_right Id.Set.add extra_id ex_ids, List.rev_append match_td matchs) tms ([],Id.Set.empty,[]) in let env' = Id.Set.fold - (fun var bli -> push_name_env ntnvars (Variable,[],[],[]) bli (Loc.ghost,Name var)) + (fun var bli -> push_name_env ntnvars (Variable,[],[],[]) bli (Loc.tag @@ Name var)) (Id.Set.union ex_ids as_in_vars) (reset_hidden_inductive_implicit_test env) in (* PatVars before a real pattern do not need to be matched *) let stripped_match_from_in = let rec aux = function | [] -> [] - | (_,PatVar _) :: q -> aux q + | (_, { v = PatVar _}) :: q -> aux q | l -> l in aux match_from_in in let rtnpo = match stripped_match_from_in with | [] -> Option.map (intern_type env') rtnpo (* Only PatVar in "in" clauses *) | l -> (* Build a return predicate by expansion of the patterns of the "in" clause *) - let thevars,thepats = List.split l in + let thevars, thepats = List.split l in let sub_rtn = (* Some (GSort (Loc.ghost,GType None)) *) None in - let sub_tms = List.map (fun id -> GVar (Loc.ghost,id),(Name id,None)) thevars (* "match v1,..,vn" *) in - let main_sub_eqn = - (Loc.ghost,[],thepats, (* "|p1,..,pn" *) + let sub_tms = List.map (fun id -> (CAst.make @@ GVar id),(Name id,None)) thevars (* "match v1,..,vn" *) in + let main_sub_eqn = Loc.tag @@ + ([],thepats, (* "|p1,..,pn" *) Option.cata (intern_type env') - (GHole(Loc.ghost,Evar_kinds.CasesType false,Misctypes.IntroAnonymous,None)) + (CAst.make ?loc @@ GHole(Evar_kinds.CasesType false,Misctypes.IntroAnonymous,None)) rtnpo) (* "=> P" if there were a return predicate P, and "=> _" otherwise *) in let catch_all_sub_eqn = if List.for_all (irrefutable globalenv) thepats then [] else - [Loc.ghost,[],List.make (List.length thepats) (PatVar(Loc.ghost,Anonymous)), (* "|_,..,_" *) - GHole(Loc.ghost,Evar_kinds.ImpossibleCase,Misctypes.IntroAnonymous,None)] (* "=> _" *) in - Some (GCases(Loc.ghost,Term.RegularStyle,sub_rtn,sub_tms,main_sub_eqn::catch_all_sub_eqn)) + [Loc.tag @@ ([],List.make (List.length thepats) (CAst.make @@ PatVar Anonymous), (* "|_,..,_" *) + CAst.make @@ GHole(Evar_kinds.ImpossibleCase,Misctypes.IntroAnonymous,None))] (* "=> _" *) in + Some (CAst.make @@ GCases(Term.RegularStyle,sub_rtn,sub_tms,main_sub_eqn::catch_all_sub_eqn)) in let eqns' = List.map (intern_eqn (List.length tms) env) eqns in - GCases (loc, sty, rtnpo, tms, List.flatten eqns') - | CLetTuple (loc, nal, (na,po), b, c) -> + CAst.make ?loc @@ + GCases (sty, rtnpo, tms, List.flatten eqns') + | CLetTuple (nal, (na,po), b, c) -> let env' = reset_tmp_scope env in (* "in" is None so no match to add *) let ((b',(na',_)),_,_) = intern_case_item env' Id.Set.empty (b,na,None) in let p' = Option.map (fun u -> let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env') - (Loc.ghost,na') in + (Loc.tag na') in intern_type env'' u) po in - GLetTuple (loc, List.map snd nal, (na', p'), b', + CAst.make ?loc @@ + GLetTuple (List.map snd nal, (na', p'), b', intern (List.fold_left (push_name_env ntnvars (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c) - | CIf (loc, c, (na,po), b1, b2) -> + | CIf (c, (na,po), b1, b2) -> let env' = reset_tmp_scope env in let ((c',(na',_)),_,_) = intern_case_item env' Id.Set.empty (c,na,None) in (* no "in" no match to ad too *) let p' = Option.map (fun p -> let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env) - (Loc.ghost,na') in + (Loc.tag na') in intern_type env'' p) po in - GIf (loc, c', (na', p'), intern env b1, intern env b2) - | CHole (loc, k, naming, solve) -> + CAst.make ?loc @@ + GIf (c', (na', p'), intern env b1, intern env b2) + | CHole (k, naming, solve) -> let k = match k with | None -> let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in (match naming with | Misctypes.IntroIdentifier id -> Evar_kinds.NamedHole id - | _ -> Evar_kinds.QuestionMark st) + | _ -> Evar_kinds.QuestionMark (st,Anonymous)) | Some k -> k in let solve = match solve with @@ -1717,37 +1734,45 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = | Some gen -> let (ltacvars, ntnvars) = lvar in let ntnvars = Id.Map.domain ntnvars in + let extra = ltacvars.ltac_extra in let lvars = Id.Set.union ltacvars.ltac_bound ltacvars.ltac_vars in let lvars = Id.Set.union lvars ntnvars in - let lvars = Id.Set.union lvars env.ids in + let ltacvars = Id.Set.union lvars env.ids in let ist = { - Genintern.ltacvars = lvars; - genv = globalenv; + Genintern.genv = globalenv; + ltacvars; + extra; } in let (_, glb) = Genintern.generic_intern ist gen in Some glb in - GHole (loc, k, naming, solve) + CAst.make ?loc @@ + GHole (k, naming, solve) (* Parsing pattern variables *) - | CPatVar (loc, n) when allow_patvar -> - GPatVar (loc, (true,n)) - | CEvar (loc, n, []) when allow_patvar -> - GPatVar (loc, (false,n)) + | CPatVar n when allow_patvar -> + CAst.make ?loc @@ + GPatVar (true,n) + | CEvar (n, []) when allow_patvar -> + CAst.make ?loc @@ + GPatVar (false,n) (* end *) (* Parsing existential variables *) - | CEvar (loc, n, l) -> - GEvar (loc, n, List.map (on_snd (intern env)) l) - | CPatVar (loc, _) -> + | CEvar (n, l) -> + CAst.make ?loc @@ + GEvar (n, List.map (on_snd (intern env)) l) + | CPatVar _ -> raise (InternalizationError (loc,IllegalMetavariable)) (* end *) - | CSort (loc, s) -> - GSort(loc,s) - | CCast (loc, c1, c2) -> - GCast (loc,intern env c1, Miscops.map_cast_type (intern_type env) c2) - + | CSort s -> + CAst.make ?loc @@ + GSort s + | CCast (c1, c2) -> + CAst.make ?loc @@ + GCast (intern env c1, Miscops.map_cast_type (intern_type env) c2) + ) and intern_type env = intern (set_type_scope env) - and intern_local_binder env bind = + and intern_local_binder env bind : intern_env * Glob_term.extended_glob_local_binder list = intern_local_binder_aux intern ntnvars env bind (* Expands a multiple pattern into a disjunction of multiple patterns *) @@ -1766,7 +1791,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = (ids,List.flatten mpl') (* Expands a pattern-matching clause [lhs => rhs] *) - and intern_eqn n env (loc,lhs,rhs) = + and intern_eqn n env (loc,(lhs,rhs)) = let eqn_ids,pll = intern_disjunctive_multiple_pattern env loc n lhs in (* Linearity implies the order in ids is irrelevant *) check_linearity lhs eqn_ids; @@ -1774,16 +1799,16 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = List.map (fun (asubst,pl) -> let rhs = replace_vars_constr_expr asubst rhs in let rhs' = intern {env with ids = env_ids} rhs in - (loc,eqn_ids,pl,rhs')) pll + (loc,(eqn_ids,pl,rhs'))) pll and intern_case_item env forbidden_names_for_gen (tm,na,t) = (* the "match" part *) let tm' = intern env tm in (* the "as" part *) let extra_id,na = match tm', na with - | GVar (loc,id), None when not (Id.Map.mem id (snd lvar)) -> Some id,(loc,Name id) - | GRef (loc, VarRef id, _), None -> Some id,(loc,Name id) - | _, None -> None,(Loc.ghost,Anonymous) + | {loc; v = GVar id}, None when not (Id.Map.mem id (snd lvar)) -> Some id,(loc,Name id) + | {loc; v = GRef (VarRef id, _)}, None -> Some id,(loc,Name id) + | _, None -> None,(Loc.tag Anonymous) | _, Some (loc,na) -> None,(loc,na) in (* the "in" part *) let match_td,typ = match t with @@ -1801,14 +1826,14 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = let rec canonize_args case_rel_ctxt arg_pats forbidden_names match_acc var_acc = let add_name l = function | _,Anonymous -> l - | loc,(Name y as x) -> (y,PatVar(loc,x)) :: l in + | loc,(Name y as x) -> (y, CAst.make ?loc @@ PatVar x) :: l in match case_rel_ctxt,arg_pats with (* LetIn in the rel_context *) | LocalDef _ :: t, l when not with_letin -> - canonize_args t l forbidden_names match_acc ((Loc.ghost,Anonymous)::var_acc) + canonize_args t l forbidden_names match_acc ((Loc.tag Anonymous)::var_acc) | [],[] -> (add_name match_acc na, var_acc) - | _::t,PatVar (loc,x)::tt -> + | _::t, { loc; v = PatVar x}::tt -> canonize_args t tt forbidden_names (add_name match_acc (loc,x)) ((loc,x)::var_acc) | (LocalAssum (cano_name,ty) | LocalDef (cano_name,_,ty)) :: t, c::tt -> @@ -1820,24 +1845,24 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = let _,args_rel = List.chop nparams (List.rev mip.Declarations.mind_arity_ctxt) in canonize_args args_rel l (Id.Set.elements forbidden_names_for_gen) [] [] in - match_to_do, Some (cases_pattern_expr_loc t,ind,List.rev_map snd nal) + match_to_do, Some (cases_pattern_expr_loc t,(ind,List.rev_map snd nal)) | None -> [], None in (tm',(snd na,typ)), extra_id, match_td - and iterate_prod loc2 env bk ty body nal = + and iterate_prod ?loc env bk ty body nal = let env, bl = intern_assumption intern ntnvars env nal bk ty in - it_mkGProd loc2 bl (intern_type env body) + it_mkGProd ?loc bl (intern_type env body) - and iterate_lam loc2 env bk ty body nal = + and iterate_lam loc env bk ty body nal = let env, bl = intern_assumption intern ntnvars env nal bk ty in - it_mkGLambda loc2 bl (intern env body) + it_mkGLambda ?loc bl (intern env body) and intern_impargs c env l subscopes args = let eargs, rargs = extract_explicit_arg l args in if !parsing_explicit then if Id.Map.is_empty eargs then intern_args env subscopes rargs - else error "Arguments given by name or position not supported in explicit mode." + else user_err Pp.(str "Arguments given by name or position not supported in explicit mode.") else let rec aux n impl subscopes eargs rargs = let (enva,subscopes') = apply_scope_env env subscopes in @@ -1854,15 +1879,16 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = (* with implicit arguments if maximal insertion is set *) [] else - GHole (set_hole_implicit (n,get_implicit_name n l) (force_inference_of imp) c) :: - aux (n+1) impl' subscopes' eargs rargs + (CAst.map_from_loc (fun ?loc (a,b,c) -> GHole(a,b,c)) + (set_hole_implicit (n,get_implicit_name n l) (force_inference_of imp) c) + ) :: aux (n+1) impl' subscopes' eargs rargs end | (imp::impl', a::rargs') -> intern enva a :: aux (n+1) impl' subscopes' eargs rargs' | (imp::impl', []) -> if not (Id.Map.is_empty eargs) then (let (id,(loc,_)) = Id.Map.choose eargs in - user_err ~loc (str "Not enough non implicit \ + user_err ?loc (str "Not enough non implicit \ arguments to accept the argument bound to " ++ pr_id id ++ str".")); [] @@ -1871,17 +1897,18 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = intern_args env subscopes rargs in aux 1 l subscopes eargs rargs - and apply_impargs c env imp subscopes l loc = + and apply_impargs c env imp subscopes l loc = + let l : (Constrexpr.constr_expr * Constrexpr.explicitation Loc.located option) list = l in let imp = select_impargs_size (List.length (List.filter (fun (_,x) -> x == None) l)) imp in let l = intern_impargs c env imp subscopes l in smart_gapp c loc l and smart_gapp f loc = function | [] -> f - | l -> match f with - | GApp (loc', g, args) -> GApp (Loc.merge loc' loc, g, args@l) - | _ -> GApp (Loc.merge (loc_of_glob_constr f) loc, f, l) - + | l -> match f with + | { loc = loc'; v = GApp (g, args) } -> CAst.make ?loc:(Loc.merge_opt loc' loc) @@ GApp (g, args@l) + | _ -> CAst.make ?loc:(Loc.merge_opt (loc_of_glob_constr f) loc) @@ GApp (f, l) + and intern_args env subscopes = function | [] -> [] | a::args -> @@ -1893,7 +1920,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = intern env c with InternalizationError (loc,e) -> - user_err ~loc ~hdr:"internalize" + user_err ?loc ~hdr:"internalize" (explain_internalization_error e) (**************************************************************************) @@ -1913,6 +1940,7 @@ let scope_of_type_kind = function let empty_ltac_sign = { ltac_vars = Id.Set.empty; ltac_bound = Id.Set.empty; + ltac_extra = Genintern.Store.empty; } let intern_gen kind env @@ -1933,7 +1961,7 @@ let intern_pattern globalenv patt = intern_cases_pattern globalenv (None,[]) empty_alias patt with InternalizationError (loc,e) -> - user_err ~loc ~hdr:"internalize" (explain_internalization_error e) + user_err ?loc ~hdr:"internalize" (explain_internalization_error e) (*********************************************************************) @@ -2019,12 +2047,12 @@ let interp_notation_constr ?(impls=empty_internalization_env) nenv a = let interp_binder env sigma na t = let t = intern_gen IsType env t in - let t' = locate_if_hole (loc_of_glob_constr t) na t in + let t' = locate_if_hole ?loc:(loc_of_glob_constr t) na t in understand ~expected_type:IsType env sigma t' let interp_binder_evars env evdref na t = let t = intern_gen IsType env t in - let t' = locate_if_hole (loc_of_glob_constr t) na t in + let t' = locate_if_hole ?loc:(loc_of_glob_constr t) na t in understand_tcc_evars env evdref ~expected_type:IsType t' let my_intern_constr env lvar acc c = @@ -2041,15 +2069,15 @@ let intern_context global_level env impl_env binders = tmp_scope = None; scopes = []; impls = impl_env}, []) binders in (lenv.impls, List.map glob_local_binder_of_extended bl) with InternalizationError (loc,e) -> - user_err ~loc ~hdr:"internalize" (explain_internalization_error e) + user_err ?loc ~hdr:"internalize" (explain_internalization_error e) -let interp_rawcontext_evars env evdref k bl = +let interp_glob_context_evars env evdref k bl = let open EConstr in let (env, par, _, impls) = List.fold_left (fun (env,params,n,impls) (na, k, b, t) -> let t' = - if Option.is_empty b then locate_if_hole (loc_of_glob_constr t) na t + if Option.is_empty b then locate_if_hole ?loc:(loc_of_glob_constr t) na t else t in let t = understand_tcc_evars env evdref ~expected_type:IsType t' in @@ -2072,6 +2100,6 @@ let interp_rawcontext_evars env evdref k bl = let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) ?(shift=0) env evdref params = let int_env,bl = intern_context global_level env impl_env params in - let x = interp_rawcontext_evars env evdref shift bl in + let x = interp_glob_context_evars env evdref shift bl in int_env, x diff --git a/interp/constrintern.mli b/interp/constrintern.mli index fdd50c6a1e..644f60d850 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -70,6 +70,8 @@ type ltac_sign = { (** Variables of Ltac which may be bound to a term *) ltac_bound : Id.Set.t; (** Other variables of Ltac *) + ltac_extra : Genintern.Store.t; + (** Arbitrary payload *) } val empty_ltac_sign : ltac_sign @@ -174,9 +176,9 @@ val interp_context_evars : val locate_reference : Libnames.qualid -> Globnames.global_reference val is_global : Id.t -> bool -val construct_reference : ('c, 't) Context.Named.pt -> Id.t -> constr -val global_reference : Id.t -> constr -val global_reference_in_absolute_module : DirPath.t -> Id.t -> constr +val construct_reference : ('c, 't) Context.Named.pt -> Id.t -> Globnames.global_reference +val global_reference : Id.t -> Globnames.global_reference +val global_reference_in_absolute_module : DirPath.t -> Id.t -> Globnames.global_reference (** Interprets a term as the left-hand side of a notation. The returned map is guaranteed to have the same domain as the input one. *) diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index 9f549b0c0f..10621f14dd 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -139,30 +139,32 @@ let interval loc = let loc1,loc2 = Loc.unloc loc in loc1, loc2-1 -let dump_ref loc filepath modpath ident ty = +let dump_ref ?loc filepath modpath ident ty = match !glob_output with | Feedback -> - Feedback.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty)) + Option.iter (fun loc -> + Feedback.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty)) + ) loc | NoGlob -> () - | _ when not (Loc.is_ghost loc) -> + | _ -> Option.iter (fun loc -> let bl,el = interval loc in dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n" bl el filepath modpath ident ty) - | _ -> () + ) loc -let dump_reference loc modpath ident ty = +let dump_reference ?loc modpath ident ty = let filepath = Names.DirPath.to_string (Lib.library_dp ()) in - dump_ref loc filepath modpath ident ty + dump_ref ?loc filepath modpath ident ty -let dump_modref loc mp ty = +let dump_modref ?loc mp ty = let (dp, l) = Lib.split_modpath mp in let filepath = Names.DirPath.to_string dp in let modpath = Names.DirPath.to_string (Names.DirPath.make l) in let ident = "<>" in - dump_ref loc filepath modpath ident ty + dump_ref ?loc filepath modpath ident ty -let dump_libref loc dp ty = - dump_ref loc (Names.DirPath.to_string dp) "<>" "<>" ty +let dump_libref ?loc dp ty = + dump_ref ?loc (Names.DirPath.to_string dp) "<>" "<>" ty let cook_notation df sc = (* We encode notations so that they are space-free and still human-readable *) @@ -208,10 +210,10 @@ let dump_notation_location posl df (((path,secpath),_),sc) = let secpath = Names.DirPath.to_string secpath in let df = cook_notation df sc in List.iter (fun l -> - dump_ref (Loc.make_loc l) path secpath df "not") + dump_ref ~loc:(Loc.make_loc l) path secpath df "not") posl -let add_glob_gen loc sp lib_dp ty = +let add_glob_gen ?loc sp lib_dp ty = if dump () then let mod_dp,id = Libnames.repr_path sp in let mod_dp = remove_sections mod_dp in @@ -219,50 +221,51 @@ let add_glob_gen loc sp lib_dp ty = let filepath = Names.DirPath.to_string lib_dp in let modpath = Names.DirPath.to_string mod_dp_trunc in let ident = Names.Id.to_string id in - dump_ref loc filepath modpath ident ty + dump_ref ?loc filepath modpath ident ty -let add_glob loc ref = - if dump () && not (Loc.is_ghost loc) then +let add_glob ?loc ref = + if dump () then let sp = Nametab.path_of_global ref in let lib_dp = Lib.library_part ref in let ty = type_of_global_ref ref in - add_glob_gen loc sp lib_dp ty + add_glob_gen ?loc sp lib_dp ty let mp_of_kn kn = let mp,sec,l = Names.repr_kn kn in Names.MPdot (mp,l) -let add_glob_kn loc kn = - if dump () && not (Loc.is_ghost loc) then +let add_glob_kn ?loc kn = + if dump () then let sp = Nametab.path_of_syndef kn in let lib_dp = Lib.dp_of_mp (mp_of_kn kn) in - add_glob_gen loc sp lib_dp "syndef" + add_glob_gen ?loc sp lib_dp "syndef" -let dump_binding loc id = () +let dump_binding ?loc id = () -let dump_def ty loc secpath id = +let dump_def ?loc ty secpath id = Option.iter (fun loc -> if !glob_output = Feedback then Feedback.feedback (Feedback.GlobDef (loc, id, secpath, ty)) else let bl,el = interval loc in dump_string (Printf.sprintf "%s %d:%d %s %s\n" ty bl el secpath id) + ) loc let dump_definition (loc, id) sec s = - dump_def s loc (Names.DirPath.to_string (Lib.current_dirpath sec)) (Names.Id.to_string id) + dump_def ?loc s (Names.DirPath.to_string (Lib.current_dirpath sec)) (Names.Id.to_string id) let dump_constraint (((loc, n),_), _, _) sec ty = match n with | Names.Name id -> dump_definition (loc, id) sec ty | Names.Anonymous -> () -let dump_moddef loc mp ty = +let dump_moddef ?loc mp ty = let (dp, l) = Lib.split_modpath mp in let mp = Names.DirPath.to_string (Names.DirPath.make l) in - dump_def ty loc "<>" mp + dump_def ?loc ty "<>" mp -let dump_notation (loc,(df,_)) sc sec = +let dump_notation (loc,(df,_)) sc sec = Option.iter (fun loc -> (* We dump the location of the opening '"' *) let i = fst (Loc.unloc loc) in let location = (Loc.make_loc (i, i+1)) in - dump_def "not" location (Names.DirPath.to_string (Lib.current_dirpath sec)) (cook_notation df sc) - + dump_def ~loc:location "not" (Names.DirPath.to_string (Lib.current_dirpath sec)) (cook_notation df sc) + ) loc diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index e84a640521..f42055af7b 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -22,19 +22,19 @@ val feedback_glob : unit -> unit val pause : unit -> unit val continue : unit -> unit -val add_glob : Loc.t -> Globnames.global_reference -> unit -val add_glob_kn : Loc.t -> Names.kernel_name -> unit - -val dump_definition : Loc.t * Names.Id.t -> bool -> string -> unit -val dump_moddef : Loc.t -> Names.module_path -> string -> unit -val dump_modref : Loc.t -> Names.module_path -> string -> unit -val dump_reference : Loc.t -> string -> string -> string -> unit -val dump_libref : Loc.t -> Names.DirPath.t -> string -> unit +val add_glob : ?loc:Loc.t -> Globnames.global_reference -> unit +val add_glob_kn : ?loc:Loc.t -> Names.kernel_name -> unit + +val dump_definition : Names.Id.t Loc.located -> bool -> string -> unit +val dump_moddef : ?loc:Loc.t -> Names.module_path -> string -> unit +val dump_modref : ?loc:Loc.t -> Names.module_path -> string -> unit +val dump_reference : ?loc:Loc.t -> string -> string -> string -> unit +val dump_libref : ?loc:Loc.t -> Names.DirPath.t -> string -> unit val dump_notation_location : (int * int) list -> Constrexpr.notation -> (Notation.notation_location * Notation_term.scope_name option) -> unit -val dump_binding : Loc.t -> Names.Id.Set.elt -> unit +val dump_binding : ?loc:Loc.t -> Names.Id.Set.elt -> unit val dump_notation : - Loc.t * (Constrexpr.notation * Notation.notation_location) -> + (Constrexpr.notation * Notation.notation_location) Loc.located -> Notation_term.scope_name option -> bool -> unit val dump_constraint : Constrexpr.typeclass_constraint -> bool -> string -> unit diff --git a/interp/genintern.ml b/interp/genintern.ml index be7abfa995..e443824bd2 100644 --- a/interp/genintern.ml +++ b/interp/genintern.ml @@ -10,9 +10,19 @@ open Names open Mod_subst open Genarg +module Store = Store.Make(struct end) + type glob_sign = { ltacvars : Id.Set.t; - genv : Environ.env } + genv : Environ.env; + extra : Store.t; +} + +let empty_glob_sign env = { + ltacvars = Id.Set.empty; + genv = env; + extra = Store.empty; +} type ('raw, 'glb) intern_fun = glob_sign -> 'raw -> glob_sign * 'glb type 'glb subst_fun = substitution -> 'glb -> 'glb diff --git a/interp/genintern.mli b/interp/genintern.mli index 4b0354be39..658caa08c2 100644 --- a/interp/genintern.mli +++ b/interp/genintern.mli @@ -10,9 +10,15 @@ open Names open Mod_subst open Genarg +module Store : Store.S + type glob_sign = { ltacvars : Id.Set.t; - genv : Environ.env } + genv : Environ.env; + extra : Store.t; +} + +val empty_glob_sign : Environ.env -> glob_sign (** {5 Internalization functions} *) diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 19c872b310..ade524141a 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -28,11 +28,11 @@ let generalizable_table = Summary.ref Id.Pred.empty ~name:"generalizable-ident" let declare_generalizable_ident table (loc,id) = if not (Id.equal id (root_of_id id)) then - user_err ~loc ~hdr:"declare_generalizable_ident" + user_err ?loc ~hdr:"declare_generalizable_ident" ((pr_id id ++ str " is not declarable as generalizable identifier: it must have no trailing digits, quote, or _")); if Id.Pred.mem id table then - user_err ~loc ~hdr:"declare_generalizable_ident" + user_err ?loc ~hdr:"declare_generalizable_ident" ((pr_id id++str" is already declared as a generalizable identifier")) else Id.Pred.add id table @@ -79,7 +79,7 @@ let is_freevar ids env x = (* Auxiliary functions for the inference of implicitly quantified variables. *) let ungeneralizable loc id = - user_err ~loc ~hdr:"Generalization" + user_err ?loc ~hdr:"Generalization" (str "Unbound and ungeneralizable variable " ++ pr_id id) let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = @@ -91,11 +91,11 @@ let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = else ungeneralizable loc id else l in - let rec aux bdvars l c = match c with + let rec aux bdvars l c = match CAst.(c.v) with | CRef (Ident (loc,id),_) -> found loc id bdvars l - | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id),_) :: _, [], [])) when not (Id.Set.mem id bdvars) -> + | CNotation ("{ _ : _ | _ }", ({ CAst.v = CRef (Ident (_, id),_) } :: _, [], [])) when not (Id.Set.mem id bdvars) -> Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add id bdvars) l c - | c -> Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c + | _ -> Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c in aux bound l c let ids_of_names l = @@ -119,16 +119,16 @@ let free_vars_of_binders ?(bound=Id.Set.empty) l (binders : local_binder_expr li in aux bound l binders let generalizable_vars_of_glob_constr ?(bound=Id.Set.empty) ?(allowed=Id.Set.empty) = - let rec vars bound vs = function - | GVar (loc,id) -> + let rec vars bound vs t = match t with + | { loc; CAst.v = GVar id } -> if is_freevar bound (Global.env ()) id then - if Id.List.mem_assoc id vs then vs - else (id, loc) :: vs + if Id.List.mem_assoc_sym id vs then vs + else (Loc.tag ?loc id) :: vs else vs | c -> Glob_ops.fold_glob_constr_with_binders Id.Set.add vars bound vs c in fun rt -> let vars = List.rev (vars bound [] rt) in - List.iter (fun (id, loc) -> + List.iter (fun (loc, id) -> if not (Id.Set.mem id allowed || find_generalizable_ident id) then ungeneralizable loc id) vars; vars @@ -151,7 +151,7 @@ let combine_params avoid fn applied needed = | Anonymous -> false in if not (List.exists is_id needed) then - user_err ~loc (str "Wrong argument name: " ++ Nameops.pr_id id); + user_err ?loc (str "Wrong argument name: " ++ Nameops.pr_id id); true | _ -> false) applied in @@ -185,31 +185,35 @@ let combine_params avoid fn applied needed = aux (t' :: ids) avoid' app need | (x,_) :: _, [] -> - user_err ~loc:(Constrexpr_ops.constr_loc x) (str "Typeclass does not expect more arguments") + user_err ?loc:(Constrexpr_ops.constr_loc x) (str "Typeclass does not expect more arguments") in aux [] avoid applied needed let combine_params_freevar = fun avoid (_, decl) -> let id' = next_name_away_from (RelDecl.get_name decl) avoid in - (CRef (Ident (Loc.ghost, id'),None), Id.Set.add id' avoid) + (CAst.make @@ CRef (Ident (Loc.tag id'),None), Id.Set.add id' avoid) let destClassApp cl = - match cl with - | CApp (loc, (None, CRef (ref, inst)), l) -> loc, ref, List.map fst l, inst - | CAppExpl (loc, (None, ref, inst), l) -> loc, ref, l, inst - | CRef (ref, inst) -> loc_of_reference ref, ref, [], inst + let open CAst in + let loc = cl.loc in + match cl.v with + | CApp ((None, { v = CRef (ref, inst) }), l) -> Loc.tag ?loc (ref, List.map fst l, inst) + | CAppExpl ((None, ref, inst), l) -> Loc.tag ?loc (ref, l, inst) + | CRef (ref, inst) -> Loc.tag ?loc:(loc_of_reference ref) (ref, [], inst) | _ -> raise Not_found let destClassAppExpl cl = - match cl with - | CApp (loc, (None, CRef (ref, inst)), l) -> loc, ref, l, inst - | CRef (ref, inst) -> loc_of_reference ref, ref, [], inst + let open CAst in + let loc = cl.loc in + match cl.v with + | CApp ((None, { v = CRef (ref, inst) } ), l) -> Loc.tag ?loc (ref, l, inst) + | CRef (ref, inst) -> Loc.tag ?loc:(loc_of_reference ref) (ref, [], inst) | _ -> raise Not_found let implicit_application env ?(allow_partial=true) f ty = let is_class = try - let (_, r, _, _ as clapp) = destClassAppExpl ty in + let (_, (r, _, _) as clapp) = destClassAppExpl ty in let (loc, qid) = qualid_of_reference r in let gr = Nametab.locate qid in if Typeclasses.is_class gr then Some (clapp, gr) else None @@ -217,7 +221,7 @@ let implicit_application env ?(allow_partial=true) f ty = in match is_class with | None -> ty, env - | Some ((loc, id, par, inst), gr) -> + | Some ((loc, (id, par, inst)), gr) -> let avoid = Id.Set.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in let c, avoid = let c = class_info gr in @@ -235,7 +239,7 @@ let implicit_application env ?(allow_partial=true) f ty = end; let pars = List.rev (List.combine ci rd) in let args, avoid = combine_params avoid f par pars in - CAppExpl (loc, (None, id, inst), args), avoid + CAst.make ?loc @@ CAppExpl ((None, id, inst), args), avoid in c, avoid let implicits_of_glob_constr ?(with_products=true) l = @@ -249,23 +253,23 @@ let implicits_of_glob_constr ?(with_products=true) l = (ExplByPos (i, name), (true, true, true)) :: l | _ -> l in - let rec aux i c = + let rec aux i { loc; CAst.v = c } = let abs na bk b = add_impl i na bk (aux (succ i) b) in match c with - | GProd (loc, na, bk, t, b) -> + | GProd (na, bk, t, b) -> if with_products then abs na bk b else let () = match bk with | Implicit -> Feedback.msg_warning (strbrk "Ignoring implicit status of product binder " ++ - pr_name na ++ strbrk " and following binders") + Name.print na ++ strbrk " and following binders") | _ -> () in [] - | GLambda (loc, na, bk, t, b) -> abs na bk b - | GLetIn (loc, na, b, t, c) -> aux i c - | GRec (_, fix_kind, nas, args, tys, bds) -> + | GLambda (na, bk, t, b) -> abs na bk b + | GLetIn (na, b, t, c) -> aux i b + | GRec (fix_kind, nas, args, tys, bds) -> let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in List.fold_left_i (fun i l (na,bk,_,_) -> add_impl i na bk l) i (aux (List.length args.(nb) + i) bds.(nb)) args.(nb) | _ -> [] diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli index 71009ec3c2..945bed2aad 100644 --- a/interp/implicit_quantifiers.mli +++ b/interp/implicit_quantifiers.mli @@ -16,8 +16,8 @@ open Globnames val declare_generalizable : Vernacexpr.locality_flag -> (Id.t located) list option -> unit val ids_of_list : Id.t list -> Id.Set.t -val destClassApp : constr_expr -> Loc.t * reference * constr_expr list * instance_expr option -val destClassAppExpl : constr_expr -> Loc.t * reference * (constr_expr * explicitation located option) list * instance_expr option +val destClassApp : constr_expr -> (reference * constr_expr list * instance_expr option) located +val destClassAppExpl : constr_expr -> (reference * (constr_expr * explicitation located option) list * instance_expr option) located (** Fragile, should be used only for construction a set of identifiers to avoid *) @@ -31,7 +31,7 @@ val free_vars_of_binders : order with the location of their first occurrence *) val generalizable_vars_of_glob_constr : ?bound:Id.Set.t -> ?allowed:Id.Set.t -> - glob_constr -> (Id.t * Loc.t) list + glob_constr -> Id.t located list val make_fresh : Id.Set.t -> Environ.env -> Id.t -> Id.t diff --git a/interp/interp.mllib b/interp/interp.mllib index 607af82a03..6d290a325c 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -14,6 +14,5 @@ Implicit_quantifiers Constrintern Modintern Constrextern -Coqlib Discharge Declare diff --git a/interp/modintern.ml b/interp/modintern.ml index d4ade7058a..3115c2bcbf 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -26,16 +26,16 @@ let error_not_a_module_loc kind loc qid = | ModType -> Modops.ModuleTypingError (Modops.NotAModuleType s) | ModAny -> ModuleInternalizationError (NotAModuleNorModtype s) in - Loc.raise ~loc e + Loc.raise ?loc e let error_application_to_not_path loc me = - Loc.raise ~loc (Modops.ModuleTypingError (Modops.ApplicationToNotPath me)) + Loc.raise ?loc (Modops.ModuleTypingError (Modops.ApplicationToNotPath me)) let error_incorrect_with_in_module loc = - Loc.raise ~loc (ModuleInternalizationError IncorrectWithInModule) + Loc.raise ?loc (ModuleInternalizationError IncorrectWithInModule) let error_application_to_module_type loc = - Loc.raise ~loc (ModuleInternalizationError IncorrectModuleApplication) + Loc.raise ?loc (ModuleInternalizationError IncorrectModuleApplication) (** Searching for a module name in the Nametab. @@ -47,12 +47,12 @@ let lookup_module_or_modtype kind (loc,qid) = try if kind == ModType then raise Not_found; let mp = Nametab.locate_module qid in - Dumpglob.dump_modref loc mp "modtype"; (mp,Module) + Dumpglob.dump_modref ?loc mp "modtype"; (mp,Module) with Not_found -> try if kind == Module then raise Not_found; let mp = Nametab.locate_modtype qid in - Dumpglob.dump_modref loc mp "mod"; (mp,ModType) + Dumpglob.dump_modref ?loc mp "mod"; (mp,ModType) with Not_found -> error_not_a_module_loc kind loc qid let lookup_module lqid = fst (lookup_module_or_modtype Module lqid) @@ -65,17 +65,16 @@ let transl_with_decl env = function let ctx = Evd.evar_context_universe_context ectx in WithDef (fqid,(c,ctx)) -let loc_of_module = function - | CMident (loc,_) | CMapply (loc,_,_) | CMwith (loc,_,_) -> loc +let loc_of_module l = l.CAst.loc (* Invariant : the returned kind is never ModAny, and it is equal to the input kind when this one isn't ModAny. *) -let rec interp_module_ast env kind = function +let rec interp_module_ast env kind m = match m.CAst.v with | CMident qid -> - let (mp,kind) = lookup_module_or_modtype kind qid in + let (mp,kind) = lookup_module_or_modtype kind (m.CAst.loc,qid) in (MEident mp, kind) - | CMapply (_,me1,me2) -> + | CMapply (me1,me2) -> let me1',kind1 = interp_module_ast env kind me1 in let me2',kind2 = interp_module_ast env ModAny me2 in let mp2 = match me2' with @@ -85,8 +84,8 @@ let rec interp_module_ast env kind = function if kind2 == ModType then error_application_to_module_type (loc_of_module me2); (MEapply (me1',mp2), kind1) - | CMwith (loc,me,decl) -> + | CMwith (me,decl) -> let me,kind = interp_module_ast env kind me in - if kind == Module then error_incorrect_with_in_module loc; + if kind == Module then error_incorrect_with_in_module m.CAst.loc; let decl = transl_with_decl env decl in (MEwith(me,decl), kind) diff --git a/interp/notation.ml b/interp/notation.ml index 7be2fe0f01..d19654b10b 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -219,10 +219,10 @@ let remove_delimiters scope = with Not_found -> assert false (* A delimiter for scope [scope] should exist *) -let find_delimiters_scope loc key = +let find_delimiters_scope ?loc key = try String.Map.find key !delimiters_map with Not_found -> - user_err ~loc ~hdr:"find_delimiters" + user_err ?loc ~hdr:"find_delimiters" (str "Unknown scope delimiting key " ++ str key ++ str ".") (* Uninterpretation tables *) @@ -263,16 +263,16 @@ let notations_key_table = ref (KeyMap.empty : notation_rule list KeyMap.t) let prim_token_key_table = ref KeyMap.empty let glob_prim_constr_key = function - | GApp (_,GRef (_,ref,_),_) | GRef (_,ref,_) -> RefKey (canonical_gr ref) + | { CAst.v = GApp ({ CAst.v = GRef (ref,_) } ,_) } | { CAst.v = GRef (ref,_) } -> RefKey (canonical_gr ref) | _ -> Oth let glob_constr_keys = function - | GApp (_,GRef (_,ref,_),_) -> [RefKey (canonical_gr ref); Oth] - | GRef (_,ref,_) -> [RefKey (canonical_gr ref)] + | { CAst.v = GApp ({ CAst.v = GRef (ref,_) },_) } -> [RefKey (canonical_gr ref); Oth] + | { CAst.v = GRef (ref,_) } -> [RefKey (canonical_gr ref)] | _ -> [Oth] let cases_pattern_key = function - | PatCstr (_,ref,_,_) -> RefKey (canonical_gr (ConstructRef ref)) + | { CAst.v = PatCstr (ref,_,_) } -> RefKey (canonical_gr (ConstructRef ref)) | _ -> Oth let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) @@ -290,7 +290,7 @@ let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) type required_module = full_path * string list type 'a prim_token_interpreter = - Loc.t -> 'a -> glob_constr + ?loc:Loc.t -> 'a -> glob_constr type cases_pattern_status = bool (* true = use prim token in patterns *) @@ -298,7 +298,7 @@ type 'a prim_token_uninterpreter = glob_constr list * (glob_constr -> 'a option) * cases_pattern_status type internal_prim_token_interpreter = - Loc.t -> prim_token -> required_module * (unit -> glob_constr) + ?loc:Loc.t -> prim_token -> required_module * (unit -> glob_constr) let prim_token_interpreter_tab = (Hashtbl.create 7 : (scope_name, internal_prim_token_interpreter) Hashtbl.t) @@ -308,7 +308,7 @@ let add_prim_token_interpreter sc interp = let cont = Hashtbl.find prim_token_interpreter_tab sc in Hashtbl.replace prim_token_interpreter_tab sc (interp cont) with Not_found -> - let cont = (fun _loc _p -> raise Not_found) in + let cont = (fun ?loc _p -> raise Not_found) in Hashtbl.add prim_token_interpreter_tab sc (interp cont) let declare_prim_token_interpreter sc interp (patl,uninterp,b) = @@ -324,22 +324,22 @@ let mkString = function | None -> None | Some s -> if Unicode.is_utf8 s then Some (String s) else None -let delay dir int loc x = (dir, (fun () -> int loc x)) +let delay dir int ?loc x = (dir, (fun () -> int ?loc x)) let declare_numeral_interpreter sc dir interp (patl,uninterp,inpat) = declare_prim_token_interpreter sc - (fun cont loc -> function Numeral n-> delay dir interp loc n | p -> cont loc p) + (fun cont ?loc -> function Numeral n-> delay dir interp ?loc n | p -> cont ?loc p) (patl, (fun r -> Option.map mkNumeral (uninterp r)), inpat) let declare_string_interpreter sc dir interp (patl,uninterp,inpat) = declare_prim_token_interpreter sc - (fun cont loc -> function String s -> delay dir interp loc s | p -> cont loc p) + (fun cont ?loc -> function String s -> delay dir interp ?loc s | p -> cont ?loc p) (patl, (fun r -> mkString (uninterp r)), inpat) -let check_required_module loc sc (sp,d) = +let check_required_module ?loc sc (sp,d) = try let _ = Nametab.global_of_path sp in () with Not_found -> - user_err ~loc ~hdr:"prim_token_interpreter" + user_err ?loc ~hdr:"prim_token_interpreter" (str "Cannot interpret in " ++ str sc ++ str " without requiring first module " ++ str (List.last d) ++ str ".") (* Look if some notation or numeral printer in [scope] can be used in @@ -444,49 +444,49 @@ let notation_of_prim_token = function | Numeral n -> "- "^(to_string (neg n)) | String _ -> raise Not_found -let find_prim_token check_allowed loc p sc = +let find_prim_token check_allowed ?loc p sc = (* Try for a user-defined numerical notation *) try let (_,c),df = find_notation (notation_of_prim_token p) sc in - let pat = Notation_ops.glob_constr_of_notation_constr loc c in + let pat = Notation_ops.glob_constr_of_notation_constr ?loc c in check_allowed pat; pat, df with Not_found -> (* Try for a primitive numerical notation *) - let (spdir,interp) = Hashtbl.find prim_token_interpreter_tab sc loc p in - check_required_module loc sc spdir; + let (spdir,interp) = Hashtbl.find prim_token_interpreter_tab sc ?loc p in + check_required_module ?loc sc spdir; let pat = interp () in check_allowed pat; pat, ((dirpath (fst spdir),DirPath.empty),"") -let interp_prim_token_gen g loc p local_scopes = +let interp_prim_token_gen ?loc g p local_scopes = let scopes = make_current_scopes local_scopes in let p_as_ntn = try notation_of_prim_token p with Not_found -> "" in - try find_interpretation p_as_ntn (find_prim_token g loc p) scopes + try find_interpretation p_as_ntn (find_prim_token ?loc g p) scopes with Not_found -> - user_err ~loc ~hdr:"interp_prim_token" + user_err ?loc ~hdr:"interp_prim_token" ((match p with | Numeral n -> str "No interpretation for numeral " ++ str (to_string n) | String s -> str "No interpretation for string " ++ qs s) ++ str ".") -let interp_prim_token = - interp_prim_token_gen (fun _ -> ()) +let interp_prim_token ?loc = + interp_prim_token_gen ?loc (fun _ -> ()) -let rec check_allowed_ref_in_pat looked_for = function +let rec check_allowed_ref_in_pat looked_for = CAst.(with_val (function | GVar _ | GHole _ -> () - | GRef (_,g,_) -> looked_for g - | GApp (loc,GRef (_,g,_),l) -> + | GRef (g,_) -> looked_for g + | GApp ({ v = GRef (g,_) },l) -> looked_for g; List.iter (check_allowed_ref_in_pat looked_for) l - | _ -> raise Not_found + | _ -> raise Not_found)) -let interp_prim_token_cases_pattern_expr loc looked_for p = - interp_prim_token_gen (check_allowed_ref_in_pat looked_for) loc p +let interp_prim_token_cases_pattern_expr ?loc looked_for p = + interp_prim_token_gen ?loc (check_allowed_ref_in_pat looked_for) p -let interp_notation loc ntn local_scopes = +let interp_notation ?loc ntn local_scopes = let scopes = make_current_scopes local_scopes in try find_interpretation ntn (find_notation ntn) scopes with Not_found -> - user_err ~loc + user_err ?loc (str "Unknown interpretation for notation \"" ++ str ntn ++ str "\".") let uninterp_notations c = @@ -521,8 +521,8 @@ let uninterp_prim_token_ind_pattern ind args = if not b then raise Notation_ops.No_match; let args' = List.map (fun x -> snd (glob_constr_of_closed_cases_pattern x)) args in - let ref = GRef (Loc.ghost,ref,None) in - match numpr (GApp (Loc.ghost,ref,args')) with + let ref = CAst.make @@ GRef (ref,None) in + match numpr (CAst.make @@ GApp (ref,args')) with | None -> raise Notation_ops.No_match | Some n -> (sc,n) with Not_found -> raise Notation_ops.No_match @@ -540,7 +540,7 @@ let uninterp_prim_token_cases_pattern c = let availability_of_prim_token n printer_scope local_scopes = let f scope = - try ignore (Hashtbl.find prim_token_interpreter_tab scope Loc.ghost n); true + try ignore ((Hashtbl.find prim_token_interpreter_tab scope) n); true with Not_found -> false in let scopes = make_current_scopes local_scopes in Option.map snd (find_without_delimiters f (Some printer_scope,None) scopes) @@ -822,7 +822,7 @@ let pr_scope_classes sc = let pr_notation_info prglob ntn c = str "\"" ++ str ntn ++ str "\" := " ++ - prglob (Notation_ops.glob_constr_of_notation_constr Loc.ghost c) + prglob (Notation_ops.glob_constr_of_notation_constr c) let pr_named_scope prglob scope sc = (if String.equal scope default_scope then @@ -890,25 +890,25 @@ let global_reference_of_notation test (ntn,(sc,c,_)) = Some (ntn,sc,ref) | _ -> None -let error_ambiguous_notation loc _ntn = - user_err ~loc (str "Ambiguous notation.") +let error_ambiguous_notation ?loc _ntn = + user_err ?loc (str "Ambiguous notation.") -let error_notation_not_reference loc ntn = - user_err ~loc +let error_notation_not_reference ?loc ntn = + user_err ?loc (str "Unable to interpret " ++ quote (str ntn) ++ str " as a reference.") -let interp_notation_as_global_reference loc test ntn sc = +let interp_notation_as_global_reference ?loc test ntn sc = let scopes = match sc with | Some sc -> - let scope = find_scope (find_delimiters_scope Loc.ghost sc) in + let scope = find_scope (find_delimiters_scope sc) in String.Map.add sc scope String.Map.empty | None -> !scope_map in let ntns = browse_notation true ntn scopes in let refs = List.map (global_reference_of_notation test) ntns in match Option.List.flatten refs with | [_,_,ref] -> ref - | [] -> error_notation_not_reference loc ntn + | [] -> error_notation_not_reference ?loc ntn | refs -> let f (ntn,sc,ref) = let def = find_default ntn !scope_stack in @@ -918,8 +918,8 @@ let interp_notation_as_global_reference loc test ntn sc = in match List.filter f refs with | [_,_,ref] -> ref - | [] -> error_notation_not_reference loc ntn - | _ -> error_ambiguous_notation loc ntn + | [] -> error_notation_not_reference ?loc ntn + | _ -> error_ambiguous_notation ?loc ntn let locate_notation prglob ntn scope = let ntns = factorize_entries (browse_notation false ntn !scope_map) in diff --git a/interp/notation.mli b/interp/notation.mli index 300480ff1c..d271a88fe7 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -55,7 +55,7 @@ val find_scope : scope_name -> scope val declare_delimiters : scope_name -> delimiters -> unit val remove_delimiters : scope_name -> unit -val find_delimiters_scope : Loc.t -> delimiters -> scope_name +val find_delimiters_scope : ?loc:Loc.t -> delimiters -> scope_name (** {6 Declare and uses back and forth an interpretation of primitive token } *) @@ -69,7 +69,7 @@ type required_module = full_path * string list type cases_pattern_status = bool (** true = use prim token in patterns *) type 'a prim_token_interpreter = - Loc.t -> 'a -> glob_constr + ?loc:Loc.t -> 'a -> glob_constr type 'a prim_token_uninterpreter = glob_constr list * (glob_constr -> 'a option) * cases_pattern_status @@ -83,11 +83,10 @@ val declare_string_interpreter : scope_name -> required_module -> (** Return the [term]/[cases_pattern] bound to a primitive token in a given scope context*) -val interp_prim_token : Loc.t -> prim_token -> local_scopes -> +val interp_prim_token : ?loc:Loc.t -> prim_token -> local_scopes -> glob_constr * (notation_location * scope_name option) - (* This function returns a glob_const representing a pattern *) -val interp_prim_token_cases_pattern_expr : Loc.t -> (global_reference -> unit) -> prim_token -> +val interp_prim_token_cases_pattern_expr : ?loc:Loc.t -> (global_reference -> unit) -> prim_token -> local_scopes -> glob_constr * (notation_location * scope_name option) (** Return the primitive token associated to a [term]/[cases_pattern]; @@ -116,7 +115,7 @@ val declare_notation_interpretation : notation -> scope_name option -> val declare_uninterpretation : interp_rule -> interpretation -> unit (** Return the interpretation bound to a notation *) -val interp_notation : Loc.t -> notation -> local_scopes -> +val interp_notation : ?loc:Loc.t -> notation -> local_scopes -> interpretation * (notation_location * scope_name option) type notation_rule = interp_rule * interpretation * int option @@ -139,7 +138,7 @@ val level_of_notation : notation -> level (** raise [Not_found] if no level *) (** {6 Miscellaneous} *) -val interp_notation_as_global_reference : Loc.t -> (global_reference -> bool) -> +val interp_notation_as_global_reference : ?loc:Loc.t -> (global_reference -> bool) -> notation -> delimiters option -> global_reference (** Checks for already existing notations *) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index d08fb107be..8e876ec16d 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -22,31 +22,6 @@ open Notation_term (**********************************************************************) (* Utilities *) -let on_true_do b f c = if b then (f c; b) else b - -let compare_glob_constr f add t1 t2 = match t1,t2 with - | GRef (_,r1,_), GRef (_,r2,_) -> eq_gr r1 r2 - | GVar (_,v1), GVar (_,v2) -> on_true_do (Id.equal v1 v2) add (Name v1) - | GApp (_,f1,l1), GApp (_,f2,l2) -> f f1 f2 && List.for_all2eq f l1 l2 - | GLambda (_,na1,bk1,ty1,c1), GLambda (_,na2,bk2,ty2,c2) - when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 -> - on_true_do (f ty1 ty2 && f c1 c2) add na1 - | GProd (_,na1,bk1,ty1,c1), GProd (_,na2,bk2,ty2,c2) - when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 -> - on_true_do (f ty1 ty2 && f c1 c2) add na1 - | GHole _, GHole _ -> true - | GSort (_,s1), GSort (_,s2) -> Miscops.glob_sort_eq s1 s2 - | GLetIn (_,na1,b1,t1,c1), GLetIn (_,na2,b2,t2,c2) when Name.equal na1 na2 -> - on_true_do (f b1 b2 && f c1 c2) add na1 - | (GCases _ | GRec _ - | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _),_ - | _,(GCases _ | GRec _ - | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _) - -> error "Unsupported construction in recursive notations." - | (GRef _ | GVar _ | GApp _ | GLambda _ | GProd _ - | GHole _ | GSort _ | GLetIn _), _ - -> false - let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with | NRef gr1, NRef gr2 -> eq_gr gr1 gr2 | NVar id1, NVar id2 -> Int.equal (List.index Id.equal id1 vars1) (List.index Id.equal id2 vars2) @@ -112,65 +87,68 @@ let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with (* Re-interpret a notation as a glob_constr, taking care of binders *) let name_to_ident = function - | Anonymous -> CErrors.error "This expression should be a simple identifier." + | Anonymous -> CErrors.user_err Pp.(str "This expression should be a simple identifier.") | Name id -> id let to_id g e id = let e,na = g e (Name id) in e,name_to_ident na -let rec cases_pattern_fold_map loc g e = function - | PatVar (_,na) -> - let e',na' = g e na in e', PatVar (loc,na') - | PatCstr (_,cstr,patl,na) -> +let rec cases_pattern_fold_map ?loc g e = CAst.with_val (function + | PatVar na -> + let e',na' = g e na in e', CAst.make ?loc @@ PatVar na' + | PatCstr (cstr,patl,na) -> let e',na' = g e na in - let e',patl' = List.fold_map (cases_pattern_fold_map loc g) e patl in - e', PatCstr (loc,cstr,patl',na') + let e',patl' = List.fold_map (cases_pattern_fold_map ?loc g) e patl in + e', CAst.make ?loc @@ PatCstr (cstr,patl',na') + ) let subst_binder_type_vars l = function | Evar_kinds.BinderType (Name id) -> let id = - try match Id.List.assoc id l with GVar(_,id') -> id' | _ -> id + try match Id.List.assoc id l with { CAst.v = GVar id' } -> id' | _ -> id with Not_found -> id in Evar_kinds.BinderType (Name id) | e -> e -let rec subst_glob_vars l = function - | GVar (_,id) as r -> (try Id.List.assoc id l with Not_found -> r) - | GProd (loc,Name id,bk,t,c) -> +let rec subst_glob_vars l gc = CAst.map (function + | GVar id as r -> (try (Id.List.assoc id l).CAst.v with Not_found -> r) + | GProd (Name id,bk,t,c) -> let id = - try match Id.List.assoc id l with GVar(_,id') -> id' | _ -> id + try match Id.List.assoc id l with { CAst.v = GVar id' } -> id' | _ -> id with Not_found -> id in - GProd (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c) - | GLambda (loc,Name id,bk,t,c) -> + GProd (Name id,bk,subst_glob_vars l t,subst_glob_vars l c) + | GLambda (Name id,bk,t,c) -> let id = - try match Id.List.assoc id l with GVar(_,id') -> id' | _ -> id + try match Id.List.assoc id l with { CAst.v = GVar id' } -> id' | _ -> id with Not_found -> id in - GLambda (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c) - | GHole (loc,x,naming,arg) -> GHole (loc,subst_binder_type_vars l x,naming,arg) - | r -> map_glob_constr (subst_glob_vars l) r (* assume: id is not binding *) + GLambda (Name id,bk,subst_glob_vars l t,subst_glob_vars l c) + | GHole (x,naming,arg) -> GHole (subst_binder_type_vars l x,naming,arg) + | _ -> (map_glob_constr (subst_glob_vars l) gc).CAst.v (* assume: id is not binding *) + ) gc let ldots_var = Id.of_string ".." -let glob_constr_of_notation_constr_with_binders loc g f e = function - | NVar id -> GVar (loc,id) - | NApp (a,args) -> GApp (loc,f e a, List.map (f e) args) +let glob_constr_of_notation_constr_with_binders ?loc g f e nc = + let lt x = CAst.make ?loc x in lt @@ match nc with + | NVar id -> GVar id + | NApp (a,args) -> GApp (f e a, List.map (f e) args) | NList (x,y,iter,tail,swap) -> let t = f e tail in let it = f e iter in - let innerl = (ldots_var,t)::(if swap then [] else [x,GVar(loc,y)]) in - let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in - let outerl = (ldots_var,inner)::(if swap then [x,GVar(loc,y)] else []) in - subst_glob_vars outerl it + let innerl = (ldots_var,t)::(if swap then [] else [x, lt @@ GVar y]) in + let inner = lt @@ GApp (lt @@ GVar (ldots_var),[subst_glob_vars innerl it]) in + let outerl = (ldots_var,inner)::(if swap then [x, lt @@ GVar y] else []) in + (subst_glob_vars outerl it).CAst.v | NBinderList (x,y,iter,tail) -> let t = f e tail in let it = f e iter in - let innerl = [(ldots_var,t);(x,GVar(loc,y))] in - let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in + let innerl = [(ldots_var,t);(x, lt @@ GVar y)] in + let inner = lt @@ GApp (lt @@ GVar ldots_var,[subst_glob_vars innerl it]) in let outerl = [(ldots_var,inner)] in - subst_glob_vars outerl it + (subst_glob_vars outerl it).CAst.v | NLambda (na,ty,c) -> - let e',na = g e na in GLambda (loc,na,Explicit,f e ty,f e' c) + let e',na = g e na in GLambda (na,Explicit,f e ty,f e' c) | NProd (na,ty,c) -> - let e',na = g e na in GProd (loc,na,Explicit,f e ty,f e' c) + let e',na = g e na in GProd (na,Explicit,f e ty,f e' c) | NLetIn (na,b,t,c) -> - let e',na = g e na in GLetIn (loc,na,f e b,Option.map (f e) t,f e' c) + let e',na = g e na in GLetIn (na,f e b,Option.map (f e) t,f e' c) | NCases (sty,rtntypopt,tml,eqnl) -> let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') -> let e',t' = match t with @@ -178,36 +156,36 @@ let glob_constr_of_notation_constr_with_binders loc g f e = function | Some (ind,nal) -> let e',nal' = List.fold_right (fun na (e',nal) -> let e',na' = g e' na in e',na'::nal) nal (e',[]) in - e',Some (loc,ind,nal') in + e',Some (Loc.tag ?loc (ind,nal')) in let e',na' = g e' na in (e',(f e tm,(na',t'))::tml')) tml (e,[]) in - let fold (idl,e) na = let (e,na) = g e na in ((name_cons na idl,e),na) in + let fold (idl,e) na = let (e,na) = g e na in ((Name.cons na idl,e),na) in let eqnl' = List.map (fun (patl,rhs) -> let ((idl,e),patl) = - List.fold_map (cases_pattern_fold_map loc fold) ([],e) patl in - (loc,idl,patl,f e rhs)) eqnl in - GCases (loc,sty,Option.map (f e') rtntypopt,tml',eqnl') + List.fold_map (cases_pattern_fold_map ?loc fold) ([],e) patl in + Loc.tag (idl,patl,f e rhs)) eqnl in + GCases (sty,Option.map (f e') rtntypopt,tml',eqnl') | NLetTuple (nal,(na,po),b,c) -> let e',nal = List.fold_map g e nal in let e'',na = g e na in - GLetTuple (loc,nal,(na,Option.map (f e'') po),f e b,f e' c) + GLetTuple (nal,(na,Option.map (f e'') po),f e b,f e' c) | NIf (c,(na,po),b1,b2) -> let e',na = g e na in - GIf (loc,f e c,(na,Option.map (f e') po),f e b1,f e b2) + GIf (f e c,(na,Option.map (f e') po),f e b1,f e b2) | NRec (fk,idl,dll,tl,bl) -> let e,dll = Array.fold_map (List.fold_map (fun e (na,oc,b) -> let e,na = g e na in (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in let e',idl = Array.fold_map (to_id g) e idl in - GRec (loc,fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl) - | NCast (c,k) -> GCast (loc,f e c,Miscops.map_cast_type (f e) k) - | NSort x -> GSort (loc,x) - | NHole (x, naming, arg) -> GHole (loc, x, naming, arg) - | NRef x -> GRef (loc,x,None) + GRec (fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl) + | NCast (c,k) -> GCast (f e c,Miscops.map_cast_type (f e) k) + | NSort x -> GSort x + | NHole (x, naming, arg) -> GHole (x, naming, arg) + | NRef x -> GRef (x,None) -let glob_constr_of_notation_constr loc x = +let glob_constr_of_notation_constr ?loc x = let rec aux () x = - glob_constr_of_notation_constr_with_binders loc (fun () id -> ((),id)) aux () x + glob_constr_of_notation_constr_with_binders ?loc (fun () id -> ((),id)) aux () x in aux () x (******************************************************************************) @@ -218,14 +196,15 @@ let add_name r = function Anonymous -> () | Name id -> add_id r id let split_at_recursive_part c = let sub = ref None in + let open CAst in let rec aux = function - | GApp (loc0,GVar(loc,v),c::l) when Id.equal v ldots_var -> + | { loc = loc0; v = GApp ({ loc; v = GVar v },c::l) } when Id.equal v ldots_var -> (* *) begin match !sub with | None -> let () = sub := Some c in begin match l with - | [] -> GVar (loc, ldots_var) - | _ :: _ -> GApp (loc0, GVar (loc, ldots_var), l) + | [] -> CAst.make ?loc @@ GVar ldots_var + | _ :: _ -> CAst.make ?loc:loc0 @@ GApp (CAst.make ?loc @@ GVar ldots_var, l) end | Some _ -> (* Not narrowed enough to find only one recursive part *) @@ -236,14 +215,17 @@ let split_at_recursive_part c = match !sub with | None -> (* No recursive pattern found *) raise Not_found | Some c -> - match outer_iterator with - | GVar (_,v) when Id.equal v ldots_var -> (* Not enough context *) raise Not_found + match outer_iterator.v with + | GVar v when Id.equal v ldots_var -> (* Not enough context *) raise Not_found | _ -> outer_iterator, c -let subtract_loc loc1 loc2 = Loc.make_loc (fst (Loc.unloc loc1),fst (Loc.unloc loc2)-1) +let subtract_loc loc1 loc2 = + let l1 = fst (Option.cata Loc.unloc (0,0) loc1) in + let l2 = fst (Option.cata Loc.unloc (0,0) loc2) in + Some (Loc.make_loc (l1,l2-1)) -let check_is_hole id = function GHole _ -> () | t -> - user_err ~loc:(loc_of_glob_constr t) +let check_is_hole id = function { CAst.v = GHole _ } -> () | t -> + user_err ?loc:(loc_of_glob_constr t) (strbrk "In recursive notation with binders, " ++ pr_id id ++ strbrk " is expected to come without type.") @@ -254,21 +236,22 @@ type recursive_pattern_kind = | RecursiveBinders of glob_constr * glob_constr let compare_recursive_parts found f f' (iterator,subc) = + let open CAst in let diff = ref None in let terminator = ref None in - let rec aux c1 c2 = match c1,c2 with - | GVar(_,v), term when Id.equal v ldots_var -> + let rec aux c1 c2 = match c1.v, c2.v with + | GVar v, term when Id.equal v ldots_var -> (* We found the pattern *) assert (match !terminator with None -> true | Some _ -> false); - terminator := Some term; + terminator := Some c2; true - | GApp (_,GVar(_,v),l1), GApp (_,term,l2) when Id.equal v ldots_var -> + | GApp ({ v = GVar v },l1), GApp (term, l2) when Id.equal v ldots_var -> (* We found the pattern, but there are extra arguments *) (* (this allows e.g. alternative (recursive) notation of application) *) assert (match !terminator with None -> true | Some _ -> false); terminator := Some term; List.for_all2eq aux l1 l2 - | GVar (_,x), GVar (_,y) when not (Id.equal x y) -> + | GVar x, GVar y when not (Id.equal x y) -> (* We found the position where it differs *) let lassoc = match !terminator with None -> false | Some _ -> true in let x,y = if lassoc then y,x else x,y in @@ -278,8 +261,8 @@ let compare_recursive_parts found f f' (iterator,subc) = true | Some _ -> false end - | GLambda (_,Name x,_,t_x,c), GLambda (_,Name y,_,t_y,term) - | GProd (_,Name x,_,t_x,c), GProd (_,Name y,_,t_y,term) -> + | GLambda (Name x,_,t_x,c), GLambda (Name y,_,t_y,term) + | GProd (Name x,_,t_x,c), GProd (Name y,_,t_y,term) when not (Id.equal x y) -> (* We found a binding position where it differs *) begin match !diff with | None -> @@ -288,14 +271,14 @@ let compare_recursive_parts found f f' (iterator,subc) = | Some _ -> false end | _ -> - compare_glob_constr aux (add_name found) c1 c2 in + mk_glob_constr_eq aux c1 c2 in if aux iterator subc then match !diff with | None -> let loc1 = loc_of_glob_constr iterator in let loc2 = loc_of_glob_constr (Option.get !terminator) in (* Here, we would need a loc made of several parts ... *) - user_err ~loc:(subtract_loc loc1 loc2) + user_err ?loc:(subtract_loc loc1 loc2) (str "Both ends of the recursive pattern are the same.") | Some (x,y,RecursiveTerms lassoc) -> let newfound,x,y,lassoc = @@ -311,13 +294,13 @@ let compare_recursive_parts found f f' (iterator,subc) = (pi1 !found, (x,y) :: pi2 !found, pi3 !found),x,y,lassoc in let iterator = f' (if lassoc then iterator - else subst_glob_vars [x,GVar(Loc.ghost,y)] iterator) in + else subst_glob_vars [x, CAst.make @@ GVar y] iterator) in (* found have been collected by compare_constr *) found := newfound; NList (x,y,iterator,f (Option.get !terminator),lassoc) | Some (x,y,RecursiveBinders (t_x,t_y)) -> let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in - let iterator = f' (subst_glob_vars [x,GVar(Loc.ghost,y)] iterator) in + let iterator = f' (subst_glob_vars [x, CAst.make @@ GVar y] iterator) in (* found have been collected by compare_constr *) found := newfound; check_is_hole x t_x; @@ -335,52 +318,52 @@ let notation_constr_and_vars_of_glob_constr a = try compare_recursive_parts found aux aux' (split_at_recursive_part c) with Not_found -> found := keepfound; - match c with - | GApp (_,GVar (loc,f),[c]) when Id.equal f ldots_var -> + match c.CAst.v with + | GApp ({ CAst.v = GVar f; loc},[c]) when Id.equal f ldots_var -> (* Fall on the second part of the recursive pattern w/o having found the first part *) - user_err ~loc + user_err ?loc (str "Cannot find where the recursive pattern starts.") - | c -> + | _c -> aux' c - and aux' = function - | GVar (_,id) -> add_id found id; NVar id - | GApp (_,g,args) -> NApp (aux g, List.map aux args) - | GLambda (_,na,bk,ty,c) -> add_name found na; NLambda (na,aux ty,aux c) - | GProd (_,na,bk,ty,c) -> add_name found na; NProd (na,aux ty,aux c) - | GLetIn (_,na,b,t,c) -> add_name found na; NLetIn (na,aux b,Option.map aux t,aux c) - | GCases (_,sty,rtntypopt,tml,eqnl) -> - let f (_,idl,pat,rhs) = List.iter (add_id found) idl; (pat,aux rhs) in + and aux' x = CAst.with_val (function + | GVar id -> add_id found id; NVar id + | GApp (g,args) -> NApp (aux g, List.map aux args) + | GLambda (na,bk,ty,c) -> add_name found na; NLambda (na,aux ty,aux c) + | GProd (na,bk,ty,c) -> add_name found na; NProd (na,aux ty,aux c) + | GLetIn (na,b,t,c) -> add_name found na; NLetIn (na,aux b,Option.map aux t, aux c) + | GCases (sty,rtntypopt,tml,eqnl) -> + let f (_,(idl,pat,rhs)) = List.iter (add_id found) idl; (pat,aux rhs) in NCases (sty,Option.map aux rtntypopt, List.map (fun (tm,(na,x)) -> add_name found na; Option.iter - (fun (_,_,nl) -> List.iter (add_name found) nl) x; - (aux tm,(na,Option.map (fun (_,ind,nal) -> (ind,nal)) x))) tml, + (fun (_,(_,nl)) -> List.iter (add_name found) nl) x; + (aux tm,(na,Option.map (fun (_,(ind,nal)) -> (ind,nal)) x))) tml, List.map f eqnl) - | GLetTuple (loc,nal,(na,po),b,c) -> + | GLetTuple (nal,(na,po),b,c) -> add_name found na; List.iter (add_name found) nal; NLetTuple (nal,(na,Option.map aux po),aux b,aux c) - | GIf (loc,c,(na,po),b1,b2) -> + | GIf (c,(na,po),b1,b2) -> add_name found na; NIf (aux c,(na,Option.map aux po),aux b1,aux b2) - | GRec (_,fk,idl,dll,tl,bl) -> + | GRec (fk,idl,dll,tl,bl) -> Array.iter (add_id found) idl; let dll = Array.map (List.map (fun (na,bk,oc,b) -> if bk != Explicit then - error "Binders marked as implicit not allowed in notations."; + user_err Pp.(str "Binders marked as implicit not allowed in notations."); add_name found na; (na,Option.map aux oc,aux b))) dll in NRec (fk,idl,dll,Array.map aux tl,Array.map aux bl) - | GCast (_,c,k) -> NCast (aux c,Miscops.map_cast_type aux k) - | GSort (_,s) -> NSort s - | GHole (_,w,naming,arg) -> + | GCast (c,k) -> NCast (aux c,Miscops.map_cast_type aux k) + | GSort s -> NSort s + | GHole (w,naming,arg) -> if arg != None then has_ltac := true; NHole (w, naming, arg) - | GRef (_,r,_) -> NRef r + | GRef (r,_) -> NRef r | GEvar _ | GPatVar _ -> - error "Existential variables not allowed in notations." - + user_err Pp.(str "Existential variables not allowed in notations.") + ) x in let t = aux a in (* Side effect *) @@ -407,9 +390,9 @@ let check_variables_and_reversibility nenv (found,foundrec,foundrecbinding) = Id.List.mem_assoc_sym x foundrec || Id.List.mem_assoc_sym x foundrecbinding then - error + user_err Pp.(str (Id.to_string x ^ - " should not be bound in a recursive pattern of the right-hand side.") + " should not be bound in a recursive pattern of the right-hand side.")) else injective := false in let check_pair s x y where = @@ -451,13 +434,13 @@ let notation_constr_of_constr avoiding t = notation_constr_of_glob_constr nenv t let rec subst_pat subst pat = - match pat with + match pat.CAst.v with | PatVar _ -> pat - | PatCstr (loc,((kn,i),j),cpl,n) -> + | PatCstr (((kn,i),j),cpl,n) -> let kn' = subst_mind subst kn and cpl' = List.smartmap (subst_pat subst) cpl in - if kn' == kn && cpl' == cpl then pat else - PatCstr (loc,((kn',i),j),cpl',n) + if kn' == kn && cpl' == cpl then pat else + CAst.make ?loc:pat.CAst.loc @@ PatCstr (((kn',i),j),cpl',n) let rec subst_notation_constr subst bound raw = match raw with @@ -587,9 +570,9 @@ let abstract_return_type_context pi mklam tml rtno = rtno let abstract_return_type_context_glob_constr = - abstract_return_type_context (fun (_,_,nal) -> nal) - (fun na c -> - GLambda(Loc.ghost,na,Explicit,GHole(Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None),c)) + abstract_return_type_context (fun (_,(_,nal)) -> nal) + (fun na c -> CAst.make @@ + GLambda(na,Explicit,CAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None),c)) let abstract_return_type_context_notation_constr = abstract_return_type_context snd @@ -661,18 +644,19 @@ let add_binding_env alp (terms,onlybinders,termlists,binderlists) var v = let add_bindinglist_env (terms,onlybinders,termlists,binderlists) x bl = (terms,onlybinders,termlists,(x,bl)::binderlists) -let rec pat_binder_of_term = function - | GVar (loc, id) -> PatVar (loc, Name id) - | GApp (loc, GRef (_,ConstructRef cstr,_), l) -> +let rec pat_binder_of_term t = CAst.map (function + | GVar id -> PatVar (Name id) + | GApp ({ CAst.v = GRef (ConstructRef cstr,_)}, l) -> let nparams = Inductiveops.inductive_nparams (fst cstr) in let _,l = List.chop nparams l in - PatCstr (loc, cstr, List.map pat_binder_of_term l, Anonymous) + PatCstr (cstr, List.map pat_binder_of_term l, Anonymous) | _ -> raise No_match + ) t let bind_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var v = try let v' = Id.List.assoc var terms in - match v, v' with + match CAst.(v.v, v'.v) with | GHole _, _ -> sigma | _, GHole _ -> let sigma = Id.List.remove_assoc var terms,onlybinders,termlists,binderlists in @@ -686,7 +670,7 @@ let bind_termlist_env alp (terms,onlybinders,termlists,binderlists as sigma) var try let vl' = Id.List.assoc var termlists in let unify_term v v' = - match v, v' with + match CAst.(v.v, v'.v) with | GHole _, _ -> v' | _, GHole _ -> v | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v' else raise No_match in @@ -703,7 +687,7 @@ let bind_termlist_env alp (terms,onlybinders,termlists,binderlists as sigma) var let bind_term_as_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var id = try match Id.List.assoc var terms with - | GVar (_,id') -> + | { CAst.v = GVar id' } -> (if not (Id.equal id id') then (fst alp,(id,id')::snd alp) else alp), sigma | _ -> anomaly (str "A term which can be a binder has to be a variable") @@ -711,7 +695,7 @@ let bind_term_as_binding_env alp (terms,onlybinders,termlists,binderlists as sig (* The matching against a term allowing to find the instance has not been found yet *) (* If it will be a different name, we shall unfortunately fail *) (* TODO: look at the consequences for alp *) - alp, add_env alp sigma var (GVar (Loc.ghost,id)) + alp, add_env alp sigma var (CAst.make @@ GVar id) let bind_binding_as_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var id = try @@ -738,16 +722,17 @@ let bind_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var else (fst alp,(id1,id2)::snd alp),sigma with Not_found -> alp, add_binding_env alp sigma var v -let rec map_cases_pattern_name_left f = function - | PatVar (loc,na) -> PatVar (loc,f na) - | PatCstr (loc,c,l,na) -> PatCstr (loc,c,List.map_left (map_cases_pattern_name_left f) l,f na) +let rec map_cases_pattern_name_left f = CAst.map (function + | PatVar na -> PatVar (f na) + | PatCstr (c,l,na) -> PatCstr (c,List.map_left (map_cases_pattern_name_left f) l,f na) + ) -let rec fold_cases_pattern_eq f x p p' = match p, p' with - | PatVar (loc,na), PatVar (_,na') -> let x,na = f x na na' in x, PatVar (loc,na) - | PatCstr (loc,c,l,na), PatCstr (_,c',l',na') when eq_constructor c c' -> +let rec fold_cases_pattern_eq f x p p' = let open CAst in match p, p' with + | { loc; v = PatVar na}, { v = PatVar na' } -> let x,na = f x na na' in x, CAst.make ?loc @@ PatVar na + | { loc; v = PatCstr (c,l,na)}, { v = PatCstr (c',l',na') } when eq_constructor c c' -> let x,l = fold_cases_pattern_list_eq f x l l' in let x,na = f x na na' in - x, PatCstr (loc,c,l,na) + x, CAst.make ?loc @@ PatCstr (c,l,na) | _ -> failwith "Not equal" and fold_cases_pattern_list_eq f x pl pl' = match pl, pl' with @@ -758,9 +743,9 @@ and fold_cases_pattern_list_eq f x pl pl' = match pl, pl' with x, p :: pl | _ -> assert false -let rec cases_pattern_eq p1 p2 = match p1, p2 with -| PatVar (_, na1), PatVar (_, na2) -> Name.equal na1 na2 -| PatCstr (_, c1, pl1, na1), PatCstr (_, c2, pl2, na2) -> +let rec cases_pattern_eq p1 p2 = match CAst.(p1.v, p2.v) with +| PatVar na1, PatVar na2 -> Name.equal na1 na2 +| PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && Name.equal na1 na2 | _ -> false @@ -779,7 +764,7 @@ let bind_bindinglist_env alp (terms,onlybinders,termlists,binderlists as sigma) let unify_pat alp p p' = try fold_cases_pattern_eq unify_name alp p p' with Failure _ -> raise No_match in let unify_term alp v v' = - match v, v' with + match CAst.(v.v, v'.v) with | GHole _, _ -> v' | _, GHole _ -> v | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v else raise No_match in @@ -790,16 +775,17 @@ let bind_bindinglist_env alp (terms,onlybinders,termlists,binderlists as sigma) | None, None -> None in let unify_binding_kind bk bk' = if bk == bk' then bk' else raise No_match in let unify_binder alp b b' = - match b, b' with - | GLocalAssum (loc,na,bk,t), GLocalAssum (_,na',bk',t') -> + let loc, loc' = CAst.(b.loc, b'.loc) in + match CAst.(b.v, b'.v) with + | GLocalAssum (na,bk,t), GLocalAssum (na',bk',t') -> let alp, na = unify_name alp na na' in - alp, GLocalAssum (loc, na, unify_binding_kind bk bk', unify_term alp t t') - | GLocalDef (loc,na,bk,c,t), GLocalDef (_,na',bk',c',t') -> + alp, CAst.make ?loc @@ GLocalAssum (na, unify_binding_kind bk bk', unify_term alp t t') + | GLocalDef (na,bk,c,t), GLocalDef (na',bk',c',t') -> let alp, na = unify_name alp na na' in - alp, GLocalDef (loc, na, unify_binding_kind bk bk', unify_term alp c c', unify_opt_term alp t t') - | GLocalPattern (loc,(p,ids),id,bk,t), GLocalPattern (_,(p',_),_,bk',t') -> + alp, CAst.make ?loc @@ GLocalDef (na, unify_binding_kind bk bk', unify_term alp c c', unify_opt_term alp t t') + | GLocalPattern ((p,ids),id,bk,t), GLocalPattern ((p',_),_,bk',t') -> let alp, p = unify_pat alp p p' in - alp, GLocalPattern (loc, (p,ids), id, unify_binding_kind bk bk', unify_term alp t t') + alp, CAst.make ?loc @@ GLocalPattern ((p,ids), id, unify_binding_kind bk bk', unify_term alp t t') | _ -> raise No_match in let rec unify alp bl bl' = match bl, bl' with @@ -826,18 +812,18 @@ let bind_bindinglist_as_term_env alp (terms,onlybinders,termlists,binderlists) v let unify_pat p p' = if cases_pattern_eq (map_cases_pattern_name_left (name_app (rename_var (snd alp))) p) p' then p' else raise No_match in - let unify_term_binder c b' = + let unify_term_binder c = CAst.(map (fun b' -> match c, b' with - | GVar (loc, id), GLocalAssum (_, na', bk', t') -> - GLocalAssum (loc, unify_id id na', bk', t') - | c, GLocalPattern (loc, (p',ids), id, bk', t') -> + | { v = GVar id}, GLocalAssum (na', bk', t') -> + GLocalAssum (unify_id id na', bk', t') + | c, GLocalPattern ((p',ids), id, bk', t') -> let p = pat_binder_of_term c in - GLocalPattern (loc, (unify_pat p p',ids), id, bk', t') - | _ -> raise No_match in + GLocalPattern ((unify_pat p p',ids), id, bk', t') + | _ -> raise No_match )) in let rec unify cl bl' = match cl, bl' with | [], [] -> [] - | c :: cl, GLocalDef (_, _, _, _, t) :: bl' -> unify cl bl' + | c :: cl, { CAst.v = GLocalDef ( _, _, _, t) } :: bl' -> unify cl bl' | c :: cl, b' :: bl' -> unify_term_binder c b' :: unify cl bl' | _ -> raise No_match in let bl = unify cl bl' in @@ -879,9 +865,9 @@ let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with | _ -> raise No_match let rec match_cases_pattern_binders metas acc pat1 pat2 = - match (pat1,pat2) with - | PatVar (_,na1), PatVar (_,na2) -> match_names metas acc na1 na2 - | PatCstr (_,c1,patl1,na1), PatCstr (_,c2,patl2,na2) + match CAst.(pat1.v, pat2.v) with + | PatVar na1, PatVar na2 -> match_names metas acc na1 na2 + | PatCstr (c1,patl1,na1), PatCstr (c2,patl2,na2) when eq_constructor c1 c2 && Int.equal (List.length patl1) (List.length patl2) -> List.fold_left2 (match_cases_pattern_binders metas) (match_names metas acc na1 na2) patl1 patl2 @@ -889,21 +875,22 @@ let rec match_cases_pattern_binders metas acc pat1 pat2 = let glue_letin_with_decls = true -let rec match_iterated_binders islambda decls = function - | GLambda (loc,Name p,bk,t,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,ids,[cp],b)])) +let rec match_iterated_binders islambda decls bi = CAst.(with_loc_val (fun ?loc -> function + | GLambda (Name p,bk,t, { v = GCases (LetPatternStyle,None,[({ v = GVar e },_)],[(_,(ids,[cp],b))])}) when islambda && Id.equal p e -> - match_iterated_binders islambda (GLocalPattern (loc,(cp,ids),p,bk,t)::decls) b - | GLambda (loc,na,bk,t,b) when islambda -> - match_iterated_binders islambda (GLocalAssum (loc,na,bk,t)::decls) b - | GProd (loc,Name p,bk,t,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,ids,[cp],b)])) + match_iterated_binders islambda ((CAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b + | GLambda (na,bk,t,b) when islambda -> + match_iterated_binders islambda ((CAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b + | GProd (Name p,bk,t, { v = GCases (LetPatternStyle,None,[({ v = GVar e },_)],[(_,(ids,[cp],b))]) } ) when not islambda && Id.equal p e -> - match_iterated_binders islambda (GLocalPattern (loc,(cp,ids),p,bk,t)::decls) b - | GProd (loc,(Name _ as na),bk,t,b) when not islambda -> - match_iterated_binders islambda (GLocalAssum (loc,na,bk,t)::decls) b - | GLetIn (loc,na,c,t,b) when glue_letin_with_decls -> + match_iterated_binders islambda ((CAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b + | GProd ((Name _ as na),bk,t,b) when not islambda -> + match_iterated_binders islambda ((CAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b + | GLetIn (na,c,t,b) when glue_letin_with_decls -> match_iterated_binders islambda - (GLocalDef (loc,na,Explicit (*?*), c,t)::decls) b - | b -> (decls,b) + ((CAst.make ?loc @@ GLocalDef (na,Explicit (*?*), c,t))::decls) b + | b -> (decls, CAst.make ?loc b) + )) bi let remove_sigma x (terms,onlybinders,termlists,binderlists) = (Id.List.remove_assoc x terms,onlybinders,termlists,binderlists) @@ -964,91 +951,92 @@ let does_not_come_from_already_eta_expanded_var = (* The following test is then an approximation of what can be done *) (* optimally (whether other looping situations can occur remains to be *) (* checked). *) - function GVar _ -> false | _ -> true + function { CAst.v = GVar _ } -> false | _ -> true let rec match_ inner u alp metas sigma a1 a2 = - match (a1,a2) with - + let open CAst in + let loc = a1.loc in + match a1.v, a2 with (* Matching notation variable *) - | r1, NVar id2 when is_term_meta id2 metas -> bind_term_env alp sigma id2 r1 - | GVar (_,id1), NVar id2 when is_onlybinding_meta id2 metas -> bind_binding_as_term_env alp sigma id2 id1 - | r1, NVar id2 when is_bindinglist_meta id2 metas -> bind_term_env alp sigma id2 r1 + | r1, NVar id2 when is_term_meta id2 metas -> bind_term_env alp sigma id2 a1 + | GVar id1, NVar id2 when is_onlybinding_meta id2 metas -> bind_binding_as_term_env alp sigma id2 id1 + | r1, NVar id2 when is_bindinglist_meta id2 metas -> bind_term_env alp sigma id2 a1 (* Matching recursive notations for terms *) | r1, NList (x,y,iter,termin,lassoc) -> - match_termlist (match_hd u alp) alp metas sigma r1 x y iter termin lassoc + match_termlist (match_hd u alp) alp metas sigma a1 x y iter termin lassoc (* "λ p, let 'cp = p in t" -> "λ 'cp, t" *) - | GLambda (loc,Name p,bk,t1,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,ids,[cp],b1)])), + | GLambda (Name p,bk,t1, { v = GCases (LetPatternStyle,None,[({ v = GVar e},_)],[(_,(ids,[cp],b1))])}), NBinderList (x,_,NLambda (Name _id2,_,b2),termin) when Id.equal p e -> - let (decls,b) = match_iterated_binders true [GLocalPattern(loc,(cp,ids),p,bk,t1)] b1 in + let (decls,b) = match_iterated_binders true [CAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t1)] b1 in let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin (* Matching recursive notations for binders: ad hoc cases supporting let-in *) - | GLambda (loc,na1,bk,t1,b1), NBinderList (x,_,NLambda (Name _id2,_,b2),termin)-> - let (decls,b) = match_iterated_binders true [GLocalAssum (loc,na1,bk,t1)] b1 in + | GLambda (na1,bk,t1,b1), NBinderList (x,_,NLambda (Name _id2,_,b2),termin)-> + let (decls,b) = match_iterated_binders true [CAst.make ?loc @@ GLocalAssum (na1,bk,t1)] b1 in (* TODO: address the possibility that termin is a Lambda itself *) let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin (* "∀ p, let 'cp = p in t" -> "∀ 'cp, t" *) - | GProd (loc,Name p,bk,t1,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,ids,[cp],b1)])), + | GProd (Name p,bk,t1, { v = GCases (LetPatternStyle,None,[({ v = GVar e },_)],[(_,(ids,[cp],b1))]) } ), NBinderList (x,_,NProd (Name _id2,_,b2),(NVar v as termin)) when Id.equal p e -> - let (decls,b) = match_iterated_binders true [GLocalPattern (loc,(cp,ids),p,bk,t1)] b1 in + let (decls,b) = match_iterated_binders true [CAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t1)] b1 in let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin - | GProd (loc,na1,bk,t1,b1), NBinderList (x,_,NProd (Name _id2,_,b2),termin) + | GProd (na1,bk,t1,b1), NBinderList (x,_,NProd (Name _id2,_,b2),termin) when na1 != Anonymous -> - let (decls,b) = match_iterated_binders false [GLocalAssum (loc,na1,bk,t1)] b1 in + let (decls,b) = match_iterated_binders false [CAst.make ?loc @@ GLocalAssum (na1,bk,t1)] b1 in (* TODO: address the possibility that termin is a Prod itself *) let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin (* Matching recursive notations for binders: general case *) - | r, NBinderList (x,y,iter,termin) -> - match_binderlist_with_app (match_hd u) alp metas sigma r x y iter termin + | _r, NBinderList (x,y,iter,termin) -> + match_binderlist_with_app (match_hd u) alp metas sigma a1 x y iter termin (* Matching individual binders as part of a recursive pattern *) - | GLambda (loc,Name p,bk,t,GCases (_,LetPatternStyle,None,[(GVar(_,e),_)],[(_,ids,[cp],b1)])), + | GLambda (Name p,bk,t, { v = GCases (LetPatternStyle,None,[({ v = GVar e },_)],[(_,(ids,[cp],b1))])}), NLambda (Name id,_,b2) when is_bindinglist_meta id metas -> - let alp,sigma = bind_bindinglist_env alp sigma id [GLocalPattern (loc,(cp,ids),p,bk,t)] in + let alp,sigma = bind_bindinglist_env alp sigma id [CAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t)] in match_in u alp metas sigma b1 b2 - | GLambda (loc,na,bk,t,b1), NLambda (Name id,_,b2) + | GLambda (na,bk,t,b1), NLambda (Name id,_,b2) when is_bindinglist_meta id metas -> - let alp,sigma = bind_bindinglist_env alp sigma id [GLocalAssum (loc,na,bk,t)] in + let alp,sigma = bind_bindinglist_env alp sigma id [CAst.make ?loc @@ GLocalAssum (na,bk,t)] in match_in u alp metas sigma b1 b2 - | GProd (loc,na,bk,t,b1), NProd (Name id,_,b2) + | GProd (na,bk,t,b1), NProd (Name id,_,b2) when is_bindinglist_meta id metas && na != Anonymous -> - let alp,sigma = bind_bindinglist_env alp sigma id [GLocalAssum (loc,na,bk,t)] in + let alp,sigma = bind_bindinglist_env alp sigma id [CAst.make ?loc @@ GLocalAssum (na,bk,t)] in match_in u alp metas sigma b1 b2 (* Matching compositionally *) - | GVar (_,id1), NVar id2 when alpha_var id1 id2 (fst alp) -> sigma - | GRef (_,r1,_), NRef r2 when (eq_gr r1 r2) -> sigma - | GApp (loc,f1,l1), NApp (f2,l2) -> + | GVar id1, NVar id2 when alpha_var id1 id2 (fst alp) -> sigma + | GRef (r1,_), NRef r2 when (eq_gr r1 r2) -> sigma + | GApp (f1,l1), NApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in let f1,l1,f2,l2 = if n1 < n2 then let l21,l22 = List.chop (n2-n1) l2 in f1,l1, NApp (f2,l21), l22 else if n1 > n2 then - let l11,l12 = List.chop (n1-n2) l1 in GApp (loc,f1,l11),l12, f2,l2 + let l11,l12 = List.chop (n1-n2) l1 in CAst.make ?loc @@ GApp (f1,l11),l12, f2,l2 else f1,l1, f2, l2 in let may_use_eta = does_not_come_from_already_eta_expanded_var f1 in List.fold_left2 (match_ may_use_eta u alp metas) (match_in u alp metas sigma f1 f2) l1 l2 - | GLambda (_,na1,_,t1,b1), NLambda (na2,t2,b2) -> + | GLambda (na1,_,t1,b1), NLambda (na2,t2,b2) -> match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 - | GProd (_,na1,_,t1,b1), NProd (na2,t2,b2) -> + | GProd (na1,_,t1,b1), NProd (na2,t2,b2) -> match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 - | GLetIn (_,na1,b1,_,c1), NLetIn (na2,b2,None,c2) - | GLetIn (_,na1,b1,None,c1), NLetIn (na2,b2,_,c2) -> + | GLetIn (na1,b1,_,c1), NLetIn (na2,b2,None,c2) + | GLetIn (na1,b1,None,c1), NLetIn (na2,b2,_,c2) -> match_binders u alp metas na1 na2 (match_in u alp metas sigma b1 b2) c1 c2 - | GLetIn (_,na1,b1,Some t1,c1), NLetIn (na2,b2,Some t2,c2) -> + | GLetIn (na1,b1,Some t1,c1), NLetIn (na2,b2,Some t2,c2) -> match_binders u alp metas na1 na2 (match_in u alp metas (match_in u alp metas sigma b1 b2) t1 t2) c1 c2 - | GCases (_,sty1,rtno1,tml1,eqnl1), NCases (sty2,rtno2,tml2,eqnl2) + | GCases (sty1,rtno1,tml1,eqnl1), NCases (sty2,rtno2,tml2,eqnl2) when sty1 == sty2 && Int.equal (List.length tml1) (List.length tml2) && Int.equal (List.length eqnl1) (List.length eqnl2) -> @@ -1062,17 +1050,17 @@ let rec match_ inner u alp metas sigma a1 a2 = (fun s (tm1,_) (tm2,_) -> match_in u alp metas s tm1 tm2) sigma tml1 tml2 in List.fold_left2 (match_equations u alp metas) sigma eqnl1 eqnl2 - | GLetTuple (_,nal1,(na1,to1),b1,c1), NLetTuple (nal2,(na2,to2),b2,c2) + | GLetTuple (nal1,(na1,to1),b1,c1), NLetTuple (nal2,(na2,to2),b2,c2) when Int.equal (List.length nal1) (List.length nal2) -> let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in let sigma = match_in u alp metas sigma b1 b2 in let (alp,sigma) = List.fold_left2 (match_names metas) (alp,sigma) nal1 nal2 in match_in u alp metas sigma c1 c2 - | GIf (_,a1,(na1,to1),b1,c1), NIf (a2,(na2,to2),b2,c2) -> + | GIf (a1,(na1,to1),b1,c1), NIf (a2,(na2,to2),b2,c2) -> let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in List.fold_left2 (match_in u alp metas) sigma [a1;b1;c1] [a2;b2;c2] - | GRec (_,fk1,idl1,dll1,tl1,bl1), NRec (fk2,idl2,dll2,tl2,bl2) + | GRec (fk1,idl1,dll1,tl1,bl1), NRec (fk2,idl2,dll2,tl2,bl2) when match_fix_kind fk1 fk2 && Int.equal (Array.length idl1) (Array.length idl2) && Array.for_all2 (fun l1 l2 -> Int.equal (List.length l1) (List.length l2)) dll1 dll2 -> @@ -1086,13 +1074,13 @@ let rec match_ inner u alp metas sigma a1 a2 = let alp,sigma = Array.fold_right2 (fun id1 id2 alsig -> match_names metas alsig (Name id1) (Name id2)) idl1 idl2 (alp,sigma) in Array.fold_left2 (match_in u alp metas) sigma bl1 bl2 - | GCast(_,c1,CastConv t1), NCast (c2,CastConv t2) - | GCast(_,c1,CastVM t1), NCast (c2,CastVM t2) -> + | GCast(c1,CastConv t1), NCast (c2,CastConv t2) + | GCast(c1,CastVM t1), NCast (c2,CastVM t2) -> match_in u alp metas (match_in u alp metas sigma c1 c2) t1 t2 - | GCast(_,c1, CastCoerce), NCast(c2, CastCoerce) -> + | GCast(c1, CastCoerce), NCast(c2, CastCoerce) -> match_in u alp metas sigma c1 c2 - | GSort (_,GType _), NSort (GType _) when not u -> sigma - | GSort (_,s1), NSort s2 when Miscops.glob_sort_eq s1 s2 -> sigma + | GSort (GType _), NSort (GType _) when not u -> sigma + | GSort s1, NSort s2 when Miscops.glob_sort_eq s1 s2 -> sigma | GPatVar _, NHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match | a, NHole _ -> sigma @@ -1102,21 +1090,21 @@ let rec match_ inner u alp metas sigma a1 a2 = otherwise how to ensure it corresponds to a well-typed eta-expansion; we make an exception for types which are metavariables: this is useful e.g. to print "{x:_ & P x}" knowing that notation "{x & P x}" is not defined. *) - | b1, NLambda (Name id as na,(NHole _ | NVar _ as t2),b2) when inner -> + | _b1, NLambda (Name id as na,(NHole _ | NVar _ as t2),b2) when inner -> let avoid = - free_glob_vars b1 @ (* as in Namegen: *) glob_visible_short_qualid b1 in + free_glob_vars a1 @ (* as in Namegen: *) glob_visible_short_qualid a1 in let id' = Namegen.next_ident_away id avoid in - let t1 = GHole(Loc.ghost,Evar_kinds.BinderType (Name id'),Misctypes.IntroAnonymous,None) in + let t1 = CAst.make @@ GHole(Evar_kinds.BinderType (Name id'),Misctypes.IntroAnonymous,None) in let sigma = match t2 with | NHole _ -> sigma | NVar id2 -> bind_term_env alp sigma id2 t1 | _ -> assert false in let (alp,sigma) = if is_bindinglist_meta id metas then - bind_bindinglist_env alp sigma id [GLocalAssum (Loc.ghost,Name id',Explicit,t1)] + bind_bindinglist_env alp sigma id [CAst.make @@ GLocalAssum (Name id',Explicit,t1)] else match_names metas (alp,sigma) (Name id') na in - match_in u alp metas sigma (mkGApp Loc.ghost b1 (GVar (Loc.ghost,id'))) b2 + match_in u alp metas sigma (mkGApp a1 (CAst.make @@ GVar id')) b2 | (GRec _ | GEvar _), _ | _,_ -> raise No_match @@ -1129,7 +1117,7 @@ and match_binders u alp metas na1 na2 sigma b1 b2 = let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in match_in u alp metas sigma b1 b2 -and match_equations u alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) = +and match_equations u alp metas sigma (_,(_,patl1,rhs1)) (patl2,rhs2) = (* patl1 and patl2 have the same length because they respectively correspond to some tml1 and tml2 that have the same length *) let (alp,sigma) = @@ -1137,9 +1125,9 @@ and match_equations u alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) = (alp,sigma) patl1 patl2 in match_in u alp metas sigma rhs1 rhs2 -let term_of_binder = function - | Name id -> GVar (Loc.ghost,id) - | Anonymous -> GHole (Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) +let term_of_binder bi = CAst.make @@ match bi with + | Name id -> GVar id + | Anonymous -> GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) let match_notation_constr u c (metas,pat) = let terms,binders,termlists,binderlists = @@ -1150,7 +1138,7 @@ let match_notation_constr u c (metas,pat) = with Not_found -> (* Happens for binders bound to Anonymous *) (* Find a better way to propagate Anonymous... *) - GVar (Loc.ghost,x) in + CAst.make @@GVar x in List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') -> match typ with | NtnTypeConstr -> @@ -1169,7 +1157,7 @@ let match_notation_constr u c (metas,pat) = let add_patterns_for_params ind l = let mib,_ = Global.lookup_inductive ind in let nparams = mib.Declarations.mind_nparams in - Util.List.addn nparams (PatVar (Loc.ghost,Anonymous)) l + Util.List.addn nparams (CAst.make @@ PatVar Anonymous) l let bind_env_cases_pattern (terms,x,termlists,y as sigma) var v = try @@ -1194,12 +1182,13 @@ let match_cases_pattern_list match_fun metas sigma rest x y iter termin lassoc = (terms,onlybinders,(x,if lassoc then l else List.rev l)::termlists, binderlists) let rec match_cases_pattern metas (terms,(),termlists,() as sigma) a1 a2 = - match (a1,a2) with - | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 r1),(0,[]) - | PatVar (_,Anonymous), NHole _ -> sigma,(0,[]) - | PatCstr (loc,(ind,_ as r1),largs,_), NRef (ConstructRef r2) when eq_constructor r1 r2 -> + let open CAst in + match a1.v, a2 with + | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(0,[]) + | PatVar Anonymous, NHole _ -> sigma,(0,[]) + | PatCstr ((ind,_ as r1),largs,_), NRef (ConstructRef r2) when eq_constructor r1 r2 -> sigma,(0,add_patterns_for_params (fst r1) largs) - | PatCstr (loc,(ind,_ as r1),args1,_), NApp (NRef (ConstructRef r2),l2) + | PatCstr ((ind,_ as r1),args1,_), NApp (NRef (ConstructRef r2),l2) when eq_constructor r1 r2 -> let l1 = add_patterns_for_params (fst r1) args1 in let le2 = List.length l2 in @@ -1211,7 +1200,7 @@ let rec match_cases_pattern metas (terms,(),termlists,() as sigma) a1 a2 = (List.fold_left2 (match_cases_pattern_no_more_args metas) sigma l1' l2),(le2,more_args) | r1, NList (x,y,iter,termin,lassoc) -> (match_cases_pattern_list (match_cases_pattern_no_more_args) - metas (terms,(),termlists,()) r1 x y iter termin lassoc),(0,[]) + metas (terms,(),termlists,()) a1 x y iter termin lassoc),(0,[]) | _ -> raise No_match and match_cases_pattern_no_more_args metas sigma a1 a2 = diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index a61ba172ee..64f811dc20 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -33,12 +33,12 @@ val notation_constr_of_glob_constr : notation_interp_env -> (** Re-interpret a notation as a [glob_constr], taking care of binders *) -val glob_constr_of_notation_constr_with_binders : Loc.t -> +val glob_constr_of_notation_constr_with_binders : ?loc:Loc.t -> ('a -> Name.t -> 'a * Name.t) -> ('a -> notation_constr -> glob_constr) -> 'a -> notation_constr -> glob_constr -val glob_constr_of_notation_constr : Loc.t -> notation_constr -> glob_constr +val glob_constr_of_notation_constr : ?loc:Loc.t -> notation_constr -> glob_constr (** {5 Matching a notation pattern against a [glob_constr]} *) diff --git a/interp/reserve.ml b/interp/reserve.ml index 1565ba4a92..20fdd6caa2 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -86,12 +86,12 @@ let in_reserved : Id.t * notation_constr -> obj = let declare_reserved_type_binding (loc,id) t = if not (Id.equal id (root_of_id id)) then - user_err ~loc ~hdr:"declare_reserved_type" + user_err ?loc ~hdr:"declare_reserved_type" ((pr_id id ++ str " is not reservable: it must have no trailing digits, quote, or _")); begin try let _ = Id.Map.find id !reserve_table in - user_err ~loc ~hdr:"declare_reserved_type" + user_err ?loc ~hdr:"declare_reserved_type" ((pr_id id++str" is already bound to a type")) with Not_found -> () end; add_anonymous_leaf (in_reserved (id,t)) diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index d863e05616..a9d94669a6 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -46,7 +46,7 @@ let locate_global_with_alias ?(head=false) (loc,qid) = if head then global_of_extended_global_head ref else global_of_extended_global ref with Not_found -> - user_err ~loc (pr_qualid qid ++ + user_err ?loc (pr_qualid qid ++ str " is bound to a notation that does not denote a reference.") let global_inductive_with_alias r = @@ -54,28 +54,28 @@ let global_inductive_with_alias r = try match locate_global_with_alias lqid with | IndRef ind -> ind | ref -> - user_err ~loc:(loc_of_reference r) ~hdr:"global_inductive" + user_err ?loc:(loc_of_reference r) ~hdr:"global_inductive" (pr_reference r ++ spc () ++ str "is not an inductive type.") - with Not_found -> Nametab.error_global_not_found ~loc qid + with Not_found -> Nametab.error_global_not_found ?loc qid let global_with_alias ?head r = let (loc,qid as lqid) = qualid_of_reference r in try locate_global_with_alias ?head lqid - with Not_found -> Nametab.error_global_not_found ~loc qid + with Not_found -> Nametab.error_global_not_found ?loc qid let smart_global ?head = function | AN r -> global_with_alias ?head r - | ByNotation (loc,ntn,sc) -> - Notation.interp_notation_as_global_reference loc (fun _ -> true) ntn sc + | ByNotation (loc,(ntn,sc)) -> + Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc let smart_global_inductive = function | AN r -> global_inductive_with_alias r - | ByNotation (loc,ntn,sc) -> + | ByNotation (loc,(ntn,sc)) -> destIndRef - (Notation.interp_notation_as_global_reference loc isIndRef ntn sc) + (Notation.interp_notation_as_global_reference ?loc isIndRef ntn sc) let loc_of_smart_reference = function | AN r -> loc_of_reference r - | ByNotation (loc,_,_) -> loc + | ByNotation (loc,(_,_)) -> loc diff --git a/interp/smartlocate.mli b/interp/smartlocate.mli index 0749ca5769..acae1a391f 100644 --- a/interp/smartlocate.mli +++ b/interp/smartlocate.mli @@ -38,4 +38,4 @@ val smart_global : ?head:bool -> reference or_by_notation -> global_reference val smart_global_inductive : reference or_by_notation -> inductive (** Return the loc of a smart reference *) -val loc_of_smart_reference : reference or_by_notation -> Loc.t +val loc_of_smart_reference : reference or_by_notation -> Loc.t option diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 5920b0d508..a393dd71c2 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -32,7 +32,7 @@ let wit_pre_ident : string uniform_genarg_type = let loc_of_or_by_notation f = function | AN c -> f c - | ByNotation (loc,s,_) -> loc + | ByNotation (loc,(s,_)) -> loc let wit_int_or_var = make0 ~dyn:(val_tag (topwit wit_int)) "int_or_var" @@ -59,6 +59,8 @@ let wit_open_constr = make0 ~dyn:(val_tag (topwit wit_constr)) "open_constr" let wit_constr_with_bindings = make0 "constr_with_bindings" +let wit_open_constr_with_bindings = make0 "open_constr_with_bindings" + let wit_bindings = make0 "bindings" let wit_red_expr = make0 "redexpr" diff --git a/interp/stdarg.mli b/interp/stdarg.mli index ac40a23281..be876504ec 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -21,7 +21,7 @@ open Tactypes open Genarg (** FIXME: nothing to do there. *) -val loc_of_or_by_notation : ('a -> Loc.t) -> 'a or_by_notation -> Loc.t +val loc_of_or_by_notation : ('a -> Loc.t option) -> 'a or_by_notation -> Loc.t option val wit_unit : unit uniform_genarg_type @@ -59,6 +59,11 @@ val wit_constr_with_bindings : glob_constr_and_expr with_bindings, constr with_bindings delayed_open) genarg_type +val wit_open_constr_with_bindings : + (constr_expr with_bindings, + glob_constr_and_expr with_bindings, + constr with_bindings delayed_open) genarg_type + val wit_bindings : (constr_expr bindings, glob_constr_and_expr bindings, diff --git a/interp/topconstr.ml b/interp/topconstr.ml index e05be65fb0..94bbc60eaf 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -21,7 +21,7 @@ open Constrexpr_ops let asymmetric_patterns = ref (false) let _ = Goptions.declare_bool_option { - Goptions.optsync = true; Goptions.optdepr = false; + Goptions.optdepr = false; Goptions.optname = "no parameters in constructors"; Goptions.optkey = ["Asymmetric";"Patterns"]; Goptions.optread = (fun () -> !asymmetric_patterns); @@ -34,6 +34,10 @@ let _ = Goptions.declare_bool_option { let error_invalid_pattern_notation ?loc () = user_err ?loc (str "Invalid notation for pattern.") +(* Legacy functions *) +let down_located f (_l, x) = f x +let located_fold_left f x (_l, y) = f x y + (**********************************************************************) (* Functions on constr_expr *) @@ -43,23 +47,23 @@ let is_constructor id = (Nametab.locate_extended (qualid_of_ident id))) with Not_found -> false -let rec cases_pattern_fold_names f a = function - | CPatRecord (_, l) -> +let rec cases_pattern_fold_names f a pt = match CAst.(pt.v) with + | CPatRecord l -> List.fold_left (fun acc (r, cp) -> cases_pattern_fold_names f acc cp) a l - | CPatAlias (_,pat,id) -> f id a - | CPatOr (_,patl) -> + | CPatAlias (pat,id) -> f id a + | CPatOr (patl) -> List.fold_left (cases_pattern_fold_names f) a patl - | CPatCstr (_,_,patl1,patl2) -> + | CPatCstr (_,patl1,patl2) -> List.fold_left (cases_pattern_fold_names f) (Option.fold_left (List.fold_left (cases_pattern_fold_names f)) a patl1) patl2 - | CPatNotation (_,_,(patl,patll),patl') -> + | CPatNotation (_,(patl,patll),patl') -> List.fold_left (cases_pattern_fold_names f) (List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll)) patl' - | CPatDelimiters (_,_,pat) -> cases_pattern_fold_names f a pat - | CPatAtom (_,Some (Ident (_,id))) when not (is_constructor id) -> f id a + | CPatDelimiters (_,pat) -> cases_pattern_fold_names f a pat + | CPatAtom (Some (Ident (_,id))) when not (is_constructor id) -> f id a | CPatPrim _ | CPatAtom _ -> a - | CPatCast (loc,_,_) -> - CErrors.user_err ~loc ~hdr:"cases_pattern_fold_names" + | CPatCast ({CAst.loc},_) -> + CErrors.user_err ?loc ~hdr:"cases_pattern_fold_names" (Pp.strbrk "Casts are not supported here.") let ids_of_pattern = @@ -67,7 +71,7 @@ let ids_of_pattern = let ids_of_pattern_list = List.fold_left - (Loc.located_fold_left + (located_fold_left (List.fold_left (cases_pattern_fold_names Id.Set.add))) Id.Set.empty @@ -79,13 +83,13 @@ let ids_of_cases_tomatch tms = (fun (_, ona, indnal) l -> Option.fold_right (fun t ids -> cases_pattern_fold_names Id.Set.add ids t) indnal - (Option.fold_right (Loc.down_located (name_fold Id.Set.add)) ona l)) + (Option.fold_right (down_located (Name.fold_right Id.Set.add)) ona l)) tms Id.Set.empty let rec fold_constr_expr_binders g f n acc b = function | (nal,bk,t)::l -> let nal = snd (List.split nal) in - let n' = List.fold_right (name_fold g) nal n in + let n' = List.fold_right (Name.fold_right g) nal n in f n (fold_constr_expr_binders g f n' acc b l) t | [] -> f n acc b @@ -93,59 +97,60 @@ let rec fold_constr_expr_binders g f n acc b = function let rec fold_local_binders g f n acc b = function | CLocalAssum (nal,bk,t)::l -> let nal = snd (List.split nal) in - let n' = List.fold_right (name_fold g) nal n in + let n' = List.fold_right (Name.fold_right g) nal n in f n (fold_local_binders g f n' acc b l) t | CLocalDef ((_,na),c,t)::l -> - Option.fold_left (f n) (f n (fold_local_binders g f (name_fold g na n) acc b l) c) t - | CLocalPattern (_,pat,t)::l -> + Option.fold_left (f n) (f n (fold_local_binders g f (Name.fold_right g na n) acc b l) c) t + | CLocalPattern (_,(pat,t))::l -> let acc = fold_local_binders g f (cases_pattern_fold_names g n pat) acc b l in Option.fold_left (f n) acc t | [] -> f n acc b -let fold_constr_expr_with_binders g f n acc = function - | CAppExpl (loc,(_,_,_),l) -> List.fold_left (f n) acc l - | CApp (loc,(_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) - | CProdN (_,l,b) | CLambdaN (_,l,b) -> fold_constr_expr_binders g f n acc b l - | CLetIn (_,na,a,t,b) -> - f (name_fold g (snd na) n) (Option.fold_left (f n) (f n acc a) t) b - | CCast (loc,a,(CastConv b|CastVM b|CastNative b)) -> f n (f n acc a) b - | CCast (loc,a,CastCoerce) -> f n acc a - | CNotation (_,_,(l,ll,bll)) -> +let fold_constr_expr_with_binders g f n acc = CAst.with_val (function + | CAppExpl ((_,_,_),l) -> List.fold_left (f n) acc l + | CApp ((_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) + | CProdN (l,b) | CLambdaN (l,b) -> fold_constr_expr_binders g f n acc b l + | CLetIn (na,a,t,b) -> + f (Name.fold_right g (snd na) n) (Option.fold_left (f n) (f n acc a) t) b + | CCast (a,(CastConv b|CastVM b|CastNative b)) -> f n (f n acc a) b + | CCast (a,CastCoerce) -> f n acc a + | CNotation (_,(l,ll,bll)) -> (* The following is an approximation: we don't know exactly if an ident is binding nor to which subterms bindings apply *) let acc = List.fold_left (f n) acc (l@List.flatten ll) in - List.fold_left (fun acc bl -> fold_local_binders g f n acc (CHole (Loc.ghost,None,IntroAnonymous,None)) bl) acc bll - | CGeneralization (_,_,_,c) -> f n acc c - | CDelimiters (loc,_,a) -> f n acc a + List.fold_left (fun acc bl -> fold_local_binders g f n acc (CAst.make @@ CHole (None,IntroAnonymous,None)) bl) acc bll + | CGeneralization (_,_,c) -> f n acc c + | CDelimiters (_,a) -> f n acc a | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ -> acc - | CRecord (loc,l) -> List.fold_left (fun acc (id, c) -> f n acc c) acc l - | CCases (loc,sty,rtnpo,al,bl) -> + | CRecord l -> List.fold_left (fun acc (id, c) -> f n acc c) acc l + | CCases (sty,rtnpo,al,bl) -> let ids = ids_of_cases_tomatch al in let acc = Option.fold_left (f (Id.Set.fold g ids n)) acc rtnpo in let acc = List.fold_left (f n) acc (List.map (fun (fst,_,_) -> fst) al) in - List.fold_right (fun (loc,patl,rhs) acc -> + List.fold_right (fun (loc,(patl,rhs)) acc -> let ids = ids_of_pattern_list patl in f (Id.Set.fold g ids n) acc rhs) bl acc - | CLetTuple (loc,nal,(ona,po),b,c) -> - let n' = List.fold_right (Loc.down_located (name_fold g)) nal n in - f (Option.fold_right (Loc.down_located (name_fold g)) ona n') (f n acc b) c - | CIf (_,c,(ona,po),b1,b2) -> + | CLetTuple (nal,(ona,po),b,c) -> + let n' = List.fold_right (down_located (Name.fold_right g)) nal n in + f (Option.fold_right (down_located (Name.fold_right g)) ona n') (f n acc b) c + | CIf (c,(ona,po),b1,b2) -> let acc = f n (f n (f n acc b1) b2) c in Option.fold_left - (f (Option.fold_right (Loc.down_located (name_fold g)) ona n)) acc po - | CFix (loc,_,l) -> + (f (Option.fold_right (down_located (Name.fold_right g)) ona n)) acc po + | CFix (_,l) -> let n' = List.fold_right (fun ((_,id),_,_,_,_) -> g id) l n in List.fold_right (fun (_,(_,o),lb,t,c) acc -> fold_local_binders g f n' (fold_local_binders g f n acc t lb) c lb) l acc - | CCoFix (loc,_,_) -> + | CCoFix (_,_) -> Feedback.msg_warning (strbrk "Capture check in multiple binders not done"); acc + ) let free_vars_of_constr_expr c = let rec aux bdvars l = function - | CRef (Ident (_,id),_) -> if Id.List.mem id bdvars then l else Id.Set.add id l + | { CAst.v = CRef (Ident (_,id),_) } -> if Id.List.mem id bdvars then l else Id.Set.add id l | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c in aux [] Id.Set.empty c @@ -158,7 +163,7 @@ let split_at_annot bl na = match na with | None -> begin match names with - | [] -> error "A fixpoint needs at least one parameter." + | [] -> user_err (Pp.str "A fixpoint needs at least one parameter.") | _ -> ([], bl) end | Some (loc, id) -> @@ -180,20 +185,20 @@ let split_at_annot bl na = end | CLocalDef ((_,na),_,_) as x :: rest -> if Name.equal (Name id) na then - user_err ~loc + user_err ?loc (Nameops.pr_id id ++ str" must be a proper parameter and not a local definition.") else aux (x :: acc) rest - | CLocalPattern (loc,_,_) :: rest -> - Loc.raise ~loc (Stream.Error "pattern with quote not allowed after fix") + | CLocalPattern (_,_) :: rest -> + Loc.raise ?loc (Stream.Error "pattern with quote not allowed after fix") | [] -> - user_err ~loc + user_err ?loc (str "No parameter named " ++ Nameops.pr_id id ++ str".") in aux [] bl (* Used in correctness and interface *) -let map_binder g e nal = List.fold_right (Loc.down_located (name_fold g)) nal e +let map_binder g e nal = List.fold_right (down_located (Name.fold_right g)) nal e let map_binders f g e bl = (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) @@ -207,86 +212,88 @@ let map_local_binders f g e bl = CLocalAssum(nal,k,ty) -> (map_binder g e nal, CLocalAssum(nal,k,f e ty)::bl) | CLocalDef((loc,na),c,ty) -> - (name_fold g na e, CLocalDef((loc,na),f e c,Option.map (f e) ty)::bl) - | CLocalPattern (loc,pat,t) -> + (Name.fold_right g na e, CLocalDef((loc,na),f e c,Option.map (f e) ty)::bl) + | CLocalPattern (loc,(pat,t)) -> let ids = ids_of_pattern pat in - (Id.Set.fold g ids e, CLocalPattern (loc,pat,Option.map (f e) t)::bl) in + (Id.Set.fold g ids e, CLocalPattern (loc,(pat,Option.map (f e) t))::bl) in let (e,rbl) = List.fold_left h (e,[]) bl in (e, List.rev rbl) -let map_constr_expr_with_binders g f e = function - | CAppExpl (loc,r,l) -> CAppExpl (loc,r,List.map (f e) l) - | CApp (loc,(p,a),l) -> - CApp (loc,(p,f e a),List.map (fun (a,i) -> (f e a,i)) l) - | CProdN (loc,bl,b) -> - let (e,bl) = map_binders f g e bl in CProdN (loc,bl,f e b) - | CLambdaN (loc,bl,b) -> - let (e,bl) = map_binders f g e bl in CLambdaN (loc,bl,f e b) - | CLetIn (loc,na,a,t,b) -> - CLetIn (loc,na,f e a,Option.map (f e) t,f (name_fold g (snd na) e) b) - | CCast (loc,a,c) -> CCast (loc,f e a, Miscops.map_cast_type (f e) c) - | CNotation (loc,n,(l,ll,bll)) -> +let map_constr_expr_with_binders g f e = CAst.map (function + | CAppExpl (r,l) -> CAppExpl (r,List.map (f e) l) + | CApp ((p,a),l) -> + CApp ((p,f e a),List.map (fun (a,i) -> (f e a,i)) l) + | CProdN (bl,b) -> + let (e,bl) = map_binders f g e bl in CProdN (bl,f e b) + | CLambdaN (bl,b) -> + let (e,bl) = map_binders f g e bl in CLambdaN (bl,f e b) + | CLetIn (na,a,t,b) -> + CLetIn (na,f e a,Option.map (f e) t,f (Name.fold_right g (snd na) e) b) + | CCast (a,c) -> CCast (f e a, Miscops.map_cast_type (f e) c) + | CNotation (n,(l,ll,bll)) -> (* This is an approximation because we don't know what binds what *) - CNotation (loc,n,(List.map (f e) l,List.map (List.map (f e)) ll, + CNotation (n,(List.map (f e) l,List.map (List.map (f e)) ll, List.map (fun bl -> snd (map_local_binders f g e bl)) bll)) - | CGeneralization (loc,b,a,c) -> CGeneralization (loc,b,a,f e c) - | CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a) + | CGeneralization (b,a,c) -> CGeneralization (b,a,f e c) + | CDelimiters (s,a) -> CDelimiters (s,f e a) | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ as x -> x - | CRecord (loc,l) -> CRecord (loc,List.map (fun (id, c) -> (id, f e c)) l) - | CCases (loc,sty,rtnpo,a,bl) -> - let bl = List.map (fun (loc,patl,rhs) -> + | CRecord l -> CRecord (List.map (fun (id, c) -> (id, f e c)) l) + | CCases (sty,rtnpo,a,bl) -> + let bl = List.map (fun (loc,(patl,rhs)) -> let ids = ids_of_pattern_list patl in - (loc,patl,f (Id.Set.fold g ids e) rhs)) bl in + (loc,(patl,f (Id.Set.fold g ids e) rhs))) bl in let ids = ids_of_cases_tomatch a in let po = Option.map (f (Id.Set.fold g ids e)) rtnpo in - CCases (loc, sty, po, List.map (fun (tm,x,y) -> f e tm,x,y) a,bl) - | CLetTuple (loc,nal,(ona,po),b,c) -> - let e' = List.fold_right (Loc.down_located (name_fold g)) nal e in - let e'' = Option.fold_right (Loc.down_located (name_fold g)) ona e in - CLetTuple (loc,nal,(ona,Option.map (f e'') po),f e b,f e' c) - | CIf (loc,c,(ona,po),b1,b2) -> - let e' = Option.fold_right (Loc.down_located (name_fold g)) ona e in - CIf (loc,f e c,(ona,Option.map (f e') po),f e b1,f e b2) - | CFix (loc,id,dl) -> - CFix (loc,id,List.map (fun (id,n,bl,t,d) -> + CCases (sty, po, List.map (fun (tm,x,y) -> f e tm,x,y) a,bl) + | CLetTuple (nal,(ona,po),b,c) -> + let e' = List.fold_right (down_located (Name.fold_right g)) nal e in + let e'' = Option.fold_right (down_located (Name.fold_right g)) ona e in + CLetTuple (nal,(ona,Option.map (f e'') po),f e b,f e' c) + | CIf (c,(ona,po),b1,b2) -> + let e' = Option.fold_right (down_located (Name.fold_right g)) ona e in + CIf (f e c,(ona,Option.map (f e') po),f e b1,f e b2) + | CFix (id,dl) -> + CFix (id,List.map (fun (id,n,bl,t,d) -> let (e',bl') = map_local_binders f g e bl in let t' = f e' t in (* Note: fix names should be inserted before the arguments... *) let e'' = List.fold_left (fun e ((_,id),_,_,_,_) -> g id e) e' dl in let d' = f e'' d in (id,n,bl',t',d')) dl) - | CCoFix (loc,id,dl) -> - CCoFix (loc,id,List.map (fun (id,bl,t,d) -> + | CCoFix (id,dl) -> + CCoFix (id,List.map (fun (id,bl,t,d) -> let (e',bl') = map_local_binders f g e bl in let t' = f e' t in let e'' = List.fold_left (fun e ((_,id),_,_,_) -> g id e) e' dl in let d' = f e'' d in (id,bl',t',d')) dl) + ) (* Used in constrintern *) let rec replace_vars_constr_expr l = function - | CRef (Ident (loc,id),us) as x -> - (try CRef (Ident (loc,Id.Map.find id l),us) with Not_found -> x) + | { CAst.loc; v = CRef (Ident (loc_id,id),us) } as x -> + (try CAst.make ?loc @@ CRef (Ident (loc_id,Id.Map.find id l),us) with Not_found -> x) | c -> map_constr_expr_with_binders Id.Map.remove replace_vars_constr_expr l c (* Returns the ranges of locs of the notation that are not occupied by args *) (* and which are then occupied by proper symbols of the notation (or spaces) *) -let locs_of_notation loc locs ntn = - let (bl, el) = Loc.unloc loc in - let locs = List.map Loc.unloc locs in +let locs_of_notation ?loc locs ntn = + let unloc loc = Option.cata Loc.unloc (0,0) loc in + let (bl, el) = unloc loc in + let locs = List.map unloc locs in let rec aux pos = function | [] -> if Int.equal pos el then [] else [(pos,el)] | (ba,ea)::l -> if Int.equal pos ba then aux ea l else (pos,ba)::aux ea l in aux bl (List.sort (fun l1 l2 -> fst l1 - fst l2) locs) -let ntn_loc loc (args,argslist,binderslist) = - locs_of_notation loc +let ntn_loc ?loc (args,argslist,binderslist) = + locs_of_notation ?loc (List.map constr_loc (args@List.flatten argslist)@ List.map local_binders_loc binderslist) -let patntn_loc loc (args,argslist) = - locs_of_notation loc +let patntn_loc ?loc (args,argslist) = + locs_of_notation ?loc (List.map cases_pattern_expr_loc (args@List.flatten argslist)) diff --git a/interp/topconstr.mli b/interp/topconstr.mli index b6ac40041e..fabb1cb930 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -40,9 +40,9 @@ val map_constr_expr_with_binders : 'a -> constr_expr -> constr_expr val ntn_loc : - Loc.t -> constr_notation_substitution -> string -> (int * int) list + ?loc:Loc.t -> constr_notation_substitution -> string -> (int * int) list val patntn_loc : - Loc.t -> cases_pattern_notation_substitution -> string -> (int * int) list + ?loc:Loc.t -> cases_pattern_notation_substitution -> string -> (int * int) list (** For cases pattern parsing errors *) diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli index 77f052ddbd..614c097b5a 100644 --- a/intf/constrexpr.mli +++ b/intf/constrexpr.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Loc open Names open Libnames open Misctypes @@ -38,75 +37,76 @@ type prim_token = type instance_expr = Misctypes.glob_level list -type cases_pattern_expr = - | CPatAlias of Loc.t * cases_pattern_expr * Id.t - | CPatCstr of Loc.t * reference +type cases_pattern_expr_r = + | CPatAlias of cases_pattern_expr * Id.t + | CPatCstr of reference * cases_pattern_expr list option * cases_pattern_expr list (** [CPatCstr (_, c, Some l1, l2)] represents (@c l1) l2 *) - | CPatAtom of Loc.t * reference option - | CPatOr of Loc.t * cases_pattern_expr list - | CPatNotation of Loc.t * notation * cases_pattern_notation_substitution + | CPatAtom of reference option + | CPatOr of cases_pattern_expr list + | CPatNotation of notation * cases_pattern_notation_substitution * cases_pattern_expr list (** CPatNotation (_, n, l1 ,l2) represents (notation n applied with substitution l1) applied to arguments l2 *) - | CPatPrim of Loc.t * prim_token - | CPatRecord of Loc.t * (reference * cases_pattern_expr) list - | CPatDelimiters of Loc.t * string * cases_pattern_expr - | CPatCast of Loc.t * cases_pattern_expr * constr_expr + | CPatPrim of prim_token + | CPatRecord of (reference * cases_pattern_expr) list + | CPatDelimiters of string * cases_pattern_expr + | CPatCast of cases_pattern_expr * constr_expr +and cases_pattern_expr = cases_pattern_expr_r CAst.t and cases_pattern_notation_substitution = cases_pattern_expr list * (** for constr subterms *) cases_pattern_expr list list (** for recursive notations *) -and constr_expr = - | CRef of reference * instance_expr option - | CFix of Loc.t * Id.t located * fix_expr list - | CCoFix of Loc.t * Id.t located * cofix_expr list - | CProdN of Loc.t * binder_expr list * constr_expr - | CLambdaN of Loc.t * binder_expr list * constr_expr - | CLetIn of Loc.t * Name.t located * constr_expr * constr_expr option * constr_expr - | CAppExpl of Loc.t * (proj_flag * reference * instance_expr option) * constr_expr list - | CApp of Loc.t * (proj_flag * constr_expr) * - (constr_expr * explicitation located option) list - | CRecord of Loc.t * (reference * constr_expr) list +and constr_expr_r = + | CRef of reference * instance_expr option + | CFix of Id.t Loc.located * fix_expr list + | CCoFix of Id.t Loc.located * cofix_expr list + | CProdN of binder_expr list * constr_expr + | CLambdaN of binder_expr list * constr_expr + | CLetIn of Name.t Loc.located * constr_expr * constr_expr option * constr_expr + | CAppExpl of (proj_flag * reference * instance_expr option) * constr_expr list + | CApp of (proj_flag * constr_expr) * + (constr_expr * explicitation Loc.located option) list + | CRecord of (reference * constr_expr) list (* representation of the "let" and "match" constructs *) - | CCases of Loc.t (* position of the "match" keyword *) - * case_style (* determines whether this value represents "let" or "match" construct *) - * constr_expr option (* return-clause *) - * case_expr list - * branch_expr list (* branches *) - - | CLetTuple of Loc.t * Name.t located list * (Name.t located option * constr_expr option) * - constr_expr * constr_expr - | CIf of Loc.t * constr_expr * (Name.t located option * constr_expr option) - * constr_expr * constr_expr - | CHole of Loc.t * Evar_kinds.t option * intro_pattern_naming_expr * Genarg.raw_generic_argument option - | CPatVar of Loc.t * patvar - | CEvar of Loc.t * Glob_term.existential_name * (Id.t * constr_expr) list - | CSort of Loc.t * glob_sort - | CCast of Loc.t * constr_expr * constr_expr cast_type - | CNotation of Loc.t * notation * constr_notation_substitution - | CGeneralization of Loc.t * binding_kind * abstraction_kind option * constr_expr - | CPrim of Loc.t * prim_token - | CDelimiters of Loc.t * string * constr_expr + | CCases of case_style (* determines whether this value represents "let" or "match" construct *) + * constr_expr option (* return-clause *) + * case_expr list + * branch_expr list (* branches *) + + | CLetTuple of Name.t Loc.located list * (Name.t Loc.located option * constr_expr option) * + constr_expr * constr_expr + | CIf of constr_expr * (Name.t Loc.located option * constr_expr option) + * constr_expr * constr_expr + | CHole of Evar_kinds.t option * intro_pattern_naming_expr * Genarg.raw_generic_argument option + | CPatVar of patvar + | CEvar of Glob_term.existential_name * (Id.t * constr_expr) list + | CSort of glob_sort + | CCast of constr_expr * constr_expr cast_type + | CNotation of notation * constr_notation_substitution + | CGeneralization of binding_kind * abstraction_kind option * constr_expr + | CPrim of prim_token + | CDelimiters of string * constr_expr +and constr_expr = constr_expr_r CAst.t and case_expr = constr_expr (* expression that is being matched *) - * Name.t located option (* as-clause *) + * Name.t Loc.located option (* as-clause *) * cases_pattern_expr option (* in-clause *) and branch_expr = - Loc.t * cases_pattern_expr list located list * constr_expr + (cases_pattern_expr list Loc.located list * constr_expr) Loc.located and binder_expr = - Name.t located list * binder_kind * constr_expr + Name.t Loc.located list * binder_kind * constr_expr and fix_expr = - Id.t located * (Id.t located option * recursion_order_expr) * + Id.t Loc.located * (Id.t Loc.located option * recursion_order_expr) * local_binder_expr list * constr_expr * constr_expr and cofix_expr = - Id.t located * local_binder_expr list * constr_expr * constr_expr + Id.t Loc.located * local_binder_expr list * constr_expr * constr_expr and recursion_order_expr = | CStructRec @@ -115,16 +115,16 @@ and recursion_order_expr = (** Anonymous defs allowed ?? *) and local_binder_expr = - | CLocalAssum of Name.t located list * binder_kind * constr_expr - | CLocalDef of Name.t located * constr_expr * constr_expr option - | CLocalPattern of Loc.t * cases_pattern_expr * constr_expr option + | CLocalAssum of Name.t Loc.located list * binder_kind * constr_expr + | CLocalDef of Name.t Loc.located * constr_expr * constr_expr option + | CLocalPattern of (cases_pattern_expr * constr_expr option) Loc.located and constr_notation_substitution = constr_expr list * (** for constr subterms *) constr_expr list list * (** for recursive notations *) local_binder_expr list list (** for binders subexpressions *) -type typeclass_constraint = (Name.t located * Id.t located list option) * binding_kind * constr_expr +type typeclass_constraint = (Name.t Loc.located * Id.t Loc.located list option) * binding_kind * constr_expr and typeclass_context = typeclass_constraint list @@ -133,10 +133,11 @@ type constr_pattern_expr = constr_expr (** Concrete syntax for modules and module types *) type with_declaration_ast = - | CWith_Module of Id.t list located * qualid located - | CWith_Definition of Id.t list located * constr_expr - -type module_ast = - | CMident of qualid located - | CMapply of Loc.t * module_ast * module_ast - | CMwith of Loc.t * module_ast * with_declaration_ast + | CWith_Module of Id.t list Loc.located * qualid Loc.located + | CWith_Definition of Id.t list Loc.located * constr_expr + +type module_ast_r = + | CMident of qualid + | CMapply of module_ast * module_ast + | CMwith of module_ast * with_declaration_ast +and module_ast = module_ast_r CAst.t diff --git a/intf/evar_kinds.mli b/intf/evar_kinds.mli index 470ad2a23b..835e94c777 100644 --- a/intf/evar_kinds.mli +++ b/intf/evar_kinds.mli @@ -21,7 +21,7 @@ type t = * bool (** Force inference *) | BinderType of Name.t | NamedHole of Id.t (* coming from some ?[id] syntax *) - | QuestionMark of obligation_definition_status + | QuestionMark of obligation_definition_status * Name.t | CasesType of bool (* true = a subterm of the type *) | InternalHole | TomatchTypeParameter of inductive * int diff --git a/intf/genredexpr.mli b/intf/genredexpr.mli index 16f0c0c92a..2a542e0ff2 100644 --- a/intf/genredexpr.mli +++ b/intf/genredexpr.mli @@ -52,7 +52,7 @@ type ('a,'b,'c) red_expr_gen = type ('a,'b,'c) may_eval = | ConstrTerm of 'a | ConstrEval of ('a,'b,'c) red_expr_gen * 'a - | ConstrContext of (Loc.t * Id.t) * 'a + | ConstrContext of Id.t Loc.located * 'a | ConstrTypeOf of 'a open Libnames diff --git a/intf/glob_term.mli b/intf/glob_term.mli index ced5a8b44f..33c71884a2 100644 --- a/intf/glob_term.mli +++ b/intf/glob_term.mli @@ -24,35 +24,36 @@ type existential_name = Id.t (** The kind of patterns that occurs in "match ... with ... end" locs here refers to the ident's location, not whole pat *) -type cases_pattern = - | PatVar of Loc.t * Name.t - | PatCstr of Loc.t * constructor * cases_pattern list * Name.t +type cases_pattern_r = + | PatVar of Name.t + | PatCstr of constructor * cases_pattern list * Name.t (** [PatCstr(p,C,l,x)] = "|'C' 'l' as 'x'" *) +and cases_pattern = cases_pattern_r CAst.t (** Representation of an internalized (or in other words globalized) term. *) -type glob_constr = - | GRef of (Loc.t * global_reference * glob_level list option) +type glob_constr_r = + | GRef of global_reference * glob_level list option (** An identifier that represents a reference to an object defined either in the (global) environment or in the (local) context. *) - | GVar of (Loc.t * Id.t) + | GVar of Id.t (** An identifier that cannot be regarded as "GRef". Bound variables are typically represented this way. *) - | GEvar of Loc.t * existential_name * (Id.t * glob_constr) list - | GPatVar of Loc.t * (bool * patvar) (** Used for patterns only *) - | GApp of Loc.t * glob_constr * glob_constr list - | GLambda of Loc.t * Name.t * binding_kind * glob_constr * glob_constr - | GProd of Loc.t * Name.t * binding_kind * glob_constr * glob_constr - | GLetIn of Loc.t * Name.t * glob_constr * glob_constr option * glob_constr - | GCases of Loc.t * case_style * glob_constr option * tomatch_tuples * cases_clauses - (** [GCases(l,style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in [MatchStyle]) *) - | GLetTuple of Loc.t * Name.t list * (Name.t * glob_constr option) * - glob_constr * glob_constr - | GIf of Loc.t * glob_constr * (Name.t * glob_constr option) * glob_constr * glob_constr - | GRec of Loc.t * fix_kind * Id.t array * glob_decl list array * - glob_constr array * glob_constr array - | GSort of Loc.t * glob_sort - | GHole of (Loc.t * Evar_kinds.t * intro_pattern_naming_expr * Genarg.glob_generic_argument option) - | GCast of Loc.t * glob_constr * glob_constr cast_type + | GEvar of existential_name * (Id.t * glob_constr) list + | GPatVar of bool * patvar (** Used for patterns only *) + | GApp of glob_constr * glob_constr list + | GLambda of Name.t * binding_kind * glob_constr * glob_constr + | GProd of Name.t * binding_kind * glob_constr * glob_constr + | GLetIn of Name.t * glob_constr * glob_constr option * glob_constr + | GCases of case_style * glob_constr option * tomatch_tuples * cases_clauses + (** [GCases(style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in [MatchStyle]) *) + | GLetTuple of Name.t list * (Name.t * glob_constr option) * glob_constr * glob_constr + | GIf of glob_constr * (Name.t * glob_constr option) * glob_constr * glob_constr + | GRec of fix_kind * Id.t array * glob_decl list array * + glob_constr array * glob_constr array + | GSort of glob_sort + | GHole of Evar_kinds.t * intro_pattern_naming_expr * Genarg.glob_generic_argument option + | GCast of glob_constr * glob_constr cast_type +and glob_constr = glob_constr_r CAst.t and glob_decl = Name.t * binding_kind * glob_constr option * glob_constr @@ -66,22 +67,23 @@ and fix_kind = | GCoFix of int and predicate_pattern = - Name.t * (Loc.t * inductive * Name.t list) option + Name.t * (inductive * Name.t list) Loc.located option (** [(na,id)] = "as 'na' in 'id'" where if [id] is [Some(l,I,k,args)]. *) and tomatch_tuple = (glob_constr * predicate_pattern) and tomatch_tuples = tomatch_tuple list -and cases_clause = (Loc.t * Id.t list * cases_pattern list * glob_constr) +and cases_clause = (Id.t list * cases_pattern list * glob_constr) Loc.located (** [(p,il,cl,t)] = "|'cl' => 't'". Precondition: the free variables of [t] are members of [il]. *) and cases_clauses = cases_clause list -type extended_glob_local_binder = - | GLocalAssum of Loc.t * Name.t * binding_kind * glob_constr - | GLocalDef of Loc.t * Name.t * binding_kind * glob_constr * glob_constr option - | GLocalPattern of Loc.t * (cases_pattern * Id.t list) * Id.t * binding_kind * glob_constr +type extended_glob_local_binder_r = + | GLocalAssum of Name.t * binding_kind * glob_constr + | GLocalDef of Name.t * binding_kind * glob_constr * glob_constr option + | GLocalPattern of (cases_pattern * Id.t list) * Id.t * binding_kind * glob_constr +and extended_glob_local_binder = extended_glob_local_binder_r CAst.t (** A globalised term together with a closure representing the value of its free variables. Intended for use when these variables are taken diff --git a/intf/misctypes.mli b/intf/misctypes.mli index 7c2dc5177c..2ab70a78ef 100644 --- a/intf/misctypes.mli +++ b/intf/misctypes.mli @@ -27,12 +27,12 @@ and intro_pattern_naming_expr = and 'constr intro_pattern_action_expr = | IntroWildcard | IntroOrAndPattern of 'constr or_and_intro_pattern_expr - | IntroInjection of (Loc.t * 'constr intro_pattern_expr) list - | IntroApplyOn of (Loc.t * 'constr) * (Loc.t * 'constr intro_pattern_expr) + | IntroInjection of ('constr intro_pattern_expr) Loc.located list + | IntroApplyOn of 'constr Loc.located * 'constr intro_pattern_expr Loc.located | IntroRewrite of bool and 'constr or_and_intro_pattern_expr = - | IntroOrPattern of (Loc.t * 'constr intro_pattern_expr) list list - | IntroAndPattern of (Loc.t * 'constr intro_pattern_expr) list + | IntroOrPattern of ('constr intro_pattern_expr) Loc.located list list + | IntroAndPattern of ('constr intro_pattern_expr) Loc.located list (** Move destination for hypothesis *) @@ -79,7 +79,7 @@ type 'a cast_type = type quantified_hypothesis = AnonHyp of int | NamedHyp of Id.t -type 'a explicit_bindings = (Loc.t * quantified_hypothesis * 'a) list +type 'a explicit_bindings = (quantified_hypothesis * 'a) Loc.located list type 'a bindings = | ImplicitBindings of 'a list @@ -99,7 +99,7 @@ type 'a and_short_name = 'a * Id.t Loc.located option type 'a or_by_notation = | AN of 'a - | ByNotation of (Loc.t * string * string option) + | ByNotation of (string * string option) Loc.located (* NB: the last string in [ByNotation] is actually a [Notation.delimiters], but this formulation avoids a useless dependency. *) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index cb093d85d5..ab440c6b71 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -143,6 +143,7 @@ type search_restriction = type rec_flag = bool (* true = Rec; false = NoRec *) type verbose_flag = bool (* true = Verbose; false = Silent *) + (* list of idents for qed exporting *) type opacity_flag = Opaque of lident list option | Transparent type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option @@ -223,7 +224,8 @@ type syntax_modifier = type proof_end = | Admitted - | Proved of opacity_flag * (lident * theorem_kind option) option + (* name in `Save ident` when closing goal *) + | Proved of opacity_flag * lident option type scheme = | InductionScheme of bool * reference or_by_notation * sort_expr @@ -482,7 +484,7 @@ and vernac_implicit_status = Implicit | MaximallyImplicit | NotImplicit and vernac_argument_status = { name : Name.t; recarg_like : bool; - notation_scope : (Loc.t * string) option; + notation_scope : string Loc.located option; implicit_status : vernac_implicit_status; } diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index b1dd26119e..8515d51b0d 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -1000,7 +1000,7 @@ let rec kl info m = if is_val m then (incr prune; term_of_fconstr m) else let (nm,s) = kni info m [] in - let _ = fapp_stack(nm,s) in (* to unlock Zupdates! *) + let () = if !share then ignore (fapp_stack (nm, s)) in (* to unlock Zupdates! *) zip_term (kl info) (norm_head info nm) s (* no redex: go up for atoms and already normalized terms, go down @@ -1050,7 +1050,7 @@ let inject c = mk_clos (subs_id 0) c let whd_stack infos m stk = let k = kni infos m stk in - let _ = fapp_stack k in (* to unlock Zupdates! *) + let () = if !share then ignore (fapp_stack k) in (* to unlock Zupdates! *) k (* cache of constants: the body is computed only when needed. *) diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index 3f1cf92487..4533169804 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -71,7 +71,7 @@ let set_strategy ({ var_opacity; cst_opacity } as oracle) k l = | _ -> Cpred.add c oracle.cst_trstate in { oracle with cst_opacity; cst_trstate; } - | RelKey _ -> CErrors.error "set_strategy: RelKey" + | RelKey _ -> CErrors.user_err Pp.(str "set_strategy: RelKey") let fold_strategy f { var_opacity; cst_opacity; } accu = let fvar id lvl accu = f (VarKey id) lvl accu in diff --git a/kernel/inductive.ml b/kernel/inductive.ml index d8d365c347..4f4b641b44 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -25,7 +25,7 @@ type mind_specif = mutual_inductive_body * one_inductive_body let lookup_mind_specif env (kn,tyi) = let mib = Environ.lookup_mind kn env in if tyi >= Array.length mib.mind_packets then - error "Inductive.lookup_mind_specif: invalid inductive index"; + user_err Pp.(str "Inductive.lookup_mind_specif: invalid inductive index"); (mib, mib.mind_packets.(tyi)) let find_rectype env c = @@ -247,7 +247,7 @@ let type_of_constructor (cstr, u) (mib,mip) = let specif = mip.mind_user_lc in let i = index_of_constructor cstr in let nconstr = Array.length mip.mind_consnames in - if i > nconstr then error "Not enough constructors in the type."; + if i > nconstr then user_err Pp.(str "Not enough constructors in the type."); constructor_instantiate (fst ind) u mib specif.(i-1) let constrained_type_of_constructor (cstr,u as cstru) (mib,mip as ind) = diff --git a/kernel/names.ml b/kernel/names.ml index f5b3f4e007..ae34033355 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -35,7 +35,7 @@ struct let hash = String.hash let check_valid ?(strict=true) x = - let iter (fatal, x) = if fatal || strict then CErrors.error x in + let iter (fatal, x) = if fatal || strict then CErrors.user_err Pp.(str x) in Option.iter iter (Unicode.ident_refutation x) let is_valid s = match Unicode.ident_refutation s with @@ -104,8 +104,12 @@ struct | _ -> false let hash = function - | Anonymous -> 0 - | Name id -> Id.hash id + | Anonymous -> 0 + | Name id -> Id.hash id + + let print = function + | Anonymous -> str "_" + | Name id -> Id.print id module Self_Hashcons = struct diff --git a/kernel/names.mli b/kernel/names.mli index 5b0163aa55..c73eb197bb 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -105,6 +105,9 @@ sig val hcons : t -> t (** Hashconsing over names. *) + val print : t -> Pp.std_ppcmds + (** Pretty-printer (print "_" for [Anonymous]. *) + end (** {6 Type aliases} *) diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 6bd82170e6..26d0617683 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -125,7 +125,7 @@ let call_linker ?(fatal=true) prefix f upds = if not (Sys.file_exists f) then begin let msg = "Cannot find native compiler file " ^ f in - if fatal then CErrors.error msg + if fatal then CErrors.user_err Pp.(str msg) else if !Flags.debug then Feedback.msg_debug (Pp.str msg) end else diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index d0593c0e05..502a10113d 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -36,12 +36,11 @@ let empty_opaquetab = { (* hooks *) let default_get_opaque dp _ = - CErrors.error - ("Cannot access opaque proofs in library " ^ DirPath.to_string dp) + CErrors.user_err Pp.(pr_sequence str ["Cannot access opaque proofs in library"; DirPath.to_string dp]) let default_get_univ dp _ = - CErrors.error - ("Cannot access universe constraints of opaque proofs in library " ^ - DirPath.to_string dp) + CErrors.user_err (Pp.pr_sequence Pp.str [ + "Cannot access universe constraints of opaque proofs in library "; + DirPath.to_string dp]) let get_opaque = ref default_get_opaque let get_univ = ref default_get_univ diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index caaaff1b89..f5e8e86530 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -192,7 +192,7 @@ let check_engagement env expected_impredicative_set = begin match impredicative_set, expected_impredicative_set with | PredicativeSet, ImpredicativeSet -> - CErrors.error "Needs option -impredicative-set." + CErrors.user_err Pp.(str "Needs option -impredicative-set.") | _ -> () end @@ -346,10 +346,10 @@ let check_required current_libs needed = try let actual = DPMap.find id current_libs in if not(digest_match ~actual ~required) then - CErrors.error - ("Inconsistent assumptions over module "^(DirPath.to_string id)^".") + CErrors.user_err Pp.(pr_sequence str + ["Inconsistent assumptions over module"; DirPath.to_string id; "."]) with Not_found -> - CErrors.error ("Reference to unknown module "^(DirPath.to_string id)^".") + CErrors.user_err Pp.(pr_sequence str ["Reference to unknown module"; DirPath.to_string id; "."]) in Array.iter check needed @@ -367,7 +367,7 @@ let safe_push_named d env = let _ = try let _ = Environ.lookup_named id env in - CErrors.error ("Identifier "^Id.to_string id^" already defined.") + CErrors.user_err Pp.(pr_sequence str ["Identifier"; Id.to_string id; "already defined."]) with Not_found -> () in Environ.push_named d env @@ -908,7 +908,7 @@ let register_inline kn senv = let open Environ in let open Pre_env in if not (evaluable_constant kn senv.env) then - CErrors.error "Register inline: an evaluable constant is expected"; + CErrors.user_err Pp.(str "Register inline: an evaluable constant is expected"); let env = pre_env senv.env in let (cb,r) = Cmap_env.find kn env.env_globals.env_constants in let cb = {cb with const_inline_code = true} in diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index d0fdf9fdae..f779f68be4 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -110,8 +110,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 in let u = if poly then - CErrors.error ("Checking of subtyping of polymorphic" ^ - " inductive types not implemented") + CErrors.user_err Pp.(str "Checking of subtyping of polymorphic inductive types not implemented") else Instance.empty in let mib2 = Declareops.subst_mind_body subst2 mib2 in @@ -347,7 +346,7 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = let c2 = Mod_subst.force_constr lc2 in check_conv NotConvertibleBodyField cst poly u infer_conv env' c1 c2)) | IndType ((kn,i),mind1) -> - ignore (CErrors.error ( + ignore (CErrors.user_err Pp.(str @@ "The kernel does not recognize yet that a parameter can be " ^ "instantiated by an inductive type. Hint: you can rename the " ^ "inductive type and give a definition to map the old name to the new " ^ @@ -364,7 +363,7 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = let error = NotConvertibleTypeField (env, arity1, typ2) in check_conv error cst false Univ.Instance.empty infer_conv_leq env arity1 typ2 | IndConstr (((kn,i),j) as cstr,mind1) -> - ignore (CErrors.error ( + ignore (CErrors.user_err Pp.(str @@ "The kernel does not recognize yet that a parameter can be " ^ "instantiated by a constructor. Hint: you can rename the " ^ "constructor and give a definition to map the old name to the new " ^ diff --git a/kernel/term.ml b/kernel/term.ml index 03562d9f31..a4296a530c 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -526,26 +526,26 @@ let decompose_lam = (* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T) *) let decompose_prod_n n = - if n < 0 then error "decompose_prod_n: integer parameter must be positive"; + if n < 0 then user_err (str "decompose_prod_n: integer parameter must be positive"); let rec prodec_rec l n c = if Int.equal n 0 then l,c else match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c - | _ -> error "decompose_prod_n: not enough products" + | _ -> user_err (str "decompose_prod_n: not enough products") in prodec_rec [] n (* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T) *) let decompose_lam_n n = - if n < 0 then error "decompose_lam_n: integer parameter must be positive"; + if n < 0 then user_err (str "decompose_lam_n: integer parameter must be positive"); let rec lamdec_rec l n c = if Int.equal n 0 then l,c else match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c - | _ -> error "decompose_lam_n: not enough abstractions" + | _ -> user_err (str "decompose_lam_n: not enough abstractions") in lamdec_rec [] n @@ -581,7 +581,7 @@ let decompose_lam_assum = ci,Ti);..;(x1,None,T1)] and of the inner type [T]) *) let decompose_prod_n_assum n = if n < 0 then - error "decompose_prod_n_assum: integer parameter must be positive"; + user_err (str "decompose_prod_n_assum: integer parameter must be positive"); let rec prodec_rec l n c = if Int.equal n 0 then l,c else @@ -590,7 +590,7 @@ let decompose_prod_n_assum n = | Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c - | c -> error "decompose_prod_n_assum: not enough assumptions" + | c -> user_err (str "decompose_prod_n_assum: not enough assumptions") in prodec_rec Context.Rel.empty n @@ -602,7 +602,7 @@ let decompose_prod_n_assum n = but n is the actual number of destructurated lambdas. *) let decompose_lam_n_assum n = if n < 0 then - error "decompose_lam_n_assum: integer parameter must be positive"; + user_err (str "decompose_lam_n_assum: integer parameter must be positive"); let rec lamdec_rec l n c = if Int.equal n 0 then l,c else @@ -611,14 +611,14 @@ let decompose_lam_n_assum n = | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) n c | Cast (c,_,_) -> lamdec_rec l n c - | c -> error "decompose_lam_n_assum: not enough abstractions" + | c -> user_err (str "decompose_lam_n_assum: not enough abstractions") in lamdec_rec Context.Rel.empty n (* Same, counting let-in *) let decompose_lam_n_decls n = if n < 0 then - error "decompose_lam_n_decls: integer parameter must be positive"; + user_err (str "decompose_lam_n_decls: integer parameter must be positive"); let rec lamdec_rec l n c = if Int.equal n 0 then l,c else @@ -627,7 +627,7 @@ let decompose_lam_n_decls n = | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c - | c -> error "decompose_lam_n_decls: not enough abstractions" + | c -> user_err (str "decompose_lam_n_decls: not enough abstractions") in lamdec_rec Context.Rel.empty n diff --git a/lib/aux_file.ml b/lib/aux_file.ml index 1b6651a55f..09a254e9d9 100644 --- a/lib/aux_file.ml +++ b/lib/aux_file.ml @@ -46,19 +46,21 @@ let contents x = x let empty_aux_file = H.empty -let get aux loc key = M.find key (H.find (Loc.unloc loc) aux) +let get ?loc aux key = M.find key (H.find (Option.cata Loc.unloc (0,0) loc) aux) -let record_in_aux_at loc key v = +let record_in_aux_at ?loc key v = Option.iter (fun oc -> - let i, j = Loc.unloc loc in - Printf.fprintf oc "%d %d %s %S\n" i j key v) - !oc + match loc with + | Some loc -> let i, j = Loc.unloc loc in + Printf.fprintf oc "%d %d %s %S\n" i j key v + | None -> Printf.fprintf oc "--- %s %S\n" key v + ) !oc -let current_loc = ref Loc.ghost +let current_loc : Loc.t option ref = ref None -let record_in_aux_set_at loc = current_loc := loc +let record_in_aux_set_at ?loc () = current_loc := loc -let record_in_aux key v = record_in_aux_at !current_loc key v +let record_in_aux key v = record_in_aux_at ?loc:!current_loc key v let set h loc k v = let m = try H.find loc h with Not_found -> M.empty in @@ -91,4 +93,4 @@ let load_aux_file_for vfile = Flags.if_verbose Feedback.msg_info Pp.(str"Loading file "++str aux_fname++str": "++str s); empty_aux_file -let set h loc k v = set h (Loc.unloc loc) k v +let set ?loc h k v = set h (Option.cata Loc.unloc (0,0) loc) k v diff --git a/lib/aux_file.mli b/lib/aux_file.mli index 86e322b71d..a7960fa169 100644 --- a/lib/aux_file.mli +++ b/lib/aux_file.mli @@ -9,9 +9,9 @@ type aux_file val load_aux_file_for : string -> aux_file -val get : aux_file -> Loc.t -> string -> string val empty_aux_file : aux_file -val set : aux_file -> Loc.t -> string -> string -> aux_file +val get : ?loc:Loc.t -> aux_file -> string -> string +val set : ?loc:Loc.t -> aux_file -> string -> string -> aux_file module H : Map.S with type key = int * int module M : Map.S with type key = string @@ -22,6 +22,6 @@ val start_aux_file : aux_file:string -> v_file:string -> unit val stop_aux_file : unit -> unit val recording : unit -> bool -val record_in_aux_at : Loc.t -> string -> string -> unit +val record_in_aux_at : ?loc:Loc.t -> string -> string -> unit val record_in_aux : string -> string -> unit -val record_in_aux_set_at : Loc.t -> unit +val record_in_aux_set_at : ?loc:Loc.t -> unit -> unit diff --git a/lib/bigint.ml b/lib/bigint.ml index e95604ffc0..1ecc2ce2cc 100644 --- a/lib/bigint.ml +++ b/lib/bigint.ml @@ -257,9 +257,9 @@ let sub_mult m d q k = end done -(** Euclid division m/d = (q,r) - This is the "Floor" variant, as with ocaml's / - (but not as ocaml's Big_int.quomod_big_int). +(** Euclid division m/d = (q,r), with m = q*d+r and |r|<|q|. + This is the "Trunc" variant (a.k.a "Truncated-Toward-Zero"), + as with ocaml's / (but not as ocaml's Big_int.quomod_big_int). We have sign r = sign m *) let euclid m d = diff --git a/lib/bigint.mli b/lib/bigint.mli index e5525f164e..a1dc660771 100644 --- a/lib/bigint.mli +++ b/lib/bigint.mli @@ -30,6 +30,12 @@ val mult_2 : bigint -> bigint val add : bigint -> bigint -> bigint val sub : bigint -> bigint -> bigint val mult : bigint -> bigint -> bigint + +(** Euclid division m/d = (q,r), with m = q*d+r and |r|<|q|. + This is the "Trunc" variant (a.k.a "Truncated-Toward-Zero"), + as with ocaml's / (but not as ocaml's Big_int.quomod_big_int). + We have sign r = sign m *) + val euclid : bigint -> bigint -> bigint * bigint val less_than : bigint -> bigint -> bool diff --git a/lib/cAst.ml b/lib/cAst.ml new file mode 100644 index 0000000000..301a6bac8c --- /dev/null +++ b/lib/cAst.ml @@ -0,0 +1,24 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** The ast type contains generic metadata for AST nodes. *) +type 'a t = { + v : 'a; + loc : Loc.t option; +} + +let make ?loc v = { v; loc } + +let map f n = { n with v = f n.v } +let map_with_loc f n = { n with v = f ?loc:n.loc n.v } +let map_from_loc f l = + let loc, v = l in + { v = f ?loc v ; loc } + +let with_val f n = f n.v +let with_loc_val f n = f ?loc:n.loc n.v diff --git a/lib/cAst.mli b/lib/cAst.mli new file mode 100644 index 0000000000..700a06ce84 --- /dev/null +++ b/lib/cAst.mli @@ -0,0 +1,22 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** The ast type contains generic metadata for AST nodes *) +type 'a t = private { + v : 'a; + loc : Loc.t option; +} + +val make : ?loc:Loc.t -> 'a -> 'a t + +val map : ('a -> 'b) -> 'a t -> 'b t +val map_with_loc : (?loc:Loc.t -> 'a -> 'b) -> 'a t -> 'b t +val map_from_loc : (?loc:Loc.t -> 'a -> 'b) -> 'a Loc.located -> 'b t + +val with_val : ('a -> 'b) -> 'a t -> 'b +val with_loc_val : (?loc:Loc.t -> 'a -> 'b) -> 'a t -> 'b diff --git a/lib/cErrors.ml b/lib/cErrors.ml index b55fd80c68..b0e77a4c90 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -38,7 +38,6 @@ exception UserError of string option * std_ppcmds (* User errors *) let todo s = prerr_string ("TODO: "^s^"\n") let user_err ?loc ?hdr strm = Loc.raise ?loc (UserError (hdr, strm)) -let error string = user_err (str string) let invalid_arg ?loc s = Loc.raise ?loc (Invalid_argument s) @@ -138,3 +137,8 @@ let handled e = let bottom _ = raise Bottom in try let _ = print_gen bottom !handle_stack e in true with Bottom -> false + +(* Deprecated functions *) +let error string = user_err (str string) +let user_err_loc (loc,hdr,msg) = user_err ~loc ~hdr msg +let errorlabstrm hdr msg = user_err ~hdr msg diff --git a/lib/cErrors.mli b/lib/cErrors.mli index 0665a8ce73..ca0838575e 100644 --- a/lib/cErrors.mli +++ b/lib/cErrors.mli @@ -41,9 +41,6 @@ val user_err : ?loc:Loc.t -> ?hdr:string -> std_ppcmds -> 'a (** Main error raising primitive. [user_err ?loc ?hdr pp] signals an error [pp] with optional header and location [hdr] [loc] *) -val error : string -> 'a -(** [error s] just calls [user_error "_" (str s)] *) - exception AlreadyDeclared of std_ppcmds val alreadydeclared : std_ppcmds -> 'a @@ -98,3 +95,14 @@ val noncritical : exn -> bool (** Check whether an exception is handled by some toplevel printer. The [Anomaly] exception is never handled. *) val handled : exn -> bool + +(** Deprecated functions *) +val error : string -> 'a + [@@ocaml.deprecated "use [user_err] instead"] + +val errorlabstrm : string -> std_ppcmds -> 'a + [@@ocaml.deprecated "use [user_err ~hdr] instead"] + +val user_err_loc : Loc.t * string * std_ppcmds -> 'a + [@@ocaml.deprecated "use [user_err ~loc] instead"] + diff --git a/lib/cString.ml b/lib/cString.ml index 61ed03083e..7048dbb81b 100644 --- a/lib/cString.ml +++ b/lib/cString.ml @@ -11,7 +11,9 @@ module type S = module type of String module type ExtS = sig include S + [@@@ocaml.warning "-3"] (* [@@noalloc] since 4.03.0 GPR#240 *) external equal : string -> string -> bool = "caml_string_equal" "noalloc" + [@@@ocaml.warning "+3"] val hash : string -> int val is_empty : string -> bool val explode : string -> string list @@ -33,7 +35,9 @@ end include String +[@@@ocaml.warning "-3"] (* [@@noalloc] since 4.03.0 GPR#240 *) external equal : string -> string -> bool = "caml_string_equal" "noalloc" +[@@@ocaml.warning "+3"] let rec hash len s i accu = if i = len then accu diff --git a/lib/cString.mli b/lib/cString.mli index 65edfbbe68..b30f26abe7 100644 --- a/lib/cString.mli +++ b/lib/cString.mli @@ -14,7 +14,10 @@ sig include S (** We include the standard library *) + [@@@ocaml.warning "-3"] (* [@@noalloc] since 4.03.0 GPR#240 *) external equal : string -> string -> bool = "caml_string_equal" "noalloc" + [@@@ocaml.warning "+3"] + (** Equality on strings *) val hash : string -> int diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index 71e02b3ba4..d004fd6711 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -20,10 +20,10 @@ type t = { let warnings : (string, t) Hashtbl.t = Hashtbl.create 97 let categories : (string, string list) Hashtbl.t = Hashtbl.create 97 -let current_loc = ref Loc.ghost +let current_loc = ref None let flags = ref "" -let set_current_loc = (:=) current_loc +let set_current_loc loc = current_loc := loc let get_flags () = !flags @@ -35,29 +35,22 @@ let add_warning_in_category ~name ~category = in Hashtbl.replace categories category (name::ws) -let refine_loc = function - | None when not (Loc.is_ghost !current_loc) -> Some !current_loc - | loc -> loc - let create ~name ~category ?(default=Enabled) pp = Hashtbl.add warnings name { default; category; status = default }; add_warning_in_category ~name ~category; if default <> Disabled then add_warning_in_category ~name ~category:"default"; - fun ?loc x -> let w = Hashtbl.find warnings name in + fun ?loc x -> + let w = Hashtbl.find warnings name in + let loc = Option.append loc !current_loc in match w.status with | Disabled -> () - | AsError -> - begin match refine_loc loc with - | Some loc -> CErrors.user_err ~loc (pp x) - | None -> CErrors.user_err (pp x) - end + | AsError -> CErrors.user_err ?loc (pp x) | Enabled -> let msg = pp x ++ spc () ++ str "[" ++ str name ++ str "," ++ str category ++ str "]" in - let loc = refine_loc loc in Feedback.msg_warning ?loc msg let warn_unknown_warning = @@ -93,7 +86,7 @@ let parse_flag s = | '+' -> (AsError, String.sub s 1 (String.length s - 1)) | '-' -> (Disabled, String.sub s 1 (String.length s - 1)) | _ -> (Enabled, s) - else CErrors.error "Invalid warnings flag" + else CErrors.user_err Pp.(str "Invalid warnings flag") let string_of_flag (status,name) = match status with diff --git a/lib/cWarnings.mli b/lib/cWarnings.mli index 3f6cee31b7..c1fb5d6042 100644 --- a/lib/cWarnings.mli +++ b/lib/cWarnings.mli @@ -8,7 +8,7 @@ type status = Disabled | Enabled | AsError -val set_current_loc : Loc.t -> unit +val set_current_loc : Loc.t option -> unit val create : name:string -> category:string -> ?default:status -> ('a -> Pp.std_ppcmds) -> ?loc:Loc.t -> 'a -> unit diff --git a/lib/clib.mllib b/lib/clib.mllib index c73ae9b904..d5c938fe54 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -18,6 +18,7 @@ IStream Flags Control Loc +CAst CList CString Deque @@ -32,3 +33,4 @@ CUnix Envars Aux_file Monad +CoqProject_file diff --git a/lib/coqProject_file.ml4 b/lib/coqProject_file.ml4 new file mode 100644 index 0000000000..7a16605695 --- /dev/null +++ b/lib/coqProject_file.ml4 @@ -0,0 +1,215 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type project = { + project_file : string option; + makefile : string option; + install_kind : install option; + use_ocamlopt : bool; + + v_files : string list; + mli_files : string list; + ml4_files : string list; + ml_files : string list; + mllib_files : string list; + mlpack_files : string list; + + ml_includes : path list; + r_includes : (path * logic_path) list; + q_includes : (path * logic_path) list; + extra_args : string list; + defs : (string * string) list; + + extra_targets : extra_target list; + subdirs : string list; +} +and extra_target = { + target : string; + dependencies : string; + phony : bool; + command : string; +} +and logic_path = string +and path = { path : string; canonical_path : string } +and install = + | NoInstall + | TraditionalInstall + | UserInstall + +(* TODO generate with PPX *) +let mk_project project_file makefile install_kind use_ocamlopt = { + project_file; + makefile; + install_kind; + use_ocamlopt; + + v_files = []; + mli_files = []; + ml4_files = []; + ml_files = []; + mllib_files = []; + mlpack_files = []; + extra_targets = []; + subdirs = []; + ml_includes = []; + r_includes = []; + q_includes = []; + extra_args = []; + defs = []; +} + +(********************* utils ********************************************) + +let rec post_canonize f = + if Filename.basename f = Filename.current_dir_name + then let dir = Filename.dirname f in + if dir = Filename.current_dir_name then f else post_canonize dir + else f + +(* Avoid Sys.is_directory raise an exception (if the file does not exists) *) +let is_directory f = Sys.file_exists f && Sys.is_directory f + +(********************* parser *******************************************) + +exception Parsing_error of string + +let rec parse_string = parser + | [< '' ' | '\n' | '\t' >] -> "" + | [< 'c; s >] -> (String.make 1 c)^(parse_string s) + | [< >] -> "" +and parse_string2 = parser + | [< ''"' >] -> "" + | [< 'c; s >] -> (String.make 1 c)^(parse_string2 s) + | [< >] -> raise (Parsing_error "unterminated string") +and parse_skip_comment = parser + | [< ''\n'; s >] -> s + | [< 'c; s >] -> parse_skip_comment s + | [< >] -> [< >] +and parse_args = parser + | [< '' ' | '\n' | '\t'; s >] -> parse_args s + | [< ''#'; s >] -> parse_args (parse_skip_comment s) + | [< ''"'; str = parse_string2; s >] -> ("" ^ str) :: parse_args s + | [< 'c; str = parse_string; s >] -> ((String.make 1 c) ^ str) :: (parse_args s) + | [< >] -> [] + +let parse f = + let c = open_in f in + let res = parse_args (Stream.of_channel c) in + close_in c; + res +;; + +let process_cmd_line orig_dir proj args = + let orig_dir = (* avoids turning foo.v in ./foo.v *) + if orig_dir = "." then "" else orig_dir in + let error s = Feedback.msg_error (Pp.str (s^".")); exit 1 in + let mk_path d = + let p = CUnix.correct_path d orig_dir in + { path = CUnix.remove_path_dot (post_canonize p); + canonical_path = CUnix.canonical_path_name p } in + let rec aux proj = function + | [] -> proj + | "-impredicative-set" :: _ -> + error "Use \"-arg -impredicative-set\" instead of \"-impredicative-set\"" + | "-no-install" :: _ -> + error "Use \"-install none\" instead of \"-no-install\"" + | "-custom" :: _ -> + error "Use \"-extra[-phony] target deps command\" instead of \"-custom command deps target\"" + + | ("-no-opt"|"-byte") :: r -> aux { proj with use_ocamlopt = false } r + | ("-full"|"-opt") :: r -> aux { proj with use_ocamlopt = true } r + | "-install" :: d :: r -> + if proj.install_kind <> None then + Feedback.msg_warning (Pp.str "-install set more than once."); + let install = match d with + | "user" -> UserInstall + | "none" -> NoInstall + | "global" -> TraditionalInstall + | _ -> error ("invalid option \""^d^"\" passed to -install") in + aux { proj with install_kind = Some install } r + | "-extra" :: target :: dependencies :: command :: r -> + let tgt = { target; dependencies; phony = false; command } in + aux { proj with extra_targets = proj.extra_targets @ [tgt] } r + | "-extra-phony" :: target :: dependencies :: command :: r -> + let tgt = { target; dependencies; phony = true; command } in + aux { proj with extra_targets = proj.extra_targets @ [tgt] } r + + | "-Q" :: d :: lp :: r -> + aux { proj with q_includes = proj.q_includes @ [mk_path d,lp] } r + | "-I" :: d :: r -> + aux { proj with ml_includes = proj.ml_includes @ [mk_path d] } r + | "-R" :: d :: lp :: r -> + aux { proj with r_includes = proj.r_includes @ [mk_path d,lp] } r + + | "-f" :: file :: r -> + let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in + let () = match proj.project_file with + | None -> () + | Some _ -> Feedback.msg_warning (Pp.str + "Multiple project files are deprecated.") + in + let proj = aux { proj with project_file = Some file } (parse file) in + aux proj r + + | "-o" :: file :: r -> + if String.contains file '/' then + error "Output file must be in the current directory"; + if proj.makefile <> None then + error "Option -o given more than once"; + aux { proj with makefile = Some file } r + | v :: "=" :: def :: r -> + aux { proj with defs = proj.defs @ [v,def] } r + | "-arg" :: a :: r -> + aux { proj with extra_args = proj.extra_args @ [a] } r + | f :: r -> + let f = CUnix.correct_path f orig_dir in + let proj = + if is_directory f then { proj with subdirs = proj.subdirs @ [f] } + else match CUnix.get_extension f with + | ".v" -> { proj with v_files = proj.v_files @ [f] } + | ".ml" -> { proj with ml_files = proj.ml_files @ [f] } + | ".ml4" -> { proj with ml4_files = proj.ml4_files @ [f] } + | ".mli" -> { proj with mli_files = proj.mli_files @ [f] } + | ".mllib" -> { proj with mllib_files = proj.mllib_files @ [f] } + | ".mlpack" -> { proj with mlpack_files = proj.mlpack_files @ [f] } + | _ -> raise (Parsing_error ("Unknown option "^f)) in + aux proj r + in + aux proj args + + (******************************* API ************************************) + +let cmdline_args_to_project ~curdir args = + process_cmd_line curdir (mk_project None None None true) args + +let read_project_file f = + process_cmd_line (Filename.dirname f) + (mk_project (Some f) None (Some NoInstall) true) (parse f) + +let rec find_project_file ~from ~projfile_name = + let fname = Filename.concat from projfile_name in + if Sys.file_exists fname then Some fname + else + let newdir = Filename.dirname from in + if newdir = "" || newdir = "/" then None + else find_project_file ~from:newdir ~projfile_name +;; + +let coqtop_args_from_project + { ml_includes; r_includes; q_includes; extra_args } += + let map = List.map in + let args = + map (fun { canonical_path = i } -> ["-I"; i]) ml_includes @ + map (fun ({ canonical_path = i }, l) -> ["-Q"; i; l]) q_includes @ + map (fun ({ canonical_path = p }, l) -> ["-R"; p; l]) r_includes @ + [extra_args] in + List.flatten args +;; + +(* vim:set ft=ocaml: *) diff --git a/lib/coqProject_file.mli b/lib/coqProject_file.mli new file mode 100644 index 0000000000..8c8fc068a3 --- /dev/null +++ b/lib/coqProject_file.mli @@ -0,0 +1,52 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +exception Parsing_error of string + +type project = { + project_file : string option; + makefile : string option; + install_kind : install option; + use_ocamlopt : bool; + + v_files : string list; + mli_files : string list; + ml4_files : string list; + ml_files : string list; + mllib_files : string list; + mlpack_files : string list; + + ml_includes : path list; + r_includes : (path * logic_path) list; + q_includes : (path * logic_path) list; + extra_args : string list; + defs : (string * string) list; + + (* deprecated in favor of a Makefile.local using :: rules *) + extra_targets : extra_target list; + subdirs : string list; + +} +and extra_target = { + target : string; + dependencies : string; + phony : bool; + command : string; +} +and logic_path = string +and path = { path : string; canonical_path : string } +and install = + | NoInstall + | TraditionalInstall + | UserInstall + +val cmdline_args_to_project : curdir:string -> string list -> project +val read_project_file : string -> project +val coqtop_args_from_project : project -> string list +val find_project_file : from:string -> projfile_name:string -> string option + diff --git a/lib/envars.ml b/lib/envars.ml index 89ce528318..bc8012297f 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -23,8 +23,6 @@ let ( / ) a b = let coqify d = d / "coq" -let opt2list = function None -> [] | Some x -> [x] - let home ~warn = getenv_else "HOME" (fun () -> try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found -> @@ -81,9 +79,6 @@ let expand_path_macros ~warn s = (** {2 Coq paths} *) -let relative_base = - Filename.dirname (Filename.dirname Sys.executable_name) - let coqbin = CUnix.canonical_path_name (Filename.dirname Sys.executable_name) @@ -98,25 +93,26 @@ let _ = if Coq_config.arch_is_win32 then Unix.putenv "PATH" (coqbin ^ ";" ^ getenv_else "PATH" (fun () -> "")) +(** Add a local installation suffix (unless the suffix is itself + absolute in which case the prefix does not matter) *) +let use_suffix prefix suffix = + if String.length suffix > 0 && suffix.[0] = '/' then suffix else prefix / suffix + (** [check_file_else ~dir ~file oth] checks if [file] exists in - the installation directory [dir] given relatively to [coqroot]. - If this Coq is only locally built, then [file] must be in [coqroot]. + the installation directory [dir] given relatively to [coqroot], + which maybe has been relocated. If the check fails, then [oth ()] is evaluated. Using file system equality seems well enough for this heuristic *) let check_file_else ~dir ~file oth = - let path = if Coq_config.local then coqroot else coqroot / dir in + let path = use_suffix coqroot dir in if Sys.file_exists (path / file) then path else oth () let guess_coqlib fail = let prelude = "theories/Init/Prelude.vo" in - let dir = if Coq_config.arch_is_win32 then "lib" else "lib/coq" in - check_file_else ~dir ~file:prelude + check_file_else ~dir:Coq_config.coqlibsuffix ~file:prelude (fun () -> - let coqlib = match Coq_config.coqlib with - | Some coqlib -> coqlib - | None -> coqroot - in - if Sys.file_exists (coqlib / prelude) then coqlib + if not Coq_config.local && Sys.file_exists (Coq_config.coqlib / prelude) + then Coq_config.coqlib else fail "cannot guess a path for Coq libraries; please use -coqlib option") @@ -130,8 +126,19 @@ let set_coqlib ~fail = let coqlib () = !Flags.coqlib let docdir () = - let dir = if Coq_config.arch_is_win32 then "doc" else "share/doc/coq" in - check_file_else ~dir ~file:"html" (fun () -> Coq_config.docdir) + (* This assumes implicitly that the suffix is non-trivial *) + let path = use_suffix coqroot Coq_config.docdirsuffix in + if Sys.file_exists path then path else Coq_config.docdir + +let datadir () = + (* This assumes implicitly that the suffix is non-trivial *) + let path = use_suffix coqroot Coq_config.datadirsuffix in + if Sys.file_exists path then path else Coq_config.datadir + +let configdir () = + (* This assumes implicitly that the suffix is non-trivial *) + let path = use_suffix coqroot Coq_config.configdirsuffix in + if Sys.file_exists path then path else Coq_config.configdir let coqpath = let coqpath = getenv_else "COQPATH" (fun () -> "") in @@ -146,12 +153,8 @@ let coqpath = let exe s = s ^ Coq_config.exec_extension -let guess_ocamlfind () = which (user_path ()) (exe "ocamlfind") - let ocamlfind () = - if !Flags.ocamlfind_spec then !Flags.ocamlfind else - if !Flags.boot then Coq_config.ocamlfind else - try guess_ocamlfind () / "ocamlfind" with Not_found -> Coq_config.ocamlfind + if !Flags.ocamlfind_spec then !Flags.ocamlfind else Coq_config.ocamlfind (** {2 Camlp4 paths} *) @@ -190,20 +193,34 @@ let xdg_data_dirs warn = try List.map coqify (path_to_list (Sys.getenv "XDG_DATA_DIRS")) with - | Not_found when String.equal Sys.os_type "Win32" -> [relative_base / "share"] - | Not_found -> ["/usr/local/share/coq";"/usr/share/coq"] + | Not_found -> [datadir ()] in - xdg_data_home warn :: sys_dirs @ opt2list Coq_config.datadir - -let xdg_config_dirs warn = - let sys_dirs = - try - List.map coqify (path_to_list (Sys.getenv "XDG_CONFIG_DIRS")) - with - | Not_found when String.equal Sys.os_type "Win32" -> [relative_base / "config"] - | Not_found -> ["/etc/xdg/coq"] - in - xdg_config_home warn :: sys_dirs @ opt2list Coq_config.configdir + xdg_data_home warn :: sys_dirs let xdg_dirs ~warn = List.filter Sys.file_exists (xdg_data_dirs warn) + +(* Print the configuration information *) + +let coq_src_subdirs = [ + "config" ; "dev" ; "lib" ; "kernel" ; "library" ; + "engine" ; "pretyping" ; "interp" ; "parsing" ; "proofs" ; + "tactics" ; "toplevel" ; "printing" ; "intf" ; + "grammar" ; "ide" ; "stm"; "vernac" ] @ + Coq_config.plugins_dirs + +let print_config ?(prefix_var_name="") f = + let open Printf in + fprintf f "%sLOCAL=%s\n" prefix_var_name (if Coq_config.local then "1" else "0"); + fprintf f "%sCOQLIB=%s/\n" prefix_var_name (coqlib ()); + fprintf f "%sDOCDIR=%s/\n" prefix_var_name (docdir ()); + fprintf f "%sOCAMLFIND=%s\n" prefix_var_name (ocamlfind ()); + fprintf f "%sCAMLP4=%s\n" prefix_var_name Coq_config.camlp4; + fprintf f "%sCAMLP4O=%s\n" prefix_var_name Coq_config.camlp4o; + fprintf f "%sCAMLP4BIN=%s/\n" prefix_var_name (camlp4bin ()); + fprintf f "%sCAMLP4LIB=%s\n" prefix_var_name (camlp4lib ()); + fprintf f "%sCAMLP4OPTIONS=%s\n" prefix_var_name Coq_config.camlp4compat; + fprintf f "%sHASNATDYNLINK=%s\n" prefix_var_name + (if Coq_config.has_natdynlink then "true" else "false"); + fprintf f "%sCOQ_SRC_SUBDIRS=%s\n" prefix_var_name (String.concat " " coq_src_subdirs) + diff --git a/lib/envars.mli b/lib/envars.mli index 90a42859b9..c8bbf17d96 100644 --- a/lib/envars.mli +++ b/lib/envars.mli @@ -27,12 +27,18 @@ val home : warn:(string -> unit) -> string (** [coqlib] is the path to the Coq library. *) val coqlib : unit -> string +(** [docdir] is the path to the installed documentation. *) +val docdir : unit -> string + +(** [datadir] is the path to the installed data directory. *) +val datadir : unit -> string + +(** [configdir] is the path to the installed config directory. *) +val configdir : unit -> string + (** [set_coqlib] must be runned once before any access to [coqlib] *) val set_coqlib : fail:(string -> string) -> unit -(** [docdir] is the path to the Coq documentation. *) -val docdir : unit -> string - (** [coqbin] is the name of the current executable. *) val coqbin : string @@ -66,6 +72,11 @@ val camlp4 : unit -> string *) val xdg_config_home : (string -> unit) -> string val xdg_data_home : (string -> unit) -> string -val xdg_config_dirs : (string -> unit) -> string list val xdg_data_dirs : (string -> unit) -> string list val xdg_dirs : warn : (string -> unit) -> string list + +(** {6 Prints the configuration information } *) +val print_config : ?prefix_var_name:string -> out_channel -> unit + +(** Directories in which coq sources are found *) +val coq_src_subdirs : string list diff --git a/lib/feedback.ml b/lib/feedback.ml index 0846e419b2..f6abf65120 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -30,7 +30,7 @@ type feedback_content = | FileDependency of string option * string | FileLoaded of string * string (* Extra metadata *) - | Custom of Loc.t * string * xml + | Custom of Loc.t option * string * xml (* Generic messages *) | Message of level * Loc.t option * Pp.std_ppcmds diff --git a/lib/feedback.mli b/lib/feedback.mli index bdd236ac78..dc104132a0 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -38,7 +38,7 @@ type feedback_content = | FileDependency of string option * string | FileLoaded of string * string (* Extra metadata *) - | Custom of Loc.t * string * xml + | Custom of Loc.t option * string * xml (* Generic messages *) | Message of level * Loc.t option * Pp.std_ppcmds diff --git a/lib/flags.ml b/lib/flags.ml index 00f515b5a6..b2671e5b60 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -80,6 +80,8 @@ let async_proofs_is_master () = let async_proofs_delegation_threshold = ref 0.03 let debug = ref false +let stm_debug = ref false + let in_debugger = ref false let in_toplevel = ref false diff --git a/lib/flags.mli b/lib/flags.mli index 0b00ac13c2..7ce808041a 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -49,6 +49,9 @@ val debug : bool ref val in_debugger : bool ref val in_toplevel : bool ref +(** Enable STM debugging *) +val stm_debug : bool ref + val profile : bool (* Legacy flags *) diff --git a/lib/hashcons.ml b/lib/hashcons.ml index 4eaacf9145..0ee3ec6277 100644 --- a/lib/hashcons.ml +++ b/lib/hashcons.ml @@ -130,7 +130,11 @@ module Hstring = Make( type t = string type u = unit let hashcons () s =(* incr accesstr;*) s + + [@@@ocaml.warning "-3"] (* [@@noalloc] since 4.03.0 GPR#240 *) external eq : string -> string -> bool = "caml_string_equal" "noalloc" + [@@@ocaml.warning "+3"] + (** Copy from CString *) let rec hash len s i accu = if i = len then accu diff --git a/lib/loc.ml b/lib/loc.ml index e373a760cb..ee759bdfc1 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -26,12 +26,6 @@ let make_loc (bp, ep) = { fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; bp = bp; ep = ep; } -let ghost = { - fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; - bp = 0; ep = 0; } - -let is_ghost loc = loc.ep = 0 - let merge loc1 loc2 = if loc1.bp < loc2.bp then if loc1.ep < loc2.ep then { @@ -51,24 +45,25 @@ let merge loc1 loc2 = bp = loc2.bp; ep = loc1.ep; } else loc2 -let unloc loc = (loc.bp, loc.ep) +let merge_opt l1 l2 = match l1, l2 with + | None, None -> None + | Some l , None -> Some l + | None, Some l -> Some l + | Some l1, Some l2 -> Some (merge l1 l2) -let dummy_loc = ghost -let join_loc = merge +let unloc loc = (loc.bp, loc.ep) (** Located type *) +type 'a located = t option * 'a -type 'a located = t * 'a -let located_fold_left f x (_,a) = f x a -let located_iter2 f (_,a) (_,b) = f a b -let down_located f (_,a) = f a +let tag ?loc x = loc, x +let map f (l,x) = (l, f x) (** Exceptions *) let location : t Exninfo.t = Exninfo.make () let add_loc e loc = Exninfo.add e location loc - let get_loc e = Exninfo.get e location let raise ?loc e = @@ -77,3 +72,10 @@ let raise ?loc e = | Some loc -> let info = Exninfo.add Exninfo.null location loc in Exninfo.iraise (e, info) + +(** Deprecated *) +let located_fold_left f x (_,a) = f x a +let located_iter2 f (_,a) (_,b) = f a b +let down_located f (_,a) = f a + + diff --git a/lib/loc.mli b/lib/loc.mli index bb88f86428..edcf701bf2 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -18,9 +18,6 @@ type t = { ep : int; (** end position *) } -type 'a located = t * 'a -(** Embed a location in a type *) - (** {5 Location manipulation} *) (** This is inherited from CAMPL4/5. *) @@ -35,13 +32,9 @@ val unloc : t -> int * int val make_loc : int * int -> t (** Make a location out of its start and end position *) -val ghost : t -(** Dummy location *) - -val is_ghost : t -> bool -(** Test whether the location is meaningful *) - val merge : t -> t -> t +val merge_opt : t option -> t option -> t option +(** Merge locations, usually generating the largest possible span *) (** {5 Located exceptions} *) @@ -54,18 +47,23 @@ val get_loc : Exninfo.info -> t option val raise : ?loc:t -> exn -> 'a (** [raise loc e] is the same as [Pervasives.raise (add_loc e loc)]. *) -(** {5 Location utilities} *) +(** {5 Objects with location information } *) + +type 'a located = t option * 'a +val tag : ?loc:t -> 'a -> 'a located +(** Embed a location in a type *) + +val map : ('a -> 'b) -> 'a located -> 'b located +(** Modify an object carrying a location *) + +(** Deprecated functions *) val located_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b located -> 'a -val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit + [@@ocaml.deprecated "use pattern matching"] val down_located : ('a -> 'b) -> 'a located -> 'b -(** Projects out a located object *) + [@@ocaml.deprecated "use pattern matching"] -(** {5 Backward compatibility} *) - -val dummy_loc : t -(** Same as [ghost] *) +val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit + [@@ocaml.deprecated "use pattern matching"] -val join_loc : t -> t -> t -(** Same as [merge] *) diff --git a/lib/stateid.ml b/lib/stateid.ml index c153f0e808..29f020071b 100644 --- a/lib/stateid.ml +++ b/lib/stateid.ml @@ -40,7 +40,7 @@ type ('a,'b) request = { exn_info : t * t; stop : t; document : 'b; - loc : Loc.t; + loc : Loc.t option; uuid : 'a; name : string } diff --git a/lib/stateid.mli b/lib/stateid.mli index 1d87a343b3..d9e75f5840 100644 --- a/lib/stateid.mli +++ b/lib/stateid.mli @@ -34,7 +34,7 @@ type ('a,'b) request = { exn_info : t * t; stop : t; document : 'b; - loc : Loc.t; + loc : Loc.t option; uuid : 'a; name : string } diff --git a/lib/util.ml b/lib/util.ml index 0d2425f271..36282b2dac 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -136,6 +136,8 @@ type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a type ('a, 'b) eq = ('a, 'b) CSig.eq = Refl : ('a, 'a) eq +let sym : type a b. (a, b) eq -> (b, a) eq = fun Refl -> Refl + module Union = struct let map f g = function diff --git a/lib/util.mli b/lib/util.mli index cf8041a0d9..56ec5394eb 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -133,5 +133,7 @@ type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a type ('a, 'b) eq = ('a, 'b) CSig.eq = Refl : ('a, 'a) eq +val sym : ('a, 'b) eq -> ('b, 'a) eq + val open_utf8_file_in : string -> in_channel (** Open an utf-8 encoded file and skip the byte-order mark if any. *) diff --git a/interp/coqlib.ml b/library/coqlib.ml index 9539980f04..955ff4c089 100644 --- a/interp/coqlib.ml +++ b/library/coqlib.ml @@ -10,11 +10,9 @@ open CErrors open Util open Pp open Names -open Term open Libnames open Globnames open Nametab -open Smartlocate let coq = Nameops.coq_string (* "Coq" *) @@ -26,29 +24,27 @@ type message = string let make_dir l = DirPath.make (List.rev_map Id.of_string l) let find_reference locstr dir s = - let sp = Libnames.make_path (make_dir dir) (Id.of_string s) in - try global_of_extended_global (Nametab.extended_global_of_path sp) + let dp = make_dir dir in + let sp = Libnames.make_path dp (Id.of_string s) in + try Nametab.global_of_path sp with Not_found -> - anomaly ~label:locstr (str "cannot find " ++ Libnames.pr_path sp) + (* Following bug 5066 we are more permissive with the handling + of not found errors here *) + user_err ~hdr:locstr + Pp.(str "cannot find " ++ Libnames.pr_path sp ++ + str "; maybe library " ++ Libnames.pr_dirpath dp ++ + str " has to be required first.") let coq_reference locstr dir s = find_reference locstr (coq::dir) s -let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s) - -let gen_reference = coq_reference -let gen_constant = coq_constant let has_suffix_in_dirs dirs ref = let dir = dirpath (path_of_global ref) in List.exists (fun d -> is_dirpath_prefix_of d dir) dirs -let global_of_extended q = - try Some (global_of_extended_global q) with Not_found -> None - let gen_reference_in_modules locstr dirs s = let dirs = List.map make_dir dirs in let qualid = qualid_of_string s in - let all = Nametab.locate_extended_all qualid in - let all = List.map_filter global_of_extended all in + let all = Nametab.locate_all qualid in let all = List.sort_uniquize RefOrdered_env.compare all in let these = List.filter (has_suffix_in_dirs dirs) all in match these with @@ -65,10 +61,6 @@ let gen_reference_in_modules locstr dirs s = str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++ prlist_with_sep pr_comma pr_dirpath dirs) -let gen_constant_in_modules locstr dirs s = - Universes.constr_of_global (gen_reference_in_modules locstr dirs s) - - (* For tactics/commands requiring vernacular libraries *) let check_required_library d = @@ -93,16 +85,12 @@ let check_required_library d = (* Specific Coq objects *) let init_reference dir s = - let d = "Init"::dir in - check_required_library (coq::d); gen_reference "Coqlib" d s - -let init_constant dir s = - let d = "Init"::dir in - check_required_library (coq::d); gen_constant "Coqlib" d s + let d = coq::"Init"::dir in + check_required_library d; find_reference "Coqlib" d s let logic_reference dir s = - let d = "Logic"::dir in - check_required_library ("Coq"::d); gen_reference "Coqlib" d s + let d = coq::"Logic"::dir in + check_required_library d; find_reference "Coqlib" d s let arith_dir = [coq;"Arith"] let arith_modules = [arith_dir] @@ -149,12 +137,6 @@ let make_con dir id = Globnames.encode_con dir (Id.of_string id) let id = make_con datatypes_module "idProp" let type_of_id = make_con datatypes_module "IDProp" -let _ = Termops.set_impossible_default_clause - (fun () -> - let c, ctx = Universes.fresh_global_instance (Global.env()) (ConstRef id) in - let (_, u) = destConst c in - (c,mkConstU (type_of_id,u)), ctx) - (** Natural numbers *) let nat_kn = make_ind datatypes_module "nat" let nat_path = Libnames.make_path datatypes_module (Id.of_string "nat") @@ -194,14 +176,14 @@ type coq_sigma_data = { typ : global_reference } type coq_bool_data = { - andb : constr; - andb_prop : constr; - andb_true_intro : constr} + andb : global_reference; + andb_prop : global_reference; + andb_true_intro : global_reference} let build_bool_type () = - { andb = init_constant ["Datatypes"] "andb"; - andb_prop = init_constant ["Datatypes"] "andb_prop"; - andb_true_intro = init_constant ["Datatypes"] "andb_true_intro" } + { andb = init_reference ["Datatypes"] "andb"; + andb_prop = init_reference ["Datatypes"] "andb_prop"; + andb_true_intro = init_reference ["Datatypes"] "andb_true_intro" } let build_sigma_set () = anomaly (Pp.str "Use build_sigma_type") @@ -244,7 +226,6 @@ type coq_inversion_data = { } let lazy_init_reference dir id = lazy (init_reference dir id) -let lazy_init_constant dir id = lazy (init_constant dir id) let lazy_logic_reference dir id = lazy (logic_reference dir id) (* Leibniz equality on Type *) @@ -307,7 +288,7 @@ let build_coq_inversion_jmeq_data () = inv_congr = Lazy.force coq_jmeq_congr_canonical } (* Specif *) -let coq_sumbool = lazy_init_constant ["Specif"] "sumbool" +let coq_sumbool = lazy_init_reference ["Specif"] "sumbool" let build_coq_sumbool () = Lazy.force coq_sumbool @@ -349,22 +330,22 @@ let build_coq_inversion_eq_true_data () = inv_congr = Lazy.force coq_eq_true_congr } (* The False proposition *) -let coq_False = lazy_init_constant ["Logic"] "False" +let coq_False = lazy_init_reference ["Logic"] "False" (* The True proposition and its unique proof *) -let coq_True = lazy_init_constant ["Logic"] "True" -let coq_I = lazy_init_constant ["Logic"] "I" +let coq_True = lazy_init_reference ["Logic"] "True" +let coq_I = lazy_init_reference ["Logic"] "I" (* Connectives *) -let coq_not = lazy_init_constant ["Logic"] "not" -let coq_and = lazy_init_constant ["Logic"] "and" -let coq_conj = lazy_init_constant ["Logic"] "conj" -let coq_or = lazy_init_constant ["Logic"] "or" -let coq_ex = lazy_init_constant ["Logic"] "ex" -let coq_iff = lazy_init_constant ["Logic"] "iff" +let coq_not = lazy_init_reference ["Logic"] "not" +let coq_and = lazy_init_reference ["Logic"] "and" +let coq_conj = lazy_init_reference ["Logic"] "conj" +let coq_or = lazy_init_reference ["Logic"] "or" +let coq_ex = lazy_init_reference ["Logic"] "ex" +let coq_iff = lazy_init_reference ["Logic"] "iff" -let coq_iff_left_proj = lazy_init_constant ["Logic"] "proj1" -let coq_iff_right_proj = lazy_init_constant ["Logic"] "proj2" +let coq_iff_left_proj = lazy_init_reference ["Logic"] "proj1" +let coq_iff_right_proj = lazy_init_reference ["Logic"] "proj2" (* Runtime part *) let build_coq_True () = Lazy.force coq_True @@ -385,8 +366,8 @@ let build_coq_iff_right_proj () = Lazy.force coq_iff_right_proj (* The following is less readable but does not depend on parsing *) let coq_eq_ref = lazy (init_reference ["Logic"] "eq") let coq_identity_ref = lazy (init_reference ["Datatypes"] "identity") -let coq_jmeq_ref = lazy (gen_reference "Coqlib" ["Logic";"JMeq"] "JMeq") -let coq_eq_true_ref = lazy (gen_reference "Coqlib" ["Init";"Datatypes"] "eq_true") +let coq_jmeq_ref = lazy (find_reference "Coqlib" [coq;"Logic";"JMeq"] "JMeq") +let coq_eq_true_ref = lazy (find_reference "Coqlib" [coq;"Init";"Datatypes"] "eq_true") let coq_existS_ref = lazy (anomaly (Pp.str "use coq_existT_ref")) let coq_existT_ref = lazy (init_reference ["Specif"] "existT") let coq_exist_ref = lazy (init_reference ["Specif"] "exist") @@ -397,3 +378,6 @@ let coq_sig_ref = lazy (init_reference ["Specif"] "sig") let coq_or_ref = lazy (init_reference ["Logic"] "or") let coq_iff_ref = lazy (init_reference ["Logic"] "iff") +(* Deprecated *) +let gen_reference = coq_reference + diff --git a/interp/coqlib.mli b/library/coqlib.mli index 1facb47e1e..716d97c9d0 100644 --- a/interp/coqlib.mli +++ b/library/coqlib.mli @@ -9,12 +9,30 @@ open Names open Libnames open Globnames -open Term open Util (** This module collects the global references, constructions and patterns of the standard library used in ocaml files *) +(** The idea is to migrate to rebindable name-based approach, thus the + only function this FILE will provide will be: + + [find_reference : string -> global_reference] + + such that [find_reference "core.eq.type"] returns the proper [global_reference] + + [bind_reference : string -> global_reference -> unit] + + will bind a reference. + + A feature based approach would be possible too. + + Contrary to the old approach of raising an anomaly, we expect + tactics to gracefully fail in the absence of some primitive. + + This is work in progress, see below. +*) + (** {6 ... } *) (** [find_reference caller_message [dir;subdir;...] s] returns a global reference to the name dir.subdir.(...).s; the corresponding module @@ -25,31 +43,18 @@ open Util type message = string val find_reference : message -> string list -> string -> global_reference - -(** [coq_reference caller_message [dir;subdir;...] s] returns a - global reference to the name Coq.dir.subdir.(...).s *) - val coq_reference : message -> string list -> string -> global_reference -(** idem but return a term *) - -val coq_constant : message -> string list -> string -> constr - -(** Synonyms of [coq_constant] and [coq_reference] *) - -val gen_constant : message -> string list -> string -> constr -val gen_reference : message -> string list -> string -> global_reference +(** For tactics/commands requiring vernacular libraries *) +val check_required_library : string list -> unit (** Search in several modules (not prefixed by "Coq") *) -val gen_constant_in_modules : string->string list list-> string -> constr val gen_reference_in_modules : string->string list list-> string -> global_reference + val arith_modules : string list list val zarith_base_modules : string list list val init_modules : string list list -(** For tactics/commands requiring vernacular libraries *) -val check_required_library : string list -> unit - (** {6 Global references } *) (** Modules *) @@ -65,6 +70,10 @@ val jmeq_module_name : string list val datatypes_module_name : string list +(** Identity *) +val id : constant +val type_of_id : constant + (** Natural numbers *) val nat_path : full_path val glob_nat : global_reference @@ -95,9 +104,9 @@ val glob_jmeq : global_reference at runtime. *) type coq_bool_data = { - andb : constr; - andb_prop : constr; - andb_true_intro : constr} + andb : global_reference; + andb_prop : global_reference; + andb_true_intro : global_reference} val build_bool_type : coq_bool_data delayed (** {6 For Equality tactics } *) @@ -154,33 +163,33 @@ val build_coq_inversion_jmeq_data : coq_inversion_data delayed val build_coq_inversion_eq_true_data : coq_inversion_data delayed (** Specif *) -val build_coq_sumbool : constr delayed +val build_coq_sumbool : global_reference delayed (** {6 ... } *) (** Connectives The False proposition *) -val build_coq_False : constr delayed +val build_coq_False : global_reference delayed (** The True proposition and its unique proof *) -val build_coq_True : constr delayed -val build_coq_I : constr delayed +val build_coq_True : global_reference delayed +val build_coq_I : global_reference delayed (** Negation *) -val build_coq_not : constr delayed +val build_coq_not : global_reference delayed (** Conjunction *) -val build_coq_and : constr delayed -val build_coq_conj : constr delayed -val build_coq_iff : constr delayed +val build_coq_and : global_reference delayed +val build_coq_conj : global_reference delayed +val build_coq_iff : global_reference delayed -val build_coq_iff_left_proj : constr delayed -val build_coq_iff_right_proj : constr delayed +val build_coq_iff_left_proj : global_reference delayed +val build_coq_iff_right_proj : global_reference delayed (** Disjunction *) -val build_coq_or : constr delayed +val build_coq_or : global_reference delayed (** Existential quantifier *) -val build_coq_ex : constr delayed +val build_coq_ex : global_reference delayed val coq_eq_ref : global_reference lazy_t val coq_identity_ref : global_reference lazy_t @@ -196,3 +205,7 @@ val coq_sig_ref : global_reference lazy_t val coq_or_ref : global_reference lazy_t val coq_iff_ref : global_reference lazy_t + +(* Deprecated functions *) +val gen_reference : message -> string list -> string -> global_reference +[@@ocaml.deprecated "Please use Coqlib.find_reference"] diff --git a/library/declare.ml b/library/declare.ml index 91e0cb44b3..95b3674c3e 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -512,8 +512,8 @@ let do_constraint poly l = let open Misctypes in let u_of_id x = match x with - | GProp -> Loc.dummy_loc, (false, Univ.Level.prop) - | GSet -> Loc.dummy_loc, (false, Univ.Level.set) + | GProp -> Loc.tag (false, Univ.Level.prop) + | GSet -> Loc.tag (false, Univ.Level.set) | GType None | GType (Some (_, Anonymous)) -> user_err ~hdr:"Constraint" (str "Cannot declare constraints on anonymous universes") @@ -521,7 +521,7 @@ let do_constraint poly l = let names, _ = Global.global_universe_names () in try loc, Idmap.find id names with Not_found -> - user_err ~loc ~hdr:"Constraint" (str "Undeclared universe " ++ pr_id id) + user_err ?loc ~hdr:"Constraint" (str "Undeclared universe " ++ pr_id id) in let in_section = Lib.sections_are_opened () in let () = @@ -529,18 +529,18 @@ let do_constraint poly l = user_err ~hdr:"Constraint" (str"Cannot declare polymorphic constraints outside sections") in - let check_poly loc p loc' p' = + let check_poly ?loc p loc' p' = if poly then () else if p || p' then let loc = if p then loc else loc' in - user_err ~loc ~hdr:"Constraint" + user_err ?loc ~hdr:"Constraint" (str "Cannot declare a global constraint on " ++ str "a polymorphic universe, use " ++ str "Polymorphic Constraint instead") in let constraints = List.fold_left (fun acc (l, d, r) -> let ploc, (p, lu) = u_of_id l and rloc, (p', ru) = u_of_id r in - check_poly ploc p rloc p'; + check_poly ?loc:ploc p rloc p'; Univ.Constraint.add (lu, d, ru) acc) Univ.Constraint.empty l in diff --git a/library/declaremods.ml b/library/declaremods.ml index 3a263b1e12..08c33b5c15 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -345,7 +345,7 @@ let get_applications mexpr = let rec get params = function | MEident mp -> mp, params | MEapply (fexpr, mp) -> get (mp::params) fexpr - | MEwith _ -> error "Non-atomic functor application." + | MEwith _ -> user_err Pp.(str "Non-atomic functor application.") in get [] mexpr (** Create the substitution corresponding to some functor applications *) @@ -353,7 +353,7 @@ let get_applications mexpr = let rec compute_subst env mbids sign mp_l inl = match mbids,mp_l with | _,[] -> mbids,empty_subst - | [],r -> error "Application of a functor with too few arguments." + | [],r -> user_err Pp.(str "Application of a functor with too few arguments.") | mbid::mbids,mp::mp_l -> let farg_id, farg_b, fbody_b = Modops.destr_functor sign in let mb = Environ.lookup_module mp env in @@ -777,7 +777,7 @@ let rec decompose_functor mpl typ = match mpl, typ with | [], _ -> typ | _::mpl, MoreFunctor(_,_,str) -> decompose_functor mpl str - | _ -> error "Application of a functor with too much arguments." + | _ -> user_err Pp.(str "Application of a functor with too much arguments.") exception NoIncludeSelf diff --git a/library/goptions.ml b/library/goptions.ml index c111113ca0..a803771cbc 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -24,7 +24,6 @@ type option_value = (** Summary of an option status *) type option_state = { - opt_sync : bool; opt_depr : bool; opt_name : string; opt_value : option_value; @@ -62,7 +61,6 @@ module MakeTable = val key : option_name val title : string val member_message : t -> bool -> std_ppcmds - val synchronous : bool end) -> struct type option_mark = @@ -73,17 +71,13 @@ module MakeTable = let _ = if String.List.mem_assoc nick !A.table then - error "Sorry, this table name is already used." + user_err Pp.(str "Sorry, this table name is already used.") module MySet = Set.Make (struct type t = A.t let compare = A.compare end) - let t = - if A.synchronous - then Summary.ref MySet.empty ~name:nick - else ref MySet.empty + let t = Summary.ref MySet.empty ~name:nick let (add_option,remove_option) = - if A.synchronous then let cache_options (_,(f,p)) = match f with | GOadd -> t := MySet.add p !t | GOrmv -> t := MySet.remove p !t in @@ -103,9 +97,6 @@ module MakeTable = in ((fun c -> Lib.add_anonymous_leaf (inGo (GOadd, c))), (fun c -> Lib.add_anonymous_leaf (inGo (GOrmv, c)))) - else - ((fun c -> t := MySet.add c !t), - (fun c -> t := MySet.remove c !t)) let print_table table_name printer table = Feedback.msg_notice @@ -141,7 +132,6 @@ sig val key : option_name val title : string val member_message : string -> bool -> std_ppcmds - val synchronous : bool end module StringConvert = functor (A : StringConvertArg) -> @@ -156,7 +146,6 @@ struct let key = A.key let title = A.title let member_message = A.member_message - let synchronous = A.synchronous end module MakeStringTable = @@ -176,7 +165,6 @@ sig val key : option_name val title : string val member_message : t -> bool -> std_ppcmds - val synchronous : bool end module RefConvert = functor (A : RefConvertArg) -> @@ -191,7 +179,6 @@ struct let key = A.key let title = A.title let member_message = A.member_message - let synchronous = A.synchronous end module MakeRefTable = @@ -201,7 +188,6 @@ module MakeRefTable = (* 2- Flags. *) type 'a option_sig = { - optsync : bool; optdepr : bool; optname : string; optkey : option_name; @@ -228,11 +214,11 @@ let get_option key = OptionMap.find key !value_tab let check_key key = try let _ = get_option key in - error "Sorry, this option name is already used." + user_err Pp.(str "Sorry, this option name is already used.") with Not_found -> if String.List.mem_assoc (nickname key) !string_table || String.List.mem_assoc (nickname key) !ref_table - then error "Sorry, this option name is already used." + then user_err Pp.(str "Sorry, this option name is already used.") open Libobject @@ -247,11 +233,10 @@ let get_locality = function | None -> OptDefault let declare_option cast uncast append ?(preprocess = fun x -> x) - { optsync=sync; optdepr=depr; optname=name; optkey=key; optread=read; optwrite=write } = + { optdepr=depr; optname=name; optkey=key; optread=read; optwrite=write } = check_key key; let default = read() in let change = - if sync then let _ = Summary.declare_summary (nickname key) { Summary.freeze_function = (fun _ -> read ()); Summary.unfreeze_function = write; @@ -275,18 +260,12 @@ let declare_option cast uncast append ?(preprocess = fun x -> x) discharge_function = discharge_options; classify_function = classify_options } in (fun l m v -> let v = preprocess v in Lib.add_anonymous_leaf (options (l, m, v))) - else - (fun _ m v -> - let v = preprocess v in - match m with - | OptSet -> write v - | OptAppend -> write (append (read ()) v)) in let warn () = if depr then warn_deprecated_option key in let cread () = cast (read ()) in let cwrite l v = warn (); change l OptSet (uncast v) in let cappend l v = warn (); change l OptAppend (uncast v) in - value_tab := OptionMap.add key (name, depr, (sync,cread,cwrite,cappend)) !value_tab; + value_tab := OptionMap.add key (name, depr, (cread,cwrite,cappend)) !value_tab; write type 'a write_function = 'a -> unit @@ -325,10 +304,10 @@ let set_option_value locality check_and_cast key v = let opt = try Some (get_option key) with Not_found -> None in match opt with | None -> warn_unknown_option key - | Some (name, depr, (_,read,write,append)) -> + | Some (name, depr, (read,write,append)) -> write (get_locality locality) (check_and_cast v (read ())) -let bad_type_error () = error "Bad type of value for this option." +let bad_type_error () = user_err Pp.(str "Bad type of value for this option.") let check_int_value v = function | IntValue _ -> IntValue v @@ -366,7 +345,7 @@ let set_string_option_append_value_gen locality key v = let opt = try Some (get_option key) with Not_found -> None in match opt with | None -> warn_unknown_option key - | Some (name, depr, (_,read,write,append)) -> + | Some (name, depr, (read,write,append)) -> append (get_locality locality) (check_string_value v (read ())) let set_int_option_value = set_int_option_value_gen None @@ -387,7 +366,7 @@ let msg_option_value (name,v) = (* | IdentValue r -> pr_global_env Id.Set.empty r *) let print_option_value key = - let (name, depr, (_,read,_,_)) = get_option key in + let (name, depr, (read,_,_)) = get_option key in let s = read () in match s with | BoolValue b -> @@ -397,9 +376,8 @@ let print_option_value key = let get_tables () = let tables = !value_tab in - let fold key (name, depr, (sync,read,_,_)) accu = + let fold key (name, depr, (read,_,_)) accu = let state = { - opt_sync = sync; opt_name = name; opt_depr = depr; opt_value = read (); @@ -416,15 +394,8 @@ let print_tables () = in str "Synchronous options:" ++ fnl () ++ OptionMap.fold - (fun key (name, depr, (sync,read,_,_)) p -> - if sync then p ++ print_option key name (read ()) depr - else p) - !value_tab (mt ()) ++ - str "Asynchronous options:" ++ fnl () ++ - OptionMap.fold - (fun key (name, depr, (sync,read,_,_)) p -> - if sync then p - else p ++ print_option key name (read ()) depr) + (fun key (name, depr, (read,_,_)) p -> + p ++ print_option key name (read ()) depr) !value_tab (mt ()) ++ str "Tables:" ++ fnl () ++ List.fold_right diff --git a/library/goptions.mli b/library/goptions.mli index 3b3651f393..f612c4e369 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -40,8 +40,8 @@ Unset Tata Tutu Titi. Print Table Tata Tutu Titi. (** synonym: Test Table Tata Tutu Titi. *) - The created table/option may be declared synchronous or not - (synchronous = consistent with the resetting commands) *) + All options are synchronized with the document. +*) open Pp open Libnames @@ -65,7 +65,6 @@ module MakeStringTable : val key : option_name val title : string val member_message : string -> bool -> std_ppcmds - val synchronous : bool end) -> sig val active : string -> bool @@ -93,7 +92,6 @@ module MakeRefTable : val key : option_name val title : string val member_message : t -> bool -> std_ppcmds - val synchronous : bool end) -> sig val active : A.t -> bool @@ -108,8 +106,6 @@ module MakeRefTable : used when printing the option value (command "Print Toto Titi." *) type 'a option_sig = { - optsync : bool; - (** whether the option is synchronous w.r.t to the section/module system. *) optdepr : bool; (** whether the option is DEPRECATED *) optname : string; @@ -120,8 +116,6 @@ type 'a option_sig = { optwrite : 'a -> unit } -(** When an option is declared synchronous ([optsync] is [true]), the output is - a synchronous write function. Otherwise it is [optwrite] *) (** The [preprocess] function is triggered before setting the option. It can be used to emit a warning on certain values, and clean-up the final value. *) @@ -177,7 +171,6 @@ type option_value = (** Summary of an option status *) type option_state = { - opt_sync : bool; opt_depr : bool; opt_name : string; opt_value : option_value; diff --git a/library/impargs.ml b/library/impargs.ml index a63264b669..885185da1a 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -364,7 +364,7 @@ let set_manual_implicits env flags enriching autoimps l = with Not_found -> l, None in if not (List.distinct l) then - error ("Some parameters are referred more than once."); + user_err Pp.(str "Some parameters are referred more than once."); (* Compare with automatic implicits to recover printing data and names *) let rec merge k l = function | (Name id,imp)::imps -> @@ -658,7 +658,7 @@ let check_inclusion l = let rec aux = function | n1::(n2::_ as nl) -> if n1 <= n2 then - error "Sequences of implicit arguments must be of different lengths."; + user_err Pp.(str "Sequences of implicit arguments must be of different lengths."); aux nl | _ -> () in aux (List.map (fun (imps,_) -> List.length imps) l) diff --git a/library/lib.ml b/library/lib.ml index ddd2ed6afa..4ad4e261d7 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -76,7 +76,7 @@ let classify_segment seg = (* LEM; TODO: Understand what this does and see if what I do is the correct thing for ClosedMod(ule|type) *) | (_,ClosedModule _) :: stk -> clean acc stk - | (_,OpenedSection _) :: _ -> error "there are still opened sections" + | (_,OpenedSection _) :: _ -> user_err Pp.(str "there are still opened sections") | (_,OpenedModule (ty,_,_,_)) :: _ -> user_err ~hdr:"Lib.classify_segment" (str "there are still opened " ++ str (module_kind ty) ++ str "s") @@ -184,7 +184,7 @@ let split_lib_gen test = | [] -> None in match findeq [] !lib_state.lib_stk with - | None -> error "no such entry" + | None -> user_err Pp.(str "no such entry") | Some r -> r let eq_object_name (fp1, kn1) (fp2, kn2) = @@ -222,7 +222,7 @@ let add_anonymous_entry node = let add_leaf id obj = if Names.ModPath.equal (current_mp ()) Names.initial_path then - error ("No session module started (use -top dir)"); + user_err Pp.(str "No session module started (use -top dir)"); let oname = make_oname id in cache_object (oname,obj); add_entry oname (Leaf obj); @@ -272,8 +272,8 @@ let current_mod_id () = try match find_entry_p is_opening_node_or_lib with | oname,OpenedModule (_,_,_,fs) -> basename (fst oname) | oname,CompilingLibrary _ -> basename (fst oname) - | _ -> error "you are not in a module" - with Not_found -> error "no opened modules" + | _ -> user_err Pp.(str "you are not in a module") + with Not_found -> user_err Pp.(str "no opened modules") let start_mod is_type export id mp fs = @@ -305,7 +305,7 @@ let end_mod is_type = else error_still_opened (module_kind ty) oname | oname,OpenedSection _ -> error_still_opened "section" oname | _ -> assert false - with Not_found -> error "No opened modules." + with Not_found -> user_err (Pp.str "No opened modules.") in let (after,mark,before) = split_lib_at_opening oname in lib_state := { !lib_state with lib_stk = before }; @@ -326,9 +326,9 @@ let contents_after sp = let (after,_,_) = split_lib sp in after (* TODO: use check_for_module ? *) let start_compilation s mp = if !lib_state.comp_name != None then - error "compilation unit is already started"; + user_err Pp.(str "compilation unit is already started"); if not (Names.DirPath.is_empty (current_sections ())) then - error "some sections are already opened"; + user_err Pp.(str "some sections are already opened"); let prefix = s, (mp, Names.DirPath.empty) in let () = add_anonymous_entry (CompilingLibrary prefix) in lib_state := { !lib_state with comp_name = Some s; @@ -337,7 +337,7 @@ let start_compilation s mp = let end_compilation_checks dir = let _ = try match snd (find_entry_p is_opening_node) with - | OpenedSection _ -> error "There are some open sections." + | OpenedSection _ -> user_err Pp.(str "There are some open sections.") | OpenedModule (ty,_,_,_) -> user_err ~hdr:"Lib.end_compilation_checks" (str "There are some open " ++ str (module_kind ty) ++ str "s.") @@ -394,7 +394,7 @@ let find_opening_node id = user_err ~hdr:"Lib.find_opening_node" (str "Last block to end has name " ++ pr_id id' ++ str "."); entry - with Not_found -> error "There is nothing to end." + with Not_found -> user_err Pp.(str "There is nothing to end.") (* Discharge tables *) @@ -428,7 +428,7 @@ let add_section () = let check_same_poly p vars = let pred = function Context _ -> p = false | Variable (_, _, poly, _) -> p != poly in if List.exists pred vars then - error "Cannot mix universe polymorphic and monomorphic declarations in sections." + user_err Pp.(str "Cannot mix universe polymorphic and monomorphic declarations in sections.") let add_section_variable id impl poly ctx = match !sectab with @@ -555,7 +555,7 @@ let close_section () = | oname,OpenedSection (_,fs) -> oname,fs | _ -> assert false with Not_found -> - error "No opened section." + user_err Pp.(str "No opened section.") in let (secdecls,mark,before) = split_lib_at_opening oname in lib_state := { !lib_state with lib_stk = before }; diff --git a/library/libnames.ml b/library/libnames.ml index dd74e192ff..50f28b0205 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -58,14 +58,14 @@ let add_dirpath_suffix p id = DirPath.make (id :: DirPath.repr p) let parse_dir s = let len = String.length s in let rec decoupe_dirs dirs n = - if Int.equal n len && n > 0 then error (s ^ " is an invalid path."); + if Int.equal n len && n > 0 then user_err Pp.(str @@ s ^ " is an invalid path."); if n >= len then dirs else let pos = try String.index_from s n '.' with Not_found -> len in - if Int.equal pos n then error (s ^ " is an invalid path."); + if Int.equal pos n then user_err Pp.(str @@ s ^ " is an invalid path."); let dir = String.sub s n (pos-n) in decoupe_dirs ((Id.of_string dir)::dirs) (pos+1) in diff --git a/library/libnames.mli b/library/libnames.mli index 58d1da9d64..57013ef82e 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -125,7 +125,7 @@ val eq_reference : reference -> reference -> bool val qualid_of_reference : reference -> qualid located val string_of_reference : reference -> string val pr_reference : reference -> std_ppcmds -val loc_of_reference : reference -> Loc.t +val loc_of_reference : reference -> Loc.t option val join_reference : reference -> reference -> reference (** Deprecated synonyms *) diff --git a/library/library.ml b/library/library.ml index 3086e3d182..5a5f99cc51 100644 --- a/library/library.ml +++ b/library/library.ml @@ -582,7 +582,7 @@ let require_library_from_dirpath modrefl export = let safe_locate_module (loc,qid) = try Nametab.locate_module qid with Not_found -> - user_err ~loc ~hdr:"import_library" + user_err ?loc ~hdr:"import_library" (pr_qualid qid ++ str " is not a module") let import_module export modl = @@ -597,7 +597,7 @@ let import_module export modl = | [] -> () | modl -> add_anonymous_leaf (in_import_library (List.rev modl, export)) in let rec aux acc = function - | (loc,dir as m) :: l -> + | (loc, dir as m) :: l -> let m,acc = try Nametab.locate_module dir, acc with Not_found-> flush acc; safe_locate_module m, [] in @@ -607,7 +607,7 @@ let import_module export modl = flush acc; try Declaremods.import_module export mp; aux [] l with Not_found -> - user_err ~loc ~hdr:"import_library" + user_err ?loc ~hdr:"import_library" (pr_qualid dir ++ str " is not a module")) | [] -> flush acc in aux [] modl @@ -764,7 +764,7 @@ let save_library_to ?todo dir f otab = if !Flags.native_compiler then let fn = Filename.dirname f'^"/"^Nativecode.mod_uid_of_dirpath dir in if not (Nativelib.compile_library dir ast fn) then - error "Could not compile the library to native code." + user_err Pp.(str "Could not compile the library to native code.") with reraise -> let reraise = CErrors.push reraise in let () = Feedback.msg_warning (str "Removed file " ++ str f') in diff --git a/library/library.mllib b/library/library.mllib index df4f735034..6f433b77d1 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -16,3 +16,4 @@ Goptions Decls Heads Keys +Coqlib diff --git a/library/nameops.ml b/library/nameops.ml index 098f5112fd..0b5dfd8d0e 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open Util open Names @@ -14,10 +13,6 @@ open Names let pr_id id = Id.print id -let pr_name = function - | Anonymous -> str "_" - | Name id -> pr_id id - (* Utilities *) let code_of_0 = Char.code '0' @@ -124,34 +119,82 @@ let atompart_of_id id = fst (repr_ident id) (* Names *) -let out_name = function - | Name id -> id - | Anonymous -> failwith "Nameops.out_name" +module type ExtName = +sig + + include module type of struct include Names.Name end + + exception IsAnonymous + + val fold_left : ('a -> Id.t -> 'a) -> 'a -> t -> 'a + val fold_right : (Id.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter : (Id.t -> unit) -> t -> unit + val map : (Id.t -> Id.t) -> t -> t + val fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> t -> 'a * t + val get_id : t -> Id.t + val pick : t -> t -> t + val cons : t -> Id.t list -> Id.t list + val to_option : Name.t -> Id.t option + +end + +module Name : ExtName = +struct + + include Names.Name + + exception IsAnonymous + + let fold_left f a = function + | Name id -> f a id + | Anonymous -> a + + let fold_right f na a = + match na with + | Name id -> f id a + | Anonymous -> a + + let iter f na = fold_right (fun x () -> f x) na () + + let map f = function + | Name id -> Name (f id) + | Anonymous -> Anonymous + + let fold_map f a = function + | Name id -> let (a, id) = f a id in (a, Name id) + | Anonymous -> a, Anonymous + + let get_id = function + | Name id -> id + | Anonymous -> raise IsAnonymous -let name_fold f na a = - match na with - | Name id -> f id a - | Anonymous -> a + let pick na1 na2 = + match na1 with + | Name _ -> na1 + | Anonymous -> na2 -let name_iter f na = name_fold (fun x () -> f x) na () + let cons na l = + match na with + | Anonymous -> l + | Name id -> id::l -let name_cons na l = - match na with - | Anonymous -> l - | Name id -> id::l + let to_option = function + | Anonymous -> None + | Name id -> Some id -let name_app f = function - | Name id -> Name (f id) - | Anonymous -> Anonymous +end -let name_fold_map f e = function - | Name id -> let (e,id) = f e id in (e,Name id) - | Anonymous -> e,Anonymous +open Name -let name_max na1 na2 = - match na1 with - | Name _ -> na1 - | Anonymous -> na2 +(* Compatibility *) +let out_name = get_id +let name_fold = fold_right +let name_iter = iter +let name_app = map +let name_fold_map = fold_map +let name_cons = cons +let name_max = pick +let pr_name = print let pr_lab l = Label.print l diff --git a/library/nameops.mli b/library/nameops.mli index 3a67b61a13..abfc09db8d 100644 --- a/library/nameops.mli +++ b/library/nameops.mli @@ -9,8 +9,6 @@ open Names (** Identifiers and names *) -val pr_id : Id.t -> Pp.std_ppcmds -val pr_name : Name.t -> Pp.std_ppcmds val make_ident : string -> int option -> Id.t val repr_ident : Id.t -> string * int option @@ -50,16 +48,69 @@ val increment_subscript : Id.t -> Id.t val forget_subscript : Id.t -> Id.t +module Name : sig + + include module type of struct include Names.Name end + + exception IsAnonymous + + val fold_left : ('a -> Id.t -> 'a) -> 'a -> Name.t -> 'a + (** [fold_left f na a] is [f id a] if [na] is [Name id], and [a] otherwise. *) + + val fold_right : (Id.t -> 'a -> 'a) -> Name.t -> 'a -> 'a + (** [fold_right f a na] is [f a id] if [na] is [Name id], and [a] otherwise. *) + + val iter : (Id.t -> unit) -> Name.t -> unit + (** [iter f na] does [f id] if [na] equals [Name id], nothing otherwise. *) + + val map : (Id.t -> Id.t) -> Name.t -> t + (** [map f na] is [Anonymous] if [na] is [Anonymous] and [Name (f id)] if [na] is [Name id]. *) + + val fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t + (** [fold_map f na a] is [a',Name id'] when [na] is [Name id] and [f a id] is [(a',id')]. + It is [a,Anonymous] otherwise. *) + + val get_id : Name.t -> Id.t + (** [get_id] associates [id] to [Name id]. @raise IsAnonymous otherwise. *) + + val pick : Name.t -> Name.t -> Name.t + (** [pick na na'] returns [Anonymous] if both names are [Anonymous]. + Pick one of [na] or [na'] otherwise. *) + + val cons : Name.t -> Id.t list -> Id.t list + (** [cons na l] returns [id::l] if [na] is [Name id] and [l] otherwise. *) + + val to_option : Name.t -> Id.t option + (** [to_option Anonymous] is [None] and [to_option (Name id)] is [Some id] *) + +end + val out_name : Name.t -> Id.t -(** [out_name] associates [id] to [Name id]. Raises [Failure "Nameops.out_name"] - otherwise. *) +(** @deprecated Same as [Name.get_id] *) val name_fold : (Id.t -> 'a -> 'a) -> Name.t -> 'a -> 'a +(** @deprecated Same as [Name.fold_right] *) + val name_iter : (Id.t -> unit) -> Name.t -> unit -val name_cons : Name.t -> Id.t list -> Id.t list +(** @deprecated Same as [Name.iter] *) + val name_app : (Id.t -> Id.t) -> Name.t -> Name.t +(** @deprecated Same as [Name.map] *) + val name_fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t +(** @deprecated Same as [Name.fold_map] *) + val name_max : Name.t -> Name.t -> Name.t +(** @deprecated Same as [Name.pick] *) + +val name_cons : Name.t -> Id.t list -> Id.t list +(** @deprecated Same as [Name.cons] *) + +val pr_name : Name.t -> Pp.std_ppcmds +(** @deprecated Same as [Name.print] *) + +val pr_id : Id.t -> Pp.std_ppcmds +(** @deprecated Same as [Names.Id.print] *) val pr_lab : Label.t -> Pp.std_ppcmds diff --git a/library/nametab.ml b/library/nametab.ml index b76048e890..2e4e98013e 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -143,8 +143,8 @@ struct (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) (* But ours is also absolute! This is an error! *) - error ("Cannot mask the absolute name \"" - ^ U.to_string uname' ^ "\"!") + user_err Pp.(str @@ "Cannot mask the absolute name \"" + ^ U.to_string uname' ^ "\"!") | Nothing | Relative _ -> mktree (Absolute (uname,o)) tree.map @@ -453,11 +453,11 @@ let global r = try match locate_extended qid with | TrueGlobal ref -> ref | SynDef _ -> - user_err ~loc ~hdr:"global" + user_err ?loc ~hdr:"global" (str "Unexpected reference to a notation: " ++ pr_qualid qid) with Not_found -> - error_global_not_found ~loc qid + error_global_not_found ?loc qid (* Exists functions ********************************************************) @@ -532,7 +532,7 @@ let global_inductive r = match global r with | IndRef ind -> ind | ref -> - user_err ~loc:(loc_of_reference r) ~hdr:"global_inductive" + user_err ?loc:(loc_of_reference r) ~hdr:"global_inductive" (pr_reference r ++ spc () ++ str "is not an inductive type") diff --git a/library/nametab.mli b/library/nametab.mli index d20c399b60..095ac4f9df 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -173,3 +173,38 @@ val shortest_qualid_of_tactic : ltac_constant -> qualid val extended_locate : qualid -> extended_global_reference (*= locate_extended *) val absolute_reference : full_path -> global_reference (** = global_of_path *) + +(** {5 Generic name handling} *) + +(** NOT FOR PUBLIC USE YET. Plugin writers, please do not rely on this API. *) + +module type UserName = sig + type t + val equal : t -> t -> bool + val to_string : t -> string + val repr : t -> Id.t * module_ident list +end + +module type EqualityType = +sig + type t + val equal : t -> t -> bool +end + +module type NAMETREE = sig + type elt + type t + type user_name + + val empty : t + val push : visibility -> user_name -> elt -> t -> t + val locate : qualid -> t -> elt + val find : user_name -> t -> elt + val exists : user_name -> t -> bool + val user_name : qualid -> t -> user_name + val shortest_qualid : Id.Set.t -> user_name -> t -> qualid + val find_prefixes : qualid -> t -> elt list +end + +module Make (U : UserName) (E : EqualityType) : + NAMETREE with type user_name = U.t and type elt = E.t diff --git a/man/gallina.1 b/man/gallina.1 index 8c607216ed..f8879c457b 100644 --- a/man/gallina.1 +++ b/man/gallina.1 @@ -29,7 +29,7 @@ The suffix '.g' stands for Gallina. For that purpose, gallina removes all commands that follow a "Theorem", "Lemma", "Fact", "Remark" or "Goal" statement until it -reaches a command "Abort.", "Save.", "Qed.", "Defined." or "Proof +reaches a command "Abort.", "Qed.", "Defined." or "Proof <...>.". It also removes every "Hint", "Syntax", "Immediate" or "Transparent" command. @@ -52,7 +52,7 @@ Comments are removed in the *.g file. .SH NOTES Nested comments are correctly handled. In particular, every command -"Save." or "Abort." in a comment is not taken into account. +"Qed." or "Abort." in a comment is not taken into account. .SH BUGS diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 86c66ec5f1..6940fd6fb9 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -308,13 +308,13 @@ let interp_entry forpat e = match e with | ETBinderList (true, _) -> assert false | ETBinderList (false, tkl) -> TTAny (TTBinderListF tkl) -let constr_expr_of_name (loc,na) = match na with - | Anonymous -> CHole (loc,None,Misctypes.IntroAnonymous,None) - | Name id -> CRef (Ident (loc,id), None) +let constr_expr_of_name (loc,na) = CAst.make ?loc @@ match na with + | Anonymous -> CHole (None,Misctypes.IntroAnonymous,None) + | Name id -> CRef (Ident (Loc.tag ?loc id), None) -let cases_pattern_expr_of_name (loc,na) = match na with - | Anonymous -> CPatAtom (loc,None) - | Name id -> CPatAtom (loc,Some (Ident (loc,id))) +let cases_pattern_expr_of_name (loc,na) = CAst.make ?loc @@ match na with + | Anonymous -> CPatAtom None + | Name id -> CPatAtom (Some (Ident (Loc.tag ?loc id))) type 'r env = { constrs : 'r list; @@ -337,13 +337,13 @@ match e with | TTBinderListF _ -> { subst with binders = (List.flatten v, false) :: subst.binders } | TTBigint -> begin match forpat with - | ForConstr -> push_constr subst (CPrim (Loc.ghost, Numeral v)) - | ForPattern -> push_constr subst (CPatPrim (Loc.ghost, Numeral v)) + | ForConstr -> push_constr subst (CAst.make @@ CPrim (Numeral v)) + | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Numeral v)) end | TTReference -> begin match forpat with - | ForConstr -> push_constr subst (CRef (v, None)) - | ForPattern -> push_constr subst (CPatAtom (Loc.ghost, Some v)) + | ForConstr -> push_constr subst (CAst.make @@ CRef (v, None)) + | ForPattern -> push_constr subst (CAst.make @@ CPatAtom (Some v)) end | TTConstrList _ -> { subst with constrlists = v :: subst.constrlists } @@ -426,12 +426,12 @@ let rec pure_sublevels : type a b c. int option -> (a, b, c) rule -> int list = let make_act : type r. r target -> _ -> r gen_eval = function | ForConstr -> fun notation loc env -> let env = (env.constrs, env.constrlists, List.map fst env.binders) in - CNotation (loc, notation , env) + CAst.make ~loc @@ CNotation (notation , env) | ForPattern -> fun notation loc env -> let invalid = List.exists (fun (_, b) -> not b) env.binders in let () = if invalid then Topconstr.error_invalid_pattern_notation ~loc () in let env = (env.constrs, env.constrlists) in - CPatNotation (loc, notation, env, []) + CAst.make ~loc @@ CPatNotation (notation, env, []) let extend_constr state forpat ng = let n = ng.notgram_level in diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 984957589f..07c77619fe 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -17,7 +17,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - Loc.t * 'a raw_abstract_argument_type option * ('s, 'a) symbol -> 's grammar_prod_item + ('a raw_abstract_argument_type option * ('s, 'a) symbol) Loc.located -> 's grammar_prod_item type 'a ty_arg = ('a -> raw_generic_argument) @@ -36,7 +36,7 @@ let rec ty_rule_of_gram = function let tok = Atoken (CLexer.terminal s) in let r = TyNext (rem, tok, None) in AnyTyRule r -| GramNonTerminal (_, t, tok) :: rem -> +| GramNonTerminal (_, (t, tok)) :: rem -> let AnyTyRule rem = ty_rule_of_gram rem in let inj = Option.map (fun t obj -> Genarg.in_gen t obj) t in let r = TyNext (rem, tok, inj) in diff --git a/parsing/egramml.mli b/parsing/egramml.mli index 29baaf052b..030d396059 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -15,8 +15,8 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string - | GramNonTerminal : Loc.t * 'a Genarg.raw_abstract_argument_type option * - ('s, 'a) Extend.symbol -> 's grammar_prod_item + | GramNonTerminal : ('a Genarg.raw_abstract_argument_type option * + ('s, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item val extend_vernac_command_grammar : Vernacexpr.extend_name -> vernac_expr Pcoq.Gram.entry option -> diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 15f100c3b0..54bac253d0 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -33,12 +33,12 @@ let _ = List.iter CLexer.add_keyword constr_kw let mk_cast = function (c,(_,None)) -> c | (c,(_,Some ty)) -> - let loc = Loc.merge (constr_loc c) (constr_loc ty) - in CCast(loc, c, CastConv ty) + let loc = Loc.merge_opt (constr_loc c) (constr_loc ty) + in CAst.make ?loc @@ CCast(c, CastConv ty) let binder_of_name expl (loc,na) = CLocalAssum ([loc, na], Default expl, - CHole (loc, Some (Evar_kinds.BinderType na), IntroAnonymous, None)) + CAst.make ?loc @@ CHole (Some (Evar_kinds.BinderType na), IntroAnonymous, None)) let binders_of_names l = List.map (binder_of_name Explicit) l @@ -46,26 +46,26 @@ let binders_of_names l = let mk_fixb (id,bl,ann,body,(loc,tyc)) = let ty = match tyc with Some ty -> ty - | None -> CHole (loc, None, IntroAnonymous, None) in + | None -> CAst.make @@ CHole (None, IntroAnonymous, None) in (id,ann,bl,ty,body) let mk_cofixb (id,bl,ann,body,(loc,tyc)) = let _ = Option.map (fun (aloc,_) -> - CErrors.user_err ~loc:aloc + CErrors.user_err ?loc:aloc ~hdr:"Constr:mk_cofixb" (Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in let ty = match tyc with Some ty -> ty - | None -> CHole (loc, None, IntroAnonymous, None) in + | None -> CAst.make @@ CHole (None, IntroAnonymous, None) in (id,bl,ty,body) let mk_fix(loc,kw,id,dcls) = if kw then let fb = List.map mk_fixb dcls in - CFix(loc,id,fb) + CAst.make ~loc @@ CFix(id,fb) else let fb = List.map mk_cofixb dcls in - CCoFix(loc,id,fb) + CAst.make ~loc @@ CCoFix(id,fb) let mk_single_fix (loc,kw,dcl) = let (id,_,_,_,_) = dcl in mk_fix(loc,kw,id,[dcl]) @@ -120,7 +120,7 @@ let name_colon = | _ -> err ()) | _ -> err ()) -let aliasvar = function CPatAlias (loc, _, id) -> Some (loc,Name id) | _ -> None +let aliasvar = function { CAst.loc = loc; CAst.v = CPatAlias (_, id) } -> Some (loc,Name id) | _ -> None GEXTEND Gram GLOBAL: binder_constr lconstr constr operconstr universe_level sort global @@ -131,7 +131,7 @@ GEXTEND Gram [ [ id = Prim.ident -> id ] ] ; Prim.name: - [ [ "_" -> (!@loc, Anonymous) ] ] + [ [ "_" -> Loc.tag ~loc:!@loc Anonymous ] ] ; global: [ [ r = Prim.reference -> r ] ] @@ -159,62 +159,62 @@ GEXTEND Gram ; constr: [ [ c = operconstr LEVEL "8" -> c - | "@"; f=global; i = instance -> CAppExpl(!@loc,(None,f,i),[]) ] ] + | "@"; f=global; i = instance -> CAst.make ~loc:!@loc @@ CAppExpl((None,f,i),[]) ] ] ; operconstr: [ "200" RIGHTA [ c = binder_constr -> c ] | "100" RIGHTA [ c1 = operconstr; "<:"; c2 = binder_constr -> - CCast(!@loc,c1, CastVM c2) + CAst.make ~loc:(!@loc) @@ CCast(c1, CastVM c2) | c1 = operconstr; "<:"; c2 = SELF -> - CCast(!@loc,c1, CastVM c2) + CAst.make ~loc:(!@loc) @@ CCast(c1, CastVM c2) | c1 = operconstr; "<<:"; c2 = binder_constr -> - CCast(!@loc,c1, CastNative c2) + CAst.make ~loc:(!@loc) @@ CCast(c1, CastNative c2) | c1 = operconstr; "<<:"; c2 = SELF -> - CCast(!@loc,c1, CastNative c2) + CAst.make ~loc:(!@loc) @@ CCast(c1, CastNative c2) | c1 = operconstr; ":";c2 = binder_constr -> - CCast(!@loc,c1, CastConv c2) + CAst.make ~loc:(!@loc) @@ CCast(c1, CastConv c2) | c1 = operconstr; ":"; c2 = SELF -> - CCast(!@loc,c1, CastConv c2) + CAst.make ~loc:(!@loc) @@ CCast(c1, CastConv c2) | c1 = operconstr; ":>" -> - CCast(!@loc,c1, CastCoerce) ] + CAst.make ~loc:(!@loc) @@ CCast(c1, CastCoerce) ] | "99" RIGHTA [ ] | "90" RIGHTA [ ] | "10" LEFTA - [ f=operconstr; args=LIST1 appl_arg -> CApp(!@loc,(None,f),args) - | "@"; f=global; i = instance; args=LIST0 NEXT -> CAppExpl(!@loc,(None,f,i),args) + [ f=operconstr; args=LIST1 appl_arg -> CAst.make ~loc:(!@loc) @@ CApp((None,f),args) + | "@"; f=global; i = instance; args=LIST0 NEXT -> CAst.make ~loc:!@loc @@ CAppExpl((None,f,i),args) | "@"; (locid,id) = pattern_identref; args=LIST1 identref -> - let args = List.map (fun x -> CRef (Ident x,None), None) args in - CApp(!@loc,(None,CPatVar(locid,id)),args) ] + let args = List.map (fun x -> CAst.make @@ CRef (Ident x,None), None) args in + CAst.make ~loc:(!@loc) @@ CApp((None, CAst.make ?loc:locid @@ CPatVar id),args) ] | "9" [ ".."; c = operconstr LEVEL "0"; ".." -> - CAppExpl (!@loc,(None,Ident (!@loc,ldots_var),None),[c]) ] + CAst.make ~loc:!@loc @@ CAppExpl ((None, Ident (Loc.tag ~loc:!@loc ldots_var),None),[c]) ] | "8" [ ] | "1" LEFTA [ c=operconstr; ".("; f=global; args=LIST0 appl_arg; ")" -> - CApp(!@loc,(Some (List.length args+1),CRef (f,None)),args@[c,None]) + CAst.make ~loc:(!@loc) @@ CApp((Some (List.length args+1), CAst.make @@ CRef (f,None)),args@[c,None]) | c=operconstr; ".("; "@"; f=global; args=LIST0 (operconstr LEVEL "9"); ")" -> - CAppExpl(!@loc,(Some (List.length args+1),f,None),args@[c]) - | c=operconstr; "%"; key=IDENT -> CDelimiters (!@loc,key,c) ] + CAst.make ~loc:(!@loc) @@ CAppExpl((Some (List.length args+1),f,None),args@[c]) + | c=operconstr; "%"; key=IDENT -> CAst.make ~loc:(!@loc) @@ CDelimiters (key,c) ] | "0" [ c=atomic_constr -> c | c=match_constr -> c | "("; c = operconstr LEVEL "200"; ")" -> - (match c with - CPrim (_,Numeral z) when Bigint.is_pos_or_zero z -> - CNotation(!@loc,"( _ )",([c],[],[])) + (match c.CAst.v with + CPrim (Numeral z) when Bigint.is_pos_or_zero z -> + CAst.make ~loc:(!@loc) @@ CNotation("( _ )",([c],[],[])) | _ -> c) | "{|"; c = record_declaration; "|}" -> c | "`{"; c = operconstr LEVEL "200"; "}" -> - CGeneralization (!@loc, Implicit, None, c) + CAst.make ~loc:(!@loc) @@ CGeneralization (Implicit, None, c) | "`("; c = operconstr LEVEL "200"; ")" -> - CGeneralization (!@loc, Explicit, None, c) + CAst.make ~loc:(!@loc) @@ CGeneralization (Explicit, None, c) ] ] ; record_declaration: - [ [ fs = record_fields -> CRecord (!@loc, fs) ] ] + [ [ fs = record_fields -> CAst.make ~loc:(!@loc) @@ CRecord fs ] ] ; record_fields: @@ -226,62 +226,66 @@ GEXTEND Gram record_field_declaration: [ [ id = global; bl = binders; ":="; c = lconstr -> - (id, mkCLambdaN (!@loc) bl c) ] ] + (id, mkCLambdaN ~loc:!@loc bl c) ] ] ; binder_constr: [ [ "forall"; bl = open_binders; ","; c = operconstr LEVEL "200" -> - mkCProdN (!@loc) bl c + mkCProdN ~loc:!@loc bl c | "fun"; bl = open_binders; "=>"; c = operconstr LEVEL "200" -> - mkCLambdaN (!@loc) bl c + mkCLambdaN ~loc:!@loc bl c | "let"; id=name; bl = binders; ty = type_cstr; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> let ty,c1 = match ty, c1 with - | (_,None), CCast(loc,c, CastConv t) -> (constr_loc t,Some t), c (* Tolerance, see G_vernac.def_body *) + | (_,None), { CAst.v = CCast(c, CastConv t) } -> (Loc.tag ?loc:(constr_loc t) @@ Some t), c (* Tolerance, see G_vernac.def_body *) | _, _ -> ty, c1 in - CLetIn(!@loc,id,mkCLambdaN (constr_loc c1) bl c1, - Option.map (mkCProdN (fst ty) bl) (snd ty), c2) + CAst.make ~loc:!@loc @@ CLetIn(id,mkCLambdaN ?loc:(constr_loc c1) bl c1, + Option.map (mkCProdN ?loc:(fst ty) bl) (snd ty), c2) | "let"; fx = single_fix; "in"; c = operconstr LEVEL "200" -> let fixp = mk_single_fix fx in - let (li,id) = match fixp with - CFix(_,id,_) -> id - | CCoFix(_,id,_) -> id + let (li,id) = match fixp.CAst.v with + CFix(id,_) -> id + | CCoFix(id,_) -> id | _ -> assert false in - CLetIn(!@loc,(li,Name id),fixp,None,c) + CAst.make ~loc:!@loc @@ CLetIn((li,Name id),fixp,None,c) | "let"; lb = ["("; l=LIST0 name SEP ","; ")" -> l | "()" -> []]; po = return_type; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> - CLetTuple (!@loc,lb,po,c1,c2) + CAst.make ~loc:!@loc @@ CLetTuple (lb,po,c1,c2) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> - CCases (!@loc, LetPatternStyle, None, [c1, None, None], [(!@loc, [(!@loc,[p])], c2)]) + CAst.make ~loc:!@loc @@ + CCases (LetPatternStyle, None, [c1, None, None], [Loc.tag ~loc:!@loc ([(Loc.tag ~loc:!@loc [p])], c2)]) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> - CCases (!@loc, LetPatternStyle, Some rt, [c1, aliasvar p, None], [(!@loc, [(!@loc, [p])], c2)]) + CAst.make ~loc:!@loc @@ + CCases (LetPatternStyle, Some rt, [c1, aliasvar p, None], [Loc.tag ~loc:!@loc ([(Loc.tag ~loc:!@loc [p])], c2)]) + | "let"; "'"; p=pattern; "in"; t = pattern LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> - CCases (!@loc, LetPatternStyle, Some rt, [c1, aliasvar p, Some t], [(!@loc, [(!@loc, [p])], c2)]) + CAst.make ~loc:!@loc @@ + CCases (LetPatternStyle, Some rt, [c1, aliasvar p, Some t], [Loc.tag ~loc:!@loc ([(Loc.tag ~loc:!@loc [p])], c2)]) | "if"; c=operconstr LEVEL "200"; po = return_type; "then"; b1=operconstr LEVEL "200"; "else"; b2=operconstr LEVEL "200" -> - CIf (!@loc, c, po, b1, b2) + CAst.make ~loc:(!@loc) @@ CIf (c, po, b1, b2) | c=fix_constr -> c ] ] ; appl_arg: [ [ id = lpar_id_coloneq; c=lconstr; ")" -> - (c,Some (!@loc,ExplByName id)) + (c,Some (Loc.tag ~loc:!@loc @@ ExplByName id)) | c=operconstr LEVEL "9" -> (c,None) ] ] ; atomic_constr: - [ [ g=global; i=instance -> CRef (g,i) - | s=sort -> CSort (!@loc,s) - | n=INT -> CPrim (!@loc, Numeral (Bigint.of_string n)) - | s=string -> CPrim (!@loc, String s) - | "_" -> CHole (!@loc, None, IntroAnonymous, None) - | "?"; "["; id=ident; "]" -> CHole (!@loc, None, IntroIdentifier id, None) - | "?"; "["; id=pattern_ident; "]" -> CHole (!@loc, None, IntroFresh id, None) - | id=pattern_ident; inst = evar_instance -> CEvar(!@loc,id,inst) ] ] + [ [ g=global; i=instance -> CAst.make ~loc:!@loc @@ CRef (g,i) + | s=sort -> CAst.make ~loc:!@loc @@ CSort s + | n=INT -> CAst.make ~loc:!@loc @@ CPrim (Numeral (Bigint.of_string n)) + | s=string -> CAst.make ~loc:!@loc @@ CPrim (String s) + | "_" -> CAst.make ~loc:!@loc @@ CHole (None, IntroAnonymous, None) + | "?"; "["; id=ident; "]" -> CAst.make ~loc:!@loc @@ CHole (None, IntroIdentifier id, None) + | "?"; "["; id=pattern_ident; "]" -> CAst.make ~loc:!@loc @@ CHole (None, IntroFresh id, None) + | id=pattern_ident; inst = evar_instance -> CAst.make ~loc:!@loc @@ CEvar(id,inst) ] ] ; inst: [ [ id = ident; ":="; c = lconstr -> (id,c) ] ] @@ -322,7 +326,7 @@ GEXTEND Gram ; match_constr: [ [ "match"; ci=LIST1 case_item SEP ","; ty=OPT case_type; "with"; - br=branches; "end" -> CCases(!@loc,RegularStyle,ty,ci,br) ] ] + br=branches; "end" -> CAst.make ~loc:!@loc @@ CCases(RegularStyle,ty,ci,br) ] ] ; case_item: [ [ c=operconstr LEVEL "100"; @@ -345,11 +349,11 @@ GEXTEND Gram [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ] ; mult_pattern: - [ [ pl = LIST1 pattern LEVEL "99" SEP "," -> (!@loc,pl) ] ] + [ [ pl = LIST1 pattern LEVEL "99" SEP "," -> (Loc.tag ~loc:!@loc pl) ] ] ; eqn: [ [ pll = LIST1 mult_pattern SEP "|"; - "=>"; rhs = lconstr -> (!@loc,pll,rhs) ] ] + "=>"; rhs = lconstr -> (Loc.tag ~loc:!@loc (pll,rhs)) ] ] ; record_pattern: [ [ id = global; ":="; pat = pattern -> (id, pat) ] ] @@ -364,53 +368,54 @@ GEXTEND Gram pattern: [ "200" RIGHTA [ ] | "100" RIGHTA - [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (!@loc,p::pl) ] + [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CAst.make ~loc:!@loc @@ CPatOr (p::pl) ] | "99" RIGHTA [ ] | "11" LEFTA [ p = pattern; "as"; id = ident -> - CPatAlias (!@loc, p, id) ] + CAst.make ~loc:!@loc @@ CPatAlias (p, id) ] | "10" RIGHTA [ p = pattern; lp = LIST1 NEXT -> - (match p with - | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, None, lp) - | CPatCstr (_, r, None, l2) -> CErrors.user_err - ~loc:(cases_pattern_expr_loc p) ~hdr:"compound_pattern" - (Pp.str "Nested applications not supported.") - | CPatCstr (_, r, l1, l2) -> CPatCstr (!@loc, r, l1 , l2@lp) - | CPatNotation (_, n, s, l) -> CPatNotation (!@loc, n , s, l@lp) + (let open CAst in match p with + | { v = CPatAtom (Some r) } -> CAst.make ~loc:!@loc @@ CPatCstr (r, None, lp) + | { v = CPatCstr (r, None, l2); loc } -> + CErrors.user_err ?loc ~hdr:"compound_pattern" + (Pp.str "Nested applications not supported.") + | { v = CPatCstr (r, l1, l2) } -> CAst.make ~loc:!@loc @@ CPatCstr (r, l1 , l2@lp) + | { v = CPatNotation (n, s, l) } -> CAst.make ~loc:!@loc @@ CPatNotation (n , s, l@lp) | _ -> CErrors.user_err - ~loc:(cases_pattern_expr_loc p) ~hdr:"compound_pattern" - (Pp.str "Such pattern cannot have arguments.")) + ?loc:(cases_pattern_expr_loc p) ~hdr:"compound_pattern" + (Pp.str "Such pattern cannot have arguments.")) |"@"; r = Prim.reference; lp = LIST0 NEXT -> - CPatCstr (!@loc, r, Some lp, []) ] + CAst.make ~loc:!@loc @@ CPatCstr (r, Some lp, []) ] | "1" LEFTA - [ c = pattern; "%"; key=IDENT -> CPatDelimiters (!@loc,key,c) ] + [ c = pattern; "%"; key=IDENT -> CAst.make ~loc:!@loc @@ CPatDelimiters (key,c) ] | "0" - [ r = Prim.reference -> CPatAtom (!@loc,Some r) - | "{|"; pat = record_patterns; "|}" -> CPatRecord (!@loc, pat) - | "_" -> CPatAtom (!@loc,None) + [ r = Prim.reference -> CAst.make ~loc:!@loc @@ CPatAtom (Some r) + | "{|"; pat = record_patterns; "|}" -> CAst.make ~loc:!@loc @@ CPatRecord pat + | "_" -> CAst.make ~loc:!@loc @@ CPatAtom None | "("; p = pattern LEVEL "200"; ")" -> - (match p with - CPatPrim (_,Numeral z) when Bigint.is_pos_or_zero z -> - CPatNotation(!@loc,"( _ )",([p],[]),[]) + (match p.CAst.v with + | CPatPrim (Numeral z) when Bigint.is_pos_or_zero z -> + CAst.make ~loc:!@loc @@ CPatNotation("( _ )",([p],[]),[]) | _ -> p) | "("; p = pattern LEVEL "200"; ":"; ty = lconstr; ")" -> let p = match p with - CPatPrim (_,Numeral z) when Bigint.is_pos_or_zero z -> - CPatNotation(!@loc,"( _ )",([p],[]),[]) + | { CAst.v = CPatPrim (Numeral z) } when Bigint.is_pos_or_zero z -> + CAst.make ~loc:!@loc @@ CPatNotation("( _ )",([p],[]),[]) | _ -> p in - CPatCast (!@loc, p, ty) - | n = INT -> CPatPrim (!@loc, Numeral (Bigint.of_string n)) - | s = string -> CPatPrim (!@loc, String s) ] ] + CAst.make ~loc:!@loc @@ CPatCast (p, ty) + | n = INT -> CAst.make ~loc:!@loc @@ CPatPrim (Numeral (Bigint.of_string n)) + | s = string -> CAst.make ~loc:!@loc @@ CPatPrim (String s) ] ] ; impl_ident_tail: [ [ "}" -> binder_of_name Implicit | nal=LIST1 name; ":"; c=lconstr; "}" -> (fun na -> CLocalAssum (na::nal,Default Implicit,c)) | nal=LIST1 name; "}" -> - (fun na -> CLocalAssum (na::nal,Default Implicit,CHole (Loc.join_loc (fst na) !@loc, Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None))) + (fun na -> CLocalAssum (na::nal,Default Implicit, + CAst.make ?loc:(Loc.merge_opt (fst na) (Some !@loc)) @@ CHole (Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None))) | ":"; c=lconstr; "}" -> (fun na -> CLocalAssum ([na],Default Implicit,c)) ] ] @@ -423,7 +428,7 @@ GEXTEND Gram ] ] ; impl_name_head: - [ [ id = impl_ident_head -> (!@loc,Name id) ] ] + [ [ id = impl_ident_head -> (Loc.tag ~loc:!@loc @@ Name id) ] ] ; binders_fixannot: [ [ na = impl_name_head; assum = impl_ident_tail; bl = binders_fixannot -> @@ -443,8 +448,8 @@ GEXTEND Gram | id = name; idl = LIST0 name; bl = binders -> binders_of_names (id::idl) @ bl | id1 = name; ".."; id2 = name -> - [CLocalAssum ([id1;(!@loc,Name ldots_var);id2], - Default Explicit,CHole (!@loc, None, IntroAnonymous, None))] + [CLocalAssum ([id1;(Loc.tag ~loc:!@loc (Name ldots_var));id2], + Default Explicit, CAst.make ~loc:!@loc @@ CHole (None, IntroAnonymous, None))] | bl = closed_binder; bl' = binders -> bl@bl' ] ] @@ -453,7 +458,7 @@ GEXTEND Gram [ [ l = LIST0 binder -> List.flatten l ] ] ; binder: - [ [ id = name -> [CLocalAssum ([id],Default Explicit,CHole (!@loc, None, IntroAnonymous, None))] + [ [ id = name -> [CLocalAssum ([id],Default Explicit, CAst.make ~loc:!@loc @@ CHole (None, IntroAnonymous, None))] | bl = closed_binder -> bl ] ] ; closed_binder: @@ -462,44 +467,44 @@ GEXTEND Gram | "("; id=name; ":"; c=lconstr; ")" -> [CLocalAssum ([id],Default Explicit,c)] | "("; id=name; ":="; c=lconstr; ")" -> - (match c with - | CCast(_,c, CastConv t) -> [CLocalDef (id,c,Some t)] + (match c.CAst.v with + | CCast(c, CastConv t) -> [CLocalDef (id,c,Some t)] | _ -> [CLocalDef (id,c,None)]) | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> [CLocalDef (id,c,Some t)] | "{"; id=name; "}" -> - [CLocalAssum ([id],Default Implicit,CHole (!@loc, None, IntroAnonymous, None))] + [CLocalAssum ([id],Default Implicit, CAst.make ~loc:!@loc @@ CHole (None, IntroAnonymous, None))] | "{"; id=name; idl=LIST1 name; ":"; c=lconstr; "}" -> [CLocalAssum (id::idl,Default Implicit,c)] | "{"; id=name; ":"; c=lconstr; "}" -> [CLocalAssum ([id],Default Implicit,c)] | "{"; id=name; idl=LIST1 name; "}" -> - List.map (fun id -> CLocalAssum ([id],Default Implicit,CHole (!@loc, None, IntroAnonymous, None))) (id::idl) + List.map (fun id -> CLocalAssum ([id],Default Implicit, CAst.make ~loc:!@loc @@ CHole (None, IntroAnonymous, None))) (id::idl) | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" -> List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (Implicit, Explicit, b), t)) tc | "`{"; tc = LIST1 typeclass_constraint SEP "," ; "}" -> List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (Implicit, Implicit, b), t)) tc | "'"; p = pattern LEVEL "0" -> let (p, ty) = - match p with - | CPatCast (_, p, ty) -> (p, Some ty) + match p.CAst.v with + | CPatCast (p, ty) -> (p, Some ty) | _ -> (p, None) in - [CLocalPattern (!@loc, p, ty)] + [CLocalPattern (Loc.tag ~loc:!@loc (p, ty))] ] ] ; typeclass_constraint: - [ [ "!" ; c = operconstr LEVEL "200" -> (!@loc, Anonymous), true, c + [ [ "!" ; c = operconstr LEVEL "200" -> (Loc.tag ~loc:!@loc Anonymous), true, c | "{"; id = name; "}"; ":" ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" -> id, expl, c | iid=name_colon ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" -> - (!@loc, iid), expl, c + (Loc.tag ~loc:!@loc iid), expl, c | c = operconstr LEVEL "200" -> - (!@loc, Anonymous), false, c + (Loc.tag ~loc:!@loc Anonymous), false, c ] ] ; type_cstr: - [ [ c=OPT [":"; c=lconstr -> c] -> (!@loc,c) ] ] + [ [ c=OPT [":"; c=lconstr -> c] -> Loc.tag ~loc:!@loc c ] ] ; END;; diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index abb463f821..78f75a73cb 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -43,13 +43,13 @@ GEXTEND Gram [ [ LEFTQMARK; id = ident -> id ] ] ; pattern_identref: - [ [ id = pattern_ident -> (!@loc, id) ] ] + [ [ id = pattern_ident -> Loc.tag ~loc:!@loc id ] ] ; var: (* as identref, but interpret as a term identifier in ltac *) - [ [ id = ident -> (!@loc, id) ] ] + [ [ id = ident -> Loc.tag ~loc:!@loc id ] ] ; identref: - [ [ id = ident -> (!@loc, id) ] ] + [ [ id = ident -> Loc.tag ~loc:!@loc id ] ] ; field: [ [ s = FIELD -> Id.of_string s ] ] @@ -60,8 +60,8 @@ GEXTEND Gram ] ] ; fullyqualid: - [ [ id = ident; (l,id')=fields -> !@loc,id::List.rev (id'::l) - | id = ident -> !@loc,[id] + [ [ id = ident; (l,id')=fields -> Loc.tag ~loc:!@loc @@ id::List.rev (id'::l) + | id = ident -> Loc.tag ~loc:!@loc [id] ] ] ; basequalid: @@ -70,32 +70,32 @@ GEXTEND Gram ] ] ; name: - [ [ IDENT "_" -> (!@loc, Anonymous) - | id = ident -> (!@loc, Name id) ] ] + [ [ IDENT "_" -> Loc.tag ~loc:!@loc Anonymous + | id = ident -> Loc.tag ~loc:!@loc @@ Name id ] ] ; reference: [ [ id = ident; (l,id') = fields -> - Qualid (!@loc, local_make_qualid (l@[id]) id') - | id = ident -> Ident (!@loc,id) + Qualid (Loc.tag ~loc:!@loc @@ local_make_qualid (l@[id]) id') + | id = ident -> Ident (Loc.tag ~loc:!@loc id) ] ] ; by_notation: - [ [ s = ne_string; sc = OPT ["%"; key = IDENT -> key ] -> (!@loc, s, sc) ] ] + [ [ s = ne_string; sc = OPT ["%"; key = IDENT -> key ] -> Loc.tag ~loc:!@loc (s, sc) ] ] ; smart_global: [ [ c = reference -> Misctypes.AN c | ntn = by_notation -> Misctypes.ByNotation ntn ] ] ; qualid: - [ [ qid = basequalid -> !@loc, qid ] ] + [ [ qid = basequalid -> Loc.tag ~loc:!@loc qid ] ] ; ne_string: [ [ s = STRING -> - if s="" then CErrors.user_err ~loc:(!@loc) (Pp.str"Empty string."); s + if s="" then CErrors.user_err ~loc:!@loc (Pp.str"Empty string."); s ] ] ; ne_lstring: - [ [ s = ne_string -> (!@loc, s) ] ] + [ [ s = ne_string -> Loc.tag ~loc:!@loc s ] ] ; dirpath: [ [ id = ident; l = LIST0 field -> @@ -105,7 +105,7 @@ GEXTEND Gram [ [ s = STRING -> s ] ] ; lstring: - [ [ s = string -> (!@loc, s) ] ] + [ [ s = string -> (Loc.tag ~loc:!@loc s) ] ] ; integer: [ [ i = INT -> my_int_of_string (!@loc) i diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 68b8be6b87..a3f9793bbd 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -48,14 +48,11 @@ GEXTEND Gram | IDENT "Qed" -> VernacEndProof (Proved (Opaque None,None)) | IDENT "Qed"; IDENT "exporting"; l = LIST0 identref SEP "," -> VernacEndProof (Proved (Opaque (Some l),None)) - | IDENT "Save" -> VernacEndProof (Proved (Opaque None,None)) - | IDENT "Save"; tok = thm_token; id = identref -> - VernacEndProof (Proved (Opaque None,Some (id,Some tok))) | IDENT "Save"; id = identref -> - VernacEndProof (Proved (Opaque None,Some (id,None))) + VernacEndProof (Proved (Opaque None, Some id)) | IDENT "Defined" -> VernacEndProof (Proved (Transparent,None)) | IDENT "Defined"; id=identref -> - VernacEndProof (Proved (Transparent,Some (id,None))) + VernacEndProof (Proved (Transparent,Some id)) | IDENT "Restart" -> VernacRestart | IDENT "Undo" -> VernacUndo 1 | IDENT "Undo"; n = natural -> VernacUndo n @@ -119,7 +116,7 @@ GEXTEND Gram ; constr_body: [ [ ":="; c = lconstr -> c - | ":"; t = lconstr; ":="; c = lconstr -> CCast(!@loc,c,CastConv t) ] ] + | ":"; t = lconstr; ":="; c = lconstr -> CAst.make ~loc:!@loc @@ CCast(c,CastConv t) ] ] ; mode: [ [ l = LIST1 [ "+" -> ModeInput diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 085c98e379..893605499c 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -102,7 +102,7 @@ GEXTEND Gram ; located_vernac: - [ [ v = vernac -> !@loc, v ] ] + [ [ v = vernac -> Loc.tag ~loc:!@loc v ] ] ; END @@ -229,19 +229,19 @@ GEXTEND Gram if List.exists (function CLocalPattern _ -> true | _ -> false) bl then (* FIXME: "red" will be applied to types in bl and Cast with remain *) - let c = mkCLambdaN (!@loc) bl c in + let c = mkCLambdaN ~loc:!@loc bl c in DefineBody ([], red, c, None) else (match c with - | CCast(_,c, CastConv t) -> DefineBody (bl, red, c, Some t) + | { CAst.v = CCast(c, CastConv t) } -> DefineBody (bl, red, c, Some t) | _ -> DefineBody (bl, red, c, None)) | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> let ((bl, c), tyo) = if List.exists (function CLocalPattern _ -> true | _ -> false) bl then (* FIXME: "red" will be applied to types in bl and Cast with remain *) - let c = CCast (!@loc, c, CastConv t) in - (([],mkCLambdaN (!@loc) bl c), None) + let c = CAst.make ~loc:!@loc @@ CCast (c, CastConv t) in + (([],mkCLambdaN ~loc:!@loc bl c), None) else ((bl, c), Some t) in DefineBody (bl, red, c, tyo) @@ -305,7 +305,7 @@ GEXTEND Gram ; type_cstr: [ [ ":"; c=lconstr -> c - | -> CHole (!@loc, None, Misctypes.IntroAnonymous, None) ] ] + | -> CAst.make ~loc:!@loc @@ CHole (None, Misctypes.IntroAnonymous, None) ] ] ; (* Inductive schemes *) scheme: @@ -349,19 +349,19 @@ GEXTEND Gram ; record_binder_body: [ [ l = binders; oc = of_type_with_opt_coercion; - t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN (!@loc) l t)) + t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN ~loc:!@loc l t)) | l = binders; oc = of_type_with_opt_coercion; t = lconstr; ":="; b = lconstr -> fun id -> - (oc,DefExpr (id,mkCLambdaN (!@loc) l b,Some (mkCProdN (!@loc) l t))) + (oc,DefExpr (id,mkCLambdaN ~loc:!@loc l b,Some (mkCProdN ~loc:!@loc l t))) | l = binders; ":="; b = lconstr -> fun id -> - match b with - | CCast(_,b, (CastConv t|CastVM t|CastNative t)) -> - (None,DefExpr(id,mkCLambdaN (!@loc) l b,Some (mkCProdN (!@loc) l t))) + match b.CAst.v with + | CCast(b', (CastConv t|CastVM t|CastNative t)) -> + (None,DefExpr(id,mkCLambdaN ~loc:!@loc l b',Some (mkCProdN ~loc:!@loc l t))) | _ -> - (None,DefExpr(id,mkCLambdaN (!@loc) l b,None)) ] ] + (None,DefExpr(id,mkCLambdaN ~loc:!@loc l b,None)) ] ] ; record_binder: - [ [ id = name -> (None,AssumExpr(id,CHole (!@loc, None, Misctypes.IntroAnonymous, None))) + [ [ id = name -> (None,AssumExpr(id, CAst.make ~loc:!@loc @@ CHole (None, Misctypes.IntroAnonymous, None))) | id = name; f = record_binder_body -> f id ] ] ; assum_list: @@ -378,9 +378,9 @@ GEXTEND Gram constructor_type: [[ l = binders; t= [ coe = of_type_with_opt_coercion; c = lconstr -> - fun l id -> (not (Option.is_empty coe),(id,mkCProdN (!@loc) l c)) + fun l id -> (not (Option.is_empty coe),(id,mkCProdN ~loc:!@loc l c)) | -> - fun l id -> (false,(id,mkCProdN (!@loc) l (CHole (!@loc, None, Misctypes.IntroAnonymous, None)))) ] + fun l id -> (false,(id,mkCProdN ~loc:!@loc l (CAst.make ~loc:!@loc @@ CHole (None, Misctypes.IntroAnonymous, None)))) ] -> t l ]] ; @@ -511,11 +511,11 @@ GEXTEND Gram (* Module expressions *) module_expr: [ [ me = module_expr_atom -> me - | me1 = module_expr; me2 = module_expr_atom -> CMapply (!@loc,me1,me2) + | me1 = module_expr; me2 = module_expr_atom -> CAst.make ~loc:!@loc @@ CMapply (me1,me2) ] ] ; module_expr_atom: - [ [ qid = qualid -> CMident qid | "("; me = module_expr; ")" -> me ] ] + [ [ qid = qualid -> CAst.make ~loc:!@loc @@ CMident (snd qid) | "("; me = module_expr; ")" -> me ] ] ; with_declaration: [ [ "Definition"; fqid = fullyqualid; ":="; c = Constr.lconstr -> @@ -525,11 +525,12 @@ GEXTEND Gram ] ] ; module_type: - [ [ qid = qualid -> CMident qid + [ [ qid = qualid -> CAst.make ~loc:!@loc @@ CMident (snd qid) | "("; mt = module_type; ")" -> mt - | mty = module_type; me = module_expr_atom -> CMapply (!@loc,mty,me) + | mty = module_type; me = module_expr_atom -> + CAst.make ~loc:!@loc @@ CMapply (mty,me) | mty = module_type; "with"; decl = with_declaration -> - CMwith (!@loc,mty,decl) + CAst.make ~loc:!@loc @@ CMwith (mty,decl) ] ] ; (* Proof using *) @@ -541,8 +542,8 @@ GEXTEND Gram starredidentref: [ [ i = identref -> SsSingl i | i = identref; "*" -> SsFwdClose(SsSingl i) - | "Type" -> SsSingl (!@loc, Id.of_string "Type") - | "Type"; "*" -> SsFwdClose (SsSingl (!@loc, Id.of_string "Type")) ]] + | "Type" -> SsSingl (Loc.tag ~loc:!@loc @@ Id.of_string "Type") + | "Type"; "*" -> SsFwdClose (SsSingl (Loc.tag ~loc:!@loc @@ Id.of_string "Type")) ]] ; ssexpr: [ "35" @@ -591,15 +592,15 @@ GEXTEND Gram d = def_body -> let s = coerce_reference_to_id qid in VernacDefinition - ((Some Global,CanonicalStructure),((Loc.ghost,s),None),d) + ((Some Global,CanonicalStructure),((Loc.tag s),None),d) (* Coercions *) | IDENT "Coercion"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((None,Coercion),((Loc.ghost,s),None),d) + VernacDefinition ((None,Coercion),((Loc.tag s),None),d) | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((Some Decl_kinds.Local,Coercion),((Loc.ghost,s),None),d) + VernacDefinition ((Some Decl_kinds.Local,Coercion),((Loc.tag s),None),d) | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacIdentityCoercion (true, f, s, t) @@ -659,7 +660,7 @@ GEXTEND Gram if Option.is_empty !slash_position then (slash_position := Some i; parse_args i args) else - error "The \"/\" modifier can occur only once" + user_err Pp.(str "The \"/\" modifier can occur only once") in let args = parse_args 0 (List.flatten args) in let more_implicits = Option.default [] more_implicits in @@ -719,7 +720,7 @@ GEXTEND Gram ; argument_spec: [ [ b = OPT "!"; id = name ; s = OPT scope -> - snd id, not (Option.is_empty b), Option.map (fun x -> !@loc, x) s + snd id, not (Option.is_empty b), Option.map (fun x -> Loc.tag ~loc:!@loc x) s ] ]; (* List of arguments implicit status, scope, modifiers *) @@ -732,24 +733,24 @@ GEXTEND Gram | "/" -> [`Slash] | "("; items = LIST1 argument_spec; ")"; sc = OPT scope -> let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x - | Some _, Some _ -> error "scope declared twice" in + | None, x -> x | x, None -> Option.map (fun y -> Loc.tag ~loc:!@loc y) x + | Some _, Some _ -> user_err Pp.(str "scope declared twice") in List.map (fun (name,recarg_like,notation_scope) -> `Id { name=name; recarg_like=recarg_like; notation_scope=f notation_scope; implicit_status = NotImplicit}) items | "["; items = LIST1 argument_spec; "]"; sc = OPT scope -> let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x - | Some _, Some _ -> error "scope declared twice" in + | None, x -> x | x, None -> Option.map (fun y -> Loc.tag ~loc:!@loc y) x + | Some _, Some _ -> user_err Pp.(str "scope declared twice") in List.map (fun (name,recarg_like,notation_scope) -> `Id { name=name; recarg_like=recarg_like; notation_scope=f notation_scope; implicit_status = Implicit}) items | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope -> let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x - | Some _, Some _ -> error "scope declared twice" in + | None, x -> x | x, None -> Option.map (fun y -> Loc.tag ~loc:!@loc y) x + | Some _, Some _ -> user_err Pp.(str "scope declared twice") in List.map (fun (name,recarg_like,notation_scope) -> `Id { name=name; recarg_like=recarg_like; notation_scope=f notation_scope; @@ -776,7 +777,7 @@ GEXTEND Gram [ [ name = pidentref; sup = OPT binders -> (let ((loc,id),l) = name in ((loc, Name id),l)), (Option.default [] sup) - | -> ((!@loc, Anonymous), None), [] ] ] + | -> ((Loc.tag ~loc:!@loc Anonymous), None), [] ] ] ; hint_info: [ [ "|"; i = OPT natural; pat = OPT constr_pattern -> @@ -938,7 +939,7 @@ GEXTEND Gram PrintGrammar ent | IDENT "LoadPath"; dir = OPT dirpath -> PrintLoadPath dir | IDENT "Modules" -> - error "Print Modules is obsolete; use Print Libraries instead" + user_err Pp.(str "Print Modules is obsolete; use Print Libraries instead") | IDENT "Libraries" -> PrintModules | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath @@ -1143,8 +1144,8 @@ GEXTEND Gram | IDENT "only"; IDENT "parsing" -> SetOnlyParsing | IDENT "compat"; s = STRING -> SetCompatVersion (Coqinit.get_compat_version s) - | IDENT "format"; s1 = [s = STRING -> (!@loc,s)]; - s2 = OPT [s = STRING -> (!@loc,s)] -> + | IDENT "format"; s1 = [s = STRING -> Loc.tag ~loc:!@loc s]; + s2 = OPT [s = STRING -> Loc.tag ~loc:!@loc s] -> begin match s1, s2 with | (_,k), Some s -> SetFormat(k,s) | s, None -> SetFormat ("text",s) end diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 4248db697a..959e8ddf52 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -206,7 +206,7 @@ module Prim : val qualid : qualid located Gram.entry val fullyqualid : Id.t list located Gram.entry val reference : reference Gram.entry - val by_notation : (Loc.t * string * string option) Gram.entry + val by_notation : (string * string option) Loc.located Gram.entry val smart_global : reference or_by_notation Gram.entry val dirpath : DirPath.t Gram.entry val ne_string : string Gram.entry diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index a0b04ce3b5..33a9dd4fd9 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -8,7 +8,7 @@ let init_constant dir s = in find_constant contrib_name dir s -let get_constant dir s = lazy (Coqlib.gen_constant contrib_name dir s) +let get_constant dir s = lazy (Universes.constr_of_global @@ Coqlib.coq_reference contrib_name dir s) let get_inductive dir s = let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index aa71a45658..5dea4631c4 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -29,8 +29,7 @@ let debug x = let _= let gdopt= - { optsync=true; - optdepr=false; + { optdepr=false; optname="Congruence Verbose"; optkey=["Congruence";"Verbose"]; optread=(fun ()-> !cc_verbose); diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 1cb417bf47..43c06a54d4 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -26,7 +26,7 @@ open Proofview.Notations module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -let reference dir s = lazy (Coqlib.gen_reference "CC" dir s) +let reference dir s = lazy (Coqlib.coq_reference "CC" dir s) let _f_equal = reference ["Init";"Logic"] "f_equal" let _eq_rect = reference ["Init";"Logic"] "eq_rect" @@ -231,9 +231,9 @@ let make_prb gls depth additionnal_terms = let build_projection intype (cstr:pconstructor) special default gls= let open Tacmach.New in let ci= (snd(fst cstr)) in - let body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in + let sigma, body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in let id=pf_get_new_id (Id.of_string "t") gls in - mkLambda(Name id,intype,body) + sigma, mkLambda(Name id,intype,body) (* generate an adhoc tactic following the proof tree *) @@ -346,12 +346,13 @@ let rec proof_tac p : unit Proofview.tactic = let special=mkRel (1+nargs-argind) in refresh_universes (type_of ti) (fun intype -> refresh_universes (type_of default) (fun outtype -> - let proj = + let sigma, proj = build_projection intype cstr special default gl in let injt= app_global_with_holes _f_equal [|intype;outtype;proj;ti;tj|] 1 in - Tacticals.New.tclTHEN injt (proof_tac prf))) + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHEN injt (proof_tac prf)))) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end } @@ -442,11 +443,11 @@ let cc_tactic depth additionnal_terms = let open Glob_term in let env = Proofview.Goal.env gl in let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in - let hole = GHole (Loc.ghost, Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None) in + let hole = CAst.make @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None) in let pr_missing (c, missing) = let c = Detyping.detype ~lax:true false [] env sigma c in let holes = List.init missing (fun _ -> hole) in - Printer.pr_glob_constr_env env (GApp (Loc.ghost, c, holes)) + Printer.pr_glob_constr_env env (CAst.make @@ GApp (c, holes)) in Feedback.msg_info (Pp.str "Goal is solvable by congruence but some arguments are missing."); diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 12d7f06603..b3ab29cced 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -53,9 +53,9 @@ let start_deriving f suchthat lemma = [suchthat], respectively. *) let (opaque,f_def,lemma_def) = match com with - | Admitted _ -> CErrors.error"Admitted isn't supported in Derive." + | Admitted _ -> CErrors.user_err Pp.(str "Admitted isn't supported in Derive.") | Proved (_,Some _,_) -> - CErrors.error"Cannot save a proof of Derive with an explicit name." + CErrors.user_err Pp.(str "Cannot save a proof of Derive with an explicit name.") | Proved (opaque, None, obj) -> match Proof_global.(obj.entries) with | [_;f_def;lemma_def] -> diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index fc8d5356c8..c498eb5890 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -109,12 +109,17 @@ let pseudo_qualify = qualify "__" let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false -let lowercase_id id = Id.of_string (String.uncapitalize (ascii_of_id id)) +[@@@ocaml.warning "-3"] (* String.(un)capitalize_ascii since 4.03.0 GPR#124 *) +let capitalize = String.capitalize +let uncapitalize = String.uncapitalize +[@@@ocaml.warning "+3"] + +let lowercase_id id = Id.of_string (uncapitalize (ascii_of_id id)) let uppercase_id id = let s = ascii_of_id id in assert (not (String.is_empty s)); if s.[0] == '_' then Id.of_string ("Coq_"^s) - else Id.of_string (String.capitalize s) + else Id.of_string (capitalize s) type kind = Term | Type | Cons | Mod diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 322fbcea74..2c85b185c4 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -41,7 +41,7 @@ let toplevel_env () = | "MODULE TYPE" -> let modtype = Global.lookup_modtype (MPdot (mp, l)) in Some (l, SFBmodtype modtype) - | "INCLUDE" -> error "No extraction of toplevel Include yet." + | "INCLUDE" -> user_err Pp.(str "No extraction of toplevel Include yet.") | _ -> None end | _ -> None @@ -435,7 +435,7 @@ let mono_filename f = else try Id.of_string (Filename.basename f) with UserError _ -> - error "Extraction: provided filename is not a valid identifier" + user_err Pp.(str "Extraction: provided filename is not a valid identifier") in Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 0692c88cd1..eb13fd6755 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -20,9 +20,10 @@ open Mlutil open Common (*s Haskell renaming issues. *) - +[@@@ocaml.warning "-3"] (* String.(un)capitalize_ascii since 4.03.0 GPR#124 *) let pr_lower_id id = str (String.uncapitalize (Id.to_string id)) let pr_upper_id id = str (String.capitalize (Id.to_string id)) +[@@@ocaml.warning "+3"] let keywords = List.fold_right (fun s -> Id.Set.add (Id.of_string s)) @@ -185,7 +186,7 @@ let rec pp_expr par env args = pp_boxed_tuple (pp_expr true env []) l | MLcase (_,t, pv) when is_custom_match pv -> if not (is_regular_match pv) then - error "Cannot mix yet user-given match and general patterns."; + user_err Pp.(str "Cannot mix yet user-given match and general patterns."); let mkfun (ids,_,e) = if not (List.is_empty ids) then named_lams (List.rev ids) e else dummy_lams (ast_lift 1 e) 1 diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index d8e3821557..4399fc561f 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -246,7 +246,7 @@ let rec pp_expr par env args = pp_boxed_tuple (pp_expr true env []) l | MLcase (_, t, pv) when is_custom_match pv -> if not (is_regular_match pv) then - error "Cannot mix yet user-given match and general patterns."; + user_err Pp.(str "Cannot mix yet user-given match and general patterns."); let mkfun (ids,_,e) = if not (List.is_empty ids) then named_lams (List.rev ids) e else dummy_lams (ast_lift 1 e) 1 diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index 8d0cc4a0db..3c81564e34 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -96,9 +96,9 @@ let rec pp_expr env args = prlist_with_sep spc (pp_cons_args env) args') in if is_coinductive r then paren (str "delay " ++ st) else st - | MLtuple _ -> error "Cannot handle tuples in Scheme yet." + | MLtuple _ -> user_err Pp.(str "Cannot handle tuples in Scheme yet.") | MLcase (_,_,pv) when not (is_regular_match pv) -> - error "Cannot handle general patterns in Scheme yet." + user_err Pp.(str "Cannot handle general patterns in Scheme yet.") | MLcase (_,t,pv) when is_custom_match pv -> let mkfun (ids,_,e) = if not (List.is_empty ids) then named_lams (List.rev ids) e diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index d6a334c5fe..a369cbdf37 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -20,6 +20,11 @@ open Util open Pp open Miniml +[@@@ocaml.warning "-3"] (* String.capitalize_ascii since 4.03.0 GPR#124 *) +let capitalize = String.capitalize +[@@@ocaml.warning "+3"] + + (** Sets and maps for [global_reference] that use the "user" [kernel_name] instead of the canonical one *) @@ -55,7 +60,7 @@ let is_modfile = function | _ -> false let raw_string_of_modfile = function - | MPfile f -> String.capitalize (Id.to_string (List.hd (DirPath.repr f))) + | MPfile f -> capitalize (Id.to_string (List.hd (DirPath.repr f))) | _ -> assert false let is_toplevel mp = @@ -494,8 +499,7 @@ let my_bool_option name initval = let flag = ref initval in let access = fun () -> !flag in let _ = declare_bool_option - {optsync = true; - optdepr = false; + {optdepr = false; optname = "Extraction "^name; optkey = ["Extraction"; name]; optread = access; @@ -567,16 +571,14 @@ let chg_flag n = int_flag_ref := n; opt_flag_ref := flag_of_int n let optims () = !opt_flag_ref let _ = declare_bool_option - {optsync = true; - optdepr = false; + {optdepr = false; optname = "Extraction Optimize"; optkey = ["Extraction"; "Optimize"]; optread = (fun () -> not (Int.equal !int_flag_ref 0)); optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))} let _ = declare_int_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "Extraction Flag"; optkey = ["Extraction";"Flag"]; optread = (fun _ -> Some !int_flag_ref); @@ -590,8 +592,7 @@ let conservative_types_ref = ref false let conservative_types () = !conservative_types_ref let _ = declare_bool_option - {optsync = true; - optdepr = false; + {optdepr = false; optname = "Extraction Conservative Types"; optkey = ["Extraction"; "Conservative"; "Types"]; optread = (fun () -> !conservative_types_ref); @@ -603,8 +604,7 @@ let file_comment_ref = ref "" let file_comment () = !file_comment_ref let _ = declare_string_option - {optsync = true; - optdepr = false; + {optdepr = false; optname = "Extraction File Comment"; optkey = ["Extraction"; "File"; "Comment"]; optread = (fun () -> !file_comment_ref); @@ -777,7 +777,7 @@ let file_of_modfile mp = let add_blacklist_entries l = blacklist_table := - List.fold_right (fun s -> Id.Set.add (Id.of_string (String.capitalize s))) + List.fold_right (fun s -> Id.Set.add (Id.of_string (capitalize s))) l !blacklist_table (* Registration of operations for rollback. *) @@ -892,7 +892,7 @@ let extract_constant_inline inline r ids s = let extract_inductive r s l optstr = check_inside_section (); let g = Smartlocate.global_with_alias r in - Dumpglob.add_glob (loc_of_reference r) g; + Dumpglob.add_glob ?loc:(loc_of_reference r) g; match g with | IndRef ((kn,i) as ip) -> let mib = Global.lookup_mind kn in diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index b250175354..bbb9feae2e 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -30,8 +30,7 @@ let ground_depth=ref 3 let _= let gdopt= - { optsync=true; - optdepr=false; + { optdepr=false; optname="Firstorder Depth"; optkey=["Firstorder";"Depth"]; optread=(fun ()->Some !ground_depth); @@ -46,8 +45,7 @@ let congruence_depth=ref 100 let _= let gdopt= - { optsync=true; - optdepr=false; + { optdepr=false; optname="Congruence Depth"; optkey=["Congruence";"Depth"]; optread=(fun ()->Some !congruence_depth); @@ -63,7 +61,7 @@ let default_intuition_tac = let name = { Tacexpr.mltac_plugin = "ground_plugin"; mltac_tactic = "auto_with"; } in let entry = { Tacexpr.mltac_name = name; mltac_index = 0 } in Tacenv.register_ml_tactic name [| tac |]; - Tacexpr.TacML (Loc.ghost, entry, []) + Tacexpr.TacML (Loc.tag (entry, [])) let (set_default_solver, default_solver, print_default_solver) = Tactic_option.declare_tactic_option ~default:default_intuition_tac "Firstorder default solver" diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 5a1e7c26a1..4c6355f61c 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -161,7 +161,7 @@ let left_instance_tac (inst,id) continue seq= let evmap, _ = try Typing.type_of (pf_env gl) evmap gt with e when CErrors.noncritical e -> - error "Untypable instance, maybe higher-order non-prenex quantification" in + user_err Pp.(str "Untypable instance, maybe higher-order non-prenex quantification") in Sigma.Unsafe.of_pair (generalize [gt], evmap) end }) else diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 86a6770070..8c6b5b91de 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -231,7 +231,8 @@ let ll_forall_tac prod backtrack id continue seq= (* special for compatibility with old Intuition *) -let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str +let constant str = Universes.constr_of_global + @@ Coqlib.coq_reference "User" ["Init";"Logic"] str let defined_connectives=lazy [AllOccurrences,EvalConstRef (fst (Term.destConst (constant "not"))); diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 2d18b66054..826afc35b6 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -227,7 +227,7 @@ let extend_with_auto_hints env sigma l seq = try searchtable_map dbname with Not_found-> - error ("Firstorder: "^dbname^" : No such Hint database") in + user_err Pp.(str ("Firstorder: "^dbname^" : No such Hint database")) in Hint_db.iter g hdb in List.iter h l; !seqref, sigma (*FIXME: forgetting about universes*) diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index 25d8f8c832..a6290cb00c 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -285,14 +285,15 @@ let fourier_lineq lineq1 = let get = Lazy.force let cget = get let eget c = EConstr.of_constr (Lazy.force c) -let constant = Coqlib.gen_constant "Fourier" +let constant path s = Universes.constr_of_global @@ + Coqlib.coq_reference "Fourier" path s (* Standard library *) open Coqlib let coq_sym_eqT = lazy (build_coq_eq_sym ()) -let coq_False = lazy (build_coq_False ()) -let coq_not = lazy (build_coq_not ()) -let coq_eq = lazy (build_coq_eq ()) +let coq_False = lazy (Universes.constr_of_global @@ build_coq_False ()) +let coq_not = lazy (Universes.constr_of_global @@ build_coq_not ()) +let coq_eq = lazy (Universes.constr_of_global @@ build_coq_eq ()) (* Rdefinitions *) let constant_real = constant ["Reals";"Rdefinitions"] @@ -513,11 +514,11 @@ let rec fourier () = with NoIneq -> ()) hyps; (* lineq = les inéquations découlant des hypothèses *) - if !lineq=[] then CErrors.error "No inequalities"; + if !lineq=[] then CErrors.user_err Pp.(str "No inequalities"); let res=fourier_lineq (!lineq) in let tac=ref (Proofview.tclUNIT ()) in if res=[] - then CErrors.error "fourier failed" + then CErrors.user_err Pp.(str "fourier failed") (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *) else (match res with [(cres,sres,lc)]-> diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 55d361e3d2..0041797de7 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -409,9 +409,9 @@ let rewrite_until_var arg_num eq_ids : tactic = let rec_pte_id = Id.of_string "Hrec" let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = EConstr.of_constr (Coqlib.build_coq_False ()) in - let coq_True = EConstr.of_constr (Coqlib.build_coq_True ()) in - let coq_I = EConstr.of_constr (Coqlib.build_coq_I ()) in + let coq_False = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_False ()) in + let coq_True = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_True ()) in + let coq_I = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_I ()) in let rec scan_type context type_of_hyp : tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in @@ -820,10 +820,10 @@ let build_proof build_proof new_finalize {dyn_infos with info = f } g end | Fix _ | CoFix _ -> - error ( "Anonymous local (co)fixpoints are not handled yet") + user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet")) - | Proj _ -> error "Prod" - | Prod _ -> error "Prod" + | Proj _ -> user_err Pp.(str "Prod") + | Prod _ -> user_err Pp.(str "Prod") | LetIn _ -> let new_infos = { dyn_infos with @@ -944,7 +944,7 @@ let generalize_non_dep hyp g = ((* observe_tac "thin" *) (thin to_revert)) g -let id_of_decl = RelDecl.get_name %> Nameops.out_name +let id_of_decl = RelDecl.get_name %> Nameops.Name.get_id let var_of_decl = id_of_decl %> mkVar let revert idl = tclTHEN @@ -1097,7 +1097,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (Global.env ()) (Evd.empty) (EConstr.of_constr body) - | None -> error ( "Cannot define a principle over an axiom ") + | None -> user_err Pp.(str "Cannot define a principle over an axiom ") in let fbody = get_body fnames.(fun_num) in let f_ctxt,f_body = decompose_lam (project g) fbody in @@ -1127,11 +1127,11 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam ) in observe (str "full_params := " ++ - prlist_with_sep spc (RelDecl.get_name %> Nameops.out_name %> Ppconstr.pr_id) + prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) full_params ); observe (str "princ_params := " ++ - prlist_with_sep spc (RelDecl.get_name %> Nameops.out_name %> Ppconstr.pr_id) + prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) princ_params ); observe (str "fbody_with_full_params := " ++ @@ -1158,7 +1158,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (fun i types -> let types = prod_applist (project g) types (List.rev_map var_of_decl princ_params) in { idx = idxs.(i) - fix_offset; - name = Nameops.out_name (fresh_id names.(i)); + name = Nameops.Name.get_id (fresh_id names.(i)); types = types; offset = fix_offset; nb_realargs = @@ -1181,7 +1181,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in let app_f = mkApp(f,first_args) in let pte_args = (Array.to_list first_args)@[app_f] in - let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in + let app_pte = applist(mkVar (Nameops.Name.get_id pte),pte_args) in let body_with_param,num = let body = get_body fnames.(i) in let body_with_full_params = @@ -1199,7 +1199,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam bs.(num), List.rev_map var_of_decl princ_params)) ),num - | _ -> error "Not a mutual block" + | _ -> user_err Pp.(str "Not a mutual block") in let info = {infos with @@ -1208,9 +1208,9 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam num_in_block = num } in -(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *) +(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) (* str " to " ++ Ppconstr.pr_id info.name); *) - (Id.Map.add (Nameops.out_name pte) info acc_map,info::acc_info) + (Id.Map.add (Nameops.Name.get_id pte) info acc_map,info::acc_info) ) 0 (Id.Map.empty,[]) @@ -1284,7 +1284,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (do_replace evd full_params (fix_info.idx + List.length princ_params) - (args_id@(List.map (RelDecl.get_name %> Nameops.out_name) princ_params)) + (args_id@(List.map (RelDecl.get_name %> Nameops.Name.get_id) princ_params)) (all_funs.(fix_info.num_in_block)) fix_info.num_in_block all_funs @@ -1563,17 +1563,17 @@ let prove_principle_for_gen | _ -> assert false in (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (get_name %> Nameops.out_name %> mkVar) (pre_rec_arg@princ_info.params) in + let subst_constrs = List.map (get_name %> Nameops.Name.get_id %> mkVar) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in - let wf_thm_id = Nameops.out_name (fresh_id (Name (Id.of_string "wf_R"))) in + let wf_thm_id = Nameops.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) in let acc_rec_arg_id = - Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) + Nameops.Name.get_id (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) in let revert l = tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l)) in - let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in + let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = ((* observe_tac "prove_rec_arg_acc" *) (tclCOMPLETE @@ -1591,12 +1591,12 @@ let prove_principle_for_gen ) g in - let args_ids = List.map (get_name %> Nameops.out_name) princ_info.args in + let args_ids = List.map (get_name %> Nameops.Name.get_id) princ_info.args in let lemma = match !tcc_lemma_ref with - | Undefined -> error "No tcc proof !!" + | Undefined -> user_err Pp.(str "No tcc proof !!") | Value lemma -> EConstr.of_constr lemma - | Not_needed -> EConstr.of_constr (Coqlib.build_coq_I ()) + | Not_needed -> EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_I ()) in (* let rec list_diff del_list check_list = *) (* match del_list with *) @@ -1639,7 +1639,7 @@ let prove_principle_for_gen [ observe_tac "start_tac" start_tac; h_intros - (List.rev_map (get_name %> Nameops.out_name) + (List.rev_map (get_name %> Nameops.Name.get_id) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); (* observe_tac "" *) Proofview.V82.of_tactic (assert_by @@ -1677,14 +1677,14 @@ let prove_principle_for_gen in let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in let predicates_names = - List.map (get_name %> Nameops.out_name) princ_info.predicates + List.map (get_name %> Nameops.Name.get_id) princ_info.predicates in let pte_info = { proving_tac = (fun eqs -> (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) -(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *) -(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *) +(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) +(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) @@ -1693,7 +1693,7 @@ let prove_principle_for_gen is_mes acc_inv fix_id (!tcc_list@(List.map - (get_name %> Nameops.out_name) + (get_name %> Nameops.Name.get_id) (princ_info.args@princ_info.params) )@ ([acc_rec_arg_id])) eqs ) @@ -1722,7 +1722,7 @@ let prove_principle_for_gen (* observe_tac "instanciate_hyps_with_args" *) (instanciate_hyps_with_args make_proof - (List.map (get_name %> Nameops.out_name) princ_info.branches) + (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) (List.rev args_ids) ) gl' diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 529b91c4ca..9425271671 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -62,7 +62,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = then List.tl args else args in - Context.Named.Declaration.LocalAssum (Nameops.out_name (Context.Rel.Declaration.get_name decl), + Context.Named.Declaration.LocalAssum (Nameops.Name.get_id (Context.Rel.Declaration.get_name decl), Term.compose_prod real_args (mkSort new_sort)) in let new_predicates = @@ -75,7 +75,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let rel_as_kn = fst (match princ_type_info.indref with | Some (Globnames.IndRef ind) -> ind - | _ -> error "Not a valid predicate" + | _ -> user_err Pp.(str "Not a valid predicate") ) in let ptes_vars = List.map Context.Named.Declaration.get_id new_predicates in @@ -185,11 +185,11 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = with | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in new_b, List.map pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) end @@ -214,11 +214,11 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = with | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in new_b, List.map pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) end @@ -416,7 +416,7 @@ let get_funs_constant mp dp = in let body = EConstr.Unsafe.to_constr body in body - | None -> error ( "Cannot define a principle over an axiom ") + | None -> user_err Pp.(str ( "Cannot define a principle over an axiom ")) in let f = find_constant_body const in let l_const = get_funs_constant const f in @@ -432,7 +432,7 @@ let get_funs_constant mp dp = List.iter (fun params -> if not (List.equal (fun (n1, c1) (n2, c2) -> Name.equal n1 n2 && eq_constr c1 c2) first_params params) - then error "Not a mutal recursive block" + then user_err Pp.(str "Not a mutal recursive block") ) l_params in @@ -445,7 +445,7 @@ let get_funs_constant mp dp = | _ -> if is_first && Int.equal (List.length l_bodies) 1 then raise Not_Rec - else error "Not a mutal recursive block" + else user_err Pp.(str "Not a mutal recursive block") in let first_infos = extract_info true (List.hd l_bodies) in let check body = (* Hope this is correct *) @@ -454,7 +454,7 @@ let get_funs_constant mp dp = Array.equal eq_constr ta1 ta2 && Array.equal eq_constr ca1 ca2 in if not (eq_infos first_infos (extract_info false body)) - then error "Not a mutal recursive block" + then user_err Pp.(str "Not a mutal recursive block") in List.iter check l_bodies with Not_Rec -> () diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index b5eacee818..1db8be0818 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -23,8 +23,8 @@ open Pltac DECLARE PLUGIN "recdef_plugin" let pr_binding prc = function - | loc, NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) - | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) + | loc, (NamedHyp id, c) -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) + | loc, (AnonHyp n, c) -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) let pr_bindings prc prlc = function | ImplicitBindings l -> @@ -90,7 +90,7 @@ let pr_intro_as_pat _prc _ _ pat = let out_disjunctive = function | loc, IntroAction (IntroOrAndPattern l) -> (loc,l) - | _ -> CErrors.error "Disjunctive or conjunctive intro pattern expected." + | _ -> CErrors.user_err Pp.(str "Disjunctive or conjunctive intro pattern expected.") ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat | [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] @@ -158,7 +158,7 @@ GEXTEND Gram GLOBAL: function_rec_definition_loc ; function_rec_definition_loc: - [ [ g = Vernac.rec_definition -> !@loc, g ]] + [ [ g = Vernac.rec_definition -> Loc.tag ~loc:!@loc g ]] ; END @@ -228,7 +228,7 @@ VERNAC COMMAND EXTEND NewFunctionalScheme ; try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> - CErrors.error ("Cannot generate induction principle(s)") + CErrors.user_err Pp.(str "Cannot generate induction principle(s)") | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 7dc8691311..68e097fe9c 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -248,10 +248,10 @@ let mk_result ctxt value avoid = **************************************************) let coq_True_ref = - lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True") + lazy (Coqlib.coq_reference "" ["Init";"Logic"] "True") let coq_False_ref = - lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False") + lazy (Coqlib.coq_reference "" ["Init";"Logic"] "False") (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with @@ -274,10 +274,10 @@ let make_discr_match_el = *) let make_discr_match_brl i = List.map_i - (fun j (_,idl,patl,_) -> + (fun j (_,(idl,patl,_)) -> Loc.tag @@ if Int.equal j i - then (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_True_ref)) - else (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_False_ref)) + then (idl,patl, mkGRef (Lazy.force coq_True_ref)) + else (idl,patl, mkGRef (Lazy.force coq_False_ref)) ) 0 (* @@ -348,9 +348,9 @@ let add_pat_variables pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); - match pat with - | PatVar(_,na) -> Environ.push_rel (RelDecl.LocalAssum (na,typ)) env - | PatCstr(_,c,patl,na) -> + match pat.CAst.v with + | PatVar na -> Environ.push_rel (RelDecl.LocalAssum (na,typ)) env + | PatCstr(c,patl,na) -> let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) with Not_found -> assert false @@ -398,11 +398,11 @@ let add_pat_variables pat typ env : Environ.env = -let rec pattern_to_term_and_type env typ = function - | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> +let rec pattern_to_term_and_type env typ = CAst.with_val (function + | PatVar Anonymous -> assert false + | PatVar (Name id) -> mkGVar id - | PatCstr(loc,constr,patternl,_) -> + | PatCstr(constr,patternl,_) -> let cst_narg = Inductiveops.constructor_nallargs_env (Global.env ()) @@ -430,6 +430,7 @@ let rec pattern_to_term_and_type env typ = function mkGApp(mkGRef(ConstructRef constr), implicit_args@patl_as_term ) + ) (* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the @@ -463,13 +464,14 @@ let rec pattern_to_term_and_type env typ = function *) -let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = +let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = observe (str " Entering : " ++ Printer.pr_glob_constr rt); - match rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> + let open CAst in + match rt.v with + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> (* do nothing (except changing type of course) *) mk_result [] rt avoid - | GApp(_,_,_) -> + | GApp(_,_) -> let f,args = glob_decompose_app rt in let args_res : (glob_constr list) build_entry_return = List.fold_right (* create the arguments lists of constructors and combine them *) @@ -481,20 +483,20 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = (mk_result [] [] avoid) in begin - match f with + match f.v with | GLambda _ -> let rec aux t l = match l with | [] -> t - | u::l -> - match t with - | GLambda(loc,na,_,nat,b) -> - GLetIn(Loc.ghost,na,u,None,aux b l) + | u::l -> CAst.make @@ + match t.v with + | GLambda(na,_,nat,b) -> + GLetIn(na,u,None,aux b l) | _ -> - GApp(Loc.ghost,t,l) + GApp(t,l) in build_entry_lc env funnames avoid (aux f args) - | GVar(_,id) when Id.Set.mem id funnames -> + | GVar id when Id.Set.mem id funnames -> (* if we have [f t1 ... tn] with [f]$\in$[fnames] then we create a fresh variable [res], add [res] and its "value" (i.e. [res v1 ... vn]) to each @@ -535,7 +537,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = args_res.result } | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *) - | GLetIn(_,n,v,t,b) -> + | GLetIn(n,v,t,b) -> (* if we have [(let x := v in b) t1 ... tn] , we discard our work and compute the list of constructor for [let x = v in (b t1 ... tn)] up to alpha conversion @@ -549,7 +551,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let new_b = replace_var_by_term id - (GVar(Loc.ghost,id)) + (CAst.make @@ GVar id) b in (Name new_id,new_b,new_avoid) @@ -567,18 +569,18 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = *) let f_res = build_entry_lc env funnames args_res.to_avoid f in combine_results combine_app f_res args_res - | GCast(_,b,_) -> + | GCast(b,_) -> (* for an applied cast we just trash the cast part and restart the work. WARNING: We need to restart since [b] itself should be an application term *) build_entry_lc env funnames avoid (mkGApp(b,args)) - | GRec _ -> error "Not handled GRec" - | GProd _ -> error "Cannot apply a type" + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GProd _ -> user_err Pp.(str "Cannot apply a type") end (* end of the application treatement *) - | GLambda(_,n,_,t,b) -> + | GLambda(n,_,t,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the type @@ -593,7 +595,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let new_env = raw_push_named (new_n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_lam new_n) t_res b_res - | GProd(_,n,_,t,b) -> + | GProd(n,_,t,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the type @@ -603,13 +605,13 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let new_env = raw_push_named (n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_prod n) t_res b_res - | GLetIn(loc,n,v,typ,b) -> + | GLetIn(n,v,typ,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the value [t] and combine the two result *) - let v = match typ with None -> v | Some t -> GCast (loc,v,CastConv t) in + let v = match typ with None -> v | Some t -> CAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in let v_res = build_entry_lc env funnames avoid v in let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in let v_type = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr v_as_constr) in @@ -621,13 +623,13 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_letin n) v_res b_res - | GCases(_,_,_,el,brl) -> + | GCases(_,_,el,brl) -> (* we create the discrimination function and treat the case itself *) let make_discr = make_discr_match brl in build_entry_lc_from_case env funnames make_discr el brl avoid - | GIf(_,b,(na,e_option),lhs,rhs) -> + | GIf(b,(na,e_option),lhs,rhs) -> let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in let b_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr b_as_constr) in let (ind,_) = @@ -641,7 +643,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = assert (Int.equal (Array.length case_pats) 2); let brl = List.map_i - (fun i x -> (Loc.ghost,[],[case_pats.(i)],x)) + (fun i x -> Loc.tag ([],[case_pats.(i)],x)) 0 [lhs;rhs] in @@ -650,7 +652,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = in (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) build_entry_lc env funnames avoid match_expr - | GLetTuple(_,nal,_,b,e) -> + | GLetTuple(nal,_,b,e) -> begin let nal_as_glob_constr = List.map @@ -671,15 +673,13 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = in let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in assert (Int.equal (Array.length case_pats) 1); - let br = - (Loc.ghost,[],[case_pats.(0)],e) - in + let br = Loc.tag ([],[case_pats.(0)],e) in let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in build_entry_lc env funnames avoid match_expr end - | GRec _ -> error "Not handled GRec" - | GCast(_,b,_) -> + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GCast(b,_) -> build_entry_lc env funnames avoid b and build_entry_lc_from_case env funname make_discr (el:tomatch_tuples) @@ -739,7 +739,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve | [] -> (* computed_branches *) {result = [];to_avoid = avoid} | br::brl' -> (* alpha conversion to prevent name clashes *) - let _,idl,patl,return = alpha_br avoid br in + let _,(idl,patl,return) = alpha_br avoid br in let new_avoid = idl@avoid in (* for now we can no more use idl as an identifier *) (* building a list of precondition stating that we are not in this branch (will be used in the following recursive calls) @@ -862,8 +862,8 @@ let is_res id = let same_raw_term rt1 rt2 = - match rt1,rt2 with - | GRef(_,r1,_), GRef (_,r2,_) -> Globnames.eq_gr r1 r2 + match CAst.(rt1.v, rt2.v) with + | GRef(r1,_), GRef (r2,_) -> Globnames.eq_gr r1 r2 | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = @@ -895,16 +895,17 @@ exception Continue let rec rebuild_cons env nb_args relname args crossed_types depth rt = observe (str "rebuilding : " ++ pr_glob_constr rt); let open Context.Rel.Declaration in - match rt with - | GProd(_,n,k,t,b) -> + let open CAst in + match rt.v with + | GProd(n,k,t,b) -> let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t::crossed_types in begin match t with - | GApp(_,(GVar(_,res_id) as res_rt),args') when is_res res_id -> + | { v = GApp(({ v = GVar res_id } as res_rt),args') } when is_res res_id -> begin match args' with - | (GVar(_,this_relname))::args' -> + | { v = GVar this_relname }::args' -> (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious @@ -926,7 +927,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | _ -> (* the first args is the name of the function! *) assert false end - | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;GVar(loc3,id);rt]) + | { loc = loc1; v = GApp({ loc = loc2; v = GRef(eq_as_ref,_) },[ty; { loc = loc3; v = GVar id};rt]) } when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin @@ -963,9 +964,8 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let params,arg' = ((Util.List.chop nparam args')) in - let rt_typ = - GApp(Loc.ghost, - GRef (Loc.ghost,Globnames.IndRef (fst ind),None), + let rt_typ = CAst.make @@ + GApp(CAst.make @@ GRef (Globnames.IndRef (fst ind),None), (List.map (fun p -> Detyping.detype false [] env (Evd.from_env env) @@ -975,7 +975,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (mkGHole ())))) in let eq' = - GApp(loc1,GRef(loc2,jmeq,None),[ty;GVar(loc3,id);rt_typ;rt]) + CAst.make ?loc:loc1 @@ GApp(CAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;CAst.make ?loc:loc3 @@ GVar id;rt_typ;rt]) in observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in @@ -1044,7 +1044,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = mkGProd(n,t,new_b),id_to_exclude else new_b, Id.Set.add id id_to_exclude *) - | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;rt1;rt2]) + | { loc = loc1; v = GApp({ loc = loc2; v = GRef(eq_as_ref,_) },[ty;rt1;rt2]) } when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin @@ -1095,7 +1095,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (Id.Set.filter not_free_in_t id_to_exclude) | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude end - | GLambda(_,n,k,t,b) -> + | GLambda(n,k,t,b) -> begin let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in @@ -1114,14 +1114,14 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = then new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) else - GProd(Loc.ghost,n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude + CAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude | _ -> anomaly (Pp.str "Should not have an anonymous function here") (* We have renamed all the anonymous functions during alpha_renaming phase *) end - | GLetIn(loc,n,v,t,b) -> + | GLetIn(n,v,t,b) -> begin - let t = match t with None -> v | Some t -> GCast (loc,v,CastConv t) in + let t = match t with None -> v | Some t -> CAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in let not_free_in_t id = not (is_free_in id t) in let evd = (Evd.from_env env) in let t',ctx = Pretyping.understand env evd t in @@ -1137,10 +1137,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = match n with | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> GLetIn(Loc.ghost,n,t,None,new_b), (* HOPING IT WOULD WORK *) + | _ -> CAst.make @@ GLetIn(n,t,None,new_b), (* HOPING IT WOULD WORK *) Id.Set.filter not_free_in_t id_to_exclude end - | GLetTuple(_,nal,(na,rto),t,b) -> + | GLetTuple(nal,(na,rto),t,b) -> assert (Option.is_empty rto); begin let not_free_in_t id = not (is_free_in id t) in @@ -1163,7 +1163,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (* | Name id when Id.Set.mem id id_to_exclude -> *) (* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) (* | _ -> *) - GLetTuple(Loc.ghost,nal,(na,None),t,new_b), + CAst.make @@ GLetTuple(nal,(na,None),t,new_b), Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') end @@ -1189,16 +1189,16 @@ let rebuild_cons env nb_args relname args crossed_types rt = TODO: Find a valid way to deal with implicit arguments here! *) -let rec compute_cst_params relnames params = function +let rec compute_cst_params relnames params gt = CAst.with_val (function | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params - | GApp(_,GVar(_,relname'),rtl) when Id.Set.mem relname' relnames -> + | GApp({ CAst.v = GVar relname' },rtl) when Id.Set.mem relname' relnames -> compute_cst_params_from_app [] (params,rtl) - | GApp(_,f,args) -> + | GApp(f,args) -> List.fold_left (compute_cst_params relnames) params (f::args) - | GLambda(_,_,_,t,b) | GProd(_,_,_,t,b) | GLetTuple(_,_,_,t,b) -> + | GLambda(_,_,t,b) | GProd(_,_,t,b) | GLetTuple(_,_,t,b) -> let t_params = compute_cst_params relnames params t in compute_cst_params relnames t_params b - | GLetIn(_,_,v,t,b) -> + | GLetIn(_,v,t,b) -> let v_params = compute_cst_params relnames params v in let t_params = Option.fold_left (compute_cst_params relnames) v_params t in compute_cst_params relnames t_params b @@ -1209,10 +1209,11 @@ let rec compute_cst_params relnames params = function | GHole _ -> params | GIf _ | GRec _ | GCast _ -> raise (UserError(Some "compute_cst_params", str "Not handled case")) + ) gt and compute_cst_params_from_app acc (params,rtl) = match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,None) as param)::params',(GVar(_,id'))::rtl' + | ((Name id,_,None) as param)::params', { CAst.v = GVar id' }::rtl' when Id.compare id id' == 0 -> compute_cst_params_from_app (param::acc) (params',rtl') | _ -> List.rev acc @@ -1248,15 +1249,15 @@ let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * glob_ List.rev !l let rec rebuild_return_type rt = - match rt with - | Constrexpr.CProdN(loc,n,t') -> - Constrexpr.CProdN(loc,n,rebuild_return_type t') - | Constrexpr.CLetIn(loc,na,v,t,t') -> - Constrexpr.CLetIn(loc,na,v,t,rebuild_return_type t') - | _ -> Constrexpr.CProdN(Loc.ghost,[[Loc.ghost,Anonymous], - Constrexpr.Default Decl_kinds.Explicit,rt], - Constrexpr.CSort(Loc.ghost,GType [])) - + let loc = rt.CAst.loc in + match rt.CAst.v with + | Constrexpr.CProdN(n,t') -> + CAst.make ?loc @@ Constrexpr.CProdN(n,rebuild_return_type t') + | Constrexpr.CLetIn(na,v,t,t') -> + CAst.make ?loc @@ Constrexpr.CLetIn(na,v,t,rebuild_return_type t') + | _ -> CAst.make ?loc @@ Constrexpr.CProdN([[Loc.tag Anonymous], + Constrexpr.Default Decl_kinds.Explicit, rt], + CAst.make @@ Constrexpr.CSort(GType [])) let do_build_inductive evd (funconstants: Term.pconstant list) (funsargs: (Name.t * glob_constr * glob_constr option) list list) @@ -1307,13 +1308,12 @@ let do_build_inductive (fun (n,t,typ) acc -> match typ with | Some typ -> - Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, + CAst.make @@ Constrexpr.CLetIn((Loc.tag n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), acc) | None -> - Constrexpr.CProdN - (Loc.ghost, - [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], + CAst.make @@ Constrexpr.CProdN + ([[(Loc.tag n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], acc ) ) @@ -1375,13 +1375,12 @@ let do_build_inductive (fun (n,t,typ) acc -> match typ with | Some typ -> - Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, + CAst.make @@ Constrexpr.CLetIn((Loc.tag n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), acc) | None -> - Constrexpr.CProdN - (Loc.ghost, - [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], + CAst.make @@ Constrexpr.CProdN + ([[(Loc.tag n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], acc ) ) @@ -1408,18 +1407,18 @@ let do_build_inductive (fun (n,t,typ) -> match typ with | Some typ -> - Constrexpr.CLocalDef((Loc.ghost,n), Constrextern.extern_glob_constr Id.Set.empty t, + Constrexpr.CLocalDef((Loc.tag n), Constrextern.extern_glob_constr Id.Set.empty t, Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ)) | None -> Constrexpr.CLocalAssum - ([(Loc.ghost,n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t) + ([(Loc.tag n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t) ) rels_params in let ext_rels_constructors = Array.map (List.map (fun (id,t) -> - false,((Loc.ghost,id), + false,((Loc.tag id), with_full_print (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t)) ) @@ -1427,7 +1426,7 @@ let do_build_inductive (rel_constructors) in let rel_ind i ext_rel_constructors = - (((Loc.ghost,relnames.(i)), None), + (((Loc.tag @@ relnames.(i)), None), rel_params, Some rel_arities.(i), ext_rel_constructors),[] diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 99f50437b9..0361e8cb13 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -10,16 +10,16 @@ open Misctypes Some basic functions to rebuild glob_constr In each of them the location is Loc.ghost *) -let mkGRef ref = GRef(Loc.ghost,ref,None) -let mkGVar id = GVar(Loc.ghost,id) -let mkGApp(rt,rtl) = GApp(Loc.ghost,rt,rtl) -let mkGLambda(n,t,b) = GLambda(Loc.ghost,n,Explicit,t,b) -let mkGProd(n,t,b) = GProd(Loc.ghost,n,Explicit,t,b) -let mkGLetIn(n,b,t,c) = GLetIn(Loc.ghost,n,b,t,c) -let mkGCases(rto,l,brl) = GCases(Loc.ghost,Term.RegularStyle,rto,l,brl) -let mkGSort s = GSort(Loc.ghost,s) -let mkGHole () = GHole(Loc.ghost,Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) -let mkGCast(b,t) = GCast(Loc.ghost,b,CastConv t) +let mkGRef ref = CAst.make @@ GRef(ref,None) +let mkGVar id = CAst.make @@ GVar(id) +let mkGApp(rt,rtl) = CAst.make @@ GApp(rt,rtl) +let mkGLambda(n,t,b) = CAst.make @@ GLambda(n,Explicit,t,b) +let mkGProd(n,t,b) = CAst.make @@ GProd(n,Explicit,t,b) +let mkGLetIn(n,b,t,c) = CAst.make @@ GLetIn(n,b,t,c) +let mkGCases(rto,l,brl) = CAst.make @@ GCases(Term.RegularStyle,rto,l,brl) +let mkGSort s = CAst.make @@ GSort(s) +let mkGHole () = CAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) +let mkGCast(b,t) = CAst.make @@ GCast(b,CastConv t) (* Some basic functions to decompose glob_constrs @@ -27,7 +27,7 @@ let mkGCast(b,t) = GCast(Loc.ghost,b,CastConv t) *) let glob_decompose_prod = let rec glob_decompose_prod args = function - | GProd(_,n,k,t,b) -> + | { CAst.v = GProd(n,k,t,b) } -> glob_decompose_prod ((n,t)::args) b | rt -> args,rt in @@ -35,9 +35,9 @@ let glob_decompose_prod = let glob_decompose_prod_or_letin = let rec glob_decompose_prod args = function - | GProd(_,n,k,t,b) -> + | { CAst.v = GProd(n,k,t,b) } -> glob_decompose_prod ((n,None,Some t)::args) b - | GLetIn(_,n,b,t,c) -> + | { CAst.v = GLetIn(n,b,t,c) } -> glob_decompose_prod ((n,Some b,t)::args) c | rt -> args,rt in @@ -59,7 +59,7 @@ let glob_decompose_prod_n n = if i<=0 then args,c else match c with - | GProd(_,n,_,t,b) -> + | { CAst.v = GProd(n,_,t,b) } -> glob_decompose_prod (i-1) ((n,t)::args) b | rt -> args,rt in @@ -71,9 +71,9 @@ let glob_decompose_prod_or_letin_n n = if i<=0 then args,c else match c with - | GProd(_,n,_,t,b) -> + | { CAst.v = GProd(n,_,t,b) } -> glob_decompose_prod (i-1) ((n,None,Some t)::args) b - | GLetIn(_,n,b,t,c) -> + | { CAst.v = GLetIn(n,b,t,c) } -> glob_decompose_prod (i-1) ((n,Some b,t)::args) c | rt -> args,rt in @@ -84,7 +84,7 @@ let glob_decompose_app = let rec decompose_rapp acc rt = (* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) match rt with - | GApp(_,rt,rtl) -> + | { CAst.v = GApp(rt,rtl) } -> decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt | rt -> rt,List.rev acc in @@ -120,93 +120,89 @@ let remove_name_from_mapping mapping na = let change_vars = let rec change_vars mapping rt = - match rt with - | GRef _ -> rt - | GVar(loc,id) -> + CAst.map_with_loc (fun ?loc -> function + | GRef _ as x -> x + | GVar id -> let new_id = try Id.Map.find id mapping with Not_found -> id in - GVar(loc,new_id) - | GEvar _ -> rt - | GPatVar _ -> rt - | GApp(loc,rt',rtl) -> - GApp(loc, - change_vars mapping rt', + GVar(new_id) + | GEvar _ as x -> x + | GPatVar _ as x -> x + | GApp(rt',rtl) -> + GApp(change_vars mapping rt', List.map (change_vars mapping) rtl ) - | GLambda(loc,name,k,t,b) -> - GLambda(loc, - name, + | GLambda(name,k,t,b) -> + GLambda(name, k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) - | GProd(loc,name,k,t,b) -> - GProd(loc, - name, + | GProd(name,k,t,b) -> + GProd( name, k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) - | GLetIn(loc,name,def,typ,b) -> - GLetIn(loc, - name, + | GLetIn(name,def,typ,b) -> + GLetIn(name, change_vars mapping def, Option.map (change_vars mapping) typ, change_vars (remove_name_from_mapping mapping name) b ) - | GLetTuple(loc,nal,(na,rto),b,e) -> + | GLetTuple(nal,(na,rto),b,e) -> let new_mapping = List.fold_left remove_name_from_mapping mapping nal in - GLetTuple(loc, - nal, + GLetTuple(nal, (na, Option.map (change_vars mapping) rto), change_vars mapping b, change_vars new_mapping e ) - | GCases(loc,sty,infos,el,brl) -> - GCases(loc,sty, + | GCases(sty,infos,el,brl) -> + GCases(sty, infos, List.map (fun (e,x) -> (change_vars mapping e,x)) el, List.map (change_vars_br mapping) brl ) - | GIf(loc,b,(na,e_option),lhs,rhs) -> - GIf(loc, - change_vars mapping b, + | GIf(b,(na,e_option),lhs,rhs) -> + GIf(change_vars mapping b, (na,Option.map (change_vars mapping) e_option), change_vars mapping lhs, change_vars mapping rhs ) - | GRec _ -> error "Local (co)fixes are not supported" - | GSort _ -> rt - | GHole _ -> rt - | GCast(loc,b,c) -> - GCast(loc,change_vars mapping b, + | GRec _ -> user_err ?loc Pp.(str "Local (co)fixes are not supported") + | GSort _ as x -> x + | GHole _ as x -> x + | GCast(b,c) -> + GCast(change_vars mapping b, Miscops.map_cast_type (change_vars mapping) c) - and change_vars_br mapping ((loc,idl,patl,res) as br) = + ) rt + and change_vars_br mapping ((loc,(idl,patl,res)) as br) = let new_mapping = List.fold_right Id.Map.remove idl mapping in if Id.Map.is_empty new_mapping then br - else (loc,idl,patl,change_vars new_mapping res) + else (loc,(idl,patl,change_vars new_mapping res)) in change_vars let rec alpha_pat excluded pat = - match pat with - | PatVar(loc,Anonymous) -> + let loc = pat.CAst.loc in + match pat.CAst.v with + | PatVar Anonymous -> let new_id = Indfun_common.fresh_id excluded "_x" in - PatVar(loc,Name new_id),(new_id::excluded),Id.Map.empty - | PatVar(loc,Name id) -> + (CAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty + | PatVar(Name id) -> if Id.List.mem id excluded then let new_id = Namegen.next_ident_away id excluded in - PatVar(loc,Name new_id),(new_id::excluded), + (CAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded), (Id.Map.add id new_id Id.Map.empty) - else pat,excluded,Id.Map.empty - | PatCstr(loc,constr,patl,na) -> + else pat, excluded,Id.Map.empty + | PatCstr(constr,patl,na) -> let new_na,new_excluded,map = match na with | Name id when Id.List.mem id excluded -> @@ -223,7 +219,7 @@ let rec alpha_pat excluded pat = ([],new_excluded,map) patl in - PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map + (CAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map let alpha_patl excluded patl = let patl,new_excluded,map = @@ -242,11 +238,11 @@ let alpha_patl excluded patl = let raw_get_pattern_id pat acc = let rec get_pattern_id pat = - match pat with - | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> + match pat.CAst.v with + | PatVar(Anonymous) -> assert false + | PatVar(Name id) -> [id] - | PatCstr(loc,constr,patternl,_) -> + | PatCstr(constr,patternl,_) -> List.fold_right (fun pat idl -> let idl' = get_pattern_id pat in @@ -260,29 +256,30 @@ let raw_get_pattern_id pat acc = let get_pattern_id pat = raw_get_pattern_id pat [] let rec alpha_rt excluded rt = - let new_rt = - match rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ -> rt - | GLambda(loc,Anonymous,k,t,b) -> + let loc = rt.CAst.loc in + let new_rt = CAst.make ?loc @@ + match rt.CAst.v with + | GRef _ | GVar _ | GEvar _ | GPatVar _ as rt -> rt + | GLambda(Anonymous,k,t,b) -> let new_id = Namegen.next_ident_away (Id.of_string "_x") excluded in let new_excluded = new_id :: excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - GLambda(loc,Name new_id,k,new_t,new_b) - | GProd(loc,Anonymous,k,t,b) -> + GLambda(Name new_id,k,new_t,new_b) + | GProd(Anonymous,k,t,b) -> let new_t = alpha_rt excluded t in let new_b = alpha_rt excluded b in - GProd(loc,Anonymous,k,new_t,new_b) - | GLetIn(loc,Anonymous,b,t,c) -> + GProd(Anonymous,k,new_t,new_b) + | GLetIn(Anonymous,b,t,c) -> let new_b = alpha_rt excluded b in let new_t = Option.map (alpha_rt excluded) t in let new_c = alpha_rt excluded c in - GLetIn(loc,Anonymous,new_b,new_t,new_c) - | GLambda(loc,Name id,k,t,b) -> + GLetIn(Anonymous,new_b,new_t,new_c) + | GLambda(Name id,k,t,b) -> let new_id = Namegen.next_ident_away id excluded in let t,b = if Id.equal new_id id - then t,b + then t, b else let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) @@ -290,8 +287,8 @@ let rec alpha_rt excluded rt = let new_excluded = new_id::excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - GLambda(loc,Name new_id,k,new_t,new_b) - | GProd(loc,Name id,k,t,b) -> + GLambda(Name new_id,k,new_t,new_b) + | GProd(Name id,k,t,b) -> let new_id = Namegen.next_ident_away id excluded in let new_excluded = new_id::excluded in let t,b = @@ -303,8 +300,8 @@ let rec alpha_rt excluded rt = in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - GProd(loc,Name new_id,k,new_t,new_b) - | GLetIn(loc,Name id,b,t,c) -> + GProd(Name new_id,k,new_t,new_b) + | GLetIn(Name id,b,t,c) -> let new_id = Namegen.next_ident_away id excluded in let c = if Id.equal new_id id then c @@ -314,10 +311,9 @@ let rec alpha_rt excluded rt = let new_b = alpha_rt new_excluded b in let new_t = Option.map (alpha_rt new_excluded) t in let new_c = alpha_rt new_excluded c in - GLetIn(loc,Name new_id,new_b,new_t,new_c) - + GLetIn(Name new_id,new_b,new_t,new_c) - | GLetTuple(loc,nal,(na,rto),t,b) -> + | GLetTuple(nal,(na,rto),t,b) -> let rev_new_nal,new_excluded,mapping = List.fold_left (fun (nal,excluded,mapping) na -> @@ -344,92 +340,92 @@ let rec alpha_rt excluded rt = let new_t = alpha_rt new_excluded new_t in let new_b = alpha_rt new_excluded new_b in let new_rto = Option.map (alpha_rt new_excluded) new_rto in - GLetTuple(loc,new_nal,(na,new_rto),new_t,new_b) - | GCases(loc,sty,infos,el,brl) -> + GLetTuple(new_nal,(na,new_rto),new_t,new_b) + | GCases(sty,infos,el,brl) -> let new_el = List.map (function (rt,i) -> alpha_rt excluded rt, i) el in - GCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) - | GIf(loc,b,(na,e_o),lhs,rhs) -> - GIf(loc,alpha_rt excluded b, + GCases(sty,infos,new_el,List.map (alpha_br excluded) brl) + | GIf(b,(na,e_o),lhs,rhs) -> + GIf(alpha_rt excluded b, (na,Option.map (alpha_rt excluded) e_o), alpha_rt excluded lhs, alpha_rt excluded rhs ) - | GRec _ -> error "Not handled GRec" - | GSort _ -> rt - | GHole _ -> rt - | GCast (loc,b,c) -> - GCast(loc,alpha_rt excluded b, + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GSort _ + | GHole _ as rt -> rt + | GCast (b,c) -> + GCast(alpha_rt excluded b, Miscops.map_cast_type (alpha_rt excluded) c) - | GApp(loc,f,args) -> - GApp(loc, - alpha_rt excluded f, + | GApp(f,args) -> + GApp(alpha_rt excluded f, List.map (alpha_rt excluded) args ) in new_rt -and alpha_br excluded (loc,ids,patl,res) = +and alpha_br excluded (loc,(ids,patl,res)) = let new_patl,new_excluded,mapping = alpha_patl excluded patl in let new_ids = List.fold_right raw_get_pattern_id new_patl [] in let new_excluded = new_ids@excluded in let renamed_res = change_vars mapping res in let new_res = alpha_rt new_excluded renamed_res in - (loc,new_ids,new_patl,new_res) + (loc,(new_ids,new_patl,new_res)) (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) let is_free_in id = - let rec is_free_in = function + let rec is_free_in x = CAst.with_loc_val (fun ?loc -> function | GRef _ -> false - | GVar(_,id') -> Id.compare id' id == 0 + | GVar id' -> Id.compare id' id == 0 | GEvar _ -> false | GPatVar _ -> false - | GApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl) - | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) -> + | GApp(rt,rtl) -> List.exists is_free_in (rt::rtl) + | GLambda(n,_,t,b) | GProd(n,_,t,b) -> let check_in_b = match n with | Name id' -> not (Id.equal id' id) | _ -> true in is_free_in t || (check_in_b && is_free_in b) - | GLetIn(_,n,b,t,c) -> + | GLetIn(n,b,t,c) -> let check_in_c = match n with | Name id' -> not (Id.equal id' id) | _ -> true in is_free_in b || Option.cata is_free_in true t || (check_in_c && is_free_in c) - | GCases(_,_,_,el,brl) -> + | GCases(_,_,el,brl) -> (List.exists (fun (e,_) -> is_free_in e) el) || List.exists is_free_in_br brl - | GLetTuple(_,nal,_,b,t) -> + | GLetTuple(nal,_,b,t) -> let check_in_nal = not (List.exists (function Name id' -> Id.equal id' id | _ -> false) nal) in is_free_in t || (check_in_nal && is_free_in b) - | GIf(_,cond,_,br1,br2) -> + | GIf(cond,_,br1,br2) -> is_free_in cond || is_free_in br1 || is_free_in br2 - | GRec _ -> raise (UserError(None,str "Not handled GRec")) + | GRec _ -> user_err Pp.(str "Not handled GRec") | GSort _ -> false | GHole _ -> false - | GCast (_,b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t - | GCast (_,b,CastCoerce) -> is_free_in b - and is_free_in_br (_,ids,_,rt) = + | GCast (b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t + | GCast (b,CastCoerce) -> is_free_in b + ) x + and is_free_in_br (_,(ids,_,rt)) = (not (Id.List.mem id ids)) && is_free_in rt in is_free_in -let rec pattern_to_term = function - | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> +let rec pattern_to_term pt = CAst.with_val (function + | PatVar Anonymous -> assert false + | PatVar(Name id) -> mkGVar id - | PatCstr(loc,constr,patternl,_) -> + | PatCstr(constr,patternl,_) -> let cst_narg = Inductiveops.constructor_nallargs_env (Global.env ()) @@ -448,78 +444,73 @@ let rec pattern_to_term = function mkGApp(mkGRef(Globnames.ConstructRef constr), implicit_args@patl_as_term ) - + ) pt let replace_var_by_term x_id term = - let rec replace_var_by_pattern rt = - match rt with - | GRef _ -> rt - | GVar(_,id) when Id.compare id x_id == 0 -> term - | GVar _ -> rt - | GEvar _ -> rt - | GPatVar _ -> rt - | GApp(loc,rt',rtl) -> - GApp(loc, - replace_var_by_pattern rt', + let rec replace_var_by_pattern x = CAst.map (function + | GVar id when Id.compare id x_id == 0 -> term.CAst.v + | GRef _ + | GVar _ + | GEvar _ + | GPatVar _ as rt -> rt + | GApp(rt',rtl) -> + GApp(replace_var_by_pattern rt', List.map replace_var_by_pattern rtl ) - | GLambda(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt - | GLambda(loc,name,k,t,b) -> - GLambda(loc, - name, + | GLambda(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt + | GLambda(name,k,t,b) -> + GLambda(name, k, replace_var_by_pattern t, replace_var_by_pattern b ) - | GProd(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt - | GProd(loc,name,k,t,b) -> - GProd(loc, - name, + | GProd(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt + | GProd(name,k,t,b) -> + GProd( name, k, replace_var_by_pattern t, replace_var_by_pattern b ) - | GLetIn(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt - | GLetIn(loc,name,def,typ,b) -> - GLetIn(loc, - name, + | GLetIn(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt + | GLetIn(name,def,typ,b) -> + GLetIn(name, replace_var_by_pattern def, Option.map (replace_var_by_pattern) typ, replace_var_by_pattern b ) - | GLetTuple(_,nal,_,_,_) + | GLetTuple(nal,_,_,_) as rt when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal -> rt - | GLetTuple(loc,nal,(na,rto),def,b) -> - GLetTuple(loc, - nal, + | GLetTuple(nal,(na,rto),def,b) -> + GLetTuple(nal, (na,Option.map replace_var_by_pattern rto), replace_var_by_pattern def, replace_var_by_pattern b ) - | GCases(loc,sty,infos,el,brl) -> - GCases(loc,sty, + | GCases(sty,infos,el,brl) -> + GCases(sty, infos, List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, List.map replace_var_by_pattern_br brl ) - | GIf(loc,b,(na,e_option),lhs,rhs) -> - GIf(loc, replace_var_by_pattern b, + | GIf(b,(na,e_option),lhs,rhs) -> + GIf(replace_var_by_pattern b, (na,Option.map replace_var_by_pattern e_option), replace_var_by_pattern lhs, replace_var_by_pattern rhs ) | GRec _ -> raise (UserError(None,str "Not handled GRec")) - | GSort _ -> rt - | GHole _ -> rt - | GCast(loc,b,c) -> - GCast(loc,replace_var_by_pattern b, + | GSort _ + | GHole _ as rt -> rt + | GCast(b,c) -> + GCast(replace_var_by_pattern b, Miscops.map_cast_type replace_var_by_pattern c) - and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = + ) x + and replace_var_by_pattern_br ((loc,(idl,patl,res)) as br) = if List.exists (fun id -> Id.compare id x_id == 0) idl then br - else (loc,idl,patl,replace_var_by_pattern res) + else (loc,(idl,patl,replace_var_by_pattern res)) in replace_var_by_pattern @@ -532,9 +523,10 @@ exception NotUnifiable let rec are_unifiable_aux = function | [] -> () | eq::eqs -> + let open CAst in match eq with - | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs - | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> + | { v = PatVar _ },_ | _, { v = PatVar _ } -> are_unifiable_aux eqs + | { v = PatCstr(constructor1,cpl1,_) }, { v = PatCstr(constructor2,cpl2,_) } -> if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else @@ -554,9 +546,10 @@ let are_unifiable pat1 pat2 = let rec eq_cases_pattern_aux = function | [] -> () | eq::eqs -> + let open CAst in match eq with - | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs - | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> + | { v = PatVar _ }, { v = PatVar _ } -> eq_cases_pattern_aux eqs + | { v = PatCstr(constructor1,cpl1,_) }, { v = PatCstr(constructor2,cpl2,_) } -> if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else @@ -576,10 +569,11 @@ let eq_cases_pattern pat1 pat2 = let ids_of_pat = - let rec ids_of_pat ids = function - | PatVar(_,Anonymous) -> ids - | PatVar(_,Name id) -> Id.Set.add id ids - | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl + let rec ids_of_pat ids = CAst.with_val (function + | PatVar Anonymous -> ids + | PatVar(Name id) -> Id.Set.add id ids + | PatCstr(_,patl,_) -> List.fold_left ids_of_pat ids patl + ) in ids_of_pat Id.Set.empty @@ -589,22 +583,22 @@ let id_of_name = function (* TODO: finish Rec caes *) let ids_of_glob_constr c = - let rec ids_of_glob_constr acc c = + let rec ids_of_glob_constr acc {loc; CAst.v = c} = let idof = id_of_name in match c with - | GVar (_,id) -> id::acc - | GApp (loc,g,args) -> + | GVar id -> id::acc + | GApp (g,args) -> ids_of_glob_constr [] g @ List.flatten (List.map (ids_of_glob_constr []) args) @ acc - | GLambda (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc - | GProd (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc - | GLetIn (loc,na,b,t,c) -> idof na :: ids_of_glob_constr [] b @ Option.cata (ids_of_glob_constr []) [] t @ ids_of_glob_constr [] c @ acc - | GCast (loc,c,(CastConv t|CastVM t|CastNative t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc - | GCast (loc,c,CastCoerce) -> ids_of_glob_constr [] c @ acc - | GIf (loc,c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc - | GLetTuple (_,nal,(na,po),b,c) -> + | GLambda (na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc + | GProd (na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc + | GLetIn (na,b,t,c) -> idof na :: ids_of_glob_constr [] b @ Option.cata (ids_of_glob_constr []) [] t @ ids_of_glob_constr [] c @ acc + | GCast (c,(CastConv t|CastVM t|CastNative t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc + | GCast (c,CastCoerce) -> ids_of_glob_constr [] c @ acc + | GIf (c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc + | GLetTuple (nal,(na,po),b,c) -> List.map idof nal @ ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc - | GCases (loc,sty,rtntypopt,tml,brchl) -> - List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_glob_constr [] c) brchl) + | GCases (sty,rtntypopt,tml,brchl) -> + List.flatten (List.map (fun (_,(idl,patl,c)) -> idl @ ids_of_glob_constr [] c) brchl) | GRec _ -> failwith "Fix inside a constructor branch" | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> [] in @@ -616,61 +610,58 @@ let ids_of_glob_constr c = let zeta_normalize = - let rec zeta_normalize_term rt = - match rt with - | GRef _ -> rt - | GVar _ -> rt - | GEvar _ -> rt - | GPatVar _ -> rt - | GApp(loc,rt',rtl) -> - GApp(loc, - zeta_normalize_term rt', + let rec zeta_normalize_term x = CAst.map (function + | GRef _ + | GVar _ + | GEvar _ + | GPatVar _ as rt -> rt + | GApp(rt',rtl) -> + GApp(zeta_normalize_term rt', List.map zeta_normalize_term rtl ) - | GLambda(loc,name,k,t,b) -> - GLambda(loc, - name, + | GLambda(name,k,t,b) -> + GLambda(name, k, zeta_normalize_term t, zeta_normalize_term b ) - | GProd(loc,name,k,t,b) -> - GProd(loc, - name, + | GProd(name,k,t,b) -> + GProd(name, k, zeta_normalize_term t, zeta_normalize_term b ) - | GLetIn(_,Name id,def,typ,b) -> - zeta_normalize_term (replace_var_by_term id def b) - | GLetIn(loc,Anonymous,def,typ,b) -> zeta_normalize_term b - | GLetTuple(loc,nal,(na,rto),def,b) -> - GLetTuple(loc, - nal, + | GLetIn(Name id,def,typ,b) -> + (zeta_normalize_term (replace_var_by_term id def b)).CAst.v + | GLetIn(Anonymous,def,typ,b) -> + (zeta_normalize_term b).CAst.v + | GLetTuple(nal,(na,rto),def,b) -> + GLetTuple(nal, (na,Option.map zeta_normalize_term rto), zeta_normalize_term def, zeta_normalize_term b ) - | GCases(loc,sty,infos,el,brl) -> - GCases(loc,sty, + | GCases(sty,infos,el,brl) -> + GCases(sty, infos, List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, List.map zeta_normalize_br brl ) - | GIf(loc,b,(na,e_option),lhs,rhs) -> - GIf(loc, zeta_normalize_term b, + | GIf(b,(na,e_option),lhs,rhs) -> + GIf(zeta_normalize_term b, (na,Option.map zeta_normalize_term e_option), zeta_normalize_term lhs, zeta_normalize_term rhs ) | GRec _ -> raise (UserError(None,str "Not handled GRec")) - | GSort _ -> rt - | GHole _ -> rt - | GCast(loc,b,c) -> - GCast(loc,zeta_normalize_term b, + | GSort _ + | GHole _ as rt -> rt + | GCast(b,c) -> + GCast(zeta_normalize_term b, Miscops.map_cast_type zeta_normalize_term c) - and zeta_normalize_br (loc,idl,patl,res) = - (loc,idl,patl,zeta_normalize_term res) + ) x + and zeta_normalize_br (loc,(idl,patl,res)) = + (loc,(idl,patl,zeta_normalize_term res)) in zeta_normalize_term @@ -679,40 +670,40 @@ let zeta_normalize = let expand_as = - let rec add_as map pat = + let rec add_as map ({loc; CAst.v = pat } as rt) = match pat with | PatVar _ -> map - | PatCstr(_,_,patl,Name id) -> - Id.Map.add id (pattern_to_term pat) (List.fold_left add_as map patl) - | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl + | PatCstr(_,patl,Name id) -> + Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) + | PatCstr(_,patl,_) -> List.fold_left add_as map patl in - let rec expand_as map rt = - match rt with - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> rt - | GVar(_,id) -> + let rec expand_as map = CAst.map (function + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ as rt -> rt + | GVar id as rt -> begin try - Id.Map.find id map + (Id.Map.find id map).CAst.v with Not_found -> rt end - | GApp(loc,f,args) -> GApp(loc,expand_as map f,List.map (expand_as map) args) - | GLambda(loc,na,k,t,b) -> GLambda(loc,na,k,expand_as map t, expand_as map b) - | GProd(loc,na,k,t,b) -> GProd(loc,na,k,expand_as map t, expand_as map b) - | GLetIn(loc,na,v,typ,b) -> GLetIn(loc,na, expand_as map v,Option.map (expand_as map) typ,expand_as map b) - | GLetTuple(loc,nal,(na,po),v,b) -> - GLetTuple(loc,nal,(na,Option.map (expand_as map) po), + | GApp(f,args) -> GApp(expand_as map f,List.map (expand_as map) args) + | GLambda(na,k,t,b) -> GLambda(na,k,expand_as map t, expand_as map b) + | GProd(na,k,t,b) -> GProd(na,k,expand_as map t, expand_as map b) + | GLetIn(na,v,typ,b) -> GLetIn(na, expand_as map v,Option.map (expand_as map) typ,expand_as map b) + | GLetTuple(nal,(na,po),v,b) -> + GLetTuple(nal,(na,Option.map (expand_as map) po), expand_as map v, expand_as map b) - | GIf(loc,e,(na,po),br1,br2) -> - GIf(loc,expand_as map e,(na,Option.map (expand_as map) po), + | GIf(e,(na,po),br1,br2) -> + GIf(expand_as map e,(na,Option.map (expand_as map) po), expand_as map br1, expand_as map br2) - | GRec _ -> error "Not handled GRec" - | GCast(loc,b,c) -> - GCast(loc,expand_as map b, + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GCast(b,c) -> + GCast(expand_as map b, Miscops.map_cast_type (expand_as map) c) - | GCases(loc,sty,po,el,brl) -> - GCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, + | GCases(sty,po,el,brl) -> + GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, List.map (expand_as_br map) brl) - and expand_as_br map (loc,idl,cpl,rt) = - (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) + ) + and expand_as_br map (loc,(idl,cpl,rt)) = + (loc,(idl,cpl, expand_as (List.fold_left add_as map cpl) rt)) in expand_as Id.Map.empty diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 84359a36b7..25d79582f3 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -82,11 +82,8 @@ val alpha_rt : Id.t list -> glob_constr -> glob_constr (* same as alpha_rt but for case branches *) val alpha_br : Id.t list -> - Loc.t * Id.t list * Glob_term.cases_pattern list * - Glob_term.glob_constr -> - Loc.t * Id.t list * Glob_term.cases_pattern list * - Glob_term.glob_constr - + Glob_term.cases_clause -> + Glob_term.cases_clause (* Reduction function *) val replace_var_by_term : diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index d335836dfc..4946285e16 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -156,7 +156,7 @@ let build_newrecursive let (rec_sign,rec_impls) = List.fold_left (fun (env,impls) (((_,recname),_),bl,arityc,_) -> - let arityc = Constrexpr_ops.mkCProdN Loc.ghost bl arityc in + let arityc = Constrexpr_ops.mkCProdN bl arityc in let arity,ctx = Constrintern.interp_type env0 sigma arityc in let evdref = ref (Evd.from_env env0) in let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in @@ -186,34 +186,36 @@ let build_newrecursive l = in build_newrecursive l' +let error msg = user_err Pp.(str msg) + (* Checks whether or not the mutual bloc is recursive *) let is_rec names = let names = List.fold_right Id.Set.add names Id.Set.empty in let check_id id names = Id.Set.mem id names in - let rec lookup names = function - | GVar(_,id) -> check_id id names + let rec lookup names gt = match gt.CAst.v with + | GVar(id) -> check_id id names | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> false - | GCast(_,b,_) -> lookup names b + | GCast(b,_) -> lookup names b | GRec _ -> error "GRec not handled" - | GIf(_,b,_,lhs,rhs) -> + | GIf(b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) - | GProd(_,na,_,t,b) | GLambda(_,na,_,t,b) -> - lookup names t || lookup (Nameops.name_fold Id.Set.remove na names) b - | GLetIn(_,na,b,t,c) -> - lookup names b || Option.cata (lookup names) true t || lookup (Nameops.name_fold Id.Set.remove na names) c - | GLetTuple(_,nal,_,t,b) -> lookup names t || + | GProd(na,_,t,b) | GLambda(na,_,t,b) -> + lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b + | GLetIn(na,b,t,c) -> + lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c + | GLetTuple(nal,_,t,b) -> lookup names t || lookup (List.fold_left - (fun acc na -> Nameops.name_fold Id.Set.remove na acc) + (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) names nal ) b - | GApp(_,f,args) -> List.exists (lookup names) (f::args) - | GCases(_,_,_,el,brl) -> + | GApp(f,args) -> List.exists (lookup names) (f::args) + | GCases(_,_,el,brl) -> List.exists (fun (e,_) -> lookup names e) el || List.exists (lookup_br names) brl - and lookup_br names (_,idl,_,rt) = + and lookup_br names (_,(idl,_,rt)) = let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt in @@ -355,7 +357,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error (*i The next call to mk_rel_id is valid since we have just construct the graph Ensures by : do_built i*) - let f_R_mut = Ident (Loc.ghost,mk_rel_id (List.nth names 0)) in + let f_R_mut = Ident (Loc.tag @@ mk_rel_id (List.nth names 0)) in let ind_kn = fst (locate_with_msg (pr_reference f_R_mut++str ": Not an inductive type!") @@ -453,7 +455,7 @@ let generate_correction_proof_wf f_ref tcc_lemma_ref let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body pre_hook = - let type_of_f = Constrexpr_ops.mkCProdN Loc.ghost args ret_type in + let type_of_f = Constrexpr_ops.mkCProdN args ret_type in let rec_arg_num = let names = List.map @@ -469,9 +471,8 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas in let unbounded_eq = let f_app_args = - Constrexpr.CAppExpl - (Loc.ghost, - (None,(Ident (Loc.ghost,fname)),None) , + CAst.make @@ Constrexpr.CAppExpl( + (None,(Ident (Loc.tag fname)),None) , (List.map (function | _,Anonymous -> assert false @@ -481,10 +482,10 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas ) ) in - Constrexpr.CApp (Loc.ghost,(None,Constrexpr_ops.mkRefC (Qualid (Loc.ghost,(qualid_of_string "Logic.eq")))), + CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (Qualid (Loc.tag (qualid_of_string "Logic.eq")))), [(f_app_args,None);(body,None)]) in - let eq = Constrexpr_ops.mkCProdN Loc.ghost args unbounded_eq in + let eq = Constrexpr_ops.mkCProdN args unbounded_eq in let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type nb_args relation = try @@ -538,13 +539,13 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas | None -> let ltof = let make_dir l = DirPath.make (List.rev_map Id.of_string l) in - Libnames.Qualid (Loc.ghost,Libnames.qualid_of_path + Libnames.Qualid (Loc.tag @@ Libnames.qualid_of_path (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof"))) in let fun_from_mes = let applied_mes = Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in - Constrexpr_ops.mkLambdaC ([(Loc.ghost,Name wf_arg)],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) + Constrexpr_ops.mkLambdaC ([(Loc.tag @@ Name wf_arg)],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) in let wf_rel_from_mes = Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) @@ -555,7 +556,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas let a = Names.Id.of_string "___a" in let b = Names.Id.of_string "___b" in Constrexpr_ops.mkLambdaC( - [Loc.ghost,Name a;Loc.ghost,Name b], + [Loc.tag @@ Name a;Loc.tag @@ Name b], Constrexpr.Default Explicit, wf_arg_type, Constrexpr_ops.mkAppC(wf_rel_expr, @@ -589,15 +590,15 @@ let rec rebuild_bl (aux,assoc) bl typ = | [], _ -> (List.rev aux,replace_vars_constr_expr assoc typ,assoc) | (Constrexpr.CLocalAssum(nal,bk,_))::bl',typ -> rebuild_nal (aux,assoc) bk bl' nal (List.length nal) typ - | (Constrexpr.CLocalDef(na,_,_))::bl',Constrexpr.CLetIn(_,_,nat,ty,typ') -> + | (Constrexpr.CLocalDef(na,_,_))::bl',{ CAst.v = Constrexpr.CLetIn(_,nat,ty,typ') } -> rebuild_bl ((Constrexpr.CLocalDef(na,replace_vars_constr_expr assoc nat,Option.map (replace_vars_constr_expr assoc) ty (* ??? *))::aux),assoc) bl' typ' | _ -> assert false and rebuild_nal (aux,assoc) bk bl' nal lnal typ = - match nal,typ with + match nal, typ.CAst.v with | [], _ -> rebuild_bl (aux,assoc) bl' typ - | _,CProdN(_,[],typ) -> rebuild_nal (aux,assoc) bk bl' nal lnal typ - | _,CProdN(_,(nal',bk',nal't)::rest,typ') -> + | _,CProdN([],typ) -> rebuild_nal (aux,assoc) bk bl' nal lnal typ + | _,CProdN((nal',bk',nal't)::rest,typ') -> let lnal' = List.length nal' in if lnal' >= lnal then @@ -607,15 +608,15 @@ let rec rebuild_bl (aux,assoc) bl typ = rebuild_bl ((assum :: aux), nassoc) bl' (if List.is_empty new_nal' && List.is_empty rest then typ' - else if List.is_empty new_nal' - then CProdN(Loc.ghost,rest,typ') - else CProdN(Loc.ghost,((new_nal',bk',nal't)::rest),typ')) + else CAst.make @@ if List.is_empty new_nal' + then CProdN(rest,typ') + else CProdN(((new_nal',bk',nal't)::rest),typ')) else let captured_nal,non_captured_nal = List.chop lnal' nal in let nassoc = make_assoc assoc nal' captured_nal in let assum = CLocalAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't) in rebuild_nal ((assum :: aux), nassoc) - bk bl' non_captured_nal (lnal - lnal') (CProdN(Loc.ghost,rest,typ')) + bk bl' non_captured_nal (lnal - lnal') (CAst.make @@ CProdN(rest,typ')) | _ -> assert false let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ @@ -726,67 +727,65 @@ let do_generate_principle pconstants on_error register_built interactive_proof in () -let rec add_args id new_args b = - match b with - | CRef (r,_) -> - begin match r with +let rec add_args id new_args = CAst.map (function + | CRef (r,_) as b -> + begin match r with | Libnames.Ident(loc,fname) when Id.equal fname id -> - CAppExpl(Loc.ghost,(None,r,None),new_args) + CAppExpl((None,r,None),new_args) | _ -> b end | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo") - | CProdN(loc,nal,b1) -> - CProdN(loc, - List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, + | CProdN(nal,b1) -> + CProdN(List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, add_args id new_args b1) - | CLambdaN(loc,nal,b1) -> - CLambdaN(loc, - List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, + | CLambdaN(nal,b1) -> + CLambdaN(List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, add_args id new_args b1) - | CLetIn(loc,na,b1,t,b2) -> - CLetIn(loc,na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) - | CAppExpl(loc,(pf,r,us),exprl) -> + | CLetIn(na,b1,t,b2) -> + CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) + | CAppExpl((pf,r,us),exprl) -> begin match r with | Libnames.Ident(loc,fname) when Id.equal fname id -> - CAppExpl(loc,(pf,r,us),new_args@(List.map (add_args id new_args) exprl)) - | _ -> CAppExpl(loc,(pf,r,us),List.map (add_args id new_args) exprl) + CAppExpl((pf,r,us),new_args@(List.map (add_args id new_args) exprl)) + | _ -> CAppExpl((pf,r,us),List.map (add_args id new_args) exprl) end - | CApp(loc,(pf,b),bl) -> - CApp(loc,(pf,add_args id new_args b), + | CApp((pf,b),bl) -> + CApp((pf,add_args id new_args b), List.map (fun (e,o) -> add_args id new_args e,o) bl) - | CCases(loc,sty,b_option,cel,cal) -> - CCases(loc,sty,Option.map (add_args id new_args) b_option, + | CCases(sty,b_option,cel,cal) -> + CCases(sty,Option.map (add_args id new_args) b_option, List.map (fun (b,na,b_option) -> add_args id new_args b, na, b_option) cel, - List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal + List.map (fun (loc,(cpl,e)) -> Loc.tag ?loc @@ (cpl,add_args id new_args e)) cal ) - | CLetTuple(loc,nal,(na,b_option),b1,b2) -> - CLetTuple(loc,nal,(na,Option.map (add_args id new_args) b_option), + | CLetTuple(nal,(na,b_option),b1,b2) -> + CLetTuple(nal,(na,Option.map (add_args id new_args) b_option), add_args id new_args b1, add_args id new_args b2 ) - | CIf(loc,b1,(na,b_option),b2,b3) -> - CIf(loc,add_args id new_args b1, + | CIf(b1,(na,b_option),b2,b3) -> + CIf(add_args id new_args b1, (na,Option.map (add_args id new_args) b_option), add_args id new_args b2, add_args id new_args b3 ) - | CHole _ -> b - | CPatVar _ -> b - | CEvar _ -> b - | CSort _ -> b - | CCast(loc,b1,b2) -> - CCast(loc,add_args id new_args b1, + | CHole _ + | CPatVar _ + | CEvar _ + | CPrim _ + | CSort _ as b -> b + | CCast(b1,b2) -> + CCast(add_args id new_args b1, Miscops.map_cast_type (add_args id new_args) b2) - | CRecord (loc, pars) -> - CRecord (loc, List.map (fun (e,o) -> e, add_args id new_args o) pars) + | CRecord pars -> + CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars) | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation") | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization") - | CPrim _ -> b | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters") + ) exception Stop of Constrexpr.constr_expr @@ -797,8 +796,8 @@ let rec chop_n_arrow n t = if n <= 0 then t (* If we have already removed all the arrows then return the type *) else (* If not we check the form of [t] *) - match t with - | Constrexpr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : + match t.CAst.v with + | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, to result are possible : either we need to discard more than the number of arrows contained in this product declaration then we just recall [chop_n_arrow] on the remaining number of arrow to chop and [t'] we discard it and @@ -816,8 +815,8 @@ let rec chop_n_arrow n t = then aux (n - nal_l) nal_ta' else - let new_t' = - Constrexpr.CProdN(Loc.ghost, + let new_t' = CAst.make @@ + Constrexpr.CProdN( ((snd (List.chop n nal)),k,t'')::nal_ta',t') in raise (Stop new_t') @@ -832,8 +831,8 @@ let rec chop_n_arrow n t = let rec get_args b t : Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr = - match b with - | Constrexpr.CLambdaN (loc, (nal_ta), b') -> + match b.CAst.v with + | Constrexpr.CLambdaN ((nal_ta), b') -> begin let n = (List.fold_left (fun n (nal,_,_) -> @@ -872,8 +871,8 @@ let make_graph (f_ref:global_reference) = in let (nal_tas,b,t) = get_args extern_body extern_type in let expr_list = - match b with - | Constrexpr.CFix(loc,l_id,fixexprl) -> + match b.CAst.v with + | Constrexpr.CFix(l_id,fixexprl) -> let l = List.map (fun (id,(n,recexp),bl,t,b) -> @@ -885,8 +884,8 @@ let make_graph (f_ref:global_reference) = | Constrexpr.CLocalDef (na,_,_)-> [] | Constrexpr.CLocalAssum (nal,_,_) -> List.map - (fun (loc,n) -> - CRef(Libnames.Ident(loc, Nameops.out_name n),None)) + (fun (loc,n) -> CAst.make ?loc @@ + CRef(Libnames.Ident(loc, Nameops.Name.get_id n),None)) nal | Constrexpr.CLocalPattern _ -> assert false ) @@ -894,14 +893,14 @@ let make_graph (f_ref:global_reference) = ) in let b' = add_args (snd id) new_args b in - ((((id,None), ( Some (Loc.ghost,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + ((((id,None), ( Some (Loc.tag rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixexprl in l | _ -> let id = Label.to_id (con_label c) in - [(((Loc.ghost,id),None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] + [(((Loc.tag id),None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] in let mp,dp,_ = repr_con c in do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list; diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 848b44a603..2476478abe 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -66,9 +66,9 @@ let chop_rlambda_n = if n == 0 then List.rev acc,rt else - match rt with - | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b - | Glob_term.GLetIn(_,name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b + match rt.CAst.v with + | Glob_term.GLambda(name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b + | Glob_term.GLetIn(name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b | _ -> raise (CErrors.UserError(Some "chop_rlambda_n", str "chop_rlambda_n: Not enough Lambdas")) @@ -80,8 +80,8 @@ let chop_rprod_n = if n == 0 then List.rev acc,rt else - match rt with - | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b + match rt.CAst.v with + | Glob_term.GProd(name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b | _ -> raise (CErrors.UserError(Some "chop_rprod_n",str "chop_rprod_n: Not enough products")) in chop_prod_n [] @@ -103,7 +103,7 @@ let list_add_set_eq eq_fun x l = let const_of_id id = let _,princ_ref = - qualid_of_reference (Libnames.Ident (Loc.ghost,id)) + qualid_of_reference (Libnames.Ident (Loc.tag id)) in try Constrintern.locate_reference princ_ref with Not_found -> @@ -120,7 +120,8 @@ let def_of_const t = |_ -> assert false let coq_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" + Universes.constr_of_global @@ + Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s;; let find_reference sl s = @@ -422,7 +423,6 @@ open Goptions let functional_induction_rewrite_dependent_proofs_sig = { - optsync = false; optdepr = false; optname = "Functional Induction Rewrite Dependent"; optkey = ["Functional";"Induction";"Rewrite";"Dependent"]; @@ -435,7 +435,6 @@ let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = t let function_debug_sig = { - optsync = false; optdepr = false; optname = "Function debug"; optkey = ["Function_debug"]; @@ -454,7 +453,6 @@ let strict_tcc = ref false let is_strict_tcc () = !strict_tcc let strict_tcc_sig = { - optsync = false; optdepr = false; optname = "Raw Function Tcc"; optkey = ["Function_raw_tcc"]; @@ -472,13 +470,17 @@ exception ToShow of exn let jmeq () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - EConstr.of_constr (Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq") + EConstr.of_constr @@ + Universes.constr_of_global @@ + Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq" with e when CErrors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - EConstr.of_constr (Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl") + EConstr.of_constr @@ + Universes.constr_of_global @@ + Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq_refl" with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = @@ -489,7 +491,10 @@ let hrec_id = Id.of_string "hrec" let well_founded = function () -> EConstr.of_constr (coq_constant "well_founded") let acc_rel = function () -> EConstr.of_constr (coq_constant "Acc") let acc_inv_id = function () -> EConstr.of_constr (coq_constant "Acc_inv") -let well_founded_ltof = function () -> EConstr.of_constr (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof") + +let well_founded_ltof () = EConstr.of_constr @@ Universes.constr_of_global @@ + Coqlib.coq_reference "" ["Arith";"Wf_nat"] "well_founded_ltof" + let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) @@ -505,13 +510,13 @@ let list_rewrite (rev:bool) (eqs: (EConstr.constr*bool) list) = (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; let decompose_lam_n sigma n = - if n < 0 then CErrors.error "decompose_lam_n: integer parameter must be positive"; + if n < 0 then CErrors.user_err Pp.(str "decompose_lam_n: integer parameter must be positive"); let rec lamdec_rec l n c = if Int.equal n 0 then l,c else match EConstr.kind sigma c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c - | _ -> CErrors.error "decompose_lam_n: not enough abstractions" + | _ -> CErrors.user_err Pp.(str "decompose_lam_n: not enough abstractions") in lamdec_rec [] n diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 6c0c28905e..12232dd83d 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -30,8 +30,8 @@ module RelDecl = Context.Rel.Declaration let pr_binding prc = function - | loc, NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) - | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) + | loc, (NamedHyp id, c) -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) + | loc, (AnonHyp n, c) -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) let pr_bindings prc prlc = function | ImplicitBindings l -> @@ -197,7 +197,7 @@ let generate_type evd g_to_f f graph i = let find_induction_principle evd f = let f_as_constant,u = match EConstr.kind !evd f with | Const c' -> c' - | _ -> error "Must be used with a function" + | _ -> user_err Pp.(str "Must be used with a function") in let infos = find_Function_infos f_as_constant in match infos.rect_lemma with @@ -273,7 +273,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes List.map (fun decl -> List.map - (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id)) + (fun id -> Loc.tag @@ IntroNaming (IntroIdentifier id)) (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) ) branches @@ -421,7 +421,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let params_bindings,avoid = List.fold_left2 (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.out_name (RelDecl.get_name decl)) avoid in + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) avoid in p::bindings,id::avoid ) ([],pf_ids_of_hyps g) @@ -431,7 +431,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let lemmas_bindings = List.rev (fst (List.fold_left2 (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.out_name (RelDecl.get_name decl)) avoid in + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) avoid in (nf_zeta p)::bindings,id::avoid) ([],avoid) princ_infos.predicates @@ -546,7 +546,7 @@ and intros_with_rewrite_aux : tactic = intros_with_rewrite ] g end - | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (Coqlib.build_coq_False ())) -> + | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_False ())) -> Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> tclTHENSEQ[ @@ -701,7 +701,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = let graph_def = graphs.(j) in let infos = try find_Function_infos (fst (destConst (project g) funcs.(j))) - with Not_found -> error "No graph found" + with Not_found -> user_err Pp.(str "No graph found") in if infos.is_general || Rtree.is_infinite Declareops.eq_recarg graph_def.mind_recargs @@ -1006,6 +1006,7 @@ let functional_inversion kn hid fconst f_correct : tactic = | _ -> tclFAIL 1 (mt ()) g +let error msg = user_err Pp.(str msg) let invfun qhyp f = let f = diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 0af0898a0a..7634437171 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -65,14 +65,14 @@ let string_of_name = id_of_name %> Id.to_string (** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) let isVarf f x = match x with - | GVar (_,x) -> Id.equal x f + | { CAst.v = GVar x } -> Id.equal x f | _ -> false (** [ident_global_exist id] returns true if identifier [id] is linked in global environment. *) let ident_global_exist id = try - let ans = CRef (Libnames.Ident (Loc.ghost,id), None) in + let ans = CAst.make @@ CRef (Libnames.Ident (Loc.tag id), None) in let _ = ignore (Constrintern.intern_constr (Global.env()) ans) in true with e when CErrors.noncritical e -> false @@ -133,20 +133,6 @@ let prNamedRLDecl s lc = prstr "\n"; end -let showind (id:Id.t) = - let cstrid = Constrintern.global_reference id in - let (ind1, u),cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty (EConstr.of_constr cstrid) in - let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in - let u = EConstr.Unsafe.to_instance u in - List.iter (fun decl -> - print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":"); - prconstr (RelDecl.get_type decl); print_string "\n") - ib1.mind_arity_ctxt; - Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) (ind1, u)); - Array.iteri - (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) - ib1.mind_user_lc - (** {2 Misc} *) exception Found of int @@ -347,7 +333,7 @@ let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list = filter_shift_stable lnk (Array.to_list larr) - +let error msg = user_err Pp.(str msg) (** {1 Utilities for merging} *) @@ -505,38 +491,38 @@ exception NoMerge let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in - match c1 , c2 with - | GApp(_,f1, arr1), GApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> + match CAst.(c1.v, c2.v) with + | GApp(f1, arr1), GApp(f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> let _ = prstr "\nICI1!\n" in let args = filter_shift_stable lnk (arr1 @ arr2) in - GApp (Loc.ghost,GVar (Loc.ghost,shift.ident) , args) - | GApp(_,f1, arr1), GApp(_,f2,arr2) -> raise NoMerge - | GLetIn(_,nme,bdy,typ,trm) , _ -> + CAst.make @@ GApp ((CAst.make @@ GVar shift.ident) , args) + | GApp(f1, arr1), GApp(f2,arr2) -> raise NoMerge + | GLetIn(nme,bdy,typ,trm) , _ -> let _ = prstr "\nICI2!\n" in let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in - GLetIn(Loc.ghost,nme,bdy,typ,newtrm) - | _, GLetIn(_,nme,bdy,typ,trm) -> + CAst.make @@ GLetIn(nme,bdy,typ,newtrm) + | _, GLetIn(nme,bdy,typ,trm) -> let _ = prstr "\nICI3!\n" in let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in - GLetIn(Loc.ghost,nme,bdy,typ,newtrm) + CAst.make @@ GLetIn(nme,bdy,typ,newtrm) | _ -> let _ = prstr "\nICI4!\n" in raise NoMerge let rec merge_app_unsafe c1 c2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in - match c1 , c2 with - | GApp(_,f1, arr1), GApp(_,f2,arr2) -> + match CAst.(c1.v, c2.v) with + | GApp(f1, arr1), GApp(f2,arr2) -> let args = filter_shift_stable lnk (arr1 @ arr2) in - GApp (Loc.ghost,GVar(Loc.ghost,shift.ident) , args) + CAst.make @@ GApp (CAst.make @@ GVar shift.ident, args) (* FIXME: what if the function appears in the body of the let? *) - | GLetIn(_,nme,bdy,typ,trm) , _ -> + | GLetIn(nme,bdy,typ,trm) , _ -> let _ = prstr "\nICI2 '!\n" in let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in - GLetIn(Loc.ghost,nme,bdy,typ,newtrm) - | _, GLetIn(_,nme,bdy,typ,trm) -> + CAst.make @@ GLetIn(nme,bdy,typ,newtrm) + | _, GLetIn(nme,bdy,typ,trm) -> let _ = prstr "\nICI3 '!\n" in let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in - GLetIn(Loc.ghost,nme,bdy,typ,newtrm) + CAst.make @@ GLetIn(nme,bdy,typ,newtrm) | _ -> let _ = prstr "\nICI4 '!\n" in raise NoMerge @@ -549,14 +535,14 @@ let rec merge_rec_hyps shift accrec filter_shift_stable : (Name.t * glob_constr option * glob_constr option) list = let mergeonehyp t reldecl = match reldecl with - | (nme,x,Some (GApp(_,i,args) as ind)) + | (nme,x,Some ({ CAst.v = GApp(i,args)} as ind)) -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable) | (nme,Some _,None) -> error "letins with recursive calls not treated yet" | (nme,None,Some _) -> assert false | (nme,None,None) | (nme,Some _,Some _) -> assert false in match ltyp with | [] -> [] - | (nme,None,Some (GApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> + | (nme,None,Some ({ CAst. v = GApp(f, largs) } as t)) :: lt when isVarf ind2name f -> let rechyps = List.map (mergeonehyp t) accrec in rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable @@ -572,7 +558,7 @@ let find_app (nme:Id.t) ltyp = (List.map (fun x -> match x with - | _,None,Some (GApp(_,f,_)) when isVarf nme f -> raise (Found 0) + | _,None,Some { CAst.v = GApp(f,_)} when isVarf nme f -> raise (Found 0) | _ -> ()) ltyp); false @@ -631,8 +617,8 @@ let rec merge_types shift accrec1 rechyps , concl | (nme,None, Some t1)as e ::lt1 -> - (match t1 with - | GApp(_,f,carr) when isVarf ind1name f -> + (match t1.CAst.v with + | GApp(f,carr) when isVarf ind1name f -> merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 | _ -> let recres, recconcl2 = @@ -824,7 +810,7 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let _ = prNamedRConstr (string_of_name nme) tp in let _ = prstr " ; " in let typ = glob_constr_to_constr_expr tp in - CLocalAssum ([(Loc.ghost,nme)], Constrexpr_ops.default_binder_kind, typ) :: acc) + CLocalAssum ([(Loc.tag nme)], Constrexpr_ops.default_binder_kind, typ) :: acc) [] params in let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in let arity,_ = @@ -834,7 +820,7 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let c = RelDecl.get_type decl in let typ = Constrextern.extern_constr false env Evd.empty c in let newenv = Environ.push_rel (LocalAssum (nm,c)) env in - CProdN (Loc.ghost, [[(Loc.ghost,nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv) + CAst.make @@ CProdN ([[(Loc.tag nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv) (concl,Global.env()) (shift.funresprms2 @ shift.funresprms1 @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in @@ -848,12 +834,12 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = FIXME: params et cstr_expr (arity) *) let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift (rawlist:(Id.t * glob_constr) list) = - let lident = (Loc.ghost, shift.ident), None in + let lident = (Loc.tag shift.ident), None in let bindlist , cstr_expr = (* params , arities *) merge_rec_params_and_arity prms1 prms2 shift mkSet in let lcstor_expr : (bool * (lident * constr_expr)) list = List.map (* zeta_normalize t ? *) - (fun (id,t) -> false, ((Loc.ghost,id),glob_constr_to_constr_expr t)) + (fun (id,t) -> false, ((Loc.tag id),glob_constr_to_constr_expr t)) rawlist in lident , bindlist , Some cstr_expr , lcstor_expr @@ -863,7 +849,7 @@ let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) = | LocalAssum (nme,t) -> let t = EConstr.of_constr t in let traw = Detyping.detype false [] (Global.env()) Evd.empty t in - GProd (Loc.ghost,nme,Explicit,traw,t2) + CAst.make @@ GProd (nme,Explicit,traw,t2) | LocalDef _ -> assert false @@ -901,7 +887,7 @@ let merge_inductive (ind1: inductive) (ind2: inductive) (* Find infos on identifier id. *) let find_Function_infos_safe (id:Id.t): Indfun_common.function_info = let kn_of_id x = - let f_ref = Libnames.Ident (Loc.ghost,x) in + let f_ref = Libnames.Ident (Loc.tag x) in locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref) locate_constant f_ref in try find_Function_infos (kn_of_id id) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index bd30f11596..62eba9513d 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -47,14 +47,16 @@ open Context.Rel.Declaration (* Ugly things which should not be here *) -let coq_constant m s = - EConstr.of_constr (Coqlib.coq_constant "RecursiveDefinition" m s) +let coq_constant m s = EConstr.of_constr @@ Universes.constr_of_global @@ + Coqlib.coq_reference "RecursiveDefinition" m s let arith_Nat = ["Arith";"PeanoNat";"Nat"] let arith_Lt = ["Arith";"Lt"] let coq_init_constant s = - EConstr.of_constr (Coqlib.gen_constant_in_modules "RecursiveDefinition" Coqlib.init_modules s) + EConstr.of_constr ( + Universes.constr_of_global @@ + Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s) let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in @@ -136,7 +138,7 @@ let ex = function () -> (coq_init_constant "ex") let nat = function () -> (coq_init_constant "nat") let iter_ref () = try find_reference ["Recdef"] "iter" - with Not_found -> error "module Recdef not loaded" + with Not_found -> user_err Pp.(str "module Recdef not loaded") let iter = function () -> (constr_of_global (delayed_force iter_ref)) let eq = function () -> (coq_init_constant "eq") let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") @@ -172,7 +174,6 @@ let simpl_iter clause = let (value_f:Constr.constr list -> global_reference -> Constr.constr) = let open Term in fun al fterm -> - let d0 = Loc.ghost in let rev_x_id_l = ( List.fold_left @@ -189,16 +190,15 @@ let (value_f:Constr.constr list -> global_reference -> Constr.constr) = in let env = Environ.push_rel_context context (Global.env ()) in let glob_body = - GCases - (d0,RegularStyle,None, - [GApp(d0, GRef(d0,fterm,None), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l), + CAst.make @@ + GCases + (RegularStyle,None, + [CAst.make @@ GApp(CAst.make @@ GRef(fterm,None), List.rev_map (fun x_id -> CAst.make @@ GVar x_id) rev_x_id_l), (Anonymous,None)], - [d0, [v_id], [PatCstr(d0,(destIndRef - (delayed_force coq_sig_ref),1), - [PatVar(d0, Name v_id); - PatVar(d0, Anonymous)], - Anonymous)], - GVar(d0,v_id)]) + [Loc.tag ([v_id], [CAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1), + [CAst.make @@ PatVar(Name v_id); CAst.make @@ PatVar Anonymous], + Anonymous)], + CAst.make @@ GVar v_id)]) in let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in it_mkLambda_or_LetIn body context @@ -325,8 +325,8 @@ let check_not_nested sigma forbidden e = | Construct _ -> () | Case(_,t,e,a) -> check_not_nested t;check_not_nested e;Array.iter check_not_nested a - | Fix _ -> error "check_not_nested : Fix" - | CoFix _ -> error "check_not_nested : Fix" + | Fix _ -> user_err Pp.(str "check_not_nested : Fix") + | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") in try check_not_nested e @@ -432,8 +432,8 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = let sigma = project g in match EConstr.kind sigma expr_info.info with - | CoFix _ | Fix _ -> error "Function cannot treat local fixpoint or cofixpoint" - | Proj _ -> error "Function cannot treat projections" + | CoFix _ | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") + | Proj _ -> user_err Pp.(str "Function cannot treat projections") | LetIn(na,b,t,e) -> begin let new_continuation_tac = @@ -879,14 +879,13 @@ let rec make_rewrite_list expr_info max = function let k_na,_,t = destProd sigma t_eq in let _,_,t = destProd sigma t in let def_na,_,_ = destProd sigma t in - Nameops.out_name k_na,Nameops.out_name def_na + Nameops.Name.get_id k_na,Nameops.Name.get_id def_na in Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true (mkVar hp, - ExplicitBindings[Loc.ghost,NamedHyp def, - expr_info.f_constr;Loc.ghost,NamedHyp k, - f_S max]) false) g) ) + ExplicitBindings[Loc.tag @@ (NamedHyp def, expr_info.f_constr); + Loc.tag @@ (NamedHyp k, f_S max)]) false) g) ) ) [make_rewrite_list expr_info max l; observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *) @@ -906,15 +905,14 @@ let make_rewrite expr_info l hp max = let k_na,_,t = destProd sigma t_eq in let _,_,t = destProd sigma t in let def_na,_,_ = destProd sigma t in - Nameops.out_name k_na,Nameops.out_name def_na + Nameops.Name.get_id k_na,Nameops.Name.get_id def_na in observe_tac (str "general_rewrite_bindings") (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true (mkVar hp, - ExplicitBindings[Loc.ghost,NamedHyp def, - expr_info.f_constr;Loc.ghost,NamedHyp k, - f_S (f_S max)]) false)) g) + ExplicitBindings[Loc.tag @@ (NamedHyp def, expr_info.f_constr); + Loc.tag @@ (NamedHyp k, f_S (f_S max))]) false)) g) [observe_tac(str "make_rewrite finalize") ( (* tclORELSE( h_reflexivity) *) (observe_tclTHENLIST (str "make_rewrite")[ @@ -1227,7 +1225,7 @@ let get_current_subgoals_types () = exception EmptySubgoals let build_and_l sigma l = - let and_constr = Coqlib.build_coq_and () in + let and_constr = Universes.constr_of_global @@ Coqlib.build_coq_and () in let conj_constr = coq_conj () in let mk_and p1 p2 = mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in @@ -1308,10 +1306,10 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp in let na = next_global_ident_away name [] in if Termops.occur_existential sigma gls_type then - CErrors.error "\"abstract\" cannot handle existentials"; + CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials"); let hook _ _ = let opacity = - let na_ref = Libnames.Ident (Loc.ghost,na) in + let na_ref = Libnames.Ident (Loc.tag na) in let na_global = Smartlocate.global_with_alias na_ref in match na_global with ConstRef c -> is_opaque_constant c @@ -1561,7 +1559,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let hook _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in - let _ = Extraction_plugin.Table.extraction_inline true [Ident (Loc.ghost,term_id)] in + let _ = Extraction_plugin.Table.extraction_inline true [Ident (Loc.tag term_id)] in (* message "start second proof"; *) let stop = try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4 index 28ff6df838..0a13a20a97 100644 --- a/plugins/ltac/coretactics.ml4 +++ b/plugins/ltac/coretactics.ml4 @@ -305,10 +305,9 @@ END open Tacexpr let initial_atomic () = - let dloc = Loc.ghost in let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in let iter (s, t) = - let body = TacAtom (dloc, t) in + let body = TacAtom (Loc.tag t) in Tacenv.register_ltac false false (Id.of_string s) body in let () = List.iter iter @@ -323,7 +322,39 @@ let initial_atomic () = List.iter iter [ "idtac",TacId []; "fail", TacFail(TacLocal,ArgArg 0,[]); - "fresh", TacArg(dloc,TacFreshId []) + "fresh", TacArg(Loc.tag @@ TacFreshId []) ] let () = Mltop.declare_cache_obj initial_atomic "coretactics" + +(* First-class Ltac access to primitive blocks *) + +let initial_name s = { mltac_plugin = "coretactics"; mltac_tactic = s; } +let initial_entry s = { mltac_name = initial_name s; mltac_index = 0; } + +let register_list_tactical name f = + let tac args ist = match args with + | [v] -> + begin match Tacinterp.Value.to_list v with + | None -> Tacticals.New.tclZEROMSG (Pp.str "Expected a list") + | Some tacs -> + let tacs = List.map (fun tac -> Tacinterp.tactic_of_value ist tac) tacs in + f tacs + end + | _ -> assert false + in + Tacenv.register_ml_tactic (initial_name name) [|tac|] + +let () = register_list_tactical "first" Tacticals.New.tclFIRST +let () = register_list_tactical "solve" Tacticals.New.tclSOLVE + +let initial_tacticals () = + let idn n = Id.of_string (Printf.sprintf "_%i" n) in + let varn n = Reference (ArgVar (None, idn n)) in + let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in + List.iter iter [ + "first", TacFun ([Name (idn 0)], TacML (None, (initial_entry "first", [varn 0]))); + "solve", TacFun ([Name (idn 0)], TacML (None, (initial_entry "solve", [varn 0]))); + ] + +let () = Mltop.declare_cache_obj initial_tacticals "coretactics" diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index bc9c300e23..bf84f61a5b 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -56,17 +56,16 @@ let instantiate_tac n c ido = InHyp -> (match decl with | LocalAssum (_,typ) -> evar_list sigma (EConstr.of_constr typ) - | _ -> error - "Please be more specific: in type or value?") + | _ -> user_err Pp.(str "Please be more specific: in type or value?")) | InHypTypeOnly -> evar_list sigma (EConstr.of_constr (NamedDecl.get_type decl)) | InHypValueOnly -> (match decl with | LocalDef (_,body,_) -> evar_list sigma (EConstr.of_constr body) - | _ -> error "Not a defined hypothesis.") in + | _ -> user_err Pp.(str "Not a defined hypothesis.")) in if List.length evl < n then - error "Not enough uninstantiated existential variables."; - if n <= 0 then error "Incorrect existential variable index."; + user_err Pp.(str "Not enough uninstantiated existential variables."); + if n <= 0 then user_err Pp.(str "Incorrect existential variable index."); let evk,_ = List.nth evl (n-1) in instantiate_evar evk c sigma gl end @@ -76,12 +75,12 @@ let instantiate_tac_by_name id c = let sigma = gl.sigma in let evk = try Evd.evar_key id sigma - with Not_found -> error "Unknown existential variable." in + with Not_found -> user_err Pp.(str "Unknown existential variable.") in instantiate_evar evk c sigma gl end let let_evar name typ = - let src = (Loc.ghost,Evar_kinds.GoalEvar) in + let src = (Loc.tag Evar_kinds.GoalEvar) in Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in @@ -109,8 +108,8 @@ let hget_evar n = let concl = Proofview.Goal.concl gl in let evl = evar_list sigma concl in if List.length evl < n then - error "Not enough uninstantiated existential variables."; - if n <= 0 then error "Incorrect existential variable index."; + user_err Pp.(str "Not enough uninstantiated existential variables."); + if n <= 0 then user_err Pp.(str "Incorrect existential variable index."); let ev = List.nth evl (n-1) in let ev_type = EConstr.existential_type sigma ev in Tactics.change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl)) diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 index ec3a49df49..fdb8d34618 100644 --- a/plugins/ltac/extraargs.ml4 +++ b/plugins/ltac/extraargs.ml4 @@ -90,7 +90,7 @@ let occurrences_of = function | n::_ as nl when n < 0 -> AllOccurrencesBut (List.map abs nl) | nl -> if List.exists (fun n -> n < 0) nl then - CErrors.error "Illegal negative occurrence number."; + CErrors.user_err Pp.(str "Illegal negative occurrence number."); OnlyOccurrences nl let coerce_to_int v = match Value.to_int v with @@ -228,11 +228,11 @@ ARGUMENT EXTEND hloc | [ "in" "|-" "*" ] -> [ ConclLocation () ] | [ "in" ident(id) ] -> - [ HypLocation ((Loc.ghost,id),InHyp) ] + [ HypLocation ((Loc.tag id),InHyp) ] | [ "in" "(" "Type" "of" ident(id) ")" ] -> - [ HypLocation ((Loc.ghost,id),InHypTypeOnly) ] + [ HypLocation ((Loc.tag id),InHypTypeOnly) ] | [ "in" "(" "Value" "of" ident(id) ")" ] -> - [ HypLocation ((Loc.ghost,id),InHypValueOnly) ] + [ HypLocation ((Loc.tag id),InHypValueOnly) ] END diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index bd48614dbc..9726a5b401 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -73,7 +73,7 @@ END let induction_arg_of_quantified_hyp = function | AnonHyp n -> None,ElimOnAnonHyp n - | NamedHyp id -> None,ElimOnIdent (Loc.ghost,id) + | NamedHyp id -> None,ElimOnIdent (Loc.tag id) (* Versions *_main must come first!! so that "1" is interpreted as a ElimOnAnonHyp and not as a "constr", and "id" is interpreted as a @@ -264,7 +264,7 @@ let add_rewrite_hint bases ort t lcsr = (Declare.declare_universe_context false ctx; Univ.ContextSet.empty) in - Constrexpr_ops.constr_loc ce, (c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t in + Loc.tag ?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 List.iter add_hints bases @@ -306,6 +306,7 @@ let project_hint pri l2r r = | _ -> assert false in let p = if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in + let sigma, p = Evd.fresh_global env sigma p in let p = EConstr.of_constr p in let c = Reductionops.whd_beta sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in let c = it_mkLambda_or_LetIn @@ -628,15 +629,15 @@ let subst_var_with_hole occ tid t = let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in let locref = ref 0 in let rec substrec = function - | GVar (_,id) as x -> + | { CAst.v = GVar id } as x -> if Id.equal id tid then (decr occref; if Int.equal !occref 0 then x else (incr locref; - GHole (Loc.make_loc (!locref,0), - Evar_kinds.QuestionMark(Evar_kinds.Define true), + CAst.make ~loc:(Loc.make_loc (!locref,0)) @@ + GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous), Misctypes.IntroAnonymous, None))) else x | c -> map_glob_constr_left_to_right substrec c in @@ -648,13 +649,13 @@ let subst_hole_with_term occ tc t = let locref = ref 0 in let occref = ref occ in let rec substrec = function - | GHole (_,Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s) -> + | { CAst.v = GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s) } -> decr occref; if Int.equal !occref 0 then tc else (incr locref; - GHole (Loc.make_loc (!locref,0), - Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s)) + CAst.make ~loc:(Loc.make_loc (!locref,0)) @@ + GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s)) | c -> map_glob_constr_left_to_right substrec c in substrec t @@ -676,8 +677,8 @@ let hResolve id c occ t = with | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e -> let (e, info) = CErrors.push e in - let loc = match Loc.get_loc info with None -> Loc.ghost | Some loc -> loc in - resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole) + let loc_begin = Option.cata (fun l -> fst (Loc.unloc l)) 0 (Loc.get_loc info) in + resolve_hole (subst_hole_with_term loc_begin c_raw t_hole) in let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in let t_constr = EConstr.of_constr t_constr in @@ -735,7 +736,7 @@ let rewrite_except h = let refl_equal = let coq_base_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" + Coqlib.gen_reference_in_modules "RecursiveDefinition" (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in function () -> (coq_base_constant "eq_refl") @@ -746,8 +747,9 @@ let refl_equal = let mkCaseEq a : unit Proofview.tactic = Proofview.Goal.enter { enter = begin fun gl -> let type_of_a = Tacmach.New.pf_unsafe_type_of gl a in - Tacticals.New.tclTHENLIST - [Tactics.generalize [(mkApp(EConstr.of_constr (delayed_force refl_equal), [| type_of_a; a|]))]; + Tacticals.New.pf_constr_of_global (delayed_force refl_equal) >>= fun req -> + Tacticals.New.tclTHENLIST + [Tactics.generalize [(mkApp(req, [| type_of_a; a|]))]; Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in @@ -781,7 +783,7 @@ let case_eq_intros_rewrite x = let rec find_a_destructable_match sigma t = let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in let cl = [cl, (None, None), None], None in - let dest = TacAtom (Loc.ghost, TacInductionDestruct(false, false, cl)) in + let dest = TacAtom (Loc.tag @@ TacInductionDestruct(false, false, cl)) in match EConstr.kind sigma t with | Case (_,_,x,_) when closed0 sigma x -> if isVar sigma x then @@ -1084,7 +1086,7 @@ let decompose l c = let sigma = Tacmach.New.project gl in let to_ind c = if isInd sigma c then fst (destInd sigma c) - else error "not an inductive type" + else user_err Pp.(str "not an inductive type") in let l = List.map to_ind l in Elim.h_decompose l c diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index d717ed0a53..36ac10bfe7 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -41,7 +41,7 @@ let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac let reference_to_id = function | Libnames.Ident (loc, id) -> (loc, id) | Libnames.Qualid (loc,_) -> - CErrors.user_err ~loc + CErrors.user_err ?loc (str "This expression should be a simple identifier.") let tactic_mode = Gram.entry_create "vernac:tactic_command" @@ -159,9 +159,9 @@ GEXTEND Gram | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; l = LIST0 message_token -> TacFail (g,n,l) | st = simple_tactic -> st - | a = tactic_arg -> TacArg(!@loc,a) + | a = tactic_arg -> TacArg(Loc.tag ~loc:!@loc a) | r = reference; la = LIST0 tactic_arg_compat -> - TacArg(!@loc,TacCall (!@loc,r,la)) ] + TacArg(Loc.tag ~loc:!@loc @@ TacCall (Loc.tag ~loc:!@loc (r,la))) ] | "0" [ "("; a = tactic_expr; ")" -> a | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> @@ -169,7 +169,7 @@ GEXTEND Gram | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) | None -> TacDispatch tf end - | a = tactic_atom -> TacArg (!@loc,a) ] ] + | a = tactic_atom -> TacArg (Loc.tag ~loc:!@loc a) ] ] ; failkw: [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] @@ -187,7 +187,7 @@ GEXTEND Gram (* Tactic arguments to the right of an application *) tactic_arg_compat: [ [ a = tactic_arg -> a - | c = Constr.constr -> (match c with CRef (r,None) -> Reference r | c -> ConstrMayEval (ConstrTerm c)) + | c = Constr.constr -> (match c with { CAst.v = CRef (r,None) } -> Reference r | c -> ConstrMayEval (ConstrTerm c)) (* Unambiguous entries: tolerated w/o "ltac:" modifier *) | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; @@ -203,7 +203,7 @@ GEXTEND Gram verbose most of the time. *) fresh_id: [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) - | qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (!@loc,id) ] ] + | qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (Loc.tag ~loc:!@loc id) ] ] ; constr_eval: [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> @@ -219,7 +219,7 @@ GEXTEND Gram ; tactic_atom: [ [ n = integer -> TacGeneric (genarg_of_int n) - | r = reference -> TacCall (!@loc,r,[]) + | r = reference -> TacCall (Loc.tag ~loc:!@loc (r,[])) | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; match_key: @@ -255,10 +255,10 @@ GEXTEND Gram let t, ty = match mpv with | Term t -> (match t with - | CCast (loc, t, (CastConv ty | CastVM ty | CastNative ty)) -> Term t, Some (Term ty) + | { CAst.v = CCast (t, (CastConv ty | CastVM ty | CastNative ty)) } -> Term t, Some (Term ty) | _ -> mpv, None) | _ -> mpv, None - in Def (na, t, Option.default (Term (CHole (Loc.ghost, None, IntroAnonymous, None))) ty) + in Def (na, t, Option.default (Term (CAst.make @@ CHole (None, IntroAnonymous, None))) ty) ] ] ; match_context_rule: @@ -353,7 +353,7 @@ GEXTEND Gram operconstr: LEVEL "0" [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in - CHole (!@loc, None, IntroAnonymous, Some arg) ] ] + CAst.make ~loc:!@loc @@ CHole (None, IntroAnonymous, Some arg) ] ] ; END @@ -367,7 +367,6 @@ open Libnames let print_info_trace = ref None let _ = declare_int_option { - optsync = true; optdepr = false; optname = "print info trace"; optkey = ["Info" ; "Level"]; @@ -460,9 +459,9 @@ END let pr_ltac_production_item = function | Tacentries.TacTerm s -> quote (str s) -| Tacentries.TacNonTerm (_, (arg, None), None) -> str arg -| Tacentries.TacNonTerm (_, (arg, Some _), None) -> assert false -| Tacentries.TacNonTerm (_, (arg, sep), Some id) -> +| Tacentries.TacNonTerm (_, ((arg, None), None)) -> str arg +| Tacentries.TacNonTerm (_, ((arg, Some _), None)) -> assert false +| Tacentries.TacNonTerm (_, ((arg, sep), Some id)) -> let sep = match sep with | None -> mt () | Some sep -> str "," ++ spc () ++ quote (str sep) @@ -472,9 +471,9 @@ let pr_ltac_production_item = function VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item | [ string(s) ] -> [ Tacentries.TacTerm s ] | [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> - [ Tacentries.TacNonTerm (loc, (Names.Id.to_string nt, sep), Some p) ] + [ Tacentries.TacNonTerm (Loc.tag ~loc ((Names.Id.to_string nt, sep), Some p)) ] | [ ident(nt) ] -> - [ Tacentries.TacNonTerm (loc, (Names.Id.to_string nt, None), None) ] + [ Tacentries.TacNonTerm (Loc.tag ~loc ((Names.Id.to_string nt, None), None)) ] END VERNAC COMMAND EXTEND VernacTacticNotation diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4 index 3e6e2db605..4dceb03314 100644 --- a/plugins/ltac/g_obligations.ml4 +++ b/plugins/ltac/g_obligations.ml4 @@ -31,7 +31,7 @@ let () = Obligations.default_tactic := tac let with_tac f tac = - let env = { Genintern.genv = Global.env (); ltacvars = Names.Id.Set.empty } in + let env = Genintern.empty_glob_sign (Global.env ()) in let tac = match tac with | None -> None | Some tac -> @@ -50,7 +50,7 @@ module Tactic = Pltac open Pcoq -let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Specif.sig")) +let sigref = mkRefC (Qualid (Loc.tag @@ Libnames.qualid_of_string "Coq.Init.Specif.sig")) type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index ac979bcf89..5adf8475ae 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -124,7 +124,7 @@ END let clsubstitute o c = Proofview.Goal.enter { enter = begin fun gl -> - let is_tac id = match fst (fst (snd c)) with GVar (_, id') when Id.equal id' id -> true | _ -> false in + let is_tac id = match fst (fst (snd c)) with { CAst.v = GVar id' } when Id.equal id' id -> true | _ -> false in let hyps = Tacmach.New.pf_ids_of_hyps gl in Tacticals.New.tclMAP (fun cl -> diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 index e33c25cf88..83bfd0233a 100644 --- a/plugins/ltac/g_tactic.ml4 +++ b/plugins/ltac/g_tactic.ml4 @@ -117,16 +117,16 @@ let mk_fix_tac (loc,id,bl,ann,ty) = | _, Some x -> let ids = List.map snd (List.flatten (List.map pi1 bl)) in (try List.index Names.Name.equal (snd x) ids - with Not_found -> error "No such fix variable.") - | _ -> error "Cannot guess decreasing argument of fix." in - (id,n,CProdN(loc,bl,ty)) + with Not_found -> user_err Pp.(str "No such fix variable.")) + | _ -> user_err Pp.(str "Cannot guess decreasing argument of fix.") in + (id,n, CAst.make ~loc @@ CProdN(bl,ty)) let mk_cofix_tac (loc,id,bl,ann,ty) = let _ = Option.map (fun (aloc,_) -> user_err ~loc:aloc ~hdr:"Constr:mk_cofix_tac" (Pp.str"Annotation forbidden in cofix expression.")) ann in - (id,CProdN(loc,bl,ty)) + (id,CAst.make ~loc @@ CProdN(bl,ty)) (* Functions overloaded by quotifier *) let destruction_arg_of_constr (c,lbind as clbind) = match lbind with @@ -143,32 +143,32 @@ let mkTacCase with_evar = function (* Reinterpret numbers as a notation for terms *) | [(clear,ElimOnAnonHyp n),(None,None),None],None -> TacCase (with_evar, - (clear,(CPrim (Loc.ghost, Numeral (Bigint.of_int n)), + (clear,(CAst.make @@ CPrim (Numeral (Bigint.of_int n)), NoBindings))) (* Reinterpret ident as notations for variables in the context *) (* because we don't know if they are quantified or not *) | [(clear,ElimOnIdent id),(None,None),None],None -> - TacCase (with_evar,(clear,(CRef (Ident id,None),NoBindings))) + TacCase (with_evar,(clear,(CAst.make @@ CRef (Ident id,None),NoBindings))) | ic -> if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic) then - error "Use of numbers as direct arguments of 'case' is not supported."; + user_err Pp.(str "Use of numbers as direct arguments of 'case' is not supported."); TacInductionDestruct (false,with_evar,ic) -let rec mkCLambdaN_simple_loc loc bll c = +let rec mkCLambdaN_simple_loc ?loc bll c = match bll with | ((loc1,_)::_ as idl,bk,t) :: bll -> - CLambdaN (loc,[idl,bk,t],mkCLambdaN_simple_loc (Loc.merge loc1 loc) bll c) - | ([],_,_) :: bll -> mkCLambdaN_simple_loc loc bll c + CAst.make ?loc @@ CLambdaN ([idl,bk,t],mkCLambdaN_simple_loc ?loc:(Loc.merge_opt loc1 loc) bll c) + | ([],_,_) :: bll -> mkCLambdaN_simple_loc ?loc bll c | [] -> c let mkCLambdaN_simple bl c = match bl with | [] -> c | h :: _ -> - let loc = Loc.merge (fst (List.hd (pi1 h))) (Constrexpr_ops.constr_loc c) in - mkCLambdaN_simple_loc loc bl c + let loc = Loc.merge_opt (fst (List.hd (pi1 h))) (Constrexpr_ops.constr_loc c) in + mkCLambdaN_simple_loc ?loc bl c -let loc_of_ne_list l = Loc.merge (fst (List.hd l)) (fst (List.last l)) +let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) let map_int_or_var f = function | ArgArg x -> ArgArg (f x) @@ -290,7 +290,7 @@ GEXTEND Gram (* (A & B & C) is translated into (A,(B,C)) *) let rec pairify = function | ([]|[_]|[_;_]) as l -> l - | t::q -> [t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))] + | t::q -> [t; Loc.tag ?loc:(loc_of_ne_list q) (IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))] in IntroAndPattern (pairify (si::tc)) ] ] ; equality_intropattern: @@ -305,8 +305,8 @@ GEXTEND Gram ; nonsimple_intropattern: [ [ l = simple_intropattern -> l - | "*" -> !@loc, IntroForthcoming true - | "**" -> !@loc, IntroForthcoming false ]] + | "*" -> Loc.tag ~loc:!@loc @@ IntroForthcoming true + | "**" -> Loc.tag ~loc:!@loc @@ IntroForthcoming false ]] ; simple_intropattern: [ [ pat = simple_intropattern_closed; @@ -314,19 +314,19 @@ GEXTEND Gram let loc0,pat = pat in let f c pat = let loc1 = Constrexpr_ops.constr_loc c in - let loc = Loc.merge loc0 loc1 in + let loc = Loc.merge_opt loc0 loc1 in IntroAction (IntroApplyOn ((loc1,c),(loc,pat))) in - !@loc, List.fold_right f l pat ] ] + Loc.tag ~loc:!@loc @@ List.fold_right f l pat ] ] ; simple_intropattern_closed: - [ [ pat = or_and_intropattern -> !@loc, IntroAction (IntroOrAndPattern pat) - | pat = equality_intropattern -> !@loc, IntroAction pat - | "_" -> !@loc, IntroAction IntroWildcard - | pat = naming_intropattern -> !@loc, IntroNaming pat ] ] + [ [ pat = or_and_intropattern -> Loc.tag ~loc:!@loc @@ IntroAction (IntroOrAndPattern pat) + | pat = equality_intropattern -> Loc.tag ~loc:!@loc @@ IntroAction pat + | "_" -> Loc.tag ~loc:!@loc @@ IntroAction IntroWildcard + | pat = naming_intropattern -> Loc.tag ~loc:!@loc @@ IntroNaming pat ] ] ; simple_binding: - [ [ "("; id = ident; ":="; c = lconstr; ")" -> (!@loc, NamedHyp id, c) - | "("; n = natural; ":="; c = lconstr; ")" -> (!@loc, AnonHyp n, c) ] ] + [ [ "("; id = ident; ":="; c = lconstr; ")" -> Loc.tag ~loc:!@loc (NamedHyp id, c) + | "("; n = natural; ":="; c = lconstr; ")" -> Loc.tag ~loc:!@loc (AnonHyp n, c) ] ] ; bindings: [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> @@ -429,7 +429,7 @@ GEXTEND Gram | -> true ]] ; simple_binder: - [ [ na=name -> ([na],Default Explicit,CHole (!@loc, Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None)) + [ [ na=name -> ([na],Default Explicit, CAst.make ~loc:!@loc @@ CHole (Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None)) | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c) ] ] ; @@ -457,7 +457,7 @@ GEXTEND Gram | -> None ] ] ; or_and_intropattern_loc: - [ [ ipat = or_and_intropattern -> ArgArg (!@loc,ipat) + [ [ ipat = or_and_intropattern -> ArgArg (Loc.tag ~loc:!@loc ipat) | locid = identref -> ArgVar locid ] ] ; as_or_and_ipat: @@ -465,13 +465,13 @@ GEXTEND Gram | -> None ] ] ; eqn_ipat: - [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (!@loc, pat) + [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (Loc.tag ~loc:!@loc pat) | IDENT "_eqn"; ":"; pat = naming_intropattern -> let loc = !@loc in - warn_deprecated_eqn_syntax ~loc "H"; Some (loc, pat) + warn_deprecated_eqn_syntax ~loc "H"; Some (Loc.tag ~loc pat) | IDENT "_eqn" -> let loc = !@loc in - warn_deprecated_eqn_syntax ~loc "?"; Some (loc, IntroAnonymous) + warn_deprecated_eqn_syntax ~loc "?"; Some (Loc.tag ~loc IntroAnonymous) | -> None ] ] ; as_name: @@ -510,145 +510,171 @@ GEXTEND Gram [ [ (* Basic tactics *) IDENT "intros"; pl = ne_intropatterns -> - TacAtom (!@loc, TacIntroPattern (false,pl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacIntroPattern (false,pl)) | IDENT "intros" -> - TacAtom (!@loc, TacIntroPattern (false,[!@loc,IntroForthcoming false])) + TacAtom (Loc.tag ~loc:!@loc @@ TacIntroPattern (false,[Loc.tag ~loc:!@loc @@IntroForthcoming false])) | IDENT "eintros"; pl = ne_intropatterns -> - TacAtom (!@loc, TacIntroPattern (true,pl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacIntroPattern (true,pl)) | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,false,cl,inhyp)) + inhyp = in_hyp_as -> TacAtom (Loc.tag ~loc:!@loc @@ TacApply (true,false,cl,inhyp)) | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,true,cl,inhyp)) + inhyp = in_hyp_as -> TacAtom (Loc.tag ~loc:!@loc @@ TacApply (true,true,cl,inhyp)) | IDENT "simple"; IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,false,cl,inhyp)) + inhyp = in_hyp_as -> TacAtom (Loc.tag ~loc:!@loc @@ TacApply (false,false,cl,inhyp)) | IDENT "simple"; IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP","; - inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,true,cl,inhyp)) + inhyp = in_hyp_as -> TacAtom (Loc.tag ~loc:!@loc @@ TacApply (false,true,cl,inhyp)) | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - TacAtom (!@loc, TacElim (false,cl,el)) + TacAtom (Loc.tag ~loc:!@loc @@ TacElim (false,cl,el)) | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - TacAtom (!@loc, TacElim (true,cl,el)) - | IDENT "case"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase false icl) - | IDENT "ecase"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase true icl) + TacAtom (Loc.tag ~loc:!@loc @@ TacElim (true,cl,el)) + | IDENT "case"; icl = induction_clause_list -> TacAtom (Loc.tag ~loc:!@loc @@ mkTacCase false icl) + | IDENT "ecase"; icl = induction_clause_list -> TacAtom (Loc.tag ~loc:!@loc @@ mkTacCase true icl) | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> - TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd)) + TacAtom (Loc.tag ~loc:!@loc @@ TacMutualFix (id,n,List.map mk_fix_tac fd)) | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> - TacAtom (!@loc, TacMutualCofix (id,List.map mk_cofix_tac fd)) + TacAtom (Loc.tag ~loc:!@loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) | IDENT "pose"; (id,b) = bindings_with_parameters -> - TacAtom (!@loc, TacLetTac (Names.Name id,b,Locusops.nowhere,true,None)) + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,Names.Name id,b,Locusops.nowhere,true,None)) | IDENT "pose"; b = constr; na = as_name -> - TacAtom (!@loc, TacLetTac (na,b,Locusops.nowhere,true,None)) + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) + | IDENT "epose"; (id,b) = bindings_with_parameters -> + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) + | IDENT "epose"; b = constr; na = as_name -> + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) | IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> - TacAtom (!@loc, TacLetTac (Names.Name id,c,p,true,None)) + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,Names.Name id,c,p,true,None)) | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> - TacAtom (!@loc, TacLetTac (na,c,p,true,None)) + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,c,p,true,None)) + | IDENT "eset"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) + | IDENT "eset"; c = constr; na = as_name; p = clause_dft_concl -> + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,c,p,true,None)) | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; p = clause_dft_all -> - TacAtom (!@loc, TacLetTac (na,c,p,false,e)) + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,c,p,false,e)) + | IDENT "eremember"; c = constr; na = as_name; e = eqn_ipat; + p = clause_dft_all -> + TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,c,p,false,e)) (* Alternative syntax for "pose proof c as id" *) | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; c = lconstr; ")" -> - TacAtom (!@loc, TacAssert (true,None,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,None,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c)) + | IDENT "eassert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; + c = lconstr; ")" -> + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,None,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c)) (* Alternative syntax for "assert c as id by tac" *) | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; c = lconstr; ")"; tac=by_tactic -> - TacAtom (!@loc, TacAssert (true,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,Some tac,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c)) + | IDENT "eassert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,Some tac,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c)) (* Alternative syntax for "enough c as id by tac" *) | IDENT "enough"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; c = lconstr; ")"; tac=by_tactic -> - TacAtom (!@loc, TacAssert (false,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,false,Some tac,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c)) + | IDENT "eenough"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,false,Some tac,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c)) | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (!@loc, TacAssert (true,Some tac,ipat,c)) + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,Some tac,ipat,c)) + | IDENT "eassert"; c = constr; ipat = as_ipat; tac = by_tactic -> + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,Some tac,ipat,c)) | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - TacAtom (!@loc, TacAssert (true,None,ipat,c)) + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,None,ipat,c)) + | IDENT "epose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,None,ipat,c)) | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (!@loc, TacAssert (false,Some tac,ipat,c)) + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,false,Some tac,ipat,c)) + | IDENT "eenough"; c = constr; ipat = as_ipat; tac = by_tactic -> + TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,false,Some tac,ipat,c)) | IDENT "generalize"; c = constr -> - TacAtom (!@loc, TacGeneralize [((AllOccurrences,c),Names.Anonymous)]) + TacAtom (Loc.tag ~loc:!@loc @@ TacGeneralize [((AllOccurrences,c),Names.Anonymous)]) | IDENT "generalize"; c = constr; l = LIST1 constr -> let gen_everywhere c = ((AllOccurrences,c),Names.Anonymous) in - TacAtom (!@loc, TacGeneralize (List.map gen_everywhere (c::l))) + TacAtom (Loc.tag ~loc:!@loc @@ TacGeneralize (List.map gen_everywhere (c::l))) | IDENT "generalize"; c = constr; lookup_at_as_comma; nl = occs; na = as_name; l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] -> - TacAtom (!@loc, TacGeneralize (((nl,c),na)::l)) + TacAtom (Loc.tag ~loc:!@loc @@ TacGeneralize (((nl,c),na)::l)) (* Derived basic tactics *) | IDENT "induction"; ic = induction_clause_list -> - TacAtom (!@loc, TacInductionDestruct (true,false,ic)) + TacAtom (Loc.tag ~loc:!@loc @@ TacInductionDestruct (true,false,ic)) | IDENT "einduction"; ic = induction_clause_list -> - TacAtom (!@loc, TacInductionDestruct(true,true,ic)) + TacAtom (Loc.tag ~loc:!@loc @@ TacInductionDestruct(true,true,ic)) | IDENT "destruct"; icl = induction_clause_list -> - TacAtom (!@loc, TacInductionDestruct(false,false,icl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacInductionDestruct(false,false,icl)) | IDENT "edestruct"; icl = induction_clause_list -> - TacAtom (!@loc, TacInductionDestruct(false,true,icl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacInductionDestruct(false,true,icl)) (* Equality and inversion *) | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t)) + cl = clause_dft_concl; t=by_tactic -> TacAtom (Loc.tag ~loc:!@loc @@ TacRewrite (false,l,cl,t)) | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (true,l,cl,t)) + cl = clause_dft_concl; t=by_tactic -> TacAtom (Loc.tag ~loc:!@loc @@ TacRewrite (true,l,cl,t)) | IDENT "dependent"; k = [ IDENT "simple"; IDENT "inversion" -> SimpleInversion | IDENT "inversion" -> FullInversion | IDENT "inversion_clear" -> FullInversionClear ]; hyp = quantified_hypothesis; ids = as_or_and_ipat; co = OPT ["with"; c = constr -> c] -> - TacAtom (!@loc, TacInversion (DepInversion (k,co,ids),hyp)) + TacAtom (Loc.tag ~loc:!@loc @@ TacInversion (DepInversion (k,co,ids),hyp)) | IDENT "simple"; IDENT "inversion"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - TacAtom (!@loc, TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) + TacAtom (Loc.tag ~loc:!@loc @@ TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) | IDENT "inversion"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - TacAtom (!@loc, TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) + TacAtom (Loc.tag ~loc:!@loc @@ TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) | IDENT "inversion_clear"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - TacAtom (!@loc, TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) + TacAtom (Loc.tag ~loc:!@loc @@ TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) | IDENT "inversion"; hyp = quantified_hypothesis; "using"; c = constr; cl = in_hyp_list -> - TacAtom (!@loc, TacInversion (InversionUsing (c,cl), hyp)) + TacAtom (Loc.tag ~loc:!@loc @@ TacInversion (InversionUsing (c,cl), hyp)) (* Conversion *) | IDENT "red"; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Red false, cl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Red false, cl)) | IDENT "hnf"; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Hnf, cl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Hnf, cl)) | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Simpl (all_with d, po), cl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Simpl (all_with d, po), cl)) | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Cbv s, cl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Cbv s, cl)) | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Cbn s, cl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Cbn s, cl)) | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Lazy s, cl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Lazy s, cl)) | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Cbv (all_with delta), cl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Cbv (all_with delta), cl)) | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (CbvVm po, cl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (CbvVm po, cl)) | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (CbvNative po, cl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (CbvNative po, cl)) | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Unfold ul, cl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Unfold ul, cl)) | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Fold l, cl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Fold l, cl)) | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Pattern pl, cl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Pattern pl, cl)) (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) | IDENT "change"; (oc,c) = conversion; cl = clause_dft_concl -> let p,cl = merge_occurrences (!@loc) cl oc in - TacAtom (!@loc, TacChange (p,c,cl)) + TacAtom (Loc.tag ~loc:!@loc @@ TacChange (p,c,cl)) ] ] ; END;; diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index a619575591..580c21d40e 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -51,7 +51,7 @@ let pr_global x = Nametab.pr_global_env Id.Set.empty x type 'a grammar_tactic_prod_item_expr = | TacTerm of string -| TacNonTerm of Loc.t * 'a * Names.Id.t option +| TacNonTerm of ('a * Names.Id.t option) Loc.located type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list @@ -149,7 +149,7 @@ type 'a extra_genarg_printer = let pr_or_by_notation f = function | AN v -> f v - | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc + | ByNotation (_,(s,sc)) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc let pr_located pr (loc,x) = pr x @@ -162,8 +162,8 @@ type 'a extra_genarg_printer = | NamedHyp id -> pr_id id let pr_binding prc = function - | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c) - | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) + | loc, (NamedHyp id, c) -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c) + | loc, (AnonHyp n, c) -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) let pr_bindings prc prlc = function | ImplicitBindings l -> @@ -212,7 +212,7 @@ type 'a extra_genarg_printer = let rec tacarg_using_rule_token pr_gen = function | [] -> [] | TacTerm s :: l -> keyword s :: tacarg_using_rule_token pr_gen l - | TacNonTerm (_, (symb, arg), _) :: l -> + | TacNonTerm (_, ((symb, arg), _)) :: l -> pr_gen symb arg :: tacarg_using_rule_token pr_gen l let pr_tacarg_using_rule pr_gen l = @@ -252,7 +252,7 @@ type 'a extra_genarg_printer = let prods = (KNmap.find key !prnotation_tab).pptac_prods in let pr = function | TacTerm s -> primitive s - | TacNonTerm (_, symb, _) -> str (Printf.sprintf "(%s)" (pr_user_symbol symb)) + | TacNonTerm (_, (symb, _)) -> str (Printf.sprintf "(%s)" (pr_user_symbol symb)) in pr_sequence pr prods with Not_found -> @@ -264,9 +264,9 @@ type 'a extra_genarg_printer = let rec pack prods args = match prods, args with | [], [] -> [] | TacTerm s :: prods, args -> TacTerm s :: pack prods args - | TacNonTerm (_, _, None) :: prods, args -> pack prods args - | TacNonTerm (loc, symb, (Some _ as ido)) :: prods, arg :: args -> - TacNonTerm (loc, (symb, arg), ido) :: pack prods args + | TacNonTerm (_, (_, None)) :: prods, args -> pack prods args + | TacNonTerm (loc, (symb, (Some _ as ido))) :: prods, arg :: args -> + TacNonTerm (loc, ((symb, arg), ido)) :: pack prods args | _ -> raise Not_found in let prods = pack pp.pptac_prods l in @@ -276,7 +276,7 @@ type 'a extra_genarg_printer = let pr arg = str "_" in KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)" - let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.ghost, arg)) + let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.tag arg)) let is_genarg tag wit = let ArgT.Any tag = tag in @@ -332,28 +332,28 @@ type 'a extra_genarg_printer = pr_extend_gen (pr_farg prtac) let pr_raw_alias prc prlc prtac prpat lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.tag a)))) lev key args let pr_glob_alias prc prlc prtac prpat lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.tag a)))) lev key args (**********************************************************************) (* The tactic printer *) let strip_prod_binders_expr n ty = let rec strip_ty acc n ty = - match ty with - Constrexpr.CProdN(_,bll,a) -> + match ty.CAst.v with + Constrexpr.CProdN(bll,a) -> let nb = List.fold_left (fun i (nal,_,_) -> i + List.length nal) 0 bll in let bll = List.map (fun (x, _, y) -> x, y) bll in if nb >= n then (List.rev (bll@acc)), a else strip_ty (bll@acc) (n-nb) a - | _ -> error "Cannot translate fix tactic: not enough products" in + | _ -> user_err Pp.(str "Cannot translate fix tactic: not enough products") in strip_ty [] n ty let pr_ltac_or_var pr = function | ArgArg x -> pr x - | ArgVar (loc,id) -> pr_with_comments loc (pr_id id) + | ArgVar (loc,id) -> pr_with_comments ?loc (pr_id id) let pr_ltac_constant kn = if !Flags.in_debugger then pr_kn kn @@ -369,8 +369,8 @@ type 'a extra_genarg_printer = let pr_esubst prc l = let pr_qhyp = function - (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")" - | (_,NamedHyp id,c) -> + (_,(AnonHyp n,c)) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")" + | (_,(NamedHyp id,c)) -> str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")" in prlist_with_sep spc pr_qhyp l @@ -417,7 +417,7 @@ type 'a extra_genarg_printer = let pr_as_name = function | Anonymous -> mt () - | Name id -> spc () ++ keyword "as" ++ spc () ++ pr_lident (Loc.ghost,id) + | Name id -> spc () ++ keyword "as" ++ spc () ++ pr_lident (Loc.tag id) let pr_pose_as_style prc na c = spc() ++ prc c ++ pr_as_name na @@ -508,7 +508,7 @@ type 'a extra_genarg_printer = let pr_core_destruction_arg prc prlc = function | ElimOnConstr c -> pr_with_bindings prc prlc c - | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id) + | ElimOnIdent (loc,id) -> pr_with_comments ?loc (pr_id id) | ElimOnAnonHyp n -> int n let pr_destruction_arg prc prlc (clear_flag,h) = @@ -571,11 +571,11 @@ type 'a extra_genarg_printer = str "=>" ++ brk (1,4) ++ pr t)) | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t - let pr_funvar n = spc () ++ pr_name n + let pr_funvar n = spc () ++ Name.print n let pr_let_clause k pr (id,(bl,t)) = hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++ - str " :=" ++ brk (1,1) ++ pr (TacArg (Loc.ghost,t))) + str " :=" ++ brk (1,1) ++ pr (TacArg (Loc.tag t))) let pr_let_clauses recflag pr = function | hd::tl -> @@ -768,15 +768,15 @@ type 'a extra_genarg_printer = primitive "cofix" ++ spc () ++ pr_id id ++ spc() ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_cofix_tac l ) - | TacAssert (b,Some tac,ipat,c) -> + | TacAssert (ev,b,Some tac,ipat,c) -> hov 1 ( - primitive (if b then "assert" else "enough") ++ + primitive (if b then if ev then "eassert" else "assert" else if ev then "eenough" else "enough") ++ pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac ) - | TacAssert (_,None,ipat,c) -> + | TacAssert (ev,_,None,ipat,c) -> hov 1 ( - primitive "pose proof" + primitive (if ev then "epose proof" else "pose proof") ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ) | TacGeneralize l -> @@ -786,11 +786,11 @@ type 'a extra_genarg_printer = pr_with_occurrences pr.pr_constr cl ++ pr_as_name na) l ) - | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl -> - hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c) - | TacLetTac (na,c,cl,b,e) -> + | TacLetTac (ev,na,c,cl,true,_) when Locusops.is_nowhere cl -> + hov 1 (primitive (if ev then "epose" else "pose") ++ pr_pose pr.pr_constr pr.pr_lconstr na c) + | TacLetTac (ev,na,c,cl,b,e) -> hov 1 ( - (if b then primitive "set" else primitive "remember") ++ + primitive (if b then if ev then "eset" else "set" else if ev then "eremember" else "remember") ++ (if b then pr_pose pr.pr_constr pr.pr_lconstr na c else pr_pose_as_style pr.pr_constr na c) ++ pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++ @@ -1038,7 +1038,7 @@ type 'a extra_genarg_printer = | TacId l -> keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom | TacAtom (loc,t) -> - pr_with_comments loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom + pr_with_comments ?loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom | TacArg(_,Tacexp e) -> pr.pr_tactic (latom,E) e, latom | TacArg(_,ConstrMayEval (ConstrTerm c)) -> @@ -1049,19 +1049,19 @@ type 'a extra_genarg_printer = primitive "fresh" ++ pr_fresh_ids l, latom | TacArg(_,TacGeneric arg) -> pr.pr_generic arg, latom - | TacArg(_,TacCall(loc,f,[])) -> + | TacArg(_,TacCall(loc,(f,[]))) -> pr.pr_reference f, latom - | TacArg(_,TacCall(loc,f,l)) -> - pr_with_comments loc (hov 1 ( + | TacArg(_,TacCall(loc,(f,l))) -> + pr_with_comments ?loc (hov 1 ( pr.pr_reference f ++ spc () ++ prlist_with_sep spc pr_tacarg l)), lcall | TacArg (_,a) -> pr_tacarg a, latom - | TacML (loc,s,l) -> - pr_with_comments loc (pr.pr_extend 1 s l), lcall - | TacAlias (loc,kn,l) -> - pr_with_comments loc (pr.pr_alias (level_of inherited) kn l), latom + | TacML (loc,(s,l)) -> + pr_with_comments ?loc (pr.pr_extend 1 s l), lcall + | TacAlias (loc,(kn,l)) -> + pr_with_comments ?loc (pr.pr_alias (level_of inherited) kn l), latom ) in if prec_less prec inherited then strm @@ -1079,17 +1079,17 @@ type 'a extra_genarg_printer = | TacNumgoals -> keyword "numgoals" | (TacCall _|Tacexp _ | TacGeneric _) as a -> - hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.ghost,a)))) + hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.tag a)))) in pr_tac let strip_prod_binders_glob_constr n (ty,_) = let rec strip_ty acc n ty = if Int.equal n 0 then (List.rev acc, (ty,None)) else - match ty with - Glob_term.GProd(loc,na,Explicit,a,b) -> - strip_ty (([Loc.ghost,na],(a,None))::acc) (n-1) b - | _ -> error "Cannot translate fix tactic: not enough products" in + match ty.CAst.v with + Glob_term.GProd(na,Explicit,a,b) -> + strip_ty (([Loc.tag na],(a,None))::acc) (n-1) b + | _ -> user_err Pp.(str "Cannot translate fix tactic: not enough products") in strip_ty [] n ty let raw_printers = @@ -1159,8 +1159,8 @@ type 'a extra_genarg_printer = if n=0 then (List.rev acc, EConstr.of_constr ty) else match Term.kind_of_term ty with Term.Prod(na,a,b) -> - strip_ty (([Loc.ghost,na],EConstr.of_constr a)::acc) (n-1) b - | _ -> error "Cannot translate fix tactic: not enough products" in + strip_ty (([Loc.tag na],EConstr.of_constr a)::acc) (n-1) b + | _ -> user_err Pp.(str "Cannot translate fix tactic: not enough products") in strip_ty [] n ty let pr_atomic_tactic_level env sigma n t = @@ -1210,7 +1210,7 @@ let declare_extra_genarg_pprule wit (h : 'c extra_genarg_printer) = begin match wit with | ExtraArg s -> () - | _ -> error "Can declare a pretty-printing rule only for extra argument types." + | _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.") end; let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in let g x = @@ -1254,7 +1254,7 @@ let () = wit_clause_dft_concl (pr_clauses (Some true) pr_lident) (pr_clauses (Some true) pr_lident) - (pr_clauses (Some true) (fun id -> pr_lident (Loc.ghost,id))) + (pr_clauses (Some true) (fun id -> pr_lident (Loc.tag id))) ; Genprint.register_print0 wit_constr diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 433f342c4f..19bdf2d49f 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -21,7 +21,7 @@ open Ppextend type 'a grammar_tactic_prod_item_expr = | TacTerm of string -| TacNonTerm of Loc.t * 'a * Names.Id.t option +| TacNonTerm of ('a * Names.Id.t option) Loc.located type 'a raw_extra_genarg_printer = (constr_expr -> std_ppcmds) -> diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index a853576f25..3ff7b53c7e 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -129,7 +129,7 @@ let to_ltacprof_results xml = let feedback_results results = Feedback.(feedback - (Custom (Loc.dummy_loc, "ltacprof_results", of_ltacprof_results results))) + (Custom (None, "ltacprof_results", of_ltacprof_results results))) (* ************** pretty printing ************************************* *) @@ -249,7 +249,7 @@ let string_of_call ck = | Tacexpr.LtacVarCall (id, t) -> Nameops.pr_id id | Tacexpr.LtacAtomCall te -> (Pptactic.pr_glob_tactic (Global.env ()) - (Tacexpr.TacAtom (Loc.ghost, te))) + (Tacexpr.TacAtom (Loc.tag te))) | Tacexpr.LtacConstrInterp (c, _) -> pr_glob_constr_env (Global.env ()) c | Tacexpr.LtacMLCall te -> @@ -411,8 +411,7 @@ let _ = Declaremods.append_end_library_hook do_print_results_at_close let _ = let open Goptions in declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "Ltac Profiling"; optkey = ["Ltac"; "Profiling"]; optread = get_profiling; diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 5630a2d7b6..dadcfb9f26 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -55,22 +55,16 @@ let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] -let make_dir l = DirPath.make (List.rev_map Id.of_string l) +let lazy_find_reference dir s = + let gr = lazy (Coqlib.coq_reference "generalized rewriting" dir s) in + fun () -> Lazy.force gr -let try_find_global_reference dir s = - let sp = Libnames.make_path (make_dir ("Coq"::dir)) (Id.of_string s) in - try Nametab.global_of_path sp - with Not_found -> - anomaly (str "Global reference " ++ str s ++ str " not found in generalized rewriting") - -let find_reference dir s = - let gr = lazy (try_find_global_reference dir s) in - fun () -> Lazy.force gr +let find_reference dir s = Coqlib.coq_reference "generalized rewriting" dir s type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) let find_global dir s = - let gr = lazy (try_find_global_reference dir s) in + let gr = lazy (find_reference dir s) in fun (evd,cstrs) -> let sigma = Sigma.Unsafe.of_evar_map evd in let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force gr) in @@ -81,7 +75,7 @@ let find_global dir s = (** Global constants. *) -let coq_eq_ref = find_reference ["Init"; "Logic"] "eq" +let coq_eq_ref = lazy_find_reference ["Init"; "Logic"] "eq" let coq_eq = find_global ["Init"; "Logic"] "eq" let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" let coq_all = find_global ["Init"; "Logic"] "all" @@ -158,11 +152,11 @@ end) = struct let forall_relation = find_global morphisms "forall_relation" let pointwise_relation = find_global morphisms "pointwise_relation" - let forall_relation_ref = find_reference morphisms "forall_relation" - let pointwise_relation_ref = find_reference morphisms "pointwise_relation" + let forall_relation_ref = lazy_find_reference morphisms "forall_relation" + let pointwise_relation_ref = lazy_find_reference morphisms "pointwise_relation" let respectful = find_global morphisms "respectful" - let respectful_ref = find_reference morphisms "respectful" + let respectful_ref = lazy_find_reference morphisms "respectful" let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation" @@ -174,8 +168,8 @@ end) = struct let rewrite_relation_class = find_global relation_classes "RewriteRelation" - let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper")) - let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy")) + let proper_class = lazy (class_info (find_reference morphisms "Proper")) + let proper_proxy_class = lazy (class_info (find_reference morphisms "ProperProxy")) let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) @@ -241,7 +235,7 @@ end) = struct let liftarg = mkLambda (na, ty, arg) in let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs - else error "build_signature: no constraint can apply on a dependent argument" + else user_err Pp.(str "build_signature: no constraint can apply on a dependent argument") | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") | _, [] -> (match finalcstr with @@ -478,7 +472,7 @@ type hypinfo = { let get_symmetric_proof b = if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof -let error_no_relation () = error "Cannot find a relation to rewrite." +let error_no_relation () = user_err Pp.(str "Cannot find a relation to rewrite.") let rec decompose_app_rel env evd t = (** Head normalize for compatibility with the old meta mechanism *) @@ -531,7 +525,7 @@ let decompose_applied_relation env sigma (c,l) = let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with | Some c -> c - | None -> error "Cannot find an homogeneous relation to rewrite." + | None -> user_err Pp.(str "Cannot find an homogeneous relation to rewrite.") let rewrite_db = "rewrite" @@ -757,17 +751,23 @@ let default_flags = { under_lambdas = true; on_morphisms = true; } let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None -let make_eq () = -(*FIXME*) EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ())) -let make_eq_refl () = -(*FIXME*) EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq_refl ())) +let new_global (evars, cstrs) gr = + let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map evars) gr + in (Sigma.to_evar_map sigma, cstrs), c + +let make_eq sigma = + new_global sigma (Coqlib.build_coq_eq ()) +let make_eq_refl sigma = + new_global sigma (Coqlib.build_coq_eq_refl ()) -let get_rew_prf r = match r.rew_prf with - | RewPrf (rel, prf) -> rel, prf +let get_rew_prf evars r = match r.rew_prf with + | RewPrf (rel, prf) -> evars, (rel, prf) | RewCast c -> - let rel = mkApp (make_eq (), [| r.rew_car |]) in - rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]), - c, mkApp (rel, [| r.rew_from; r.rew_to |])) + let evars, eq = make_eq evars in + let evars, eq_refl = make_eq_refl evars in + let rel = mkApp (eq, [| r.rew_car |]) in + evars, (rel, mkCast (mkApp (eq_refl, [| r.rew_car; r.rew_from |]), + c, mkApp (rel, [| r.rew_from; r.rew_to |]))) let poly_subrelation sort = if sort then PropGlobal.subrelation else TypeGlobal.subrelation @@ -833,11 +833,12 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev env evars carrier relation x in [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' | Some r -> - [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, + let evars, proof = get_rew_prf evars r in + [ snd proof; r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs') | None -> if not (Option.is_empty y) then - error "Cannot rewrite inside dependent arguments of a function"; + user_err Pp.(str "Cannot rewrite inside dependent arguments of a function"); x :: acc, x :: subst, evars, sigargs, x :: typeargs') ([], [], evars, sigargs, []) args args' in @@ -853,7 +854,8 @@ let apply_constraint env avoid car rel prf cstr res = | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res let coerce env avoid cstr res = - let rel, prf = get_rew_prf res in + let evars, (rel, prf) = get_rew_prf res.rew_evars res in + let res = { res with rew_evars = evars } in apply_constraint env avoid res.rew_car rel prf cstr res let apply_rule unify loccs : int pure_strategy = @@ -874,8 +876,7 @@ let apply_rule unify loccs : int pure_strategy = else if Termops.eq_constr (fst rew.rew_evars) t rew.rew_to then (occ, Identity) else let res = { rew with rew_car = ty } in - let rel, prf = get_rew_prf res in - let res = Success (apply_constraint env unfresh rew.rew_car rel prf cstr res) in + let res = Success (coerce env unfresh cstr res) in (occ, res) } @@ -1237,9 +1238,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = in let res = match res with - | Success r -> - let rel, prf = get_rew_prf r in - Success (apply_constraint env unfresh r.rew_car rel prf (prop,cstr) r) + | Success r -> Success (coerce env unfresh (prop,cstr) r) | Fail | Identity -> res in state, res | _ -> state, Fail @@ -1425,7 +1424,7 @@ module Strategies = let unfolded = try Tacred.try_red_product env sigma c with e when CErrors.noncritical e -> - error "fold: the term is not unfoldable !" + user_err Pp.(str "fold: the term is not unfoldable !") in try let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in @@ -1786,34 +1785,34 @@ let rec strategy_of_ast = function (* By default the strategy for "rewrite_db" is top-down *) -let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l) +let mkappc s l = CAst.make @@ CAppExpl ((None,(Libnames.Ident (Loc.tag @@ Id.of_string s)),None),l) let declare_an_instance n s args = - (((Loc.ghost,Name n),None), Explicit, - CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None), + (((Loc.tag @@ Name n),None), Explicit, + CAst.make @@ CAppExpl ((None, Qualid (Loc.tag @@ qualid_of_string s),None), args)) let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance global binders instance fields = new_instance (Flags.is_universe_polymorphism ()) - binders instance (Some (true, CRecord (Loc.ghost,fields))) + binders instance (Some (true, CAst.make @@ CRecord (fields))) ~global ~generalize:false ~refine:false Hints.empty_hint_info let declare_instance_refl global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" in anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "reflexivity"),lemma)] + [(Ident (Loc.tag @@ Id.of_string "reflexivity"),lemma)] let declare_instance_sym global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" in anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "symmetry"),lemma)] + [(Ident (Loc.tag @@ Id.of_string "symmetry"),lemma)] let declare_instance_trans global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" in anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "transitivity"),lemma)] + [(Ident (Loc.tag @@ Id.of_string "transitivity"),lemma)] let declare_relation ?(binders=[]) a aeq n refl symm trans = init_setoid (); @@ -1837,16 +1836,16 @@ let declare_relation ?(binders=[]) a aeq n refl symm trans = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in ignore( anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "PreOrder_Reflexive"), lemma1); - (Ident (Loc.ghost,Id.of_string "PreOrder_Transitive"),lemma3)]) + [(Ident (Loc.tag @@ Id.of_string "PreOrder_Reflexive"), lemma1); + (Ident (Loc.tag @@ Id.of_string "PreOrder_Transitive"),lemma3)]) | (None, Some lemma2, Some lemma3) -> let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in ignore( anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "PER_Symmetric"), lemma2); - (Ident (Loc.ghost,Id.of_string "PER_Transitive"),lemma3)]) + [(Ident (Loc.tag @@ Id.of_string "PER_Symmetric"), lemma2); + (Ident (Loc.tag @@ Id.of_string "PER_Transitive"),lemma3)]) | (Some lemma1, Some lemma2, Some lemma3) -> let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in @@ -1854,11 +1853,11 @@ let declare_relation ?(binders=[]) a aeq n refl symm trans = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), lemma1); - (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), lemma2); - (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), lemma3)]) + [(Ident (Loc.tag @@ Id.of_string "Equivalence_Reflexive"), lemma1); + (Ident (Loc.tag @@ Id.of_string "Equivalence_Symmetric"), lemma2); + (Ident (Loc.tag @@ Id.of_string "Equivalence_Transitive"), lemma3)]) -let cHole = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) +let cHole = CAst.make @@ CHole (None, Misctypes.IntroAnonymous, None) let proper_projection sigma r ty = let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) in @@ -1958,17 +1957,16 @@ let add_setoid global binders a aeq t n = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); - (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); - (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + [(Ident (Loc.tag @@ Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); + (Ident (Loc.tag @@ Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); + (Ident (Loc.tag @@ Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) let make_tactic name = let open Tacexpr in - let loc = Loc.ghost in let tacpath = Libnames.qualid_of_string name in - let tacname = Qualid (loc, tacpath) in - TacArg (loc, TacCall (loc, tacname, [])) + let tacname = Qualid (Loc.tag tacpath) in + TacArg (Loc.tag @@ TacCall (Loc.tag (tacname, []))) let add_morphism_infer glob m n = init_setoid (); @@ -2011,14 +2009,14 @@ let add_morphism glob binders m s n = let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = - (((Loc.ghost,Name instance_id),None), Explicit, - CAppExpl (Loc.ghost, - (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), + (((Loc.tag @@ Name instance_id),None), Explicit, + CAst.make @@ CAppExpl ( + (None, Qualid (Loc.tag @@ Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in ignore(new_instance ~global:glob poly binders instance - (Some (true, CRecord (Loc.ghost,[]))) + (Some (true, CAst.make @@ CRecord [])) ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) (** Bind to "rewrite" too *) @@ -2205,7 +2203,7 @@ let setoid_symmetry_in id = let rec split_last_two = function | [c1;c2] -> [],(c1, c2) | x::y::z -> let l,res = split_last_two (y::z) in x::l, res - | _ -> error "Cannot find an equivalence relation to rewrite." + | _ -> user_err Pp.(str "Cannot find an equivalence relation to rewrite.") in let others,(c1,c2) = split_last_two args in let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index b76009c997..e037bb4b26 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -268,11 +268,11 @@ let coerce_to_constr_list env v = List.map map l | None -> raise (CannotCoerceTo "a term list") -let coerce_to_intro_pattern_list loc env sigma v = +let coerce_to_intro_pattern_list ?loc env sigma v = match Value.to_list v with | None -> raise (CannotCoerceTo "an intro pattern list") | Some l -> - let map v = (loc, coerce_to_intro_pattern env sigma v) in + let map v = Loc.tag ?loc @@ coerce_to_intro_pattern env sigma v in List.map map l let coerce_to_hyp env sigma v = diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index 4a44f86d92..9883c03c46 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -75,7 +75,7 @@ val coerce_to_evaluable_ref : val coerce_to_constr_list : Environ.env -> Value.t -> constr list val coerce_to_intro_pattern_list : - Loc.t -> Environ.env -> Evd.evar_map -> Value.t -> Tacexpr.intro_patterns + ?loc:Loc.t -> Environ.env -> Evd.evar_map -> Value.t -> Tacexpr.intro_patterns val coerce_to_hyp : Environ.env -> Evd.evar_map -> Value.t -> Id.t diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 91262f6fd6..f44ccbd3b5 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -21,7 +21,7 @@ open Nameops type 'a grammar_tactic_prod_item_expr = 'a Pptactic.grammar_tactic_prod_item_expr = | TacTerm of string -| TacNonTerm of Loc.t * 'a * Names.Id.t option +| TacNonTerm of ('a * Names.Id.t option) Loc.located type raw_argument = string * string option type argument = Genarg.ArgT.any Extend.user_symbol @@ -60,7 +60,7 @@ let get_tacentry n m = else EntryName (rawwit Tacarg.wit_tactic, atactic n) let get_separator = function -| None -> error "Missing separator." +| None -> user_err Pp.(str "Missing separator.") | Some sep -> sep let rec parse_user_entry s sep = @@ -110,7 +110,7 @@ let get_tactic_entry n = else if 1<=n && n<5 then Pltac.tactic_expr, Some (Extend.Level (string_of_int n)) else - error ("Invalid Tactic Notation level: "^(string_of_int n)^".") + user_err Pp.(str ("Invalid Tactic Notation level: "^(string_of_int n)^".")) (**********************************************************************) (** State of the grammar extensions *) @@ -166,17 +166,17 @@ let add_tactic_entry (kn, ml, tg) state = TacGeneric arg in let l = List.map map l in - (TacAlias (loc,kn,l):raw_tactic_expr) + (TacAlias (Loc.tag ~loc (kn,l)):raw_tactic_expr) in let () = if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then - error "Notation for simple tactic must start with an identifier." + user_err Pp.(str "Notation for simple tactic must start with an identifier.") in let map = function | TacTerm s -> GramTerminal s - | TacNonTerm (loc, s, ido) -> + | TacNonTerm (loc, (s, ido)) -> let EntryName (typ, e) = prod_item_of_symbol tg.tacgram_level s in - GramNonTerminal (loc, Option.map (fun _ -> typ) ido, e) + GramNonTerminal (Loc.tag ?loc @@ (Option.map (fun _ -> typ) ido, e)) in let prods = List.map map tg.tacgram_prods in let rules = make_rule mkact prods in @@ -202,13 +202,13 @@ let register_tactic_notation_entry name entry = let interp_prod_item = function | TacTerm s -> TacTerm s - | TacNonTerm (loc, (nt, sep), ido) -> + | TacNonTerm (loc, ((nt, sep), ido)) -> let symbol = parse_user_entry nt sep in let interp s = function | None -> if String.Map.mem s !entry_names then String.Map.find s !entry_names else begin match ArgT.name s with - | None -> error ("Unknown entry "^s^".") + | None -> user_err Pp.(str ("Unknown entry "^s^".")) | Some arg -> arg end | Some n -> @@ -220,7 +220,7 @@ let interp_prod_item = function end in let symbol = interp_entry_name interp symbol in - TacNonTerm (loc, symbol, ido) + TacNonTerm (loc, (symbol, ido)) let make_fresh_key = let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in @@ -253,8 +253,8 @@ let pprule pa = { let check_key key = if Tacenv.check_alias key then - error "Conflicting tactic notations keys. This can happen when including \ - twice the same module." + user_err Pp.(str "Conflicting tactic notations keys. This can happen when including \ + twice the same module.") let cache_tactic_notation (_, tobj) = let key = tobj.tacobj_key in @@ -296,7 +296,7 @@ let inTacticGrammar : tactic_grammar_obj -> obj = let cons_production_parameter = function | TacTerm _ -> None -| TacNonTerm (_, _, ido) -> ido +| TacNonTerm (_, (_, ido)) -> ido let add_glob_tactic_notation local ~level prods forml ids tac = let parule = { @@ -334,10 +334,10 @@ let extend_atomic_tactic name entries = in let empty_value = function | TacTerm s -> raise NonEmptyArgument - | TacNonTerm (_, symb, _) -> + | TacNonTerm (_, (symb, _)) -> let EntryName (typ, e) = prod_item_of_symbol 0 symb in let Genarg.Rawwit wit = typ in - let inj x = TacArg (Loc.ghost, TacGeneric (Genarg.in_gen typ x)) in + let inj x = TacArg (Loc.tag @@ TacGeneric (Genarg.in_gen typ x)) in let default = epsilon_value inj e in match default with | None -> raise NonEmptyArgument @@ -351,7 +351,7 @@ let extend_atomic_tactic name entries = | Some (id, args) -> let args = List.map (fun a -> Tacexp a) args in let entry = { mltac_name = name; mltac_index = i } in - let body = TacML (Loc.ghost, entry, args) in + let body = TacML (Loc.tag (entry, args)) in Tacenv.register_ltac false false (Names.Id.of_string id) body in List.iteri add_atomic entries @@ -362,12 +362,12 @@ let add_ml_tactic_notation name ~level prods = let open Tacexpr in let get_id = function | TacTerm s -> None - | TacNonTerm (_, _, ido) -> ido + | TacNonTerm (_, (_, ido)) -> ido in let ids = List.map_filter get_id prods in let entry = { mltac_name = name; mltac_index = len - i - 1 } in - let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in - let tac = TacML (Loc.ghost, entry, List.map map ids) in + let map id = Reference (Misctypes.ArgVar (Loc.tag id)) in + let tac = TacML (Loc.tag (entry, List.map map ids)) in add_glob_tactic_notation false ~level prods true ids tac in List.iteri iter (List.rev prods); @@ -401,7 +401,7 @@ let create_ltac_quotation name cast (e, l) = entry), Atoken (CLexer.terminal ")")) in - let action _ v _ _ _ loc = cast (loc, v) in + let action _ v _ _ _ loc = cast (Some loc, v) in let gram = (level, assoc, [Rule (rule, action)]) in Pcoq.grammar_extend Pltac.tactic_arg None (None, [gram]) @@ -427,7 +427,7 @@ let register_ltac local tacl = let kn = Lib.make_kn id in let id_pp = pr_id id in let () = if is_defined_tac kn then - CErrors.user_err ~loc + CErrors.user_err ?loc (str "There is already an Ltac named " ++ id_pp ++ str".") in let is_shadowed = @@ -444,7 +444,7 @@ let register_ltac local tacl = let kn = try Nametab.locate_tactic (snd (qualid_of_reference ident)) with Not_found -> - CErrors.user_err ~loc + CErrors.user_err ?loc (str "There is no Ltac named " ++ pr_reference ident ++ str ".") in UpdateTac kn, body @@ -502,7 +502,7 @@ let print_ltacs () = | Tacexpr.TacFun (l, t) -> (l, t) | _ -> ([], body) in - let pr_ltac_fun_arg n = spc () ++ pr_name n in + let pr_ltac_fun_arg n = spc () ++ Name.print n in hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l) in Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index dac62dad33..07aa7ad82e 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -20,7 +20,7 @@ val register_ltac : locality_flag -> Tacexpr.tacdef_body list -> unit type 'a grammar_tactic_prod_item_expr = 'a Pptactic.grammar_tactic_prod_item_expr = | TacTerm of string -| TacNonTerm of Loc.t * 'a * Names.Id.t option +| TacNonTerm of ('a * Names.Id.t option) Loc.located type raw_argument = string * string option (** An argument type as provided in Tactic notations, i.e. a string like diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 8aefe76059..b78dc37426 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -141,10 +141,10 @@ type 'a gen_atomic_tactic_expr = | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list | TacMutualCofix of Id.t * (Id.t * 'trm) list | TacAssert of - bool * 'tacexpr option option * + evars_flag * bool * 'tacexpr option option * 'dtrm intro_pattern_expr located option * 'trm | TacGeneralize of ('trm with_occurrences * Name.t) list - | TacLetTac of Name.t * 'trm * 'nam clause_expr * letin_flag * + | TacLetTac of evars_flag * Name.t * 'trm * 'nam clause_expr * letin_flag * intro_pattern_naming_expr located option (* Derived basic tactics *) @@ -184,8 +184,7 @@ type 'a gen_tactic_arg = | TacGeneric of 'lev generic_argument | ConstrMayEval of ('trm,'cst,'pat) may_eval | Reference of 'ref - | TacCall of Loc.t * 'ref * - 'a gen_tactic_arg list + | TacCall of ('ref * 'a gen_tactic_arg list) Loc.located | TacFreshId of string or_var list | Tacexp of 'tacexpr | TacPretype of 'trm @@ -207,7 +206,7 @@ constraint 'a = < 'r : ltac refs, 'n : idents, 'l : levels *) and 'a gen_tactic_expr = - | TacAtom of Loc.t * 'a gen_atomic_tactic_expr + | TacAtom of ('a gen_atomic_tactic_expr) Loc.located | TacThen of 'a gen_tactic_expr * 'a gen_tactic_expr @@ -266,9 +265,9 @@ and 'a gen_tactic_expr = | TacArg of 'a gen_tactic_arg located | TacSelect of goal_selector * 'a gen_tactic_expr (* For ML extensions *) - | TacML of Loc.t * ml_tactic_entry * 'a gen_tactic_arg list + | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located (* For syntax extensions *) - | TacAlias of Loc.t * KerName.t * 'a gen_tactic_arg list + | TacAlias of (KerName.t * 'a gen_tactic_arg list) Loc.located constraint 'a = < term:'t; @@ -389,7 +388,7 @@ type ltac_call_kind = | LtacVarCall of Id.t * glob_tactic_expr | LtacConstrInterp of Glob_term.glob_constr * Pretyping.ltac_var_map -type ltac_trace = (Loc.t * ltac_call_kind) list +type ltac_trace = ltac_call_kind Loc.located list type tacdef_body = | TacticDefinition of Id.t Loc.located * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 75227def0f..0096abfa69 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -31,8 +31,6 @@ open Locus (** Globalization of tactic expressions : Conversion from [raw_tactic_expr] to [glob_tactic_expr] *) -let dloc = Loc.ghost - let error_tactic_expected ?loc = user_err ?loc (str "Tactic expected.") @@ -41,13 +39,12 @@ let error_tactic_expected ?loc = type glob_sign = Genintern.glob_sign = { ltacvars : Id.Set.t; (* ltac variables and the subset of vars introduced by Intro/Let/... *) - genv : Environ.env } - -let fully_empty_glob_sign = - { ltacvars = Id.Set.empty; genv = Environ.empty_env } + genv : Environ.env; + extra : Genintern.Store.t; +} -let make_empty_glob_sign () = - { fully_empty_glob_sign with genv = Global.env () } +let fully_empty_glob_sign = Genintern.empty_glob_sign Environ.empty_env +let make_empty_glob_sign () = Genintern.empty_glob_sign (Global.env ()) (* We have identifier <| global_reference <| constr *) @@ -74,16 +71,16 @@ let intern_name l ist = function let strict_check = ref false -let adjust_loc loc = if !strict_check then dloc else loc +let adjust_loc loc = if !strict_check then None else loc (* Globalize a name which must be bound -- actually just check it is bound *) let intern_hyp ist (loc,id as locid) = if not !strict_check then locid else if find_ident id ist then - (dloc,id) + Loc.tag id else - Pretype_errors.error_var_not_found ~loc id + Pretype_errors.error_var_not_found ?loc id let intern_or_var f ist = function | ArgVar locid -> ArgVar (intern_hyp ist locid) @@ -110,19 +107,19 @@ let intern_ltac_variable ist = function let intern_constr_reference strict ist = function | Ident (_,id) as r when not strict && find_hyp id ist -> - GVar (dloc,id), Some (CRef (r,None)) + (CAst.make @@ GVar id), Some (CAst.make @@ CRef (r,None)) | Ident (_,id) as r when find_var id ist -> - GVar (dloc,id), if strict then None else Some (CRef (r,None)) + (CAst.make @@ GVar id), if strict then None else Some (CAst.make @@ CRef (r,None)) | r -> let loc,_ as lqid = qualid_of_reference r in - GRef (loc,locate_global_with_alias lqid,None), - if strict then None else Some (CRef (r,None)) + CAst.make @@ GRef (locate_global_with_alias lqid,None), + if strict then None else Some (CAst.make @@ CRef (r,None)) (* Internalize an isolated reference in position of tactic *) let intern_isolated_global_tactic_reference r = let (loc,qid) = qualid_of_reference r in - TacCall (loc,ArgArg (loc,locate_tactic qid),[]) + TacCall (Loc.tag ?loc (ArgArg (loc,locate_tactic qid),[])) let intern_isolated_tactic_reference strict ist r = (* An ltac reference *) @@ -192,12 +189,13 @@ let intern_binding_name ist x = and if a term w/o ltac vars, check the name is indeed quantified *) x -let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env} c = +let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env; extra} c = let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in let ltacvars = { Constrintern.ltac_vars = lfun; ltac_bound = Id.Set.empty; + ltac_extra = extra; } in let c' = warn (Constrintern.intern_gen scope ~allow_patvar ~ltacvars env) c @@ -208,8 +206,8 @@ let intern_constr = intern_constr_gen false false let intern_type = intern_constr_gen false true (* Globalize bindings *) -let intern_binding ist (loc,b,c) = - (loc,intern_binding_name ist b,intern_constr ist c) +let intern_binding ist (loc,(b,c)) = + (loc,(intern_binding_name ist b,intern_constr ist c)) let intern_bindings ist = function | NoBindings -> NoBindings @@ -254,7 +252,7 @@ and intern_or_and_intro_pattern lf ist = function let intern_or_and_intro_pattern_loc lf ist = function | ArgVar (_,id) as x -> if find_var id ist then x - else error "Disjunctive/conjunctive introduction pattern expected." + else user_err Pp.(str "Disjunctive/conjunctive introduction pattern expected.") | ArgArg (loc,l) -> ArgArg (loc,intern_or_and_intro_pattern lf ist l) let intern_intro_pattern_naming_loc lf ist (loc,pat) = @@ -267,8 +265,8 @@ let intern_destruction_arg ist = function | clear,ElimOnIdent (loc,id) -> if !strict_check then (* If in a defined tactic, no intros-until *) - match intern_constr ist (CRef (Ident (dloc,id), None)) with - | GVar (loc,id),_ -> clear,ElimOnIdent (loc,id) + match intern_constr ist (CAst.make @@ CRef (Ident (Loc.tag id), None)) with + | {loc; CAst.v = GVar id}, _ -> clear,ElimOnIdent (loc,id) | c -> clear,ElimOnConstr (c,NoBindings) else clear,ElimOnIdent (loc,id) @@ -287,9 +285,9 @@ let intern_evaluable_global_reference ist r = let intern_evaluable_reference_or_by_notation ist = function | AN r -> intern_evaluable_global_reference ist r - | ByNotation (loc,ntn,sc) -> + | ByNotation (loc,(ntn,sc)) -> evaluable_of_global_reference ist.genv - (Notation.interp_notation_as_global_reference loc + (Notation.interp_notation_as_global_reference ?loc (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) (* Globalize a reduction expression *) @@ -313,6 +311,7 @@ let intern_constr_pattern ist ~as_type ~ltacvars pc = let ltacvars = { Constrintern.ltac_vars = ltacvars; ltac_bound = Id.Set.empty; + ltac_extra = ist.extra; } in let metas,pat = Constrintern.intern_constr_pattern ist.genv ~as_type ~ltacvars pc @@ -344,12 +343,16 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = let r = match r with | AN r -> r | _ -> Qualid (loc,qualid_of_path (path_of_global (smart_global r))) in - let sign = { Constrintern.ltac_vars = ist.ltacvars; Constrintern.ltac_bound = Id.Set.empty } in + let sign = { + Constrintern.ltac_vars = ist.ltacvars; + ltac_bound = Id.Set.empty; + ltac_extra = ist.extra; + } in let c = Constrintern.interp_reference sign r in - match c with - | GRef (_,r,None) -> + match c.CAst.v with + | GRef (r,None) -> Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) - | GVar (_,id) -> + | GVar id -> let r = evaluable_of_global_reference ist.genv (VarRef id) in Inl (ArgArg (r,None)) | _ -> @@ -357,7 +360,7 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = Inr (bound_names,(c,None),dummy_pat) in (l, match p with | Inl r -> interp_ref r - | Inr (CAppExpl(_,(None,r,None),[])) -> + | Inr { CAst.v = CAppExpl((None,r,None),[]) } -> (* We interpret similarly @ref and ref *) interp_ref (AN r) | Inr c -> @@ -368,13 +371,13 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = let dump_glob_red_expr = function | Unfold occs -> List.iter (fun (_, r) -> try - Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) + Dumpglob.add_glob ?loc:(loc_of_or_by_notation Libnames.loc_of_reference r) (Smartlocate.smart_global r) with e when CErrors.noncritical e -> ()) occs | Cbv grf | Lazy grf -> List.iter (fun r -> try - Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) + Dumpglob.add_glob ?loc:(loc_of_or_by_notation Libnames.loc_of_reference r) (Smartlocate.smart_global r) with e when CErrors.noncritical e -> ()) grf.rConst | _ -> () @@ -455,7 +458,7 @@ let rec intern_match_goal_hyps ist ?(as_type=false) lfun = function (* Utilities *) let extract_let_names lrc = let fold accu ((loc, name), _) = - if Id.Set.mem name accu then user_err ~loc + if Id.Set.mem name accu then user_err ?loc ~hdr:"glob_tactic" (str "This variable is bound several times.") else Id.Set.add name accu in @@ -486,17 +489,17 @@ let rec intern_atomic lf ist x = | TacMutualCofix (id,l) -> let f (id,c) = (intern_ident lf ist id,intern_type ist c) in TacMutualCofix (intern_ident lf ist id, List.map f l) - | TacAssert (b,otac,ipat,c) -> - TacAssert (b,Option.map (Option.map (intern_pure_tactic ist)) otac, + | TacAssert (ev,b,otac,ipat,c) -> + TacAssert (ev,b,Option.map (Option.map (intern_pure_tactic ist)) otac, Option.map (intern_intro_pattern lf ist) ipat, intern_constr_gen false (not (Option.is_empty otac)) ist c) | TacGeneralize cl -> TacGeneralize (List.map (fun (c,na) -> intern_constr_with_occurrences ist c, intern_name lf ist na) cl) - | TacLetTac (na,c,cls,b,eqpat) -> + | TacLetTac (ev,na,c,cls,b,eqpat) -> let na = intern_name lf ist na in - TacLetTac (na,intern_constr ist c, + TacLetTac (ev,na,intern_constr ist c, (clause_app (intern_hyp_location ist) cls),b, (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat)) @@ -546,7 +549,7 @@ and intern_tactic_seq onlytac ist = function | TacAtom (loc,t) -> let lf = ref ist.ltacvars in let t = intern_atomic lf ist t in - !lf, TacAtom (adjust_loc loc, t) + !lf, TacAtom (Loc.tag ?loc:(adjust_loc loc) t) | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun) | TacLetIn (isrec,l,u) -> let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in @@ -620,12 +623,12 @@ and intern_tactic_seq onlytac ist = function ist.ltacvars, TacSelect (sel, intern_pure_tactic ist tac) (* For extensions *) - | TacAlias (loc,s,l) -> + | TacAlias (loc,(s,l)) -> let l = List.map (intern_tacarg !strict_check false ist) l in - ist.ltacvars, TacAlias (loc,s,l) - | TacML (loc,opn,l) -> + ist.ltacvars, TacAlias (Loc.tag ?loc (s,l)) + | TacML (loc,(opn,l)) -> let _ignore = Tacenv.interp_ml_tactic opn in - ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_tacarg !strict_check false ist) l) + ist.ltacvars, TacML (loc, (opn,List.map (intern_tacarg !strict_check false ist) l)) and intern_tactic_as_arg loc onlytac ist a = match intern_tacarg !strict_check onlytac ist a with @@ -633,7 +636,7 @@ and intern_tactic_as_arg loc onlytac ist a = | TacGeneric _ as a -> TacArg (loc,a) | Tacexp a -> a | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> - if onlytac then error_tactic_expected ~loc else TacArg (loc,a) + if onlytac then error_tactic_expected ?loc else TacArg (loc,a) and intern_tactic_or_tacarg ist = intern_tactic false ist @@ -646,11 +649,11 @@ and intern_tactic_fun ist (var,body) = and intern_tacarg strict onlytac ist = function | Reference r -> intern_non_tactic_reference strict ist r | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) - | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f - | TacCall (loc,f,l) -> - TacCall (loc, + | TacCall (loc,(f,[])) -> intern_isolated_tactic_reference strict ist f + | TacCall (loc,(f,l)) -> + TacCall (Loc.tag ?loc ( intern_applied_tactic_reference ist f, - List.map (intern_tacarg !strict_check false ist) l) + List.map (intern_tacarg !strict_check false ist) l)) | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x) | TacPretype c -> TacPretype (intern_constr ist c) | TacNumgoals -> TacNumgoals @@ -708,15 +711,14 @@ let glob_tactic_env l env x = let ltacvars = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in Flags.with_option strict_check - (intern_pure_tactic - { ltacvars; genv = env }) + (intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars }) x let split_ltac_fun = function | TacFun (l,t) -> (l,t) | t -> ([],t) -let pr_ltac_fun_arg n = spc () ++ pr_name n +let pr_ltac_fun_arg n = spc () ++ Name.print n let print_ltac id = try diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli index 71ca354fa1..8ad52ca023 100644 --- a/plugins/ltac/tacintern.mli +++ b/plugins/ltac/tacintern.mli @@ -18,7 +18,9 @@ open Misctypes type glob_sign = Genintern.glob_sign = { ltacvars : Id.Set.t; - genv : Environ.env } + genv : Environ.env; + extra : Genintern.Store.t; +} val fully_empty_glob_sign : glob_sign diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index b8c021f188..594c4fa15f 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -200,8 +200,6 @@ end let print_top_val env v = Pptactic.pr_value Pptactic.ltop v -let dloc = Loc.ghost - let catching_error call_trace fail (e, info) = let inner_trace = Option.default [] (Exninfo.get info ltac_trace_info) @@ -314,7 +312,7 @@ let append_trace trace v = (* Dynamically check that an argument is a tactic *) let coerce_to_tactic loc id v = let v = Value.normalize v in - let fail () = user_err ~loc + let fail () = user_err ?loc (str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") in let v = Value.normalize v in @@ -325,7 +323,7 @@ let coerce_to_tactic loc id v = | _ -> fail () else fail () -let intro_pattern_of_ident id = (Loc.ghost, IntroNaming (IntroIdentifier id)) +let intro_pattern_of_ident id = (Loc.tag @@ IntroNaming (IntroIdentifier id)) let value_of_ident id = in_gen (topwit wit_intro_pattern) (intro_pattern_of_ident id) @@ -369,22 +367,22 @@ let debugging_exception_step ist signal_anomaly e pp = debugging_step ist (fun () -> pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) -let error_ltac_variable loc id env v s = - user_err ~loc (str "Ltac variable " ++ pr_id id ++ +let error_ltac_variable ?loc id env v s = + user_err ?loc (str "Ltac variable " ++ pr_id id ++ strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ strbrk "which cannot be coerced to " ++ str s ++ str".") (* Raise Not_found if not in interpretation sign *) let try_interp_ltac_var coerce ist env (loc,id) = let v = Id.Map.find id ist.lfun in - try coerce v with CannotCoerceTo s -> error_ltac_variable loc id env v s + try coerce v with CannotCoerceTo s -> error_ltac_variable ?loc id env v s let interp_ltac_var coerce ist env locid = try try_interp_ltac_var coerce ist env locid with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time") let interp_ident ist env sigma id = - try try_interp_ltac_var (coerce_var_to_ident false env sigma) ist (Some (env,sigma)) (dloc,id) + try try_interp_ltac_var (coerce_var_to_ident false env sigma) ist (Some (env,sigma)) (Loc.tag id) with Not_found -> id (* Interprets an optional identifier, bound or fresh *) @@ -403,7 +401,7 @@ let interp_intro_pattern_naming_var loc ist env sigma id = let interp_int ist locid = try try_interp_ltac_var coerce_to_int ist None locid with Not_found -> - user_err ~loc:(fst locid) ~hdr:"interp_int" + user_err ?loc:(fst locid) ~hdr:"interp_int" (str "Unbound variable " ++ pr_id (snd locid) ++ str".") let interp_int_or_var ist = function @@ -426,7 +424,7 @@ let interp_hyp ist env sigma (loc,id as locid) = with Not_found -> (* Then look if bound in the proof context at calling time *) if is_variable env id then id - else Loc.raise ~loc (Logic.RefinerError (Logic.NoSuchHyp id)) + else Loc.raise ?loc (Logic.RefinerError (Logic.NoSuchHyp id)) let interp_hyp_list_as_list ist env sigma (loc,id as x) = try coerce_to_hyp_list env sigma (Id.Map.find id ist.lfun) @@ -442,7 +440,7 @@ let interp_reference ist env sigma = function with Not_found -> try VarRef (get_id (Environ.lookup_named id env)) - with Not_found -> error_global_not_found ~loc (qualid_of_ident id) + with Not_found -> error_global_not_found ?loc (qualid_of_ident id) let try_interp_evaluable env (loc, id) = let v = Environ.lookup_named id env in @@ -458,14 +456,14 @@ let interp_evaluable ist env sigma = function with Not_found -> match r with | EvalConstRef _ -> r - | _ -> error_global_not_found ~loc (qualid_of_ident id) + | _ -> error_global_not_found ?loc (qualid_of_ident id) end | ArgArg (r,None) -> r | ArgVar (loc, id) -> try try_interp_ltac_var (coerce_to_evaluable_ref env sigma) ist (Some (env,sigma)) (loc, id) with Not_found -> try try_interp_evaluable env (loc, id) - with Not_found -> error_global_not_found ~loc (qualid_of_ident id) + with Not_found -> error_global_not_found ?loc (qualid_of_ident id) (* Interprets an hypothesis name *) let interp_occurrences ist occs = @@ -524,7 +522,7 @@ let extract_ids ids lfun = if has_type v (topwit wit_intro_pattern) then let (_, ipat) = out_gen (topwit wit_intro_pattern) v in if Id.List.mem id ids then accu - else accu @ intropattern_ids (dloc, ipat) + else accu @ intropattern_ids (Loc.tag ipat) else accu in Id.Map.fold fold lfun [] @@ -534,7 +532,7 @@ let default_fresh_id = Id.of_string "H" let interp_fresh_id ist env sigma l = let extract_ident ist env sigma id = try try_interp_ltac_var (coerce_to_ident_not_fresh env sigma) - ist (Some (env,sigma)) (dloc,id) + ist (Some (env,sigma)) (Loc.tag id) with Not_found -> id in let ids = List.map_filter (function ArgVar (_, id) -> Some id | _ -> None) l in let avoid = match TacStore.get ist.extra f_avoid_ids with @@ -587,6 +585,7 @@ let interp_uconstr ist env sigma = function let ltacvars = { Constrintern.ltac_vars = Id.(Set.union (Map.domain typed) (Map.domain untyped)); ltac_bound = Id.Map.domain ist.lfun; + ltac_extra = Genintern.Store.empty; } in { closure ; term = intern_gen WithoutTypeConstraint ~ltacvars env ce } @@ -614,6 +613,7 @@ let interp_gen kind ist allow_patvar flags env sigma (c,ce) = let ltacvars = { ltac_vars = constr_context; ltac_bound = Id.Map.domain ist.lfun; + ltac_extra = Genintern.Store.empty; } in let kind_for_intern = match kind with OfType _ -> WithoutTypeConstraint | _ -> kind in @@ -672,10 +672,7 @@ let pure_open_constr_flags = { expand_evars = false } (* Interprets an open constr *) -let interp_open_constr ?(expected_type=WithoutTypeConstraint) ist env sigma c = - let flags = - if expected_type == WithoutTypeConstraint then open_constr_no_classes_flags () - else open_constr_use_classes_flags () in +let interp_open_constr ?(expected_type=WithoutTypeConstraint) ?(flags=open_constr_no_classes_flags ()) ist env sigma c = interp_gen expected_type ist false flags env sigma c let interp_pure_open_constr ist = @@ -692,7 +689,7 @@ let interp_typed_pattern ist env sigma (_,c,_) = let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = let try_expand_ltac_var sigma x = try match dest_fun x with - | GVar (_,id), _ -> + | { CAst.v = GVar id }, _ -> let v = Id.Map.find id ist.lfun in sigma, List.map inj_fun (coerce_to_constr_list env v) | _ -> @@ -734,7 +731,7 @@ let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = Inr (pattern_of_constr env sigma (EConstr.to_constr sigma c)) in (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id) with Not_found -> - error_global_not_found ~loc (qualid_of_ident id)) + error_global_not_found ?loc (qualid_of_ident id)) | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) | Inr c -> Inr (interp_typed_pattern ist env sigma c) in interp_occurrences ist occs, p @@ -792,7 +789,7 @@ let interp_may_eval f ist env sigma = function !evdref , c with | Not_found -> - user_err ~loc ~hdr:"interp_may_eval" + user_err ?loc ~hdr:"interp_may_eval" (str "Unbound context identifier" ++ pr_id s ++ str".")) | ConstrTypeOf c -> let (sigma,c_interp) = f ist env sigma c in @@ -934,7 +931,7 @@ and interp_or_and_intro_pattern ist env sigma = function and interp_intro_pattern_list_as_list ist env sigma = function | [loc,IntroNaming (IntroIdentifier id)] as l -> - (try sigma, coerce_to_intro_pattern_list loc env sigma (Id.Map.find id ist.lfun) + (try sigma, coerce_to_intro_pattern_list ?loc env sigma (Id.Map.find id ist.lfun) with Not_found | CannotCoerceTo _ -> List.fold_map (interp_intro_pattern ist env) sigma l) | l -> List.fold_map (interp_intro_pattern ist env) sigma l @@ -949,7 +946,7 @@ let interp_or_and_intro_pattern_option ist env sigma = function (match coerce_to_intro_pattern env sigma (Id.Map.find id ist.lfun) with | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l) | _ -> - user_err ~loc (str "Cannot coerce to a disjunctive/conjunctive pattern.")) + user_err ?loc (str "Cannot coerce to a disjunctive/conjunctive pattern.")) | Some (ArgArg (loc,l)) -> let sigma,l = interp_or_and_intro_pattern ist env sigma l in sigma, Some (loc,l) @@ -970,19 +967,19 @@ let interp_binding_name ist sigma = function (* If a name is bound, it has to be a quantified hypothesis *) (* user has to use other names for variables if these ones clash with *) (* a name intented to be used as a (non-variable) identifier *) - try try_interp_ltac_var (coerce_to_quantified_hypothesis sigma) ist None(dloc,id) + try try_interp_ltac_var (coerce_to_quantified_hypothesis sigma) ist None(Loc.tag id) with Not_found -> NamedHyp id let interp_declared_or_quantified_hypothesis ist env sigma = function | AnonHyp n -> AnonHyp n | NamedHyp id -> try try_interp_ltac_var - (coerce_to_decl_or_quant_hyp env sigma) ist (Some (env,sigma)) (dloc,id) + (coerce_to_decl_or_quant_hyp env sigma) ist (Some (env,sigma)) (Loc.tag id) with Not_found -> NamedHyp id -let interp_binding ist env sigma (loc,b,c) = +let interp_binding ist env sigma (loc,(b,c)) = let sigma, c = interp_open_constr ist env sigma c in - sigma, (loc,interp_binding_name ist sigma b,c) + sigma, (loc,(interp_binding_name ist sigma b,c)) let interp_bindings ist env sigma = function | NoBindings -> @@ -996,7 +993,7 @@ let interp_bindings ist env sigma = function let interp_constr_with_bindings ist env sigma (c,bl) = let sigma, bl = interp_bindings ist env sigma bl in - let sigma, c = interp_open_constr ist env sigma c in + let sigma, c = interp_constr ist env sigma c in sigma, (c,bl) let interp_open_constr_with_bindings ist env sigma (c,bl) = @@ -1005,14 +1002,14 @@ let interp_open_constr_with_bindings ist env sigma (c,bl) = sigma, (c, bl) let loc_of_bindings = function -| NoBindings -> Loc.ghost +| NoBindings -> None | ImplicitBindings l -> loc_of_glob_constr (fst (List.last l)) -| ExplicitBindings l -> pi1 (List.last l) +| ExplicitBindings l -> fst (List.last l) let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) = let loc1 = loc_of_glob_constr c in let loc2 = loc_of_bindings bl in - let loc = if Loc.is_ghost loc2 then loc1 else Loc.merge loc1 loc2 in + let loc = Loc.merge_opt loc1 loc2 in let f = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = interp_open_constr_with_bindings ist env sigma cb in @@ -1025,12 +1022,12 @@ let interp_destruction_arg ist gl arg = | keep,ElimOnConstr c -> keep,ElimOnConstr { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_constr_with_bindings ist env sigma c in + let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in Sigma.Unsafe.of_pair (c, sigma) } | keep,ElimOnAnonHyp n as x -> x | keep,ElimOnIdent (loc,id) -> - let error () = user_err ~loc + let error () = user_err ?loc (strbrk "Cannot coerce " ++ pr_id id ++ strbrk " neither to a quantified hypothesis nor to a term.") in @@ -1041,7 +1038,7 @@ let interp_destruction_arg ist gl arg = (keep, ElimOnConstr { delayed = begin fun env sigma -> try Sigma.here (constr_of_id env id', NoBindings) sigma with Not_found -> - user_err ~loc ~hdr:"interp_destruction_arg" ( + user_err ?loc ~hdr:"interp_destruction_arg" ( pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.") end }) in @@ -1067,7 +1064,7 @@ let interp_destruction_arg ist gl arg = if Tactics.is_quantified_hypothesis id gl then keep,ElimOnIdent (loc,id) else - let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in + let c = (CAst.make ?loc @@ GVar id,Some (CAst.make @@ CRef (Ident (loc,id),None))) in let f = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma,c) = interp_open_constr ist env sigma c in @@ -1116,11 +1113,11 @@ let cons_and_check_name id l = let rec read_match_goal_hyps lfun ist env sigma lidh = function | (Hyp ((loc,na) as locna,mp))::tl -> - let lidh' = name_fold cons_and_check_name na lidh in + let lidh' = Name.fold_right cons_and_check_name na lidh in Hyp (locna,read_pattern lfun ist env sigma mp):: (read_match_goal_hyps lfun ist env sigma lidh' tl) | (Def ((loc,na) as locna,mv,mp))::tl -> - let lidh' = name_fold cons_and_check_name na lidh in + let lidh' = Name.fold_right cons_and_check_name na lidh in Def (locna,read_pattern lfun ist env sigma mv, read_pattern lfun ist env sigma mp):: (read_match_goal_hyps lfun ist env sigma lidh' tl) | [] -> [] @@ -1250,7 +1247,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with eval_tactic ist tac | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) (* For extensions *) - | TacAlias (loc,s,l) -> + | TacAlias (loc,(s,l)) -> let (ids, body) = Tacenv.interp_alias s in let (>>=) = Ftactic.bind in let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in @@ -1281,8 +1278,8 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with in Ftactic.run tac (fun () -> Proofview.tclUNIT ()) - | TacML (loc,opn,l) -> - push_trace (loc,LtacMLCall tac) ist >>= fun trace -> + | TacML (loc,(opn,l)) -> + push_trace (Loc.tag ?loc @@ LtacMLCall tac) ist >>= fun trace -> let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in let tac = Tacenv.interp_ml_tactic opn in let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in @@ -1301,7 +1298,7 @@ and force_vrec ist v : Val.t Ftactic.t = | v -> Ftactic.return (of_tacvalue v) else Ftactic.return v -and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = +and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t = match r with | ArgVar (loc,id) -> let v = @@ -1315,7 +1312,7 @@ and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = end | ArgArg (loc,r) -> let ids = extract_ids [] ist.lfun in - let loc_info = ((if Loc.is_ghost loc' then loc else loc'),LtacNameCall r) in + let loc_info = (Option.default loc loc',LtacNameCall r) in let extra = TacStore.set ist.extra f_avoid_ids ids in push_trace loc_info ist >>= fun trace -> let extra = TacStore.set extra f_trace trace in @@ -1326,7 +1323,7 @@ and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = and interp_tacarg ist arg : Val.t Ftactic.t = match arg with | TacGeneric arg -> interp_genarg ist arg - | Reference r -> interp_ltac_reference dloc false ist r + | Reference r -> interp_ltac_reference false ist r | ConstrMayEval c -> Ftactic.s_enter { s_enter = begin fun gl -> let sigma = project gl in @@ -1334,17 +1331,17 @@ and interp_tacarg ist arg : Val.t Ftactic.t = let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) end } - | TacCall (loc,r,[]) -> - interp_ltac_reference loc true ist r - | TacCall (loc,f,l) -> + | TacCall (loc,(r,[])) -> + interp_ltac_reference true ist r + | TacCall (loc,(f,l)) -> let (>>=) = Ftactic.bind in - interp_ltac_reference loc true ist f >>= fun fv -> + interp_ltac_reference true ist f >>= fun fv -> Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> interp_app loc ist fv largs | TacFreshId l -> Ftactic.enter { enter = begin fun gl -> let id = interp_fresh_id ist (pf_env gl) (project gl) l in - Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id))) + Ftactic.return (in_gen (topwit wit_intro_pattern) (Loc.tag @@ IntroNaming (IntroIdentifier id))) end } | TacPretype c -> Ftactic.s_enter { s_enter = begin fun gl -> @@ -1423,7 +1420,7 @@ and tactic_of_value ist vle = (str "A fully applied tactic is expected:" ++ spc() ++ Pp.str "missing " ++ Pp.str (String.plural numargs "argument") ++ Pp.str " for " ++ Pp.str (String.plural numargs "variable") ++ Pp.str " " ++ - pr_enum pr_name vars ++ Pp.str ".") + pr_enum Name.print vars ++ Pp.str ".") | VRec _ -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") else if has_type vle (topwit wit_tactic) then let tac = out_gen (topwit wit_tactic) vle in @@ -1435,7 +1432,7 @@ and interp_letrec ist llc u = Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *) let lref = ref ist.lfun in let fold accu ((_, id), b) = - let v = of_tacvalue (VRec (lref, TacArg (dloc, b))) in + let v = of_tacvalue (VRec (lref, TacArg (Loc.tag b))) in Id.Map.add id v accu in let lfun = List.fold_left fold ist.lfun llc in @@ -1678,8 +1675,8 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in - let sigma, cb = interp_constr_with_bindings ist env sigma cb in - let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in + let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in + let sigma, cbo = Option.fold_map (interp_open_constr_with_bindings ist env) sigma cbo in let named_tac = let tac = Tactics.elim ev keep cb cbo in name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac @@ -1690,7 +1687,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.Goal.enter { enter = begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in - let sigma, cb = interp_constr_with_bindings ist env sigma cb in + let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in let named_tac = let tac = Tactics.general_case_analysis ev keep cb in name_atomic ~env (TacCase(ev,(keep,cb))) tac @@ -1727,18 +1724,21 @@ and interp_atomic ist tac : unit Proofview.tactic = Sigma.Unsafe.of_pair (tac, sigma) end } end - | TacAssert (b,t,ipat,c) -> + | TacAssert (ev,b,t,ipat,c) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in - let (sigma,c) = - (if Option.is_empty t then interp_constr else interp_type) ist env sigma c + let (sigma,c) = + let expected_type = + if Option.is_empty t then WithoutTypeConstraint else IsType in + let flags = open_constr_use_classes_flags () in + interp_open_constr ~expected_type ~flags ist env sigma c in let sigma, ipat' = interp_intro_pattern_option ist env sigma ipat in let tac = Option.map (Option.map (interp_tactic ist)) t in - Tacticals.New.tclWITHHOLES false + Tacticals.New.tclWITHHOLES ev (name_atomic ~env - (TacAssert(b,Option.map (Option.map ignore) t,ipat,c)) + (TacAssert(ev,b,Option.map (Option.map ignore) t,ipat,c)) (Tactics.forward b tac ipat' c)) sigma end } | TacGeneralize cl -> @@ -1751,36 +1751,37 @@ and interp_atomic ist tac : unit Proofview.tactic = (TacGeneralize cl) (Tactics.generalize_gen cl)) sigma end } - | TacLetTac (na,c,clp,b,eqpat) -> + | TacLetTac (ev,na,c,clp,b,eqpat) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let clp = interp_clause ist env sigma clp in let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in - if Locusops.is_nowhere clp then + if Locusops.is_nowhere clp (* typically "pose" *) then (* We try to fully-typecheck the term *) - let (sigma,c_interp) = interp_constr ist env sigma c in + let flags = open_constr_use_classes_flags () in + let (sigma,c_interp) = interp_open_constr ~flags ist env sigma c in let let_tac b na c cl eqpat = - let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in + let id = Option.default (Loc.tag IntroAnonymous) eqpat in let with_eq = if b then None else Some (true,id) in Tactics.letin_tac with_eq na c None cl in let na = interp_name ist env sigma na in - Tacticals.New.tclWITHHOLES false + Tacticals.New.tclWITHHOLES ev (name_atomic ~env - (TacLetTac(na,c_interp,clp,b,eqpat)) + (TacLetTac(ev,na,c_interp,clp,b,eqpat)) (let_tac b na c_interp clp eqpat)) sigma else (* We try to keep the pattern structure as much as possible *) let let_pat_tac b na c cl eqpat = - let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in + let id = Option.default (Loc.tag IntroAnonymous) eqpat in let with_eq = if b then None else Some (true,id) in - Tactics.letin_pat_tac with_eq na c cl + Tactics.letin_pat_tac ev with_eq na c cl in let (sigma',c) = interp_pure_open_constr ist env sigma c in name_atomic ~env - (TacLetTac(na,c,clp,b,eqpat)) - (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*) + (TacLetTac(ev,na,c,clp,b,eqpat)) + (Tacticals.New.tclWITHHOLES ev (let_pat_tac b (interp_name ist env sigma na) (sigma,c) clp eqpat) sigma') end } @@ -1807,7 +1808,7 @@ and interp_atomic ist tac : unit Proofview.tactic = in let l,lp = List.split l in let sigma,el = - Option.fold_map (interp_constr_with_bindings ist env) sigma el in + Option.fold_map (interp_open_constr_with_bindings ist env) sigma el in let tac = name_atomic ~env (TacInductionDestruct(isrec,ev,(lp,el))) (Tactics.induction_destruct isrec ev (l,el)) @@ -1966,8 +1967,7 @@ let interp_tac_gen lfun avoid_ids debug t = let ist = { lfun = lfun; extra = extra } in let ltacvars = Id.Map.domain lfun in interp_tactic ist - (intern_pure_tactic { - ltacvars; genv = env } t) + (intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars } t) end } let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t @@ -1976,7 +1976,7 @@ let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t (* [global] means that [t] should be internalized outside of goals. *) let hide_interp global t ot = let hide_interp env = - let ist = { ltacvars = Id.Set.empty; genv = env } in + let ist = Genintern.empty_glob_sign env in let te = intern_pure_tactic ist t in let t = eval_tactic te in match ot with @@ -2045,6 +2045,11 @@ let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigm Sigma.Unsafe.of_pair (c, sigma) } +let interp_open_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> + let (sigma, c) = interp_open_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in + Sigma.Unsafe.of_pair (c, sigma) + } + let interp_destruction_arg' ist c = Ftactic.enter { enter = begin fun gl -> Ftactic.return (interp_destruction_arg ist gl c) end } @@ -2067,6 +2072,7 @@ let () = register_interp0 wit_open_constr (lifts interp_open_constr); register_interp0 wit_bindings interp_bindings'; register_interp0 wit_constr_with_bindings interp_constr_with_bindings'; + register_interp0 wit_open_constr_with_bindings interp_open_constr_with_bindings'; register_interp0 wit_destruction_arg interp_destruction_arg'; () @@ -2099,17 +2105,13 @@ let interp_redexp env sigma r = (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = - let eval ty env sigma lfun arg = + let eval lfun env sigma ty tac = let ist = { lfun = lfun; extra = TacStore.empty; } in - if Genarg.has_type arg (glbwit wit_tactic) then - let tac = Genarg.out_gen (glbwit wit_tactic) arg in - let tac = interp_tactic ist tac in - let (c, sigma) = Pfedit.refine_by_tactic env sigma ty tac in - (EConstr.of_constr c, sigma) - else - failwith "not a tactic" + let tac = interp_tactic ist tac in + let (c, sigma) = Pfedit.refine_by_tactic env sigma ty tac in + (EConstr.of_constr c, sigma) in - Hook.set Pretyping.genarg_interp_hook eval + Pretyping.register_constr_interp0 wit_tactic eval (** Used in tactic extension **) @@ -2125,7 +2127,7 @@ let lift_constr_tac_to_ml_tac vars tac = let c = Id.Map.find id ist.lfun in try Some (coerce_to_closed_constr env c) with CannotCoerceTo ty -> - error_ltac_variable Loc.ghost dummy_id (Some (env,sigma)) c ty + error_ltac_variable dummy_id (Some (env,sigma)) c ty in let args = List.map_filter map vars in tac args ist @@ -2138,8 +2140,7 @@ let vernac_debug b = let _ = let open Goptions in declare_bool_option - { optsync = false; - optdepr = false; + { optdepr = false; optname = "Ltac debug"; optkey = ["Ltac";"Debug"]; optread = (fun () -> get_debug () != Tactic_debug.DebugOff); @@ -2148,8 +2149,7 @@ let _ = let _ = let open Goptions in declare_bool_option - { optsync = false; - optdepr = false; + { optdepr = false; optname = "Ltac debug"; optkey = ["Debug";"Ltac"]; optread = (fun () -> get_debug () != Tactic_debug.DebugOff); diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index 494f36a95a..2ec45312ea 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -110,7 +110,7 @@ val interp_int : interp_sign -> Id.t Loc.located -> int val interp_int_or_var : interp_sign -> int or_var -> int -val error_ltac_variable : Loc.t -> Id.t -> +val error_ltac_variable : ?loc:Loc.t -> Id.t -> (Environ.env * Evd.evar_map) option -> value -> string -> 'a (** Transforms a constr-expecting tactic into a tactic finding its arguments in diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index fe3a9f3b2a..2858df3130 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -14,7 +14,6 @@ open Stdarg open Tacarg open Misctypes open Globnames -open Term open Genredexpr open Patternops @@ -32,8 +31,8 @@ let subst_glob_constr_and_expr subst (c, e) = let subst_glob_constr = subst_glob_constr_and_expr (* shortening *) -let subst_binding subst (loc,b,c) = - (loc,subst_quantified_hypothesis subst b,subst_glob_constr subst c) +let subst_binding subst (loc,(b,c)) = + (loc,(subst_quantified_hypothesis subst b,subst_glob_constr subst c)) let subst_bindings subst = function | NoBindings -> NoBindings @@ -77,9 +76,7 @@ let subst_or_var f = function | ArgVar _ as x -> x | ArgArg x -> ArgArg (f x) -let dloc = Loc.ghost - -let subst_located f (_loc,id) = (dloc,f id) +let subst_located f = Loc.map f let subst_reference subst = subst_or_var (subst_located (subst_kn subst)) @@ -93,7 +90,7 @@ open Printer let subst_global_reference subst = let subst_global ref = let ref',t' = subst_global subst ref in - if not (eq_constr (Universes.constr_of_global ref') t') then + if not (is_global ref' t') then Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ pr_global ref') ; @@ -148,13 +145,13 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l) | TacMutualCofix (id,l) -> TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l) - | TacAssert (b,otac,na,c) -> - TacAssert (b,Option.map (Option.map (subst_tactic subst)) otac,na, + | TacAssert (ev,b,otac,na,c) -> + TacAssert (ev,b,Option.map (Option.map (subst_tactic subst)) otac,na, subst_glob_constr subst c) | TacGeneralize cl -> TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl) - | TacLetTac (id,c,clp,b,eqpat) -> - TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat) + | TacLetTac (ev,id,c,clp,b,eqpat) -> + TacLetTac (ev,id,subst_glob_constr subst c,clp,b,eqpat) (* Derived basic tactics *) | TacInductionDestruct (isrec,ev,(l,el)) -> @@ -182,7 +179,7 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp) and subst_tactic subst (t:glob_tactic_expr) = match t with - | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t) + | TacAtom (_loc,t) -> TacAtom (Loc.tag @@ subst_atomic subst t) | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun) | TacLetIn (r,l,u) -> let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in @@ -229,22 +226,22 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with | TacFirst l -> TacFirst (List.map (subst_tactic subst) l) | TacSolve l -> TacSolve (List.map (subst_tactic subst) l) | TacComplete tac -> TacComplete (subst_tactic subst tac) - | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a) + | TacArg (_,a) -> TacArg (Loc.tag @@ subst_tacarg subst a) | TacSelect (s, tac) -> TacSelect (s, subst_tactic subst tac) (* For extensions *) - | TacAlias (_,s,l) -> + | TacAlias (_,(s,l)) -> let s = subst_kn subst s in - TacAlias (dloc,s,List.map (subst_tacarg subst) l) - | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_tacarg subst) l) + TacAlias (Loc.tag (s,List.map (subst_tacarg subst) l)) + | TacML (loc,(opn,l)) -> TacML (loc, (opn,List.map (subst_tacarg subst) l)) and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) and subst_tacarg subst = function | Reference r -> Reference (subst_reference subst r) | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) - | TacCall (_loc,f,l) -> - TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l) + | TacCall (loc,(f,l)) -> + TacCall (Loc.tag ?loc (subst_reference subst f, List.map (subst_tacarg subst) l)) | TacFreshId _ as x -> x | TacPretype c -> TacPretype (subst_glob_constr subst c) | TacNumgoals -> TacNumgoals diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index dac15ff79e..294cba4d75 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -91,8 +91,7 @@ open Goptions let _ = declare_bool_option - { optsync = false; - optdepr = false; + { optdepr = false; optname = "Ltac batch debug"; optkey = ["Ltac";"Batch";"Debug"]; optread = (fun () -> !batch); @@ -366,7 +365,7 @@ let explain_ltac_call_trace last trace loc = Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" | Tacexpr.LtacAtomCall te -> quote (Pptactic.pr_glob_tactic (Global.env()) - (Tacexpr.TacAtom (Loc.ghost,te))) + (Tacexpr.TacAtom (Loc.tag te))) | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> quote (Printer.pr_glob_constr_env (Global.env()) c) ++ (if not (Id.Map.is_empty vars) then @@ -401,16 +400,16 @@ let skip_extensions trace = | [] -> [] in List.rev (aux (List.rev trace)) -let finer_loc loc1 loc2 = Loc.merge loc1 loc2 = loc2 +let finer_loc loc1 loc2 = Loc.merge_opt loc1 loc2 = loc2 -let extract_ltac_trace trace eloc = +let extract_ltac_trace ?loc trace = let trace = skip_extensions trace in - let (loc,c),tail = List.sep_last trace in + let (tloc,c),tail = List.sep_last trace in if is_defined_ltac trace then (* We entered a user-defined tactic, we display the trace with location of the call *) - let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in - Some msg, if finer_loc eloc loc then eloc else loc + let msg = hov 0 (explain_ltac_call_trace c tail loc ++ fnl()) in + (if finer_loc loc tloc then loc else tloc), Some msg else (* We entered a primitive tactic, we don't display trace but report on the finest location *) @@ -418,21 +417,21 @@ let extract_ltac_trace trace eloc = (* trace is with innermost call coming first *) let rec aux best_loc = function | (loc,_)::tail -> - if Loc.is_ghost best_loc || - not (Loc.is_ghost loc) && finer_loc loc best_loc + if Option.is_empty best_loc || + not (Option.is_empty loc) && finer_loc loc best_loc then aux loc tail else aux best_loc tail | [] -> best_loc in - aux eloc trace in - None, best_loc + aux loc trace in + best_loc, None let get_ltac_trace (_, info) = let ltac_trace = Exninfo.get info ltac_trace_info in - let loc = Option.default Loc.ghost (Loc.get_loc info) in + let loc = Loc.get_loc info in match ltac_trace with | None -> None - | Some trace -> Some (extract_ltac_trace trace loc) + | Some trace -> Some (extract_ltac_trace ?loc trace) let () = ExplainErr.register_additional_error_info get_ltac_trace diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli index 0b4d35a22a..ac35464c45 100644 --- a/plugins/ltac/tactic_debug.mli +++ b/plugins/ltac/tactic_debug.mli @@ -77,4 +77,4 @@ val db_breakpoint : debug_info -> Id.t Loc.located message_token list -> unit Proofview.NonLogical.t val extract_ltac_trace : - Tacexpr.ltac_trace -> Loc.t -> Pp.std_ppcmds option * Loc.t + ?loc:Loc.t -> Tacexpr.ltac_trace -> Pp.std_ppcmds option Loc.located diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 4de2081cf8..d8e21d81d1 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -70,8 +70,7 @@ let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 open Goptions let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "unfolding of not in intuition"; optkey = ["Intuition";"Negation";"Unfolding"]; optread = (fun () -> !negation_unfolding); @@ -79,8 +78,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "unfolding of iff in intuition"; optkey = ["Intuition";"Iff";"Unfolding"]; optread = (fun () -> !iff_unfolding); @@ -88,7 +86,6 @@ let _ = (** Base tactics *) -let loc = Loc.ghost let idtac = Proofview.tclUNIT () let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ())) @@ -206,7 +203,7 @@ let u_iff = make_unfold "iff" let u_not = make_unfold "not" let reduction_not_iff _ ist = - let make_reduce c = TacAtom (loc, TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in + let make_reduce c = TacAtom (Loc.tag @@ TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in let tac = match !negation_unfolding, unfold_iff () with | true, true -> make_reduce [u_not; u_iff] | true, false -> make_reduce [u_not] @@ -223,9 +220,7 @@ let apply_nnpp _ ist = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> try - let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in - let nnpp = EConstr.of_constr nnpp in - apply nnpp + Tacticals.New.pf_constr_of_global (Nametab.global_of_path coq_nnpp_path) >>= apply with Not_found -> tclFAIL 0 (Pp.mt ()) end @@ -259,11 +254,11 @@ let tauto_power_flags = { } let with_flags flags _ ist = - let f = (loc, Id.of_string "f") in - let x = (loc, Id.of_string "x") in + let f = (Loc.tag @@ Id.of_string "f") in + let x = (Loc.tag @@ Id.of_string "x") in let arg = Val.Dyn (tag_tauto_flags, flags) in let ist = { ist with lfun = Id.Map.add (snd x) arg ist.lfun } in - eval_tactic_ist ist (TacArg (loc, TacCall (loc, ArgVar f, [Reference (ArgVar x)]))) + eval_tactic_ist ist (TacArg (Loc.tag @@ TacCall (Loc.tag (ArgVar f, [Reference (ArgVar x)])))) let register_tauto_tactic tac name0 args = let ids = List.map (fun id -> Id.of_string id) args in @@ -271,7 +266,7 @@ let register_tauto_tactic tac name0 args = let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in let entry = { mltac_name = name; mltac_index = 0 } in let () = Tacenv.register_ml_tactic name [| tac |] in - let tac = TacFun (ids, TacML (loc, entry, [])) in + let tac = TacFun (ids, TacML (Loc.tag (entry, []))) in let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in Mltop.declare_cache_obj obj tauto_plugin diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index a36607ec38..7497aae3ca 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -65,7 +65,6 @@ let _ = let int_opt l vref = { - optsync = true; optdepr = false; optname = List.fold_right (^) l ""; optkey = l ; @@ -75,7 +74,6 @@ let _ = let lia_enum_opt = { - optsync = true; optdepr = false; optname = "Lia Enum"; optkey = ["Lia";"Enum"]; @@ -330,7 +328,6 @@ let selecti s m = module M = struct - open Coqlib open Constr open EConstr @@ -358,8 +355,8 @@ struct ["LRing_normalise"]] let coq_modules = - init_modules @ - [logic_dir] @ arith_modules @ zarith_base_modules @ mic_modules + Coqlib.(init_modules @ + [logic_dir] @ arith_modules @ zarith_base_modules @ mic_modules) let bin_module = [["Coq";"Numbers";"BinNums"]] @@ -377,8 +374,8 @@ struct * ZMicromega.v *) - let gen_constant_in_modules s m n = EConstr.of_constr (gen_constant_in_modules s m n) - let init_constant = gen_constant_in_modules "ZMicromega" init_modules + let gen_constant_in_modules s m n = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) + let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules let constant = gen_constant_in_modules "ZMicromega" coq_modules let bin_constant = gen_constant_in_modules "ZMicromega" bin_module let r_constant = gen_constant_in_modules "ZMicromega" r_modules @@ -1531,18 +1528,18 @@ let rec apply_ids t ids = | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids let coq_Node = - lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node")) + lazy (gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") let coq_Leaf = - lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf")) + lazy (gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") let coq_Empty = - lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty")) + lazy (gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") let coq_VarMap = - lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t")) + lazy (gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t") let rec dump_varmap typ m = @@ -1994,7 +1991,7 @@ let micromega_gen let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let ipat_of_name id = Some (Loc.tag @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in let goal_name = fresh_id [] (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in @@ -2061,8 +2058,8 @@ let micromega_order_changer cert env ff = [ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |])); ("__varmap", vm, Term.mkApp - (EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t"), [|typ|])); + (gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); ("__wit", cert, cert_typ) ] (Tacmach.New.pf_concl gl))); @@ -2109,7 +2106,7 @@ let micromega_genr prover tac = let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let ipat_of_name id = Some (Loc.tag @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in let goal_name = fresh_id [] (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index 632b9dac14..6ba4c0f930 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -134,8 +134,10 @@ let mul = function | (Const n,q) when eq_num n num_1 -> q | (p,q) -> Mul(p,q) -let tpexpr = - lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") +let gen_constant msg path s = Universes.constr_of_global @@ + coq_reference msg path s + +let tpexpr = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc") let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX") let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd") @@ -462,7 +464,7 @@ let theoremedeszeros_termes lp = lexico:=true; |7 -> sinfo "ordre lexico computation with sugar, division by pairs"; lexico:=true; - | _ -> error "nsatz: bad parameter" + | _ -> user_err Pp.(str "nsatz: bad parameter") ); let lvar = List.init nvars (fun i -> Printf.sprintf "x%i" (i + 1)) in let lvar = ["a";"b";"c";"d";"e";"f";"g";"h";"i";"j";"k";"l";"m";"n";"o";"p";"q";"r";"s";"t";"u";"v";"w";"x";"y";"z"] @ lvar in @@ -541,7 +543,7 @@ let nsatz lpol = let return_term t = let a = - mkApp(gen_constant "CC" ["Init";"Logic"] "refl_equal",[|tllp ();t|]) in + mkApp(gen_constant "CC" ["Init";"Logic"] "eq_refl",[|tllp ();t|]) in let a = EConstr.of_constr a in generalize [a] @@ -549,5 +551,5 @@ let nsatz_compute t = let lpol = try nsatz t with Ideal.NotInIdeal -> - error "nsatz cannot solve this problem" in + user_err Pp.(str "nsatz cannot solve this problem") in return_term lpol diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 92b092ffe9..d7408e88ec 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -39,10 +39,10 @@ open OmegaSolver let elim_id id = Proofview.Goal.enter { enter = begin fun gl -> - simplest_elim (Tacmach.New.pf_global id gl) + simplest_elim (mkVar id) end } let resolve_id id = Proofview.Goal.enter { enter = begin fun gl -> - apply (Tacmach.New.pf_global id gl) + apply (mkVar id) end } let timing timer_name f arg = f arg @@ -71,8 +71,7 @@ open Goptions let _ = declare_bool_option - { optsync = false; - optdepr = false; + { optdepr = false; optname = "Omega system time displaying flag"; optkey = ["Omega";"System"]; optread = read display_system_flag; @@ -80,8 +79,7 @@ let _ = let _ = declare_bool_option - { optsync = false; - optdepr = false; + { optdepr = false; optname = "Omega action display flag"; optkey = ["Omega";"Action"]; optread = read display_action_flag; @@ -89,8 +87,7 @@ let _ = let _ = declare_bool_option - { optsync = false; - optdepr = false; + { optdepr = false; optname = "Omega old style flag"; optkey = ["Omega";"OldStyle"]; optread = read old_style_flag; @@ -98,8 +95,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = true; + { optdepr = true; optname = "Omega automatic reset of generated names"; optkey = ["Stable";"Omega"]; optread = read reset_flag; @@ -200,7 +196,7 @@ let coq_modules = init_modules @arith_modules @ [logic_dir] @ zarith_base_modules @ [["Coq"; "omega"; "OmegaLemmas"]] -let gen_constant_in_modules n m s = EConstr.of_constr (gen_constant_in_modules n m s) +let gen_constant_in_modules n m s = EConstr.of_constr (Universes.constr_of_global @@ gen_reference_in_modules n m s) let init_constant = gen_constant_in_modules "Omega" init_modules let constant = gen_constant_in_modules "Omega" coq_modules @@ -460,7 +456,7 @@ let destructurate_prop sigma t = Kapp (Other (string_of_path (path_of_global (IndRef isp))),args) | Var id,[] -> Kvar id | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) - | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal" + | Prod (Name _,_,_),[] -> CErrors.user_err Pp.(str "Omega: Not a quantifier-free goal") | _ -> Kufo let destructurate_type sigma t = @@ -895,7 +891,7 @@ let rec scalar p n = function (Lazy.force coq_fast_Zmult_assoc_reverse); focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (n*x)) - | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products" + | Otimes(t1,t2) -> CErrors.user_err Pp.(str "Omega: Can't solve a goal with non-linear products") | (Oatom _ as t) -> [], Otimes(t,Oz n) | Oz i -> [focused_simpl p],Oz(n*i) | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |])) @@ -947,7 +943,7 @@ let rec negate p = function [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] (Lazy.force coq_fast_Zopp_mult_distr_r); focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (neg x)) - | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products" + | Otimes(t1,t2) -> CErrors.user_err Pp.(str "Omega: Can't solve a goal with non-linear products") | (Oatom _ as t) -> let r = Otimes(t,Oz(negone)) in [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1)], r @@ -1030,7 +1026,7 @@ let shrink_pair p f1 f2 = | t1,t2 -> begin oprint t1; print_newline (); oprint t2; print_newline (); - flush Pervasives.stdout; error "shrink.1" + flush Pervasives.stdout; CErrors.user_err Pp.(str "shrink.1") end let reduce_factor p = function @@ -1042,10 +1038,10 @@ let reduce_factor p = function let rec compute = function | Oz n -> n | Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2) - | _ -> error "condense.1" + | _ -> CErrors.user_err Pp.(str "condense.1") in [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c)) - | t -> oprint t; error "reduce_factor.1" + | t -> oprint t; CErrors.user_err Pp.(str "reduce_factor.1") let rec condense p = function | Oplus(f1,(Oplus(f2,r) as t)) -> diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index 6b711a1761..ce7ffb1e7e 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -35,7 +35,7 @@ let omega_tactic l = | "positive" -> eval_tactic "zify_positive" | "N" -> eval_tactic "zify_N" | "Z" -> eval_tactic "zify_op" - | s -> CErrors.error ("No Omega knowledge base for type "^s)) + | s -> CErrors.user_err Pp.(str ("No Omega knowledge base for type "^s))) (Util.List.sort_uniquize String.compare l) in Tacticals.New.tclTHEN diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml index 334b03de1d..2a018fa3f4 100644 --- a/plugins/omega/omega.ml +++ b/plugins/omega/omega.ml @@ -96,7 +96,7 @@ type afine = { type state_action = { st_new_eq : afine; - st_def : afine; + st_def : afine; (* /!\ this represents [st_def = st_var] *) st_orig : afine; st_coef : bigint; st_var : int } @@ -587,10 +587,6 @@ let rec depend relie_on accu = function end | [] -> relie_on, accu -let solve (new_eq_id,new_eq_var,print_var) system = - try let _ = simplify new_eq_id false system in failwith "no contradiction" - with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ()))) - let negation (eqs,ineqs) = let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in let normal = function diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index 6c3e661128..980f03db33 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -19,15 +19,14 @@ open Tacarg DECLARE PLUGIN "quote_plugin" -let loc = Loc.ghost let cont = Id.of_string "cont" let x = Id.of_string "x" let make_cont (k : Val.t) (c : EConstr.t) = let c = Tacinterp.Value.of_constr c in - let tac = TacCall (loc, ArgVar (loc, cont), [Reference (ArgVar (loc, x))]) in + let tac = TacCall (Loc.tag (ArgVar (Loc.tag cont), [Reference (ArgVar (Loc.tag x))])) in let ist = { lfun = Id.Map.add cont k (Id.Map.singleton x c); extra = TacStore.empty; } in - Tacinterp.eval_tactic_ist ist (TacArg (loc, tac)) + Tacinterp.eval_tactic_ist ist (TacArg (Loc.tag tac)) TACTIC EXTEND quote [ "quote" ident(f) ] -> [ quote f [] ] diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index c649cfb2c6..ba8356b525 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -118,7 +118,8 @@ open Proofview.Notations the constants are loaded in the environment *) let constant dir s = - EConstr.of_constr (Coqlib.gen_constant "Quote" ("quote"::dir) s) + EConstr.of_constr @@ Universes.constr_of_global @@ + Coqlib.coq_reference "Quote" ("quote"::dir) s let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm") let coq_Node_vm = lazy (constant ["Quote"] "Node_vm") @@ -183,7 +184,7 @@ type inversion_scheme = { goal [gl]. This function uses the auxiliary functions [i_can't_do_that], [decomp_term], [compute_lhs] and [compute_rhs]. *) -let i_can't_do_that () = error "Quote: not a simple fixpoint" +let i_can't_do_that () = user_err Pp.(str "Quote: not a simple fixpoint") let decomp_term sigma c = EConstr.kind sigma (Termops.strip_outer_cast sigma c) @@ -455,39 +456,56 @@ let quote_terms env sigma ivs lc = term. Ring for example needs that, but Ring doesn't use Quote yet. *) +let pf_constrs_of_globals l = + let rec aux l acc = + match l with + [] -> Proofview.tclUNIT (List.rev acc) + | hd :: tl -> + Tacticals.New.pf_constr_of_global hd >>= fun g -> aux tl (g :: acc) + in aux l [] + let quote f lid = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let f = Tacmach.New.pf_global f gl in - let cl = List.map (fun id -> EConstr.to_constr sigma (Tacmach.New.pf_global id gl)) lid in - let ivs = compute_ivs f cl gl in - let concl = Proofview.Goal.concl gl in - let quoted_terms = quote_terms env sigma ivs [concl] in - let (p, vm) = match quoted_terms with + Proofview.Goal.enter { enter = begin fun gl -> + let fg = Tacmach.New.pf_global f gl in + let clg = List.map (fun id -> Tacmach.New.pf_global id gl) lid in + Tacticals.New.pf_constr_of_global fg >>= fun f -> + pf_constrs_of_globals clg >>= fun cl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let ivs = compute_ivs f (List.map (EConstr.to_constr sigma) cl) gl in + let concl = Proofview.Goal.concl gl in + let quoted_terms = quote_terms env sigma ivs [concl] in + let (p, vm) = match quoted_terms with | [p], vm -> (p,vm) | _ -> assert false - in - match ivs.variable_lhs with - | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast - | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast + in + match ivs.variable_lhs with + | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast + | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast + end } end } let gen_quote cont c f lid = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let f = Tacmach.New.pf_global f gl in - let cl = List.map (fun id -> EConstr.to_constr sigma (Tacmach.New.pf_global id gl)) lid in - let ivs = compute_ivs f cl gl in - let quoted_terms = quote_terms env sigma ivs [c] in - let (p, vm) = match quoted_terms with - | [p], vm -> (p,vm) - | _ -> assert false - in - match ivs.variable_lhs with - | None -> cont (mkApp (f, [| p |])) - | Some _ -> cont (mkApp (f, [| vm; p |])) + Proofview.Goal.enter { enter = begin fun gl -> + let fg = Tacmach.New.pf_global f gl in + let clg = List.map (fun id -> Tacmach.New.pf_global id gl) lid in + Tacticals.New.pf_constr_of_global fg >>= fun f -> + pf_constrs_of_globals clg >>= fun cl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let cl = List.map (EConstr.to_constr sigma) cl in + let ivs = compute_ivs f cl gl in + let quoted_terms = quote_terms env sigma ivs [c] in + let (p, vm) = match quoted_terms with + | [p], vm -> (p,vm) + | _ -> assert false + in + match ivs.variable_lhs with + | None -> cont (mkApp (f, [| p |])) + | Some _ -> cont (mkApp (f, [| vm; p |])) + end } end } (*i diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 187601fc62..d242264a91 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -10,12 +10,14 @@ Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable ZArith_base. Delimit Scope Int_scope with I. -(* Abstract Integers. *) +(** * Abstract Integers. *) Module Type Int. Parameter t : Set. + Bind Scope Int_scope with t. + Parameter zero : t. Parameter one : t. Parameter plus : t -> t -> t. @@ -32,10 +34,10 @@ Module Type Int. Open Scope Int_scope. - (* First, int is a ring: *) + (** First, Int is a ring: *) Axiom ring : @ring_theory t 0 1 plus mult minus opp (@eq t). - (* int should also be ordered: *) + (** Int should also be ordered: *) Parameter le : t -> t -> Prop. Parameter lt : t -> t -> Prop. @@ -49,35 +51,47 @@ Module Type Int. Axiom ge_le_iff : forall i j, (i>=j) <-> (j<=i). Axiom gt_lt_iff : forall i j, (i>j) <-> (j<i). - (* Basic properties of this order *) + (** Basic properties of this order *) Axiom lt_trans : forall i j k, i<j -> j<k -> i<k. Axiom lt_not_eq : forall i j, i<j -> i<>j. - (* Compatibilities *) + (** Compatibilities *) Axiom lt_0_1 : 0<1. Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l. Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i). Axiom mult_lt_compat_l : forall i j k, 0 < k -> i < j -> k*i<k*j. - (* We should have a way to decide the equality and the order*) + (** We should have a way to decide the equality and the order*) Parameter compare : t -> t -> comparison. Infix "?=" := compare (at level 70, no associativity) : Int_scope. Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j. Axiom compare_Lt : forall i j, compare i j = Lt <-> i<j. Axiom compare_Gt : forall i j, compare i j = Gt <-> i>j. - (* Up to here, these requirements could be fulfilled + (** Up to here, these requirements could be fulfilled by any totally ordered ring. Let's now be int-specific: *) Axiom le_lt_int : forall x y, x<y <-> x<=y+-(1). - (* Btw, lt_0_1 could be deduced from this last axiom *) + (** Btw, lt_0_1 could be deduced from this last axiom *) + + (** Now we also require a division function. + It is deliberately underspecified, since that's enough + for the proofs below. But the most appropriate variant + (and the one needed to stay in sync with the omega engine) + is "Floor" (the historical version of Coq's [Z.div]). *) + + Parameter diveucl : t -> t -> t * t. + Notation "i / j" := (fst (diveucl i j)). + Notation "i 'mod' j" := (snd (diveucl i j)). + Axiom diveucl_spec : + forall i j, j<>0 -> i = j * (i/j) + (i mod j). End Int. -(* Of course, Z is a model for our abstract int *) +(** Of course, Z is a model for our abstract int *) Module Z_as_Int <: Int. @@ -131,21 +145,24 @@ Module Z_as_Int <: Int. Definition le_lt_int := Z.lt_le_pred. -End Z_as_Int. + Definition diveucl := Z.div_eucl. + Definition diveucl_spec := Z.div_mod. +End Z_as_Int. +(** * Properties of abstract integers *) Module IntProperties (I:Int). Import I. Local Notation int := I.t. - (* Primo, some consequences of being a ring theory... *) + (** Primo, some consequences of being a ring theory... *) Definition two := 1+1. Notation "2" := two : Int_scope. - (* Aliases for properties packed in the ring record. *) + (** Aliases for properties packed in the ring record. *) Definition plus_assoc := ring.(Radd_assoc). Definition plus_comm := ring.(Radd_comm). @@ -160,31 +177,22 @@ Module IntProperties (I:Int). Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l mult_plus_distr_r opp_def minus_def. - (* More facts about plus *) + (** More facts about [plus] *) Lemma plus_0_r : forall x, x+0 = x. Proof. intros; rewrite plus_comm; apply plus_0_l. Qed. - Lemma plus_0_r_reverse : forall x, x = x+0. - Proof. intros; symmetry; apply plus_0_r. Qed. - - Lemma plus_assoc_reverse : forall x y z, x+y+z = x+(y+z). - Proof. intros; symmetry; apply plus_assoc. Qed. - Lemma plus_permute : forall x y z, x+(y+z) = y+(x+z). Proof. intros; do 2 rewrite plus_assoc; f_equal; apply plus_comm. Qed. Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z. Proof. intros. - rewrite (plus_0_r_reverse y), (plus_0_r_reverse z), <-(opp_def x). + rewrite <- (plus_0_r y), <- (plus_0_r z), <-(opp_def x). now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. Qed. - (* More facts about mult *) - - Lemma mult_assoc_reverse : forall x y z, x*y*z = x*(y*z). - Proof. intros; symmetry; apply mult_assoc. Qed. + (** More facts about [mult] *) Lemma mult_plus_distr_l : forall x y z, x*(y+z)=x*y+x*z. Proof. @@ -193,18 +201,25 @@ Module IntProperties (I:Int). apply mult_plus_distr_r. Qed. - Lemma mult_0_l : forall x, 0*x = 0. + Lemma mult_0_l x : 0*x = 0. Proof. - intros. - generalize (mult_plus_distr_r 0 1 x). - rewrite plus_0_l, mult_1_l, plus_comm; intros. + assert (H := mult_plus_distr_r 0 1 x). + rewrite plus_0_l, mult_1_l, plus_comm in H. apply plus_reg_l with x. - rewrite <- H. - apply plus_0_r_reverse. + now rewrite <- H, plus_0_r. + Qed. + + Lemma mult_0_r x : x*0 = 0. + Proof. + rewrite mult_comm. apply mult_0_l. Qed. + Lemma mult_1_r x : x*1 = x. + Proof. + rewrite mult_comm. apply mult_1_l. + Qed. - (* More facts about opp *) + (** More facts about [opp] *) Definition plus_opp_r := opp_def. @@ -249,104 +264,47 @@ Module IntProperties (I:Int). now rewrite opp_def, <-mult_plus_distr_r, opp_def, mult_0_l. Qed. - Lemma egal_left : forall n m, n=m -> n+-m = 0. - Proof. intros; subst; apply opp_def. Qed. - - Lemma ne_left_2 : forall x y : int, x<>y -> 0<>(x + - y). - Proof. - intros; contradict H. - apply (plus_reg_l (-y)). - now rewrite plus_opp_l, plus_comm, H. - Qed. - - (* Special lemmas for factorisation. *) - - Lemma red_factor0 : forall n, n = n*1. - Proof. symmetry; rewrite mult_comm; apply mult_1_l. Qed. - - Lemma red_factor1 : forall n, n+n = n*2. - Proof. - intros; unfold two. - now rewrite mult_comm, mult_plus_distr_r, mult_1_l. - Qed. - - Lemma red_factor2 : forall n m, n + n*m = n * (1+m). - Proof. - intros; rewrite mult_plus_distr_l. - f_equal; now rewrite mult_comm, mult_1_l. - Qed. - - Lemma red_factor3 : forall n m, n*m + n = n*(1+m). - Proof. intros; now rewrite plus_comm, red_factor2. Qed. - - Lemma red_factor4 : forall n m p, n*m + n*p = n*(m+p). + Lemma egal_left n m : 0 = n+-m <-> n = m. Proof. - intros; now rewrite mult_plus_distr_l. + split; intros. + - apply plus_reg_l with (-m). + rewrite plus_comm, <- H. symmetry. apply plus_opp_l. + - symmetry. subst; apply opp_def. Qed. - Lemma red_factor5 : forall n m , n * 0 + m = m. - Proof. intros; now rewrite mult_comm, mult_0_l, plus_0_l. Qed. - - Definition red_factor6 := plus_0_r_reverse. - - - (* Specialized distributivities *) + (** Specialized distributivities *) Hint Rewrite mult_plus_distr_l mult_plus_distr_r mult_assoc : int. Hint Rewrite <- plus_assoc : int. - Lemma OMEGA10 : - forall v c1 c2 l1 l2 k1 k2 : int, - (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = - v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). - Proof. - intros; autorewrite with int; f_equal; now rewrite plus_permute. - Qed. - - Lemma OMEGA11 : - forall v1 c1 l1 l2 k1 : int, - (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). - Proof. - intros; now autorewrite with int. - Qed. + Hint Rewrite plus_0_l plus_0_r mult_0_l mult_0_r mult_1_l mult_1_r : int. - Lemma OMEGA12 : - forall v2 c2 l1 l2 k2 : int, - l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). + Lemma OMEGA10 v c1 c2 l1 l2 k1 k2 : + v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2) = + (v * c1 + l1) * k1 + (v * c2 + l2) * k2. Proof. - intros; autorewrite with int; now rewrite plus_permute. + autorewrite with int; f_equal; now rewrite plus_permute. Qed. - Lemma OMEGA13 : - forall v l1 l2 x : int, - v * -x + l1 + (v * x + l2) = l1 + l2. + Lemma OMEGA11 v1 c1 l1 l2 k1 : + v1 * (c1 * k1) + (l1 * k1 + l2) = (v1 * c1 + l1) * k1 + l2. Proof. - intros; autorewrite with int. - rewrite plus_permute; f_equal. - rewrite plus_assoc. - now rewrite <- mult_plus_distr_l, plus_opp_l, mult_comm, mult_0_l, plus_0_l. + now autorewrite with int. Qed. - Lemma OMEGA15 : - forall v c1 c2 l1 l2 k2 : int, - v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). + Lemma OMEGA12 v2 c2 l1 l2 k2 : + v2 * (c2 * k2) + (l1 + l2 * k2) = l1 + (v2 * c2 + l2) * k2. Proof. - intros; autorewrite with int; f_equal; now rewrite plus_permute. + autorewrite with int; now rewrite plus_permute. Qed. - Lemma OMEGA16 : forall v c l k : int, (v * c + l) * k = v * (c * k) + l * k. + Lemma sum1 a b c d : 0 = a -> 0 = b -> 0 = a * c + b * d. Proof. - intros; now autorewrite with int. - Qed. - - Lemma sum1 : forall a b c d : int, 0 = a -> 0 = b -> 0 = a * c + b * d. - Proof. - intros; elim H; elim H0; simpl; auto. - now rewrite mult_0_l, mult_0_l, plus_0_l. + intros; subst. now autorewrite with int. Qed. - (* Secondo, some results about order (and equality) *) + (** Secondo, some results about order (and equality) *) Lemma lt_irrefl : forall n, ~ n<n. Proof. @@ -413,86 +371,74 @@ Module IntProperties (I:Int). Definition beq i j := match compare i j with Eq => true | _ => false end. - Lemma beq_iff : forall i j, beq i j = true <-> i=j. - Proof. - intros; unfold beq; generalize (compare_Eq i j). - destruct compare; intuition discriminate. - Qed. + Infix "=?" := beq : Int_scope. - Lemma beq_true : forall i j, beq i j = true -> i=j. + Lemma beq_iff i j : (i =? j) = true <-> i=j. Proof. - intros. - rewrite <- beq_iff; auto. + unfold beq. rewrite <- (compare_Eq i j). now destruct compare. Qed. - Lemma beq_false : forall i j, beq i j = false -> i<>j. + Lemma beq_reflect i j : reflect (i=j) (i =? j). Proof. - intros. - intro H'. - rewrite <- beq_iff in H'; rewrite H' in H; discriminate. + apply iff_reflect. symmetry. apply beq_iff. Qed. Lemma eq_dec : forall n m:int, { n=m } + { n<>m }. Proof. - intros; generalize (beq_iff n m); destruct beq; [left|right]; intuition. + intros n m; generalize (beq_iff n m); destruct beq; [left|right]; intuition. Qed. - Definition bgt i j := match compare i j with Gt => true | _ => false end. + Definition blt i j := match compare i j with Lt => true | _ => false end. + + Infix "<?" := blt : Int_scope. - Lemma bgt_iff : forall i j, bgt i j = true <-> i>j. + Lemma blt_iff i j : (i <? j) = true <-> i<j. Proof. - intros; unfold bgt; generalize (compare_Gt i j). - destruct compare; intuition discriminate. + unfold blt. rewrite <- (compare_Lt i j). now destruct compare. Qed. - Lemma bgt_true : forall i j, bgt i j = true -> i>j. - Proof. intros; now rewrite <- bgt_iff. Qed. - - Lemma bgt_false : forall i j, bgt i j = false -> i<=j. + Lemma blt_reflect i j : reflect (i<j) (i <? j). Proof. - intros. - rewrite le_lt_iff, <-gt_lt_iff, <-bgt_iff; intro H'; now rewrite H' in H. + apply iff_reflect. symmetry. apply blt_iff. Qed. Lemma le_is_lt_or_eq : forall n m, n<=m -> { n<m } + { n=m }. Proof. - intros. + intros n m Hnm. destruct (eq_dec n m) as [H'|H']. - right; intuition. - left; rewrite lt_le_iff. - contradict H'. - apply le_antisym; auto. + - right; intuition. + - left; rewrite lt_le_iff. + contradict H'. + now apply le_antisym. Qed. Lemma le_neq_lt : forall n m, n<=m -> n<>m -> n<m. Proof. - intros. - destruct (le_is_lt_or_eq _ _ H); intuition. + intros n m H. now destruct (le_is_lt_or_eq _ _ H). Qed. Lemma le_trans : forall n m p, n<=m -> m<=p -> n<=p. Proof. - intros n m p; do 3 rewrite le_lt_iff; intros A B C. + intros n m p; rewrite 3 le_lt_iff; intros A B C. destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto. generalize (lt_trans _ _ _ H C); intuition. Qed. - (* order and operations *) - - Lemma le_0_neg : forall n, 0 <= n <-> -n <= 0. + Lemma not_eq (a b:int) : ~ a <> b <-> a = b. Proof. - intros. - pattern 0 at 2; rewrite <- (mult_0_l (-(1))). - rewrite <- opp_eq_mult_neg_1. - split; intros. - apply opp_le_compat; auto. - rewrite <-(opp_involutive 0), <-(opp_involutive n). - apply opp_le_compat; auto. + destruct (eq_dec a b); intuition. Qed. - Lemma le_0_neg' : forall n, n <= 0 <-> 0 <= -n. + (** Order and operations *) + + Lemma le_0_neg n : n <= 0 <-> 0 <= -n. Proof. - intros; rewrite le_0_neg, opp_involutive; intuition. + rewrite <- (mult_0_l (-(1))) at 2. + rewrite <- opp_eq_mult_neg_1. + split; intros. + - now apply opp_le_compat. + - rewrite <-(opp_involutive 0), <-(opp_involutive n). + now apply opp_le_compat. Qed. Lemma plus_le_reg_r : forall n m p, n + p <= m + p -> n <= m. @@ -534,20 +480,14 @@ Module IntProperties (I:Int). apply opp_le_compat; auto. Qed. - Lemma lt_0_neg : forall n, 0 < n <-> -n < 0. + Lemma lt_0_neg n : n < 0 <-> 0 < -n. Proof. - intros. - pattern 0 at 2; rewrite <- (mult_0_l (-(1))). + rewrite <- (mult_0_l (-(1))) at 2. rewrite <- opp_eq_mult_neg_1. split; intros. - apply opp_lt_compat; auto. - rewrite <-(opp_involutive 0), <-(opp_involutive n). - apply opp_lt_compat; auto. - Qed. - - Lemma lt_0_neg' : forall n, n < 0 <-> 0 < -n. - Proof. - intros; rewrite lt_0_neg, opp_involutive; intuition. + - now apply opp_lt_compat. + - rewrite <-(opp_involutive 0), <-(opp_involutive n). + now apply opp_lt_compat. Qed. Lemma mult_lt_0_compat : forall n m, 0 < n -> 0 < m -> 0 < n*m. @@ -557,111 +497,70 @@ Module IntProperties (I:Int). apply mult_lt_compat_l; auto. Qed. - Lemma mult_integral : forall n m, n * m = 0 -> n = 0 \/ m = 0. + Lemma mult_integral_r n m : 0 < n -> n * m = 0 -> m = 0. Proof. - intros. - destruct (lt_eq_lt_dec n 0) as [[Hn|Hn]|Hn]; auto; - destruct (lt_eq_lt_dec m 0) as [[Hm|Hm]|Hm]; auto; exfalso. - - rewrite lt_0_neg' in Hn. - rewrite lt_0_neg' in Hm. - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite <- opp_mult_distr_r, mult_comm, <- opp_mult_distr_r, opp_involutive. - rewrite mult_comm, H. - exact (lt_irrefl 0). - - rewrite lt_0_neg' in Hn. - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite mult_comm, <- opp_mult_distr_r, mult_comm. - rewrite H. - rewrite opp_eq_mult_neg_1, mult_0_l. - exact (lt_irrefl 0). - - rewrite lt_0_neg' in Hm. - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite <- opp_mult_distr_r. - rewrite H. - rewrite opp_eq_mult_neg_1, mult_0_l. - exact (lt_irrefl 0). - - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite H. - exact (lt_irrefl 0). + intros Hn H. + destruct (lt_eq_lt_dec 0 m) as [[Hm| <- ]|Hm]; auto; exfalso. + - generalize (mult_lt_0_compat _ _ Hn Hm). + rewrite H. + exact (lt_irrefl 0). + - rewrite lt_0_neg in Hm. + generalize (mult_lt_0_compat _ _ Hn Hm). + rewrite <- opp_mult_distr_r, opp_eq_mult_neg_1, H, mult_0_l. + exact (lt_irrefl 0). Qed. - Lemma mult_le_compat : - forall i j k l, i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l. + Lemma mult_integral n m : n * m = 0 -> n = 0 \/ m = 0. Proof. - intros. - destruct (le_is_lt_or_eq _ _ H1). - - apply le_trans with (i*l). - destruct (le_is_lt_or_eq _ _ H0); [ | subst; apply le_refl]. - apply lt_le_weak. - apply mult_lt_compat_l; auto. - - generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. - rewrite (mult_comm i), (mult_comm j). - destruct (le_is_lt_or_eq _ _ H0); - [ | subst; do 2 rewrite mult_0_l; apply le_refl]. - destruct (le_is_lt_or_eq _ _ H); - [ | subst; apply le_refl]. - apply lt_le_weak. - apply mult_lt_compat_l; auto. - - subst i. - rewrite mult_0_l. - generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. - destruct (le_is_lt_or_eq _ _ H); - [ | subst; rewrite mult_0_l; apply le_refl]. - destruct (le_is_lt_or_eq _ _ H0); - [ | subst; rewrite mult_comm, mult_0_l; apply le_refl]. - apply lt_le_weak. - apply mult_lt_0_compat; auto. + intros H. + destruct (lt_eq_lt_dec 0 n) as [[Hn|Hn]|Hn]. + - right; apply (mult_integral_r n m); trivial. + - now left. + - right; apply (mult_integral_r (-n) m). + + now apply lt_0_neg. + + rewrite mult_comm, <- opp_mult_distr_r, mult_comm, H. + now rewrite opp_eq_mult_neg_1, mult_0_l. Qed. - Lemma sum5 : - forall a b c d : int, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d. + Lemma mult_le_compat_l i j k : + 0<=k -> i<=j -> k*i <= k*j. Proof. - intros. - subst b; rewrite mult_0_l, plus_0_r. - contradict H. - symmetry in H; destruct (mult_integral _ _ H); congruence. + intros Hk Hij. + apply le_is_lt_or_eq in Hk. apply le_is_lt_or_eq in Hij. + destruct Hk as [Hk | <-], Hij as [Hij | <-]; + rewrite ? mult_0_l; try apply le_refl. + now apply lt_le_weak, mult_lt_compat_l. Qed. - Lemma one_neq_zero : 1 <> 0. + Lemma mult_le_compat i j k l : + i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l. Proof. - red; intro. - symmetry in H. - apply (lt_not_eq 0 1); auto. - apply lt_0_1. + intros Hij Hkl Hi Hk. + apply le_trans with (i*l). + - now apply mult_le_compat_l. + - rewrite (mult_comm i), (mult_comm j). + apply mult_le_compat_l; trivial. + now apply le_trans with k. Qed. - Lemma minus_one_neq_zero : -(1) <> 0. + Lemma sum5 a b c d : 0 <> c -> 0 <> a -> 0 = b -> 0 <> a * c + b * d. Proof. - apply lt_not_eq. - rewrite <- lt_0_neg. - apply lt_0_1. + intros Hc Ha <-. autorewrite with int. contradict Hc. + symmetry in Hc. destruct (mult_integral _ _ Hc); congruence. Qed. - Lemma le_left : forall n m, n <= m -> 0 <= m + - n. + Lemma le_left n m : n <= m <-> 0 <= m + - n. Proof. - intros. - rewrite <- (opp_def m). - apply plus_le_compat. - apply le_refl. - apply opp_le_compat; auto. + split; intros. + - rewrite <- (opp_def m). + apply plus_le_compat. + apply le_refl. + apply opp_le_compat; auto. + - apply plus_le_reg_r with (-n). + now rewrite plus_opp_r. Qed. - Lemma OMEGA2 : forall x y, 0 <= x -> 0 <= y -> 0 <= x + y. - Proof. - intros. - replace 0 with (0+0). - apply plus_le_compat; auto. - rewrite plus_0_l; auto. - Qed. - - Lemma OMEGA8 : forall x y, 0 <= x -> 0 <= y -> x = - y -> x = 0. + Lemma OMEGA8 x y : 0 <= x -> 0 <= y -> x = - y -> x = 0. Proof. intros. assert (y=-x). @@ -675,17 +574,15 @@ Module IntProperties (I:Int). elim (lt_not_eq _ _ H1); auto. Qed. - Lemma sum2 : - forall a b c d : int, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d. + Lemma sum2 a b c d : + 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d. Proof. - intros. - subst a; rewrite mult_0_l, plus_0_l. + intros Hd <- Hb. autorewrite with int. rewrite <- (mult_0_l 0). apply mult_le_compat; auto; apply le_refl. Qed. - Lemma sum3 : - forall a b c d : int, + Lemma sum3 a b c d : 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d. Proof. intros. @@ -697,56 +594,39 @@ Module IntProperties (I:Int). apply mult_le_compat; auto; apply le_refl. Qed. - Lemma sum4 : forall k : int, k>0 -> 0 <= k. - Proof. - intros k; rewrite gt_lt_iff; apply lt_le_weak. - Qed. - - (* Lemmas specific to integers (they use lt_le_int) *) - - Lemma lt_left : forall n m, n < m -> 0 <= m + -(1) + - n. - Proof. - intros; apply le_left. - now rewrite <- le_lt_int. - Qed. + (** Lemmas specific to integers (they use [le_lt_int]) *) - Lemma lt_left_inv : forall x y, 0 <= y + -(1) + - x -> x < y. + Lemma lt_left n m : n < m <-> 0 <= m + -n + -(1). Proof. - intros. - generalize (plus_le_compat _ _ _ _ H (le_refl x)); clear H. - now rewrite plus_0_l, <-plus_assoc, plus_opp_l, plus_0_r, le_lt_int. + rewrite <- plus_assoc, (plus_comm (-n)), plus_assoc. + rewrite <- le_left. + apply le_lt_int. Qed. - Lemma OMEGA4 : forall x y z, x > 0 -> y > x -> z * y + x <> 0. + Lemma OMEGA4 x y z : 0 < x -> x < y -> z * y + x <> 0. Proof. - intros. - intro H'. - rewrite gt_lt_iff in H,H0. + intros H H0 H'. + assert (0 < y) by now apply lt_trans with x. destruct (lt_eq_lt_dec z 0) as [[G|G]|G]. - rewrite lt_0_neg' in G. - generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0). - rewrite H'. - pattern y at 2; rewrite <-(mult_1_l y), <-mult_plus_distr_r. - intros. - rewrite le_lt_int in G. - rewrite <- opp_plus_distr in G. - assert (0 < y) by (apply lt_trans with x; auto). - generalize (mult_le_compat _ _ _ _ G (lt_le_weak _ _ H2) (le_refl 0) (le_refl 0)). - rewrite mult_0_l, mult_comm, <- opp_mult_distr_r, mult_comm, <-le_0_neg', le_lt_iff. - intuition. + - generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0). + rewrite H'. + rewrite <-(mult_1_l y) at 2. rewrite <-mult_plus_distr_r. + apply le_lt_iff. + rewrite mult_comm. rewrite <- (mult_0_r y). + apply mult_le_compat_l; auto using lt_le_weak. + apply le_0_neg. rewrite opp_plus_distr. + apply le_lt_int. now apply lt_0_neg. - subst; rewrite mult_0_l, plus_0_l in H'; subst. - apply (lt_not_eq _ _ H); auto. + - apply (lt_not_eq 0 (z*y+x)); auto. + subst. now autorewrite with int. - apply (lt_not_eq 0 (z*y+x)); auto. - rewrite <- (plus_0_l 0). - apply plus_lt_compat; auto. - apply mult_lt_0_compat; auto. - apply lt_trans with x; auto. + - apply (lt_not_eq 0 (z*y+x)); auto. + rewrite <- (plus_0_l 0). + auto using plus_lt_compat, mult_lt_0_compat. Qed. - Lemma OMEGA19 : forall x, x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). + Lemma OMEGA19 x : x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). Proof. intros. do 2 rewrite <- le_lt_int. @@ -759,35 +639,22 @@ Module IntProperties (I:Int). apply opp_lt_compat; auto. Qed. - Lemma mult_le_approx : - forall n m p, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. + Lemma mult_le_approx n m p : + 0 < n -> p < n -> 0 <= m * n + p -> 0 <= m. Proof. - intros n m p. - do 2 rewrite gt_lt_iff. - do 2 rewrite le_lt_iff; intros. - contradict H1. - rewrite lt_0_neg' in H1. - rewrite lt_0_neg'. - rewrite opp_plus_distr. - rewrite mult_comm, opp_mult_distr_r. + do 2 rewrite le_lt_iff; intros Hn Hpn H Hm. destruct H. + apply lt_0_neg, le_lt_int, le_left in Hm. + rewrite lt_0_neg. + rewrite opp_plus_distr, mult_comm, opp_mult_distr_r. + rewrite le_lt_int. apply lt_left. rewrite le_lt_int. - rewrite <- plus_assoc, (plus_comm (-p)), plus_assoc. - apply lt_left. - rewrite le_lt_int. - rewrite le_lt_int in H0. - apply le_trans with (n+-(1)); auto. + apply le_trans with (n+-(1)); [ now apply le_lt_int | ]. apply plus_le_compat; [ | apply le_refl ]. - rewrite le_lt_int in H1. - generalize (mult_le_compat _ _ _ _ (lt_le_weak _ _ H) H1 (le_refl 0) (le_refl 0)). - rewrite mult_0_l. - rewrite mult_plus_distr_l. - rewrite <- opp_eq_mult_neg_1. - intros. - generalize (plus_le_compat _ _ _ _ (le_refl n) H2). - now rewrite plus_permute, opp_def, plus_0_r, plus_0_r. + rewrite <- (mult_1_r n) at 1. + apply mult_le_compat_l; auto using lt_le_weak. Qed. - (* Some decidabilities *) + (** Some decidabilities *) Lemma dec_eq : forall i j:int, decidable (i=j). Proof. @@ -822,7 +689,7 @@ Module IntProperties (I:Int). End IntProperties. - +(** * The Coq side of the romega tactic *) Module IntOmega (I:Int). Import I. @@ -830,13 +697,16 @@ Module IP:=IntProperties(I). Import IP. Local Notation int := I.t. -(* \subsubsection{Definition of reified integer expressions} +(* ** Definition of reified integer expressions + Terms are either: - \begin{itemize} - \item integers [Tint] - \item variables [Tvar] - \item operation over integers (addition, product, opposite, subtraction) - The last two are translated in additions and products. *) + - integers [Tint] + - variables [Tvar] + - operation over integers (addition, product, opposite, subtraction) + + Opposite and subtraction are translated in additions and products. + Note that we'll only deal with products for which at least one side + is [Tint]. *) Inductive term : Set := | Tint : int -> term @@ -844,8 +714,9 @@ Inductive term : Set := | Tmult : term -> term -> term | Tminus : term -> term -> term | Topp : term -> term - | Tvar : nat -> term. + | Tvar : N -> term. +Bind Scope romega_scope with term. Delimit Scope romega_scope with term. Arguments Tint _%I. Arguments Tplus (_ _)%term. @@ -859,400 +730,212 @@ Infix "-" := Tminus : romega_scope. Notation "- x" := (Topp x) : romega_scope. Notation "[ x ]" := (Tvar x) (at level 0) : romega_scope. -(* \subsubsection{Definition of reified goals} *) +(* ** Definition of reified goals -(* Very restricted definition of handled predicates that should be extended + Very restricted definition of handled predicates that should be extended to cover a wider set of operations. Taking care of negations and disequations require solving more than a goal in parallel. This is a major improvement over previous versions. *) Inductive proposition : Set := - | EqTerm : term -> term -> proposition (* equality between terms *) - | LeqTerm : term -> term -> proposition (* less or equal on terms *) - | TrueTerm : proposition (* true *) - | FalseTerm : proposition (* false *) - | Tnot : proposition -> proposition (* negation *) + (** First, basic equations, disequations, inequations *) + | EqTerm : term -> term -> proposition + | NeqTerm : term -> term -> proposition + | LeqTerm : term -> term -> proposition | GeqTerm : term -> term -> proposition | GtTerm : term -> term -> proposition | LtTerm : term -> term -> proposition - | NeqTerm : term -> term -> proposition + (** Then, the supported logical connectors *) + | TrueTerm : proposition + | FalseTerm : proposition + | Tnot : proposition -> proposition | Tor : proposition -> proposition -> proposition | Tand : proposition -> proposition -> proposition | Timp : proposition -> proposition -> proposition + (** Everything else is left as a propositional atom (and ignored). *) | Tprop : nat -> proposition. -(* Definition of goals as a list of hypothesis *) +(** Definition of goals as a list of hypothesis *) Notation hyps := (list proposition). -(* Definition of lists of subgoals (set of open goals) *) +(** Definition of lists of subgoals (set of open goals) *) Notation lhyps := (list hyps). -(* a single goal packed in a subgoal list *) +(** A single goal packed in a subgoal list *) Notation singleton := (fun a : hyps => a :: nil). -(* an absurd goal *) +(** An absurd goal *) Definition absurd := FalseTerm :: nil. -(* \subsubsection{Traces for merging equations} - This inductive type describes how the monomial of two equations should be - merged when the equations are added. - - For [F_equal], both equations have the same head variable and coefficient - must be added, furthermore if coefficients are opposite, [F_cancel] should - be used to collapse the term. [F_left] and [F_right] indicate which monomial - should be put first in the result *) - -Inductive t_fusion : Set := - | F_equal : t_fusion - | F_cancel : t_fusion - | F_left : t_fusion - | F_right : t_fusion. - -(* \subsubsection{Rewriting steps to normalize terms} *) -Inductive step : Set := - (* apply the rewriting steps to both subterms of an operation *) - | C_DO_BOTH : step -> step -> step - (* apply the rewriting step to the first branch *) - | C_LEFT : step -> step - (* apply the rewriting step to the second branch *) - | C_RIGHT : step -> step - (* apply two steps consecutively to a term *) - | C_SEQ : step -> step -> step - (* empty step *) - | C_NOP : step - (* the following operations correspond to actual rewriting *) - | C_OPP_PLUS : step - | C_OPP_OPP : step - | C_OPP_MULT_R : step - | C_OPP_ONE : step - (* This is a special step that reduces the term (computation) *) - | C_REDUCE : step - | C_MULT_PLUS_DISTR : step - | C_MULT_OPP_LEFT : step - | C_MULT_ASSOC_R : step - | C_PLUS_ASSOC_R : step - | C_PLUS_ASSOC_L : step - | C_PLUS_PERMUTE : step - | C_PLUS_COMM : step - | C_RED0 : step - | C_RED1 : step - | C_RED2 : step - | C_RED3 : step - | C_RED4 : step - | C_RED5 : step - | C_RED6 : step - | C_MULT_ASSOC_REDUCED : step - | C_MINUS : step - | C_MULT_COMM : step. - -(* \subsubsection{Omega steps} *) -(* The following inductive type describes steps as they can be found in - the trace coming from the decision procedure Omega. *) - -Inductive t_omega : Set := - (* n = 0 and n!= 0 *) - | O_CONSTANT_NOT_NUL : nat -> t_omega - | O_CONSTANT_NEG : nat -> t_omega - (* division and approximation of an equation *) - | O_DIV_APPROX : int -> int -> term -> nat -> t_omega -> nat -> t_omega - (* no solution because no exact division *) - | O_NOT_EXACT_DIVIDE : int -> int -> term -> nat -> nat -> t_omega - (* exact division *) - | O_EXACT_DIVIDE : int -> term -> nat -> t_omega -> nat -> t_omega - | O_SUM : int -> nat -> int -> nat -> list t_fusion -> t_omega -> t_omega - | O_CONTRADICTION : nat -> nat -> nat -> t_omega - | O_MERGE_EQ : nat -> nat -> nat -> t_omega -> t_omega - | O_SPLIT_INEQ : nat -> nat -> t_omega -> t_omega -> t_omega - | O_CONSTANT_NUL : nat -> t_omega - | O_NEGATE_CONTRADICT : nat -> nat -> t_omega - | O_NEGATE_CONTRADICT_INV : nat -> nat -> nat -> t_omega - | O_STATE : int -> step -> nat -> nat -> t_omega -> t_omega. - -(* \subsubsection{Rules for normalizing the hypothesis} *) -(* These rules indicate how to normalize useful propositions - of each useful hypothesis before the decomposition of hypothesis. - The rules include the inversion phase for negation removal. *) - -Inductive p_step : Set := - | P_LEFT : p_step -> p_step - | P_RIGHT : p_step -> p_step - | P_INVERT : step -> p_step - | P_STEP : step -> p_step - | P_NOP : p_step. - -(* List of normalizations to perform : if the type [p_step] had a constructor - that indicated visiting both left and right branches, we would be able to - restrict ourselves to the case of only one normalization by hypothesis. - And since all hypothesis are useful (otherwise they wouldn't be included), - we would be able to replace [h_step] by a simple list. *) - -Inductive h_step : Set := - pair_step : nat -> p_step -> h_step. - -(* \subsubsection{Rules for decomposing the hypothesis} *) -(* This type allows navigation in the logical constructors that - form the predicats of the hypothesis in order to decompose them. - This allows in particular to extract one hypothesis from a - conjunction with possibly the right level of negations. *) - -Inductive direction : Set := - | D_left : direction - | D_right : direction - | D_mono : direction. - -(* This type allows extracting useful components from hypothesis, either - hypothesis generated by splitting a disjonction, or equations. - The last constructor indicates how to solve the obtained system - via the use of the trace type of Omega [t_omega] *) - -Inductive e_step : Set := - | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step - | E_EXTRACT : nat -> list direction -> e_step -> e_step - | E_SOLVE : t_omega -> e_step. - -(* \subsection{Efficient decidable equality} *) -(* For each reified data-type, we define an efficient equality test. - It is not the one produced by [Decide Equality]. - - Then we prove two theorem allowing elimination of such equalities : - \begin{verbatim} - (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2. - (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2. - \end{verbatim} *) - -(* \subsubsection{Reified terms} *) - -Open Scope romega_scope. +(** ** Decidable equality on terms *) Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := match t1, t2 with - | Tint st1, Tint st2 => beq st1 st2 - | (st11 + st12), (st21 + st22) => eq_term st11 st21 && eq_term st12 st22 - | (st11 * st12), (st21 * st22) => eq_term st11 st21 && eq_term st12 st22 - | (st11 - st12), (st21 - st22) => eq_term st11 st21 && eq_term st12 st22 - | (- st1), (- st2) => eq_term st1 st2 - | [st1], [st2] => beq_nat st1 st2 + | Tint i1, Tint i2 => i1 =? i2 + | (t11 + t12), (t21 + t22) => eq_term t11 t21 && eq_term t12 t22 + | (t11 * t12), (t21 * t22) => eq_term t11 t21 && eq_term t12 t22 + | (t11 - t12), (t21 - t22) => eq_term t11 t21 && eq_term t12 t22 + | (- t1), (- t2) => eq_term t1 t2 + | [v1], [v2] => N.eqb v1 v2 | _, _ => false - end. - -Close Scope romega_scope. + end%term. -Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2. -Proof. - induction t1; destruct t2; simpl in *; try discriminate; - (rewrite andb_true_iff; intros (H1,H2)) || intros H; f_equal; - auto using beq_true, beq_nat_true. -Qed. +Infix "=?" := eq_term : romega_scope. -Theorem eq_term_refl : forall t0 : term, eq_term t0 t0 = true. +Theorem eq_term_iff (t t' : term) : + (t =? t')%term = true <-> t = t'. Proof. - induction t0; simpl in *; try (apply andb_true_iff; split); trivial. - - now apply beq_iff. - - now apply beq_nat_true_iff. + revert t'. induction t; destruct t'; simpl in *; + rewrite ?andb_true_iff, ?beq_iff, ?N.eqb_eq, ?IHt, ?IHt1, ?IHt2; + intuition congruence. Qed. -Ltac trivial_case := unfold not; intros; discriminate. - -Theorem eq_term_false : - forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2. +Theorem eq_term_reflect (t t' : term) : reflect (t=t') (t =? t')%term. Proof. - intros t1 t2 H E. subst t2. now rewrite eq_term_refl in H. + apply iff_reflect. symmetry. apply eq_term_iff. Qed. -(* \subsubsection{Tactiques pour éliminer ces tests} - - Si on se contente de faire un [Case (eq_typ t1 t2)] on perd - totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2]. - - Initialement, les développements avaient été réalisés avec les - tests rendus par [Decide Equality], c'est à dire un test rendant - des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un - tel test préserve bien l'information voulue mais calculatoirement de - telles fonctions sont trop lentes. *) - -(* Les tactiques définies si après se comportent exactement comme si on - avait utilisé le test précédent et fait une elimination dessus. *) - -Ltac elim_eq_term t1 t2 := - let Aux := fresh "Aux" in - pattern (eq_term t1 t2); apply bool_eq_ind; intro Aux; - [ generalize (eq_term_true t1 t2 Aux); clear Aux - | generalize (eq_term_false t1 t2 Aux); clear Aux ]. - -Ltac elim_beq t1 t2 := - let Aux := fresh "Aux" in - pattern (beq t1 t2); apply bool_eq_ind; intro Aux; - [ generalize (beq_true t1 t2 Aux); clear Aux - | generalize (beq_false t1 t2 Aux); clear Aux ]. - -Ltac elim_bgt t1 t2 := - let Aux := fresh "Aux" in - pattern (bgt t1 t2); apply bool_eq_ind; intro Aux; - [ generalize (bgt_true t1 t2 Aux); clear Aux - | generalize (bgt_false t1 t2 Aux); clear Aux ]. - +(** ** Interpretations of terms (as integers). *) -(* \subsection{Interprétations} - \subsubsection{Interprétation des termes dans Z} *) +Fixpoint Nnth {A} (n:N)(l:list A)(default:A) := + match n, l with + | _, nil => default + | 0%N, x::_ => x + | _, _::l => Nnth (N.pred n) l default + end. -Fixpoint interp_term (env : list int) (t : term) {struct t} : int := +Fixpoint interp_term (env : list int) (t : term) : int := match t with | Tint x => x | (t1 + t2)%term => interp_term env t1 + interp_term env t2 | (t1 * t2)%term => interp_term env t1 * interp_term env t2 | (t1 - t2)%term => interp_term env t1 - interp_term env t2 | (- t)%term => - interp_term env t - | [n]%term => nth n env 0 + | [n]%term => Nnth n env 0 end. -(* \subsubsection{Interprétation des prédicats} *) +(** ** Interpretation of predicats (as Coq propositions) *) -Fixpoint interp_proposition (envp : list Prop) (env : list int) - (p : proposition) {struct p} : Prop := +Fixpoint interp_prop (envp : list Prop) (env : list int) + (p : proposition) : Prop := match p with | EqTerm t1 t2 => interp_term env t1 = interp_term env t2 + | NeqTerm t1 t2 => (interp_term env t1) <> (interp_term env t2) | LeqTerm t1 t2 => interp_term env t1 <= interp_term env t2 - | TrueTerm => True - | FalseTerm => False - | Tnot p' => ~ interp_proposition envp env p' | GeqTerm t1 t2 => interp_term env t1 >= interp_term env t2 | GtTerm t1 t2 => interp_term env t1 > interp_term env t2 | LtTerm t1 t2 => interp_term env t1 < interp_term env t2 - | NeqTerm t1 t2 => (interp_term env t1)<>(interp_term env t2) - | Tor p1 p2 => - interp_proposition envp env p1 \/ interp_proposition envp env p2 - | Tand p1 p2 => - interp_proposition envp env p1 /\ interp_proposition envp env p2 - | Timp p1 p2 => - interp_proposition envp env p1 -> interp_proposition envp env p2 + | TrueTerm => True + | FalseTerm => False + | Tnot p' => ~ interp_prop envp env p' + | Tor p1 p2 => interp_prop envp env p1 \/ interp_prop envp env p2 + | Tand p1 p2 => interp_prop envp env p1 /\ interp_prop envp env p2 + | Timp p1 p2 => interp_prop envp env p1 -> interp_prop envp env p2 | Tprop n => nth n envp True end. -(* \subsubsection{Inteprétation des listes d'hypothèses} - \paragraph{Sous forme de conjonction} - Interprétation sous forme d'une conjonction d'hypothèses plus faciles - à manipuler individuellement *) +(** ** Intepretation of hypothesis lists (as Coq conjunctions) *) -Fixpoint interp_hyps (envp : list Prop) (env : list int) - (l : hyps) {struct l} : Prop := +Fixpoint interp_hyps (envp : list Prop) (env : list int) (l : hyps) + : Prop := match l with | nil => True - | p' :: l' => interp_proposition envp env p' /\ interp_hyps envp env l' + | p' :: l' => interp_prop envp env p' /\ interp_hyps envp env l' end. -(* \paragraph{sous forme de but} - C'est cette interpétation que l'on utilise sur le but (car on utilise - [Generalize] et qu'une conjonction est forcément lourde (répétition des - types dans les conjonctions intermédiaires) *) +(** ** Interpretation of conclusion + hypotheses + + Here we use Coq implications : it's less easy to manipulate, + but handy to relate to the Coq original goal (cf. the use of + [generalize], and lighter (no repetition of types in intermediate + conjunctions). *) Fixpoint interp_goal_concl (c : proposition) (envp : list Prop) - (env : list int) (l : hyps) {struct l} : Prop := + (env : list int) (l : hyps) : Prop := match l with - | nil => interp_proposition envp env c + | nil => interp_prop envp env c | p' :: l' => - interp_proposition envp env p' -> interp_goal_concl c envp env l' + interp_prop envp env p' -> interp_goal_concl c envp env l' end. Notation interp_goal := (interp_goal_concl FalseTerm). -(* Les théorèmes qui suivent assurent la correspondance entre les deux - interprétations. *) +(** Equivalence between these two interpretations. *) Theorem goal_to_hyps : forall (envp : list Prop) (env : list int) (l : hyps), (interp_hyps envp env l -> False) -> interp_goal envp env l. Proof. - simple induction l; - [ simpl; auto - | simpl; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ]. + induction l; simpl; auto. Qed. Theorem hyps_to_goal : forall (envp : list Prop) (env : list int) (l : hyps), interp_goal envp env l -> interp_hyps envp env l -> False. Proof. - simple induction l; simpl; [ auto | intros; apply H; elim H1; auto ]. -Qed. - -(* \subsection{Manipulations sur les hypothèses} *) - -(* \subsubsection{Définitions de base de stabilité pour la réflexion} *) -(* Une opération laisse un terme stable si l'égalité est préservée *) -Definition term_stable (f : term -> term) := - forall (e : list int) (t : term), interp_term e t = interp_term e (f t). - -(* Une opération est valide sur une hypothèse, si l'hypothèse implique le - résultat de l'opération. \emph{Attention : cela ne concerne que des - opérations sur les hypothèses et non sur les buts (contravariance)}. - On définit la validité pour une opération prenant une ou deux propositions - en argument (cela suffit pour omega). *) - -Definition valid1 (f : proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p1 : proposition), - interp_proposition ep e p1 -> interp_proposition ep e (f p1). - -Definition valid2 (f : proposition -> proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p1 p2 : proposition), - interp_proposition ep e p1 -> - interp_proposition ep e p2 -> interp_proposition ep e (f p1 p2). - -(* Dans cette notion de validité, la fonction prend directement une - liste de propositions et rend une nouvelle liste de proposition. - On reste contravariant *) - -Definition valid_hyps (f : hyps -> hyps) := - forall (ep : list Prop) (e : list int) (lp : hyps), - interp_hyps ep e lp -> interp_hyps ep e (f lp). - -(* Enfin ce théorème élimine la contravariance et nous ramène à une - opération sur les buts *) - -Theorem valid_goal : - forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps), - valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l. -Proof. - intros; simpl; apply goal_to_hyps; intro H1; - apply (hyps_to_goal ep env (a l) H0); apply H; assumption. + induction l; simpl; auto. + intros H (H1,H2). auto. Qed. -(* \subsubsection{Généralisation a des listes de buts (disjonctions)} *) +(** ** Interpretations of list of goals + Here again, two flavours... *) Fixpoint interp_list_hyps (envp : list Prop) (env : list int) - (l : lhyps) {struct l} : Prop := + (l : lhyps) : Prop := match l with | nil => False | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l' end. Fixpoint interp_list_goal (envp : list Prop) (env : list int) - (l : lhyps) {struct l} : Prop := + (l : lhyps) : Prop := match l with | nil => True | h :: l' => interp_goal envp env h /\ interp_list_goal envp env l' end. +(** Equivalence between the two flavours. *) + Theorem list_goal_to_hyps : forall (envp : list Prop) (env : list int) (l : lhyps), (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l. Proof. - simple induction l; simpl; - [ auto - | intros h1 l1 H H1; split; - [ apply goal_to_hyps; intro H2; apply H1; auto - | apply H; intro H2; apply H1; auto ] ]. + induction l; simpl; intuition. now apply goal_to_hyps. Qed. Theorem list_hyps_to_goal : forall (envp : list Prop) (env : list int) (l : lhyps), interp_list_goal envp env l -> interp_list_hyps envp env l -> False. Proof. - simple induction l; simpl; - [ auto - | intros h1 l1 H (H1, H2) H3; elim H3; intro H4; - [ apply hyps_to_goal with (1 := H1); assumption | auto ] ]. + induction l; simpl; intuition. eapply hyps_to_goal; eauto. Qed. +(** ** Stabiliy and validity of operations *) + +(** An operation on terms is stable if the interpretation is unchanged. *) + +Definition term_stable (f : term -> term) := + forall (e : list int) (t : term), interp_term e t = interp_term e (f t). + +(** An operation on one hypothesis is valid if this hypothesis implies + the result of this operation. *) + +Definition valid1 (f : proposition -> proposition) := + forall (ep : list Prop) (e : list int) (p1 : proposition), + interp_prop ep e p1 -> interp_prop ep e (f p1). + +Definition valid2 (f : proposition -> proposition -> proposition) := + forall (ep : list Prop) (e : list int) (p1 p2 : proposition), + interp_prop ep e p1 -> + interp_prop ep e p2 -> interp_prop ep e (f p1 p2). + +(** Same for lists of hypotheses, and for list of goals *) + +Definition valid_hyps (f : hyps -> hyps) := + forall (ep : list Prop) (e : list int) (lp : hyps), + interp_hyps ep e lp -> interp_hyps ep e (f lp). + Definition valid_list_hyps (f : hyps -> lhyps) := forall (ep : list Prop) (e : list int) (lp : hyps), interp_hyps ep e lp -> interp_list_hyps ep e (f lp). @@ -1261,6 +944,16 @@ Definition valid_list_goal (f : hyps -> lhyps) := forall (ep : list Prop) (e : list int) (lp : hyps), interp_list_goal ep e (f lp) -> interp_goal ep e lp. +(** Some results about these validities. *) + +Theorem valid_goal : + forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps), + valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l. +Proof. + intros; simpl; apply goal_to_hyps; intro H1; + apply (hyps_to_goal ep env (a l) H0); apply H; assumption. +Qed. + Theorem goal_valid : forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f. Proof. @@ -1274,33 +967,31 @@ Theorem append_valid : interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 -> interp_list_hyps ep e (l1 ++ l2). Proof. - intros ep e; simple induction l1; - [ simpl; intros l2 [H| H]; [ contradiction | trivial ] - | simpl; intros h1 t1 HR l2 [[H| H]| H]; - [ auto - | right; apply (HR l2); left; trivial - | right; apply (HR l2); right; trivial ] ]. - + induction l1; simpl in *. + - now intros l2 [H| H]. + - intros l2 [[H| H]| H]. + + auto. + + right; apply IHl1; now left. + + right; apply IHl1; now right. Qed. -(* \subsubsection{Opérateurs valides sur les hypothèses} *) +(** ** Valid operations on hypotheses *) + +(** Extract an hypothesis from the list *) -(* Extraire une hypothèse de la liste *) Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. -Unset Printing Notations. + Theorem nth_valid : forall (ep : list Prop) (e : list int) (i : nat) (l : hyps), - interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l). + interp_hyps ep e l -> interp_prop ep e (nth_hyps i l). Proof. - unfold nth_hyps; simple induction i; - [ simple induction l; simpl; [ auto | intros; elim H0; auto ] - | intros n H; simple induction l; - [ simpl; trivial - | intros; simpl; apply H; elim H1; auto ] ]. + unfold nth_hyps. induction i; destruct l; simpl in *; try easy. + intros (H1,H2). now apply IHi. Qed. -(* Appliquer une opération (valide) sur deux hypothèses extraites de - la liste et ajouter le résultat à la liste. *) +(** Apply a valid operation on two hypotheses from the list, and + store the result in the list. *) + Definition apply_oper_2 (i j : nat) (f : proposition -> proposition -> proposition) (l : hyps) := f (nth_hyps i l) (nth_hyps j l) :: l. @@ -1310,15 +1001,18 @@ Theorem apply_oper_2_valid : valid2 f -> valid_hyps (apply_oper_2 i j f). Proof. intros i j f Hf; unfold apply_oper_2, valid_hyps; simpl; - intros lp Hlp; split; [ apply Hf; apply nth_valid; assumption | assumption ]. + intros lp Hlp; split. + - apply Hf; apply nth_valid; assumption. + - assumption. Qed. -(* Modifier une hypothèse par application d'une opération valide *) +(** In-place modification of an hypothesis by application of + a valid operation. *) Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) (l : hyps) {struct i} : hyps := match l with - | nil => nil (A:=proposition) + | nil => nil | p :: l' => match i with | O => f p :: l' @@ -1330,105 +1024,11 @@ Theorem apply_oper_1_valid : forall (i : nat) (f : proposition -> proposition), valid1 f -> valid_hyps (apply_oper_1 i f). Proof. - unfold valid_hyps; intros i f Hf ep e; elim i; - [ intro lp; case lp; - [ simpl; trivial - | simpl; intros p l' (H1, H2); split; - [ apply Hf with (1 := H1) | assumption ] ] - | intros n Hrec lp; case lp; - [ simpl; auto - | simpl; intros p l' (H1, H2); split; - [ assumption | apply Hrec; assumption ] ] ]. + unfold valid_hyps. + induction i; intros f Hf ep e [ | p lp]; simpl; intuition. Qed. -(* \subsubsection{Manipulations de termes} *) -(* Les fonctions suivantes permettent d'appliquer une fonction de - réécriture sur un sous terme du terme principal. Avec la composition, - cela permet de construire des réécritures complexes proches des - tactiques de conversion *) - -Definition apply_left (f : term -> term) (t : term) := - match t with - | (x + y)%term => (f x + y)%term - | (x * y)%term => (f x * y)%term - | (- x)%term => (- f x)%term - | x => x - end. - -Definition apply_right (f : term -> term) (t : term) := - match t with - | (x + y)%term => (x + f y)%term - | (x * y)%term => (x * f y)%term - | x => x - end. - -Definition apply_both (f g : term -> term) (t : term) := - match t with - | (x + y)%term => (f x + g y)%term - | (x * y)%term => (f x * g y)%term - | x => x - end. - -(* Les théorèmes suivants montrent la stabilité (conditionnée) des - fonctions. *) - -Theorem apply_left_stable : - forall f : term -> term, term_stable f -> term_stable (apply_left f). -Proof. - unfold term_stable; intros f H e t; case t; auto; simpl; - intros; elim H; trivial. -Qed. - -Theorem apply_right_stable : - forall f : term -> term, term_stable f -> term_stable (apply_right f). -Proof. - unfold term_stable; intros f H e t; case t; auto; simpl; - intros t0 t1; elim H; trivial. -Qed. - -Theorem apply_both_stable : - forall f g : term -> term, - term_stable f -> term_stable g -> term_stable (apply_both f g). -Proof. - unfold term_stable; intros f g H1 H2 e t; case t; auto; simpl; - intros t0 t1; elim H1; elim H2; trivial. -Qed. - -Theorem compose_term_stable : - forall f g : term -> term, - term_stable f -> term_stable g -> term_stable (fun t : term => f (g t)). -Proof. - unfold term_stable; intros f g Hf Hg e t; elim Hf; apply Hg. -Qed. - -(* \subsection{Les règles de réécriture} *) -(* Chacune des règles de réécriture est accompagnée par sa preuve de - stabilité. Toutes ces preuves ont la même forme : il faut analyser - suivant la forme du terme (élimination de chaque Case). On a besoin d'une - élimination uniquement dans les cas d'utilisation d'égalité décidable. - - Cette tactique itère la décomposition des Case. Elle est - constituée de deux fonctions s'appelant mutuellement : - \begin{itemize} - \item une fonction d'enrobage qui lance la recherche sur le but, - \item une fonction récursive qui décompose ce but. Quand elle a trouvé un - Case, elle l'élimine. - \end{itemize} - Les motifs sur les cas sont très imparfaits et dans certains cas, il - semble que cela ne marche pas. On aimerait plutot un motif de la - forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on - utilise le bon type. - - Chaque élimination introduit correctement exactement le nombre d'hypothèses - nécessaires et conserve dans le cas d'une égalité la connaissance du - résultat du test en faisant la réécriture. Pour un test de comparaison, - on conserve simplement le résultat. - - Cette fonction déborde très largement la résolution des réécritures - simples et fait une bonne partie des preuves des pas de Omega. -*) - -(* \subsubsection{La tactique pour prouver la stabilité} *) +(** ** A tactic for proving stability *) Ltac loop t := match t with @@ -1438,54 +1038,33 @@ Ltac loop t := (* Interpretations *) | (interp_hyps _ _ ?X1) => loop X1 | (interp_list_hyps _ _ ?X1) => loop X1 - | (interp_proposition _ _ ?X1) => loop X1 + | (interp_prop _ _ ?X1) => loop X1 | (interp_term _ ?X1) => loop X1 (* Propositions *) | (EqTerm ?X1 ?X2) => loop X1 || loop X2 | (LeqTerm ?X1 ?X2) => loop X1 || loop X2 - (* Termes *) + (* Terms *) | (?X1 + ?X2)%term => loop X1 || loop X2 | (?X1 - ?X2)%term => loop X1 || loop X2 | (?X1 * ?X2)%term => loop X1 || loop X2 | (- ?X1)%term => loop X1 | (Tint ?X1) => loop X1 (* Eliminations *) - | match ?X1 with - | EqTerm _ _ => _ - | LeqTerm _ _ => _ - | TrueTerm => _ - | FalseTerm => _ - | Tnot _ => _ - | GeqTerm _ _ => _ - | GtTerm _ _ => _ - | LtTerm _ _ => _ - | NeqTerm _ _ => _ - | Tor _ _ => _ - | Tand _ _ => _ - | Timp _ _ => _ - | Tprop _ => _ - end => destruct X1; auto; Simplify - | match ?X1 with - | Tint _ => _ - | (_ + _)%term => _ - | (_ * _)%term => _ - | (_ - _)%term => _ - | (- _)%term => _ - | [_]%term => _ - end => destruct X1; auto; Simplify - | (if beq ?X1 ?X2 then _ else _) => + | (if ?X1 =? ?X2 then _ else _) => let H := fresh "H" in - elim_beq X1 X2; intro H; try (rewrite H in *; clear H); - simpl; auto; Simplify - | (if bgt ?X1 ?X2 then _ else _) => + case (beq_reflect X1 X2); intro H; + try (rewrite H in *; clear H); simpl; auto; Simplify + | (if ?X1 <? ?X2 then _ else _) => + case (blt_reflect X1 X2); intro; simpl; auto; Simplify + | (if (?X1 =? ?X2)%term then _ else _) => let H := fresh "H" in - elim_bgt X1 X2; intro H; simpl; auto; Simplify - | (if eq_term ?X1 ?X2 then _ else _) => - let H := fresh "H" in - elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H); - simpl; auto; Simplify + case (eq_term_reflect X1 X2); intro H; + try (rewrite H in *; clear H); simpl; auto; Simplify | (if _ && _ then _ else _) => rewrite andb_if; Simplify | (if negb _ then _ else _) => rewrite negb_if; Simplify + | match N.compare ?X1 ?X2 with _ => _ end => + destruct (N.compare_spec X1 X2); Simplify + | match ?X1 with _ => _ end => destruct X1; auto; Simplify | _ => fail end @@ -1494,875 +1073,529 @@ with Simplify := match goal with | _ => idtac end. -Ltac prove_stable x th := - match constr:(x) with - | ?X1 => - unfold term_stable, X1; intros; Simplify; simpl; - apply th - end. - -(* \subsubsection{Les règles elle mêmes} *) -Definition Tplus_assoc_l (t : term) := - match t with - | (n + (m + p))%term => (n + m + p)%term - | _ => t - end. - -Theorem Tplus_assoc_l_stable : term_stable Tplus_assoc_l. -Proof. - prove_stable Tplus_assoc_l (ring.(Radd_assoc)). -Qed. - -Definition Tplus_assoc_r (t : term) := - match t with - | (n + m + p)%term => (n + (m + p))%term - | _ => t - end. - -Theorem Tplus_assoc_r_stable : term_stable Tplus_assoc_r. -Proof. - prove_stable Tplus_assoc_r plus_assoc_reverse. -Qed. - -Definition Tmult_assoc_r (t : term) := - match t with - | (n * m * p)%term => (n * (m * p))%term - | _ => t - end. - -Theorem Tmult_assoc_r_stable : term_stable Tmult_assoc_r. -Proof. - prove_stable Tmult_assoc_r mult_assoc_reverse. -Qed. - -Definition Tplus_permute (t : term) := - match t with - | (n + (m + p))%term => (m + (n + p))%term - | _ => t - end. - -Theorem Tplus_permute_stable : term_stable Tplus_permute. -Proof. - prove_stable Tplus_permute plus_permute. -Qed. - -Definition Tplus_comm (t : term) := - match t with - | (x + y)%term => (y + x)%term - | _ => t - end. - -Theorem Tplus_comm_stable : term_stable Tplus_comm. -Proof. - prove_stable Tplus_comm plus_comm. -Qed. - -Definition Tmult_comm (t : term) := - match t with - | (x * y)%term => (y * x)%term - | _ => t - end. - -Theorem Tmult_comm_stable : term_stable Tmult_comm. -Proof. - prove_stable Tmult_comm mult_comm. -Qed. - -Definition T_OMEGA10 (t : term) := - match t with - | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term => - if eq_term v v' - then (v * Tint (c1 * k1 + c2 * k2)%I + (l1 * Tint k1 + l2 * Tint k2))%term - else t - | _ => t - end. - -Theorem T_OMEGA10_stable : term_stable T_OMEGA10. -Proof. - prove_stable T_OMEGA10 OMEGA10. -Qed. - -Definition T_OMEGA11 (t : term) := - match t with - | ((v1 * Tint c1 + l1) * Tint k1 + l2)%term => - (v1 * Tint (c1 * k1) + (l1 * Tint k1 + l2))%term - | _ => t - end. - -Theorem T_OMEGA11_stable : term_stable T_OMEGA11. -Proof. - prove_stable T_OMEGA11 OMEGA11. -Qed. - -Definition T_OMEGA12 (t : term) := - match t with - | (l1 + (v2 * Tint c2 + l2) * Tint k2)%term => - (v2 * Tint (c2 * k2) + (l1 + l2 * Tint k2))%term - | _ => t - end. - -Theorem T_OMEGA12_stable : term_stable T_OMEGA12. -Proof. - prove_stable T_OMEGA12 OMEGA12. -Qed. - -Definition T_OMEGA13 (t : term) := - match t with - | (v * Tint x + l1 + (v' * Tint x' + l2))%term => - if eq_term v v' && beq x (-x') - then (l1+l2)%term - else t - | _ => t - end. - -Theorem T_OMEGA13_stable : term_stable T_OMEGA13. -Proof. - unfold term_stable, T_OMEGA13; intros; Simplify; simpl; - apply OMEGA13. -Qed. - -Definition T_OMEGA15 (t : term) := - match t with - | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term => - if eq_term v v' - then (v * Tint (c1 + c2 * k2)%I + (l1 + l2 * Tint k2))%term - else t - | _ => t - end. - -Theorem T_OMEGA15_stable : term_stable T_OMEGA15. -Proof. - prove_stable T_OMEGA15 OMEGA15. -Qed. - -Definition T_OMEGA16 (t : term) := - match t with - | ((v * Tint c + l) * Tint k)%term => (v * Tint (c * k) + l * Tint k)%term - | _ => t - end. - - -Theorem T_OMEGA16_stable : term_stable T_OMEGA16. -Proof. - prove_stable T_OMEGA16 OMEGA16. -Qed. - -Definition Tred_factor5 (t : term) := - match t with - | (x * Tint c + y)%term => if beq c 0 then y else t - | _ => t - end. - -Theorem Tred_factor5_stable : term_stable Tred_factor5. -Proof. - prove_stable Tred_factor5 red_factor5. -Qed. - -Definition Topp_plus (t : term) := - match t with - | (- (x + y))%term => (- x + - y)%term - | _ => t - end. - -Theorem Topp_plus_stable : term_stable Topp_plus. -Proof. - prove_stable Topp_plus opp_plus_distr. -Qed. - - -Definition Topp_opp (t : term) := - match t with - | (- - x)%term => x - | _ => t - end. - -Theorem Topp_opp_stable : term_stable Topp_opp. -Proof. - prove_stable Topp_opp opp_involutive. -Qed. - -Definition Topp_mult_r (t : term) := - match t with - | (- (x * Tint k))%term => (x * Tint (- k))%term - | _ => t - end. - -Theorem Topp_mult_r_stable : term_stable Topp_mult_r. -Proof. - prove_stable Topp_mult_r opp_mult_distr_r. -Qed. - -Definition Topp_one (t : term) := - match t with - | (- x)%term => (x * Tint (-(1)))%term - | _ => t - end. - -Theorem Topp_one_stable : term_stable Topp_one. -Proof. - prove_stable Topp_one opp_eq_mult_neg_1. -Qed. - -Definition Tmult_plus_distr (t : term) := - match t with - | ((n + m) * p)%term => (n * p + m * p)%term - | _ => t - end. - -Theorem Tmult_plus_distr_stable : term_stable Tmult_plus_distr. -Proof. - prove_stable Tmult_plus_distr mult_plus_distr_r. -Qed. - -Definition Tmult_opp_left (t : term) := - match t with - | (- x * Tint y)%term => (x * Tint (- y))%term - | _ => t - end. - -Theorem Tmult_opp_left_stable : term_stable Tmult_opp_left. -Proof. - prove_stable Tmult_opp_left mult_opp_comm. -Qed. +(** ** Operations on equation bodies *) -Definition Tmult_assoc_reduced (t : term) := - match t with - | (n * Tint m * Tint p)%term => (n * Tint (m * p))%term - | _ => t - end. +(** The operations below handle in priority _normalized_ terms, i.e. + terms of the form: + [([v1]*Tint k1 + ([v2]*Tint k2 + (... + Tint cst)))] + with [v1>v2>...] and all [ki<>0]. + See [normalize] below for a way to put terms in this form. -Theorem Tmult_assoc_reduced_stable : term_stable Tmult_assoc_reduced. -Proof. - prove_stable Tmult_assoc_reduced mult_assoc_reverse. -Qed. + These operations also produce a correct (but suboptimal) + result in case of non-normalized input terms, but this situation + should normally not happen when running [romega]. -Definition Tred_factor0 (t : term) := (t * Tint 1)%term. + /!\ Do not modify this section (especially [fusion] and [normalize]) + without tweaking the corresponding functions in [refl_omega.ml]. +*) -Theorem Tred_factor0_stable : term_stable Tred_factor0. -Proof. - prove_stable Tred_factor0 red_factor0. -Qed. +(** Multiplication and sum by two constants. Invariant: [k1<>0]. *) -Definition Tred_factor1 (t : term) := +Fixpoint scalar_mult_add (t : term) (k1 k2 : int) : term := match t with - | (x + y)%term => - if eq_term x y - then (x * Tint 2)%term - else t - | _ => t - end. + | v1 * Tint x1 + l1 => + v1 * Tint (x1 * k1) + scalar_mult_add l1 k1 k2 + | Tint x => Tint (k1 * x + k2) + | _ => t * Tint k1 + Tint k2 (* shouldn't happen *) + end%term. -Theorem Tred_factor1_stable : term_stable Tred_factor1. +Theorem scalar_mult_add_stable e t k1 k2 : + interp_term e (scalar_mult_add t k1 k2) = + interp_term e (t * Tint k1 + Tint k2). Proof. - prove_stable Tred_factor1 red_factor1. + induction t; simpl; Simplify; simpl; auto. f_equal. apply mult_comm. + rewrite IHt2. simpl. apply OMEGA11. Qed. -Definition Tred_factor2 (t : term) := - match t with - | (x + y * Tint k)%term => - if eq_term x y - then (x * Tint (1 + k))%term - else t - | _ => t - end. - -Theorem Tred_factor2_stable : term_stable Tred_factor2. -Proof. - prove_stable Tred_factor2 red_factor2. -Qed. +(** Multiplication by a (non-nul) constant. *) -Definition Tred_factor3 (t : term) := - match t with - | (x * Tint k + y)%term => - if eq_term x y - then (x * Tint (1 + k))%term - else t - | _ => t - end. +Definition scalar_mult (t : term) (k : int) := scalar_mult_add t k 0. -Theorem Tred_factor3_stable : term_stable Tred_factor3. +Theorem scalar_mult_stable e t k : + interp_term e (scalar_mult t k) = + interp_term e (t * Tint k). Proof. - prove_stable Tred_factor3 red_factor3. + unfold scalar_mult. rewrite scalar_mult_add_stable. simpl. + apply plus_0_r. Qed. +(** Adding a constant -Definition Tred_factor4 (t : term) := - match t with - | (x * Tint k1 + y * Tint k2)%term => - if eq_term x y - then (x * Tint (k1 + k2))%term - else t - | _ => t - end. - -Theorem Tred_factor4_stable : term_stable Tred_factor4. -Proof. - prove_stable Tred_factor4 red_factor4. -Qed. - -Definition Tred_factor6 (t : term) := (t + Tint 0)%term. - -Theorem Tred_factor6_stable : term_stable Tred_factor6. -Proof. - prove_stable Tred_factor6 red_factor6. -Qed. + Instead of using [scalar_norm_add t 1 k], the following + definition spares some computations. + *) -Definition Tminus_def (t : term) := +Fixpoint scalar_add (t : term) (k : int) : term := match t with - | (x - y)%term => (x + - y)%term - | _ => t - end. + | m + l => m + scalar_add l k + | Tint x => Tint (x + k) + | _ => t + Tint k + end%term. -Theorem Tminus_def_stable : term_stable Tminus_def. +Theorem scalar_add_stable e t k : + interp_term e (scalar_add t k) = interp_term e (t + Tint k). Proof. - prove_stable Tminus_def minus_def. + induction t; simpl; Simplify; simpl; auto. + rewrite IHt2. simpl. apply plus_assoc. Qed. -(* \subsection{Fonctions de réécriture complexes} *) +(** Division by a constant -(* \subsubsection{Fonction de réduction} *) -(* Cette fonction réduit un terme dont la forme normale est un entier. Il - suffit pour cela d'échanger le constructeur [Tint] avec les opérateurs - réifiés. La réduction est ``gratuite''. *) + All the non-constant coefficients should be exactly dividable *) -Fixpoint reduce (t : term) : term := +Fixpoint scalar_div (t : term) (k : int) : option (term * int) := match t with - | (x + y)%term => - match reduce x with - | Tint x' => - match reduce y with - | Tint y' => Tint (x' + y') - | y' => (Tint x' + y')%term - end - | x' => (x' + reduce y)%term - end - | (x * y)%term => - match reduce x with - | Tint x' => - match reduce y with - | Tint y' => Tint (x' * y') - | y' => (Tint x' * y')%term - end - | x' => (x' * reduce y)%term - end - | (x - y)%term => - match reduce x with - | Tint x' => - match reduce y with - | Tint y' => Tint (x' - y') - | y' => (Tint x' - y')%term - end - | x' => (x' - reduce y)%term + | v * Tint x + l => + let (q,r) := diveucl x k in + if (r =? 0)%I then + match scalar_div l k with + | None => None + | Some (u,c) => Some (v * Tint q + u, c) end - | (- x)%term => - match reduce x with - | Tint x' => Tint (- x') - | x' => (- x')%term - end - | _ => t - end. + else None + | Tint x => + let (q,r) := diveucl x k in + Some (Tint q, r) + | _ => None + end%term. + +Lemma scalar_div_stable e t k u c : k<>0 -> + scalar_div t k = Some (u,c) -> + interp_term e (u * Tint k + Tint c) = interp_term e t. +Proof. + revert u c. + induction t; simpl; Simplify; try easy. + - intros u c Hk. assert (H := diveucl_spec t0 k Hk). + simpl in H. + destruct diveucl as (q,r). simpl in H. rewrite H. + injection 1 as <- <-. simpl. f_equal. apply mult_comm. + - intros u c Hk. + destruct t1; simpl; Simplify; try easy. + destruct t1_2; simpl; Simplify; try easy. + assert (H := diveucl_spec t0 k Hk). + simpl in H. + destruct diveucl as (q,r). simpl in H. rewrite H. + case beq_reflect; [intros -> | easy]. + destruct (scalar_div t2 k) as [(u',c')|] eqn:E; [|easy]. + injection 1 as <- ->. simpl. + rewrite <- (IHt2 u' c Hk); simpl; auto. + rewrite plus_0_r , (mult_comm k q). symmetry. apply OMEGA11. +Qed. + + +(** Fusion of two equations. + + From two normalized equations, this fusion will produce + a normalized output corresponding to the coefficiented sum. + Invariant: [k1<>0] and [k2<>0]. +*) -Theorem reduce_stable : term_stable reduce. -Proof. - unfold term_stable; intros e t; elim t; auto; - try - (intros t0 H0 t1 H1; simpl; rewrite H0; rewrite H1; - (case (reduce t0); - [ intro z0; case (reduce t1); intros; auto - | intros; auto - | intros; auto - | intros; auto - | intros; auto - | intros; auto ])); intros t0 H0; simpl; - rewrite H0; case (reduce t0); intros; auto. -Qed. +Fixpoint fusion (t1 t2 : term) (k1 k2 : int) : term := + match t1 with + | [v1] * Tint x1 + l1 => + (fix fusion_t1 t2 : term := + match t2 with + | [v2] * Tint x2 + l2 => + match N.compare v1 v2 with + | Eq => + let k := (k1 * x1 + k2 * x2)%I in + if (k =? 0)%I then fusion l1 l2 k1 k2 + else [v1] * Tint k + fusion l1 l2 k1 k2 + | Lt => [v2] * Tint (k2 * x2) + fusion_t1 l2 + | Gt => [v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2 + end + | Tint x2 => [v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2 + | _ => t1 * Tint k1 + t2 * Tint k2 (* shouldn't happen *) + end) t2 + | Tint x1 => scalar_mult_add t2 k2 (k1 * x1) + | _ => t1 * Tint k1 + t2 * Tint k2 (* shouldn't happen *) + end%term. + +Theorem fusion_stable e t1 t2 k1 k2 : + interp_term e (fusion t1 t2 k1 k2) = + interp_term e (t1 * Tint k1 + t2 * Tint k2). +Proof. + revert t2; induction t1; simpl; Simplify; simpl; auto. + - intros; rewrite scalar_mult_add_stable. simpl. + rewrite plus_comm. f_equal. apply mult_comm. + - intros. Simplify. induction t2; simpl; Simplify; simpl; auto. + + rewrite IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11. + + rewrite IHt1_2. simpl. subst n0. + rewrite (mult_comm k1), (mult_comm k2) in H0. + rewrite <- OMEGA10, H0. now autorewrite with int. + + rewrite IHt1_2. simpl. subst n0. + rewrite (mult_comm k1), (mult_comm k2); apply OMEGA10. + + rewrite IHt2_2. simpl. rewrite (mult_comm k2); apply OMEGA12. + + rewrite IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11. +Qed. + +(** Term normalization. + + Precondition: all [Tmult] should be on at least one [Tint]. + Postcondition: a normalized equivalent term (see below). +*) -(* \subsubsection{Fusions} - \paragraph{Fusion de deux équations} *) -(* On donne une somme de deux équations qui sont supposées normalisées. - Cette fonction prend une trace de fusion en argument et transforme - le terme en une équation normalisée. C'est une version très simplifiée - du moteur de réécriture [rewrite]. *) - -Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := - match trace with - | nil => reduce t - | step :: trace' => - match step with - | F_equal => apply_right (fusion trace') (T_OMEGA10 t) - | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA10 t)) - | F_left => apply_right (fusion trace') (T_OMEGA11 t) - | F_right => apply_right (fusion trace') (T_OMEGA12 t) - end +Fixpoint normalize t := + match t with + | Tint n => Tint n + | [n]%term => ([n] * Tint 1 + Tint 0)%term + | (t + t')%term => fusion (normalize t) (normalize t') 1 1 + | (- t)%term => scalar_mult (normalize t) (-(1)) + | (t - t')%term => fusion (normalize t) (normalize t') 1 (-(1)) + | (Tint k * t)%term | (t * Tint k)%term => + if k =? 0 then Tint 0 else scalar_mult (normalize t) k + | (t1 * t2)%term => (t1 * t2)%term (* shouldn't happen *) end. -Theorem fusion_stable : forall trace : list t_fusion, term_stable (fusion trace). +Theorem normalize_stable : term_stable normalize. Proof. - simple induction trace; simpl; - [ exact reduce_stable - | intros stp l H; case stp; - [ apply compose_term_stable; - [ apply apply_right_stable; assumption | exact T_OMEGA10_stable ] - | unfold term_stable; intros e t1; rewrite T_OMEGA10_stable; - rewrite Tred_factor5_stable; apply H - | apply compose_term_stable; - [ apply apply_right_stable; assumption | exact T_OMEGA11_stable ] - | apply compose_term_stable; - [ apply apply_right_stable; assumption | exact T_OMEGA12_stable ] ] ]. + intros e t. + induction t; simpl; Simplify; simpl; + rewrite ?scalar_mult_stable; simpl in *; rewrite <- ?IHt1; + rewrite ?fusion_stable; simpl; autorewrite with int; auto. + - now f_equal. + - rewrite mult_comm. now f_equal. + - rewrite <- opp_eq_mult_neg_1, <-minus_def. now f_equal. + - rewrite <- opp_eq_mult_neg_1. now f_equal. Qed. -(* \paragraph{Fusion de deux équations dont une sans coefficient} *) - -Definition fusion_right (trace : list t_fusion) (t : term) : term := - match trace with - | nil => reduce t (* Il faut mettre un compute *) - | step :: trace' => - match step with - | F_equal => apply_right (fusion trace') (T_OMEGA15 t) - | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA15 t)) - | F_left => apply_right (fusion trace') (Tplus_assoc_r t) - | F_right => apply_right (fusion trace') (T_OMEGA12 t) - end - end. +(** ** Normalization of a proposition. -(* \paragraph{Fusion avec annihilation} *) -(* Normalement le résultat est une constante *) + The only basic facts left after normalization are + [0 = ...] or [0 <> ...] or [0 <= ...]. + When a fact is in negative position, we factorize a [Tnot] + out of it, and normalize the reversed fact inside. -Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term := - match trace with - | O => reduce t - | S trace' => fusion_cancel trace' (T_OMEGA13 t) - end. + /!\ Here again, do not change this code without corresponding + modifications in [refl_omega.ml]. +*) -Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t). +Fixpoint normalize_prop (negated:bool)(p:proposition) := + match p with + | EqTerm t1 t2 => + if negated then Tnot (NeqTerm (Tint 0) (normalize (t1-t2))) + else EqTerm (Tint 0) (normalize (t1-t2)) + | NeqTerm t1 t2 => + if negated then Tnot (EqTerm (Tint 0) (normalize (t1-t2))) + else NeqTerm (Tint 0) (normalize (t1-t2)) + | LeqTerm t1 t2 => + if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1))))) + else LeqTerm (Tint 0) (normalize (t2-t1)) + | GeqTerm t1 t2 => + if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1))))) + else LeqTerm (Tint 0) (normalize (t1-t2)) + | LtTerm t1 t2 => + if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2))) + else LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1)))) + | GtTerm t1 t2 => + if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1))) + else LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1)))) + | Tnot p => Tnot (normalize_prop (negb negated) p) + | Tor p p' => Tor (normalize_prop negated p) (normalize_prop negated p') + | Tand p p' => Tand (normalize_prop negated p) (normalize_prop negated p') + | Timp p p' => Timp (normalize_prop (negb negated) p) + (normalize_prop negated p') + | Tprop _ | TrueTerm | FalseTerm => p + end. + +Definition normalize_hyps := List.map (normalize_prop false). + +Local Ltac simp := cbn -[normalize]. + +Theorem normalize_prop_valid b e ep p : + interp_prop e ep (normalize_prop b p) <-> interp_prop e ep p. +Proof. + revert b. + induction p; intros; simp; try tauto. + - destruct b; simp; + rewrite <- ?normalize_stable; simpl; rewrite ?minus_def. + + rewrite not_eq. apply egal_left. + + apply egal_left. + - destruct b; simp; + rewrite <- ?normalize_stable; simpl; rewrite ?minus_def; + apply not_iff_compat, egal_left. + - destruct b; simp; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + + symmetry. rewrite le_lt_iff. apply not_iff_compat, lt_left. + + now rewrite <- le_left. + - destruct b; simp; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + + symmetry. rewrite ge_le_iff, le_lt_iff. + apply not_iff_compat, lt_left. + + rewrite ge_le_iff. now rewrite <- le_left. + - destruct b; simp; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + + rewrite gt_lt_iff, lt_le_iff. apply not_iff_compat. + now rewrite <- le_left. + + symmetry. rewrite gt_lt_iff. apply lt_left. + - destruct b; simp; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + + rewrite lt_le_iff. apply not_iff_compat. + now rewrite <- le_left. + + symmetry. apply lt_left. + - now rewrite IHp. + - now rewrite IHp1, IHp2. + - now rewrite IHp1, IHp2. + - now rewrite IHp1, IHp2. +Qed. + +Theorem normalize_hyps_valid : valid_hyps normalize_hyps. +Proof. + intros e ep l. induction l; simpl; intuition. + now rewrite normalize_prop_valid. +Qed. + +Theorem normalize_hyps_goal (ep : list Prop) (env : list int) (l : hyps) : + interp_goal ep env (normalize_hyps l) -> interp_goal ep env l. Proof. - unfold term_stable, fusion_cancel; intros trace e; elim trace; - [ exact (reduce_stable e) - | intros n H t; elim H; exact (T_OMEGA13_stable e t) ]. + intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. Qed. -(* \subsubsection{Opérations affines sur une équation} *) -(* \paragraph{Multiplication scalaire et somme d'une constante} *) - -Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term := - match trace with - | O => reduce t - | S trace' => apply_right (scalar_norm_add trace') (T_OMEGA11 t) - end. +(** ** A simple decidability checker -Theorem scalar_norm_add_stable : - forall t : nat, term_stable (scalar_norm_add t). -Proof. - unfold term_stable, scalar_norm_add; intros trace; elim trace; - [ exact reduce_stable - | intros n H e t; elim apply_right_stable; - [ exact (T_OMEGA11_stable e t) | exact H ] ]. -Qed. + For us, everything is considered decidable except + propositional atoms [Tprop _]. *) -(* \paragraph{Multiplication scalaire} *) -Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term := - match trace with - | O => reduce t - | S trace' => apply_right (scalar_norm trace') (T_OMEGA16 t) +Fixpoint decidability (p : proposition) : bool := + match p with + | Tnot t => decidability t + | Tand t1 t2 => decidability t1 && decidability t2 + | Timp t1 t2 => decidability t1 && decidability t2 + | Tor t1 t2 => decidability t1 && decidability t2 + | Tprop _ => false + | _ => true end. -Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t). -Proof. - unfold term_stable, scalar_norm; intros trace; elim trace; - [ exact reduce_stable - | intros n H e t; elim apply_right_stable; - [ exact (T_OMEGA16_stable e t) | exact H ] ]. -Qed. - -(* \paragraph{Somme d'une constante} *) -Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term := - match trace with - | O => reduce t - | S trace' => apply_right (add_norm trace') (Tplus_assoc_r t) - end. +Theorem decidable_correct : + forall (ep : list Prop) (e : list int) (p : proposition), + decidability p = true -> decidable (interp_prop ep e p). +Proof. + induction p; simpl; intros Hp; try destruct (andb_prop _ _ Hp). + - apply dec_eq. + - apply dec_ne. + - apply dec_le. + - apply dec_ge. + - apply dec_gt. + - apply dec_lt. + - left; auto. + - right; unfold not; auto. + - apply dec_not; auto. + - apply dec_or; auto. + - apply dec_and; auto. + - apply dec_imp; auto. + - discriminate. +Qed. + +(** ** Omega steps + + The following inductive type describes steps as they can be + found in the trace coming from the decision procedure Omega. + We consider here only normalized equations [0=...], disequations + [0<>...] or inequations [0<=...]. + + First, the final steps leading to a contradiction: + - [O_BAD_CONSTANT i] : hypothesis i has a constant body + and this constant is not compatible with the kind of i. + - [O_NOT_EXACT_DIVIDE i k] : + equation i can be factorized as some [k*t+c] with [0<c<k]. + + Now, the intermediate steps leading to a new hypothesis: + - [O_DIVIDE i k cont] : + the body of hypothesis i could be factorized as [k*t+c] + with either [k<>0] and [c=0] for a (dis)equation, or + [0<k] and [c<k] for an inequation. We change in-place the + body of i for [t]. + - [O_SUM k1 i1 k2 i2 cont] : creates a new hypothesis whose + kind depends on the kind of hypotheses [i1] and [i2], and + whose body is [k1*body(i1) + k2*body(i2)]. Depending of the + situation, [k1] or [k2] might have to be positive or non-nul. + - [O_MERGE_EQ i j cont] : + inequations i and j have opposite bodies, we add an equation + with one these bodies. + - [O_SPLIT_INEQ i cont1 cont2] : + disequation i is split into a disjonction of inequations. +*) -Theorem add_norm_stable : forall t : nat, term_stable (add_norm t). -Proof. - unfold term_stable, add_norm; intros trace; elim trace; - [ exact reduce_stable - | intros n H e t; elim apply_right_stable; - [ exact (Tplus_assoc_r_stable e t) | exact H ] ]. -Qed. +Definition idx := nat. (** Index of an hypothesis in the list *) -(* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *) +Inductive t_omega : Set := + | O_BAD_CONSTANT : idx -> t_omega + | O_NOT_EXACT_DIVIDE : idx -> int -> t_omega + | O_DIVIDE : idx -> int -> t_omega -> t_omega + | O_SUM : int -> idx -> int -> idx -> t_omega -> t_omega + | O_MERGE_EQ : idx -> idx -> t_omega -> t_omega + | O_SPLIT_INEQ : idx -> t_omega -> t_omega -> t_omega. -Fixpoint t_rewrite (s : step) : term -> term := - match s with - | C_DO_BOTH s1 s2 => apply_both (t_rewrite s1) (t_rewrite s2) - | C_LEFT s => apply_left (t_rewrite s) - | C_RIGHT s => apply_right (t_rewrite s) - | C_SEQ s1 s2 => fun t : term => t_rewrite s2 (t_rewrite s1 t) - | C_NOP => fun t : term => t - | C_OPP_PLUS => Topp_plus - | C_OPP_OPP => Topp_opp - | C_OPP_MULT_R => Topp_mult_r - | C_OPP_ONE => Topp_one - | C_REDUCE => reduce - | C_MULT_PLUS_DISTR => Tmult_plus_distr - | C_MULT_OPP_LEFT => Tmult_opp_left - | C_MULT_ASSOC_R => Tmult_assoc_r - | C_PLUS_ASSOC_R => Tplus_assoc_r - | C_PLUS_ASSOC_L => Tplus_assoc_l - | C_PLUS_PERMUTE => Tplus_permute - | C_PLUS_COMM => Tplus_comm - | C_RED0 => Tred_factor0 - | C_RED1 => Tred_factor1 - | C_RED2 => Tred_factor2 - | C_RED3 => Tred_factor3 - | C_RED4 => Tred_factor4 - | C_RED5 => Tred_factor5 - | C_RED6 => Tred_factor6 - | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced - | C_MINUS => Tminus_def - | C_MULT_COMM => Tmult_comm - end. +(** ** Actual resolution steps of an omega normalized goal *) -Theorem t_rewrite_stable : forall s : step, term_stable (t_rewrite s). -Proof. - simple induction s; simpl; - [ intros; apply apply_both_stable; auto - | intros; apply apply_left_stable; auto - | intros; apply apply_right_stable; auto - | unfold term_stable; intros; elim H0; apply H - | unfold term_stable; auto - | exact Topp_plus_stable - | exact Topp_opp_stable - | exact Topp_mult_r_stable - | exact Topp_one_stable - | exact reduce_stable - | exact Tmult_plus_distr_stable - | exact Tmult_opp_left_stable - | exact Tmult_assoc_r_stable - | exact Tplus_assoc_r_stable - | exact Tplus_assoc_l_stable - | exact Tplus_permute_stable - | exact Tplus_comm_stable - | exact Tred_factor0_stable - | exact Tred_factor1_stable - | exact Tred_factor2_stable - | exact Tred_factor3_stable - | exact Tred_factor4_stable - | exact Tred_factor5_stable - | exact Tred_factor6_stable - | exact Tmult_assoc_reduced_stable - | exact Tminus_def_stable - | exact Tmult_comm_stable ]. -Qed. +(** First, the final steps, leading to a contradiction *) -(* \subsection{tactiques de résolution d'un but omega normalisé} - Trace de la procédure -\subsubsection{Tactiques générant une contradiction} -\paragraph{[O_CONSTANT_NOT_NUL]} *) +(** [O_BAD_CONSTANT] *) -Definition constant_not_nul (i : nat) (h : hyps) := +Definition bad_constant (i : nat) (h : hyps) := match nth_hyps i h with - | EqTerm (Tint Nul) (Tint n) => - if beq n Nul then h else absurd + | EqTerm (Tint Nul) (Tint n) => if n =? Nul then h else absurd + | NeqTerm (Tint Nul) (Tint n) => if n =? Nul then absurd else h + | LeqTerm (Tint Nul) (Tint n) => if n <? Nul then absurd else h | _ => h end. -Theorem constant_not_nul_valid : - forall i : nat, valid_hyps (constant_not_nul i). +Theorem bad_constant_valid i : valid_hyps (bad_constant i). Proof. - unfold valid_hyps, constant_not_nul; intros i ep e lp H. + unfold valid_hyps, bad_constant; intros ep e lp H. generalize (nth_valid ep e i lp H); Simplify. + rewrite le_lt_iff. intuition. Qed. -(* \paragraph{[O_CONSTANT_NEG]} *) +(** [O_NOT_EXACT_DIVIDE] *) -Definition constant_neg (i : nat) (h : hyps) := - match nth_hyps i h with - | LeqTerm (Tint Nul) (Tint Neg) => - if bgt Nul Neg then absurd else h - | _ => h - end. - -Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i). -Proof. - unfold valid_hyps, constant_neg; intros; - generalize (nth_valid ep e i lp); Simplify; simpl. - rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. -Qed. - -(* \paragraph{[NOT_EXACT_DIVIDE]} *) -Definition not_exact_divide (k1 k2 : int) (body : term) - (t i : nat) (l : hyps) := +Definition not_exact_divide (i : nat) (k : int) (l : hyps) := match nth_hyps i l with | EqTerm (Tint Nul) b => - if beq Nul 0 && - eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && - bgt k2 0 && - bgt k1 k2 - then absurd + match scalar_div b k with + | Some (body,c) => + if (Nul =? 0) && (0 <? c) && (c <? k) then absurd else l + | None => l + end | _ => l end. -Theorem not_exact_divide_valid : - forall (k1 k2 : int) (body : term) (t0 i : nat), - valid_hyps (not_exact_divide k1 k2 body t0 i). +Theorem not_exact_divide_valid i k : + valid_hyps (not_exact_divide i k). Proof. - unfold valid_hyps, not_exact_divide; intros; - generalize (nth_valid ep e i lp); Simplify. - rewrite (scalar_norm_add_stable t0 e), <-H1. - do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros. - absurd (interp_term e body * k1 + k2 = 0); - [ now apply OMEGA4 | symmetry; auto ]. + unfold valid_hyps, not_exact_divide; intros. + generalize (nth_valid ep e i lp). + destruct (nth_hyps i lp); simpl; auto. + destruct t0; auto. + destruct (scalar_div t1 k) as [(body,c)|] eqn:E; auto. + Simplify. + assert (k <> 0). + { intro. apply (lt_not_eq 0 k); eauto using lt_trans. } + apply (scalar_div_stable e) in E; auto. simpl in E. + intros H'; rewrite <- H' in E; auto. + exfalso. revert E. now apply OMEGA4. Qed. -(* \paragraph{[O_CONTRADICTION]} *) +(** Now, the steps generating a new equation. *) -Definition contradiction (t i j : nat) (l : hyps) := - match nth_hyps i l with - | LeqTerm (Tint Nul) b1 => - match nth_hyps j l with - | LeqTerm (Tint Nul') b2 => - match fusion_cancel t (b1 + b2)%term with - | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k - then absurd - else l - | _ => l - end - | _ => l - end - | _ => l - end. - -Theorem contradiction_valid : - forall t i j : nat, valid_hyps (contradiction t i j). -Proof. - unfold valid_hyps, contradiction; intros t i j ep e l H; - generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); - case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; - simpl; intros z z' H1 H2; - generalize (eq_refl (interp_term e (fusion_cancel t (t2 + t4)%term))); - pattern (fusion_cancel t (t2 + t4)%term) at 2 3; - case (fusion_cancel t (t2 + t4)%term); simpl; - auto; intro k; elim (fusion_cancel_stable t); simpl. - Simplify; intro H3. - generalize (OMEGA2 _ _ H2 H1); rewrite H3. - rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. -Qed. +(** [O_DIVIDE] *) -(* \paragraph{[O_NEGATE_CONTRADICT]} *) - -Definition negate_contradict (i1 i2 : nat) (h : hyps) := - match nth_hyps i1 h with - | EqTerm (Tint Nul) b1 => - match nth_hyps i2 h with - | NeqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 - then absurd - else h - | _ => h - end - | NeqTerm (Tint Nul) b1 => - match nth_hyps i2 h with - | EqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 - then absurd - else h - | _ => h - end - | _ => h - end. - -Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := - match nth_hyps i1 h with - | EqTerm (Tint Nul) b1 => - match nth_hyps i2 h with - | NeqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && - eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) - then absurd - else h - | _ => h - end - | NeqTerm (Tint Nul) b1 => - match nth_hyps i2 h with - | EqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && - eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) - then absurd - else h - | _ => h - end - | _ => h +Definition divide (k : int) (prop : proposition) := + match prop with + | EqTerm (Tint o) b => + match scalar_div b k with + | Some (body,c) => + if (o =? 0) && (c =? 0) && negb (k =? 0) + then EqTerm (Tint 0) body + else TrueTerm + | None => TrueTerm + end + | NeqTerm (Tint o) b => + match scalar_div b k with + | Some (body,c) => + if (o =? 0) && (c =? 0) && negb (k =? 0) + then NeqTerm (Tint 0) body + else TrueTerm + | None => TrueTerm + end + | LeqTerm (Tint o) b => + match scalar_div b k with + | Some (body,c) => + if (o =? 0) && (0 <? k) && (c <? k) + then LeqTerm (Tint 0) body + else prop + | None => prop + end + | _ => TrueTerm end. -Theorem negate_contradict_valid : - forall i j : nat, valid_hyps (negate_contradict i j). -Proof. - unfold valid_hyps, negate_contradict; intros i j ep e l H; - generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); - case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; intros z; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; - auto; simpl; intros H1 H2; Simplify. -Qed. - -Theorem negate_contradict_inv_valid : - forall t i j : nat, valid_hyps (negate_contradict_inv t i j). +Theorem divide_valid k : valid1 (divide k). Proof. - unfold valid_hyps, negate_contradict_inv; intros t i j ep e l H; - generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); - case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; intros z; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; - auto; simpl; intros H1 H2; Simplify; - [ - rewrite <- scalar_norm_stable in H2; simpl in *; - elim (mult_integral (interp_term e t4) (-(1))); intuition; - elim minus_one_neq_zero; auto - | - elim H2; clear H2; - rewrite <- scalar_norm_stable; simpl in *; - now rewrite <- H1, mult_0_l - ]. + unfold valid1, divide; intros ep e p; + destruct p; simpl; auto; + destruct t0; simpl; auto; + destruct scalar_div as [(body,c)|] eqn:E; simpl; Simplify; auto. + - apply (scalar_div_stable e) in E; auto. simpl in E. + intros H'; rewrite <- H' in E. rewrite plus_0_r in E. + apply mult_integral in E. intuition. + - apply (scalar_div_stable e) in E; auto. simpl in E. + intros H' H''. now rewrite <- H'', mult_0_l, plus_0_l in E. + - assert (k <> 0). + { intro. apply (lt_not_eq 0 k); eauto using lt_trans. } + apply (scalar_div_stable e) in E; auto. simpl in E. rewrite <- E. + intro H'. now apply mult_le_approx with (3 := H'). Qed. -(* \subsubsection{Tactiques générant une nouvelle équation} *) -(* \paragraph{[O_SUM]} - C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant - les opérateurs de comparaison des deux arguments) d'où une - preuve un peu compliquée. On utilise quelques lemmes qui sont des - généralisations des théorèmes utilisés par OMEGA. *) +(** [O_SUM]. Invariant: [k1] and [k2] non-nul. *) -Definition sum (k1 k2 : int) (trace : list t_fusion) - (prop1 prop2 : proposition) := +Definition sum (k1 k2 : int) (prop1 prop2 : proposition) := match prop1 with - | EqTerm (Tint Null) b1 => + | EqTerm (Tint o) b1 => match prop2 with - | EqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 - then EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + | EqTerm (Tint o') b2 => + if (o =? 0) && (o' =? 0) + then EqTerm (Tint 0) (fusion b1 b2 k1 k2) + else TrueTerm + | LeqTerm (Tint o') b2 => + if (o =? 0) && (o' =? 0) && (0 <? k2) + then LeqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm - | LeqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 && bgt k2 0 - then LeqTerm (Tint 0) - (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + | NeqTerm (Tint o') b2 => + if (o =? 0) && (o' =? 0) && negb (k2 =? 0) + then NeqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm | _ => TrueTerm end - | LeqTerm (Tint Null) b1 => - if beq Null 0 && bgt k1 0 + | LeqTerm (Tint o) b1 => + if (o =? 0) && (0 <? k1) then match prop2 with - | EqTerm (Tint Null') b2 => - if beq Null' 0 then - LeqTerm (Tint 0) - (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + | EqTerm (Tint o') b2 => + if o' =? 0 then + LeqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm - | LeqTerm (Tint Null') b2 => - if beq Null' 0 && bgt k2 0 - then LeqTerm (Tint 0) - (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + | LeqTerm (Tint o') b2 => + if (o' =? 0) && (0 <? k2) + then LeqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm | _ => TrueTerm end else TrueTerm - | NeqTerm (Tint Null) b1 => + | NeqTerm (Tint o) b1 => match prop2 with - | EqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 && (negb (beq k1 0)) - then NeqTerm (Tint 0) - (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + | EqTerm (Tint o') b2 => + if (o =? 0) && (o' =? 0) && negb (k1 =? 0) + then NeqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm | _ => TrueTerm end | _ => TrueTerm end. - Theorem sum_valid : - forall (k1 k2 : int) (t : list t_fusion), valid2 (sum k1 k2 t). + forall (k1 k2 : int), valid2 (sum k1 k2). Proof. unfold valid2; intros k1 k2 t ep e p1 p2; unfold sum; - Simplify; simpl; auto; try elim (fusion_stable t); - simpl; intros; - [ apply sum1; assumption - | apply sum2; try assumption; apply sum4; assumption - | rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption - | apply sum3; try assumption; apply sum4; assumption - | apply sum5; auto ]. -Qed. - -(* \paragraph{[O_EXACT_DIVIDE]} - c'est une oper1 valide mais on préfère une substitution a ce point la *) - -Definition exact_divide (k : int) (body : term) (t : nat) - (prop : proposition) := - match prop with - | EqTerm (Tint Null) b => - if beq Null 0 && - eq_term (scalar_norm t (body * Tint k)%term) b && - negb (beq k 0) - then EqTerm (Tint 0) body - else TrueTerm - | NeqTerm (Tint Null) b => - if beq Null 0 && - eq_term (scalar_norm t (body * Tint k)%term) b && - negb (beq k 0) - then NeqTerm (Tint 0) body - else TrueTerm - | _ => TrueTerm - end. - -Theorem exact_divide_valid : - forall (k : int) (t : term) (n : nat), valid1 (exact_divide k t n). -Proof. - unfold valid1, exact_divide; intros k1 k2 t ep e p1; - Simplify; simpl; auto; subst; - rewrite <- scalar_norm_stable; simpl; intros; - [ destruct (mult_integral _ _ (eq_sym H0)); intuition - | contradict H0; rewrite <- H0, mult_0_l; auto - ]. + Simplify; simpl; rewrite ?fusion_stable; + simpl; intros; auto. + - apply sum1; auto. + - rewrite plus_comm. apply sum5; auto. + - apply sum2; auto using lt_le_weak. + - apply sum5; auto. + - rewrite plus_comm. apply sum2; auto using lt_le_weak. + - apply sum3; auto using lt_le_weak. Qed. +(** [MERGE_EQ] *) -(* \paragraph{[O_DIV_APPROX]} - La preuve reprend le schéma de la précédente mais on - est sur une opération de type valid1 et non sur une opération terminale. *) - -Definition divide_and_approx (k1 k2 : int) (body : term) - (t : nat) (prop : proposition) := - match prop with - | LeqTerm (Tint Null) b => - if beq Null 0 && - eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && - bgt k1 0 && - bgt k1 k2 - then LeqTerm (Tint 0) body - else prop - | _ => prop - end. - -Theorem divide_and_approx_valid : - forall (k1 k2 : int) (body : term) (t : nat), - valid1 (divide_and_approx k1 k2 body t). -Proof. - unfold valid1, divide_and_approx; intros k1 k2 body t ep e p1; - Simplify; simpl; auto; subst; - elim (scalar_norm_add_stable t e); simpl. - intro H2; apply mult_le_approx with (3 := H2); assumption. -Qed. - -(* \paragraph{[MERGE_EQ]} *) - -Definition merge_eq (t : nat) (prop1 prop2 : proposition) := +Definition merge_eq (prop1 prop2 : proposition) := match prop1 with - | LeqTerm (Tint Null) b1 => + | LeqTerm (Tint o) b1 => match prop2 with - | LeqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 && - eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) + | LeqTerm (Tint o') b2 => + if (o =? 0) && (o' =? 0) && + (b1 =? scalar_mult b2 (-(1)))%term then EqTerm (Tint 0) b1 else TrueTerm | _ => TrueTerm @@ -2370,680 +1603,153 @@ Definition merge_eq (t : nat) (prop1 prop2 : proposition) := | _ => TrueTerm end. -Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n). -Proof. - unfold valid2, merge_eq; intros n ep e p1 p2; Simplify; simpl; - auto; elim (scalar_norm_stable n e); simpl; - intros; symmetry ; apply OMEGA8 with (2 := H0); - [ assumption | elim opp_eq_mult_neg_1; trivial ]. -Qed. - - - -(* \paragraph{[O_CONSTANT_NUL]} *) - -Definition constant_nul (i : nat) (h : hyps) := - match nth_hyps i h with - | NeqTerm (Tint Null) (Tint Null') => - if beq Null Null' then absurd else h - | _ => h - end. - -Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i). -Proof. - unfold valid_hyps, constant_nul; intros; - generalize (nth_valid ep e i lp); Simplify; simpl; - intro H1; absurd (0 = 0); intuition. -Qed. - -(* \paragraph{[O_STATE]} *) - -Definition state (m : int) (s : step) (prop1 prop2 : proposition) := - match prop1 with - | EqTerm (Tint Null) b1 => - match prop2 with - | EqTerm b2 b3 => - if beq Null 0 - then EqTerm (Tint 0) (t_rewrite s (b1 + (- b3 + b2) * Tint m)%term) - else TrueTerm - | _ => TrueTerm - end - | _ => TrueTerm - end. - -Theorem state_valid : forall (m : int) (s : step), valid2 (state m s). +Theorem merge_eq_valid : valid2 merge_eq. Proof. - unfold valid2; intros m s ep e p1 p2; unfold state; Simplify; - simpl; auto; elim (t_rewrite_stable s e); simpl; - intros H1 H2; elim H1. - now rewrite H2, plus_opp_l, plus_0_l, mult_0_l. + unfold valid2, merge_eq; intros ep e p1 p2; Simplify; simpl; auto. + rewrite scalar_mult_stable. simpl. + intros; symmetry ; apply OMEGA8 with (2 := H0). + - assumption. + - elim opp_eq_mult_neg_1; trivial. Qed. -(* \subsubsection{Tactiques générant plusieurs but} - \paragraph{[O_SPLIT_INEQ]} - La seule pour le moment (tant que la normalisation n'est pas réfléchie). *) +(** [O_SPLIT_INEQ] (only step to produce two subgoals). *) -Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) - (l : hyps) := +Definition split_ineq (i : nat) (f1 f2 : hyps -> lhyps) (l : hyps) := match nth_hyps i l with - | NeqTerm (Tint Null) b1 => - if beq Null 0 then - f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-(1)))%term) :: l) ++ - f2 - (LeqTerm (Tint 0) - (scalar_norm_add t (b1 * Tint (-(1)) + Tint (-(1)))%term) :: l) - else l :: nil + | NeqTerm (Tint o) b1 => + if o =? 0 then + f1 (LeqTerm (Tint 0) (scalar_add b1 (-(1))) :: l) ++ + f2 (LeqTerm (Tint 0) (scalar_mult_add b1 (-(1)) (-(1))) :: l) + else l :: nil | _ => l :: nil end. Theorem split_ineq_valid : - forall (i t : nat) (f1 f2 : hyps -> lhyps), + forall (i : nat) (f1 f2 : hyps -> lhyps), valid_list_hyps f1 -> - valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2). + valid_list_hyps f2 -> valid_list_hyps (split_ineq i f1 f2). Proof. - unfold valid_list_hyps, split_ineq; intros i t f1 f2 H1 H2 ep e lp H; + unfold valid_list_hyps, split_ineq; intros i f1 f2 H1 H2 ep e lp H; generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); simpl; auto; intros t1 t2; case t1; simpl; auto; intros z; simpl; auto; intro H3. Simplify. - apply append_valid; elim (OMEGA19 (interp_term e t2)); - [ intro H4; left; apply H1; simpl; elim (add_norm_stable t); - simpl; auto - | intro H4; right; apply H2; simpl; elim (scalar_norm_add_stable t); - simpl; auto - | generalize H3; unfold not; intros E1 E2; apply E1; - symmetry ; trivial ]. + apply append_valid; elim (OMEGA19 (interp_term e t2)). + - intro H4; left; apply H1; simpl; rewrite scalar_add_stable; + simpl; auto. + - intro H4; right; apply H2; simpl; rewrite scalar_mult_add_stable; + simpl; auto. + - generalize H3; unfold not; intros E1 E2; apply E1; + symmetry ; trivial. Qed. +(** ** Replaying the resolution trace *) -(* \subsection{La fonction de rejeu de la trace} *) - -Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := +Fixpoint execute_omega (t : t_omega) (l : hyps) : lhyps := match t with - | O_CONSTANT_NOT_NUL n => singleton (constant_not_nul n l) - | O_CONSTANT_NEG n => singleton (constant_neg n l) - | O_DIV_APPROX k1 k2 body t cont n => - execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body t) l) - | O_NOT_EXACT_DIVIDE k1 k2 body t i => - singleton (not_exact_divide k1 k2 body t i l) - | O_EXACT_DIVIDE k body t cont n => - execute_omega cont (apply_oper_1 n (exact_divide k body t) l) - | O_SUM k1 i1 k2 i2 t cont => - execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2 t) l) - | O_CONTRADICTION t i j => singleton (contradiction t i j l) - | O_MERGE_EQ t i1 i2 cont => - execute_omega cont (apply_oper_2 i1 i2 (merge_eq t) l) - | O_SPLIT_INEQ t i cont1 cont2 => - split_ineq i t (execute_omega cont1) (execute_omega cont2) l - | O_CONSTANT_NUL i => singleton (constant_nul i l) - | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l) - | O_NEGATE_CONTRADICT_INV t i j => - singleton (negate_contradict_inv t i j l) - | O_STATE m s i1 i2 cont => - execute_omega cont (apply_oper_2 i1 i2 (state m s) l) + | O_BAD_CONSTANT i => singleton (bad_constant i l) + | O_NOT_EXACT_DIVIDE i k => singleton (not_exact_divide i k l) + | O_DIVIDE i k cont => + execute_omega cont (apply_oper_1 i (divide k) l) + | O_SUM k1 i1 k2 i2 cont => + execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2) l) + | O_MERGE_EQ i1 i2 cont => + execute_omega cont (apply_oper_2 i1 i2 merge_eq l) + | O_SPLIT_INEQ i cont1 cont2 => + split_ineq i (execute_omega cont1) (execute_omega cont2) l end. Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). Proof. - simple induction tr; simpl; - [ unfold valid_list_hyps; simpl; intros; left; - apply (constant_not_nul_valid n ep e lp H) - | unfold valid_list_hyps; simpl; intros; left; - apply (constant_neg_valid n ep e lp H) - | unfold valid_list_hyps, valid_hyps; - intros k1 k2 body n t' Ht' m ep e lp H; apply Ht'; - apply - (apply_oper_1_valid m (divide_and_approx k1 k2 body n) - (divide_and_approx_valid k1 k2 body n) ep e lp H) - | unfold valid_list_hyps; simpl; intros; left; - apply (not_exact_divide_valid _ _ _ _ _ ep e lp H) - | unfold valid_list_hyps, valid_hyps; - intros k body n t' Ht' m ep e lp H; apply Ht'; + simple induction tr; unfold valid_list_hyps, valid_hyps; simpl. + - intros; left; now apply bad_constant_valid. + - intros; left; now apply not_exact_divide_valid. + - intros m k t' Ht' ep e lp H; apply Ht'; apply - (apply_oper_1_valid m (exact_divide k body n) - (exact_divide_valid k body n) ep e lp H) - | unfold valid_list_hyps, valid_hyps; - intros k1 i1 k2 i2 trace t' Ht' ep e lp H; apply Ht'; + (apply_oper_1_valid m (divide k) + (divide_valid k) ep e lp H). + - intros k1 i1 k2 i2 t' Ht' ep e lp H; apply Ht'; apply - (apply_oper_2_valid i1 i2 (sum k1 k2 trace) (sum_valid k1 k2 trace) ep e - lp H) - | unfold valid_list_hyps; simpl; intros; left; - apply (contradiction_valid n n0 n1 ep e lp H) - | unfold valid_list_hyps, valid_hyps; - intros trace i1 i2 t' Ht' ep e lp H; apply Ht'; + (apply_oper_2_valid i1 i2 (sum k1 k2) (sum_valid k1 k2) ep e + lp H). + - intros i1 i2 t' Ht' ep e lp H; apply Ht'; apply - (apply_oper_2_valid i1 i2 (merge_eq trace) (merge_eq_valid trace) ep e - lp H) - | intros t' i k1 H1 k2 H2; unfold valid_list_hyps; simpl; - intros ep e lp H; + (apply_oper_2_valid i1 i2 merge_eq merge_eq_valid ep e + lp H). + - intros i k1 H1 k2 H2 ep e lp H; apply - (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) H1 H2 ep e - lp H) - | unfold valid_list_hyps; simpl; intros i ep e lp H; left; - apply (constant_nul_valid i ep e lp H) - | unfold valid_list_hyps; simpl; intros i j ep e lp H; left; - apply (negate_contradict_valid i j ep e lp H) - | unfold valid_list_hyps; simpl; intros n i j ep e lp H; - left; apply (negate_contradict_inv_valid n i j ep e lp H) - | unfold valid_list_hyps, valid_hyps; - intros m s i1 i2 t' Ht' ep e lp H; apply Ht'; - apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H) ]. -Qed. - - -(* \subsection{Les opérations globales sur le but} - \subsubsection{Normalisation} *) - -Definition move_right (s : step) (p : proposition) := - match p with - | EqTerm t1 t2 => EqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) - | LeqTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t2 + - t1)%term) - | GeqTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) - | LtTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t2 + Tint (-(1)) + - t1)%term) - | GtTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t1 + Tint (-(1)) + - t2)%term) - | NeqTerm t1 t2 => NeqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) - | p => p - end. - -Theorem move_right_valid : forall s : step, valid1 (move_right s). -Proof. - unfold valid1, move_right; intros s ep e p; Simplify; simpl; - elim (t_rewrite_stable s e); simpl; - [ symmetry ; apply egal_left; assumption - | intro; apply le_left; assumption - | intro; apply le_left; rewrite <- ge_le_iff; assumption - | intro; apply lt_left; rewrite <- gt_lt_iff; assumption - | intro; apply lt_left; assumption - | intro; apply ne_left_2; assumption ]. -Qed. - -Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s). - -Theorem do_normalize_valid : - forall (i : nat) (s : step), valid_hyps (do_normalize i s). -Proof. - intros; unfold do_normalize; apply apply_oper_1_valid; - apply move_right_valid. -Qed. - -Fixpoint do_normalize_list (l : list step) (i : nat) - (h : hyps) {struct l} : hyps := - match l with - | s :: l' => do_normalize_list l' (S i) (do_normalize i s h) - | nil => h - end. - -Theorem do_normalize_list_valid : - forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i). -Proof. - simple induction l; simpl; unfold valid_hyps; - [ auto - | intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl'; - apply (do_normalize_valid i a ep e lp); assumption ]. -Qed. - -Theorem normalize_goal : - forall (s : list step) (ep : list Prop) (env : list int) (l : hyps), - interp_goal ep env (do_normalize_list s 0 l) -> interp_goal ep env l. -Proof. - intros; apply valid_goal with (2 := H); apply do_normalize_list_valid. + (split_ineq_valid i (execute_omega k1) (execute_omega k2) H1 H2 ep e + lp H). Qed. -(* \subsubsection{Exécution de la trace} *) -Theorem execute_goal : - forall (tr : t_omega) (ep : list Prop) (env : list int) (l : hyps), - interp_list_goal ep env (execute_omega tr l) -> interp_goal ep env l. -Proof. - intros; apply (goal_valid (execute_omega tr) (omega_valid tr) ep env l H). -Qed. +(** ** Rules for decomposing the hypothesis + This type allows navigation in the logical constructors that + form the predicats of the hypothesis in order to decompose them. + This allows in particular to extract one hypothesis from a conjunction. + NB: negations are now silently traversed. *) -Theorem append_goal : - forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), - interp_list_goal ep e l1 /\ interp_list_goal ep e l2 -> - interp_list_goal ep e (l1 ++ l2). -Proof. - intros ep e; simple induction l1; - [ simpl; intros l2 (H1, H2); assumption - | simpl; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ]. -Qed. - -(* A simple decidability checker : if the proposition belongs to the - simple grammar describe below then it is decidable. Proof is by - induction and uses well known theorem about arithmetic and propositional - calculus *) - -Fixpoint decidability (p : proposition) : bool := - match p with - | EqTerm _ _ => true - | LeqTerm _ _ => true - | GeqTerm _ _ => true - | GtTerm _ _ => true - | LtTerm _ _ => true - | NeqTerm _ _ => true - | FalseTerm => true - | TrueTerm => true - | Tnot t => decidability t - | Tand t1 t2 => decidability t1 && decidability t2 - | Timp t1 t2 => decidability t1 && decidability t2 - | Tor t1 t2 => decidability t1 && decidability t2 - | Tprop _ => false - end. - -Theorem decidable_correct : - forall (ep : list Prop) (e : list int) (p : proposition), - decidability p = true -> decidable (interp_proposition ep e p). -Proof. - simple induction p; simpl; intros; - [ apply dec_eq - | apply dec_le - | left; auto - | right; unfold not; auto - | apply dec_not; auto - | apply dec_ge - | apply dec_gt - | apply dec_lt - | apply dec_ne - | apply dec_or; elim andb_prop with (1 := H1); auto - | apply dec_and; elim andb_prop with (1 := H1); auto - | apply dec_imp; elim andb_prop with (1 := H1); auto - | discriminate H ]. -Qed. - -(* An interpretation function for a complete goal with an explicit - conclusion. We use an intermediate fixpoint. *) - -Fixpoint interp_full_goal (envp : list Prop) (env : list int) - (c : proposition) (l : hyps) {struct l} : Prop := - match l with - | nil => interp_proposition envp env c - | p' :: l' => - interp_proposition envp env p' -> interp_full_goal envp env c l' - end. - -Definition interp_full (ep : list Prop) (e : list int) - (lc : hyps * proposition) : Prop := - match lc with - | (l, c) => interp_full_goal ep e c l - end. - -(* Relates the interpretation of a complete goal with the interpretation - of its hypothesis and conclusion *) - -Theorem interp_full_false : - forall (ep : list Prop) (e : list int) (l : hyps) (c : proposition), - (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c). -Proof. - simple induction l; unfold interp_full; simpl; - [ auto | intros a l1 H1 c H2 H3; apply H1; auto ]. -Qed. - -(* Push the conclusion in the list of hypothesis using a double negation - If the decidability cannot be "proven", then just forget about the - conclusion (equivalent of replacing it with false) *) - -Definition to_contradict (lc : hyps * proposition) := - match lc with - | (l, c) => if decidability c then Tnot c :: l else l - end. - -(* The previous operation is valid in the sense that the new list of - hypothesis implies the original goal *) - -Theorem to_contradict_valid : - forall (ep : list Prop) (e : list int) (lc : hyps * proposition), - interp_goal ep e (to_contradict lc) -> interp_full ep e lc. -Proof. - intros ep e lc; case lc; intros l c; simpl; - pattern (decidability c); apply bool_eq_ind; - [ simpl; intros H H1; apply interp_full_false; intros H2; - apply not_not; - [ apply decidable_correct; assumption - | unfold not at 1; intro H3; apply hyps_to_goal with (2 := H2); - auto ] - | intros H1 H2; apply interp_full_false; intro H3; - elim hyps_to_goal with (1 := H2); assumption ]. -Qed. - -(* [map_cons x l] adds [x] at the head of each list in [l] (which is a list - of lists *) - -Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} : - list (list A) := - match l with - | nil => nil - | l :: ll => (x :: l) :: map_cons A x ll - end. - -(* This function breaks up a list of hypothesis in a list of simpler - list of hypothesis that together implie the original one. The goal - of all this is to transform the goal in a list of solvable problems. - Note that : - - we need a way to drive the analysis as some hypotheis may not - require a split. - - this procedure must be perfectly mimicked by the ML part otherwise - hypothesis will get desynchronised and this will be a mess. - *) - -Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps := - match nn with - | O => ll :: nil - | S n => - match ll with - | nil => nil :: nil - | Tor p1 p2 :: l => - destructure_hyps n (p1 :: l) ++ destructure_hyps n (p2 :: l) - | Tand p1 p2 :: l => destructure_hyps n (p1 :: p2 :: l) - | Timp p1 p2 :: l => - if decidability p1 - then - destructure_hyps n (Tnot p1 :: l) ++ destructure_hyps n (p2 :: l) - else map_cons _ (Timp p1 p2) (destructure_hyps n l) - | Tnot p :: l => - match p with - | Tnot p1 => - if decidability p1 - then destructure_hyps n (p1 :: l) - else map_cons _ (Tnot (Tnot p1)) (destructure_hyps n l) - | Tor p1 p2 => destructure_hyps n (Tnot p1 :: Tnot p2 :: l) - | Tand p1 p2 => - if decidability p1 - then - destructure_hyps n (Tnot p1 :: l) ++ - destructure_hyps n (Tnot p2 :: l) - else map_cons _ (Tnot p) (destructure_hyps n l) - | _ => map_cons _ (Tnot p) (destructure_hyps n l) - end - | x :: l => map_cons _ x (destructure_hyps n l) - end - end. - -Theorem map_cons_val : - forall (ep : list Prop) (e : list int) (p : proposition) (l : lhyps), - interp_proposition ep e p -> - interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l). -Proof. - simple induction l; simpl; [ auto | intros; elim H1; intro H2; auto ]. -Qed. - -Hint Resolve map_cons_val append_valid decidable_correct. - -Theorem destructure_hyps_valid : - forall n : nat, valid_list_hyps (destructure_hyps n). -Proof. - simple induction n; - [ unfold valid_list_hyps; simpl; auto - | unfold valid_list_hyps at 2; intros n1 H ep e lp; case lp; - [ simpl; auto - | intros p l; case p; - try - (simpl; intros; apply map_cons_val; simpl; elim H0; - auto); - [ intro p'; case p'; - try - (simpl; intros; apply map_cons_val; simpl; elim H0; - auto); - [ simpl; intros p1 (H1, H2); - pattern (decidability p1); apply bool_eq_ind; - intro H3; - [ apply H; simpl; split; - [ apply not_not; auto | assumption ] - | auto ] - | simpl; intros p1 p2 (H1, H2); apply H; simpl; - elim not_or with (1 := H1); auto - | simpl; intros p1 p2 (H1, H2); - pattern (decidability p1); apply bool_eq_ind; - intro H3; - [ apply append_valid; elim not_and with (2 := H1); - [ intro; left; apply H; simpl; auto - | intro; right; apply H; simpl; auto - | auto ] - | auto ] ] - | simpl; intros p1 p2 (H1, H2); apply append_valid; - (elim H1; intro H3; simpl; [ left | right ]); - apply H; simpl; auto - | simpl; intros; apply H; simpl; tauto - | simpl; intros p1 p2 (H1, H2); - pattern (decidability p1); apply bool_eq_ind; - intro H3; - [ apply append_valid; elim imp_simp with (2 := H1); - [ intro H4; left; simpl; apply H; simpl; auto - | intro H4; right; simpl; apply H; simpl; auto - | auto ] - | auto ] ] ] ]. -Qed. - -Definition prop_stable (f : proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p : proposition), - interp_proposition ep e p <-> interp_proposition ep e (f p). - -Definition p_apply_left (f : proposition -> proposition) - (p : proposition) := - match p with - | Timp x y => Timp (f x) y - | Tor x y => Tor (f x) y - | Tand x y => Tand (f x) y - | Tnot x => Tnot (f x) - | x => x - end. - -Theorem p_apply_left_stable : - forall f : proposition -> proposition, - prop_stable f -> prop_stable (p_apply_left f). -Proof. - unfold prop_stable; intros f H ep e p; split; - (case p; simpl; auto; intros p1; elim (H ep e p1); tauto). -Qed. - -Definition p_apply_right (f : proposition -> proposition) - (p : proposition) := - match p with - | Timp x y => Timp x (f y) - | Tor x y => Tor x (f y) - | Tand x y => Tand x (f y) - | Tnot x => Tnot (f x) - | x => x - end. - -Theorem p_apply_right_stable : - forall f : proposition -> proposition, - prop_stable f -> prop_stable (p_apply_right f). -Proof. - unfold prop_stable; intros f H ep e p; split; - (case p; simpl; auto; - [ intros p1; elim (H ep e p1); tauto - | intros p1 p2; elim (H ep e p2); tauto - | intros p1 p2; elim (H ep e p2); tauto - | intros p1 p2; elim (H ep e p2); tauto ]). -Qed. - -Definition p_invert (f : proposition -> proposition) - (p : proposition) := - match p with - | EqTerm x y => Tnot (f (NeqTerm x y)) - | LeqTerm x y => Tnot (f (GtTerm x y)) - | GeqTerm x y => Tnot (f (LtTerm x y)) - | GtTerm x y => Tnot (f (LeqTerm x y)) - | LtTerm x y => Tnot (f (GeqTerm x y)) - | NeqTerm x y => Tnot (f (EqTerm x y)) - | x => x - end. - -Theorem p_invert_stable : - forall f : proposition -> proposition, - prop_stable f -> prop_stable (p_invert f). -Proof. - unfold prop_stable; intros f H ep e p; split; - (case p; simpl; auto; - [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl; - generalize (dec_eq (interp_term e t1) (interp_term e t2)); - unfold decidable; tauto - | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl; - generalize (dec_gt (interp_term e t1) (interp_term e t2)); - unfold decidable; rewrite le_lt_iff, <- gt_lt_iff; tauto - | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl; - generalize (dec_lt (interp_term e t1) (interp_term e t2)); - unfold decidable; rewrite ge_le_iff, le_lt_iff; tauto - | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl; - generalize (dec_gt (interp_term e t1) (interp_term e t2)); - unfold decidable; repeat rewrite le_lt_iff; - repeat rewrite gt_lt_iff; tauto - | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl; - generalize (dec_lt (interp_term e t1) (interp_term e t2)); - unfold decidable; repeat rewrite ge_le_iff; - repeat rewrite le_lt_iff; tauto - | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl; - generalize (dec_eq (interp_term e t1) (interp_term e t2)); - unfold decidable; tauto ]). -Qed. - -Theorem move_right_stable : forall s : step, prop_stable (move_right s). -Proof. - unfold move_right, prop_stable; intros s ep e p; split; - [ Simplify; simpl; elim (t_rewrite_stable s e); simpl; - [ symmetry ; apply egal_left; assumption - | intro; apply le_left; assumption - | intro; apply le_left; rewrite <- ge_le_iff; assumption - | intro; apply lt_left; rewrite <- gt_lt_iff; assumption - | intro; apply lt_left; assumption - | intro; apply ne_left_2; assumption ] - | case p; simpl; intros; auto; generalize H; elim (t_rewrite_stable s); - simpl; intro H1; - [ rewrite (plus_0_r_reverse (interp_term e t1)); rewrite H1; - rewrite plus_permute; rewrite plus_opp_r; - rewrite plus_0_r; trivial - | apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); - rewrite plus_opp_r; assumption - | rewrite ge_le_iff; - apply (fun a b => plus_le_reg_r a b (- interp_term e t1)); - rewrite plus_opp_r; assumption - | rewrite gt_lt_iff; apply lt_left_inv; assumption - | apply lt_left_inv; assumption - | unfold not; intro H2; apply H1; - rewrite H2; rewrite plus_opp_r; trivial ] ]. -Qed. - - -Fixpoint p_rewrite (s : p_step) : proposition -> proposition := - match s with - | P_LEFT s => p_apply_left (p_rewrite s) - | P_RIGHT s => p_apply_right (p_rewrite s) - | P_STEP s => move_right s - | P_INVERT s => p_invert (move_right s) - | P_NOP => fun p : proposition => p - end. - -Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s). -Proof. - simple induction s; simpl; - [ intros; apply p_apply_left_stable; trivial - | intros; apply p_apply_right_stable; trivial - | intros; apply p_invert_stable; apply move_right_stable - | apply move_right_stable - | unfold prop_stable; simpl; intros; split; auto ]. -Qed. +Inductive direction : Set := + | D_left : direction + | D_right : direction. -Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps := - match l with - | nil => lh - | pair_step i s :: r => normalize_hyps r (apply_oper_1 i (p_rewrite s) lh) - end. +(** This type allows extracting useful components from hypothesis, either + hypothesis generated by splitting a disjonction, or equations. + The last constructor indicates how to solve the obtained system + via the use of the trace type of Omega [t_omega] *) -Theorem normalize_hyps_valid : - forall l : list h_step, valid_hyps (normalize_hyps l). -Proof. - simple induction l; unfold valid_hyps; simpl; - [ auto - | intros n_s r; case n_s; intros n s H ep e lp H1; apply H; - apply apply_oper_1_valid; - [ unfold valid1; intros ep1 e1 p1 H2; - elim (p_rewrite_stable s ep1 e1 p1); auto - | assumption ] ]. -Qed. +Inductive e_step : Set := + | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step + | E_EXTRACT : nat -> list direction -> e_step -> e_step + | E_SOLVE : t_omega -> e_step. -Theorem normalize_hyps_goal : - forall (s : list h_step) (ep : list Prop) (env : list int) (l : hyps), - interp_goal ep env (normalize_hyps s l) -> interp_goal ep env l. -Proof. - intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. -Qed. +(** Selection of a basic fact inside an hypothesis. *) -Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} : +Fixpoint extract_hyp_pos (s : list direction) (p : proposition) : proposition := - match s with - | D_left :: l => - match p with - | Tand x y => extract_hyp_pos l x - | _ => p - end - | D_right :: l => - match p with - | Tand x y => extract_hyp_pos l y - | _ => p - end - | D_mono :: l => match p with - | Tnot x => extract_hyp_neg l x - | _ => p - end - | _ => p + match p, s with + | Tand x y, D_left :: l => extract_hyp_pos l x + | Tand x y, D_right :: l => extract_hyp_pos l y + | Tnot x, _ => extract_hyp_neg s x + | _, _ => p end - with extract_hyp_neg (s : list direction) (p : proposition) {struct s} : + with extract_hyp_neg (s : list direction) (p : proposition) : proposition := - match s with - | D_left :: l => - match p with - | Tor x y => extract_hyp_neg l x - | Timp x y => if decidability x then extract_hyp_pos l x else Tnot p - | _ => Tnot p - end - | D_right :: l => - match p with - | Tor x y => extract_hyp_neg l y - | Timp x y => extract_hyp_neg l y - | _ => Tnot p - end - | D_mono :: l => - match p with - | Tnot x => if decidability x then extract_hyp_pos l x else Tnot p - | _ => Tnot p - end - | _ => - match p with - | Tnot x => if decidability x then x else Tnot p - | _ => Tnot p - end + match p, s with + | Tor x y, D_left :: l => extract_hyp_neg l x + | Tor x y, D_right :: l => extract_hyp_neg l y + | Timp x y, D_left :: l => + if decidability x then extract_hyp_pos l x else Tnot p + | Timp x y, D_right :: l => extract_hyp_neg l y + | Tnot x, _ => if decidability x then extract_hyp_pos s x else Tnot p + | _, _ => Tnot p end. -Definition co_valid1 (f : proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p1 : proposition), - interp_proposition ep e (Tnot p1) -> interp_proposition ep e (f p1). - Theorem extract_valid : - forall s : list direction, - valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s). + forall s : list direction, valid1 (extract_hyp_pos s). Proof. - unfold valid1, co_valid1; simple induction s; - [ split; - [ simpl; auto - | intros ep e p1; case p1; simpl; auto; intro p; - pattern (decidability p); apply bool_eq_ind; - [ intro H; generalize (decidable_correct ep e p H); - unfold decidable; tauto - | simpl; auto ] ] - | intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto; - case p; auto; simpl; intros; - (apply H1; tauto) || - (apply H2; tauto) || - (pattern (decidability p0); apply bool_eq_ind; - [ intro H3; generalize (decidable_correct ep e p0 H3); - unfold decidable; intro H4; apply H1; - tauto - | intro; tauto ]) ]. + assert (forall p s ep e, + (interp_prop ep e p -> + interp_prop ep e (extract_hyp_pos s p)) /\ + (interp_prop ep e (Tnot p) -> + interp_prop ep e (extract_hyp_neg s p))). + { induction p; destruct s; simpl; auto; split; try destruct d; try easy; + intros; (apply IHp || apply IHp1 || apply IHp2 || idtac); simpl; try tauto; + destruct decidability eqn:D; auto; + apply (decidable_correct ep e) in D; unfold decidable in D; + (apply IHp || apply IHp1); tauto. } + red. intros. now apply H. Qed. -Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := +(** Attempt to shorten error messages if romega goes rogue... + NB: [interp_list_goal _ _ BUG = False /\ True]. *) +Definition BUG : lhyps := nil :: nil. + +(** Split and extract in hypotheses *) + +Fixpoint decompose_solve (s : e_step) (h : hyps) : lhyps := match s with | E_SPLIT i dl s1 s2 => match extract_hyp_pos dl (nth_hyps i h) with @@ -3053,50 +1759,45 @@ Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := then decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (Tnot y :: h) - else h :: nil + else BUG | Timp x y => if decidability x then decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h) - else h::nil - | _ => h :: nil + else BUG + | _ => BUG end | E_EXTRACT i dl s1 => decompose_solve s1 (extract_hyp_pos dl (nth_hyps i h) :: h) | E_SOLVE t => execute_omega t h end. -Theorem decompose_solve_valid : - forall s : e_step, valid_list_goal (decompose_solve s). -Proof. - intro s; apply goal_valid; unfold valid_list_hyps; elim s; - simpl; intros; - [ cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp))); - [ case (extract_hyp_pos l (nth_hyps n lp)); simpl; auto; - [ intro p; case p; simpl; auto; intros p1 p2 H2; - pattern (decidability p1); apply bool_eq_ind; - [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; - apply append_valid; elim H4; intro H5; - [ right; apply H0; simpl; tauto - | left; apply H; simpl; tauto ] - | simpl; auto ] - | intros p1 p2 H2; apply append_valid; simpl; elim H2; - [ intros H3; left; apply H; simpl; auto - | intros H3; right; apply H0; simpl; auto ] - | intros p1 p2 H2; - pattern (decidability p1); apply bool_eq_ind; - [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; - apply append_valid; elim H4; intro H5; - [ right; apply H0; simpl; tauto - | left; apply H; simpl; tauto ] - | simpl; auto ] ] - | elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto ] - | intros; apply H; simpl; split; - [ elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto - | auto ] - | apply omega_valid with (1 := H) ]. -Qed. - -(* \subsection{La dernière étape qui élimine tous les séquents inutiles} *) +Theorem decompose_solve_valid (s : e_step) : + valid_list_goal (decompose_solve s). +Proof. + apply goal_valid. red. induction s; simpl; intros ep e lp H. + - assert (H' : interp_prop ep e (extract_hyp_pos l (nth_hyps n lp))). + { now apply extract_valid, nth_valid. } + destruct extract_hyp_pos; simpl in *; auto. + + destruct p; simpl; auto. + destruct decidability eqn:D; [ | simpl; auto]. + apply (decidable_correct ep e) in D. + apply append_valid. simpl in *. destruct D. + * right. apply IHs2. simpl; auto. + * left. apply IHs1. simpl; auto. + + apply append_valid. destruct H'. + * left. apply IHs1. simpl; auto. + * right. apply IHs2. simpl; auto. + + destruct decidability eqn:D; [ | simpl; auto]. + apply (decidable_correct ep e) in D. + apply append_valid. destruct D. + * right. apply IHs2. simpl; auto. + * left. apply IHs1. simpl; auto. + - apply IHs; simpl; split; auto. + now apply extract_valid, nth_valid. + - now apply omega_valid. +Qed. + +(** Reduction of subgoal list by discarding the contradictory subgoals. *) Definition valid_lhyps (f : lhyps -> lhyps) := forall (ep : list Prop) (e : list int) (lp : lhyps), @@ -3104,18 +1805,18 @@ Definition valid_lhyps (f : lhyps -> lhyps) := Fixpoint reduce_lhyps (lp : lhyps) : lhyps := match lp with + | nil => nil | (FalseTerm :: nil) :: lp' => reduce_lhyps lp' - | x :: lp' => x :: reduce_lhyps lp' - | nil => nil (A:=hyps) + | x :: lp' => BUG end. Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps. Proof. - unfold valid_lhyps; intros ep e lp; elim lp; - [ simpl; auto - | intros a l HR; elim a; - [ simpl; tauto - | intros a1 l1; case l1; case a1; simpl; try tauto ] ]. + unfold valid_lhyps; intros ep e lp; elim lp. + - simpl; auto. + - intros a l HR; elim a. + + simpl; tauto. + + intros a1 l1; case l1; case a1; simpl; tauto. Qed. Theorem do_reduce_lhyps : @@ -3127,6 +1828,8 @@ Proof. assumption. Qed. +(** Pushing the conclusion into the hypotheses. *) + Definition concl_to_hyp (p : proposition) := if decidability p then Tnot p else TrueTerm. @@ -3135,33 +1838,35 @@ Definition do_concl_to_hyp : interp_goal envp env (concl_to_hyp c :: l) -> interp_goal_concl c envp env l. Proof. - simpl; intros envp env c l; induction l as [| a l Hrecl]; - [ simpl; unfold concl_to_hyp; - pattern (decidability c); apply bool_eq_ind; - [ intro H; generalize (decidable_correct envp env c H); - unfold decidable; simpl; tauto - | simpl; intros H1 H2; elim H2; trivial ] - | simpl; tauto ]. + induction l; simpl. + - unfold concl_to_hyp; simpl. + destruct decidability eqn:D; [ | simpl; tauto ]. + apply (decidable_correct envp env) in D. unfold decidable in D. + simpl. tauto. + - simpl in *; tauto. Qed. -Definition omega_tactic (t1 : e_step) (t2 : list h_step) - (c : proposition) (l : hyps) := - reduce_lhyps (decompose_solve t1 (normalize_hyps t2 (concl_to_hyp c :: l))). +(** The omega tactic : all steps together *) + +Definition omega_tactic (t1 : e_step) (c : proposition) (l : hyps) := + reduce_lhyps (decompose_solve t1 (normalize_hyps (concl_to_hyp c :: l))). Theorem do_omega : - forall (t1 : e_step) (t2 : list h_step) (envp : list Prop) + forall (t : e_step) (envp : list Prop) (env : list int) (c : proposition) (l : hyps), - interp_list_goal envp env (omega_tactic t1 t2 c l) -> + interp_list_goal envp env (omega_tactic t c l) -> interp_goal_concl c envp env l. Proof. - unfold omega_tactic; intros; apply do_concl_to_hyp; - apply (normalize_hyps_goal t2); apply (decompose_solve_valid t1); - apply do_reduce_lhyps; assumption. + unfold omega_tactic; intros t ep e c l H. + apply do_concl_to_hyp. + apply normalize_hyps_goal. + apply (decompose_solve_valid t). + now apply do_reduce_lhyps. Qed. End IntOmega. -(* For now, the above modular construction is instanciated on Z, - in order to retrieve the initial ROmega. *) +(** For now, the above modular construction is instanciated on Z, + in order to retrieve the initial ROmega. *) Module ZOmega := IntOmega(Z_as_Int). diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 8d7ae51fc0..fbed1df176 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -10,10 +10,10 @@ let module_refl_name = "ReflOmegaCore" let module_refl_path = ["Coq"; "romega"; module_refl_name] type result = - Kvar of string - | Kapp of string * Term.constr list - | Kimp of Term.constr * Term.constr - | Kufo;; + | Kvar of string + | Kapp of string * Term.constr list + | Kimp of Term.constr * Term.constr + | Kufo let meaningful_submodule = [ "Z"; "N"; "Pos" ] @@ -30,19 +30,17 @@ let string_of_global r = let destructurate t = let c, args = Term.decompose_app t in match Term.kind_of_term c, args with - | Term.Const (sp,_), args -> - Kapp (string_of_global (Globnames.ConstRef sp), args) - | Term.Construct (csp,_) , args -> - Kapp (string_of_global (Globnames.ConstructRef csp), args) - | Term.Ind (isp,_), args -> - Kapp (string_of_global (Globnames.IndRef isp), args) - | Term.Var id,[] -> Kvar(Names.Id.to_string id) - | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) - | Term.Prod (Names.Name _,_,_),[] -> - CErrors.error "Omega: Not a quantifier-free goal" - | _ -> Kufo - -exception Destruct + | Term.Const (sp,_), args -> + Kapp (string_of_global (Globnames.ConstRef sp), args) + | Term.Construct (csp,_) , args -> + Kapp (string_of_global (Globnames.ConstructRef csp), args) + | Term.Ind (isp,_), args -> + Kapp (string_of_global (Globnames.IndRef isp), args) + | Term.Var id, [] -> Kvar(Names.Id.to_string id) + | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) + | _ -> Kufo + +exception DestConstApp let dest_const_apply t = let f,args = Term.decompose_app t in @@ -51,8 +49,8 @@ let dest_const_apply t = | Term.Const (sp,_) -> Globnames.ConstRef sp | Term.Construct (csp,_) -> Globnames.ConstructRef csp | Term.Ind (isp,_) -> Globnames.IndRef isp - | _ -> raise Destruct - in Nametab.basename_of_global ref, args + | _ -> raise DestConstApp + in Nametab.basename_of_global ref, args let logic_dir = ["Coq";"Logic";"Decidable"] @@ -65,13 +63,13 @@ let coq_modules = let bin_module = [["Coq";"Numbers";"BinNums"]] let z_module = [["Coq";"ZArith";"BinInt"]] -let init_constant = Coqlib.gen_constant_in_modules "Omega" Coqlib.init_modules -let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules -let z_constant = Coqlib.gen_constant_in_modules "Omega" z_module -let bin_constant = Coqlib.gen_constant_in_modules "Omega" bin_module +let init_constant x = Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" Coqlib.init_modules x +let constant x = Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" coq_modules x +let z_constant x = Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" z_module x +let bin_constant x = Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" bin_module x (* Logic *) -let coq_refl_equal = lazy(init_constant "eq_refl") +let coq_refl_equal = lazy(init_constant "eq_refl") let coq_and = lazy(init_constant "and") let coq_not = lazy(init_constant "not") let coq_or = lazy(init_constant "or") @@ -81,13 +79,6 @@ let coq_I = lazy(init_constant "I") (* ReflOmegaCore/ZOmega *) -let coq_h_step = lazy (constant "h_step") -let coq_pair_step = lazy (constant "pair_step") -let coq_p_left = lazy (constant "P_LEFT") -let coq_p_right = lazy (constant "P_RIGHT") -let coq_p_invert = lazy (constant "P_INVERT") -let coq_p_step = lazy (constant "P_STEP") - let coq_t_int = lazy (constant "Tint") let coq_t_plus = lazy (constant "Tplus") let coq_t_mult = lazy (constant "Tmult") @@ -110,62 +101,17 @@ let coq_p_and = lazy (constant "Tand") let coq_p_imp = lazy (constant "Timp") let coq_p_prop = lazy (constant "Tprop") -(* Constructors for shuffle tactic *) -let coq_t_fusion = lazy (constant "t_fusion") -let coq_f_equal = lazy (constant "F_equal") -let coq_f_cancel = lazy (constant "F_cancel") -let coq_f_left = lazy (constant "F_left") -let coq_f_right = lazy (constant "F_right") - -(* Constructors for reordering tactics *) -let coq_c_do_both = lazy (constant "C_DO_BOTH") -let coq_c_do_left = lazy (constant "C_LEFT") -let coq_c_do_right = lazy (constant "C_RIGHT") -let coq_c_do_seq = lazy (constant "C_SEQ") -let coq_c_nop = lazy (constant "C_NOP") -let coq_c_opp_plus = lazy (constant "C_OPP_PLUS") -let coq_c_opp_opp = lazy (constant "C_OPP_OPP") -let coq_c_opp_mult_r = lazy (constant "C_OPP_MULT_R") -let coq_c_opp_one = lazy (constant "C_OPP_ONE") -let coq_c_reduce = lazy (constant "C_REDUCE") -let coq_c_mult_plus_distr = lazy (constant "C_MULT_PLUS_DISTR") -let coq_c_opp_left = lazy (constant "C_MULT_OPP_LEFT") -let coq_c_mult_assoc_r = lazy (constant "C_MULT_ASSOC_R") -let coq_c_plus_assoc_r = lazy (constant "C_PLUS_ASSOC_R") -let coq_c_plus_assoc_l = lazy (constant "C_PLUS_ASSOC_L") -let coq_c_plus_permute = lazy (constant "C_PLUS_PERMUTE") -let coq_c_plus_comm = lazy (constant "C_PLUS_COMM") -let coq_c_red0 = lazy (constant "C_RED0") -let coq_c_red1 = lazy (constant "C_RED1") -let coq_c_red2 = lazy (constant "C_RED2") -let coq_c_red3 = lazy (constant "C_RED3") -let coq_c_red4 = lazy (constant "C_RED4") -let coq_c_red5 = lazy (constant "C_RED5") -let coq_c_red6 = lazy (constant "C_RED6") -let coq_c_mult_opp_left = lazy (constant "C_MULT_OPP_LEFT") -let coq_c_mult_assoc_reduced = lazy (constant "C_MULT_ASSOC_REDUCED") -let coq_c_minus = lazy (constant "C_MINUS") -let coq_c_mult_comm = lazy (constant "C_MULT_COMM") - -let coq_s_constant_not_nul = lazy (constant "O_CONSTANT_NOT_NUL") -let coq_s_constant_neg = lazy (constant "O_CONSTANT_NEG") -let coq_s_div_approx = lazy (constant "O_DIV_APPROX") +let coq_s_bad_constant = lazy (constant "O_BAD_CONSTANT") +let coq_s_divide = lazy (constant "O_DIVIDE") let coq_s_not_exact_divide = lazy (constant "O_NOT_EXACT_DIVIDE") -let coq_s_exact_divide = lazy (constant "O_EXACT_DIVIDE") let coq_s_sum = lazy (constant "O_SUM") -let coq_s_state = lazy (constant "O_STATE") -let coq_s_contradiction = lazy (constant "O_CONTRADICTION") let coq_s_merge_eq = lazy (constant "O_MERGE_EQ") let coq_s_split_ineq =lazy (constant "O_SPLIT_INEQ") -let coq_s_constant_nul =lazy (constant "O_CONSTANT_NUL") -let coq_s_negate_contradict =lazy (constant "O_NEGATE_CONTRADICT") -let coq_s_negate_contradict_inv =lazy (constant "O_NEGATE_CONTRADICT_INV") (* construction for the [extract_hyp] tactic *) let coq_direction = lazy (constant "direction") let coq_d_left = lazy (constant "D_left") let coq_d_right = lazy (constant "D_right") -let coq_d_mono = lazy (constant "D_mono") let coq_e_split = lazy (constant "E_SPLIT") let coq_e_extract = lazy (constant "E_EXTRACT") @@ -174,31 +120,6 @@ let coq_e_solve = lazy (constant "E_SOLVE") let coq_interp_sequent = lazy (constant "interp_goal_concl") let coq_do_omega = lazy (constant "do_omega") -(* \subsection{Construction d'expressions} *) - -let do_left t = - if Term.eq_constr t (Lazy.force coq_c_nop) then Lazy.force coq_c_nop - else Term.mkApp (Lazy.force coq_c_do_left, [|t |] ) - -let do_right t = - if Term.eq_constr t (Lazy.force coq_c_nop) then Lazy.force coq_c_nop - else Term.mkApp (Lazy.force coq_c_do_right, [|t |]) - -let do_both t1 t2 = - if Term.eq_constr t1 (Lazy.force coq_c_nop) then do_right t2 - else if Term.eq_constr t2 (Lazy.force coq_c_nop) then do_left t1 - else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |]) - -let do_seq t1 t2 = - if Term.eq_constr t1 (Lazy.force coq_c_nop) then t2 - else if Term.eq_constr t2 (Lazy.force coq_c_nop) then t1 - else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |]) - -let rec do_list = function - | [] -> Lazy.force coq_c_nop - | [x] -> x - | (x::l) -> do_seq x (do_list l) - (* Nat *) let coq_S = lazy(init_constant "S") @@ -212,7 +133,7 @@ let rec mk_nat = function let mkListConst c = let r = - Coqlib.gen_reference "" ["Init";"Datatypes"] c + Coqlib.coq_reference "" ["Init";"Datatypes"] c in let inst = if Global.is_polymorphic r then fun u -> Univ.Instance.of_array [|u|] @@ -235,8 +156,6 @@ let mk_plist = fun l -> mk_list type1lev Term.mkProp l let mk_list = mk_list Univ.Level.set -let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l - type parse_term = | Tplus of Term.constr * Term.constr @@ -263,18 +182,40 @@ type parse_rel = | Riff of Term.constr * Term.constr | Rother -let parse_logic_rel c = - try match destructurate c with - | Kapp("True",[]) -> Rtrue - | Kapp("False",[]) -> Rfalse - | Kapp("not",[t]) -> Rnot t - | Kapp("or",[t1;t2]) -> Ror (t1,t2) - | Kapp("and",[t1;t2]) -> Rand (t1,t2) - | Kimp(t1,t2) -> Rimp (t1,t2) - | Kapp("iff",[t1;t2]) -> Riff (t1,t2) - | _ -> Rother - with e when Logic.catchable_exception e -> Rother +let parse_logic_rel c = match destructurate c with + | Kapp("True",[]) -> Rtrue + | Kapp("False",[]) -> Rfalse + | Kapp("not",[t]) -> Rnot t + | Kapp("or",[t1;t2]) -> Ror (t1,t2) + | Kapp("and",[t1;t2]) -> Rand (t1,t2) + | Kimp(t1,t2) -> Rimp (t1,t2) + | Kapp("iff",[t1;t2]) -> Riff (t1,t2) + | _ -> Rother + +(* Binary numbers *) + +let coq_xH = lazy (bin_constant "xH") +let coq_xO = lazy (bin_constant "xO") +let coq_xI = lazy (bin_constant "xI") +let coq_Z0 = lazy (bin_constant "Z0") +let coq_Zpos = lazy (bin_constant "Zpos") +let coq_Zneg = lazy (bin_constant "Zneg") +let coq_N0 = lazy (bin_constant "N0") +let coq_Npos = lazy (bin_constant "Npos") + +let rec mk_positive n = + if Bigint.equal n Bigint.one then Lazy.force coq_xH + else + let (q,r) = Bigint.euclid n Bigint.two in + Term.mkApp + ((if Bigint.equal r Bigint.zero + then Lazy.force coq_xO else Lazy.force coq_xI), + [| mk_positive q |]) +let mk_N = function + | 0 -> Lazy.force coq_N0 + | n -> Term.mkApp (Lazy.force coq_Npos, + [| mk_positive (Bigint.of_int n) |]) module type Int = sig val typ : Term.constr Lazy.t @@ -287,7 +228,7 @@ module type Int = sig val parse_term : Term.constr -> parse_term val parse_rel : ([ `NF ], 'r) Proofview.Goal.t -> Term.constr -> parse_rel (* check whether t is built only with numbers and + * - *) - val is_scalar : Term.constr -> bool + val get_scalar : Term.constr -> Bigint.bigint option end module Z : Int = struct @@ -298,38 +239,29 @@ let mult = lazy (z_constant "Z.mul") let opp = lazy (z_constant "Z.opp") let minus = lazy (z_constant "Z.sub") -let coq_xH = lazy (bin_constant "xH") -let coq_xO = lazy (bin_constant "xO") -let coq_xI = lazy (bin_constant "xI") -let coq_Z0 = lazy (bin_constant "Z0") -let coq_Zpos = lazy (bin_constant "Zpos") -let coq_Zneg = lazy (bin_constant "Zneg") - -let recognize t = +let recognize_pos t = let rec loop t = let f,l = dest_const_apply t in match Names.Id.to_string f,l with - "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t)) - | "xO",[t] -> Bigint.mult Bigint.two (loop t) - | "xH",[] -> Bigint.one - | _ -> failwith "not a number" in - let f,l = dest_const_apply t in - match Names.Id.to_string f,l with - "Zpos",[t] -> loop t - | "Zneg",[t] -> Bigint.neg (loop t) - | "Z0",[] -> Bigint.zero - | _ -> failwith "not a number";; + | "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t)) + | "xO",[t] -> Bigint.mult Bigint.two (loop t) + | "xH",[] -> Bigint.one + | _ -> raise DestConstApp + in + try Some (loop t) with DestConstApp -> None -let rec mk_positive n = - if n=Bigint.one then Lazy.force coq_xH - else - let (q,r) = Bigint.euclid n Bigint.two in - Term.mkApp - ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI), - [| mk_positive q |]) +let recognize_Z t = + try + let f,l = dest_const_apply t in + match Names.Id.to_string f,l with + | "Zpos",[t] -> recognize_pos t + | "Zneg",[t] -> Option.map Bigint.neg (recognize_pos t) + | "Z0",[] -> Some Bigint.zero + | _ -> None + with DestConstApp -> None let mk_Z n = - if n = Bigint.zero then Lazy.force coq_Z0 + if Bigint.equal n Bigint.zero then Lazy.force coq_Z0 else if Bigint.is_strictly_pos n then Term.mkApp (Lazy.force coq_Zpos, [| mk_positive n |]) else @@ -338,38 +270,46 @@ let mk_Z n = let mk = mk_Z let parse_term t = - try match destructurate t with - | Kapp("Z.add",[t1;t2]) -> Tplus (t1,t2) - | Kapp("Z.sub",[t1;t2]) -> Tminus (t1,t2) - | Kapp("Z.mul",[t1;t2]) -> Tmult (t1,t2) - | Kapp("Z.opp",[t]) -> Topp t - | Kapp("Z.succ",[t]) -> Tsucc t - | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> - (try Tnum (recognize t) with e when CErrors.noncritical e -> Tother) - | _ -> Tother - with e when Logic.catchable_exception e -> Tother - -let pf_nf gl c = Tacmach.New.pf_apply Tacred.simpl gl c + match destructurate t with + | Kapp("Z.add",[t1;t2]) -> Tplus (t1,t2) + | Kapp("Z.sub",[t1;t2]) -> Tminus (t1,t2) + | Kapp("Z.mul",[t1;t2]) -> Tmult (t1,t2) + | Kapp("Z.opp",[t]) -> Topp t + | Kapp("Z.succ",[t]) -> Tsucc t + | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) + | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> + (match recognize_Z t with Some t -> Tnum t | None -> Tother) + | _ -> Tother + +let pf_nf gl c = + EConstr.Unsafe.to_constr + (Tacmach.New.pf_apply Tacred.simpl gl (EConstr.of_constr c)) let parse_rel gl t = - try match destructurate t with - | Kapp("eq",[typ;t1;t2]) - when destructurate (EConstr.Unsafe.to_constr (pf_nf gl (EConstr.of_constr typ))) = Kapp("Z",[]) -> Req (t1,t2) - | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) - | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2) - | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2) - | Kapp("Z.ge",[t1;t2]) -> Rge (t1,t2) - | Kapp("Z.gt",[t1;t2]) -> Rgt (t1,t2) - | _ -> parse_logic_rel t - with e when Logic.catchable_exception e -> Rother - -let is_scalar t = - let rec aux t = match destructurate t with - | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> aux t1 && aux t2 - | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true - | _ -> false in - try aux t with e when CErrors.noncritical e -> false + match destructurate t with + | Kapp("eq",[typ;t1;t2]) -> + (match destructurate (pf_nf gl typ) with + | Kapp("Z",[]) -> Req (t1,t2) + | _ -> Rother) + | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) + | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2) + | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2) + | Kapp("Z.ge",[t1;t2]) -> Rge (t1,t2) + | Kapp("Z.gt",[t1;t2]) -> Rgt (t1,t2) + | _ -> parse_logic_rel t + +let rec get_scalar t = + match destructurate t with + | Kapp("Z.add", [t1;t2]) -> + Option.lift2 Bigint.add (get_scalar t1) (get_scalar t2) + | Kapp ("Z.sub",[t1;t2]) -> + Option.lift2 Bigint.sub (get_scalar t1) (get_scalar t2) + | Kapp ("Z.mul",[t1;t2]) -> + Option.lift2 Bigint.mult (get_scalar t1) (get_scalar t2) + | Kapp("Z.opp", [t]) -> Option.map Bigint.neg (get_scalar t) + | Kapp("Z.succ", [t]) -> Option.map Bigint.add_1 (get_scalar t) + | Kapp("Z.pred", [t]) -> Option.map Bigint.sub_1 (get_scalar t) + | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> recognize_Z t + | _ -> None end diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index ee7ff451a9..ca23ed6c42 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -19,12 +19,6 @@ val coq_False : Term.constr lazy_t val coq_I : Term.constr lazy_t (* from ReflOmegaCore/ZOmega *) -val coq_h_step : Term.constr lazy_t -val coq_pair_step : Term.constr lazy_t -val coq_p_left : Term.constr lazy_t -val coq_p_right : Term.constr lazy_t -val coq_p_invert : Term.constr lazy_t -val coq_p_step : Term.constr lazy_t val coq_t_int : Term.constr lazy_t val coq_t_plus : Term.constr lazy_t @@ -48,58 +42,16 @@ val coq_p_and : Term.constr lazy_t val coq_p_imp : Term.constr lazy_t val coq_p_prop : Term.constr lazy_t -val coq_f_equal : Term.constr lazy_t -val coq_f_cancel : Term.constr lazy_t -val coq_f_left : Term.constr lazy_t -val coq_f_right : Term.constr lazy_t - -val coq_c_do_both : Term.constr lazy_t -val coq_c_do_left : Term.constr lazy_t -val coq_c_do_right : Term.constr lazy_t -val coq_c_do_seq : Term.constr lazy_t -val coq_c_nop : Term.constr lazy_t -val coq_c_opp_plus : Term.constr lazy_t -val coq_c_opp_opp : Term.constr lazy_t -val coq_c_opp_mult_r : Term.constr lazy_t -val coq_c_opp_one : Term.constr lazy_t -val coq_c_reduce : Term.constr lazy_t -val coq_c_mult_plus_distr : Term.constr lazy_t -val coq_c_opp_left : Term.constr lazy_t -val coq_c_mult_assoc_r : Term.constr lazy_t -val coq_c_plus_assoc_r : Term.constr lazy_t -val coq_c_plus_assoc_l : Term.constr lazy_t -val coq_c_plus_permute : Term.constr lazy_t -val coq_c_plus_comm : Term.constr lazy_t -val coq_c_red0 : Term.constr lazy_t -val coq_c_red1 : Term.constr lazy_t -val coq_c_red2 : Term.constr lazy_t -val coq_c_red3 : Term.constr lazy_t -val coq_c_red4 : Term.constr lazy_t -val coq_c_red5 : Term.constr lazy_t -val coq_c_red6 : Term.constr lazy_t -val coq_c_mult_opp_left : Term.constr lazy_t -val coq_c_mult_assoc_reduced : Term.constr lazy_t -val coq_c_minus : Term.constr lazy_t -val coq_c_mult_comm : Term.constr lazy_t - -val coq_s_constant_not_nul : Term.constr lazy_t -val coq_s_constant_neg : Term.constr lazy_t -val coq_s_div_approx : Term.constr lazy_t +val coq_s_bad_constant : Term.constr lazy_t +val coq_s_divide : Term.constr lazy_t val coq_s_not_exact_divide : Term.constr lazy_t -val coq_s_exact_divide : Term.constr lazy_t val coq_s_sum : Term.constr lazy_t -val coq_s_state : Term.constr lazy_t -val coq_s_contradiction : Term.constr lazy_t val coq_s_merge_eq : Term.constr lazy_t val coq_s_split_ineq : Term.constr lazy_t -val coq_s_constant_nul : Term.constr lazy_t -val coq_s_negate_contradict : Term.constr lazy_t -val coq_s_negate_contradict_inv : Term.constr lazy_t val coq_direction : Term.constr lazy_t val coq_d_left : Term.constr lazy_t val coq_d_right : Term.constr lazy_t -val coq_d_mono : Term.constr lazy_t val coq_e_split : Term.constr lazy_t val coq_e_extract : Term.constr lazy_t @@ -108,19 +60,12 @@ val coq_e_solve : Term.constr lazy_t val coq_interp_sequent : Term.constr lazy_t val coq_do_omega : Term.constr lazy_t -(** Building expressions *) - -val do_left : Term.constr -> Term.constr -val do_right : Term.constr -> Term.constr -val do_both : Term.constr -> Term.constr -> Term.constr -val do_seq : Term.constr -> Term.constr -> Term.constr -val do_list : Term.constr list -> Term.constr - val mk_nat : int -> Term.constr +val mk_N : int -> Term.constr + (** Precondition: the type of the list is in Set *) val mk_list : Term.constr -> Term.constr list -> Term.constr val mk_plist : Term.types list -> Term.types -val mk_shuffle_list : Term.constr list -> Term.constr (** Analyzing a coq term *) @@ -170,7 +115,7 @@ module type Int = (* parsing a relation expression, including = < <= >= > *) val parse_rel : ([ `NF ], 'r) Proofview.Goal.t -> Term.constr -> parse_rel (* Is a particular term only made of numbers and + * - ? *) - val is_scalar : Term.constr -> bool + val get_scalar : Term.constr -> Bigint.bigint option end (* Currently, we only use Z numbers *) diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index df7e5cb99e..6479c683b2 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -21,14 +21,14 @@ let eval_tactic name = let tac = Tacenv.interp_ltac kn in Tacinterp.eval_tactic tac -let romega_tactic l = +let romega_tactic unsafe l = let tacs = List.map (function | "nat" -> eval_tactic "zify_nat" | "positive" -> eval_tactic "zify_positive" | "N" -> eval_tactic "zify_N" | "Z" -> eval_tactic "zify_op" - | s -> CErrors.error ("No ROmega knowledge base for type "^s)) + | s -> CErrors.user_err Pp.(str ("No ROmega knowledge base for type "^s))) (Util.List.sort_uniquize String.compare l) in Tacticals.New.tclTHEN @@ -38,15 +38,15 @@ let romega_tactic l = we'd better leave as little as possible in the conclusion, for an easier decidability argument. *) (Tactics.intros) - (total_reflexive_omega_tactic)) - + (total_reflexive_omega_tactic unsafe)) TACTIC EXTEND romega -| [ "romega" ] -> [ romega_tactic [] ] +| [ "romega" ] -> [ romega_tactic false [] ] +| [ "unsafe_romega" ] -> [ romega_tactic true [] ] END TACTIC EXTEND romega' | [ "romega" "with" ne_ident_list(l) ] -> - [ romega_tactic (List.map Names.Id.to_string l) ] -| [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ] + [ romega_tactic false (List.map Names.Id.to_string l) ] +| [ "romega" "with" "*" ] -> [ romega_tactic false ["nat";"positive";"N";"Z"] ] END diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index a20589fb46..fdcd622994 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -13,6 +13,10 @@ open Const_omega module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint) open OmegaSolver +module Id = Names.Id +module IntSet = Int.Set +module IntHtbl = Hashtbl.Make(Int) + (* \section{Useful functions and flags} *) (* Especially useful debugging functions *) let debug = ref false @@ -38,13 +42,11 @@ type direction = Left of int | Right of int type occ_step = O_left | O_right | O_mono type occ_path = occ_step list -let occ_step_eq s1 s2 = match s1, s2 with -| O_left, O_left | O_right, O_right | O_mono, O_mono -> true -| _ -> false - (* chemin identifiant une proposition sous forme du nom de l'hypothèse et d'une liste de pas à partir de la racine de l'hypothèse *) -type occurrence = {o_hyp : Names.Id.t; o_path : occ_path} +type occurrence = {o_hyp : Id.t; o_path : occ_path} + +type atom_index = int (* \subsection{reifiable formulas} *) type oformula = @@ -52,21 +54,22 @@ type oformula = | Oint of Bigint.bigint (* recognized binary and unary operations *) | Oplus of oformula * oformula - | Omult of oformula * oformula + | Omult of oformula * oformula (* Invariant : one side is [Oint] *) | Ominus of oformula * oformula | Oopp of oformula (* an atom in the environment *) - | Oatom of int - (* weird expression that cannot be translated *) - | Oufo of oformula + | Oatom of atom_index (* Operators for comparison recognized by Omega *) type comparaison = Eq | Leq | Geq | Gt | Lt | Neq -(* Type des prédicats réifiés (fragment de calcul propositionnel. Les - * quantifications sont externes au langage) *) +(* Representation of reified predicats (fragment of propositional calculus, + no quantifier here). *) +(* Note : in [Pprop p], the non-reified constr [p] should be closed + (it could contains some [Term.Var] but no [Term.Rel]). So no need to + lift when breaking or creating arrows. *) type oproposition = - Pequa of Term.constr * oequation + Pequa of Term.constr * oequation (* constr = copy of the Coq formula *) | Ptrue | Pfalse | Pnot of oproposition @@ -75,19 +78,18 @@ type oproposition = | Pimp of int * oproposition * oproposition | Pprop of Term.constr -(* Les équations ou propositions atomiques utiles du calcul *) +(* The equations *) and oequation = { e_comp: comparaison; (* comparaison *) e_left: oformula; (* formule brute gauche *) e_right: oformula; (* formule brute droite *) - e_trace: Term.constr; (* tactique de normalisation *) e_origin: occurrence; (* l'hypothèse dont vient le terme *) e_negated: bool; (* vrai si apparait en position nié après normalisation *) - e_depends: direction list; (* liste des points de disjonction dont + e_depends: direction list; (* liste des points de disjonction dont dépend l'accès à l'équation avec la direction (branche) pour y accéder *) - e_omega: afine (* la fonction normalisée *) + e_omega: OmegaSolver.afine (* normalized formula *) } (* \subsection{Proof context} @@ -104,24 +106,22 @@ type environment = { mutable terms : Term.constr list; (* La meme chose pour les propositions *) mutable props : Term.constr list; - (* Les variables introduites par omega *) - mutable om_vars : (oformula * int) list; (* Traduction des indices utilisés ici en les indices finaux utilisés par * la tactique Omega après dénombrement des variables utiles *) - real_indices : (int,int) Hashtbl.t; + real_indices : int IntHtbl.t; mutable cnt_connectors : int; - equations : (int,oequation) Hashtbl.t; - constructors : (int, occurrence) Hashtbl.t + equations : oequation IntHtbl.t; + constructors : occurrence IntHtbl.t } (* \subsection{Solution tree} Définition d'une solution trouvée par Omega sous la forme d'un identifiant, d'un ensemble d'équation dont dépend la solution et d'une trace *) -(* La liste des dépendances est triée et sans redondance *) + type solution = { s_index : int; - s_equa_deps : int list; - s_trace : action list } + s_equa_deps : IntSet.t; + s_trace : OmegaSolver.action list } (* Arbre de solution résolvant complètement un ensemble de systèmes *) type solution_tree = @@ -139,16 +139,35 @@ type context_content = CCHyp of occurrence | CCEqua of int +(** Some dedicated equality tests *) + +let occ_step_eq s1 s2 = match s1, s2 with +| O_left, O_left | O_right, O_right | O_mono, O_mono -> true +| _ -> false + +let rec oform_eq f f' = match f,f' with + | Oint i, Oint i' -> Bigint.equal i i' + | Oplus (f1,f2), Oplus (f1',f2') + | Omult (f1,f2), Omult (f1',f2') + | Ominus (f1,f2), Ominus (f1',f2') -> oform_eq f1 f1' && oform_eq f2 f2' + | Oopp f, Oopp f' -> oform_eq f f' + | Oatom a, Oatom a' -> Int.equal a a' + | _ -> false + +let dir_eq d d' = match d, d' with + | Left i, Left i' | Right i, Right i' -> Int.equal i i' + | _ -> false + (* \section{Specific utility functions to handle base types} *) (* Nom arbitraire de l'hypothèse codant la négation du but final *) -let id_concl = Names.Id.of_string "__goal__" +let id_concl = Id.of_string "__goal__" (* Initialisation de l'environnement de réification de la tactique *) let new_environment () = { - terms = []; props = []; om_vars = []; cnt_connectors = 0; - real_indices = Hashtbl.create 7; - equations = Hashtbl.create 7; - constructors = Hashtbl.create 7; + terms = []; props = []; cnt_connectors = 0; + real_indices = IntHtbl.create 7; + equations = IntHtbl.create 7; + constructors = IntHtbl.create 7; } (* Génération d'un nom d'équation *) @@ -178,44 +197,22 @@ let print_env_reification env = (* generation d'identifiant d'equation pour Omega *) let new_omega_eq, rst_omega_eq = - let cpt = ref 0 in + let cpt = ref (-1) in (function () -> incr cpt; !cpt), - (function () -> cpt:=0) + (function () -> cpt:=(-1)) (* generation d'identifiant de variable pour Omega *) -let new_omega_var, rst_omega_var = - let cpt = ref 0 in +let new_omega_var, rst_omega_var, set_omega_maxvar = + let cpt = ref (-1) in (function () -> incr cpt; !cpt), - (function () -> cpt:=0) + (function () -> cpt:=(-1)), + (function n -> cpt:=n) (* Affichage des variables d'un système *) let display_omega_var i = Printf.sprintf "OV%d" i -(* Recherche la variable codant un terme pour Omega et crée la variable dans - l'environnement si il n'existe pas. Cas ou la variable dans Omega représente - le terme d'un monome (le plus souvent un atome) *) - -let intern_omega env t = - begin try List.assoc_f Pervasives.(=) t env.om_vars (* FIXME *) - with Not_found -> - let v = new_omega_var () in - env.om_vars <- (t,v) :: env.om_vars; v - end - -(* Ajout forcé d'un lien entre un terme et une variable Cas où la - variable est créée par Omega et où il faut la lier après coup à un atome - réifié introduit de force *) -let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars - -(* Récupère le terme associé à une variable *) -let unintern_omega env id = - let rec loop = function - [] -> failwith "unintern" - | ((t,j)::l) -> if Int.equal id j then t else loop l in - loop env.om_vars - (* \subsection{Gestion des environnements de variable pour la réflexion} Gestion des environnements de traduction entre termes des constructions non réifiés et variables des termes reifies. Attention il s'agit de @@ -231,6 +228,13 @@ let add_reified_atom t env = let get_reified_atom env = try List.nth env.terms with Invalid_argument _ -> failwith "get_reified_atom" +(** When the omega resolution has created a variable [v], we re-sync + the environment with this new variable. To be done in the right order. *) + +let set_reified_atom v t env = + assert (Int.equal v (List.length env.terms)); + env.terms <- env.terms @ [t] + (* \subsection{Gestion de l'environnement de proposition pour Omega} *) (* ajout d'une proposition *) let add_prop env t = @@ -246,12 +250,11 @@ let get_prop v env = (* Ajout d'une equation dans l'environnement de reification *) let add_equation env e = let id = e.e_omega.id in - try let _ = Hashtbl.find env.equations id in () - with Not_found -> Hashtbl.add env.equations id e + if IntHtbl.mem env.equations id then () else IntHtbl.add env.equations id e (* accès a une equation *) let get_equation env id = - try Hashtbl.find env.equations id + try IntHtbl.find env.equations id with Not_found as e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e @@ -263,15 +266,14 @@ let rec oprint ch = function | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1 | Oatom n -> Printf.fprintf ch "V%02d" n - | Oufo x -> Printf.fprintf ch "?" + +let print_comp = function + | Eq -> "=" | Leq -> "<=" | Geq -> ">=" + | Gt -> ">" | Lt -> "<" | Neq -> "!=" let rec pprint ch = function Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 }) -> - let connector = - match comp with - Eq -> "=" | Leq -> "<=" | Geq -> ">=" - | Gt -> ">" | Lt -> "<" | Neq -> "!=" in - Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2 + Printf.fprintf ch "%a %s %a" oprint t1 (print_comp comp) oprint t2 | Ptrue -> Printf.fprintf ch "TT" | Pfalse -> Printf.fprintf ch "FF" | Pnot t -> Printf.fprintf ch "not(%a)" pprint t @@ -280,38 +282,13 @@ let rec pprint ch = function | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2 | Pprop c -> Printf.fprintf ch "Prop" -let rec weight env = function - | Oint _ -> -1 - | Oopp c -> weight env c - | Omult(c,_) -> weight env c - | Oplus _ -> failwith "weight" - | Ominus _ -> failwith "weight minus" - | Oufo _ -> -1 - | Oatom _ as c -> (intern_omega env c) - -(* \section{Passage entre oformules et représentation interne de Omega} *) - -(* \subsection{Oformula vers Omega} *) - -let omega_of_oformula env kind = - let rec loop accu = function - | Oplus(Omult(v,Oint n),r) -> - loop ({v=intern_omega env v; c=n} :: accu) r - | Oint n -> - let id = new_omega_eq () in - (*i tag_equation name id; i*) - {kind = kind; body = List.rev accu; - constant = n; id = id} - | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in - loop [] - (* \subsection{Omega vers Oformula} *) -let oformula_of_omega env af = +let oformula_of_omega af = let rec loop = function - | ({v=v; c=n}::r) -> - Oplus(Omult(unintern_omega env v,Oint n),loop r) - | [] -> Oint af.constant in + | ({v=v; c=n}::r) -> Oplus(Omult(Oatom v,Oint n),loop r) + | [] -> Oint af.constant + in loop af.body let app f v = mkApp(Lazy.force f,v) @@ -324,7 +301,6 @@ let coq_of_formula env t = | Oopp t -> app Z.opp [| loop t |] | Omult(t1,t2) -> app Z.mult [| loop t1; loop t2 |] | Oint v -> Z.mk v - | Oufo t -> loop t | Oatom var -> (* attention ne traite pas les nouvelles variables si on ne les * met pas dans env.term *) @@ -335,77 +311,59 @@ let coq_of_formula env t = (* \subsection{Oformula vers COQ reifié} *) let reified_of_atom env i = - try Hashtbl.find env.real_indices i + try IntHtbl.find env.real_indices i with Not_found -> Printf.printf "Atome %d non trouvé\n" i; - Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; + IntHtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; raise Not_found -let rec reified_of_formula env = function - | Oplus (t1,t2) -> - app coq_t_plus [| reified_of_formula env t1; reified_of_formula env t2 |] - | Oopp t -> - app coq_t_opp [| reified_of_formula env t |] - | Omult(t1,t2) -> - app coq_t_mult [| reified_of_formula env t1; reified_of_formula env t2 |] - | Oint v -> app coq_t_int [| Z.mk v |] - | Oufo t -> reified_of_formula env t - | Oatom i -> app coq_t_var [| mk_nat (reified_of_atom env i) |] - | Ominus(t1,t2) -> - app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |] +let reified_binop = function + | Oplus _ -> app coq_t_plus + | Ominus _ -> app coq_t_minus + | Omult _ -> app coq_t_mult + | _ -> assert false + +let rec reified_of_formula env t = match t with + | Oplus (t1,t2) | Omult (t1,t2) | Ominus (t1,t2) -> + reified_binop t [| reified_of_formula env t1; reified_of_formula env t2 |] + | Oopp t -> app coq_t_opp [| reified_of_formula env t |] + | Oint v -> app coq_t_int [| Z.mk v |] + | Oatom i -> app coq_t_var [| mk_N (reified_of_atom env i) |] let reified_of_formula env f = try reified_of_formula env f with reraise -> oprint stderr f; raise reraise -let rec reified_of_proposition env = function - Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> - app coq_p_eq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> - app coq_p_leq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> - app coq_p_geq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> - app coq_p_gt [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) -> - app coq_p_lt [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> - app coq_p_neq [| reified_of_formula env t1; reified_of_formula env t2 |] +let reified_cmp = function + | Eq -> app coq_p_eq + | Leq -> app coq_p_leq + | Geq -> app coq_p_geq + | Gt -> app coq_p_gt + | Lt -> app coq_p_lt + | Neq -> app coq_p_neq + +let reified_conn = function + | Por _ -> app coq_p_or + | Pand _ -> app coq_p_and + | Pimp _ -> app coq_p_imp + | _ -> assert false + +let rec reified_of_oprop env t = match t with + | Pequa (_,{ e_comp=cmp; e_left=t1; e_right=t2 }) -> + reified_cmp cmp [| reified_of_formula env t1; reified_of_formula env t2 |] | Ptrue -> Lazy.force coq_p_true | Pfalse -> Lazy.force coq_p_false - | Pnot t -> - app coq_p_not [| reified_of_proposition env t |] - | Por (_,t1,t2) -> - app coq_p_or - [| reified_of_proposition env t1; reified_of_proposition env t2 |] - | Pand(_,t1,t2) -> - app coq_p_and - [| reified_of_proposition env t1; reified_of_proposition env t2 |] - | Pimp(_,t1,t2) -> - app coq_p_imp - [| reified_of_proposition env t1; reified_of_proposition env t2 |] + | Pnot t -> app coq_p_not [| reified_of_oprop env t |] + | Por (_,t1,t2) | Pand (_,t1,t2) | Pimp (_,t1,t2) -> + reified_conn t [| reified_of_oprop env t1; reified_of_oprop env t2 |] | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |] let reified_of_proposition env f = - try reified_of_proposition env f + try reified_of_oprop env f with reraise -> pprint stderr f; raise reraise -(* \subsection{Omega vers COQ réifié} *) - -let reified_of_omega env body constant = - let coeff_constant = - app coq_t_int [| Z.mk constant |] in - let mk_coeff {c=c; v=v} t = - let coef = - app coq_t_mult - [| reified_of_formula env (unintern_omega env v); - app coq_t_int [| Z.mk c |] |] in - app coq_t_plus [|coef; t |] in - List.fold_right mk_coeff body coeff_constant - -let reified_of_omega env body c = - try reified_of_omega env body c - with reraise -> display_eq display_omega_var (body,c); raise reraise +let reified_of_eq env (l,r) = + app coq_p_eq [| reified_of_formula env l; reified_of_formula env r |] (* \section{Opérations sur les équations} Ces fonctions préparent les traces utilisées par la tactique réfléchie @@ -415,19 +373,18 @@ pour faire des opérations de normalisation sur les équations. *) (* Extraction des variables d'une équation. *) (* Chaque fonction retourne une liste triée sans redondance *) -let (@@) = List.merge_uniq compare +let (@@) = IntSet.union let rec vars_of_formula = function - | Oint _ -> [] + | Oint _ -> IntSet.empty | Oplus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) | Omult (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) | Ominus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) | Oopp e -> vars_of_formula e - | Oatom i -> [i] - | Oufo _ -> [] + | Oatom i -> IntSet.singleton i let rec vars_of_equations = function - | [] -> [] + | [] -> IntSet.empty | e::l -> (vars_of_formula e.e_left) @@ (vars_of_formula e.e_right) @@ @@ -439,247 +396,101 @@ let rec vars_of_prop = function | Por(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) | Pand(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) | Pimp(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) - | Pprop _ | Ptrue | Pfalse -> [] - -(* \subsection{Multiplication par un scalaire} *) - -let rec scalar n = function - Oplus(t1,t2) -> - let tac1,t1' = scalar n t1 and - tac2,t2' = scalar n t2 in - do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], - Oplus(t1',t2') - | Oopp t -> - do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(Bigint.neg n)) - | Omult(t1,Oint x) -> - do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x)) - | Omult(t1,t2) -> - CErrors.error "Omega: Can't solve a goal with non-linear products" - | (Oatom _ as t) -> do_list [], Omult(t,Oint n) - | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i) - | (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n)) - | Ominus _ -> failwith "scalar minus" - -(* \subsection{Propagation de l'inversion} *) - -let rec negate = function - Oplus(t1,t2) -> - let tac1,t1' = negate t1 and - tac2,t2' = negate t2 in - do_list [Lazy.force coq_c_opp_plus ; (do_both tac1 tac2)], - Oplus(t1',t2') - | Oopp t -> - do_list [Lazy.force coq_c_opp_opp], t - | Omult(t1,Oint x) -> - do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x)) - | Omult(t1,t2) -> - CErrors.error "Omega: Can't solve a goal with non-linear products" - | (Oatom _ as t) -> - do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone)) - | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i) - | Oufo c -> do_list [], Oufo (Oopp c) - | Ominus _ -> failwith "negate minus" - -let norm l = (List.length l) - -(* \subsection{Mélange (fusion) de deux équations} *) -(* \subsubsection{Version avec coefficients} *) -let shuffle_path k1 e1 k2 e2 = - let rec loop = function - (({c=c1;v=v1}::l1) as l1'), - (({c=c2;v=v2}::l2) as l2') -> - if Int.equal v1 v2 then - if Bigint.equal (k1 * c1 + k2 * c2) zero then ( - Lazy.force coq_f_cancel :: loop (l1,l2)) - else ( - Lazy.force coq_f_equal :: loop (l1,l2) ) - else if v1 > v2 then ( - Lazy.force coq_f_left :: loop(l1,l2')) - else ( - Lazy.force coq_f_right :: loop(l1',l2)) - | ({c=c1;v=v1}::l1), [] -> - Lazy.force coq_f_left :: loop(l1,[]) - | [],({c=c2;v=v2}::l2) -> - Lazy.force coq_f_right :: loop([],l2) - | [],[] -> flush stdout; [] in - mk_shuffle_list (loop (e1,e2)) - -(* \subsubsection{Version sans coefficients} *) -let rec shuffle env (t1,t2) = - match t1,t2 with - Oplus(l1,r1), Oplus(l2,r2) -> - if weight env l1 > weight env l2 then - let l_action,t' = shuffle env (r1,t2) in - do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action], Oplus(l1,t') - else - let l_action,t' = shuffle env (t1,r2) in - do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') - | Oplus(l1,r1), t2 -> - if weight env l1 > weight env t2 then - let (l_action,t') = shuffle env (r1,t2) in - do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action],Oplus(l1, t') - else do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) - | t1,Oplus(l2,r2) -> - if weight env l2 > weight env t1 then - let (l_action,t') = shuffle env (t1,r2) in - do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') - else do_list [],Oplus(t1,t2) - | Oint t1,Oint t2 -> - do_list [Lazy.force coq_c_reduce], Oint(t1+t2) - | t1,t2 -> - if weight env t1 < weight env t2 then - do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) - else do_list [],Oplus(t1,t2) - -(* \subsection{Fusion avec réduction} *) - -let shrink_pair f1 f2 = - begin match f1,f2 with - Oatom v,Oatom _ -> - Lazy.force coq_c_red1, Omult(Oatom v,Oint two) - | Oatom v, Omult(_,c2) -> - Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint one)) - | Omult (v1,c1),Oatom v -> - Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint one)) - | Omult (Oatom v,c1),Omult (v2,c2) -> - Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2)) - | t1,t2 -> - oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); - flush Pervasives.stdout; CErrors.error "shrink.1" - end - -(* \subsection{Calcul d'une sous formule constante} *) - -let reduce_factor = function - Oatom v -> - let r = Omult(Oatom v,Oint one) in - [Lazy.force coq_c_red0],r - | Omult(Oatom v,Oint n) as f -> [],f - | Omult(Oatom v,c) -> - let rec compute = function - Oint n -> n - | Oplus(t1,t2) -> compute t1 + compute t2 - | _ -> CErrors.error "condense.1" in - [Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c)) - | t -> CErrors.error "reduce_factor.1" - -(* \subsection{Réordonnancement} *) - -let rec condense env = function - Oplus(f1,(Oplus(f2,r) as t)) -> - if Int.equal (weight env f1) (weight env f2) then begin - let shrink_tac,t = shrink_pair f1 f2 in - let assoc_tac = Lazy.force coq_c_plus_assoc_l in - let tac_list,t' = condense env (Oplus(t,r)) in - assoc_tac :: do_left (do_list [shrink_tac]) :: tac_list, t' - end else begin - let tac,f = reduce_factor f1 in - let tac',t' = condense env t in - [do_both (do_list tac) (do_list tac')], Oplus(f,t') - end - | Oplus(f1,Oint n) -> - let tac,f1' = reduce_factor f1 in - [do_left (do_list tac)],Oplus(f1',Oint n) - | Oplus(f1,f2) -> - if Int.equal (weight env f1) (weight env f2) then begin - let tac_shrink,t = shrink_pair f1 f2 in - let tac,t' = condense env t in - tac_shrink :: tac,t' - end else begin - let tac,f = reduce_factor f1 in - let tac',t' = condense env f2 in - [do_both (do_list tac) (do_list tac')],Oplus(f,t') - end - | (Oint _ as t)-> [],t - | t -> - let tac,t' = reduce_factor t in - let final = Oplus(t',Oint zero) in - tac @ [Lazy.force coq_c_red6], final - -(* \subsection{Elimination des zéros} *) - -let rec clear_zero = function - Oplus(Omult(Oatom v,Oint n),r) when Bigint.equal n zero -> - let tac',t = clear_zero r in - Lazy.force coq_c_red5 :: tac',t - | Oplus(f,r) -> - let tac,t = clear_zero r in - (if List.is_empty tac then [] else [do_right (do_list tac)]),Oplus(f,t) - | t -> [],t;; - -(* \subsection{Transformation des hypothèses} *) - -let rec reduce env = function - Oplus(t1,t2) -> - let t1', trace1 = reduce env t1 in - let t2', trace2 = reduce env t2 in - let trace3,t' = shuffle env (t1',t2') in - t', do_list [do_both trace1 trace2; trace3] - | Ominus(t1,t2) -> - let t,trace = reduce env (Oplus(t1, Oopp t2)) in - t, do_list [Lazy.force coq_c_minus; trace] - | Omult(t1,t2) as t -> - let t1', trace1 = reduce env t1 in - let t2', trace2 = reduce env t2 in - begin match t1',t2' with - | (_, Oint n) -> - let tac,t' = scalar n t1' in - t', do_list [do_both trace1 trace2; tac] - | (Oint n,_) -> - let tac,t' = scalar n t2' in - t', do_list [do_both trace1 trace2; Lazy.force coq_c_mult_comm; tac] - | _ -> Oufo t, Lazy.force coq_c_nop - end - | Oopp t -> - let t',trace = reduce env t in - let trace',t'' = negate t' in - t'', do_list [do_left trace; trace'] - | (Oint _ | Oatom _ | Oufo _) as t -> t, Lazy.force coq_c_nop - -let normalize_linear_term env t = - let t1,trace1 = reduce env t in - let trace2,t2 = condense env t1 in - let trace3,t3 = clear_zero t2 in - do_list [trace1; do_list trace2; do_list trace3], t3 - -(* Cette fonction reproduit très exactement le comportement de [p_invert] *) + | Pprop _ | Ptrue | Pfalse -> IntSet.empty + +(* Normalized formulas : + + - sorted list of monomials, largest index first, + with non-null coefficients + - a constant coefficient + + /!\ Keep in sync with the corresponding functions in ReflOmegaCore ! +*) + +type nformula = + { coefs : (atom_index * Bigint.bigint) list; + cst : Bigint.bigint } + +let scale n { coefs; cst } = + { coefs = List.map (fun (v,k) -> (v,k*n)) coefs; + cst = cst*n } + +let shuffle nf1 nf2 = + let rec merge l1 l2 = match l1,l2 with + | [],_ -> l2 + | _,[] -> l1 + | (v1,k1)::r1,(v2,k2)::r2 -> + if Int.equal v1 v2 then + let k = k1+k2 in + if Bigint.equal k Bigint.zero then merge r1 r2 + else (v1,k) :: merge r1 r2 + else if v1 > v2 then (v1,k1) :: merge r1 l2 + else (v2,k2) :: merge l1 r2 + in + { coefs = merge nf1.coefs nf2.coefs; + cst = nf1.cst + nf2.cst } + +let rec normalize = function + | Oplus(t1,t2) -> shuffle (normalize t1) (normalize t2) + | Ominus(t1,t2) -> normalize (Oplus (t1, Oopp(t2))) + | Oopp(t) -> scale negone (normalize t) + | Omult(t,Oint n) | Omult (Oint n, t) -> + if Bigint.equal n Bigint.zero then { coefs = []; cst = zero } + else scale n (normalize t) + | Omult _ -> assert false (* invariant on Omult *) + | Oint n -> { coefs = []; cst = n } + | Oatom v -> { coefs = [v,Bigint.one]; cst=Bigint.zero} + +(* From normalized formulas to omega representations *) + +let omega_of_nformula env kind nf = + { id = new_omega_eq (); + kind; + constant=nf.cst; + body = List.map (fun (v,c) -> { v; c }) nf.coefs } + + let negate_oper = function Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq -let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = - let mk_step t1 t2 f kind = - let t = f t1 t2 in - let trace, oterm = normalize_linear_term env t in - let equa = omega_of_oformula env kind oterm in +let normalize_equation env (negated,depends,origin,path) oper t1 t2 = + let mk_step t kind = + let equa = omega_of_nformula env kind (normalize t) in { e_comp = oper; e_left = t1; e_right = t2; e_negated = negated; e_depends = depends; e_origin = { o_hyp = origin; o_path = List.rev path }; - e_trace = trace; e_omega = equa } in + e_omega = equa } + in try match (if negated then (negate_oper oper) else oper) with - | Eq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) EQUA - | Neq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) DISE - | Leq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o2,Oopp o1)) INEQ - | Geq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) INEQ - | Lt -> - mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint negone),Oopp o1)) - INEQ - | Gt -> - mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2)) - INEQ + | Eq -> mk_step (Oplus (t1,Oopp t2)) EQUA + | Neq -> mk_step (Oplus (t1,Oopp t2)) DISE + | Leq -> mk_step (Oplus (t2,Oopp t1)) INEQ + | Geq -> mk_step (Oplus (t1,Oopp t2)) INEQ + | Lt -> mk_step (Oplus (Oplus(t2,Oint negone),Oopp t1)) INEQ + | Gt -> mk_step (Oplus (Oplus(t1,Oint negone),Oopp t2)) INEQ with e when Logic.catchable_exception e -> raise e (* \section{Compilation des hypothèses} *) +let mkPor i x y = Por (i,x,y) +let mkPand i x y = Pand (i,x,y) +let mkPimp i x y = Pimp (i,x,y) + let rec oformula_of_constr env t = match Z.parse_term t with | Tplus (t1,t2) -> binop env (fun x y -> Oplus(x,y)) t1 t2 | Tminus (t1,t2) -> binop env (fun x y -> Ominus(x,y)) t1 t2 - | Tmult (t1,t2) when Z.is_scalar t1 || Z.is_scalar t2 -> - binop env (fun x y -> Omult(x,y)) t1 t2 + | Tmult (t1,t2) -> + (match Z.get_scalar t1 with + | Some n -> Omult (Oint n,oformula_of_constr env t2) + | None -> + match Z.get_scalar t2 with + | Some n -> Omult (oformula_of_constr env t1, Oint n) + | None -> Oatom (add_reified_atom t env)) | Topp t -> Oopp(oformula_of_constr env t) | Tsucc t -> Oplus(oformula_of_constr env t, Oint one) | Tnum n -> Oint n - | _ -> Oatom (add_reified_atom t env) + | Tother -> Oatom (add_reified_atom t env) and binop env c t1 t2 = let t1' = oformula_of_constr env t1 in @@ -692,7 +503,7 @@ and binprop env (neg2,depends,origin,path) let depends1 = if add_to_depends then Left i::depends else depends in let depends2 = if add_to_depends then Right i::depends else depends in if add_to_depends then - Hashtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path}; + IntHtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path}; let t1' = oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in let t2' = @@ -704,7 +515,7 @@ and mk_equation env ctxt c connector t1 t2 = let t1' = oformula_of_constr env t1 in let t2' = oformula_of_constr env t2 in (* On ajoute l'equation dans l'environnement. *) - let omega = normalize_equation env ctxt (connector,t1',t2') in + let omega = normalize_equation env ctxt connector t1' t2' in add_equation env omega; Pequa (c,omega) @@ -719,107 +530,83 @@ and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = | Rtrue -> Ptrue | Rfalse -> Pfalse | Rnot t -> - let t' = - oproposition_of_constr - env (not negated, depends, origin,(O_mono::path)) gl t in - Pnot t' - | Ror (t1,t2) -> - binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2 - | Rand (t1,t2) -> - binprop env ctxt negated negated gl - (fun i x y -> Pand(i,x,y)) t1 t2 + let ctxt' = (not negated, depends, origin,(O_mono::path)) in + Pnot (oproposition_of_constr env ctxt' gl t) + | Ror (t1,t2) -> binprop env ctxt (not negated) negated gl mkPor t1 t2 + | Rand (t1,t2) -> binprop env ctxt negated negated gl mkPand t1 t2 | Rimp (t1,t2) -> - binprop env ctxt (not negated) (not negated) gl - (fun i x y -> Pimp(i,x,y)) t1 t2 + binprop env ctxt (not negated) (not negated) gl mkPimp t1 t2 | Riff (t1,t2) -> - binprop env ctxt negated negated gl - (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) + (* No lifting here, since Omega only works on closed propositions. *) + binprop env ctxt negated negated gl mkPand + (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) | _ -> Pprop c (* Destructuration des hypothèses et de la conclusion *) +let display_gl env t_concl t_lhyps = + Printf.printf "REIFED PROBLEM\n\n"; + Printf.printf " CONCL: %a\n" pprint t_concl; + List.iter + (fun (i,t) -> Printf.printf " %s: %a\n" (Id.to_string i) pprint t) + t_lhyps; + print_env_reification env + let reify_gl env gl = let concl = Tacmach.New.pf_concl gl in let concl = EConstr.Unsafe.to_constr concl in + let hyps = Tacmach.New.pf_hyps_types gl in + let hyps = List.map (fun (i,t) -> (i,EConstr.Unsafe.to_constr t)) hyps in let t_concl = - Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in - if !debug then begin - Printf.printf "REIFED PROBLEM\n\n"; - Printf.printf " CONCL: "; pprint stdout t_concl; Printf.printf "\n" - end; - let rec loop = function - (i,t) :: lhyps -> - let t = EConstr.Unsafe.to_constr t in - let t' = oproposition_of_constr env (false,[],i,[]) gl t in - if !debug then begin - Printf.printf " %s: " (Names.Id.to_string i); - pprint stdout t'; - Printf.printf "\n" - end; - (i,t') :: loop lhyps - | [] -> - if !debug then print_env_reification env; - [] in - let t_lhyps = loop (Tacmach.New.pf_hyps_types gl) in - (id_concl,t_concl) :: t_lhyps - -let rec destructurate_pos_hyp orig list_equations list_depends = function - | Pequa (_,e) -> [e :: list_equations] - | Ptrue | Pfalse | Pprop _ -> [list_equations] - | Pnot t -> destructurate_neg_hyp orig list_equations list_depends t - | Por (i,t1,t2) -> - let s1 = - destructurate_pos_hyp orig list_equations (i::list_depends) t1 in - let s2 = - destructurate_pos_hyp orig list_equations (i::list_depends) t2 in + oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl in + let t_lhyps = + List.map + (fun (i,t) -> i,oproposition_of_constr env (false,[],i,[]) gl t) + hyps + in + let () = if !debug then display_gl env t_concl t_lhyps in + t_concl, t_lhyps + +let rec destruct_pos_hyp eqns = function + | Pequa (_,e) -> [e :: eqns] + | Ptrue | Pfalse | Pprop _ -> [eqns] + | Pnot t -> destruct_neg_hyp eqns t + | Por (_,t1,t2) -> + let s1 = destruct_pos_hyp eqns t1 in + let s2 = destruct_pos_hyp eqns t2 in s1 @ s2 - | Pand(i,t1,t2) -> - let list_s1 = - destructurate_pos_hyp orig list_equations (list_depends) t1 in - let rec loop = function - le1 :: ll -> destructurate_pos_hyp orig le1 list_depends t2 @ loop ll - | [] -> [] in - loop list_s1 - | Pimp(i,t1,t2) -> - let s1 = - destructurate_neg_hyp orig list_equations (i::list_depends) t1 in - let s2 = - destructurate_pos_hyp orig list_equations (i::list_depends) t2 in + | Pand(_,t1,t2) -> + List.map_append + (fun le1 -> destruct_pos_hyp le1 t2) + (destruct_pos_hyp eqns t1) + | Pimp(_,t1,t2) -> + let s1 = destruct_neg_hyp eqns t1 in + let s2 = destruct_pos_hyp eqns t2 in s1 @ s2 -and destructurate_neg_hyp orig list_equations list_depends = function - | Pequa (_,e) -> [e :: list_equations] - | Ptrue | Pfalse | Pprop _ -> [list_equations] - | Pnot t -> destructurate_pos_hyp orig list_equations list_depends t - | Pand (i,t1,t2) -> - let s1 = - destructurate_neg_hyp orig list_equations (i::list_depends) t1 in - let s2 = - destructurate_neg_hyp orig list_equations (i::list_depends) t2 in +and destruct_neg_hyp eqns = function + | Pequa (_,e) -> [e :: eqns] + | Ptrue | Pfalse | Pprop _ -> [eqns] + | Pnot t -> destruct_pos_hyp eqns t + | Pand (_,t1,t2) -> + let s1 = destruct_neg_hyp eqns t1 in + let s2 = destruct_neg_hyp eqns t2 in s1 @ s2 | Por(_,t1,t2) -> - let list_s1 = - destructurate_neg_hyp orig list_equations list_depends t1 in - let rec loop = function - le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll - | [] -> [] in - loop list_s1 + List.map_append + (fun le1 -> destruct_neg_hyp le1 t2) + (destruct_neg_hyp eqns t1) | Pimp(_,t1,t2) -> - let list_s1 = - destructurate_pos_hyp orig list_equations list_depends t1 in - let rec loop = function - le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll - | [] -> [] in - loop list_s1 - -let destructurate_hyps syst = - let rec loop = function - (i,t) :: l -> - let l_syst1 = destructurate_pos_hyp i [] [] t in - let l_syst2 = loop l in - List.cartesian (@) l_syst1 l_syst2 - | [] -> [[]] in - loop syst + List.map_append + (fun le1 -> destruct_neg_hyp le1 t2) + (destruct_pos_hyp eqns t1) + +let rec destructurate_hyps = function + | [] -> [[]] + | (i,t) :: l -> + let l_syst1 = destruct_pos_hyp [] t in + let l_syst2 = destructurate_hyps l in + List.cartesian (@) l_syst1 l_syst2 (* \subsection{Affichage d'un système d'équation} *) @@ -837,7 +624,7 @@ let display_systems syst_list = (operator_of_eq om_e.kind) in let display_equation oformula_eq = - pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline (); + pprint stdout (Pequa (Lazy.force coq_I,oformula_eq)); print_newline (); display_omega oformula_eq.e_omega; Printf.printf " Depends on:"; List.iter display_depend oformula_eq.e_depends; @@ -846,7 +633,7 @@ let display_systems syst_list = (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M") oformula_eq.e_origin.o_path)); Printf.printf "\n Origin: %s (negated : %s)\n\n" - (Names.Id.to_string oformula_eq.e_origin.o_hyp) + (Id.to_string oformula_eq.e_origin.o_hyp) (if oformula_eq.e_negated then "yes" else "no") in let display_system syst = @@ -858,59 +645,61 @@ let display_systems syst_list = calcul des hypothèses *) let rec hyps_used_in_trace = function + | [] -> IntSet.empty | act :: l -> - begin match act with - | HYP e -> [e.id] @@ (hyps_used_in_trace l) - | SPLIT_INEQ (_,(_,act1),(_,act2)) -> - hyps_used_in_trace act1 @@ hyps_used_in_trace act2 - | _ -> hyps_used_in_trace l - end - | [] -> [] - -(* Extraction des variables déclarées dans une équation. Permet ensuite - de les déclarer dans l'environnement de la procédure réflexive et - éviter les créations de variable au vol *) - -let rec variable_stated_in_trace = function - | act :: l -> - begin match act with - | STATE action -> - (*i nlle_equa: afine, def: afine, eq_orig: afine, i*) - (*i coef: int, var:int i*) - action :: variable_stated_in_trace l - | SPLIT_INEQ (_,(_,act1),(_,act2)) -> - variable_stated_in_trace act1 @ variable_stated_in_trace act2 - | _ -> variable_stated_in_trace l - end - | [] -> [] -;; - -let add_stated_equations env tree = - (* Il faut trier les variables par ordre d'introduction pour ne pas risquer - de définir dans le mauvais ordre *) - let stated_equations = - let cmpvar x y = Pervasives.(-) x.st_var y.st_var in - let rec loop = function - | Tree(_,t1,t2) -> List.merge cmpvar (loop t1) (loop t2) - | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace) - in loop tree - in - let add_env st = - (* On retransforme la définition de v en formule reifiée *) - let v_def = oformula_of_omega env st.st_def in - (* Notez que si l'ordre de création des variables n'est pas respecté, - * ca va planter *) + match act with + | HYP e -> IntSet.add e.id (hyps_used_in_trace l) + | SPLIT_INEQ (_,(_,act1),(_,act2)) -> + hyps_used_in_trace act1 @@ hyps_used_in_trace act2 + | _ -> hyps_used_in_trace l + +(** Retreive variables declared as extra equations during resolution + and declare them into the environment. + We should consider these variables in their introduction order, + otherwise really bad things will happen. *) + +let state_cmp x y = Int.compare x.st_var y.st_var + +module StateSet = + Set.Make (struct type t = state_action let compare = state_cmp end) + +let rec stated_in_trace = function + | [] -> StateSet.empty + | [SPLIT_INEQ (_,(_,t1),(_,t2))] -> + StateSet.union (stated_in_trace t1) (stated_in_trace t2) + | STATE action :: l -> StateSet.add action (stated_in_trace l) + | _ :: l -> stated_in_trace l + +let rec stated_in_tree = function + | Tree(_,t1,t2) -> StateSet.union (stated_in_tree t1) (stated_in_tree t2) + | Leaf s -> stated_in_trace s.s_trace + +let digest_stated_equations env tree = + let do_equation st (vars,gens,eqns,ids) = + (** We turn the definition of [v] + - into a reified formula : *) + let v_def = oformula_of_omega st.st_def in + (** - into a concrete Coq formula + (this uses only older vars already in env) : *) let coq_v = coq_of_formula env v_def in - let v = add_reified_atom coq_v env in - (* Le terme qu'il va falloir introduire *) - let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in - (* sa représentation sous forme d'équation mais non réifié car on n'a pas - * l'environnement pour le faire correctement *) - let term_to_reify = (v_def,Oatom v) in - (* enregistre le lien entre la variable omega et la variable Coq *) - intern_omega_force env (Oatom v) st.st_var; - (v, term_to_generalize,term_to_reify,st.st_def.id) in - List.map add_env stated_equations + (** We then update the environment *) + set_reified_atom st.st_var coq_v env; + (** The term we'll introduce *) + let term_to_generalize = + EConstr.of_constr (app coq_refl_equal [|Lazy.force Z.typ; coq_v|]) + in + (** Its representation as equation (but not reified yet, + we lack the proper env to do that). *) + let term_to_reify = (v_def,Oatom st.st_var) in + (st.st_var::vars, + term_to_generalize::gens, + term_to_reify::eqns, + CCEqua st.st_def.id :: ids) + in + let (vars,gens,eqns,ids) = + StateSet.fold do_equation (stated_in_tree tree) ([],[],[],[]) + in + (List.rev vars, List.rev gens, List.rev eqns, List.rev ids) (* Calcule la liste des éclatements à réaliser sur les hypothèses nécessaires pour extraire une liste d'équations donnée *) @@ -921,22 +710,22 @@ let add_stated_equations env tree = arg, then second arg), unless you know what you're doing. *) let rec get_eclatement env = function - i :: r -> - let l = try (get_equation env i).e_depends with Not_found -> [] in - List.union Pervasives.(=) (List.rev l) (get_eclatement env r) | [] -> [] + | i :: r -> + let l = try (get_equation env i).e_depends with Not_found -> [] in + List.union dir_eq (List.rev l) (get_eclatement env r) let select_smaller l = - let comp (_,x) (_,y) = Pervasives.(-) (List.length x) (List.length y) in + let comp (_,x) (_,y) = Int.compare (List.length x) (List.length y) in try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller" let filter_compatible_systems required systems = let rec select = function - (x::l) -> - if List.mem x required then select l - else if List.mem (barre x) required then raise Exit - else x :: select l | [] -> [] + | (x::l) -> + if List.mem_f dir_eq x required then select l + else if List.mem_f dir_eq (barre x) required then raise Exit + else x :: select l in List.map_filter (function (sol, splits) -> @@ -944,54 +733,51 @@ let filter_compatible_systems required systems = systems let rec equas_of_solution_tree = function - Tree(_,t1,t2) -> (equas_of_solution_tree t1)@@(equas_of_solution_tree t2) + | Tree(_,t1,t2) -> + (equas_of_solution_tree t1)@@(equas_of_solution_tree t2) | Leaf s -> s.s_equa_deps -(* [really_useful_prop] pushes useless props in a new Pprop variable *) -(* Things get shorter, but may also get wrong, since a Prop is considered - to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance - Pfalse is decidable. So should not be used on conclusion (??) *) - -let really_useful_prop l_equa c = - let rec real_of = function - Pequa(t,_) -> t - | Ptrue -> app coq_True [||] - | Pfalse -> app coq_False [||] - | Pnot t1 -> app coq_not [|real_of t1|] - | Por(_,t1,t2) -> app coq_or [|real_of t1; real_of t2|] - | Pand(_,t1,t2) -> app coq_and [|real_of t1; real_of t2|] - (* Attention : implications sur le lifting des variables à comprendre ! *) - | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2) - | Pprop t -> t in - let rec loop c = - match c with - Pequa(_,e) -> - if List.mem e.e_omega.id l_equa then Some c else None - | Ptrue -> None - | Pfalse -> None - | Pnot t1 -> - begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end - | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2 - | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2 - | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2 - | Pprop t -> None - and binop f t1 t2 = - begin match loop t1, loop t2 with - None, None -> None - | Some t1',Some t2' -> Some (f(t1',t2')) - | Some t1',None -> Some (f(t1',Pprop (real_of t2))) - | None,Some t2' -> Some (f(Pprop (real_of t1),t2')) - end in - match loop c with - None -> Pprop (real_of c) - | Some t -> t +(** [maximize_prop] pushes useless props in a new Pprop atom. + The reified formulas get shorter, but be careful with decidabilities. + For instance, anything that contains a Pprop is considered to be + undecidable in [ReflOmegaCore], whereas a Pfalse for instance at + the same spot will lead to a decidable formula. + In particular, do not use this function on the conclusion. + Even in hypotheses, we could probably build pathological examples + that romega won't handle correctly, but they should be pretty rare. +*) + +let maximize_prop equas c = + let rec loop c = match c with + | Pequa(t,e) -> if IntSet.mem e.e_omega.id equas then c else Pprop t + | Pnot t -> + (match loop t with + | Pprop p -> Pprop (app coq_not [|p|]) + | t' -> Pnot t') + | Por(i,t1,t2) -> + (match loop t1, loop t2 with + | Pprop p1, Pprop p2 -> Pprop (app coq_or [|p1;p2|]) + | t1', t2' -> Por(i,t1',t2')) + | Pand(i,t1,t2) -> + (match loop t1, loop t2 with + | Pprop p1, Pprop p2 -> Pprop (app coq_and [|p1;p2|]) + | t1', t2' -> Pand(i,t1',t2')) + | Pimp(i,t1,t2) -> + (match loop t1, loop t2 with + | Pprop p1, Pprop p2 -> Pprop (Term.mkArrow p1 p2) (* no lift (closed) *) + | t1', t2' -> Pimp(i,t1',t2')) + | Ptrue -> Pprop (app coq_True [||]) + | Pfalse -> Pprop (app coq_False [||]) + | Pprop _ -> c + in loop c let rec display_solution_tree ch = function Leaf t -> output_string ch (Printf.sprintf "%d[%s]" - t.s_index - (String.concat " " (List.map string_of_int t.s_equa_deps))) + t.s_index + (String.concat " " (List.map string_of_int + (IntSet.elements t.s_equa_deps)))) | Tree(i,t1,t2) -> Printf.fprintf ch "S%d(%a,%a)" i display_solution_tree t1 display_solution_tree t2 @@ -1023,7 +809,7 @@ let find_path {o_hyp=id;o_path=p} env = | (x1::l1,x2::l2) when occ_step_eq x1 x2 -> loop_path (l1,l2) | _ -> None in let rec loop_id i = function - CCHyp{o_hyp=id';o_path=p'} :: l when Names.Id.equal id id' -> + CCHyp{o_hyp=id';o_path=p'} :: l when Id.equal id id' -> begin match loop_path (p',p) with Some r -> i,r | None -> loop_id (succ i) l @@ -1034,110 +820,78 @@ let find_path {o_hyp=id;o_path=p} env = let mk_direction_list l = let trans = function - O_left -> coq_d_left | O_right -> coq_d_right | O_mono -> coq_d_mono in - mk_list (Lazy.force coq_direction) (List.map (fun d-> Lazy.force(trans d)) l) + | O_left -> Some (Lazy.force coq_d_left) + | O_right -> Some (Lazy.force coq_d_right) + | O_mono -> None (* No more [D_mono] constructor now *) + in + mk_list (Lazy.force coq_direction) (List.map_filter trans l) (* \section{Rejouer l'historique} *) -let get_hyp env_hyp i = - try List.index0 Pervasives.(=) (CCEqua i) env_hyp - with Not_found -> failwith (Printf.sprintf "get_hyp %d" i) - -let replay_history env env_hyp = - let rec loop env_hyp t = - match t with - | CONTRADICTION (e1,e2) :: l -> - let trace = mk_nat (List.length e1.body) in - mkApp (Lazy.force coq_s_contradiction, - [| trace ; mk_nat (get_hyp env_hyp e1.id); - mk_nat (get_hyp env_hyp e2.id) |]) - | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> - mkApp (Lazy.force coq_s_div_approx, - [| Z.mk k; Z.mk d; - reified_of_omega env e2.body e2.constant; - mk_nat (List.length e2.body); - loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |]) - | NOT_EXACT_DIVIDE (e1,k) :: l -> - let e2_constant = floor_div e1.constant k in - let d = e1.constant - e2_constant * k in - let e2_body = map_eq_linear (fun c -> c / k) e1.body in - mkApp (Lazy.force coq_s_not_exact_divide, - [|Z.mk k; Z.mk d; - reified_of_omega env e2_body e2_constant; - mk_nat (List.length e2_body); - mk_nat (get_hyp env_hyp e1.id)|]) - | EXACT_DIVIDE (e1,k) :: l -> - let e2_body = - map_eq_linear (fun c -> c / k) e1.body in - let e2_constant = floor_div e1.constant k in - mkApp (Lazy.force coq_s_exact_divide, - [|Z.mk k; - reified_of_omega env e2_body e2_constant; - mk_nat (List.length e2_body); - loop env_hyp l; mk_nat (get_hyp env_hyp e1.id)|]) - | (MERGE_EQ(e3,e1,e2)) :: l -> - let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2 in - mkApp (Lazy.force coq_s_merge_eq, - [| mk_nat (List.length e1.body); - mk_nat n1; mk_nat n2; - loop (CCEqua e3:: env_hyp) l |]) - | SUM(e3,(k1,e1),(k2,e2)) :: l -> - let n1 = get_hyp env_hyp e1.id - and n2 = get_hyp env_hyp e2.id in - let trace = shuffle_path k1 e1.body k2 e2.body in - mkApp (Lazy.force coq_s_sum, - [| Z.mk k1; mk_nat n1; Z.mk k2; - mk_nat n2; trace; (loop (CCEqua e3 :: env_hyp) l) |]) - | CONSTANT_NOT_NUL(e,k) :: l -> - mkApp (Lazy.force coq_s_constant_not_nul, - [| mk_nat (get_hyp env_hyp e) |]) - | CONSTANT_NEG(e,k) :: l -> - mkApp (Lazy.force coq_s_constant_neg, - [| mk_nat (get_hyp env_hyp e) |]) - | STATE {st_new_eq=new_eq; st_def =def; - st_orig=orig; st_coef=m; - st_var=sigma } :: l -> - let n1 = get_hyp env_hyp orig.id - and n2 = get_hyp env_hyp def.id in - let v = unintern_omega env sigma in - let o_def = oformula_of_omega env def in - let o_orig = oformula_of_omega env orig in - let body = - Oplus (o_orig,Omult (Oplus (Oopp v,o_def), Oint m)) in - let trace,_ = normalize_linear_term env body in - mkApp (Lazy.force coq_s_state, - [| Z.mk m; trace; mk_nat n1; mk_nat n2; - loop (CCEqua new_eq.id :: env_hyp) l |]) - | HYP _ :: l -> loop env_hyp l - | CONSTANT_NUL e :: l -> - mkApp (Lazy.force coq_s_constant_nul, - [| mk_nat (get_hyp env_hyp e) |]) - | NEGATE_CONTRADICT(e1,e2,true) :: l -> - mkApp (Lazy.force coq_s_negate_contradict, - [| mk_nat (get_hyp env_hyp e1.id); - mk_nat (get_hyp env_hyp e2.id) |]) - | NEGATE_CONTRADICT(e1,e2,false) :: l -> - mkApp (Lazy.force coq_s_negate_contradict_inv, - [| mk_nat (List.length e2.body); - mk_nat (get_hyp env_hyp e1.id); - mk_nat (get_hyp env_hyp e2.id) |]) - | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l -> - let i = get_hyp env_hyp e.id in - let r1 = loop (CCEqua e1 :: env_hyp) l1 in - let r2 = loop (CCEqua e2 :: env_hyp) l2 in - mkApp (Lazy.force coq_s_split_ineq, - [| mk_nat (List.length e.body); mk_nat i; r1 ; r2 |]) - | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> - loop env_hyp l - | (WEAKEN _ ) :: l -> failwith "not_treated" - | [] -> failwith "no contradiction" - in loop env_hyp +let hyp_idx env_hyp i = + let rec loop count = function + | [] -> failwith (Printf.sprintf "get_hyp %d" i) + | CCEqua i' :: _ when Int.equal i i' -> mk_nat count + | _ :: l -> loop (succ count) l + in loop 0 env_hyp + + +(* We now expand NEGATE_CONTRADICT and CONTRADICTION into + a O_SUM followed by a O_BAD_CONSTANT *) + +let sum_bad inv i1 i2 = + mkApp (Lazy.force coq_s_sum, + [| Z.mk Bigint.one; i1; + Z.mk (if inv then negone else Bigint.one); i2; + mkApp (Lazy.force coq_s_bad_constant, [| mk_nat 0 |])|]) + +let rec reify_trace env env_hyp = function + | CONSTANT_NOT_NUL(e,_) :: [] + | CONSTANT_NEG(e,_) :: [] + | CONSTANT_NUL e :: [] -> + mkApp (Lazy.force coq_s_bad_constant,[| hyp_idx env_hyp e |]) + | NEGATE_CONTRADICT(e1,e2,direct) :: [] -> + sum_bad direct (hyp_idx env_hyp e1.id) (hyp_idx env_hyp e2.id) + | CONTRADICTION (e1,e2) :: [] -> + sum_bad false (hyp_idx env_hyp e1.id) (hyp_idx env_hyp e2.id) + | NOT_EXACT_DIVIDE (e1,k) :: [] -> + mkApp (Lazy.force coq_s_not_exact_divide, + [| hyp_idx env_hyp e1.id; Z.mk k |]) + | DIVIDE_AND_APPROX (e1,_,k,_) :: l + | EXACT_DIVIDE (e1,k) :: l -> + mkApp (Lazy.force coq_s_divide, + [| hyp_idx env_hyp e1.id; Z.mk k; + reify_trace env env_hyp l |]) + | MERGE_EQ(e3,e1,e2) :: l -> + mkApp (Lazy.force coq_s_merge_eq, + [| hyp_idx env_hyp e1.id; hyp_idx env_hyp e2; + reify_trace env (CCEqua e3:: env_hyp) l |]) + | SUM(e3,(k1,e1),(k2,e2)) :: l -> + mkApp (Lazy.force coq_s_sum, + [| Z.mk k1; hyp_idx env_hyp e1.id; + Z.mk k2; hyp_idx env_hyp e2.id; + reify_trace env (CCEqua e3 :: env_hyp) l |]) + | STATE {st_new_eq; st_def; st_orig; st_coef } :: l -> + (* we now produce a [O_SUM] here *) + mkApp (Lazy.force coq_s_sum, + [| Z.mk Bigint.one; hyp_idx env_hyp st_orig.id; + Z.mk st_coef; hyp_idx env_hyp st_def.id; + reify_trace env (CCEqua st_new_eq.id :: env_hyp) l |]) + | HYP _ :: l -> reify_trace env env_hyp l + | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: _ -> + let r1 = reify_trace env (CCEqua e1 :: env_hyp) l1 in + let r2 = reify_trace env (CCEqua e2 :: env_hyp) l2 in + mkApp (Lazy.force coq_s_split_ineq, + [| hyp_idx env_hyp e.id; r1 ; r2 |]) + | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> reify_trace env env_hyp l + | WEAKEN _ :: l -> failwith "not_treated" + | _ -> failwith "bad history" let rec decompose_tree env ctxt = function Tree(i,left,right) -> let org = - try Hashtbl.find env.constructors i + try IntHtbl.find env.constructors i with Not_found -> failwith (Printf.sprintf "Cannot find constructor %d" i) in let (index,path) = find_path org ctxt in @@ -1149,22 +903,41 @@ let rec decompose_tree env ctxt = function decompose_tree env (left_hyp::ctxt) left; decompose_tree env (right_hyp::ctxt) right |] | Leaf s -> - decompose_tree_hyps s.s_trace env ctxt s.s_equa_deps + decompose_tree_hyps s.s_trace env ctxt (IntSet.elements s.s_equa_deps) and decompose_tree_hyps trace env ctxt = function - [] -> app coq_e_solve [| replay_history env ctxt trace |] + [] -> app coq_e_solve [| reify_trace env ctxt trace |] | (i::l) -> let equation = - try Hashtbl.find env.equations i + try IntHtbl.find env.equations i with Not_found -> failwith (Printf.sprintf "Cannot find equation %d" i) in let (index,path) = find_path equation.e_origin ctxt in - let full_path = if equation.e_negated then path @ [O_mono] else path in let cont = decompose_tree_hyps trace env (CCEqua equation.e_omega.id :: ctxt) l in - app coq_e_extract [|mk_nat index; - mk_direction_list full_path; - cont |] + app coq_e_extract [|mk_nat index; mk_direction_list path; cont |] + +let solve_system env index list_eq = + let system = List.map (fun eq -> eq.e_omega) list_eq in + let trace = + OmegaSolver.simplify_strong + (new_omega_eq,new_omega_var,display_omega_var) + system + in + (* Hypotheses used for this solution *) + let vars = hyps_used_in_trace trace in + let splits = get_eclatement env (IntSet.elements vars) in + if !debug then + begin + Printf.printf "SYSTEME %d\n" index; + display_action display_omega_var trace; + print_string "\n Depend :"; + IntSet.iter (fun i -> Printf.printf " %d" i) vars; + print_string "\n Split points :"; + List.iter display_depend splits; + Printf.printf "\n------------------------------------\n" + end; + {s_index = index; s_trace = trace; s_equa_deps = vars}, splits (* \section{La fonction principale} *) (* Cette fonction construit la @@ -1174,143 +947,100 @@ l'extraction d'un ensemble minimal de solutions permettant la résolution globale du système et enfin construit la trace qui permet de faire rejouer cette solution par la tactique réflexive. *) -let resolution env full_reified_goal systems_list = - let num = ref 0 in - let solve_system list_eq = - let index = !num in - let system = List.map (fun eq -> eq.e_omega) list_eq in - let trace = - simplify_strong - (new_omega_eq,new_omega_var,display_omega_var) - system in - (* calcule les hypotheses utilisées pour la solution *) - let vars = hyps_used_in_trace trace in - let splits = get_eclatement env vars in - if !debug then begin - Printf.printf "SYSTEME %d\n" index; - display_action display_omega_var trace; - print_string "\n Depend :"; - List.iter (fun i -> Printf.printf " %d" i) vars; - print_string "\n Split points :"; - List.iter display_depend splits; - Printf.printf "\n------------------------------------\n" - end; - incr num; - {s_index = index; s_trace = trace; s_equa_deps = vars}, splits in +let resolution unsafe env (reified_concl,reified_hyps) systems_list = if !debug then Printf.printf "\n====================================\n"; - let all_solutions = List.map solve_system systems_list in + let all_solutions = List.mapi (solve_system env) systems_list in let solution_tree = solve_with_constraints all_solutions [] in if !debug then begin display_solution_tree stdout solution_tree; print_newline() end; - (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *) - let useful_equa_id = equas_of_solution_tree solution_tree in - (* recupere explicitement ces equations *) - let equations = List.map (get_equation env) useful_equa_id in - let l_hyps' = List.uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in - let l_hyps = id_concl :: List.remove Names.Id.equal id_concl l_hyps' in - let useful_hyps = - List.map - (fun id -> List.assoc_f Names.Id.equal id full_reified_goal) l_hyps + (** Collect all hypotheses used in the solution tree *) + let useful_equa_ids = equas_of_solution_tree solution_tree in + let equations = List.map (get_equation env) (IntSet.elements useful_equa_ids) in - let useful_vars = - let really_useful_vars = vars_of_equations equations in - let concl_vars = - vars_of_prop (List.assoc_f Names.Id.equal id_concl full_reified_goal) - in - really_useful_vars @@ concl_vars + let hyps_of_eqns = + List.fold_left (fun s e -> Id.Set.add e.e_origin.o_hyp s) Id.Set.empty in + let hyps = hyps_of_eqns equations in + let useful_hypnames = Id.Set.elements (Id.Set.remove id_concl hyps) in + let useful_hyptypes = + List.map (fun id -> List.assoc_f Id.equal id reified_hyps) useful_hypnames + in + let useful_vars = vars_of_equations equations @@ vars_of_prop reified_concl + in + + (** Parts coming from equations introduced by omega: *) + let stated_vars, l_generalize_arg, to_reify_stated, hyp_stated_vars = + digest_stated_equations env solution_tree in - (* variables a introduire *) - let to_introduce = add_stated_equations env solution_tree in - let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in - let l_generalize_arg = List.map (fun (_,t,_,_) -> EConstr.of_constr t) to_introduce in - let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in - (* L'environnement de base se construit en deux morceaux : - - les variables des équations utiles (et de la conclusion) - - les nouvelles variables declarées durant les preuves *) - let all_vars_env = useful_vars @ stated_vars in - let basic_env = + (** The final variables are either coming from: + - useful hypotheses (and conclusion) + - equations introduced during resolution *) + let all_vars_env = (IntSet.elements useful_vars) @ stated_vars + in + (** We prepare the renumbering from all variables to useful ones. + Since [all_var_env] is sorted, this renumbering will preserve + order: this way, the equations in ReflOmegaCore will have + the same normal forms as here. *) + let reduced_term_env = let rec loop i = function - var :: l -> - let t = get_reified_atom env var in - Hashtbl.add env.real_indices var i; t :: loop (succ i) l - | [] -> [] in - loop 0 all_vars_env in - let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in - (* On peut maintenant généraliser le but : env est a jour *) - let l_reified_stated = - List.map (fun (_,_,(l,r),_) -> - app coq_p_eq [| reified_of_formula env l; - reified_of_formula env r |]) - to_introduce in - let reified_concl = - match useful_hyps with - (Pnot p) :: _ -> reified_of_proposition env p - | _ -> reified_of_proposition env Pfalse in + | [] -> [] + | var :: l -> + let t = get_reified_atom env var in + IntHtbl.add env.real_indices var i; t :: loop (succ i) l + in + mk_list (Lazy.force Z.typ) (loop 0 all_vars_env) + in + (** The environment [env] (and especially [env.real_indices]) is now + ready for the coming reifications: *) + let l_reified_stated = List.map (reified_of_eq env) to_reify_stated in + let reified_concl = reified_of_proposition env reified_concl in let l_reified_terms = - (List.map - (fun p -> - reified_of_proposition env (really_useful_prop useful_equa_id p)) - (List.tl useful_hyps)) in + List.map + (fun p -> reified_of_proposition env (maximize_prop useful_equa_ids p)) + useful_hyptypes + in let env_props_reified = mk_plist env.props in let reified_goal = mk_list (Lazy.force coq_proposition) (l_reified_stated @ l_reified_terms) in let reified = app coq_interp_sequent - [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in - let reified = EConstr.of_constr reified in - let normalize_equation e = - let rec loop = function - [] -> app (if e.e_negated then coq_p_invert else coq_p_step) - [| e.e_trace |] - | ((O_left | O_mono) :: l) -> app coq_p_left [| loop l |] - | (O_right :: l) -> app coq_p_right [| loop l |] in - let correct_index = - let i = List.index0 Names.Id.equal e.e_origin.o_hyp l_hyps in - (* PL: it seems that additionally introduced hyps are in the way during - normalization, hence this index shifting... *) - if Int.equal i 0 then 0 else Pervasives.(+) i (List.length to_introduce) - in - app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in - let normalization_trace = - mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in - + [| reified_concl;env_props_reified;reduced_term_env;reified_goal|] + in let initial_context = - List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) (List.tl l_hyps) in + List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) useful_hypnames in let context = CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in let decompose_tactic = decompose_tree env context solution_tree in Tactics.generalize - (l_generalize_arg @ List.map EConstr.mkVar (List.tl l_hyps)) >> - Tactics.change_concl reified >> - Tactics.apply (EConstr.of_constr (app coq_do_omega [|decompose_tactic; normalization_trace|])) >> + (l_generalize_arg @ List.map EConstr.mkVar useful_hypnames) >> + Tactics.change_concl (EConstr.of_constr reified) >> + Tactics.apply (EConstr.of_constr (app coq_do_omega [|decompose_tactic|])) >> show_goal >> - Tactics.normalise_vm_in_concl >> - (*i Alternatives to the previous line: - - Normalisation without VM: - Tactics.normalise_in_concl - - Skip the conversion check and rely directly on the QED: - Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> - i*) + (if unsafe then + (* Trust the produced term. Faster, but might fail later at Qed. + Also handy when debugging, e.g. via a Show Proof after romega. *) + Tactics.convert_concl_no_check + (EConstr.of_constr (Lazy.force coq_True)) Term.VMcast + else + Tactics.normalise_vm_in_concl) >> Tactics.apply (EConstr.of_constr (Lazy.force coq_I)) -let total_reflexive_omega_tactic = +let total_reflexive_omega_tactic unsafe = Proofview.Goal.nf_enter { enter = begin fun gl -> Coqlib.check_required_library ["Coq";"romega";"ROmega"]; rst_omega_eq (); rst_omega_var (); try let env = new_environment () in - let full_reified_goal = reify_gl env gl in + let (concl,hyps) as reified_goal = reify_gl env gl in + (* Register all atom indexes created during reification as omega vars *) + set_omega_maxvar (pred (List.length env.terms)); + let full_reified_goal = (id_concl,Pnot concl) :: hyps in let systems_list = destructurate_hyps full_reified_goal in if !debug then display_systems systems_list; - resolution env full_reified_goal systems_list - with NO_CONTRADICTION -> CErrors.error "ROmega can't solve this system" + resolution unsafe env reified_goal systems_list + with NO_CONTRADICTION -> CErrors.user_err Pp.(str "ROmega can't solve this system") end } - -(*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*) - - diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 1ad4d622b2..4eef1b0a75 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -46,8 +46,7 @@ let reset_info () = let pruning = ref true let opt_pruning= - {optsync=true; - optdepr=false; + {optdepr=false; optname="Rtauto Pruning"; optkey=["Rtauto";"Pruning"]; optread=(fun () -> !pruning); diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 3655df8951..1b07a8ca84 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -22,28 +22,28 @@ let step_count = ref 0 let node_count = ref 0 -let logic_constant = - Coqlib.gen_constant "refl_tauto" ["Init";"Logic"] +let logic_constant s = Universes.constr_of_global @@ + Coqlib.coq_reference "refl_tauto" ["Init";"Logic"] s let li_False = lazy (destInd (logic_constant "False")) -let li_and = lazy (destInd (logic_constant "and")) -let li_or = lazy (destInd (logic_constant "or")) +let li_and = lazy (destInd (logic_constant "and")) +let li_or = lazy (destInd (logic_constant "or")) -let pos_constant = - Coqlib.gen_constant "refl_tauto" ["Numbers";"BinNums"] +let pos_constant s = Universes.constr_of_global @@ + Coqlib.coq_reference "refl_tauto" ["Numbers";"BinNums"] s let l_xI = lazy (pos_constant "xI") let l_xO = lazy (pos_constant "xO") let l_xH = lazy (pos_constant "xH") -let store_constant = - Coqlib.gen_constant "refl_tauto" ["rtauto";"Bintree"] +let store_constant s = Universes.constr_of_global @@ + Coqlib.coq_reference "refl_tauto" ["rtauto";"Bintree"] s let l_empty = lazy (store_constant "empty") let l_push = lazy (store_constant "push") -let constant= - Coqlib.gen_constant "refl_tauto" ["rtauto";"Rtauto"] +let constant s = Universes.constr_of_global @@ + Coqlib.coq_reference "refl_tauto" ["rtauto";"Rtauto"] s let l_Reflect = lazy (constant "Reflect") @@ -236,8 +236,7 @@ open Goptions let verbose = ref false let opt_verbose= - {optsync=true; - optdepr=false; + {optdepr=false; optname="Rtauto Verbose"; optkey=["Rtauto";"Verbose"]; optread=(fun () -> !verbose); @@ -248,8 +247,7 @@ let _ = declare_bool_option opt_verbose let check = ref false let opt_check= - {optsync=true; - optdepr=false; + {optdepr=false; optname="Rtauto Check"; optkey=["Rtauto";"Check"]; optread=(fun () -> !check); diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 6b8ef630a2..38f05978db 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -8,7 +8,6 @@ open Ltac_plugin open Pp -open CErrors open Util open Names open Term @@ -32,6 +31,8 @@ open Misctypes open Newring_ast open Proofview.Notations +let error msg = CErrors.user_err Pp.(str msg) + (****************************************************************************) (* controlled reduction *) @@ -46,7 +47,7 @@ let tag_arg tag_rec map subs i c = let global_head_of_constr sigma c = let f, args = decompose_app sigma c in try fst (Termops.global_of_constr sigma f) - with Not_found -> anomaly (str "global_head_of_constr") + with Not_found -> CErrors.anomaly (str "global_head_of_constr") let global_of_constr_nofail c = try global_of_constr c @@ -82,7 +83,7 @@ let add_map s m = protect_maps := String.Map.add s m !protect_maps let lookup_map map = try String.Map.find map !protect_maps with Not_found -> - user_err ~hdr:"lookup_map" (str"map "++qs map++str"not found") + CErrors.user_err ~hdr:"lookup_map" (str"map "++qs map++str"not found") let protect_red map env sigma c0 = let evars ev = Evarutil.safe_evar_value sigma ev in @@ -127,11 +128,11 @@ let closed_term_ast l = mltac_name = tacname; mltac_index = 0; } in - let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in + let l = List.map (fun gr -> ArgArg(Loc.tag gr)) l in TacFun([Name(Id.of_string"t")], - TacML(Loc.ghost,tacname, - [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None)); - TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)])) + TacML(Loc.tag (tacname, + [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (CAst.make @@ GVar(Id.of_string"t"),None)); + TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)]))) (* let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" *) @@ -160,16 +161,16 @@ let decl_constant na ctx c = (* Calling a global tactic *) let ltac_call tac (args:glob_tactic_arg list) = - TacArg(Loc.ghost,TacCall(Loc.ghost, ArgArg(Loc.ghost, Lazy.force tac),args)) + TacArg(Loc.tag @@ TacCall (Loc.tag (ArgArg(Loc.tag @@ Lazy.force tac),args))) (* Calling a locally bound tactic *) let ltac_lcall tac args = - TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, Id.of_string tac),args)) + TacArg(Loc.tag @@ TacCall (Loc.tag (ArgVar(Loc.tag @@ Id.of_string tac),args))) let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) = let fold arg (i, vars, lfun) = let id = Id.of_string ("x" ^ string_of_int i) in - let x = Reference (ArgVar (Loc.ghost, id)) in + let x = Reference (ArgVar (Loc.tag id)) in (succ i, x :: vars, Id.Map.add id arg lfun) in let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in @@ -204,7 +205,7 @@ let get_res = let exec_tactic env evd n f args = let fold arg (i, vars, lfun) = let id = Id.of_string ("x" ^ string_of_int i) in - let x = Reference (ArgVar (Loc.ghost, id)) in + let x = Reference (ArgVar (Loc.tag id)) in (succ i, x :: vars, Id.Map.add id (Value.of_constr arg) lfun) in let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in @@ -212,7 +213,7 @@ let exec_tactic env evd n f args = (** Build the getter *) let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in - let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in + let get_res = TacML (Loc.tag (get_res, [TacGeneric n])) in let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in (** Evaluate the whole result *) let gl = dummy_goal env evd in @@ -229,7 +230,7 @@ let stdlib_modules = ] let coq_constant c = - lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c)) + lazy (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" stdlib_modules c)) let coq_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c) @@ -274,7 +275,7 @@ let plugin_modules = ] let my_constant c = - lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "Ring" plugin_modules c)) + lazy (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" plugin_modules c)) let my_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c) @@ -283,7 +284,7 @@ let znew_ring_path = let zltac s = lazy(make_kn (MPfile znew_ring_path) DirPath.empty (Label.make s)) -let mk_cst l s = lazy (Coqlib.gen_reference "newring" l s);; +let mk_cst l s = lazy (Coqlib.coq_reference "newring" l s);; let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;; (* Ring theory *) @@ -359,13 +360,13 @@ let find_ring_structure env sigma l = let check c = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then - user_err ~hdr:"ring" + CErrors.user_err ~hdr:"ring" (str"arguments of ring_simplify do not have all the same type") in List.iter check cl'; (try ring_for_carrier (EConstr.to_constr sigma ty) with Not_found -> - user_err ~hdr:"ring" + CErrors.user_err ~hdr:"ring" (str"cannot find a declared ring structure over"++ spc()++str"\""++pr_constr ty++str"\"")) | [] -> assert false @@ -577,8 +578,8 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = | Some (Closed lc) -> closed_term_ast (List.map Smartlocate.global_with_alias lc) | None -> - let t = ArgArg(Loc.ghost,Lazy.force ltac_inv_morph_nothing) in - TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])) + let t = ArgArg(Loc.tag @@ Lazy.force ltac_inv_morph_nothing) in + TacArg(Loc.tag (TacCall(Loc.tag (t,[])))) let make_hyp env evd c = let t = Retyping.get_type_of env !evd c in @@ -599,8 +600,8 @@ let interp_power env evd pow = let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in match pow with | None -> - let t = ArgArg(Loc.ghost, Lazy.force ltac_inv_morph_nothing) in - (TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])), plapp evd coq_None [|carrier|]) + let t = ArgArg(Loc.tag (Lazy.force ltac_inv_morph_nothing)) in + (TacArg(Loc.tag (TacCall(Loc.tag (t,[])))), plapp evd coq_None [|carrier|]) | Some (tac, spec) -> let tac = match tac with @@ -852,13 +853,13 @@ let find_field_structure env sigma l = let check c = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then - user_err ~hdr:"field" + CErrors.user_err ~hdr:"field" (str"arguments of field_simplify do not have all the same type") in List.iter check cl'; (try field_for_carrier (EConstr.to_constr sigma ty) with Not_found -> - user_err ~hdr:"field" + CErrors.user_err ~hdr:"field" (str"cannot find a declared field structure over"++ spc()++str"\""++pr_constr ty++str"\"")) | [] -> assert false diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 72c70750c9..6b752fb4b0 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -48,9 +48,8 @@ open Constrexpr_ops DECLARE PLUGIN "ssrmatching_plugin" -let dummy_loc = Loc.ghost let errorstrm = CErrors.user_err ~hdr:"ssrmatching" -let loc_error loc msg = CErrors.user_err ~loc ~hdr:msg (str msg) +let loc_error loc msg = CErrors.user_err ?loc ~hdr:msg (str msg) let ppnl = Feedback.msg_info (* 0 cost pp function. Active only if env variable SSRDEBUG is set *) @@ -64,8 +63,7 @@ let debug b = if b then pp_ref := ssr_pp else pp_ref := fun _ -> () let _ = Goptions.declare_bool_option - { Goptions.optsync = false; - Goptions.optname = "ssrmatching debugging"; + { Goptions.optname = "ssrmatching debugging"; Goptions.optkey = ["Debug";"SsrMatching"]; Goptions.optdepr = false; Goptions.optread = (fun _ -> !pp_ref == ssr_pp); @@ -133,20 +131,20 @@ let add_genarg tag pr = (** Constructors for cast type *) let dC t = CastConv t (** Constructors for constr_expr *) -let isCVar = function CRef (Ident _, _) -> true | _ -> false -let destCVar = function CRef (Ident (_, id), _) -> id | _ -> +let isCVar = function { CAst.v = CRef (Ident _, _) } -> true | _ -> false +let destCVar = function { CAst.v = CRef (Ident (_, id), _) } -> id | _ -> CErrors.anomaly (str"not a CRef") -let mkCHole loc = CHole (loc, None, IntroAnonymous, None) -let mkCLambda loc name ty t = - CLambdaN (loc, [[loc, name], Default Explicit, ty], t) -let mkCLetIn loc name bo t = - CLetIn (loc, (loc, name), bo, None, t) -let mkCCast loc t ty = CCast (loc,t, dC ty) +let mkCHole ~loc = CAst.make ?loc @@ CHole (None, IntroAnonymous, None) +let mkCLambda ?loc name ty t = CAst.make ?loc @@ + CLambdaN ([[Loc.tag ?loc name], Default Explicit, ty], t) +let mkCLetIn ?loc name bo t = CAst.make ?loc @@ + CLetIn ((Loc.tag ?loc name), bo, None, t) +let mkCCast ?loc t ty = CAst.make ?loc @@ CCast (t, dC ty) (** Constructors for rawconstr *) -let mkRHole = GHole (dummy_loc, InternalHole, IntroAnonymous, None) -let mkRApp f args = if args = [] then f else GApp (dummy_loc, f, args) -let mkRCast rc rt = GCast (dummy_loc, rc, dC rt) -let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t) +let mkRHole = CAst.make @@ GHole (InternalHole, IntroAnonymous, None) +let mkRApp f args = if args = [] then f else CAst.make @@ GApp (f, args) +let mkRCast rc rt = CAst.make @@ GCast (rc, dC rt) +let mkRLambda n s t = CAst.make @@ GLambda (n, Explicit, s, t) (* ssrterm conbinators *) let combineCG t1 t2 f g = match t1, t2 with @@ -184,8 +182,7 @@ let profile b = ;; let _ = Goptions.declare_bool_option - { Goptions.optsync = false; - Goptions.optname = "ssrmatching profiling"; + { Goptions.optname = "ssrmatching profiling"; Goptions.optkey = ["SsrMatchingProfiling"]; Goptions.optread = (fun _ -> !profile_now); Goptions.optdepr = false; @@ -471,7 +468,7 @@ let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = | Evar (k, _) -> if Evd.mem sigma0 k then KpatEvar k, f, a else if a <> [] then KpatFlex, f, a else - (match p_origin with None -> CErrors.error "indeterminate pattern" + (match p_origin with None -> CErrors.user_err Pp.(str "indeterminate pattern") | Some (dir, rule) -> errorstrm (str "indeterminate " ++ pr_dir_side dir ++ str " in " ++ pr_constr_pat rule)) @@ -908,16 +905,16 @@ let glob_cpattern gs p = let name = Name (id_of_string ("_ssrpat_" ^ s)) in k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None) in let bind_in t1 t2 = - let d = dummy_loc in let n = Name (destCVar t1) in - fst (glob (mkCCast d (mkCHole d) (mkCLambda d n (mkCHole d) t2))) in + let mkCHole = mkCHole ~loc:None in let n = Name (destCVar t1) in + fst (glob (mkCCast mkCHole (mkCLambda n mkCHole t2))) in let check_var t2 = if not (isCVar t2) then loc_error (constr_loc t2) "Only identifiers are allowed here" in match p with | _, (_, None) as x -> x | k, (v, Some t) as orig -> if k = 'x' then glob_ssrterm gs ('(', (v, Some t)) else - match t with - | CNotation(_, "( _ in _ )", ([t1; t2], [], [])) -> + match t.CAst.v with + | CNotation("( _ in _ )", ([t1; t2], [], [])) -> (try match glob t1, glob t2 with | (r1, None), (r2, None) -> encode k "In" [r1;r2] | (r1, Some _), (r2, Some _) when isCVar t1 -> @@ -925,11 +922,11 @@ let glob_cpattern gs p = | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] | _ -> CErrors.anomaly (str"where are we?") with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) - | CNotation(_, "( _ in _ in _ )", ([t1; t2; t3], [], [])) -> + | CNotation("( _ in _ in _ )", ([t1; t2; t3], [], [])) -> check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] - | CNotation(_, "( _ as _ )", ([t1; t2], [], [])) -> + | CNotation("( _ as _ )", ([t1; t2], [], [])) -> encode k "As" [fst (glob t1); fst (glob t2)] - | CNotation(_, "( _ as _ in _ )", ([t1; t2; t3], [], [])) -> + | CNotation("( _ as _ in _ )", ([t1; t2; t3], [], [])) -> check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] | _ -> glob_ssrterm gs orig ;; @@ -984,10 +981,10 @@ let pr_rpattern = pr_pattern type pattern = Evd.evar_map * (constr, constr) ssrpattern -let id_of_cpattern = function - | _,(_,Some (CRef (Ident (_, x), _))) -> Some x - | _,(_,Some (CAppExpl (_, (_, Ident (_, x), _), []))) -> Some x - | _,(GRef (_, VarRef x, _) ,None) -> Some x +let id_of_cpattern = let open CAst in function + | _,(_,Some { v = CRef (Ident (_, x), _) } ) -> Some x + | _,(_,Some { v = CAppExpl ((_, Ident (_, x), _), []) } ) -> Some x + | _,({ v = GRef (VarRef x, _)} ,None) -> Some x | _ -> None let id_of_Cterm t = match id_of_cpattern t with | Some x -> x @@ -1035,7 +1032,7 @@ GEXTEND Gram GLOBAL: cpattern; cpattern: [[ k = ssrtermkind; c = constr -> let pattern = mk_term k c in - if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]]; + if loc_ofCG pattern <> Some !@loc && k = '(' then mk_term 'x' c else pattern ]]; END ARGUMENT EXTEND lcpattern @@ -1052,7 +1049,7 @@ GEXTEND Gram GLOBAL: lcpattern; lcpattern: [[ k = ssrtermkind; c = lconstr -> let pattern = mk_term k c in - if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]]; + if loc_ofCG pattern <> Some !@loc && k = '(' then mk_term 'x' c else pattern ]]; END let thin id sigma goal = @@ -1085,9 +1082,10 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = let eAsXInT e x t = E_As_X_In_T(e,x,t) in let mkG ?(k=' ') x = k,(x,None) in let decode ist t ?reccall f g = + let open CAst in try match (pf_intern_term ist gl t) with - | GCast(_,GHole _,CastConv(GLambda(_,Name x,_,_,c))) -> f x (' ',(c,None)) - | GVar(_,id) + | { v = GCast({ v = GHole _},CastConv({ v = GLambda(Name x,_,_,c)})) } -> f x (' ',(c,None)) + | { v = GVar id } when Id.Map.mem id ist.lfun && not(Option.is_empty reccall) && not(Option.is_empty wit_ssrpatternarg) -> @@ -1128,18 +1126,18 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = thin name sigma e) sigma new_evars in sigma in - let red = let rec decode_red (ist,red) = match red with - | T(k,(GCast (_,GHole _,(CastConv(GLambda (_,Name id,_,_,t)))),None)) + let red = let rec decode_red (ist,red) = let open CAst in match red with + | T(k,({ v = GCast ({ v = GHole _ },CastConv({ v = GLambda (Name id,_,_,t)}))},None)) when let id = string_of_id id in let len = String.length id in (len > 8 && String.sub id 0 8 = "_ssrpat_") -> let id = string_of_id id in let len = String.length id in (match String.sub id 8 (len - 8), t with - | "In", GApp(_, _, [t]) -> decodeG t xInT (fun x -> T x) - | "In", GApp(_, _, [e; t]) -> decodeG t (eInXInT (mkG e)) (bad_enc id) - | "In", GApp(_, _, [e; t; e_in_t]) -> + | "In", { v = GApp( _, [t]) } -> decodeG t xInT (fun x -> T x) + | "In", { v = GApp( _, [e; t]) } -> decodeG t (eInXInT (mkG e)) (bad_enc id) + | "In", { v = GApp( _, [e; t; e_in_t]) } -> decodeG t (eInXInT (mkG e)) (fun _ -> decodeG e_in_t xInT (fun _ -> assert false)) - | "As", GApp(_, _, [e; t]) -> decodeG t (eAsXInT (mkG e)) (bad_enc id) + | "As", { v = GApp(_, [e; t]) } -> decodeG t (eAsXInT (mkG e)) (bad_enc id) | _ -> bad_enc id ()) | T t -> decode ist ~reccall:decode_red t xInT (fun x -> T x) | In_T t -> decode ist t inXInT inT @@ -1151,27 +1149,27 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = pp(lazy(str"decoded as: " ++ pr_pattern_w_ids red)); let red = match redty with None -> red | Some ty -> let ty = ' ', ty in match red with - | T t -> T (combineCG t ty (mkCCast (loc_ofCG t)) mkRCast) + | T t -> T (combineCG t ty (mkCCast ?loc:(loc_ofCG t)) mkRCast) | X_In_T (x,t) -> let ty = pf_intern_term ist gl ty in E_As_X_In_T (mkG (mkRCast mkRHole ty), x, t) | E_In_X_In_T (e,x,t) -> let ty = mkG (pf_intern_term ist gl ty) in - E_In_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t) + E_In_X_In_T (combineCG e ty (mkCCast ?loc:(loc_ofCG t)) mkRCast, x, t) | E_As_X_In_T (e,x,t) -> let ty = mkG (pf_intern_term ist gl ty) in - E_As_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t) + E_As_X_In_T (combineCG e ty (mkCCast ?loc:(loc_ofCG t)) mkRCast, x, t) | red -> red in pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); - let mkXLetIn loc x (a,(g,c)) = match c with - | Some b -> a,(g,Some (mkCLetIn loc x (mkCHole loc) b)) - | None -> a,(GLetIn (loc,x,(GHole (loc, BinderType x, IntroAnonymous, None)), None, g), None) in + let mkXLetIn ?loc x (a,(g,c)) = match c with + | Some b -> a,(g,Some (mkCLetIn ?loc x (mkCHole ~loc) b)) + | None -> a,(CAst.make ?loc @@ GLetIn (x, CAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None) in match red with | T t -> let sigma, t = interp_term ist gl t in sigma, T t | In_T t -> let sigma, t = interp_term ist gl t in sigma, In_T t | X_In_T (x, rp) | In_X_In_T (x, rp) -> let mk x p = match red with X_In_T _ -> X_In_T(x,p) | _ -> In_X_In_T(x,p) in - let rp = mkXLetIn dummy_loc (Name x) rp in + let rp = mkXLetIn (Name x) rp in let sigma, rp = interp_term ist gl rp in let _, h, _, rp = destLetIn rp in let sigma = cleanup_XinE h x rp sigma in @@ -1180,7 +1178,7 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = | E_In_X_In_T(e, x, rp) | E_As_X_In_T (e, x, rp) -> let mk e x p = match red with E_In_X_In_T _ ->E_In_X_In_T(e,x,p)|_->E_As_X_In_T(e,x,p) in - let rp = mkXLetIn dummy_loc (Name x) rp in + let rp = mkXLetIn (Name x) rp in let sigma, rp = interp_term ist gl rp in let _, h, _, rp = destLetIn rp in let sigma = cleanup_XinE h x rp sigma in @@ -1322,7 +1320,7 @@ let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h = let fill_occ_term env cl occ sigma0 (sigma, t) = try let sigma',uc,t',cl,_= pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in - if sigma' != sigma0 then CErrors.error "matching impacts evars" + if sigma' != sigma0 then CErrors.user_err Pp.(str "matching impacts evars") else cl, (Evd.merge_universe_context sigma' uc, t') with NoMatch -> try let sigma', uc, t' = @@ -1338,10 +1336,10 @@ let pf_fill_occ_term gl occ t = let cl,(_,t) = fill_occ_term env concl occ sigma0 t in cl, t -let cpattern_of_id id = ' ', (GRef (dummy_loc, VarRef id, None), None) +let cpattern_of_id id = ' ', (CAst.make @@ GRef (VarRef id, None), None) -let is_wildcard = function - | _,(_,Some (CHole _)|GHole _,None) -> true +let is_wildcard : cpattern -> bool = function + | _,(_,Some { CAst.v = CHole _ } | { CAst.v = GHole _ } ,None) -> true | _ -> false (* "ssrpattern" *) @@ -1390,7 +1388,7 @@ let () = let () = Tacenv.register_ml_tactic name [|mltac|] in let tac = TacFun ([Name (Id.of_string "pattern")], - TacML (Loc.ghost, { mltac_name = name; mltac_index = 0 }, [])) in + TacML (Loc.tag ({ mltac_name = name; mltac_index = 0 }, []))) in let obj () = Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in Mltop.declare_cache_obj obj "ssrmatching_plugin" diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 638b4e254e..8be989de57 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -221,7 +221,7 @@ val pf_unify_HO : goal sigma -> EConstr.constr -> EConstr.constr -> goal sigma (** Some more low level functions needed to implement the full SSR language on top of the former APIs *) val tag_of_cpattern : cpattern -> char -val loc_of_cpattern : cpattern -> Loc.t +val loc_of_cpattern : cpattern -> Loc.t option val id_of_pattern : pattern -> Names.variable option val is_wildcard : cpattern -> bool val cpattern_of_id : Names.variable -> cpattern diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index ed8cc6ab02..e7eea02849 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -37,34 +37,34 @@ let glob_Ascii = lazy (make_reference "Ascii") open Lazy -let interp_ascii dloc p = +let interp_ascii ?loc p = let rec aux n p = if Int.equal n 0 then [] else let mp = p mod 2 in - GRef (dloc,(if Int.equal mp 0 then glob_false else glob_true),None) + (CAst.make ?loc @@ GRef ((if Int.equal mp 0 then glob_false else glob_true),None)) :: (aux (n-1) (p/2)) in - GApp (dloc,GRef(dloc,force glob_Ascii,None), aux 8 p) + CAst.make ?loc @@ GApp (CAst.make ?loc @@ GRef(force glob_Ascii,None), aux 8 p) -let interp_ascii_string dloc s = +let interp_ascii_string ?loc s = let p = if Int.equal (String.length s) 1 then int_of_char s.[0] else if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2] then int_of_string s else - user_err ~loc:dloc ~hdr:"interp_ascii_string" + user_err ?loc ~hdr:"interp_ascii_string" (str "Expects a single character or a three-digits ascii code.") in - interp_ascii dloc p + interp_ascii ?loc p let uninterp_ascii r = let rec uninterp_bool_list n = function | [] when Int.equal n 0 -> 0 - | GRef (_,k,_)::l when Globnames.eq_gr k glob_true -> 1+2*(uninterp_bool_list (n-1) l) - | GRef (_,k,_)::l when Globnames.eq_gr k glob_false -> 2*(uninterp_bool_list (n-1) l) + | { CAst.v = GRef (k,_)}::l when Globnames.eq_gr k glob_true -> 1+2*(uninterp_bool_list (n-1) l) + | { CAst.v = GRef (k,_)}::l when Globnames.eq_gr k glob_false -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in try let aux = function - | GApp (_,GRef (_,k,_),l) when Globnames.eq_gr k (force glob_Ascii) -> uninterp_bool_list 8 l + | { CAst.v = GApp ({ CAst.v = GRef (k,_)},l) } when Globnames.eq_gr k (force glob_Ascii) -> uninterp_bool_list 8 l | _ -> raise Non_closed_ascii in Some (aux r) with @@ -80,4 +80,4 @@ let _ = Notation.declare_string_interpreter "char_scope" (ascii_path,ascii_module) interp_ascii_string - ([GRef (Loc.ghost,static_glob_Ascii,None)], uninterp_ascii_string, true) + ([CAst.make @@ GRef (static_glob_Ascii,None)], uninterp_ascii_string, true) diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index ab262fea70..9a4cd6c254 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -33,21 +33,21 @@ let warn_large_nat = strbrk "may vary from 5000 to 70000 depending on your system " ++ strbrk "limits and on the command executed).") -let nat_of_int dloc n = +let nat_of_int ?loc n = if is_pos_or_zero n then begin if less_than threshold n then warn_large_nat (); - let ref_O = GRef (dloc, glob_O, None) in - let ref_S = GRef (dloc, glob_S, None) in + let ref_O = CAst.make ?loc @@ GRef (glob_O, None) in + let ref_S = CAst.make ?loc @@ GRef (glob_S, None) in let rec mk_nat acc n = if n <> zero then - mk_nat (GApp (dloc,ref_S, [acc])) (sub_1 n) + mk_nat (CAst.make ?loc @@ GApp (ref_S, [acc])) (sub_1 n) else acc in mk_nat ref_O n end else - user_err ~hdr:"nat_of_int" + user_err ?loc ~hdr:"nat_of_int" (str "Cannot interpret a negative number as a number of type nat") (************************************************************************) @@ -55,10 +55,11 @@ let nat_of_int dloc n = exception Non_closed_number -let rec int_of_nat = function - | GApp (_,GRef (_,s,_),[a]) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) - | GRef (_,z,_) when Globnames.eq_gr z glob_O -> zero +let rec int_of_nat x = CAst.with_val (function + | GApp ({ CAst.v = GRef (s,_) } ,[a]) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) + | GRef (z,_) when Globnames.eq_gr z glob_O -> zero | _ -> raise Non_closed_number + ) x let uninterp_nat p = try @@ -73,4 +74,4 @@ let _ = Notation.declare_numeral_interpreter "nat_scope" (nat_path,datatypes_module_name) nat_of_int - ([GRef (Loc.ghost,glob_S,None); GRef (Loc.ghost,glob_O,None)], uninterp_nat, true) + ([CAst.make @@ GRef (glob_S,None); CAst.make @@ GRef (glob_O,None)], uninterp_nat, true) diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index a25ddb0622..e23852bf8f 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -86,10 +86,10 @@ exception Non_closed (* parses a *non-negative* integer (from bigint.ml) into an int31 wraps modulo 2^31 *) -let int31_of_pos_bigint dloc n = - let ref_construct = GRef (dloc, int31_construct, None) in - let ref_0 = GRef (dloc, int31_0, None) in - let ref_1 = GRef (dloc, int31_1, None) in +let int31_of_pos_bigint ?loc n = + let ref_construct = CAst.make ?loc @@ GRef (int31_construct, None) in + let ref_0 = CAst.make ?loc @@ GRef (int31_0, None) in + let ref_1 = CAst.make ?loc @@ GRef (int31_1, None) in let rec args counter n = if counter <= 0 then [] @@ -97,16 +97,16 @@ let int31_of_pos_bigint dloc n = let (q,r) = div2_with_rest n in (if r then ref_1 else ref_0)::(args (counter-1) q) in - GApp (dloc, ref_construct, List.rev (args 31 n)) + CAst.make ?loc @@ GApp (ref_construct, List.rev (args 31 n)) -let error_negative dloc = - CErrors.user_err ~loc:dloc ~hdr:"interp_int31" (Pp.str "int31 are only non-negative numbers.") +let error_negative ?loc = + CErrors.user_err ?loc ~hdr:"interp_int31" (Pp.str "int31 are only non-negative numbers.") -let interp_int31 dloc n = +let interp_int31 ?loc n = if is_pos_or_zero n then - int31_of_pos_bigint dloc n + int31_of_pos_bigint ?loc n else - error_negative dloc + error_negative ?loc (* Pretty prints an int31 *) @@ -114,12 +114,12 @@ let bigint_of_int31 = let rec args_parsing args cur = match args with | [] -> cur - | (GRef (_,b,_))::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur) - | (GRef (_,b,_))::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur)) + | { CAst.v = GRef (b,_) }::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur) + | { CAst.v = GRef (b,_) }::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur)) | _ -> raise Non_closed in function - | GApp (_, GRef (_, c, _), args) when eq_gr c int31_construct -> args_parsing args zero + | { CAst.v = GApp ({ CAst.v = GRef (c, _)}, args) } when eq_gr c int31_construct -> args_parsing args zero | _ -> raise Non_closed let uninterp_int31 i = @@ -132,7 +132,7 @@ let uninterp_int31 i = let _ = Notation.declare_numeral_interpreter int31_scope (int31_path, int31_module) interp_int31 - ([GRef (Loc.ghost, int31_construct, None)], + ([CAst.make @@ GRef (int31_construct, None)], uninterp_int31, true) @@ -162,40 +162,40 @@ let height bi = in hght 0 base (* n must be a non-negative integer (from bigint.ml) *) -let word_of_pos_bigint dloc hght n = - let ref_W0 = GRef (dloc, zn2z_W0, None) in - let ref_WW = GRef (dloc, zn2z_WW, None) in +let word_of_pos_bigint ?loc hght n = + let ref_W0 = CAst.make ?loc @@ GRef (zn2z_W0, None) in + let ref_WW = CAst.make ?loc @@ GRef (zn2z_WW, None) in let rec decomp hgt n = if hgt <= 0 then - int31_of_pos_bigint dloc n + int31_of_pos_bigint ?loc n else if equal n zero then - GApp (dloc, ref_W0, [GHole (dloc, Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None)]) + CAst.make ?loc @@ GApp (ref_W0, [CAst.make ?loc @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None)]) else let (h,l) = split_at hgt n in - GApp (dloc, ref_WW, [GHole (dloc, Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None); + CAst.make ?loc @@ GApp (ref_WW, [CAst.make ?loc @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None); decomp (hgt-1) h; decomp (hgt-1) l]) in decomp hght n -let bigN_of_pos_bigint dloc n = +let bigN_of_pos_bigint ?loc n = let h = height n in - let ref_constructor = GRef (dloc, bigN_constructor h, None) in - let word = word_of_pos_bigint dloc h n in + let ref_constructor = CAst.make ?loc @@ GRef (bigN_constructor h, None) in + let word = word_of_pos_bigint ?loc h n in let args = if h < n_inlined then [word] - else [Nat_syntax_plugin.Nat_syntax.nat_of_int dloc (of_int (h-n_inlined));word] + else [Nat_syntax_plugin.Nat_syntax.nat_of_int ?loc (of_int (h-n_inlined));word] in - GApp (dloc, ref_constructor, args) + CAst.make ?loc @@ GApp (ref_constructor, args) -let bigN_error_negative dloc = - CErrors.user_err ~loc:dloc ~hdr:"interp_bigN" (Pp.str "bigN are only non-negative numbers.") +let bigN_error_negative ?loc = + CErrors.user_err ?loc ~hdr:"interp_bigN" (Pp.str "bigN are only non-negative numbers.") -let interp_bigN dloc n = +let interp_bigN ?loc n = if is_pos_or_zero n then - bigN_of_pos_bigint dloc n + bigN_of_pos_bigint ?loc n else - bigN_error_negative dloc + bigN_error_negative ?loc (* Pretty prints a bigN *) @@ -203,14 +203,14 @@ let interp_bigN dloc n = let bigint_of_word = let rec get_height rc = match rc with - | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW -> + | { CAst.v = GApp ({ CAst.v = GRef(c,_)}, [_;lft;rght]) } when eq_gr c zn2z_WW -> 1+max (get_height lft) (get_height rght) | _ -> 0 in let rec transform hght rc = match rc with - | GApp (_,GRef(_,c,_),_) when eq_gr c zn2z_W0-> zero - | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW-> + | { CAst.v = GApp ({ CAst.v = GRef(c,_)},_)} when eq_gr c zn2z_W0-> zero + | { CAst.v = GApp ({ CAst.v = GRef(c,_)}, [_;lft;rght]) } when eq_gr c zn2z_WW-> let new_hght = hght-1 in add (mult (rank new_hght) (transform new_hght lft)) @@ -223,8 +223,8 @@ let bigint_of_word = let bigint_of_bigN rc = match rc with - | GApp (_,_,[one_arg]) -> bigint_of_word one_arg - | GApp (_,_,[_;second_arg]) -> bigint_of_word second_arg + | { CAst.v = GApp (_,[one_arg]) } -> bigint_of_word one_arg + | { CAst.v = GApp (_,[_;second_arg]) } -> bigint_of_word second_arg | _ -> raise Non_closed let uninterp_bigN rc = @@ -240,7 +240,7 @@ let uninterp_bigN rc = let bigN_list_of_constructors = let rec build i = if i < n_inlined+1 then - GRef (Loc.ghost, bigN_constructor i,None)::(build (i+1)) + (CAst.make @@ GRef (bigN_constructor i,None))::(build (i+1)) else [] in @@ -256,18 +256,18 @@ let _ = Notation.declare_numeral_interpreter bigN_scope (*** Parsing for bigZ in digital notation ***) -let interp_bigZ dloc n = - let ref_pos = GRef (dloc, bigZ_pos, None) in - let ref_neg = GRef (dloc, bigZ_neg, None) in +let interp_bigZ ?loc n = + let ref_pos = CAst.make ?loc @@ GRef (bigZ_pos, None) in + let ref_neg = CAst.make ?loc @@ GRef (bigZ_neg, None) in if is_pos_or_zero n then - GApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n]) + CAst.make ?loc @@ GApp (ref_pos, [bigN_of_pos_bigint ?loc n]) else - GApp (dloc, ref_neg, [bigN_of_pos_bigint dloc (neg n)]) + CAst.make ?loc @@ GApp (ref_neg, [bigN_of_pos_bigint ?loc (neg n)]) (* pretty printing functions for bigZ *) let bigint_of_bigZ = function - | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_pos -> bigint_of_bigN one_arg - | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_neg -> + | { CAst.v = GApp ({ CAst.v = GRef(c,_) }, [one_arg])} when eq_gr c bigZ_pos -> bigint_of_bigN one_arg + | { CAst.v = GApp ({ CAst.v = GRef(c,_) }, [one_arg])} when eq_gr c bigZ_neg -> let opp_val = bigint_of_bigN one_arg in if equal opp_val zero then raise Non_closed @@ -286,19 +286,19 @@ let uninterp_bigZ rc = let _ = Notation.declare_numeral_interpreter bigZ_scope (bigZ_path, bigZ_module) interp_bigZ - ([GRef (Loc.ghost, bigZ_pos, None); - GRef (Loc.ghost, bigZ_neg, None)], + ([CAst.make @@ GRef (bigZ_pos, None); + CAst.make @@ GRef (bigZ_neg, None)], uninterp_bigZ, true) (*** Parsing for bigQ in digital notation ***) -let interp_bigQ dloc n = - let ref_z = GRef (dloc, bigQ_z, None) in - GApp (dloc, ref_z, [interp_bigZ dloc n]) +let interp_bigQ ?loc n = + let ref_z = CAst.make ?loc @@ GRef (bigQ_z, None) in + CAst.make ?loc @@ GApp (ref_z, [interp_bigZ ?loc n]) let uninterp_bigQ rc = try match rc with - | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigQ_z -> + | { CAst.v = GApp ({ CAst.v = GRef(c,_)}, [one_arg]) } when eq_gr c bigQ_z -> Some (bigint_of_bigZ one_arg) | _ -> None (* we don't pretty-print yet fractions *) with Non_closed -> None @@ -307,5 +307,5 @@ let uninterp_bigQ rc = let _ = Notation.declare_numeral_interpreter bigQ_scope (bigQ_path, bigQ_module) interp_bigQ - ([GRef (Loc.ghost, bigQ_z, None)], uninterp_bigQ, + ([CAst.make @@ GRef (bigQ_z, None)], uninterp_bigQ, true) diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 8f065f5282..7ce066c59d 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -41,14 +41,14 @@ let glob_xI = ConstructRef path_of_xI let glob_xO = ConstructRef path_of_xO let glob_xH = ConstructRef path_of_xH -let pos_of_bignat dloc x = - let ref_xI = GRef (dloc, glob_xI, None) in - let ref_xH = GRef (dloc, glob_xH, None) in - let ref_xO = GRef (dloc, glob_xO, None) in +let pos_of_bignat ?loc x = + let ref_xI = CAst.make @@ GRef (glob_xI, None) in + let ref_xH = CAst.make @@ GRef (glob_xH, None) in + let ref_xO = CAst.make @@ GRef (glob_xO, None) in let rec pos_of x = match div2_with_rest x with - | (q,false) -> GApp (dloc, ref_xO,[pos_of q]) - | (q,true) when not (Bigint.equal q zero) -> GApp (dloc,ref_xI,[pos_of q]) + | (q,false) -> CAst.make @@ GApp (ref_xO,[pos_of q]) + | (q,true) when not (Bigint.equal q zero) -> CAst.make @@ GApp (ref_xI,[pos_of q]) | (q,true) -> ref_xH in pos_of x @@ -58,9 +58,9 @@ let pos_of_bignat dloc x = (**********************************************************************) let rec bignat_of_pos = function - | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) - | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) - | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one + | { CAst.v = GApp ({ CAst.v = GRef (b,_)},[a]) } when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) + | { CAst.v = GApp ({ CAst.v = GRef (b,_)},[a]) } when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) + | { CAst.v = GRef (a, _) } when Globnames.eq_gr a glob_xH -> Bigint.one | _ -> raise Non_closed_number (**********************************************************************) @@ -77,22 +77,22 @@ let glob_ZERO = ConstructRef path_of_ZERO let glob_POS = ConstructRef path_of_POS let glob_NEG = ConstructRef path_of_NEG -let z_of_int dloc n = +let z_of_int ?loc n = if not (Bigint.equal n zero) then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in - GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n]) + CAst.make @@ GApp(CAst.make @@ GRef (sgn,None), [pos_of_bignat ?loc n]) else - GRef (dloc, glob_ZERO, None) + CAst.make @@ GRef (glob_ZERO, None) (**********************************************************************) (* Printing Z via scopes *) (**********************************************************************) let bigint_of_z = function - | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a - | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) - | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero + | { CAst.v = GApp ({ CAst.v = GRef (b,_)},[a]) } when Globnames.eq_gr b glob_POS -> bignat_of_pos a + | { CAst.v = GApp ({ CAst.v = GRef (b,_)},[a]) } when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) + | { CAst.v = GRef (a, _) } when Globnames.eq_gr a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number (**********************************************************************) @@ -107,15 +107,15 @@ let make_path dir id = Globnames.encode_con dir (Id.of_string id) let glob_IZR = ConstRef (make_path (make_dir rdefinitions) "IZR") -let r_of_int dloc z = - GApp (dloc, GRef(dloc,glob_IZR,None), [z_of_int dloc z]) +let r_of_int ?loc z = + CAst.make @@ GApp (CAst.make @@ GRef(glob_IZR,None), [z_of_int ?loc z]) (**********************************************************************) (* Printing R via scopes *) (**********************************************************************) let bigint_of_r = function - | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_IZR -> + | { CAst.v = GApp ({ CAst.v = GRef (o,_) }, [a]) } when Globnames.eq_gr o glob_IZR -> bigint_of_z a | _ -> raise Non_closed_number @@ -128,6 +128,6 @@ let uninterp_r p = let _ = Notation.declare_numeral_interpreter "R_scope" (r_path,["Coq";"Reals";"Rdefinitions"]) r_of_int - ([GRef (Loc.ghost,glob_IZR,None)], + ([CAst.make @@ GRef (glob_IZR, None)], uninterp_r, false) diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index de0fa77eff..b7f13b0400 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -33,23 +33,23 @@ let glob_EmptyString = lazy (make_reference "EmptyString") open Lazy -let interp_string dloc s = +let interp_string ?loc s = let le = String.length s in let rec aux n = - if n = le then GRef (dloc, force glob_EmptyString, None) else - GApp (dloc,GRef (dloc, force glob_String, None), - [interp_ascii dloc (int_of_char s.[n]); aux (n+1)]) + if n = le then CAst.make ?loc @@ GRef (force glob_EmptyString, None) else + CAst.make ?loc @@ GApp (CAst.make ?loc @@ GRef (force glob_String, None), + [interp_ascii ?loc (int_of_char s.[n]); aux (n+1)]) in aux 0 let uninterp_string r = try let b = Buffer.create 16 in let rec aux = function - | GApp (_,GRef (_,k,_),[a;s]) when eq_gr k (force glob_String) -> + | { CAst.v = GApp ({ CAst.v = GRef (k,_) },[a;s]) } when eq_gr k (force glob_String) -> (match uninterp_ascii a with | Some c -> Buffer.add_char b (Char.chr c); aux s | _ -> raise Non_closed_string) - | GRef (_,z,_) when eq_gr z (force glob_EmptyString) -> + | { CAst.v = GRef (z,_) } when eq_gr z (force glob_EmptyString) -> Some (Buffer.contents b) | _ -> raise Non_closed_string @@ -61,6 +61,6 @@ let _ = Notation.declare_string_interpreter "string_scope" (string_path,["Coq";"Strings";"String"]) interp_string - ([GRef (Loc.ghost,static_glob_String,None); - GRef (Loc.ghost,static_glob_EmptyString,None)], + ([CAst.make @@ GRef (static_glob_String,None); + CAst.make @@ GRef (static_glob_EmptyString,None)], uninterp_string, true) diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index b7b5fb8a58..479448e06e 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -44,35 +44,36 @@ let glob_xI = ConstructRef path_of_xI let glob_xO = ConstructRef path_of_xO let glob_xH = ConstructRef path_of_xH -let pos_of_bignat dloc x = - let ref_xI = GRef (dloc, glob_xI, None) in - let ref_xH = GRef (dloc, glob_xH, None) in - let ref_xO = GRef (dloc, glob_xO, None) in +let pos_of_bignat ?loc x = + let ref_xI = CAst.make ?loc @@ GRef (glob_xI, None) in + let ref_xH = CAst.make ?loc @@ GRef (glob_xH, None) in + let ref_xO = CAst.make ?loc @@ GRef (glob_xO, None) in let rec pos_of x = match div2_with_rest x with - | (q,false) -> GApp (dloc, ref_xO,[pos_of q]) - | (q,true) when not (Bigint.equal q zero) -> GApp (dloc,ref_xI,[pos_of q]) + | (q,false) -> CAst.make ?loc @@ GApp (ref_xO,[pos_of q]) + | (q,true) when not (Bigint.equal q zero) -> CAst.make ?loc @@ GApp (ref_xI,[pos_of q]) | (q,true) -> ref_xH in pos_of x -let error_non_positive dloc = - user_err ~loc:dloc ~hdr:"interp_positive" +let error_non_positive ?loc = + user_err ?loc ~hdr:"interp_positive" (str "Only strictly positive numbers in type \"positive\".") -let interp_positive dloc n = - if is_strictly_pos n then pos_of_bignat dloc n - else error_non_positive dloc +let interp_positive ?loc n = + if is_strictly_pos n then pos_of_bignat ?loc n + else error_non_positive ?loc (**********************************************************************) (* Printing positive via scopes *) (**********************************************************************) -let rec bignat_of_pos = function - | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) - | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) - | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one +let rec bignat_of_pos x = CAst.with_val (function + | GApp ({ CAst.v = GRef (b,_) },[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) + | GApp ({ CAst.v = GRef (b,_) },[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) + | GRef (a, _) when Globnames.eq_gr a glob_xH -> Bigint.one | _ -> raise Non_closed_number + ) x let uninterp_positive p = try @@ -87,9 +88,9 @@ let uninterp_positive p = let _ = Notation.declare_numeral_interpreter "positive_scope" (positive_path,binnums) interp_positive - ([GRef (Loc.ghost, glob_xI, None); - GRef (Loc.ghost, glob_xO, None); - GRef (Loc.ghost, glob_xH, None)], + ([CAst.make @@ GRef (glob_xI, None); + CAst.make @@ GRef (glob_xO, None); + CAst.make @@ GRef (glob_xH, None)], uninterp_positive, true) @@ -106,27 +107,28 @@ let glob_Npos = ConstructRef path_of_Npos let n_path = make_path binnums "N" -let n_of_binnat dloc pos_or_neg n = +let n_of_binnat ?loc pos_or_neg n = CAst.make ?loc @@ if not (Bigint.equal n zero) then - GApp(dloc, GRef (dloc,glob_Npos,None), [pos_of_bignat dloc n]) + GApp(CAst.make @@ GRef (glob_Npos,None), [pos_of_bignat ?loc n]) else - GRef (dloc, glob_N0, None) + GRef(glob_N0, None) -let error_negative dloc = - user_err ~loc:dloc ~hdr:"interp_N" (str "No negative numbers in type \"N\".") +let error_negative ?loc = + user_err ?loc ~hdr:"interp_N" (str "No negative numbers in type \"N\".") -let n_of_int dloc n = - if is_pos_or_zero n then n_of_binnat dloc true n - else error_negative dloc +let n_of_int ?loc n = + if is_pos_or_zero n then n_of_binnat ?loc true n + else error_negative ?loc (**********************************************************************) (* Printing N via scopes *) (**********************************************************************) -let bignat_of_n = function - | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_Npos -> bignat_of_pos a - | GRef (_, a,_) when Globnames.eq_gr a glob_N0 -> Bigint.zero +let bignat_of_n = CAst.with_val (function + | GApp ({ CAst.v = GRef (b,_)},[a]) when Globnames.eq_gr b glob_Npos -> bignat_of_pos a + | GRef (a,_) when Globnames.eq_gr a glob_N0 -> Bigint.zero | _ -> raise Non_closed_number + ) let uninterp_n p = try Some (bignat_of_n p) @@ -138,8 +140,8 @@ let uninterp_n p = let _ = Notation.declare_numeral_interpreter "N_scope" (n_path,binnums) n_of_int - ([GRef (Loc.ghost, glob_N0, None); - GRef (Loc.ghost, glob_Npos, None)], + ([CAst.make @@ GRef (glob_N0, None); + CAst.make @@ GRef (glob_Npos, None)], uninterp_n, true) @@ -157,23 +159,24 @@ let glob_ZERO = ConstructRef path_of_ZERO let glob_POS = ConstructRef path_of_POS let glob_NEG = ConstructRef path_of_NEG -let z_of_int dloc n = +let z_of_int ?loc n = if not (Bigint.equal n zero) then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in - GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n]) + CAst.make ?loc @@ GApp(CAst.make ?loc @@ GRef(sgn,None), [pos_of_bignat ?loc n]) else - GRef (dloc, glob_ZERO, None) + CAst.make ?loc @@ GRef(glob_ZERO, None) (**********************************************************************) (* Printing Z via scopes *) (**********************************************************************) -let bigint_of_z = function - | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a - | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) - | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero +let bigint_of_z = CAst.with_val (function + | GApp ({ CAst.v = GRef (b,_)},[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a + | GApp ({ CAst.v = GRef (b,_)},[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) + | GRef (a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number + ) let uninterp_z p = try @@ -186,8 +189,8 @@ let uninterp_z p = let _ = Notation.declare_numeral_interpreter "Z_scope" (z_path,binnums) z_of_int - ([GRef (Loc.ghost, glob_ZERO, None); - GRef (Loc.ghost, glob_POS, None); - GRef (Loc.ghost, glob_NEG, None)], + ([CAst.make @@ GRef (glob_ZERO, None); + CAst.make @@ GRef (glob_POS, None); + CAst.make @@ GRef (glob_NEG, None)], uninterp_z, true) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 8a49cd5488..80680e4088 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -95,7 +95,7 @@ let msg_may_need_inversion () = (* Utils *) let make_anonymous_patvars n = - List.make n (PatVar (Loc.ghost,Anonymous)) + List.make n (CAst.make @@ PatVar Anonymous) (* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *) @@ -122,7 +122,7 @@ type 'a equation = { patterns : cases_pattern list; rhs : 'a rhs; alias_stack : Name.t list; - eqn_loc : Loc.t; + eqn_loc : Loc.t option; used : bool ref } type 'a matrix = 'a equation list @@ -178,7 +178,7 @@ and build_glob_pattern args = function | Top -> args | MakeConstructor (pci, rh) -> glob_pattern_of_partial_history - [PatCstr (Loc.ghost, pci, args, Anonymous)] rh + [CAst.make @@ PatCstr (pci, args, Anonymous)] rh let complete_history = glob_pattern_of_partial_history [] @@ -188,12 +188,12 @@ let pop_history_pattern = function | Continuation (0, l, Top) -> Result (List.rev l) | Continuation (0, l, MakeConstructor (pci, rh)) -> - feed_history (PatCstr (Loc.ghost,pci,List.rev l,Anonymous)) rh + feed_history (CAst.make @@ PatCstr (pci,List.rev l,Anonymous)) rh | _ -> anomaly (Pp.str "Constructor not yet filled with its arguments") let pop_history h = - feed_history (PatVar (Loc.ghost, Anonymous)) h + feed_history (CAst.make @@ PatVar Anonymous) h (* Builds a continuation expecting [n] arguments and building [ci] applied to this [n] arguments *) @@ -251,7 +251,7 @@ type 'a pattern_matching_problem = tomatch : tomatch_stack; history : pattern_continuation; mat : 'a matrix; - caseloc : Loc.t; + caseloc : Loc.t option; casestyle : case_style; typing_function: type_constraint -> env -> evar_map ref -> 'a option -> unsafe_judgment } @@ -273,16 +273,16 @@ type 'a pattern_matching_problem = let rec find_row_ind = function [] -> None - | PatVar _ :: l -> find_row_ind l - | PatCstr(loc,c,_,_) :: _ -> Some (loc,c) + | { CAst.v = PatVar _ } :: l -> find_row_ind l + | { CAst.v = PatCstr(c,_,_) ; loc } :: _ -> Some (loc,c) let inductive_template evdref env tmloc ind = let indu = evd_comb1 (Evd.fresh_inductive_instance env) evdref ind in let arsign = inductive_alldecls_env env indu in let indu = on_snd EInstance.make indu in let hole_source i = match tmloc with - | Some loc -> (loc, Evar_kinds.TomatchTypeParameter (ind,i)) - | None -> (Loc.ghost, Evar_kinds.TomatchTypeParameter (ind,i)) in + | Some loc -> Loc.tag ~loc @@ Evar_kinds.TomatchTypeParameter (ind,i) + | None -> Loc.tag @@ Evar_kinds.TomatchTypeParameter (ind,i) in let (_,evarl,_) = List.fold_right (fun decl (subst,evarl,n) -> @@ -342,16 +342,16 @@ let unify_tomatch_with_patterns evdref env loc typ pats realnames = let find_tomatch_tycon evdref env loc = function (* Try if some 'in I ...' is present and can be used as a constraint *) - | Some (_,ind,realnal) -> + | Some (_,(ind,realnal)) -> mk_tycon (inductive_template evdref env loc ind),Some (List.rev realnal) | None -> empty_tycon,None let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) = - let loc = Some (loc_of_glob_constr tomatch) in + let loc = loc_of_glob_constr tomatch in let tycon,realnames = find_tomatch_tycon evdref env loc indopt in let j = typing_fun tycon env evdref tomatch in - let evd, j = Coercion.inh_coerce_to_base (loc_of_glob_constr tomatch) env !evdref j in + let evd, j = Coercion.inh_coerce_to_base ?loc:(loc_of_glob_constr tomatch) env !evdref j in evdref := evd; let typ = nf_evar !evdref j.uj_type in let t = @@ -360,7 +360,7 @@ let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) = unify_tomatch_with_patterns evdref env loc typ pats realnames in (j.uj_val,t) -let coerce_to_indtype typing_fun evdref env matx tomatchl = +let coerce_to_indtype typing_fun evdref env matx tomatchl = let pats = List.map (fun r -> r.patterns) matx in let matx' = match matrix_transpose pats with | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *) @@ -370,7 +370,7 @@ let coerce_to_indtype typing_fun evdref env matx tomatchl = (************************************************************************) (* Utils *) -let mkExistential env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) evdref = +let mkExistential env ?(src=(Loc.tag Evar_kinds.InternalHole)) evdref = let e, u = e_new_type_evar env evdref univ_flexible_alg ~src:src in e let evd_comb2 f evdref x y = @@ -402,7 +402,7 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = let _ = e_cumul pb.env pb.evdref indt typ in current else - (evd_comb2 (Coercion.inh_conv_coerce_to true Loc.ghost pb.env) + (evd_comb2 (Coercion.inh_conv_coerce_to true pb.env) pb.evdref (make_judge current typ) indt).uj_val in let sigma = !(pb.evdref) in (current,try_find_ind pb.env sigma indt names)) @@ -427,9 +427,10 @@ let current_pattern eqn = | pat::_ -> pat | [] -> anomaly (Pp.str "Empty list of patterns") -let alias_of_pat = function - | PatVar (_,name) -> name - | PatCstr(_,_,_,name) -> name +let alias_of_pat = CAst.with_val (function + | PatVar name -> name + | PatCstr(_,_,name) -> name + ) let remove_current_pattern eqn = match eqn.patterns with @@ -468,17 +469,17 @@ let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns } exception NotAdjustable -let rec adjust_local_defs loc = function +let rec adjust_local_defs ?loc = function | (pat :: pats, LocalAssum _ :: decls) -> - pat :: adjust_local_defs loc (pats,decls) + pat :: adjust_local_defs ?loc (pats,decls) | (pats, LocalDef _ :: decls) -> - PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls) + (CAst.make ?loc @@ PatVar Anonymous) :: adjust_local_defs ?loc (pats,decls) | [], [] -> [] | _ -> raise NotAdjustable let check_and_adjust_constructor env ind cstrs = function - | PatVar _ as pat -> pat - | PatCstr (loc,((_,i) as cstr),args,alias) as pat -> + | { CAst.v = PatVar _ } as pat -> pat + | { CAst.v = PatCstr (((_,i) as cstr),args,alias) ; loc } as pat -> (* Check it is constructor of the right type *) let ind' = inductive_of_constructor cstr in if eq_ind ind' ind then @@ -488,28 +489,28 @@ let check_and_adjust_constructor env ind cstrs = function if Int.equal (List.length args) nb_args_constr then pat else try - let args' = adjust_local_defs loc (args, List.rev ci.cs_args) - in PatCstr (loc, cstr, args', alias) + let args' = adjust_local_defs ?loc (args, List.rev ci.cs_args) + in CAst.make ?loc @@ PatCstr (cstr, args', alias) with NotAdjustable -> - error_wrong_numarg_constructor ~loc env cstr nb_args_constr + error_wrong_numarg_constructor ?loc env cstr nb_args_constr else (* Try to insert a coercion *) try - Coercion.inh_pattern_coerce_to loc env pat ind' ind + Coercion.inh_pattern_coerce_to ?loc env pat ind' ind with Not_found -> - error_bad_constructor ~loc env cstr ind + error_bad_constructor ?loc env cstr ind let check_all_variables env sigma typ mat = List.iter (fun eqn -> match current_pattern eqn with - | PatVar (_,id) -> () - | PatCstr (loc,cstr_sp,_,_) -> - error_bad_pattern ~loc env sigma cstr_sp typ) + | { CAst.v = PatVar id } -> () + | { CAst.v = PatCstr (cstr_sp,_,_); loc } -> + error_bad_pattern ?loc env sigma cstr_sp typ) mat let check_unused_pattern env eqn = if not !(eqn.used) then - raise_pattern_matching_error ~loc:eqn.eqn_loc (env, Evd.empty, UnusedClause eqn.patterns) + raise_pattern_matching_error ?loc:eqn.eqn_loc (env, Evd.empty, UnusedClause eqn.patterns) let set_used_pattern eqn = eqn.used := true @@ -529,8 +530,8 @@ let occur_in_rhs na rhs = | Name id -> Id.List.mem id rhs.rhs_vars let is_dep_patt_in eqn = function - | PatVar (_,name) -> Flags.is_program_mode () || occur_in_rhs name eqn.rhs - | PatCstr _ -> true + | { CAst.v = PatVar name } -> Flags.is_program_mode () || occur_in_rhs name eqn.rhs + | { CAst.v = PatCstr _ } -> true let mk_dep_patt_row (pats,_,eqn) = List.map (is_dep_patt_in eqn) pats @@ -730,7 +731,7 @@ let get_names env sigma sign eqns = (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env sigma t na) avoid)) d na in - (na::l,(out_name na)::avoid)) + (na::l,(Name.get_id na)::avoid)) ([],allvars) (List.rev sign) names2 in names3,aliasname @@ -750,7 +751,7 @@ let recover_and_adjust_alias_names names sign = | x::names, LocalAssum (_,t)::sign -> (x, LocalAssum (alias_of_pat x,t)) :: aux (names,sign) | names, (LocalDef (na,_,_) as decl)::sign -> - (PatVar (Loc.ghost,na), decl) :: aux (names,sign) + (CAst.make @@ PatVar na, decl) :: aux (names,sign) | _ -> assert false in List.split (aux (names,sign)) @@ -960,14 +961,13 @@ let expand_arg tms (p,ccl) ((_,t),_,na) = let k = length_of_tomatch_type_sign na t in (p+k,liftn_predicate (k-1) (p+1) ccl tms) - let use_unit_judge evd = let j, ctx = coq_unit_judge () in let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd ctx in evd', j let add_assert_false_case pb tomatch = - let pats = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) tomatch in + let pats = List.map (fun _ -> CAst.make @@ PatVar Anonymous) tomatch in let aliasnames = List.map_filter (function Alias _ | NonDepAlias -> Some Anonymous | _ -> None) tomatch in @@ -977,7 +977,7 @@ let add_assert_false_case pb tomatch = avoid_ids = []; it = None }; alias_stack = Anonymous::aliasnames; - eqn_loc = Loc.ghost; + eqn_loc = None; used = ref false } ] let adjust_impossible_cases pb pred tomatch submat = @@ -1165,8 +1165,8 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs = (* Sorting equations by constructor *) let rec irrefutable env = function - | PatVar (_,name) -> true - | PatCstr (_,cstr,args,_) -> + | { CAst.v = PatVar name } -> true + | { CAst.v = PatCstr (cstr,args,_) } -> let ind = inductive_of_constructor cstr in let (_,mip) = Inductive.lookup_mind_specif env ind in let one_constr = Int.equal (Array.length mip.mind_user_lc) 1 in @@ -1187,14 +1187,14 @@ let group_equations pb ind current cstrs mat = let rest = remove_current_pattern eqn in let pat = current_pattern eqn in match check_and_adjust_constructor pb.env ind cstrs pat with - | PatVar (_,name) -> + | { CAst.v = PatVar name } -> (* This is a default clause that we expand *) for i=1 to Array.length cstrs do let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in brs.(i-1) <- (args, name, rest) :: brs.(i-1) done; if !only_default == None then only_default := Some true - | PatCstr (loc,((_,i)),args,name) -> + | { CAst.v = PatCstr (((_,i)),args,name) ; loc } -> (* This is a regular clause *) only_default := Some false; brs.(i-1) <- (args, name, rest) :: brs.(i-1)) mat () in @@ -1540,7 +1540,7 @@ substituer après par les initiaux *) * and linearizing the _ patterns. * Syntactic correctness has already been done in astterm *) let matx_of_eqns env eqns = - let build_eqn (loc,ids,lpat,rhs) = + let build_eqn (loc,(ids,lpat,rhs)) = let initial_lpat,initial_rhs = lpat,rhs in let initial_rhs = rhs in let rhs = @@ -1634,11 +1634,11 @@ let rec list_assoc_in_triple x = function * similarly for each ti. *) -let abstract_tycon loc env evdref subst tycon extenv t = +let abstract_tycon ?loc env evdref subst tycon extenv t = let t = nf_betaiota !evdref t in (* it helps in some cases to remove K-redex*) let src = match EConstr.kind !evdref t with - | Evar (evk,_) -> (loc,Evar_kinds.SubEvar evk) - | _ -> (loc,Evar_kinds.CasesType true) in + | Evar (evk,_) -> (Loc.tag ?loc @@ Evar_kinds.SubEvar evk) + | _ -> (Loc.tag ?loc @@ Evar_kinds.CasesType true) in let subst0,t0 = adjust_to_extended_env_and_remove_deps env extenv !evdref subst t in (* We traverse the type T of the original problem Xi looking for subterms that match the non-constructor part of the constraints (this part @@ -1692,7 +1692,7 @@ let abstract_tycon loc env evdref subst tycon extenv t = in aux (0,extenv,subst0) t0 -let build_tycon loc env tycon_env s subst tycon extenv evdref t = +let build_tycon ?loc env tycon_env s subst tycon extenv evdref t = let t,tt = match t with | None -> (* This is the situation we are building a return predicate and @@ -1700,10 +1700,10 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = let n = Context.Rel.length (rel_context env) in let n' = Context.Rel.length (rel_context tycon_env) in let impossible_case_type, u = - e_new_type_evar (reset_context env) evdref univ_flexible_alg ~src:(loc,Evar_kinds.ImpossibleCase) in + e_new_type_evar (reset_context env) evdref univ_flexible_alg ~src:(Loc.tag ?loc Evar_kinds.ImpossibleCase) in (lift (n'-n) impossible_case_type, mkSort u) | Some t -> - let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in + let t = abstract_tycon ?loc tycon_env evdref subst tycon extenv t in let evd,tt = Typing.type_of extenv !evdref t in evdref := evd; (t,tt) in @@ -1724,16 +1724,16 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = let build_inversion_problem loc env sigma tms t = let make_patvar t (subst,avoid) = let id = next_name_away (named_hd env sigma t Anonymous) avoid in - PatVar (Loc.ghost,Name id), ((id,t)::subst, id::avoid) in + CAst.make @@ PatVar (Name id), ((id,t)::subst, id::avoid) in let rec reveal_pattern t (subst,avoid as acc) = match EConstr.kind sigma (whd_all env sigma t) with - | Construct (cstr,u) -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc + | Construct (cstr,u) -> CAst.make (PatCstr (cstr,[],Anonymous)), acc | App (f,v) when isConstruct sigma f -> let cstr,u = destConstruct sigma f in let n = constructor_nrealargs_env env cstr in let l = List.lastn n (Array.to_list v) in let l,acc = List.fold_map' reveal_pattern l acc in - PatCstr (Loc.ghost,cstr,l,Anonymous), acc + CAst.make (PatCstr (cstr,l,Anonymous)), acc | _ -> make_patvar t acc in let rec aux n env acc_sign tms acc = match tms with @@ -1791,7 +1791,7 @@ let build_inversion_problem loc env sigma tms t = let main_eqn = { patterns = patl; alias_stack = []; - eqn_loc = Loc.ghost; + eqn_loc = None; used = ref false; rhs = { rhs_env = pb_env; (* we assume all vars are used; in practice we discard dependent @@ -1809,9 +1809,9 @@ let build_inversion_problem loc env sigma tms t = (* No need for a catch all clause *) [] else - [ { patterns = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) patl; + [ { patterns = List.map (fun _ -> CAst.make @@ PatVar Anonymous) patl; alias_stack = []; - eqn_loc = Loc.ghost; + eqn_loc = None; used = ref false; rhs = { rhs_env = pb_env; rhs_vars = []; @@ -1832,7 +1832,7 @@ let build_inversion_problem loc env sigma tms t = mat = main_eqn :: catch_all_eqn; caseloc = loc; casestyle = RegularStyle; - typing_function = build_tycon loc env pb_env s subst} in + typing_function = build_tycon ?loc env pb_env s subst} in let pred = (compile pb).uj_val in (!evdref,pred) @@ -1857,8 +1857,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = | None -> (match bo with | None -> [LocalAssum (na, lift n typ)] | Some b -> [LocalDef (na, lift n b, lift n typ)]) - | Some (loc,_,_) -> - user_err ~loc + | Some (loc,_) -> + user_err ?loc (str"Unexpected type annotation for a term of non inductive type.")) | IsInd (term,IndType(indf,realargs),_) -> let indf' = if dolift then lift_inductive_family n indf else indf in @@ -1868,9 +1868,9 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let arsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) arsign in let realnal = match t with - | Some (loc,ind',realnal) -> + | Some (loc,(ind',realnal)) -> if not (eq_ind ind ind') then - user_err ~loc (str "Wrong inductive type."); + user_err ?loc (str "Wrong inductive type."); if not (Int.equal nrealargs_ctxt (List.length realnal)) then anomaly (Pp.str "Ill-formed 'in' clause in cases"); List.rev realnal @@ -1885,10 +1885,10 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = | _ -> assert false in List.rev (buildrec 0 (tomatchl,tmsign)) -let inh_conv_coerce_to_tycon loc env evdref j tycon = +let inh_conv_coerce_to_tycon ?loc env evdref j tycon = match tycon with | Some p -> - let (evd',j) = Coercion.inh_conv_coerce_to true loc env !evdref j p in + let (evd',j) = Coercion.inh_conv_coerce_to ?loc true env !evdref j p in evdref := evd'; j | None -> j @@ -1971,7 +1971,7 @@ let noccur_with_meta sigma n m term = in try (occur_rec n term; true) with LocalOccur -> false -let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = +let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = let refresh_tycon sigma t = (** If we put the typing constraint in the term, it has to be refreshed to preserve the invariant that no algebraic universe @@ -2002,7 +2002,7 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = | None -> let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma ((t, _), sigma, _) = - new_type_evar env sigma univ_flexible_alg ~src:(loc, Evar_kinds.CasesType false) in + new_type_evar env sigma univ_flexible_alg ~src:(Loc.tag ?loc @@ Evar_kinds.CasesType false) in let sigma = Sigma.to_evar_map sigma in sigma, t in @@ -2064,23 +2064,24 @@ let mk_JMeq evdref typ x typ' y = let mk_JMeq_refl evdref typ x = papp evdref coq_JMeq_refl [| typ; x |] -let hole = - GHole (Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false), +let hole na = CAst.make @@ + GHole (Evar_kinds.QuestionMark (Evar_kinds.Define false,na), Misctypes.IntroAnonymous, None) let constr_of_pat env evdref arsign pat avoid = let rec typ env (ty, realargs) pat avoid = - match pat with - | PatVar (l,name) -> + let loc = pat.CAst.loc in + match pat.CAst.v with + | PatVar name -> let name, avoid = match name with Name n -> name, avoid | Anonymous -> let previd, id = prime avoid (Name (Id.of_string "wildcard")) in Name id, id :: avoid in - (PatVar (l, name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, + ((CAst.make ?loc @@ PatVar name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid) - | PatCstr (l,((_, i) as cstr),args,alias) -> + | PatCstr (((_, i) as cstr),args,alias) -> let cind = inductive_of_constructor cstr in let IndType (indf, _) = try find_rectype env ( !evdref) (lift (-(List.length realargs)) ty) @@ -2089,7 +2090,7 @@ let constr_of_pat env evdref arsign pat avoid = in let (ind,u), params = dest_ind_family indf in let params = List.map EConstr.of_constr params in - if not (eq_ind ind cind) then error_bad_constructor ~loc:l env cstr ind; + if not (eq_ind ind cind) then error_bad_constructor ?loc env cstr ind; let cstrs = get_constructors env indf in let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in @@ -2109,7 +2110,7 @@ let constr_of_pat env evdref arsign pat avoid = in let args = List.rev args in let patargs = List.rev patargs in - let pat' = PatCstr (l, cstr, patargs, alias) in + let pat' = CAst.make ?loc @@ PatCstr (cstr, patargs, alias) in let cstr = mkConstructU (on_snd EInstance.make ci.cs_cstr) in let app = applist (cstr, List.map (lift (List.length sign)) params) in let app = applist (app, args) in @@ -2165,21 +2166,21 @@ let vars_of_ctx sigma ctx = match decl with | LocalDef (na,t',t) when is_topvar sigma t' -> prev, - (GApp (Loc.ghost, - (GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)), - [hole; GVar (Loc.ghost, prev)])) :: vars + (CAst.make @@ GApp ( + (CAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)), + [hole na; CAst.make @@ GVar prev])) :: vars | _ -> match RelDecl.get_name decl with Anonymous -> invalid_arg "vars_of_ctx" - | Name n -> n, GVar (Loc.ghost, n) :: vars) + | Name n -> n, (CAst.make @@ GVar n) :: vars) ctx (Id.of_string "vars_of_ctx_error", []) in List.rev y let rec is_included x y = - match x, y with + match CAst.(x.v, y.v) with | PatVar _, _ -> true | _, PatVar _ -> true - | PatCstr (l, (_, i), args, alias), PatCstr (l', (_, i'), args', alias') -> + | PatCstr ((_, i), args, alias), PatCstr ((_, i'), args', alias') -> if Int.equal i i' then List.for_all2 is_included args args' else false @@ -2222,14 +2223,14 @@ let build_ineqs evdref prevpatterns pats liftsign = (Some ([], 0, 0, [])) eqnpats pats in match acc with None -> c - | Some (sign, len, _, c') -> - let conj = it_mkProd_or_LetIn (mk_coq_not (mk_coq_and c')) - (lift_rel_context liftsign sign) - in - conj :: c) + | Some (sign, len, _, c') -> + let sigma, conj = mk_coq_and !evdref c' in + let sigma, neg = mk_coq_not sigma conj in + let conj = it_mkProd_or_LetIn neg (lift_rel_context liftsign sign) in + evdref := sigma; conj :: c) [] prevpatterns in match diffs with [] -> None - | _ -> Some (mk_coq_and diffs) + | _ -> Some (let sigma, conj = mk_coq_and !evdref diffs in evdref := sigma; conj) let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = let i = ref 0 in @@ -2294,13 +2295,13 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in let branch_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in let branch = - let bref = GVar (Loc.ghost, branch_name) in + let bref = CAst.make @@ GVar branch_name in match vars_of_ctx !evdref rhs_rels with [] -> bref - | l -> GApp (Loc.ghost, bref, l) + | l -> CAst.make @@ GApp (bref, l) in let branch = match ineqs with - Some _ -> GApp (Loc.ghost, branch, [ hole ]) + Some _ -> CAst.make @@ GApp (branch, [ hole Anonymous ]) | None -> branch in incr i; @@ -2443,7 +2444,7 @@ let context_of_arsign l = l ([], 0) in x -let compile_program_cases loc style (typing_function, evdref) tycon env +let compile_program_cases ?loc style (typing_function, evdref) tycon env (predopt, tomatchl, eqns) = let typing_fun tycon env = function | Some t -> typing_function tycon env evdref t @@ -2550,9 +2551,9 @@ let compile_program_cases loc style (typing_function, evdref) tycon env (**************************************************************************) (* Main entry of the matching compilation *) -let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) = +let compile_cases ?loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) = if predopt == None && Flags.is_program_mode () && Program.is_program_cases () then - compile_program_cases loc style (typing_fun, evdref) + compile_program_cases ?loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) else @@ -2569,7 +2570,7 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e with the type of arguments to match; if none is provided, we build alternative possible predicates *) let arsign = extract_arity_signature env tomatchs tomatchl in - let preds = prepare_predicate loc typing_fun env !evdref tomatchs arsign tycon predopt in + let preds = prepare_predicate ?loc typing_fun env !evdref tomatchs arsign tycon predopt in let compile_for_one_predicate (sigma,nal,pred) = (* We push the initial terms to match and push their alias to rhs' envs *) @@ -2619,7 +2620,7 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e let j = compile pb in (* We coerce to the tycon (if an elim predicate was provided) *) - let j = inh_conv_coerce_to_tycon loc env myevdref j tycon in + let j = inh_conv_coerce_to_tycon ?loc env myevdref j tycon in evdref := !myevdref; j in diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 6c2b5bf68b..b16342db4b 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -38,7 +38,7 @@ val irrefutable : env -> cases_pattern -> bool (** {6 Compilation primitive. } *) val compile_cases : - Loc.t -> case_style -> + ?loc:Loc.t -> case_style -> (type_constraint -> env -> evar_map ref -> glob_constr -> unsafe_judgment) * evar_map ref -> type_constraint -> env -> glob_constr option * tomatch_tuples * cases_clauses -> @@ -65,7 +65,7 @@ type 'a equation = { patterns : cases_pattern list; rhs : 'a rhs; alias_stack : Name.t list; - eqn_loc : Loc.t; + eqn_loc : Loc.t option; used : bool ref } type 'a matrix = 'a equation list @@ -106,14 +106,14 @@ type 'a pattern_matching_problem = tomatch : tomatch_stack; history : pattern_continuation; mat : 'a matrix; - caseloc : Loc.t; + caseloc : Loc.t option; casestyle : case_style; typing_function: type_constraint -> env -> evar_map ref -> 'a option -> unsafe_judgment } val compile : 'a pattern_matching_problem -> unsafe_judgment -val prepare_predicate : Loc.t -> +val prepare_predicate : ?loc:Loc.t -> (Evarutil.type_constraint -> Environ.env -> Evd.evar_map ref -> glob_constr -> unsafe_judgment) -> Environ.env -> diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index bd7350dc4e..782552583d 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -177,7 +177,7 @@ let cofixp_reducible flgs _ stk = let debug_cbv = ref false let _ = Goptions.declare_bool_option { - Goptions.optsync = true; Goptions.optdepr = false; + Goptions.optdepr = false; Goptions.optname = "cbv visited constants display"; Goptions.optkey = ["Debug";"Cbv"]; Goptions.optread = (fun () -> !debug_cbv); diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 32da81f96c..9a973cff55 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -428,8 +428,7 @@ let automatically_import_coercions = ref false open Goptions let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "automatic import of coercions"; optkey = ["Automatic";"Coercions";"Import"]; optread = (fun () -> !automatically_import_coercions); @@ -556,7 +555,6 @@ module CoercionPrinting = let member_message x b = str "Explicit printing of coercion " ++ printer x ++ str (if b then " is set" else " is unset") - let synchronous = true end module PrintingCoercion = Goptions.MakeRefTable(CoercionPrinting) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index e6c0075c5b..83c26058ac 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -33,14 +33,13 @@ open Globnames let use_typeclasses_for_conversion = ref true let _ = - Goptions.declare_bool_option - { Goptions.optsync = true; - optdepr = false; + Goptions.(declare_bool_option + { optdepr = false; optname = "use typeclass resolution during conversion"; optkey = ["Typeclass"; "Resolution"; "For"; "Conversion"]; optread = (fun () -> !use_typeclasses_for_conversion); optwrite = (fun b -> use_typeclasses_for_conversion := b) } - + ) (* Typing operations dealing with coercions *) exception NoCoercion @@ -74,24 +73,25 @@ let apply_coercion_args env evd check isproj argl funj = !evdref, res (* appliquer le chemin de coercions de patterns p *) -let apply_pattern_coercion loc pat p = +let apply_pattern_coercion ?loc pat p = List.fold_left (fun pat (co,n) -> - let f i = if i<n then Glob_term.PatVar (loc, Anonymous) else pat in - Glob_term.PatCstr (loc, co, List.init (n+1) f, Anonymous)) + let f i = + if i<n then (CAst.make ?loc @@ Glob_term.PatVar Anonymous) else pat in + CAst.make ?loc @@ Glob_term.PatCstr (co, List.init (n+1) f, Anonymous)) pat p (* raise Not_found if no coercion found *) -let inh_pattern_coerce_to loc env pat ind1 ind2 = +let inh_pattern_coerce_to ?loc env pat ind1 ind2 = let p = lookup_pattern_path_between env (ind1,ind2) in - apply_pattern_coercion loc pat p + apply_pattern_coercion ?loc pat p (* Program coercions *) open Program -let make_existential loc ?(opaque = not (get_proofs_transparency ())) env evdref c = - let src = (loc, Evar_kinds.QuestionMark (Evar_kinds.Define opaque)) in +let make_existential ?loc ?(opaque = not (get_proofs_transparency ())) na env evdref c = + let src = Loc.tag ?loc (Evar_kinds.QuestionMark (Evar_kinds.Define opaque,na)) in Evarutil.e_new_evar env evdref ~src c let app_opt env evdref f t = @@ -140,7 +140,7 @@ let mu env evdref t = | None -> (None, v) in aux t -and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) +and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) : (EConstr.constr -> EConstr.constr) option = let open Context.Rel.Declaration in @@ -181,7 +181,7 @@ and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in let pred = mkLambda (n, eqT, applist (lift 1 c, args)) in let eq = papp evdref coq_eq_ind [| eqT; hdx; hdy |] in - let evar = make_existential loc env evdref eq in + let evar = make_existential ?loc n env evdref eq in let eq_app x = papp evdref coq_eq_rect [| eqT; hdx; pred; x; hdy; evar|] in @@ -324,7 +324,7 @@ and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) Some (fun x -> let cx = app_opt env evdref c x in - let evar = make_existential loc env evdref (mkApp (p, [| cx |])) + let evar = make_existential ?loc Anonymous env evdref (mkApp (p, [| cx |])) in (papp evdref sig_intro [| u; p; cx; evar |])) | None -> @@ -338,9 +338,9 @@ let app_coercion env evdref coercion v = let v' = Typing.e_solve_evars env evdref (f v) in whd_betaiota !evdref v' -let coerce_itf loc env evd v t c1 = +let coerce_itf ?loc env evd v t c1 = let evdref = ref evd in - let coercion = coerce loc env evdref t c1 in + let coercion = coerce ?loc env evdref t c1 in let t = Option.map (app_coercion env evdref coercion) v in !evdref, t @@ -408,16 +408,16 @@ let type_judgment env sigma j = | Sort s -> {utj_val = j.uj_val; utj_type = ESorts.kind sigma s } | _ -> error_not_a_type env sigma j -let inh_tosort_force loc env evd j = +let inh_tosort_force ?loc env evd j = try let t,p = lookup_path_to_sort_from env evd j.uj_type in let evd,j1 = apply_coercion env evd p j t in let j2 = on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env evd j2) with Not_found | NoCoercion -> - error_not_a_type ~loc env evd j + error_not_a_type ?loc env evd j -let inh_coerce_to_sort loc env evd j = +let inh_coerce_to_sort ?loc env evd j = let typ = whd_all env evd j.uj_type in match EConstr.kind evd typ with | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = ESorts.kind evd s }) @@ -425,9 +425,9 @@ let inh_coerce_to_sort loc env evd j = let (evd',s) = Evardefine.define_evar_as_sort env evd ev in (evd',{ utj_val = j.uj_val; utj_type = s }) | _ -> - inh_tosort_force loc env evd j + inh_tosort_force ?loc env evd j -let inh_coerce_to_base loc env evd j = +let inh_coerce_to_base ?loc env evd j = if Flags.is_program_mode () then let evdref = ref evd in let ct, typ' = mu env evdref j.uj_type in @@ -437,7 +437,7 @@ let inh_coerce_to_base loc env evd j = in !evdref, res else (evd, j) -let inh_coerce_to_prod loc env evd t = +let inh_coerce_to_prod ?loc env evd t = if Flags.is_program_mode () then let evdref = ref evd in let _, typ' = mu env evdref t in @@ -464,7 +464,7 @@ let inh_coerce_to_fail env evd rigidonly v t c1 = try (the_conv_x_leq env t' c1 evd, v') with UnableToUnify _ -> raise NoCoercion -let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = +let rec inh_conv_coerce_to_fail ?loc env evd rigidonly v t c1 = try (the_conv_x_leq env t c1 evd, v) with UnableToUnify (best_failed_evd,e) -> try inh_coerce_to_fail env evd rigidonly v t c1 @@ -486,49 +486,50 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = let open Context.Rel.Declaration in let env1 = push_rel (LocalAssum (name,u1)) env in let (evd', v1) = - inh_conv_coerce_to_fail loc env1 evd rigidonly + inh_conv_coerce_to_fail ?loc env1 evd rigidonly (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in let v1 = Option.get v1 in let v2 = Option.map (fun v -> beta_applist evd' (lift 1 v,[v1])) v in let t2 = match v2 with | None -> subst_term evd' v1 t2 | Some v2 -> Retyping.get_type_of env1 evd' v2 in - let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in + let (evd'',v2') = inh_conv_coerce_to_fail ?loc env1 evd' rigidonly v2 t2 u2 in (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e)) (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) -let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t = +let inh_conv_coerce_to_gen ?loc resolve_tc rigidonly env evd cj t = let (evd', val') = try - inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t + inh_conv_coerce_to_fail ?loc env evd rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (best_failed_evd,e) -> try if Flags.is_program_mode () then - coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t + coerce_itf ?loc env evd (Some cj.uj_val) cj.uj_type t else raise NoSubtacCoercion with | NoSubtacCoercion when not resolve_tc || not !use_typeclasses_for_conversion -> - error_actual_type ~loc env best_failed_evd cj t e + error_actual_type ?loc env best_failed_evd cj t e | NoSubtacCoercion -> let evd' = saturate_evd env evd in try if evd' == evd then - error_actual_type ~loc env best_failed_evd cj t e + error_actual_type ?loc env best_failed_evd cj t e else - inh_conv_coerce_to_fail loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t + inh_conv_coerce_to_fail ?loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (_evd,_error) -> - error_actual_type ~loc env best_failed_evd cj t e + error_actual_type ?loc env best_failed_evd cj t e in let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) -let inh_conv_coerce_to resolve_tc = inh_conv_coerce_to_gen resolve_tc false -let inh_conv_coerce_rigid_to resolve_tc = inh_conv_coerce_to_gen resolve_tc true +let inh_conv_coerce_to ?loc resolve_tc = inh_conv_coerce_to_gen ?loc resolve_tc false + +let inh_conv_coerce_rigid_to ?loc resolve_tc = inh_conv_coerce_to_gen resolve_tc ?loc true -let inh_conv_coerces_to loc env evd t t' = +let inh_conv_coerces_to ?loc env evd t t' = try - fst (inh_conv_coerce_to_fail loc env evd true None t t') + fst (inh_conv_coerce_to_fail ?loc env evd true None t t') with NoCoercion -> evd (* Maybe not enough information to unify *) diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli index ea3d3f0fa1..ab1f6c110f 100644 --- a/pretyping/coercion.mli +++ b/pretyping/coercion.mli @@ -25,17 +25,17 @@ val inh_app_fun : bool -> (** [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it inserts a coercion into [j], if needed, in such a way it gets as type a sort; it fails if no coercion is applicable *) -val inh_coerce_to_sort : Loc.t -> +val inh_coerce_to_sort : ?loc:Loc.t -> env -> evar_map -> unsafe_judgment -> evar_map * unsafe_type_judgment (** [inh_coerce_to_base env isevars j] coerces [j] to its base type; i.e. it inserts a coercion into [j], if needed, in such a way it gets as type its base type (the notion depends on the coercion system) *) -val inh_coerce_to_base : Loc.t -> +val inh_coerce_to_base : ?loc:Loc.t -> env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment (** [inh_coerce_to_prod env isevars t] coerces [t] to a product type *) -val inh_coerce_to_prod : Loc.t -> +val inh_coerce_to_prod : ?loc:Loc.t -> env -> evar_map -> types -> evar_map * types (** [inh_conv_coerce_to resolve_tc Loc.t env isevars j t] coerces [j] to an @@ -43,20 +43,20 @@ val inh_coerce_to_prod : Loc.t -> a way [t] and [j.uj_type] are convertible; it fails if no coercion is applicable. resolve_tc=false disables resolving type classes (as the last resort before failing) *) -val inh_conv_coerce_to : bool -> Loc.t -> +val inh_conv_coerce_to : ?loc:Loc.t -> bool -> env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment -val inh_conv_coerce_rigid_to : bool -> Loc.t -> +val inh_conv_coerce_rigid_to : ?loc:Loc.t -> bool -> env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment (** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t] is coercible to an object of type [t'] adding evar constraints if needed; it fails if no coercion exists *) -val inh_conv_coerces_to : Loc.t -> +val inh_conv_coerces_to : ?loc:Loc.t -> env -> evar_map -> types -> types -> evar_map (** [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases pattern [pat] typed in [ind1] into a pattern typed in [ind2]; raises [Not_found] if no coercion found *) val inh_pattern_coerce_to : - Loc.t -> env -> cases_pattern -> inductive -> inductive -> cases_pattern + ?loc:Loc.t -> env -> cases_pattern -> inductive -> inductive -> cases_pattern diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index edcfa99c86..2cb837ba03 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -220,9 +220,9 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels | PSoApp (n,args),m -> let fold (ans, seen) = function | PRel n -> - let () = if Int.Set.mem n seen then error "Non linear second-order pattern" in + let () = if Int.Set.mem n seen then user_err (str "Non linear second-order pattern") in (n :: ans, Int.Set.add n seen) - | _ -> error "Only bound indices allowed in second order pattern matching." + | _ -> user_err (str "Only bound indices allowed in second order pattern matching.") in let relargs, relset = List.fold_left fold ([], Int.Set.empty) args in let frels = free_rels sigma cT in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 0d798b4d94..6f099c8dfd 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -28,8 +28,6 @@ open Misctypes open Decl_kinds open Context.Named.Declaration -let dl = Loc.ghost - (** Should we keep details of universes during detyping ? *) let print_universes = Flags.univ_print @@ -69,14 +67,14 @@ let isomorphic_to_tuple lc = Int.equal (Array.length lc) 1 let encode_bool r = let (x,lc) = encode_inductive r in if not (has_two_constructors lc) then - user_err ~loc:(loc_of_reference r) ~hdr:"encode_if" + user_err ?loc:(loc_of_reference r) ~hdr:"encode_if" (str "This type has not exactly two constructors."); x let encode_tuple r = let (x,lc) = encode_inductive r in if not (isomorphic_to_tuple lc) then - user_err ~loc:(loc_of_reference r) ~hdr:"encode_tuple" + user_err ?loc:(loc_of_reference r) ~hdr:"encode_tuple" (str "This type cannot be seen as a tuple type."); x @@ -135,8 +133,7 @@ let wildcard_value = ref true let force_wildcard () = !wildcard_value let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "forced wildcard"; optkey = ["Printing";"Wildcard"]; optread = force_wildcard; @@ -146,8 +143,7 @@ let synth_type_value = ref true let synthetize_type () = !synth_type_value let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "pattern matching return type synthesizability"; optkey = ["Printing";"Synth"]; optread = synthetize_type; @@ -157,8 +153,7 @@ let reverse_matching_value = ref true let reverse_matching () = !reverse_matching_value let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "pattern-matching reversibility"; optkey = ["Printing";"Matching"]; optread = reverse_matching; @@ -168,8 +163,7 @@ let print_primproj_params_value = ref false let print_primproj_params () = !print_primproj_params_value let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "printing of primitive projection parameters"; optkey = ["Printing";"Primitive";"Projection";"Parameters"]; optread = print_primproj_params; @@ -179,8 +173,7 @@ let print_primproj_compatibility_value = ref false let print_primproj_compatibility () = !print_primproj_compatibility_value let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "backwards-compatible printing of primitive projections"; optkey = ["Printing";"Primitive";"Projection";"Compatibility"]; optread = print_primproj_compatibility; @@ -284,7 +277,7 @@ let rec decomp_branch tags nal b (avoid,env as e) sigma c = (avoid', add_name_opt na' body t env) sigma c let rec build_tree na isgoal e sigma ci cl = - let mkpat n rhs pl = PatCstr(dl,(ci.ci_ind,n+1),pl,update_name sigma na rhs) in + let mkpat n rhs pl = CAst.make @@ PatCstr((ci.ci_ind,n+1),pl,update_name sigma na rhs) in let cnl = ci.ci_pp_info.cstr_tags in let cna = ci.ci_cstr_nargs in List.flatten @@ -307,7 +300,7 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with List.map (fun (hd,rest) -> pat::hd,rest) lines) clauses) | _ -> - let pat = PatVar(dl,update_name sigma na rhs) in + let pat = CAst.make @@ PatVar(update_name sigma na rhs) in let mat = align_tree nal isgoal rhs sigma in List.map (fun (hd,rest) -> pat::hd,rest) mat @@ -330,20 +323,20 @@ let is_nondep_branch sigma c l = let extract_nondep_branches test c b l = let rec strip l r = - match r,l with - | r, [] -> r - | GLambda (_,_,_,_,t), false::l -> strip l t - | GLetIn (_,_,_,_,t), true::l -> strip l t + match r.CAst.v, l with + | r', [] -> r + | GLambda (_,_,_,t), false::l -> strip l t + | 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 let it_destRLambda_or_LetIn_names l c = let rec aux l nal c = - match c, l with + match c.CAst.v, l with | _, [] -> (List.rev nal,c) - | GLambda (_,na,_,_,c), false::l -> aux l (na::nal) c - | GLetIn (_,na,_,_,c), true::l -> aux l (na::nal) c + | GLambda (na,_,_,c), false::l -> aux l (na::nal) c + | GLetIn (na,_,_,c), true::l -> aux l (na::nal) c | _, true::l -> (* let-expansion *) aux l (Anonymous :: nal) c | _, false::l -> (* eta-expansion *) @@ -354,11 +347,11 @@ let it_destRLambda_or_LetIn_names l c = x in let x = next (free_glob_vars c) in - let a = GVar (dl,x) in + let a = CAst.make @@ GVar x in aux l (Name x :: nal) (match c with - | GApp (loc,p,l) -> GApp (loc,p,l@[a]) - | _ -> (GApp (dl,c,[a]))) + | { loc; CAst.v = GApp (p,l) } -> CAst.make ?loc @@ GApp (p,l@[a]) + | _ -> CAst.make @@ GApp (c,[a])) in aux l [] c let detype_case computable detype detype_eqns testdep avoid data p c bl = @@ -374,12 +367,12 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl = | None -> Anonymous, None, None | Some p -> let nl,typ = it_destRLambda_or_LetIn_names k p in - let n,typ = match typ with - | GLambda (_,x,_,t,c) -> x, c + let n,typ = match typ.CAst.v with + | GLambda (x,_,t,c) -> x, c | _ -> Anonymous, typ in let aliastyp = if List.for_all (Name.equal Anonymous) nl then None - else Some (dl,indsp,nl) in + else Some (Loc.tag (indsp,nl)) in n, aliastyp, Some typ in let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in @@ -401,20 +394,20 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl = | LetStyle, None -> let bl' = Array.map detype bl in let (nal,d) = it_destRLambda_or_LetIn_names constagsl.(0) bl'.(0) in - GLetTuple (dl,nal,(alias,pred),tomatch,d) + 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 (dl,tomatch,(alias,pred), + GIf (tomatch,(alias,pred), Option.get nondepbrs.(0),Option.get nondepbrs.(1)) else let eqnl = detype_eqns constructs constagsl bl in - GCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl) + GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) | _ -> let eqnl = detype_eqns constructs constagsl bl in - GCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl) + GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) let detype_sort sigma = function | Prop Null -> GProp @@ -424,7 +417,7 @@ let detype_sort sigma = function (if !print_universes then let u = Pp.string_of_ppcmds (Univ.Universe.pr_with (Termops.pr_evd_level sigma) u) in - [dl, Name.mk_name (Id.of_string_soft u)] + [Loc.tag @@ Name.mk_name (Id.of_string_soft u)] else []) type binder_kind = BProd | BLambda | BLetIn @@ -432,37 +425,37 @@ type binder_kind = BProd | BLambda | BLetIn (**********************************************************************) (* Main detyping function *) -let detype_anonymous = ref (fun loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable")) +let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable")) let set_detype_anonymous f = detype_anonymous := f let detype_level sigma l = let l = Pp.string_of_ppcmds (Termops.pr_evd_level sigma l) in - GType (Some (dl, Name.mk_name (Id.of_string_soft l))) + GType (Some (Loc.tag @@ Name.mk_name (Id.of_string_soft l))) let detype_instance sigma l = let l = EInstance.kind sigma l in if Univ.Instance.is_empty l then None else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) -let rec detype flags avoid env sigma t = +let rec detype flags avoid env sigma t = CAst.make @@ match EConstr.kind sigma (collapse_appl sigma t) with | Rel n -> (try match lookup_name_of_rel n (fst env) with - | Name id -> GVar (dl, id) - | Anonymous -> !detype_anonymous dl n + | Name id -> GVar id + | Anonymous -> (!detype_anonymous n).CAst.v with Not_found -> let s = "_UNBOUND_REL_"^(string_of_int n) - in GVar (dl, Id.of_string s)) + in GVar (Id.of_string s)) | Meta n -> (* Meta in constr are not user-parsable and are mapped to Evar *) (* using numbers to be unparsable *) - GEvar (dl, Id.of_string ("M" ^ string_of_int n), []) + GEvar (Id.of_string ("M" ^ string_of_int n), []) | Var id -> - (try let _ = Global.lookup_named id in GRef (dl, VarRef id, None) - with Not_found -> GVar (dl, id)) - | Sort s -> GSort (dl,detype_sort sigma (ESorts.kind sigma s)) + (try let _ = Global.lookup_named id in GRef (VarRef id, None) + with Not_found -> GVar id) + | Sort s -> GSort (detype_sort sigma (ESorts.kind sigma s)) | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> - detype flags avoid env sigma c1 + (detype flags avoid env sigma c1).CAst.v | Cast (c1,k,c2) -> let d1 = detype flags avoid env sigma c1 in let d2 = detype flags avoid env sigma c2 in @@ -471,34 +464,34 @@ let rec detype flags avoid env sigma t = | NATIVEcast -> CastNative d2 | _ -> CastConv d2 in - GCast(dl,d1,cast) + GCast(d1,cast) | Prod (na,ty,c) -> detype_binder flags BProd avoid env sigma na None ty c | Lambda (na,ty,c) -> detype_binder flags BLambda avoid env sigma na None ty c | LetIn (na,b,ty,c) -> detype_binder flags BLetIn avoid env sigma na (Some b) ty c | App (f,args) -> let mkapp f' args' = - match f' with - | GApp (dl',f',args'') -> - GApp (dl,f',args''@args') - | _ -> GApp (dl,f',args') + match f'.CAst.v with + | GApp (f',args'') -> + GApp (f',args''@args') + | _ -> GApp (f',args') in mkapp (detype flags avoid env sigma f) (Array.map_to_list (detype flags avoid env sigma) args) - | Const (sp,u) -> GRef (dl, ConstRef sp, detype_instance sigma u) + | Const (sp,u) -> GRef (ConstRef sp, detype_instance sigma u) | Proj (p,c) -> let noparams () = let pb = Environ.lookup_projection p (snd env) in let pars = pb.Declarations.proj_npars in - let hole = GHole(Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in + let hole = CAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in let args = List.make pars hole in - GApp (dl, GRef (dl, ConstRef (Projection.constant p), None), + GApp (CAst.make @@ GRef (ConstRef (Projection.constant p), None), (args @ [detype flags avoid env sigma c])) in if fst flags || !Flags.in_debugger || !Flags.in_toplevel then try noparams () with _ -> (* lax mode, used by debug printers only *) - GApp (dl, GRef (dl, ConstRef (Projection.constant p), None), + GApp (CAst.make @@ GRef (ConstRef (Projection.constant p), None), [detype flags avoid env sigma c]) else if print_primproj_compatibility () && Projection.unfolded p then @@ -516,12 +509,12 @@ let rec detype flags avoid env sigma t = substl (c :: List.rev args) body' with Retyping.RetypeError _ | Not_found -> anomaly (str"Cannot detype an unfolded primitive projection.") - in detype flags avoid env sigma c' + in (detype flags avoid env sigma c').CAst.v else if print_primproj_params () then try let c = Retyping.expand_projection (snd env) sigma p c [] in - detype flags avoid env sigma c + (detype flags avoid env sigma c).CAst.v with Retyping.RetypeError _ -> noparams () else noparams () @@ -548,12 +541,12 @@ let rec detype flags avoid env sigma t = Id.of_string ("X" ^ string_of_int (Evar.repr evk)), (Array.map_to_list (fun c -> (Id.of_string "__",c)) cl) in - GEvar (dl,id, + GEvar (id, List.map (on_snd (detype flags avoid env sigma)) l) | Ind (ind_sp,u) -> - GRef (dl, IndRef ind_sp, detype_instance sigma u) + GRef (IndRef ind_sp, detype_instance sigma u) | Construct (cstr_sp,u) -> - GRef (dl, ConstructRef cstr_sp, detype_instance sigma u) + GRef (ConstructRef cstr_sp, detype_instance sigma u) | Case (ci,p,c,bl) -> let comp = computable sigma p (List.length (ci.ci_pp_info.ind_tags)) in detype_case comp (detype flags avoid env sigma) @@ -576,7 +569,7 @@ and detype_fix flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) = let v = Array.map3 (fun c t i -> share_names flags (i+1) [] def_avoid def_env sigma c (lift n t)) bodies tys vn in - GRec(dl,GFix (Array.map (fun i -> Some i, GStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi), + GRec(GFix (Array.map (fun i -> Some i, GStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) @@ -592,7 +585,7 @@ and detype_cofix flags avoid env sigma n (names,tys,bodies) = let v = Array.map2 (fun c t -> share_names flags 0 [] def_avoid def_env sigma c (lift ntys t)) bodies tys in - GRec(dl,GCoFix n,Array.of_list (List.rev lfi), + GRec(GCoFix n,Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) @@ -637,7 +630,7 @@ and detype_eqns flags avoid env sigma ci computable constructs consnargsl bl = try if !Flags.raw_print || not (reverse_matching ()) then raise Exit; let mat = build_tree Anonymous (snd flags) (avoid,env) sigma ci bl in - List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype flags avoid env sigma c)) + List.map (fun (pat,((avoid,env),c)) -> Loc.tag ([],[pat],detype flags avoid env sigma c)) mat with e when CErrors.noncritical e -> Array.to_list @@ -646,17 +639,17 @@ and detype_eqns flags avoid env sigma ci computable constructs consnargsl bl = and detype_eqn (lax,isgoal as flags) avoid env sigma constr construct_nargs branch = let make_pat x avoid env b body ty ids = if force_wildcard () && noccurn sigma 1 b then - PatVar (dl,Anonymous),avoid,(add_name Anonymous body ty env),ids + CAst.make @@ PatVar Anonymous,avoid,(add_name Anonymous body ty env),ids else let flag = if isgoal then RenamingForGoal else RenamingForCasesPattern (fst env,b) in let na,avoid' = compute_displayed_name_in sigma flag avoid x b in - PatVar (dl,na),avoid',(add_name na body ty env),add_vname ids na + CAst.make (PatVar na),avoid',(add_name na body ty env),add_vname ids na in let rec buildrec ids patlist avoid env l b = match EConstr.kind sigma b, l with - | _, [] -> - (dl, Id.Set.elements ids, - [PatCstr(dl, constr, List.rev patlist,Anonymous)], + | _, [] -> Loc.tag @@ + (Id.Set.elements ids, + [CAst.make @@ PatCstr(constr, List.rev patlist,Anonymous)], detype flags avoid env sigma b) | Lambda (x,t,b), false::l -> let pat,new_avoid,new_env,new_ids = make_pat x avoid env b None t ids in @@ -670,7 +663,7 @@ and detype_eqn (lax,isgoal as flags) avoid env sigma constr construct_nargs bran buildrec ids patlist avoid env l c | _, true::l -> - let pat = PatVar (dl,Anonymous) in + let pat = CAst.make @@ PatVar Anonymous in buildrec ids (pat::patlist) avoid env l b | _, false::l -> @@ -692,14 +685,14 @@ and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c = | _ -> compute_displayed_name_in sigma flag avoid na c in let r = detype flags avoid' (add_name na' body ty env) sigma c in match bk with - | BProd -> GProd (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r) - | BLambda -> GLambda (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r) + | BProd -> GProd (na',Explicit,detype (lax,false) avoid env sigma ty, r) + | BLambda -> GLambda (na',Explicit,detype (lax,false) avoid env sigma ty, r) | BLetIn -> let c = detype (lax,false) avoid env sigma (Option.get body) in (* Heuristic: we display the type if in Prop *) let s = try Retyping.get_sort_family_of (snd env) sigma ty with _ when !Flags.in_debugger || !Flags.in_toplevel -> InType (* Can fail because of sigma missing in debugger *) in let t = if s != InProp && not !Flags.raw_print then None else Some (detype (lax,false) avoid env sigma ty) in - GLetIn (dl, na', c, t, r) + GLetIn (na', c, t, r) let detype_rel_context ?(lax=false) where avoid env sigma sign = let where = Option.map (fun c -> EConstr.it_mkLambda_or_LetIn c sign) where in @@ -743,11 +736,11 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = | Name id -> Name (convert_id cl id) | Anonymous -> Anonymous in - let rec detype_closed_glob cl = function - | GVar (loc,id) -> + let rec detype_closed_glob cl cg : Glob_term.glob_constr = CAst.map (function + | GVar id -> (* if [id] is bound to a name. *) begin try - GVar(loc,Id.Map.find id cl.idents) + GVar(Id.Map.find id cl.idents) (* if [id] is bound to a typed term *) with Not_found -> try (* assumes [detype] does not raise [Not_found] exceptions *) @@ -757,127 +750,128 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = [Printer.pr_constr_under_binders_env] does. *) let assums = List.map (fun id -> LocalAssum (Name id,(* dummy *) mkProp)) b in let env = push_rel_context assums env in - detype ?lax isgoal avoid env sigma c + (detype ?lax isgoal avoid env sigma c).CAst.v (* if [id] is bound to a [closed_glob_constr]. *) with Not_found -> try let {closure;term} = Id.Map.find id cl.untyped in - detype_closed_glob closure term + (detype_closed_glob closure term).CAst.v (* Otherwise [id] stands for itself *) with Not_found -> - GVar(loc,id) + GVar id end - | GLambda (loc,id,k,t,c) -> + | GLambda (id,k,t,c) -> let id = convert_name cl id in - GLambda(loc,id,k,detype_closed_glob cl t, detype_closed_glob cl c) - | GProd (loc,id,k,t,c) -> + GLambda(id,k,detype_closed_glob cl t, detype_closed_glob cl c) + | GProd (id,k,t,c) -> let id = convert_name cl id in - GProd(loc,id,k,detype_closed_glob cl t, detype_closed_glob cl c) - | GLetIn (loc,id,b,t,e) -> + GProd(id,k,detype_closed_glob cl t, detype_closed_glob cl c) + | GLetIn (id,b,t,e) -> let id = convert_name cl id in - GLetIn(loc,id,detype_closed_glob cl b, Option.map (detype_closed_glob cl) t, detype_closed_glob cl e) - | GLetTuple (loc,ids,(n,r),b,e) -> + GLetIn(id,detype_closed_glob cl b, Option.map (detype_closed_glob cl) t, detype_closed_glob cl e) + | GLetTuple (ids,(n,r),b,e) -> let ids = List.map (convert_name cl) ids in let n = convert_name cl n in - GLetTuple (loc,ids,(n,r),detype_closed_glob cl b, detype_closed_glob cl e) - | GCases (loc,sty,po,tml,eqns) -> + GLetTuple (ids,(n,r),detype_closed_glob cl b, detype_closed_glob cl e) + | GCases (sty,po,tml,eqns) -> let (tml,eqns) = Glob_ops.map_pattern_binders (fun na -> convert_name cl na) tml eqns in let (tml,eqns) = Glob_ops.map_pattern (fun c -> detype_closed_glob cl c) tml eqns in - GCases(loc,sty,po,tml,eqns) + GCases(sty,po,tml,eqns) | c -> - Glob_ops.map_glob_constr (detype_closed_glob cl) c + (Glob_ops.map_glob_constr (detype_closed_glob cl) cg).CAst.v + ) cg in detype_closed_glob t.closure t.term (**********************************************************************) (* Module substitution: relies on detyping *) -let rec subst_cases_pattern subst pat = - match pat with - | PatVar _ -> pat - | PatCstr (loc,((kn,i),j),cpl,n) -> +let rec subst_cases_pattern subst = CAst.map (function + | PatVar _ as pat -> pat + | PatCstr (((kn,i),j),cpl,n) as pat -> let kn' = subst_mind subst kn and cpl' = List.smartmap (subst_cases_pattern subst) cpl in if kn' == kn && cpl' == cpl then pat else - PatCstr (loc,((kn',i),j),cpl',n) + PatCstr (((kn',i),j),cpl',n) + ) let (f_subst_genarg, subst_genarg_hook) = Hook.make () -let rec subst_glob_constr subst raw = - match raw with - | GRef (loc,ref,u) -> +let rec subst_glob_constr subst = CAst.map (function + | GRef (ref,u) as raw -> let ref',t = subst_global subst ref in if ref' == ref then raw else - detype false [] (Global.env()) Evd.empty (EConstr.of_constr t) + (detype false [] (Global.env()) Evd.empty (EConstr.of_constr t)).CAst.v - | GVar _ -> raw - | GEvar _ -> raw - | GPatVar _ -> raw + | GSort _ + | GVar _ + | GEvar _ + | GPatVar _ as raw -> raw - | GApp (loc,r,rl) -> + | GApp (r,rl) as raw -> let r' = subst_glob_constr subst r and rl' = List.smartmap (subst_glob_constr subst) rl in if r' == r && rl' == rl then raw else - GApp(loc,r',rl') + GApp(r',rl') - | GLambda (loc,n,bk,r1,r2) -> + | GLambda (n,bk,r1,r2) as raw -> let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in if r1' == r1 && r2' == r2 then raw else - GLambda (loc,n,bk,r1',r2') + GLambda (n,bk,r1',r2') - | GProd (loc,n,bk,r1,r2) -> + | GProd (n,bk,r1,r2) as raw -> let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in if r1' == r1 && r2' == r2 then raw else - GProd (loc,n,bk,r1',r2') + GProd (n,bk,r1',r2') - | GLetIn (loc,n,r1,t,r2) -> + | GLetIn (n,r1,t,r2) as raw -> let r1' = subst_glob_constr subst r1 in - let t' = Option.smartmap (subst_glob_constr subst) t in let r2' = subst_glob_constr subst r2 in + let t' = Option.smartmap (subst_glob_constr subst) t in if r1' == r1 && t == t' && r2' == r2 then raw else - GLetIn (loc,n,r1',t',r2') + GLetIn (n,r1',t',r2') - | GCases (loc,sty,rtno,rl,branches) -> + | GCases (sty,rtno,rl,branches) as raw -> let rtno' = Option.smartmap (subst_glob_constr subst) rtno and rl' = List.smartmap (fun (a,x as y) -> let a' = subst_glob_constr subst a in let (n,topt) = x in let topt' = Option.smartmap - (fun (loc,(sp,i),y as t) -> + (fun ((loc,((sp,i),y) as t)) -> let sp' = subst_mind subst sp in - if sp == sp' then t else (loc,(sp',i),y)) topt in + if sp == sp' then t else (loc,((sp',i),y))) topt in if a == a' && topt == topt' then y else (a',(n,topt'))) rl and branches' = List.smartmap - (fun (loc,idl,cpl,r as branch) -> + (fun (loc,(idl,cpl,r) as branch) -> let cpl' = List.smartmap (subst_cases_pattern subst) cpl and r' = subst_glob_constr subst r in if cpl' == cpl && r' == r then branch else - (loc,idl,cpl',r')) + (loc,(idl,cpl',r'))) branches in if rtno' == rtno && rl' == rl && branches' == branches then raw else - GCases (loc,sty,rtno',rl',branches') + GCases (sty,rtno',rl',branches') - | GLetTuple (loc,nal,(na,po),b,c) -> + | GLetTuple (nal,(na,po),b,c) as raw -> let po' = Option.smartmap (subst_glob_constr subst) po and b' = subst_glob_constr subst b and c' = subst_glob_constr subst c in if po' == po && b' == b && c' == c then raw else - GLetTuple (loc,nal,(na,po'),b',c') + GLetTuple (nal,(na,po'),b',c') - | GIf (loc,c,(na,po),b1,b2) -> + | GIf (c,(na,po),b1,b2) as raw -> let po' = Option.smartmap (subst_glob_constr subst) po and b1' = subst_glob_constr subst b1 and b2' = subst_glob_constr subst b2 and c' = subst_glob_constr subst c in if c' == c && po' == po && b1' == b1 && b2' == b2 then raw else - GIf (loc,c',(na,po'),b1',b2') + GIf (c',(na,po'),b1',b2') - | GRec (loc,fix,ida,bl,ra1,ra2) -> + | GRec (fix,ida,bl,ra1,ra2) as raw -> let ra1' = Array.smartmap (subst_glob_constr subst) ra1 and ra2' = Array.smartmap (subst_glob_constr subst) ra2 in let bl' = Array.smartmap @@ -887,11 +881,9 @@ let rec subst_glob_constr subst raw = if ty'==ty && obd'==obd then dcl else (na,k,obd',ty'))) bl in if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else - GRec (loc,fix,ida,bl',ra1',ra2') - - | GSort _ -> raw + GRec (fix,ida,bl',ra1',ra2') - | GHole (loc, knd, naming, solve) -> + | GHole (knd, naming, solve) as raw -> let nknd = match knd with | Evar_kinds.ImplicitArg (ref, i, b) -> let nref, _ = subst_global subst ref in @@ -900,25 +892,25 @@ let rec subst_glob_constr subst raw = in let nsolve = Option.smartmap (Hook.get f_subst_genarg subst) solve in if nsolve == solve && nknd == knd then raw - else GHole (loc, nknd, naming, nsolve) + else GHole (nknd, naming, nsolve) - | GCast (loc,r1,k) -> + | GCast (r1,k) as raw -> let r1' = subst_glob_constr subst r1 in let k' = Miscops.smartmap_cast_type (subst_glob_constr subst) k in - if r1' == r1 && k' == k then raw else GCast (loc,r1',k') + if r1' == r1 && k' == k then raw else GCast (r1',k') + ) (* 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 = PatVar (Loc.ghost,na) in - let p = PatCstr (Loc.ghost,(ind,i+1),List.map mkPatVar nal,Anonymous) in - let map name = try Some (Nameops.out_name name) with Failure _ -> None in - let ids = List.map_filter map nal in - (Loc.ghost,ids,[p],c)) + let mkPatVar na = CAst.make @@ PatVar na in + let p = CAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in + let ids = List.map_filter Nameops.Name.to_option nal in + Loc.tag @@ (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 (Loc.ghost, ind, List.tl nal)), Some p + (List.hd nal, Some (Loc.tag (ind, List.tl nal))), Some p diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 4c6f9129f6..da287ae9f0 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -35,14 +35,6 @@ val detype_names : bool -> Id.t list -> names_context -> env -> evar_map -> cons val detype : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> constr -> glob_constr -val detype_case : - bool -> (constr -> glob_constr) -> - (constructor array -> bool list array -> constr array -> - (Loc.t * Id.t list * cases_pattern list * glob_constr) list) -> - (constr -> bool list -> bool) -> - Id.t list -> inductive * case_style * bool list array * bool list -> - constr option -> constr -> constr array -> glob_constr - val detype_sort : evar_map -> sorts -> glob_sort val detype_rel_context : ?lax:bool -> constr option -> Id.t list -> (names_context * env) -> @@ -54,7 +46,9 @@ val detype_closed_glob : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> cl val lookup_name_as_displayed : env -> evar_map -> constr -> Id.t -> int option val lookup_index_as_renamed : env -> evar_map -> constr -> int -> int option -val set_detype_anonymous : (Loc.t -> int -> glob_constr) -> unit +(* XXX: This is a hack and should go away *) +val set_detype_anonymous : (?loc:Loc.t -> int -> glob_constr) -> unit + val force_wildcard : unit -> bool val synthetize_type : unit -> bool diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 305eae15a3..630f80ad2f 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -34,7 +34,7 @@ type unify_fun = transparent_state -> let debug_unification = ref (false) let _ = Goptions.declare_bool_option { - Goptions.optsync = true; Goptions.optdepr = false; + Goptions.optdepr = false; Goptions.optname = "Print states sent to Evarconv unification"; Goptions.optkey = ["Debug";"Unification"]; @@ -42,6 +42,31 @@ let _ = Goptions.declare_bool_option { Goptions.optwrite = (fun a -> debug_unification:=a); } +(*******************************************) +(* Functions to deal with impossible cases *) +(*******************************************) +(* XXX: we would like to search for this with late binding + "data.id.type" etc... *) +let impossible_default_case () = + let c, ctx = Universes.fresh_global_instance (Global.env()) (Globnames.ConstRef Coqlib.id) in + let (_, u) = Term.destConst c in + Some (c, Term.mkConstU (Coqlib.type_of_id, u), ctx) + +let coq_unit_judge = + let open Environ in + let make_judge c t = make_judge (EConstr.of_constr c) (EConstr.of_constr t) in + let na1 = Name (Id.of_string "A") in + let na2 = Name (Id.of_string "H") in + fun () -> + match impossible_default_case () with + | Some (id, type_of_id, ctx) -> + make_judge id type_of_id, ctx + | None -> + (* In case the constants id/ID are not defined *) + Environ.make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1))) + (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))), + Univ.ContextSet.empty + let unfold_projection env evd ts p c = let cst = Projection.constant p in if is_transparent_constant ts cst then @@ -351,7 +376,7 @@ let rec evar_conv_x ts env evd pbty term1 term2 = match ground_test with | Some result -> result | None -> - (* Until pattern-unification is used consistently, use nohdbeta to not + (* Until pattern-unification is used consistently, use nohdbeta to not destroy beta-redexes that can be used for 1st-order unification *) let term1 = apprec_nohdbeta (fst ts) env evd term1 in let term2 = apprec_nohdbeta (fst ts) env evd term2 in @@ -613,7 +638,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun i -> let b = nf_evar i b1 in let t = nf_evar i t1 in - let na = Nameops.name_max na1 na2 in + let na = Nameops.Name.pick na1 na2 in evar_conv_x ts (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] and f2 i = @@ -730,7 +755,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty [(fun i -> evar_conv_x ts env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in - let na = Nameops.name_max na1 na2 in + let na = Nameops.Name.pick na1 na2 in evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2)] | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 @@ -791,7 +816,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty [(fun i -> evar_conv_x ts env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in - let na = Nameops.name_max n1 n2 in + let na = Nameops.Name.pick n1 n2 in evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] | Rel x1, Rel x2 -> @@ -887,7 +912,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) let test i = evar_conv_x trs env i CUMUL ty (substl ks b) in (i,t2::ks, m-1, test) else - let dloc = (Loc.ghost,Evar_kinds.InternalHole) in + let dloc = Loc.tag Evar_kinds.InternalHole in let i = Sigma.Unsafe.of_evar_map i in let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in let i' = Sigma.to_evar_map i' in @@ -1051,7 +1076,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = | decl'::ctxt', c::l, occs::occsl when isVarId evd (NamedDecl.get_id decl') c -> begin match occs with | Some _ -> - error "Cannot force abstraction on identity instance." + user_err Pp.(str "Cannot force abstraction on identity instance.") | None -> make_subst (ctxt',l,occsl) end @@ -1070,7 +1095,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = let set_var k = match occs with | Some Locus.AllOccurrences -> mkVar id - | Some _ -> error "Selection of specific occurrences not supported" + | Some _ -> user_err Pp.(str "Selection of specific occurrences not supported") | None -> let evty = set_holes evdref cty subst in let instance = Filter.filter_list filter instance in @@ -1108,10 +1133,10 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = (* This is an arbitrary choice *) let evd = Evd.define evk (Constr.mkVar id) evd in match evar_conv_x ts env_evar evd CUMUL idty evty with - | UnifFailure _ -> error "Cannot find an instance" + | UnifFailure _ -> user_err Pp.(str "Cannot find an instance") | Success evd -> match reconsider_unif_constraints (evar_conv_x ts) evd with - | UnifFailure _ -> error "Cannot find an instance" + | UnifFailure _ -> user_err Pp.(str "Cannot find an instance") | Success evd -> evd else @@ -1213,7 +1238,7 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = let error_cannot_unify env evd pb ?reason t1 t2 = Pretype_errors.error_cannot_unify - ~loc:(loc_of_conv_pb evd pb) env + ?loc:(loc_of_conv_pb evd pb) env evd ?reason (t1, t2) let check_problems_are_solved env evd = @@ -1245,7 +1270,7 @@ let rec solve_unconstrained_evars_with_candidates ts evd = | None -> evd | Some (evk,ev_info,l) -> let rec aux = function - | [] -> error "Unsolvable existential variables." + | [] -> user_err Pp.(str "Unsolvable existential variables.") | a::l -> try let conv_algo = evar_conv_x ts in @@ -1267,7 +1292,7 @@ let solve_unconstrained_impossible_cases env evd = match ev_info.evar_source with | loc,Evar_kinds.ImpossibleCase -> let j, ctx = coq_unit_judge () in - let evd' = Evd.merge_context_set Evd.univ_flexible_alg ~loc evd' ctx in + let evd' = Evd.merge_context_set Evd.univ_flexible_alg ?loc evd' ctx in let ty = j_type j in let conv_algo = evar_conv_x full_transparent_state in let evd' = check_evar_instance evd' evk ty conv_algo in diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 7cee1e8a7e..45857df2ae 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -80,3 +80,5 @@ val evar_eqappr_x : ?rhs_is_already_stuck:bool -> transparent_state * bool -> Evarsolve.unification_result (**/**) +(** {6 Functions to deal with impossible cases } *) +val coq_unit_judge : unit -> EConstr.unsafe_judgment Univ.in_universe_context_set diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 5fd104c781..a116198465 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -180,7 +180,7 @@ let define_evar_as_sort env evd (ev,args) = constraint on its domain and codomain. If the input constraint is an evar instantiate it with the product of 2 new evars. *) -let split_tycon loc env evd tycon = +let split_tycon ?loc env evd tycon = let rec real_split evd c = let t = Reductionops.whd_all env evd c in match EConstr.kind evd t with @@ -192,7 +192,7 @@ let split_tycon loc env evd tycon = | App (c,args) when isEvar evd c -> let (evd',lam) = define_evar_as_lambda env evd (destEvar evd c) in real_split evd' (mkApp (lam,args)) - | _ -> error_not_product ~loc env evd c + | _ -> error_not_product ?loc env evd c in match tycon with | None -> evd,(Anonymous,None,None) diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli index 2f7ac4efbe..b8134a28c5 100644 --- a/pretyping/evardefine.mli +++ b/pretyping/evardefine.mli @@ -31,7 +31,7 @@ val evar_absorb_arguments : env -> evar_map -> existential -> constr list -> evar_map * existential val split_tycon : - Loc.t -> env -> evar_map -> type_constraint -> + ?loc:Loc.t -> env -> evar_map -> type_constraint -> evar_map * (Name.t * type_constraint * type_constraint) val valcon_of_tycon : type_constraint -> val_constraint diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4ada91eb59..98e71c7fd9 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -1050,7 +1050,7 @@ let do_restrict_hyps evd (evk,args as ev) filter candidates = | None -> None,candidates | Some filter -> restrict_hyps evd evk filter candidates in match candidates,filter with - | UpdateWith [], _ -> error "Not solvable." + | UpdateWith [], _ -> user_err Pp.(str "Not solvable.") | UpdateWith [nc],_ -> let evd = Evd.define evk (EConstr.Unsafe.to_constr nc) evd in raise (EvarSolvedWhileRestricting (evd,mkEvar ev)) @@ -1230,7 +1230,7 @@ let check_evar_instance evd evk1 body conv_algo = (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) let ty = try Retyping.get_type_of ~lax:true evenv evd body - with Retyping.RetypeError _ -> error "Ill-typed evar instance" + with Retyping.RetypeError _ -> user_err Pp.(str "Ill-typed evar instance") in match conv_algo evenv evd Reduction.CUMUL ty (EConstr.of_constr evi.evar_concl) with | Success evd -> evd diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 6509aaac3d..6fb1b60898 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -15,19 +15,17 @@ open Glob_term (* Untyped intermediate terms, after ASTs and before constr. *) -let cases_pattern_loc = function - PatVar(loc,_) -> loc - | PatCstr(loc,_,_,_) -> loc +let cases_pattern_loc c = c.CAst.loc let cases_predicate_names tml = List.flatten (List.map (function | (tm,(na,None)) -> [na] - | (tm,(na,Some (_,_,nal))) -> na::nal) tml) + | (tm,(na,Some (_,(_,nal)))) -> na::nal) tml) -let mkGApp loc p t = - match p with - | GApp (loc,f,l) -> GApp (loc,f,l@[t]) - | _ -> GApp (loc,p,[t]) +let mkGApp ?loc p t = CAst.make ?loc @@ + match p.CAst.v with + | GApp (f,l) -> GApp (f,l@[t]) + | _ -> GApp (p,[t]) let map_glob_decl_left_to_right f (na,k,obd,ty) = let comp1 = Option.map f obd in @@ -35,229 +33,227 @@ let map_glob_decl_left_to_right f (na,k,obd,ty) = (na,k,comp1,comp2) let binding_kind_eq bk1 bk2 = match bk1, bk2 with -| Decl_kinds.Explicit, Decl_kinds.Explicit -> true -| Decl_kinds.Implicit, Decl_kinds.Implicit -> true -| _ -> false + | Decl_kinds.Explicit, Decl_kinds.Explicit -> true + | Decl_kinds.Implicit, Decl_kinds.Implicit -> true + | (Decl_kinds.Explicit | Decl_kinds.Implicit), _ -> false let case_style_eq s1 s2 = match s1, s2 with -| LetStyle, LetStyle -> true -| IfStyle, IfStyle -> true -| LetPatternStyle, LetPatternStyle -> true -| MatchStyle, MatchStyle -> true -| RegularStyle, RegularStyle -> true -| _ -> false - -let rec cases_pattern_eq p1 p2 = match p1, p2 with -| PatVar (_, na1), PatVar (_, na2) -> Name.equal na1 na2 -| PatCstr (_, c1, pl1, na1), PatCstr (_, c2, pl2, na2) -> - eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && - Name.equal na1 na2 -| _ -> false + | LetStyle, LetStyle -> true + | IfStyle, IfStyle -> true + | LetPatternStyle, LetPatternStyle -> true + | MatchStyle, MatchStyle -> true + | RegularStyle, RegularStyle -> true + | (LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle), _ -> false + +let rec cases_pattern_eq { CAst.v = p1} { CAst.v = p2 } = match p1, p2 with + | PatVar na1, PatVar na2 -> Name.equal na1 na2 + | PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> + eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && + Name.equal na1 na2 + | (PatVar _ | PatCstr _), _ -> false let cast_type_eq eq t1 t2 = match t1, t2 with -| CastConv t1, CastConv t2 -> eq t1 t2 -| CastVM t1, CastVM t2 -> eq t1 t2 -| CastCoerce, CastCoerce -> true -| CastNative t1, CastNative t2 -> eq t1 t2 -| _ -> false - -let rec glob_constr_eq c1 c2 = match c1, c2 with -| GRef (_, gr1, _), GRef (_, gr2, _) -> eq_gr gr1 gr2 -| GVar (_, id1), GVar (_, id2) -> Id.equal id1 id2 -| GEvar (_, id1, arg1), GEvar (_, id2, arg2) -> - Id.equal id1 id2 && - List.equal instance_eq arg1 arg2 -| GPatVar (_, (b1, pat1)), GPatVar (_, (b2, pat2)) -> - (b1 : bool) == b2 && Id.equal pat1 pat2 -| GApp (_, f1, arg1), GApp (_, f2, arg2) -> - glob_constr_eq f1 f2 && List.equal glob_constr_eq arg1 arg2 -| GLambda (_, na1, bk1, t1, c1), GLambda (_, na2, bk2, t2, c2) -> - Name.equal na1 na2 && binding_kind_eq bk1 bk2 && - glob_constr_eq t1 t2 && glob_constr_eq c1 c2 -| GProd (_, na1, bk1, t1, c1), GProd (_, na2, bk2, t2, c2) -> - Name.equal na1 na2 && binding_kind_eq bk1 bk2 && - glob_constr_eq t1 t2 && glob_constr_eq c1 c2 -| GLetIn (_, na1, b1, t1, c1), GLetIn (_, na2, b2, t2, c2) -> - Name.equal na1 na2 && glob_constr_eq b1 b2 && Option.equal glob_constr_eq t1 t2 && glob_constr_eq c1 c2 -| GCases (_, st1, c1, tp1, cl1), GCases (_, st2, c2, tp2, cl2) -> - case_style_eq st1 st2 && Option.equal glob_constr_eq c1 c2 && - List.equal tomatch_tuple_eq tp1 tp2 && - List.equal cases_clause_eq cl1 cl2 -| GLetTuple (_, na1, (n1, p1), c1, t1), GLetTuple (_, na2, (n2, p2), c2, t2) -> - List.equal Name.equal na1 na2 && Name.equal n1 n2 && - Option.equal glob_constr_eq p1 p2 && glob_constr_eq c1 c2 && - glob_constr_eq t1 t2 -| GIf (_, m1, (pat1, p1), c1, t1), GIf (_, m2, (pat2, p2), c2, t2) -> - glob_constr_eq m1 m2 && Name.equal pat1 pat2 && - Option.equal glob_constr_eq p1 p2 && glob_constr_eq c1 c2 && - glob_constr_eq t1 t2 -| GRec (_, kn1, id1, decl1, c1, t1), GRec (_, kn2, id2, decl2, c2, t2) -> - fix_kind_eq kn1 kn2 && Array.equal Id.equal id1 id2 && - Array.equal (fun l1 l2 -> List.equal glob_decl_eq l1 l2) decl1 decl2 && - Array.equal glob_constr_eq c1 c2 && - Array.equal glob_constr_eq t1 t2 -| GSort (_, s1), GSort (_, s2) -> Miscops.glob_sort_eq s1 s2 -| GHole (_, kn1, nam1, gn1), GHole (_, kn2, nam2, gn2) -> - Option.equal (==) gn1 gn2 (** Only thing sensible *) && - Miscops.intro_pattern_naming_eq nam1 nam2 -| GCast (_, c1, t1), GCast (_, c2, t2) -> - glob_constr_eq c1 c2 && cast_type_eq glob_constr_eq t1 t2 -| _ -> false - -and tomatch_tuple_eq (c1, p1) (c2, p2) = - let eqp (_, i1, na1) (_, i2, na2) = + | CastConv t1, CastConv t2 -> eq t1 t2 + | CastVM t1, CastVM t2 -> eq t1 t2 + | CastCoerce, CastCoerce -> true + | CastNative t1, CastNative t2 -> eq t1 t2 + | (CastConv _ | CastVM _ | CastCoerce | CastNative _), _ -> false + +let tomatch_tuple_eq f (c1, p1) (c2, p2) = + let eqp (_, (i1, na1)) (_, (i2, na2)) = eq_ind i1 i2 && List.equal Name.equal na1 na2 in let eq_pred (n1, o1) (n2, o2) = Name.equal n1 n2 && Option.equal eqp o1 o2 in - glob_constr_eq c1 c2 && eq_pred p1 p2 + f c1 c2 && eq_pred p1 p2 -and cases_clause_eq (_, id1, p1, c1) (_, id2, p2, c2) = - List.equal Id.equal id1 id2 && List.equal cases_pattern_eq p1 p2 && - glob_constr_eq c1 c2 +and cases_clause_eq f (_, (id1, p1, c1)) (_, (id2, p2, c2)) = + List.equal Id.equal id1 id2 && List.equal cases_pattern_eq p1 p2 && f c1 c2 -and glob_decl_eq (na1, bk1, c1, t1) (na2, bk2, c2, t2) = +let glob_decl_eq f (na1, bk1, c1, t1) (na2, bk2, c2, t2) = Name.equal na1 na2 && binding_kind_eq bk1 bk2 && - Option.equal glob_constr_eq c1 c2 && - glob_constr_eq t1 t2 - -and fix_kind_eq k1 k2 = match k1, k2 with -| GFix (a1, i1), GFix (a2, i2) -> - let eq (i1, o1) (i2, o2) = - Option.equal Int.equal i1 i2 && fix_recursion_order_eq o1 o2 - in - Int.equal i1 i2 && Array.equal eq a1 a1 -| GCoFix i1, GCoFix i2 -> Int.equal i1 i2 -| _ -> false - -and fix_recursion_order_eq o1 o2 = match o1, o2 with -| GStructRec, GStructRec -> true -| GWfRec c1, GWfRec c2 -> glob_constr_eq c1 c2 -| GMeasureRec (c1, o1), GMeasureRec (c2, o2) -> - glob_constr_eq c1 c2 && Option.equal glob_constr_eq o1 o2 -| _ -> false - -and instance_eq (x1,c1) (x2,c2) = - Id.equal x1 x2 && glob_constr_eq c1 c2 - -let map_glob_constr_left_to_right f = function - | GApp (loc,g,args) -> + Option.equal f c1 c2 && f t1 t2 + +let fix_recursion_order_eq f o1 o2 = match o1, o2 with + | GStructRec, GStructRec -> true + | GWfRec c1, GWfRec c2 -> f c1 c2 + | GMeasureRec (c1, o1), GMeasureRec (c2, o2) -> + f c1 c2 && Option.equal f o1 o2 + | (GStructRec | GWfRec _ | GMeasureRec _), _ -> false + +let fix_kind_eq f k1 k2 = match k1, k2 with + | GFix (a1, i1), GFix (a2, i2) -> + let eq (i1, o1) (i2, o2) = + Option.equal Int.equal i1 i2 && fix_recursion_order_eq f o1 o2 + in + Int.equal i1 i2 && Array.equal eq a1 a1 + | GCoFix i1, GCoFix i2 -> Int.equal i1 i2 + | (GFix _ | GCoFix _), _ -> false + +let instance_eq f (x1,c1) (x2,c2) = + Id.equal x1 x2 && f c1 c2 + +let mk_glob_constr_eq f { CAst.v = c1 } { CAst.v = c2 } = match c1, c2 with + | GRef (gr1, _), GRef (gr2, _) -> eq_gr gr1 gr2 + | GVar id1, GVar id2 -> Id.equal id1 id2 + | GEvar (id1, arg1), GEvar (id2, arg2) -> + Id.equal id1 id2 && List.equal (instance_eq f) arg1 arg2 + | GPatVar (b1, pat1), GPatVar (b2, pat2) -> + (b1 : bool) == b2 && Id.equal pat1 pat2 + | GApp (f1, arg1), GApp (f2, arg2) -> + f f1 f2 && List.equal f arg1 arg2 + | GLambda (na1, bk1, t1, c1), GLambda (na2, bk2, t2, c2) -> + Name.equal na1 na2 && binding_kind_eq bk1 bk2 && f t1 t2 && f c1 c2 + | GProd (na1, bk1, t1, c1), GProd (na2, bk2, t2, c2) -> + Name.equal na1 na2 && binding_kind_eq bk1 bk2 && f t1 t2 && f c1 c2 + | GLetIn (na1, b1, t1, c1), GLetIn (na2, b2, t2, c2) -> + Name.equal na1 na2 && f b1 b2 && Option.equal f t1 t2 && f c1 c2 + | GCases (st1, c1, tp1, cl1), GCases (st2, c2, tp2, cl2) -> + case_style_eq st1 st2 && Option.equal f c1 c2 && + List.equal (tomatch_tuple_eq f) tp1 tp2 && + List.equal (cases_clause_eq f) cl1 cl2 + | GLetTuple (na1, (n1, p1), c1, t1), GLetTuple (na2, (n2, p2), c2, t2) -> + List.equal Name.equal na1 na2 && Name.equal n1 n2 && + Option.equal f p1 p2 && f c1 c2 && f t1 t2 + | GIf (m1, (pat1, p1), c1, t1), GIf (m2, (pat2, p2), c2, t2) -> + f m1 m2 && Name.equal pat1 pat2 && + Option.equal f p1 p2 && f c1 c2 && f t1 t2 + | GRec (kn1, id1, decl1, c1, t1), GRec (kn2, id2, decl2, c2, t2) -> + fix_kind_eq f kn1 kn2 && Array.equal Id.equal id1 id2 && + Array.equal (fun l1 l2 -> List.equal (glob_decl_eq f) l1 l2) decl1 decl2 && + Array.equal f c1 c2 && Array.equal f t1 t2 + | GSort s1, GSort s2 -> Miscops.glob_sort_eq s1 s2 + | GHole (kn1, nam1, gn1), GHole (kn2, nam2, gn2) -> + Option.equal (==) gn1 gn2 (** Only thing sensible *) && + Miscops.intro_pattern_naming_eq nam1 nam2 + | GCast (c1, t1), GCast (c2, t2) -> + f c1 c2 && cast_type_eq f t1 t2 + | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ | + GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GCast _), _ -> false + +let rec glob_constr_eq c = mk_glob_constr_eq glob_constr_eq c + +let map_glob_constr_left_to_right f = CAst.map (function + | GApp (g,args) -> let comp1 = f g in let comp2 = Util.List.map_left f args in - GApp (loc,comp1,comp2) - | GLambda (loc,na,bk,ty,c) -> + GApp (comp1,comp2) + | GLambda (na,bk,ty,c) -> let comp1 = f ty in let comp2 = f c in - GLambda (loc,na,bk,comp1,comp2) - | GProd (loc,na,bk,ty,c) -> + GLambda (na,bk,comp1,comp2) + | GProd (na,bk,ty,c) -> let comp1 = f ty in let comp2 = f c in - GProd (loc,na,bk,comp1,comp2) - | GLetIn (loc,na,b,t,c) -> + GProd (na,bk,comp1,comp2) + | GLetIn (na,b,t,c) -> let comp1 = f b in let compt = Option.map f t in let comp2 = f c in - GLetIn (loc,na,comp1,compt,comp2) - | GCases (loc,sty,rtntypopt,tml,pl) -> + GLetIn (na,comp1,compt,comp2) + | GCases (sty,rtntypopt,tml,pl) -> let comp1 = Option.map f rtntypopt in let comp2 = Util.List.map_left (fun (tm,x) -> (f tm,x)) tml in - let comp3 = Util.List.map_left (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl in - GCases (loc,sty,comp1,comp2,comp3) - | GLetTuple (loc,nal,(na,po),b,c) -> + let comp3 = Util.List.map_left (fun (loc,(idl,p,c)) -> (loc,(idl,p,f c))) pl in + GCases (sty,comp1,comp2,comp3) + | GLetTuple (nal,(na,po),b,c) -> let comp1 = Option.map f po in let comp2 = f b in let comp3 = f c in - GLetTuple (loc,nal,(na,comp1),comp2,comp3) - | GIf (loc,c,(na,po),b1,b2) -> + GLetTuple (nal,(na,comp1),comp2,comp3) + | GIf (c,(na,po),b1,b2) -> let comp1 = Option.map f po in let comp2 = f b1 in let comp3 = f b2 in - GIf (loc,f c,(na,comp1),comp2,comp3) - | GRec (loc,fk,idl,bl,tyl,bv) -> + GIf (f c,(na,comp1),comp2,comp3) + | GRec (fk,idl,bl,tyl,bv) -> let comp1 = Array.map (Util.List.map_left (map_glob_decl_left_to_right f)) bl in let comp2 = Array.map f tyl in let comp3 = Array.map f bv in - GRec (loc,fk,idl,comp1,comp2,comp3) - | GCast (loc,c,k) -> + GRec (fk,idl,comp1,comp2,comp3) + | GCast (c,k) -> let comp1 = f c in let comp2 = Miscops.map_cast_type f k in - GCast (loc,comp1,comp2) + GCast (comp1,comp2) | (GVar _ | GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) as x -> x + ) let map_glob_constr = map_glob_constr_left_to_right let fold_return_type f acc (na,tyopt) = Option.fold_left f acc tyopt -let fold_glob_constr f acc = function +let fold_glob_constr f acc = CAst.with_val (function | GVar _ -> acc - | GApp (_,c,args) -> List.fold_left f (f acc c) args - | GLambda (_,_,_,b,c) | GProd (_,_,_,b,c) -> + | GApp (c,args) -> List.fold_left f (f acc c) args + | GLambda (_,_,b,c) | GProd (_,_,b,c) -> f (f acc b) c - | GLetIn (_,_,b,t,c) -> + | GLetIn (_,b,t,c) -> f (Option.fold_left f (f acc b) t) c - | GCases (_,_,rtntypopt,tml,pl) -> - let fold_pattern acc (_,idl,p,c) = f acc c in + | GCases (_,rtntypopt,tml,pl) -> + let fold_pattern acc (_,(idl,p,c)) = f acc c in List.fold_left fold_pattern (List.fold_left f (Option.fold_left f acc rtntypopt) (List.map fst tml)) pl - | GLetTuple (_,_,rtntyp,b,c) -> + | GLetTuple (_,rtntyp,b,c) -> f (f (fold_return_type f acc rtntyp) b) c - | GIf (_,c,rtntyp,b1,b2) -> + | GIf (c,rtntyp,b1,b2) -> f (f (f (fold_return_type f acc rtntyp) c) b1) b2 - | GRec (_,_,_,bl,tyl,bv) -> + | GRec (_,_,bl,tyl,bv) -> let acc = Array.fold_left (List.fold_left (fun acc (na,k,bbd,bty) -> f (Option.fold_left f acc bbd) bty)) acc bl in Array.fold_left f (Array.fold_left f acc tyl) bv - | GCast (_,c,k) -> + | GCast (c,k) -> let acc = match k with | CastConv t | CastVM t | CastNative t -> f acc t | CastCoerce -> acc in f acc c | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc + ) let fold_return_type_with_binders f g v acc (na,tyopt) = - Option.fold_left (f (name_fold g na v)) acc tyopt + Option.fold_left (f (Name.fold_right g na v)) acc tyopt -let fold_glob_constr_with_binders g f v acc = function +let fold_glob_constr_with_binders g f v acc = CAst.(with_val (function | GVar _ -> acc - | GApp (_,c,args) -> List.fold_left (f v) (f v acc c) args - | GLambda (_,na,_,b,c) | GProd (_,na,_,b,c) -> - f (name_fold g na v) (f v acc b) c - | GLetIn (_,na,b,t,c) -> - f (name_fold g na v) (Option.fold_left (f v) (f v acc b) t) c - | GCases (_,_,rtntypopt,tml,pl) -> - let fold_pattern acc (_,idl,p,c) = f (List.fold_right g idl v) acc c in + | GApp (c,args) -> List.fold_left (f v) (f v acc c) args + | GLambda (na,_,b,c) | GProd (na,_,b,c) -> + f (Name.fold_right g na v) (f v acc b) c + | GLetIn (na,b,t,c) -> + f (Name.fold_right g na v) (Option.fold_left (f v) (f v acc b) t) c + | GCases (_,rtntypopt,tml,pl) -> + let fold_pattern acc (_,(idl,p,c)) = f (List.fold_right g idl v) acc c in let fold_tomatch (v',acc) (tm,(na,onal)) = - (Option.fold_left (fun v'' (_,_,nal) -> List.fold_right (name_fold g) nal v'') - (name_fold g na v') onal, + (Option.fold_left (fun v'' (_,(_,nal)) -> List.fold_right (Name.fold_right g) nal v'') + (Name.fold_right g na v') onal, f v acc tm) in let (v',acc) = List.fold_left fold_tomatch (v,acc) tml in let acc = Option.fold_left (f v') acc rtntypopt in List.fold_left fold_pattern acc pl - | GLetTuple (_,nal,rtntyp,b,c) -> + | GLetTuple (nal,rtntyp,b,c) -> f v (f v (fold_return_type_with_binders f g v acc rtntyp) b) c - | GIf (_,c,rtntyp,b1,b2) -> + | GIf (c,rtntyp,b1,b2) -> f v (f v (f v (fold_return_type_with_binders f g v acc rtntyp) c) b1) b2 - | GRec (_,_,idl,bll,tyl,bv) -> + | GRec (_,idl,bll,tyl,bv) -> let f' i acc fid = let v,acc = List.fold_left (fun (v,acc) (na,k,bbd,bty) -> - (name_fold g na v, f v (Option.fold_left (f v) acc bbd) bty)) + (Name.fold_right g na v, f v (Option.fold_left (f v) acc bbd) bty)) (v,acc) bll.(i) in f (Array.fold_right g idl v) (f v acc tyl.(i)) (bv.(i)) in Array.fold_left_i f' acc idl - | GCast (_,c,k) -> + | GCast (c,k) -> let acc = match k with | CastConv t | CastVM t | CastNative t -> f v acc t | CastCoerce -> acc in f v acc c - | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc + | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc)) let iter_glob_constr f = fold_glob_constr (fun () -> f) () let occur_glob_constr id = + let open CAst in let rec occur barred acc = function - | GVar (loc,id') -> Id.equal id id' + | { loc ; v = GVar id' } -> Id.equal id id' | c -> (* [g] looks if [id] appears in a binding position, in which case, we don't have to look in the corresponding subterm *) @@ -267,8 +263,9 @@ let occur_glob_constr id = occur false false let free_glob_vars = + let open CAst in let rec vars bound vs = function - | GVar (loc,id') -> if Id.Set.mem id' bound then vs else Id.Set.add id' vs + | { loc ; v = GVar id' } -> if Id.Set.mem id' bound then vs else Id.Set.add id' vs | c -> fold_glob_constr_with_binders Id.Set.add vars bound vs c in fun rt -> let vs = vars Id.Set.empty Id.Set.empty rt in @@ -276,7 +273,7 @@ let free_glob_vars = let glob_visible_short_qualid c = let rec aux acc = function - | GRef (_,c,_) -> + | { CAst.v = GRef (c,_) } -> let qualid = Nametab.shortest_qualid_of_global Id.Set.empty c in let dir,id = Libnames.repr_qualid qualid in if DirPath.is_empty dir then id :: acc else acc @@ -314,37 +311,38 @@ let bound_glob_vars = probably be no significant penalty in doing reallocation as pattern-matching expressions are usually rather small. *) -let map_inpattern_binders f ((loc,id,nal) as x) = +let map_inpattern_binders f ((loc,(id,nal)) as x) = let r = CList.smartmap f nal in if r == nal then x - else loc,id,r + else loc,(id,r) let map_tomatch_binders f ((c,(na,inp)) as x) : tomatch_tuple = let r = Option.smartmap (fun p -> map_inpattern_binders f p) inp in if r == inp then x else c,(f na, r) -let rec map_case_pattern_binders f = function - | PatVar (loc,na) as x -> +let rec map_case_pattern_binders f = CAst.map (function + | PatVar na as x -> let r = f na in if r == na then x - else PatVar (loc,r) - | PatCstr (loc,c,ps,na) as x -> + else PatVar r + | PatCstr (c,ps,na) as x -> let rna = f na in let rps = CList.smartmap (fun p -> map_case_pattern_binders f p) ps in if rna == na && rps == ps then x - else PatCstr(loc,c,rps,rna) + else PatCstr(c,rps,rna) + ) -let map_cases_branch_binders f ((loc,il,cll,rhs) as x) : cases_clause = +let map_cases_branch_binders f ((loc,(il,cll,rhs)) as x) : cases_clause = (* spiwack: not sure if I must do something with the list of idents. It is intended to be a superset of the free variable of the right-hand side, if I understand correctly. But I'm not sure when or how they are used. *) let r = List.smartmap (fun cl -> map_case_pattern_binders f cl) cll in if r == cll then x - else loc,il,r,rhs + else loc,(il,r,rhs) let map_pattern_binders f tomatch branches = CList.smartmap (fun tm -> map_tomatch_binders f tm) tomatch, @@ -354,41 +352,26 @@ let map_pattern_binders f tomatch branches = let map_tomatch f (c,pp) : tomatch_tuple = f c , pp -let map_cases_branch f (loc,il,cll,rhs) : cases_clause = - loc , il , cll , f rhs +let map_cases_branch f (loc,(il,cll,rhs)) : cases_clause = + loc , (il , cll , f rhs) let map_pattern f tomatch branches = List.map (fun tm -> map_tomatch f tm) tomatch, List.map (fun br -> map_cases_branch f br) branches -let loc_of_glob_constr = function - | GRef (loc,_,_) -> loc - | GVar (loc,_) -> loc - | GEvar (loc,_,_) -> loc - | GPatVar (loc,_) -> loc - | GApp (loc,_,_) -> loc - | GLambda (loc,_,_,_,_) -> loc - | GProd (loc,_,_,_,_) -> loc - | GLetIn (loc,_,_,_,_) -> loc - | GCases (loc,_,_,_,_) -> loc - | GLetTuple (loc,_,_,_,_) -> loc - | GIf (loc,_,_,_,_) -> loc - | GRec (loc,_,_,_,_,_) -> loc - | GSort (loc,_) -> loc - | GHole (loc,_,_,_) -> loc - | GCast (loc,_,_) -> loc +let loc_of_glob_constr c = c.CAst.loc (**********************************************************************) (* Alpha-renaming *) let collide_id l id = List.exists (fun (id',id'') -> Id.equal id id' || Id.equal id id'') l let test_id l id = if collide_id l id then raise Not_found -let test_na l na = name_iter (test_id l) na +let test_na l na = Name.iter (test_id l) na let update_subst na l = let in_range id l = List.exists (fun (_,id') -> Id.equal id id') l in - let l' = name_fold Id.List.remove_assoc na l in - name_fold + let l' = Name.fold_right Id.List.remove_assoc na l in + Name.fold_right (fun id _ -> if in_range id l' then let id' = Namegen.next_ident_away_from id (fun id' -> in_range id' l') in @@ -408,77 +391,78 @@ let rename_var l id = if List.exists (fun (_,id') -> Id.equal id id') l then raise UnsoundRenaming else id -let rec rename_glob_vars l = function - | GVar (loc,id) as r -> +let rec rename_glob_vars l c = CAst.map_with_loc (fun ?loc -> function + | GVar id as r -> let id' = rename_var l id in - if id == id' then r else GVar (loc,id') - | GRef (_,VarRef id,_) as r -> + if id == id' then r else GVar id' + | GRef (VarRef id,_) as r -> if List.exists (fun (_,id') -> Id.equal id id') l then raise UnsoundRenaming else r - | GProd (loc,na,bk,t,c) -> + | GProd (na,bk,t,c) -> let na',l' = update_subst na l in - GProd (loc,na,bk,rename_glob_vars l t,rename_glob_vars l' c) - | GLambda (loc,na,bk,t,c) -> + GProd (na,bk,rename_glob_vars l t,rename_glob_vars l' c) + | GLambda (na,bk,t,c) -> let na',l' = update_subst na l in - GLambda (loc,na',bk,rename_glob_vars l t,rename_glob_vars l' c) - | GLetIn (loc,na,b,t,c) -> + GLambda (na',bk,rename_glob_vars l t,rename_glob_vars l' c) + | GLetIn (na,b,t,c) -> let na',l' = update_subst na l in - GLetIn (loc,na',rename_glob_vars l b,Option.map (rename_glob_vars l) t,rename_glob_vars l' c) + GLetIn (na',rename_glob_vars l b,Option.map (rename_glob_vars l) t,rename_glob_vars l' c) (* Lazy strategy: we fail if a collision with renaming occurs, rather than renaming further *) - | GCases (loc,ci,po,tomatchl,cls) -> + | GCases (ci,po,tomatchl,cls) -> let test_pred_pat (na,ino) = - test_na l na; Option.iter (fun (_,_,nal) -> List.iter (test_na l) nal) ino in + test_na l na; Option.iter (fun (_,(_,nal)) -> List.iter (test_na l) nal) ino in let test_clause idl = List.iter (test_id l) idl in let po = Option.map (rename_glob_vars l) po in let tomatchl = Util.List.map_left (fun (tm,x) -> test_pred_pat x; (rename_glob_vars l tm,x)) tomatchl in - let cls = Util.List.map_left (fun (loc,idl,p,c) -> test_clause idl; (loc,idl,p,rename_glob_vars l c)) cls in - GCases (loc,ci,po,tomatchl,cls) - | GLetTuple (loc,nal,(na,po),c,b) -> + let cls = Util.List.map_left (fun (loc,(idl,p,c)) -> test_clause idl; (loc,(idl,p,rename_glob_vars l c))) cls in + GCases (ci,po,tomatchl,cls) + | GLetTuple (nal,(na,po),c,b) -> List.iter (test_na l) (na::nal); - GLetTuple (loc,nal,(na,Option.map (rename_glob_vars l) po), + GLetTuple (nal,(na,Option.map (rename_glob_vars l) po), rename_glob_vars l c,rename_glob_vars l b) - | GIf (loc,c,(na,po),b1,b2) -> + | GIf (c,(na,po),b1,b2) -> test_na l na; - GIf (loc,rename_glob_vars l c,(na,Option.map (rename_glob_vars l) po), + GIf (rename_glob_vars l c,(na,Option.map (rename_glob_vars l) po), rename_glob_vars l b1,rename_glob_vars l b2) - | GRec (loc,k,idl,decls,bs,ts) -> + | GRec (k,idl,decls,bs,ts) -> Array.iter (test_id l) idl; - GRec (loc,k,idl, + GRec (k,idl, Array.map (List.map (fun (na,k,bbd,bty) -> test_na l na; (na,k,Option.map (rename_glob_vars l) bbd,rename_glob_vars l bty))) decls, Array.map (rename_glob_vars l) bs, Array.map (rename_glob_vars l) ts) - | r -> map_glob_constr (rename_glob_vars l) r + | _ -> (map_glob_constr (rename_glob_vars l) c).CAst.v + ) c (**********************************************************************) (* Conversion from glob_constr to cases pattern, if possible *) -let rec cases_pattern_of_glob_constr na = function - | GVar (loc,id) -> +let rec cases_pattern_of_glob_constr na = CAst.map (function + | GVar id -> begin match na with | Name _ -> (* Unable to manage the presence of both an alias and a variable *) raise Not_found - | Anonymous -> PatVar (loc,Name id) + | Anonymous -> PatVar (Name id) end - | GHole (loc,_,_,_) -> PatVar (loc,na) - | GRef (loc,ConstructRef cstr,_) -> - PatCstr (loc,cstr,[],na) - | GApp (loc,GRef (_,ConstructRef cstr,_),l) -> - PatCstr (loc,cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) + | GHole (_,_,_) -> PatVar na + | GRef (ConstructRef cstr,_) -> PatCstr (cstr,[],na) + | GApp ( { CAst.v = GRef (ConstructRef cstr,_) }, l) -> + PatCstr (cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) | _ -> raise Not_found + ) (* Turn a closed cases pattern into a glob_constr *) -let rec glob_constr_of_closed_cases_pattern_aux = function - | PatCstr (loc,cstr,[],Anonymous) -> - GRef (loc,ConstructRef cstr,None) - | PatCstr (loc,cstr,l,Anonymous) -> - let ref = GRef (loc,ConstructRef cstr,None) in - GApp (loc,ref, List.map glob_constr_of_closed_cases_pattern_aux l) +let rec glob_constr_of_closed_cases_pattern_aux x = CAst.map_with_loc (fun ?loc -> function + | PatCstr (cstr,[],Anonymous) -> GRef (ConstructRef cstr,None) + | PatCstr (cstr,l,Anonymous) -> + let ref = CAst.make ?loc @@ GRef (ConstructRef cstr,None) in + GApp (ref, List.map glob_constr_of_closed_cases_pattern_aux l) | _ -> raise Not_found + ) x let glob_constr_of_closed_cases_pattern = function - | PatCstr (loc,cstr,l,na) -> - na,glob_constr_of_closed_cases_pattern_aux (PatCstr (loc,cstr,l,Anonymous)) + | { CAst.loc ; v = PatCstr (cstr,l,na) } -> + na,glob_constr_of_closed_cases_pattern_aux (CAst.make ?loc @@ PatCstr (cstr,l,Anonymous)) | _ -> raise Not_found diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index af2834e498..f7cc08ca21 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -20,12 +20,12 @@ val glob_constr_eq : glob_constr -> glob_constr -> bool (** Operations on [glob_constr] *) -val cases_pattern_loc : cases_pattern -> Loc.t +val cases_pattern_loc : cases_pattern -> Loc.t option val cases_predicate_names : tomatch_tuples -> Name.t list (** Apply one argument to a glob_constr *) -val mkGApp : Loc.t -> glob_constr -> glob_constr -> glob_constr +val mkGApp : ?loc:Loc.t -> glob_constr -> glob_constr -> glob_constr val map_glob_constr : (glob_constr -> glob_constr) -> glob_constr -> glob_constr @@ -36,13 +36,17 @@ val map_glob_constr_left_to_right : val warn_variable_collision : ?loc:Loc.t -> Id.t -> unit +val mk_glob_constr_eq : (glob_constr -> glob_constr -> bool) -> + glob_constr -> glob_constr -> bool + val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a val fold_glob_constr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> 'b -> glob_constr -> 'b) -> 'a -> 'b -> glob_constr -> 'b val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit val occur_glob_constr : Id.t -> glob_constr -> bool val free_glob_vars : glob_constr -> Id.t list val bound_glob_vars : glob_constr -> Id.Set.t -val loc_of_glob_constr : glob_constr -> Loc.t +(* Obsolete *) +val loc_of_glob_constr : glob_constr -> Loc.t option val glob_visible_short_qualid : glob_constr -> Id.t list (* Renaming free variables using a renaming map; fails with diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 429e5005ec..7f3bafc685 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -97,7 +97,7 @@ let mis_nf_constructor_type ((ind,u),mib,mip) j = and ntypes = mib.mind_ntypes and nconstr = Array.length mip.mind_consnames in let make_Ik k = mkIndU (((fst ind),ntypes-k-1),u) in - if j > nconstr then error "Not enough constructors in the type."; + if j > nconstr then user_err Pp.(str "Not enough constructors in the type."); substl (List.init ntypes make_Ik) (subst_instance_constr u specif.(j-1)) (* Number of constructors *) diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml index e4fbf8d542..211ffbe01e 100644 --- a/pretyping/locusops.ml +++ b/pretyping/locusops.ml @@ -50,9 +50,9 @@ let is_nowhere = function let simple_clause_of enum_hyps cl = let error_occurrences () = - CErrors.error "This tactic does not support occurrences selection" in + CErrors.user_err Pp.(str "This tactic does not support occurrences selection") in let error_body_selection () = - CErrors.error "This tactic does not support body selection" in + CErrors.user_err Pp.(str "This tactic does not support body selection") in let hyps = match cl.onhyps with | None -> diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml index 1669f8334b..69bc2d11ff 100644 --- a/pretyping/miscops.ml +++ b/pretyping/miscops.ml @@ -62,7 +62,7 @@ let map_red_expr_gen f g h = function (** Mapping bindings *) let map_explicit_bindings f l = - let map (loc, hyp, x) = (loc, hyp, f x) in + let map (loc, (hyp, x)) = (loc, (hyp, f x)) in List.map map l let map_bindings f = function diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 0228f63cdc..afaa20b6f6 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -383,7 +383,7 @@ let native_norm env sigma c ty = let c = EConstr.Unsafe.to_constr c in let ty = EConstr.Unsafe.to_constr ty in if Coq_config.no_native_compiler then - error "Native_compute reduction has been disabled at configure time." + user_err Pp.(str "Native_compute reduction has been disabled at configure time.") else let penv = Environ.pre_env env in (* diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index a22db1407b..0818a55256 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -14,7 +14,6 @@ open Nameops open Term open Vars open Glob_term -open Glob_ops open Pp open Mod_subst open Misctypes @@ -155,14 +154,15 @@ let pattern_of_constr env sigma t = | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp)) | Proj (p, c) -> pattern_of_constr env (EConstr.Unsafe.to_constr (Retyping.expand_projection env sigma p (EConstr.of_constr c) [])) - | Evar (evk,ctxt) -> + | Evar (evk,ctxt as ev) -> (match snd (Evd.evar_source evk sigma) with | Evar_kinds.MatchingVar (b,id) -> assert (not b); PMeta (Some id) | Evar_kinds.GoalEvar | Evar_kinds.VarInstance _ -> (* These are the two evar kinds used for existing goals *) (* see Proofview.mark_in_evm *) - PEvar (evk,Array.map (pattern_of_constr env) ctxt) + if Evd.is_defined sigma evk then pattern_of_constr env (Evd.existential_value sigma ev) + else PEvar (evk,Array.map (pattern_of_constr env) ctxt) | _ -> PMeta None) | Case (ci,p,a,br) -> @@ -230,7 +230,7 @@ let instantiate_pattern env sigma lvar c = error_instantiate_pattern id (List.subtract Id.equal ctx vars) with Not_found (* Map.find failed *) -> x) - | (PFix _ | PCoFix _) -> error ("Non instantiable pattern.") + | (PFix _ | PCoFix _) -> user_err Pp.(str "Non instantiable pattern.") | c -> map_pattern_with_binders (fun id vars -> id::vars) aux vars c in aux [] c @@ -325,46 +325,46 @@ let warn_cast_in_pattern = CWarnings.create ~name:"cast-in-pattern" ~category:"automation" (fun () -> Pp.strbrk "Casts are ignored in patterns") -let rec pat_of_raw metas vars = function - | GVar (_,id) -> +let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function + | GVar id -> (try PRel (List.index Name.equal (Name id) vars) with Not_found -> PVar id) - | GPatVar (_,(false,n)) -> + | GPatVar (false,n) -> metas := n::!metas; PMeta (Some n) - | GRef (_,gr,_) -> + | GRef (gr,_) -> PRef (canonical_gr gr) (* Hack to avoid rewriting a complete interpretation of patterns *) - | GApp (_, GPatVar (_,(true,n)), cl) -> + | GApp ({ CAst.v = GPatVar (true,n) }, cl) -> metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl) - | GApp (_,c,cl) -> + | GApp (c,cl) -> PApp (pat_of_raw metas vars c, Array.of_list (List.map (pat_of_raw metas vars) cl)) - | GLambda (_,na,bk,c1,c2) -> - name_iter (fun n -> metas := n::!metas) na; + | GLambda (na,bk,c1,c2) -> + Name.iter (fun n -> metas := n::!metas) na; PLambda (na, pat_of_raw metas vars c1, pat_of_raw metas (na::vars) c2) - | GProd (_,na,bk,c1,c2) -> - name_iter (fun n -> metas := n::!metas) na; + | GProd (na,bk,c1,c2) -> + Name.iter (fun n -> metas := n::!metas) na; PProd (na, pat_of_raw metas vars c1, pat_of_raw metas (na::vars) c2) - | GLetIn (_,na,c1,t,c2) -> - name_iter (fun n -> metas := n::!metas) na; + | GLetIn (na,c1,t,c2) -> + Name.iter (fun n -> metas := n::!metas) na; PLetIn (na, pat_of_raw metas vars c1, Option.map (pat_of_raw metas vars) t, pat_of_raw metas (na::vars) c2) - | GSort (_,s) -> + | GSort s -> PSort s | GHole _ -> PMeta None - | GCast (_,c,_) -> + | GCast (c,_) -> warn_cast_in_pattern (); pat_of_raw metas vars c - | GIf (_,c,(_,None),b1,b2) -> + | GIf (c,(_,None),b1,b2) -> PIf (pat_of_raw metas vars c, pat_of_raw metas vars b1,pat_of_raw metas vars b2) - | GLetTuple (loc,nal,(_,None),b,c) -> - let mkGLambda c na = - GLambda (loc,na,Explicit,GHole (loc,Evar_kinds.InternalHole, IntroAnonymous, None),c) in + | GLetTuple (nal,(_,None),b,c) -> + let mkGLambda c na = CAst.make ?loc @@ + GLambda (na,Explicit, CAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None),c) in let c = List.fold_left mkGLambda c nal in let cip = { cip_style = LetStyle; @@ -375,24 +375,24 @@ let rec pat_of_raw metas vars = function 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]) - | GCases (loc,sty,p,[c,(na,indnames)],brs) -> + | GCases (sty,p,[c,(na,indnames)],brs) -> let get_ind = function - | (_,_,[PatCstr(_,(ind,_),_,_)],_)::_ -> Some ind + | (_,(_,[{ CAst.v = PatCstr((ind,_),_,_) }],_))::_ -> Some ind | _ -> None in let ind_tags,ind = match indnames with - | Some (_,ind,nal) -> Some (List.length nal), Some ind + | Some (_,(ind,nal)) -> Some (List.length nal), Some ind | None -> None, get_ind brs in let ext,brs = pats_of_glob_branches loc metas vars ind brs in let pred = match p,indnames with - | Some p, Some (_,_,nal) -> + | Some p, Some (_,(_,nal)) -> let nvars = na :: List.rev nal @ vars in rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas nvars p)) - | (None | Some (GHole _)), _ -> PMeta None + | (None | Some { CAst.v = GHole _}), _ -> PMeta None | Some p, None -> - user_err ~loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") + user_err ?loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") in let info = { cip_style = sty; @@ -405,26 +405,27 @@ let rec pat_of_raw metas vars = function one non-trivial branch. These facts are used in [Constrextern]. *) PCase (info, pred, pat_of_raw metas vars c, brs) - | r -> err ~loc:(loc_of_glob_constr r) (Pp.str "Non supported pattern.") + | r -> err ?loc (Pp.str "Non supported pattern.") + ) and pats_of_glob_branches loc metas vars ind brs = let get_arg = function - | PatVar(_,na) -> - name_iter (fun n -> metas := n::!metas) na; + | { CAst.v = PatVar na } -> + Name.iter (fun n -> metas := n::!metas) na; na - | PatCstr(loc,_,_,_) -> err ~loc (Pp.str "Non supported pattern.") + | { CAst.v = PatCstr(_,_,_) ; loc } -> err ?loc (Pp.str "Non supported pattern.") in let rec get_pat indexes = function | [] -> false, [] - | [(_,_,[PatVar(_,Anonymous)],GHole _)] -> true, [] (* ends with _ => _ *) - | (_,_,[PatCstr(_,(indsp,j),lv,_)],br) :: brs -> + | [(_,(_,[{ CAst.v = PatVar Anonymous }], { CAst.v = GHole _}))] -> true, [] (* ends with _ => _ *) + | (_,(_,[{ CAst.v = PatCstr((indsp,j),lv,_) }],br)) :: brs -> let () = match ind with | Some sp when eq_ind sp indsp -> () | _ -> - err ~loc (Pp.str "All constructors must be in the same inductive type.") + err ?loc (Pp.str "All constructors must be in the same inductive type.") in if Int.Set.mem (j-1) indexes then - err ~loc + 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 @@ -432,7 +433,7 @@ and pats_of_glob_branches loc metas vars ind brs = 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) - | (loc,_,_,_) :: _ -> err ~loc (Pp.str "Non supported pattern.") + | (loc,(_,_,_)) :: _ -> err ?loc (Pp.str "Non supported pattern.") in get_pat Int.Set.empty brs diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index f9cf6b83bc..d7c04b08b0 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -176,7 +176,7 @@ let unsatisfiable_constraints env evd ev comp = | Some ev -> let loc, kind = Evd.evar_source ev evd in let err = UnsatisfiableConstraints (Some (ev, kind), comp) in - Loc.raise ~loc (PretypeError (env,evd,err)) + Loc.raise ?loc (PretypeError (env,evd,err)) let unsatisfiable_exception exn = match exn with diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 4886423bd0..b0663af70c 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -132,7 +132,7 @@ let nf_fix sigma (nas, cs, ts) = let inj c = EConstr.to_constr sigma c in (nas, Array.map inj cs, Array.map inj ts) -let search_guard loc env possible_indexes fixdefs = +let search_guard ?loc env possible_indexes fixdefs = (* Standard situation with only one possibility for each fix. *) (* We treat it separately in order to get proper error msg. *) let is_singleton = function [_] -> true | _ -> false in @@ -142,7 +142,7 @@ let search_guard loc env possible_indexes fixdefs = (try check_fix env fix with reraise -> let (e, info) = CErrors.push reraise in - let info = Loc.add_loc info loc in + let info = Option.cata (fun loc -> Loc.add_loc info loc) info loc in iraise (e, info)); indexes else @@ -165,7 +165,7 @@ let search_guard loc env possible_indexes fixdefs = with TypeError _ -> ()) (List.combinations possible_indexes); let errmsg = "Cannot guess decreasing argument of fix." in - user_err ~loc ~hdr:"search_guard" (Pp.str errmsg) + user_err ?loc ~hdr:"search_guard" (Pp.str errmsg) with Found indexes -> indexes) (* To force universe name declaration before use *) @@ -175,8 +175,7 @@ let is_strict_universe_declarations () = !strict_universe_declarations let _ = Goptions.(declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "strict universe declaration"; optkey = ["Strict";"Universe";"Declaration"]; optread = is_strict_universe_declarations; @@ -184,18 +183,17 @@ let _ = let _ = Goptions.(declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "minimization to Set"; optkey = ["Universe";"Minimization";"ToSet"]; optread = Universes.is_set_minimization; optwrite = (:=) Universes.set_minimization }) - + (** Miscellaneous interpretation functions *) -let interp_universe_level_name ~anon_rigidity evd (loc,s) = +let interp_universe_level_name ~anon_rigidity evd (loc, s) = match s with | Anonymous -> - new_univ_level_variable ~loc anon_rigidity evd + new_univ_level_variable ?loc anon_rigidity evd | Name s -> let s = Id.to_string s in let names, _ = Global.global_universe_names () in @@ -220,8 +218,8 @@ let interp_universe_level_name ~anon_rigidity evd (loc,s) = evd, snd (Idmap.find id names) with Not_found -> if not (is_strict_universe_declarations ()) then - new_univ_level_variable ~loc ~name:s univ_rigid evd - else user_err ~loc ~hdr:"interp_universe_level_name" + new_univ_level_variable ?loc ~name:s univ_rigid evd + else user_err ?loc ~hdr:"interp_universe_level_name" (Pp.(str "Undeclared universe: " ++ str s)) let interp_universe ?loc evd = function @@ -234,9 +232,9 @@ let interp_universe ?loc evd = function (evd', Univ.sup u (Univ.Universe.make l))) (evd, Univ.Universe.type0m) l -let interp_level_info loc evd : Misctypes.level_info -> _ = function - | None -> new_univ_level_variable ~loc univ_rigid evd - | Some (loc,s) -> interp_universe_level_name ~anon_rigidity:univ_flexible evd (loc,s) +let interp_level_info ?loc evd : Misctypes.level_info -> _ = function + | None -> new_univ_level_variable ?loc univ_rigid evd + | Some (loc,s) -> interp_universe_level_name ~anon_rigidity:univ_flexible evd (Loc.tag ?loc s) let interp_sort ?loc evd = function | GProp -> evd, Prop Null @@ -342,7 +340,7 @@ let check_extra_evars_are_solved env current_sigma frozen = match frozen with match k with | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () | _ -> - error_unsolvable_implicit ~loc env current_sigma evk None) pending + error_unsolvable_implicit ?loc env current_sigma evk None) pending (* [check_evars] fails if some unresolved evar remains *) @@ -354,7 +352,7 @@ let check_evars env initial_sigma sigma c = let (loc,k) = evar_source evk sigma in begin match k with | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () - | _ -> Pretype_errors.error_unsolvable_implicit ~loc env sigma evk None + | _ -> Pretype_errors.error_unsolvable_implicit ?loc env sigma evk None end | _ -> EConstr.iter sigma proc_rec c in proc_rec c @@ -385,22 +383,37 @@ let process_inference_flags flags env initial_sigma (sigma,c) = let c = if flags.expand_evars then nf_evar sigma c else c in sigma,c +let adjust_evar_source evdref na c = + match na, kind !evdref c with + | Name id, Evar (evk,args) -> + let evi = Evd.find !evdref evk in + begin match evi.evar_source with + | loc, Evar_kinds.QuestionMark (b,Anonymous) -> + let src = (loc,Evar_kinds.QuestionMark (b,na)) in + let sigma = Sigma.Unsafe.of_evar_map !evdref in + let Sigma (evk', evd, _) = restrict_evar sigma evk (evar_filter evi) ~src None in + evdref := Sigma.to_evar_map evd; + mkEvar (evk',args) + | _ -> c + end + | _, _ -> c + (* Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *) let allow_anonymous_refs = ref false (* coerce to tycon if any *) -let inh_conv_coerce_to_tycon resolve_tc loc env evdref j = function +let inh_conv_coerce_to_tycon ?loc resolve_tc env evdref j = function | None -> j | Some t -> - evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env.ExtraEnv.env) evdref j t + evd_comb2 (Coercion.inh_conv_coerce_to ?loc resolve_tc env.ExtraEnv.env) evdref j t let check_instance loc subst = function | [] -> () | (id,_) :: _ -> if List.mem_assoc id subst then - user_err ~loc (pr_id id ++ str "appears more than once.") + user_err ?loc (pr_id id ++ str "appears more than once.") else - user_err ~loc (str "No such variable in the signature of the existential variable: " ++ pr_id id ++ str ".") + user_err ?loc (str "No such variable in the signature of the existential variable: " ++ pr_id id ++ str ".") (* used to enforce a name in Lambda when the type constraints itself is named, hence possibly dependent *) @@ -480,7 +493,7 @@ let pretype_id pretype k0 loc env evdref lvar id = (* and build a nice error message *) if Id.Map.mem id lvar.ltac_genargs then begin let Geninterp.Val.Dyn (typ, _) = Id.Map.find id lvar.ltac_genargs in - user_err ~loc + user_err ?loc (str "Variable " ++ pr_id id ++ str " should be bound to a term but is \ bound to a " ++ Geninterp.Val.pr typ ++ str ".") end; @@ -489,47 +502,47 @@ let pretype_id pretype k0 loc env evdref lvar id = { uj_val = mkVar id; uj_type = NamedDecl.get_type (lookup_named id env) } with Not_found -> (* [id] not found, standard error message *) - error_var_not_found ~loc id + error_var_not_found ?loc id (*************************************************************************) (* Main pretyping function *) -let interp_glob_level loc evd : Misctypes.glob_level -> _ = function +let interp_glob_level ?loc evd : Misctypes.glob_level -> _ = function | GProp -> evd, Univ.Level.prop | GSet -> evd, Univ.Level.set - | GType s -> interp_level_info loc evd s + | GType s -> interp_level_info ?loc evd s -let interp_instance loc evd ~len l = +let interp_instance ?loc evd ~len l = if len != List.length l then - user_err ~loc ~hdr:"pretype" + user_err ?loc ~hdr:"pretype" (str "Universe instance should have length " ++ int len) else let evd, l' = List.fold_left (fun (evd, univs) l -> - let evd, l = interp_glob_level loc evd l in + let evd, l = interp_glob_level ?loc evd l in (evd, l :: univs)) (evd, []) l in if List.exists (fun l -> Univ.Level.is_prop l) l' then - user_err ~loc ~hdr:"pretype" + user_err ?loc ~hdr:"pretype" (str "Universe instances cannot contain Prop, polymorphic" ++ str " universe instances must be greater or equal to Set."); evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) -let pretype_global loc rigid env evd gr us = +let pretype_global ?loc rigid env evd gr us = let evd, instance = match us with | None -> evd, None | Some l -> let _, ctx = Universes.unsafe_constr_of_global gr in let len = Univ.UContext.size ctx in - interp_instance loc evd ~len l + interp_instance ?loc evd ~len l in - let (sigma, c) = Evd.fresh_global ~loc ~rigid ?names:instance env.ExtraEnv.env evd gr in + let (sigma, c) = Evd.fresh_global ?loc ~rigid ?names:instance env.ExtraEnv.env evd gr in (sigma, EConstr.of_constr c) -let pretype_ref loc evdref env ref us = +let pretype_ref ?loc evdref env ref us = match ref with | VarRef id -> (* Section variable *) @@ -538,24 +551,24 @@ let pretype_ref loc evdref env ref us = (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal variables *) - Pretype_errors.error_var_not_found ~loc id) + Pretype_errors.error_var_not_found ?loc id) | ref -> - let evd, c = pretype_global loc univ_flexible env !evdref ref us in + let evd, c = pretype_global ?loc univ_flexible env !evdref ref us in let () = evdref := evd in let ty = unsafe_type_of env.ExtraEnv.env evd c in make_judge c ty -let judge_of_Type loc evd s = - let evd, s = interp_universe ~loc evd s in +let judge_of_Type ?loc evd s = + let evd, s = interp_universe ?loc evd s in let judge = { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) } in evd, judge -let pretype_sort loc evdref = function +let pretype_sort ?loc evdref = function | GProp -> judge_of_prop | GSet -> judge_of_set - | GType s -> evd_comb1 (judge_of_Type loc) evdref s + | GType s -> evd_comb1 (judge_of_Type ?loc) evdref s let new_type_evar env evdref loc = let sigma = Sigma.Unsafe.of_evar_map !evdref in @@ -566,42 +579,53 @@ let new_type_evar env evdref loc = evdref := Sigma.to_evar_map sigma; e -let (f_genarg_interp, genarg_interp_hook) = Hook.make () +module ConstrInterpObj = +struct + type ('r, 'g, 't) obj = + unbound_ltac_var_map -> env -> evar_map -> types -> 'g -> constr * evar_map + let name = "constr_interp" + let default _ = None +end + +module ConstrInterp = Genarg.Register(ConstrInterpObj) + +let register_constr_interp0 = ConstrInterp.register0 (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [evdref] and *) (* the type constraint tycon *) let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdref (lvar : ltac_var_map) t = - let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in + let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc resolve_tc in let pretype_type = pretype_type k0 resolve_tc in let pretype = pretype k0 resolve_tc in let open Context.Rel.Declaration in - match t with - | GRef (loc,ref,u) -> - inh_conv_coerce_to_tycon loc env evdref - (pretype_ref loc evdref env ref u) + let loc = t.CAst.loc in + match t.CAst.v with + | GRef (ref,u) -> + inh_conv_coerce_to_tycon ?loc env evdref + (pretype_ref ?loc evdref env ref u) tycon - | GVar (loc, id) -> - inh_conv_coerce_to_tycon loc env evdref + | GVar id -> + inh_conv_coerce_to_tycon ?loc env evdref (pretype_id (fun e r l t -> pretype tycon e r l t) k0 loc env evdref lvar id) tycon - | GEvar (loc, id, inst) -> + | GEvar (id, inst) -> (* Ne faudrait-il pas s'assurer que hyps est bien un sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *) let evk = try Evd.evar_key id !evdref with Not_found -> - user_err ~loc (str "Unknown existential variable.") in + user_err ?loc (str "Unknown existential variable.") in let hyps = evar_filtered_context (Evd.find !evdref evk) in let args = pretype_instance k0 resolve_tc env evdref lvar loc hyps evk inst in let c = mkEvar (evk, args) in let j = (Retyping.get_judgment_of env.ExtraEnv.env !evdref c) in - inh_conv_coerce_to_tycon loc env evdref j tycon + inh_conv_coerce_to_tycon ?loc env evdref j tycon - | GPatVar (loc,(someta,n)) -> + | GPatVar (someta,n) -> let env = ltac_interp_name_env k0 lvar env !evdref in let ty = match tycon with @@ -610,7 +634,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let k = Evar_kinds.MatchingVar (someta,n) in { uj_val = e_new_evar env evdref ~src:(loc,k) ty; uj_type = ty } - | GHole (loc, k, naming, None) -> + | GHole (k, naming, None) -> let env = ltac_interp_name_env k0 lvar env !evdref in let ty = match tycon with @@ -619,19 +643,22 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre new_type_evar env evdref loc in { uj_val = e_new_evar env evdref ~src:(loc,k) ~naming ty; uj_type = ty } - | GHole (loc, k, _naming, Some arg) -> + | GHole (k, _naming, Some arg) -> let env = ltac_interp_name_env k0 lvar env !evdref in let ty = match tycon with | Some ty -> ty | None -> new_type_evar env evdref loc in + let open Genarg in let ist = lvar.ltac_genargs in - let (c, sigma) = Hook.get f_genarg_interp ty env.ExtraEnv.env !evdref ist arg in + let GenArg (Glbwit tag, arg) = arg in + let interp = ConstrInterp.obj tag in + let (c, sigma) = interp ist env.ExtraEnv.env !evdref ty arg in let () = evdref := sigma in { uj_val = c; uj_type = ty } - | GRec (loc,fixkind,names,bl,lar,vdef) -> + | GRec (fixkind,names,bl,lar,vdef) -> let rec type_bl env ctxt = function [] -> ctxt | (na,bk,None,ty)::bl -> @@ -679,7 +706,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) ctxtv vdef in - Typing.check_type_fixpoint loc env.ExtraEnv.env evdref names ftys vdefj; + Typing.check_type_fixpoint ?loc env.ExtraEnv.env evdref names ftys vdefj; let nf c = nf_evar !evdref c in let ftys = Array.map nf ftys in (** FIXME *) let fdefs = Array.map (fun x -> nf (j_val x)) vdefj in @@ -701,7 +728,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let fixdecls = (names,ftys,fdefs) in let indexes = search_guard - loc env.ExtraEnv.env possible_indexes (nf_fix !evdref fixdecls) + ?loc env.ExtraEnv.env possible_indexes (nf_fix !evdref fixdecls) in make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | GCoFix i -> @@ -710,17 +737,17 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre (try check_cofix env.ExtraEnv.env (i, nf_fix !evdref fixdecls) with reraise -> let (e, info) = CErrors.push reraise in - let info = Loc.add_loc info loc in + let info = Option.cata (Loc.add_loc info) info loc in iraise (e, info)); make_judge (mkCoFix cofix) ftys.(i) in - inh_conv_coerce_to_tycon loc env evdref fixj tycon + inh_conv_coerce_to_tycon ?loc env evdref fixj tycon - | GSort (loc,s) -> - let j = pretype_sort loc evdref s in - inh_conv_coerce_to_tycon loc env evdref j tycon + | GSort s -> + let j = pretype_sort ?loc evdref s in + inh_conv_coerce_to_tycon ?loc env evdref j tycon - | GApp (loc,f,args) -> + | GApp (f,args) -> let fj = pretype empty_tycon env evdref lvar f in let floc = loc_of_glob_constr f in let length = List.length args in @@ -773,6 +800,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre args, nf_evar !evdref (j_val hj) else [], j_val hj in + let ujval = adjust_evar_source evdref na ujval in let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in let j = { uj_val = value; uj_type = typ } in apply_rec env (n+1) j candargs rest @@ -780,7 +808,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | _ -> let hj = pretype empty_tycon env evdref lvar c in error_cant_apply_not_functional - ~loc:(Loc.merge floc argloc) env.ExtraEnv.env !evdref + ?loc:(Loc.merge_opt floc argloc) env.ExtraEnv.env !evdref resj [|hj|] in let resj = apply_rec env 1 fj candargs args in @@ -797,19 +825,19 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre else resj | _ -> resj in - inh_conv_coerce_to_tycon loc env evdref resj tycon + inh_conv_coerce_to_tycon ?loc env evdref resj tycon - | GLambda(loc,name,bk,c1,c2) -> + | GLambda(name,bk,c1,c2) -> let tycon' = evd_comb1 (fun evd tycon -> match tycon with | None -> evd, tycon | Some ty -> - let evd, ty' = Coercion.inh_coerce_to_prod loc env.ExtraEnv.env evd ty in + let evd, ty' = Coercion.inh_coerce_to_prod ?loc env.ExtraEnv.env evd ty in evd, Some ty') evdref tycon in - let (name',dom,rng) = evd_comb1 (split_tycon loc env.ExtraEnv.env) evdref tycon' in + let (name',dom,rng) = evd_comb1 (split_tycon ?loc env.ExtraEnv.env) evdref tycon' in let dom_valcon = valcon_of_tycon dom in let j = pretype_type dom_valcon env evdref lvar c1 in (* The name specified by ltac is used also to create bindings. So @@ -819,9 +847,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let j' = pretype rng (push_rel !evdref var env) evdref lvar c2 in let name = ltac_interp_name lvar name in let resj = judge_of_abstraction env.ExtraEnv.env (orelse_name name name') j j' in - inh_conv_coerce_to_tycon loc env evdref resj tycon + inh_conv_coerce_to_tycon ?loc env evdref resj tycon - | GProd(loc,name,bk,c1,c2) -> + | GProd(name,bk,c1,c2) -> let j = pretype_type empty_valcon env evdref lvar c1 in (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are @@ -841,11 +869,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre judge_of_product env.ExtraEnv.env name j j' with TypeError _ as e -> let (e, info) = CErrors.push e in - let info = Loc.add_loc info loc in + let info = Option.cata (Loc.add_loc info) info loc in iraise (e, info) in - inh_conv_coerce_to_tycon loc env evdref resj tycon + inh_conv_coerce_to_tycon ?loc env evdref resj tycon - | GLetIn(loc,name,c1,t,c2) -> + | GLetIn(name,c1,t,c2) -> let tycon1 = match t with | Some t -> @@ -866,21 +894,21 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; uj_type = subst1 j.uj_val j'.uj_type } - | GLetTuple (loc,nal,(na,po),c,d) -> + | GLetTuple (nal,(na,po),c,d) -> let cj = pretype empty_tycon env evdref lvar c in let (IndType (indf,realargs)) = try find_rectype env.ExtraEnv.env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in - error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj + error_case_not_inductive ?loc:cloc env.ExtraEnv.env !evdref cj in let cstrs = get_constructors env.ExtraEnv.env indf in if not (Int.equal (Array.length cstrs) 1) then - user_err ~loc (str "Destructing let is only for inductive types" ++ + user_err ?loc (str "Destructing let is only for inductive types" ++ str " with one constructor."); let cs = cstrs.(0) in if not (Int.equal (List.length nal) cs.cs_nargs) then - user_err ~loc:loc (str "Destructing let on this type expects " ++ + user_err ?loc:loc (str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables."); let fsign, record = let set_name na d = set_name na (map_rel_decl EConstr.of_constr d) in @@ -949,7 +977,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre if noccur_between !evdref 1 cs.cs_nargs ccl then lift (- cs.cs_nargs) ccl else - error_cant_find_case_type ~loc env.ExtraEnv.env !evdref + error_cant_find_case_type ?loc env.ExtraEnv.env !evdref cj.uj_val in (* let ccl = refresh_universes ccl in *) let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in @@ -959,16 +987,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre obj ind p cj.uj_val fj.uj_val in { uj_val = v; uj_type = ccl }) - | GIf (loc,c,(na,po),b1,b2) -> + | GIf (c,(na,po),b1,b2) -> let cj = pretype empty_tycon env evdref lvar c in let (IndType (indf,realargs)) = try find_rectype env.ExtraEnv.env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in - error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj in + error_case_not_inductive ?loc:cloc env.ExtraEnv.env !evdref cj in let cstrs = get_constructors env.ExtraEnv.env indf in if not (Int.equal (Array.length cstrs) 2) then - user_err ~loc + user_err ?loc (str "If is only for inductive types with two constructors."); let arsgn = @@ -1025,19 +1053,19 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in let cj = { uj_val = v; uj_type = p } in - inh_conv_coerce_to_tycon loc env evdref cj tycon + inh_conv_coerce_to_tycon ?loc env evdref cj tycon - | GCases (loc,sty,po,tml,eqns) -> - Cases.compile_cases loc sty + | GCases (sty,po,tml,eqns) -> + Cases.compile_cases ?loc sty ((fun vtyc env evdref -> pretype vtyc (make_env env !evdref) evdref lvar),evdref) tycon env.ExtraEnv.env (* loc *) (po,tml,eqns) - | GCast (loc,c,k) -> + | GCast (c,k) -> let cj = match k with | CastCoerce -> let cj = pretype empty_tycon env evdref lvar c in - evd_comb1 (Coercion.inh_coerce_to_base loc env.ExtraEnv.env) evdref cj + evd_comb1 (Coercion.inh_coerce_to_base ?loc env.ExtraEnv.env) evdref cj | CastConv t | CastVM t | CastNative t -> let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in let tj = pretype_type empty_valcon env evdref lvar t in @@ -1053,9 +1081,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let (evd,b) = Reductionops.vm_infer_conv env.ExtraEnv.env !evdref cty tval in if b then (evdref := evd; cj, tval) else - error_actual_type ~loc env.ExtraEnv.env !evdref cj tval + error_actual_type ?loc env.ExtraEnv.env !evdref cj tval (ConversionFailed (env.ExtraEnv.env,cty,tval)) - else user_err ~loc (str "Cannot check cast with vm: " ++ + else user_err ?loc (str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> let cj = pretype empty_tycon env evdref lvar c in @@ -1064,7 +1092,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let (evd,b) = Nativenorm.native_infer_conv env.ExtraEnv.env !evdref cty tval in if b then (evdref := evd; cj, tval) else - error_actual_type ~loc env.ExtraEnv.env !evdref cj tval + error_actual_type ?loc env.ExtraEnv.env !evdref cj tval (ConversionFailed (env.ExtraEnv.env,cty,tval)) end | _ -> @@ -1072,7 +1100,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre in let v = mkCast (cj.uj_val, k, tval) in { uj_val = v; uj_type = tval } - in inh_conv_coerce_to_tycon loc env evdref cj tycon + in inh_conv_coerce_to_tycon ?loc env evdref cj tycon and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = let f decl (subst,update) = @@ -1092,7 +1120,7 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = let t' = env |> lookup_named id |> NamedDecl.get_type in if is_conv env.ExtraEnv.env !evdref t t' then mkVar id, update else raise Not_found with Not_found -> - user_err ~loc (str "Cannot interpret " ++ + user_err ?loc (str "Cannot interpret " ++ pr_existential_key !evdref evk ++ str " in current context: no binding for " ++ pr_id id ++ str ".") in ((id,c)::subst, update) in @@ -1102,7 +1130,7 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function - | GHole (loc, knd, naming, None) -> + | { loc; CAst.v = GHole (knd, naming, None) } -> let rec is_Type c = match EConstr.kind !evdref c with | Sort s -> begin match ESorts.kind !evdref s with @@ -1133,14 +1161,14 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function | c -> let j = pretype k0 resolve_tc empty_tycon env evdref lvar c in let loc = loc_of_glob_constr c in - let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env.ExtraEnv.env) evdref j in + let tj = evd_comb1 (Coercion.inh_coerce_to_sort ?loc env.ExtraEnv.env) evdref j in match valcon with | None -> tj | Some v -> if e_cumul env.ExtraEnv.env evdref v tj.utj_val then tj else error_unexpected_type - ~loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v + ?loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v let ise_pretype_gen flags env sigma lvar kind c = let env = make_env env sigma in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index f13c10b055..dcacd07209 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -24,7 +24,7 @@ open Misctypes (** An auxiliary function for searching for fixpoint guard indexes *) val search_guard : - Loc.t -> env -> int list list -> rec_declaration -> int array + ?loc:Loc.t -> env -> int list list -> rec_declaration -> int array type typing_constraint = OfType of types | IsType | WithoutTypeConstraint @@ -163,6 +163,6 @@ val ise_pretype_gen : val interp_sort : ?loc:Loc.t -> evar_map -> glob_sort -> evar_map * sorts val interp_elimination_sort : glob_sort -> sorts_family -val genarg_interp_hook : - (types -> env -> evar_map -> unbound_ltac_var_map -> - Genarg.glob_generic_argument -> constr * evar_map) Hook.t +val register_constr_interp0 : + ('r, 'g, 't) Genarg.genarg_type -> + (unbound_ltac_var_map -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit diff --git a/pretyping/program.ml b/pretyping/program.ml index 42acc5705b..2fa3facb30 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -6,26 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open CErrors open Util -open Names -let make_dir l = DirPath.make (List.rev_map Id.of_string l) - -let find_reference locstr dir s = - let dp = make_dir dir in - let sp = Libnames.make_path dp (Id.of_string s) in - try Nametab.global_of_path sp - with Not_found -> - user_err (str "Library " ++ Libnames.pr_dirpath dp ++ - str " has to be required first.") - -let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s -let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s) - -let init_constant dir s () = coq_constant "Program" dir s -let init_reference dir s () = coq_reference "Program" dir s +let init_reference dir s () = Coqlib.coq_reference "Program" dir s let papp evdref r args = let open EConstr in @@ -54,20 +38,25 @@ let coq_eq_rect = init_reference ["Init"; "Logic"] "eq_rect" let coq_JMeq_ind = init_reference ["Logic";"JMeq"] "JMeq" let coq_JMeq_refl = init_reference ["Logic";"JMeq"] "JMeq_refl" -let coq_not = init_constant ["Init";"Logic"] "not" -let coq_and = init_constant ["Init";"Logic"] "and" +let coq_not = init_reference ["Init";"Logic"] "not" +let coq_and = init_reference ["Init";"Logic"] "and" -let delayed_force c = EConstr.of_constr (c ()) +let new_global sigma gr = + let open Sigma in + let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map sigma) gr + in Sigma.to_evar_map sigma, c -let mk_coq_not x = EConstr.mkApp (delayed_force coq_not, [| x |]) +let mk_coq_not sigma x = + let sigma, notc = new_global sigma (coq_not ()) in + sigma, EConstr.mkApp (notc, [| x |]) let unsafe_fold_right f = function hd :: tl -> List.fold_right f tl hd | [] -> invalid_arg "unsafe_fold_right" -let mk_coq_and l = - let and_typ = delayed_force coq_and in - unsafe_fold_right +let mk_coq_and sigma l = + let sigma, and_typ = new_global sigma (coq_and ()) in + sigma, unsafe_fold_right (fun c conj -> EConstr.mkApp (and_typ, [| c ; conj |])) l @@ -87,8 +76,7 @@ open Goptions let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "preferred transparency of Program obligations"; optkey = ["Transparent";"Obligations"]; optread = get_proofs_transparency; @@ -96,8 +84,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "program cases"; optkey = ["Program";"Cases"]; optread = (fun () -> !program_cases); @@ -105,8 +92,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "program generalized coercion"; optkey = ["Program";"Generalized";"Coercion"]; optread = (fun () -> !program_generalized_coercion); diff --git a/pretyping/program.mli b/pretyping/program.mli index 94a7bdcb6d..8439b9528c 100644 --- a/pretyping/program.mli +++ b/pretyping/program.mli @@ -32,8 +32,8 @@ val coq_eq_rect : unit -> global_reference val coq_JMeq_ind : unit -> global_reference val coq_JMeq_refl : unit -> global_reference -val mk_coq_and : constr list -> constr -val mk_coq_not : constr -> constr +val mk_coq_and : Evd.evar_map -> constr list -> Evd.evar_map * constr +val mk_coq_not : Evd.evar_map -> constr -> Evd.evar_map * constr (** Polymorphic application of delayed references *) val papp : Evd.evar_map ref -> (unit -> global_reference) -> constr array -> constr diff --git a/pretyping/redops.ml b/pretyping/redops.ml index 7d65925e57..8e190f40b9 100644 --- a/pretyping/redops.ml +++ b/pretyping/redops.ml @@ -20,13 +20,13 @@ let make_red_flag l = | FZeta :: lf -> add_flag { red with rZeta = true } lf | FConst l :: lf -> if red.rDelta then - CErrors.error - "Cannot set both constants to unfold and constants not to unfold"; + CErrors.user_err Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); add_flag { red with rConst = union_consts red.rConst l } lf | FDeltaBut l :: lf -> if red.rConst <> [] && not red.rDelta then - CErrors.error - "Cannot set both constants to unfold and constants not to unfold"; + CErrors.user_err Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); add_flag { red with rConst = union_consts red.rConst l; rDelta = true } lf diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index dcb19b31af..5a2328aaa4 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -29,7 +29,7 @@ exception Elimconst let refolding_in_reduction = ref false let _ = Goptions.declare_bool_option { - Goptions.optsync = true; Goptions.optdepr = false; + Goptions.optdepr = false; Goptions.optname = "Perform refolding of fixpoints/constants like cbn during reductions"; Goptions.optkey = ["Refolding";"Reduction"]; @@ -811,7 +811,7 @@ let fix_recarg ((recindices,bodynum),_) stack = let debug_RAKAM = ref (false) let _ = Goptions.declare_bool_option { - Goptions.optsync = true; Goptions.optdepr = false; + Goptions.optdepr = false; Goptions.optname = "Print states of the Reductionops abstract machine"; Goptions.optkey = ["Debug";"RAKAM"]; @@ -1219,7 +1219,7 @@ let clos_norm_flags flgs env sigma t = EConstr.of_constr (CClosure.norm_val (CClosure.create_clos_infos ~evars flgs env) (CClosure.inject (EConstr.Unsafe.to_constr t))) - with e when is_anomaly e -> error "Tried to normalize ill-typed term" + with e when is_anomaly e -> user_err Pp.(str "Tried to normalize ill-typed term") let clos_whd_flags flgs env sigma t = try @@ -1227,7 +1227,7 @@ let clos_whd_flags flgs env sigma t = EConstr.of_constr (CClosure.whd_val (CClosure.create_clos_infos ~evars flgs env) (CClosure.inject (EConstr.Unsafe.to_constr t))) - with e when is_anomaly e -> error "Tried to normalize ill-typed term" + with e when is_anomaly e -> user_err Pp.(str "Tried to normalize ill-typed term") let nf_beta = clos_norm_flags CClosure.beta (Global.env ()) let nf_betaiota = clos_norm_flags CClosure.betaiota (Global.env ()) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 67221046bd..3d41d2ddd5 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -858,7 +858,7 @@ let try_red_product env sigma c = let red_product env sigma c = try try_red_product env sigma c - with Redelimination -> error "No head constant to reduce." + with Redelimination -> user_err (str "No head constant to reduce.") (* (* This old version of hnf uses betadeltaiota instead of itself (resp @@ -1080,7 +1080,7 @@ let unfold env sigma name c = if is_evaluable env name then clos_norm_flags (unfold_red name) env sigma c else - error (string_of_evaluable_ref env name^" is opaque.") + user_err Pp.(str (string_of_evaluable_ref env name^" is opaque.")) (* [unfoldoccs : (readable_constraints -> (int list * full_path) -> constr -> constr)] * Unfolds the constant name in a term c following a list of occurrences occl. @@ -1090,7 +1090,7 @@ let unfoldoccs env sigma (occs,name) c = let unfo nowhere_except_in locs = let (nbocc,uc) = substlin env sigma name 1 (nowhere_except_in,locs) c in if Int.equal nbocc 1 then - error ((string_of_evaluable_ref env name)^" does not occur."); + user_err Pp.(str ((string_of_evaluable_ref env name)^" does not occur.")); let rest = List.filter (fun o -> o >= nbocc) locs in let () = match rest with | [] -> () @@ -1112,7 +1112,7 @@ let unfoldn loccname env sigma c = let fold_one_com com env sigma c = let rcom = try red_product env sigma com - with Redelimination -> error "Not reducible." in + with Redelimination -> user_err Pp.(str "Not reducible.") in (* Reason first on the beta-iota-zeta normal form of the constant as unfold produces it, so that the "unfold f; fold f" configuration works to refold fix expressions *) @@ -1147,7 +1147,7 @@ let compute = cbv_betadeltaiota let abstract_scheme env sigma (locc,a) (c, sigma) = let ta = Retyping.get_type_of env sigma a in let na = named_hd env sigma ta Anonymous in - if occur_meta sigma ta then error "Cannot find a type for the generalisation."; + if occur_meta sigma ta then user_err Pp.(str "Cannot find a type for the generalisation."); if occur_meta sigma a then mkLambda (na,ta,c), sigma else diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 93c71e6ea9..d7b4842810 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -30,8 +30,7 @@ open Goptions let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "check that typeclasses proof search returns unique solutions"; optkey = ["Typeclasses";"Unique";"Solutions"]; optread = get_typeclasses_unique_solutions; @@ -423,7 +422,7 @@ let add_class cl = match inst with | Some (Backward, info) -> (match body with - | None -> CErrors.error "Non-definable projection can not be declared as a subinstance" + | None -> CErrors.user_err Pp.(str "Non-definable projection can not be declared as a subinstance") | Some b -> declare_instance (Some info) false (ConstRef b)) | _ -> ()) cl.cl_projs diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 00535adb7d..757e12451e 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -152,13 +152,13 @@ let e_judge_of_case env evdref ci pj cj lfj = { uj_val = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj); uj_type = rslty } -let check_type_fixpoint loc env evdref lna lar vdefj = +let check_type_fixpoint ?loc env evdref lna lar vdefj = let lt = Array.length vdefj in if Int.equal (Array.length lar) lt then for i = 0 to lt-1 do if not (Evarconv.e_cumul env evdref (vdefj.(i)).uj_type (lift lt lar.(i))) then - error_ill_typed_rec_body ~loc env !evdref + error_ill_typed_rec_body ?loc env !evdref i lna vdefj lar done @@ -360,7 +360,7 @@ and execute_recdef env evdref (names,lar,vdef) = let env1 = push_rec_types (names,lara,vdef) env in let vdefj = execute_array env1 evdref vdef in let vdefv = Array.map j_val vdefj in - let _ = check_type_fixpoint Loc.ghost env1 evdref names lara vdefj in + let _ = check_type_fixpoint env1 evdref names lara vdefj in (names,lara,vdefv) and execute_array env evdref = Array.map (execute env evdref) diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 91134b4999..1f3ba34e51 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -44,7 +44,7 @@ val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr -> (** Raise an error message if bodies have types not unifiable with the expected ones *) -val check_type_fixpoint : Loc.t -> env -> evar_map ref -> +val check_type_fixpoint : ?loc:Loc.t -> env -> evar_map ref -> Names.Name.t array -> types array -> unsafe_judgment array -> unit val judge_of_prop : unsafe_judgment diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 661c1d8657..d1643a8c7d 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -45,7 +45,7 @@ module NamedDecl = Context.Named.Declaration let keyed_unification = ref (false) let _ = Goptions.declare_bool_option { - Goptions.optsync = true; Goptions.optdepr = false; + Goptions.optdepr = false; Goptions.optname = "Unification is keyed"; Goptions.optkey = ["Keyed";"Unification"]; Goptions.optread = (fun () -> !keyed_unification); @@ -56,7 +56,7 @@ let is_keyed_unification () = !keyed_unification let debug_unification = ref (false) let _ = Goptions.declare_bool_option { - Goptions.optsync = true; Goptions.optdepr = false; + Goptions.optdepr = false; Goptions.optname = "Print states sent to tactic unification"; Goptions.optkey = ["Debug";"Tactic";"Unification"]; @@ -257,8 +257,7 @@ let global_pattern_unification_flag = ref true open Goptions let _ = declare_bool_option - { optsync = true; - optdepr = true; + { optdepr = true; optname = "pattern-unification for existential variables in tactics"; optkey = ["Tactic";"Evars";"Pattern";"Unification"]; optread = (fun () -> !global_pattern_unification_flag); @@ -269,8 +268,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "pattern-unification for existential variables in tactics"; optkey = ["Tactic";"Pattern";"Unification"]; optread = (fun () -> !global_pattern_unification_flag); @@ -1250,9 +1248,9 @@ let applyHead env (type r) (evd : r Sigma.t) n c = let sigma = Sigma.to_evar_map evd in match EConstr.kind sigma (whd_all env sigma cty) with | Prod (_,c1,c2) -> - let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in + let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.tag Evar_kinds.GoalEvar) c1 in apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd' - | _ -> error "Apply_Head_Then" + | _ -> user_err Pp.(str "Apply_Head_Then") in apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c) Sigma.refl evd @@ -1265,7 +1263,7 @@ let is_mimick_head sigma ts f = let try_to_coerce env evd c cty tycon = let j = make_judge c cty in - let (evd',j') = inh_conv_coerce_rigid_to true Loc.ghost env evd j tycon in + let (evd',j') = inh_conv_coerce_rigid_to true env evd j tycon in let evd' = Evarconv.solve_unif_constraints_with_heuristics env evd' in let evd' = Evd.map_metas_fvalue (fun c -> EConstr.Unsafe.to_constr (nf_evar evd' (EConstr.of_constr c))) evd' in (evd',j'.uj_val) @@ -1518,7 +1516,7 @@ let w_typed_unify_array env evd flags f1 l1 f2 l2 = let iter_fail f a = let n = Array.length a in let rec ffail i = - if Int.equal i n then error "iter_fail" + if Int.equal i n then user_err Pp.(str "iter_fail") else try f a.(i) with ex when precatchable_exception ex -> ffail (i+1) @@ -1756,8 +1754,8 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = w_typed_unify_array env evd flags f1 l1 f2 l2,cl else w_typed_unify env evd CONV flags op cl,cl with ex when Pretype_errors.unsatisfiable_exception ex -> - bestexn := Some ex; error "Unsat") - else error "Bound 1" + bestexn := Some ex; user_err Pp.(str "Unsat")) + else user_err Pp.(str "Bound 1") with ex when precatchable_exception ex -> (match EConstr.kind evd cl with | App (f,args) -> @@ -1806,7 +1804,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = with ex when precatchable_exception ex -> matchrec c) - | _ -> error "Match_subterm")) + | _ -> user_err Pp.(str "Match_subterm"))) in try matchrec cl with ex when precatchable_exception ex -> @@ -1822,7 +1820,7 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = let (evd,c as a) = a () in if List.exists (fun (evd',c') -> EConstr.eq_constr evd' c c') b then b else a :: b in - let fail str _ = error str in + let fail str _ = user_err (Pp.str str) in let bind f g a = let a1 = try f a with ex @@ -1958,7 +1956,7 @@ let w_unify2 env evd flags dep cv_pb ty1 ty2 = | _, Meta p2 -> (* Find the predicate *) secondOrderAbstractionAlgo dep env evd flags ty1 (p2, oplist2) - | _ -> error "w_unify2" + | _ -> user_err Pp.(str "w_unify2") (* The unique unification algorithm works like this: If the pattern is flexible, and the goal has a lambda-abstraction at the head, then diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 148178f2fc..8d7e3521d6 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -45,7 +45,7 @@ val elim_no_delta_flags : unit -> unify_flags val is_keyed_unification : unit -> bool -(** The "unique" unification fonction *) +(** The "unique" unification function *) val w_unify : env -> evar_map -> conv_pb -> ?flags:unify_flags -> constr -> constr -> evar_map diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 74998349be..b08666483e 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -355,7 +355,7 @@ and nf_cofix env sigma cf = let cbv_vm env sigma c t = if Termops.occur_meta_or_existential sigma c then - CErrors.error "vm_compute does not support existential variables."; + CErrors.user_err Pp.(str "vm_compute does not support existential variables."); (** This evar-normalizes terms beforehand *) let c = EConstr.to_constr sigma c in let t = EConstr.to_constr sigma t in diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index b546c39aec..60511d9138 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -145,14 +145,14 @@ let tag_var = tag Tag.variable if !Flags.beautify && not (Int.equal n 0) then comment (CLexer.extract_comments n) else mt() - let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp) + let pr_with_comments ?loc pp = pr_located (fun x -> x) (Loc.tag ?loc pp) - let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c) + let pr_sep_com sep f c = pr_with_comments ?loc:(constr_loc c) (sep() ++ f c) let pr_univ l = match l with - | [_,x] -> pr_name x - | l -> str"max(" ++ prlist_with_sep (fun () -> str",") (fun x -> pr_name (snd x)) l ++ str")" + | [_,x] -> Name.print x + | l -> str"max(" ++ prlist_with_sep (fun () -> str",") (fun x -> Name.print (snd x)) l ++ str")" let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}" @@ -166,7 +166,7 @@ let tag_var = tag Tag.variable | GProp -> tag_type (str "Prop") | GSet -> tag_type (str "Set") | GType None -> tag_type (str "Type") - | GType (Some (_, u)) -> tag_type (pr_name u) + | GType (Some (_, u)) -> tag_type (Name.print u) let pr_qualid sp = let (sl, id) = repr_qualid sp in @@ -191,7 +191,7 @@ let tag_var = tag Tag.variable tag_type (str "Set") | GType u -> (match u with - | Some (_,u) -> pr_name u + | Some (_,u) -> Name.print u | None -> tag_type (str "Type")) let pr_universe_instance l = @@ -213,19 +213,18 @@ let tag_var = tag Tag.variable str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")" let pr_opt_type_spc pr = function - | CHole (_,_,Misctypes.IntroAnonymous,_) -> mt () + | { CAst.v = CHole (_,Misctypes.IntroAnonymous,_) } -> mt () | t -> str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t let pr_lident (loc,id) = - if not (Loc.is_ghost loc) then - let (b,_) = Loc.unloc loc in - pr_located pr_id (Loc.make_loc (b,b + String.length (Id.to_string id)), id) - else - pr_id id + match loc with + | None -> pr_id id + | Some loc -> let (b,_) = Loc.unloc loc in + pr_located pr_id @@ Loc.tag ~loc:(Loc.make_loc (b,b + String.length (Id.to_string id))) id let pr_lname = function | (loc,Name id) -> pr_lident (loc,id) - | lna -> pr_located pr_name lna + | lna -> pr_located Name.print lna let pr_or_var pr = function | ArgArg x -> pr x @@ -249,73 +248,75 @@ let tag_var = tag Tag.variable let lpatrec = 0 let rec pr_patt sep inh p = - let (strm,prec) = match p with - | CPatRecord (_, l) -> + let (strm,prec) = match CAst.(p.v) with + | CPatRecord l -> let pp (c, p) = pr_reference c ++ spc() ++ str ":=" ++ pr_patt spc (lpatrec, Any) p in str "{| " ++ prlist_with_sep pr_semicolon pp l ++ str " |}", lpatrec - | CPatAlias (_, p, id) -> + | CPatAlias (p, id) -> pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las - | CPatCstr (_,c, None, []) -> + | CPatCstr (c, None, []) -> pr_reference c, latom - | CPatCstr (_, c, None, args) -> + | CPatCstr (c, None, args) -> pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp - | CPatCstr (_, c, Some args, []) -> + | CPatCstr (c, Some args, []) -> str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp - | CPatCstr (_, c, Some expl_args, extra_args) -> + | CPatCstr (c, Some expl_args, extra_args) -> surround (str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) expl_args) ++ prlist (pr_patt spc (lapp,L)) extra_args, lapp - | CPatAtom (_, None) -> + | CPatAtom (None) -> str "_", latom - | CPatAtom (_,Some r) -> + | CPatAtom (Some r) -> pr_reference r, latom - | CPatOr (_,pl) -> + | CPatOr pl -> hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator - | CPatNotation (_,"( _ )",([p],[]),[]) -> + | CPatNotation ("( _ )",([p],[]),[]) -> pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom - | CPatNotation (_,s,(l,ll),args) -> + | CPatNotation (s,(l,ll),args) -> let strm_not, l_not = pr_notation (pr_patt mt) (fun _ _ _ -> mt()) s (l,ll,[]) in (if List.is_empty args||prec_less l_not (lapp,L) then strm_not else surround strm_not) ++ prlist (pr_patt spc (lapp,L)) args, if not (List.is_empty args) then lapp else l_not - | CPatPrim (_,p) -> + | CPatPrim p -> pr_prim_token p, latom - | CPatDelimiters (_,k,p) -> + | CPatDelimiters (k,p) -> pr_delimiters k (pr_patt mt lsimplepatt p), 1 | CPatCast _ -> assert false in - let loc = cases_pattern_expr_loc p in - pr_with_comments loc + let loc = p.CAst.loc in + pr_with_comments ?loc (sep() ++ if prec_less prec inh then strm else surround strm) let pr_patt = pr_patt mt - let pr_eqn pr (loc,pl,rhs) = + let pr_eqn pr (loc,(pl,rhs)) = let pl = List.map snd pl in spc() ++ hov 4 - (pr_with_comments loc + (pr_with_comments ?loc (str "| " ++ hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl ++ str " =>") ++ pr_sep_com spc (pr ltop) rhs)) - let begin_of_binder = function - | CLocalDef((loc,_),_,_) -> fst (Loc.unloc loc) - | CLocalAssum((loc,_)::_,_,_) -> fst (Loc.unloc loc) - | CLocalPattern(loc,_,_) -> fst (Loc.unloc loc) + let begin_of_binder l_bi = + let b_loc l = fst (Option.cata Loc.unloc (0,0) l) in + match l_bi with + | CLocalDef((loc,_),_,_) -> b_loc loc + | CLocalAssum((loc,_)::_,_,_) -> b_loc loc + | CLocalPattern(loc,(_,_)) -> b_loc loc | _ -> assert false let begin_of_binders = function @@ -348,7 +349,7 @@ let tag_var = tag Tag.variable end | Default b -> match t with - | CHole (_,_,Misctypes.IntroAnonymous,_) -> + | { CAst.v = CHole (_,Misctypes.IntroAnonymous,_) } -> let s = prlist_with_sep spc pr_lname nal in hov 1 (surround_implicit b s) | _ -> @@ -362,7 +363,7 @@ let tag_var = tag Tag.variable surround (pr_lname na ++ pr_opt_no_spc (fun t -> str " :" ++ ws 1 ++ pr_c t) topt ++ str" :=" ++ spc() ++ pr_c c) - | CLocalPattern (loc,p,tyo) -> + | CLocalPattern (loc,(p,tyo)) -> let p = pr_patt lsimplepatt p in match tyo with | None -> @@ -386,43 +387,44 @@ let tag_var = tag Tag.variable if is_open then pr_delimited_binders pr_com_at sep pr_c else pr_undelimited_binders sep pr_c - let rec extract_prod_binders = function + let rec extract_prod_binders = let open CAst in function (* | CLetIn (loc,na,b,c) as x -> let bl,c = extract_prod_binders c in if bl = [] then [], x else CLocalDef (na,b) :: bl, c*) - | CProdN (loc,[],c) -> + | { v = CProdN ([],c) } -> extract_prod_binders c - | CProdN (loc,[[_,Name id],bk,t], - CCases (_,LetPatternStyle,None, [CRef (Ident (_,id'),None),None,None],[(_,[_,[p]],b)])) + | { loc; v = CProdN ([[_,Name id],bk,t], + { v = CCases (LetPatternStyle,None, [{ v = CRef (Ident (_,id'),None)},None,None],[(_,([_,[p]],b))])} ) } when Id.equal id id' && not (Id.Set.mem id (Topconstr.free_vars_of_constr_expr b)) -> let bl,c = extract_prod_binders b in - CLocalPattern (loc,p,None) :: bl, c - | CProdN (loc,(nal,bk,t)::bl,c) -> - let bl,c = extract_prod_binders (CProdN(loc,bl,c)) in + CLocalPattern (loc, (p,None)) :: bl, c + | { loc; v = CProdN ((nal,bk,t)::bl,c) } -> + let bl,c = extract_prod_binders (CAst.make ?loc @@ CProdN(bl,c)) in CLocalAssum (nal,bk,t) :: bl, c | c -> [], c - let rec extract_lam_binders = function + let rec extract_lam_binders ce = let open CAst in match ce.v with (* | CLetIn (loc,na,b,c) as x -> let bl,c = extract_lam_binders c in if bl = [] then [], x else CLocalDef (na,b) :: bl, c*) - | CLambdaN (loc,[],c) -> + | CLambdaN ([],c) -> extract_lam_binders c - | CLambdaN (loc,[[_,Name id],bk,t], - CCases (_,LetPatternStyle,None, [CRef (Ident (_,id'),None),None,None],[(_,[_,[p]],b)])) + | CLambdaN ([[_,Name id],bk,t], + { v = CCases (LetPatternStyle,None, [{ v = CRef (Ident (_,id'),None)},None,None],[(_,([_,[p]],b))])} ) when Id.equal id id' && not (Id.Set.mem id (Topconstr.free_vars_of_constr_expr b)) -> let bl,c = extract_lam_binders b in - CLocalPattern (loc,p,None) :: bl, c - | CLambdaN (loc,(nal,bk,t)::bl,c) -> - let bl,c = extract_lam_binders (CLambdaN(loc,bl,c)) in + CLocalPattern (ce.loc,(p,None)) :: bl, c + | CLambdaN ((nal,bk,t)::bl,c) -> + let bl,c = extract_lam_binders (CAst.make ?loc:ce.loc @@ CLambdaN(bl,c)) in CLocalAssum (nal,bk,t) :: bl, c - | c -> [], c + | _ -> [], ce - let split_lambda = function - | CLambdaN (loc,[[na],bk,t],c) -> (na,t,c) - | CLambdaN (loc,([na],bk,t)::bl,c) -> (na,t,CLambdaN(loc,bl,c)) - | CLambdaN (loc,(na::nal,bk,t)::bl,c) -> (na,t,CLambdaN(loc,(nal,bk,t)::bl,c)) + let split_lambda = CAst.with_loc_val (fun ?loc -> function + | CLambdaN ([[na],bk,t],c) -> (na,t,c) + | CLambdaN (([na],bk,t)::bl,c) -> (na,t, CAst.make ?loc @@ CLambdaN(bl,c)) + | CLambdaN ((na::nal,bk,t)::bl,c) -> (na,t, CAst.make ?loc @@ CLambdaN((nal,bk,t)::bl,c)) | _ -> anomaly (Pp.str "ill-formed fixpoint body") + ) let rename na na' t c = match (na,na') with @@ -431,12 +433,13 @@ let tag_var = tag Tag.variable | (_,Name id), (_,Anonymous) -> (na,t,c) | _ -> (na',t,c) - let split_product na' = function - | CProdN (loc,[[na],bk,t],c) -> rename na na' t c - | CProdN (loc,([na],bk,t)::bl,c) -> rename na na' t (CProdN(loc,bl,c)) - | CProdN (loc,(na::nal,bk,t)::bl,c) -> - rename na na' t (CProdN(loc,(nal,bk,t)::bl,c)) + let split_product na' = CAst.with_loc_val (fun ?loc -> function + | CProdN ([[na],bk,t],c) -> rename na na' t c + | CProdN (([na],bk,t)::bl,c) -> rename na na' t (CAst.make ?loc @@ CProdN(bl,c)) + | CProdN ((na::nal,bk,t)::bl,c) -> + rename na na' t (CAst.make ?loc @@ CProdN((nal,bk,t)::bl,c)) | _ -> anomaly (Pp.str "ill-formed fixpoint body") + ) let rec split_fix n typ def = if Int.equal n 0 then ([],typ,def) @@ -502,7 +505,7 @@ let tag_var = tag Tag.variable let pr_case_type pr po = match po with - | None | Some (CHole (_,_,Misctypes.IntroAnonymous,_)) -> mt() + | None | Some { CAst.v = CHole (_,Misctypes.IntroAnonymous,_) } -> mt() | Some p -> spc() ++ hov 2 (keyword "return" ++ pr_sep_com spc (pr lsimpleconstr) p) @@ -539,25 +542,25 @@ let tag_var = tag Tag.variable let pr_fun_sep = spc () ++ str "=>" let pr_dangling_with_for sep pr inherited a = - match a with - | (CFix (_,_,[_])|CCoFix(_,_,[_])) -> + match a.CAst.v with + | (CFix (_,[_])|CCoFix(_,[_])) -> pr sep (latom,E) a | _ -> pr sep inherited a let pr pr sep inherited a = let return (cmds, prec) = (tag_constr_expr a cmds, prec) in - let (strm, prec) = match a with + let (strm, prec) = match CAst.(a.v) with | CRef (r, us) -> return (pr_cref r us, latom) - | CFix (_,id,fix) -> + | CFix (id,fix) -> return ( hov 0 (keyword "fix" ++ spc () ++ pr_recursive (pr_fixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) fix), lfix ) - | CCoFix (_,id,cofix) -> + | CCoFix (id,cofix) -> return ( hov 0 (keyword "cofix" ++ spc () ++ pr_recursive @@ -582,7 +585,8 @@ let tag_var = tag Tag.variable pr_fun_sep ++ pr spc ltop a), llambda ) - | CLetIn (_,(_,Name x),(CFix(_,(_,x'),[_])|CCoFix(_,(_,x'),[_]) as fx), t, b) + | CLetIn ((_,Name x), ({ CAst.v = CFix((_,x'),[_])} + | { CAst.v = CCoFix((_,x'),[_]) } as fx), t, b) when Id.equal x x' -> return ( hv 0 ( @@ -592,7 +596,7 @@ let tag_var = tag Tag.variable pr spc ltop b), lletin ) - | CLetIn (_,x,a,t,b) -> + | CLetIn (x,a,t,b) -> return ( hv 0 ( hov 2 (keyword "let" ++ spc () ++ pr_lname x @@ -602,7 +606,7 @@ let tag_var = tag Tag.variable pr spc ltop b), lletin ) - | CAppExpl (_,(Some i,f,us),l) -> + | CAppExpl ((Some i,f,us),l) -> let l1,l2 = List.chop i l in let c,l1 = List.sep_last l1 in let p = pr_proj (pr mt) pr_appexpl c (f,us) l1 in @@ -610,16 +614,16 @@ let tag_var = tag Tag.variable return (p ++ prlist (pr spc (lapp,L)) l2, lapp) else return (p, lproj) - | CAppExpl (_,(None,Ident (_,var),us),[t]) - | CApp (_,(_,CRef(Ident(_,var),us)),[t,None]) + | CAppExpl ((None,Ident (_,var),us),[t]) + | CApp ((_, {CAst.v = CRef(Ident(_,var),us)}),[t,None]) when Id.equal var Notation_ops.ldots_var -> return ( hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."), larg ) - | CAppExpl (_,(None,f,us),l) -> + | CAppExpl ((None,f,us),l) -> return (pr_appexpl (pr mt) (f,us) l, lapp) - | CApp (_,(Some i,f),l) -> + | CApp ((Some i,f),l) -> let l1,l2 = List.chop i l in let c,l1 = List.sep_last l1 in assert (Option.is_empty (snd c)); @@ -631,14 +635,14 @@ let tag_var = tag Tag.variable ) else return (p, lproj) - | CApp (_,(None,a),l) -> + | CApp ((None,a),l) -> return (pr_app (pr mt) a l, lapp) - | CRecord (_,l) -> + | CRecord l -> return ( hv 0 (str"{|" ++ pr_record_body_gen (pr spc) l ++ str" |}"), latom ) - | CCases (_,LetPatternStyle,rtntypopt,[c,as_clause,in_clause],[(_,[(loc,[p])],b)]) -> + | CCases (LetPatternStyle,rtntypopt,[c,as_clause,in_clause],[(_,([(loc,[p])],b))]) -> return ( hv 0 ( keyword "let" ++ spc () ++ str"'" ++ @@ -649,7 +653,7 @@ let tag_var = tag Tag.variable spc () ++ keyword "in" ++ pr spc ltop b)), lletpattern ) - | CCases(_,_,rtntypopt,c,eqns) -> + | CCases(_,rtntypopt,c,eqns) -> return ( v 0 (hv 0 (keyword "match" ++ brk (1,2) ++ @@ -662,7 +666,7 @@ let tag_var = tag Tag.variable ++ keyword "end"), latom ) - | CLetTuple (_,nal,(na,po),c,b) -> + | CLetTuple (nal,(na,po),c,b) -> return ( hv 0 ( hov 2 (keyword "let" ++ spc () ++ @@ -675,7 +679,7 @@ let tag_var = tag Tag.variable pr spc ltop b), lletin ) - | CIf (_,c,(na,po),b1,b2) -> + | CIf (c,(na,po),b1,b2) -> (* On force les parenthèses autour d'un "if" sous-terme (même si le parsing est lui plus tolérant) *) return ( @@ -689,19 +693,19 @@ let tag_var = tag Tag.variable lif ) - | CHole (_,_,Misctypes.IntroIdentifier id,_) -> + | CHole (_,Misctypes.IntroIdentifier id,_) -> return (str "?[" ++ pr_id id ++ str "]", latom) - | CHole (_,_,Misctypes.IntroFresh id,_) -> + | CHole (_,Misctypes.IntroFresh id,_) -> return (str "?[?" ++ pr_id id ++ str "]", latom) - | CHole (_,_,_,_) -> + | CHole (_,_,_) -> return (str "_", latom) - | CEvar (_,n,l) -> + | CEvar (n,l) -> return (pr_evar (pr mt) n l, latom) - | CPatVar (_,p) -> + | CPatVar p -> return (str "@?" ++ pr_patvar p, latom) - | CSort (_,s) -> + | CSort s -> return (pr_glob_sort s, latom) - | CCast (_,a,b) -> + | CCast (a,b) -> return ( hv 0 (pr mt (lcast,L) a ++ spc () ++ match b with @@ -711,19 +715,19 @@ let tag_var = tag Tag.variable | CastCoerce -> str ":>"), lcast ) - | CNotation (_,"( _ )",([t],[],[])) -> + | CNotation ("( _ )",([t],[],[])) -> return (pr (fun()->str"(") (max_int,L) t ++ str")", latom) - | CNotation (_,s,env) -> + | CNotation (s,env) -> pr_notation (pr mt) (pr_binders_gen (pr mt ltop)) s env - | CGeneralization (_,bk,ak,c) -> + | CGeneralization (bk,ak,c) -> return (pr_generalization bk ak (pr mt ltop c), latom) - | CPrim (_,p) -> + | CPrim p -> return (pr_prim_token p, prec_of_prim_token p) - | CDelimiters (_,sc,a) -> + | CDelimiters (sc,a) -> return (pr_delimiters sc (pr mt (ldelim,E) a), ldelim) in let loc = constr_loc a in - pr_with_comments loc + pr_with_comments ?loc (sep() ++ if prec_less prec inherited then strm else surround strm) type term_pr = { @@ -747,7 +751,7 @@ let tag_var = tag Tag.variable let pr prec c = pr prec (transf (Global.env()) c) let pr_simpleconstr = function - | CAppExpl (_,(None,f,us),[]) -> str "@" ++ pr_cref f us + | { CAst.v = CAppExpl ((None,f,us),[]) } -> str "@" ++ pr_cref f us | c -> pr lsimpleconstr c let default_term_pr = { diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index f92caf426e..482c994c25 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -35,7 +35,7 @@ val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds val pr_lident : Id.t located -> std_ppcmds val pr_lname : Name.t located -> std_ppcmds -val pr_with_comments : Loc.t -> std_ppcmds -> std_ppcmds +val pr_with_comments : ?loc:Loc.t -> std_ppcmds -> std_ppcmds val pr_com_at : int -> std_ppcmds val pr_sep_com : (unit -> std_ppcmds) -> diff --git a/printing/pputils.ml b/printing/pputils.ml index 50630fb9b5..99d07601c4 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -15,14 +15,15 @@ open Locus open Genredexpr let pr_located pr (loc, x) = - if !Flags.beautify && loc <> Loc.ghost then + match loc with + | Some loc when !Flags.beautify -> let (b, e) = Loc.unloc loc in (* Side-effect: order matters *) let before = Pp.comment (CLexer.extract_comments b) in let x = pr x in let after = Pp.comment (CLexer.extract_comments e) in before ++ x ++ after - else pr x + | _ -> pr x let pr_or_var pr = function | ArgArg x -> pr x @@ -95,7 +96,7 @@ let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) keyword = function pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr keyword)) l) | Red true -> - CErrors.error "Shouldn't be accessible from user." + CErrors.user_err Pp.(str "Shouldn't be accessible from user.") | ExtraRedExpr s -> str s | CbvVm o -> @@ -105,7 +106,7 @@ let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) keyword = function let pr_or_by_notation f = function | AN v -> f v - | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc + | ByNotation (_,(s,sc)) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc let hov_if_not_empty n p = if Pp.ismt p then p else hov n p diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 3e41439c8c..6aa136b606 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -32,11 +32,10 @@ open Decl_kinds let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr let pr_lident (loc,id) = - if Loc.is_ghost loc then - let (b,_) = Loc.unloc loc in - pr_located pr_id (Loc.make_loc (b,b + String.length(Id.to_string id)),id) - else - pr_id id + match loc with + | None -> pr_id id + | Some loc -> let (b,_) = Loc.unloc loc in + pr_located pr_id @@ Loc.tag ~loc:(Loc.make_loc (b,b + String.length (Id.to_string id))) id let pr_plident (lid, l) = pr_lident lid ++ @@ -50,15 +49,14 @@ open Decl_kinds let pr_fqid fqid = str (string_of_fqid fqid) let pr_lfqid (loc,fqid) = - if Loc.is_ghost loc then - let (b,_) = Loc.unloc loc in - pr_located pr_fqid (Loc.make_loc (b,b + String.length(string_of_fqid fqid)),fqid) - else - pr_fqid fqid + match loc with + | None -> pr_fqid fqid + | Some loc -> let (b,_) = Loc.unloc loc in + pr_located pr_fqid @@ Loc.tag ~loc:(Loc.make_loc (b,b + String.length (string_of_fqid fqid))) fqid let pr_lname = function | (loc,Name id) -> pr_lident (loc,id) - | lna -> pr_located pr_name lna + | lna -> pr_located Name.print lna let pr_smart_global = Pputils.pr_or_by_notation pr_reference @@ -203,19 +201,19 @@ open Decl_kinds keyword "Module" ++ spc() ++ pr_lfqid id ++ str" := " ++ pr_located pr_qualid qid - let rec pr_module_ast leading_space pr_c = function - | CMident qid -> + let rec pr_module_ast leading_space pr_c = let open CAst in function + | { loc ; v = CMident qid } -> if leading_space then - spc () ++ pr_located pr_qualid qid + spc () ++ pr_located pr_qualid (loc, qid) else - pr_located pr_qualid qid - | CMwith (_,mty,decl) -> + pr_located pr_qualid (loc,qid) + | { v = CMwith (mty,decl) } -> let m = pr_module_ast leading_space pr_c mty in let p = pr_with_declaration pr_c decl in m ++ spc() ++ keyword "with" ++ spc() ++ p - | CMapply (_,me1,(CMident _ as me2)) -> + | { v = CMapply (me1, ( { v = CMident _ } as me2 ) ) } -> pr_module_ast leading_space pr_c me1 ++ spc() ++ pr_module_ast false pr_c me2 - | CMapply (_,me1,me2) -> + | { v = CMapply (me1,me2) } -> pr_module_ast leading_space pr_c me1 ++ spc() ++ hov 1 (str"(" ++ pr_module_ast false pr_c me2 ++ str")") @@ -254,7 +252,7 @@ open Decl_kinds prlist_strict (pr_module_vardecls pr_c) l let pr_type_option pr_c = function - | CHole (loc, k, Misctypes.IntroAnonymous, _) -> mt() + | { CAst.v = CHole (k, Misctypes.IntroAnonymous, _) } -> mt() | _ as c -> brk(0,2) ++ str" :" ++ pr_c c let pr_decl_notation prc ((loc,ntn),c,scopt) = @@ -296,7 +294,7 @@ open Decl_kinds let begin_of_inductive = function | [] -> 0 - | (_,((loc,_),_))::_ -> fst (Loc.unloc loc) + | (_,((loc,_),_))::_ -> Option.cata (fun loc -> fst (Loc.unloc loc)) 0 loc let pr_class_rawexpr = function | FunClass -> keyword "Funclass" @@ -721,9 +719,7 @@ open Decl_kinds | Opaque (Some l) -> keyword "Qed" ++ spc() ++ str"export" ++ prlist_with_sep (fun () -> str", ") pr_lident l) - | Some (id,th) -> (match th with - | None -> (if opac <> Transparent then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id - | Some tok -> keyword "Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id) + | Some id -> (if opac <> Transparent then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id ) | VernacExactProof c -> return (hov 2 (keyword "Proof" ++ pr_lconstrarg c)) @@ -880,7 +876,7 @@ open Decl_kinds (match bk with Implicit -> str "! " | Explicit -> mt ()) ++ pr_constr cl ++ pr_hint_info pr_constr_pattern_expr info ++ (match props with - | Some (true,CRecord (_,l)) -> spc () ++ str":=" ++ spc () ++ str"{" ++ pr_record_body l ++ str "}" + | Some (true, { CAst.v = CRecord l}) -> spc () ++ str":=" ++ spc () ++ str"{" ++ pr_record_body l ++ str "}" | Some (true,_) -> assert false | Some (false,p) -> spc () ++ str":=" ++ spc () ++ pr_constr p | None -> mt())) @@ -1026,13 +1022,13 @@ open Decl_kinds | n, { name = id; recarg_like = k; notation_scope = s; implicit_status = imp } :: tl -> - spc() ++ pr_br imp (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++ + spc() ++ pr_br imp (pr_if k (str"!") ++ Name.print id ++ pr_s s) ++ print_arguments (Option.map pred n) tl in let rec print_implicits = function | [] -> mt () | (name, impl) :: rest -> - spc() ++ pr_br impl (pr_name name) ++ print_implicits rest + spc() ++ pr_br impl (Name.print name) ++ print_implicits rest in print_arguments nargs args ++ if not (List.is_empty more_implicits) then diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 381af83c73..2b21b3f9e8 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -132,7 +132,7 @@ let print_impargs_list prefix l = let print_renames_list prefix l = if List.is_empty l then [] else [add_colon prefix ++ str "Arguments are renamed to " ++ - hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map pr_name l))] + hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map Name.print l))] let need_expansion impl ref = let typ = Global.type_of_global_unsafe ref in @@ -539,7 +539,7 @@ let gallina_print_constant_with_infos sp = let gallina_print_syntactic_def kn = let qid = Nametab.shortest_qualid_of_syndef Id.Set.empty kn and (vars,a) = Syntax_def.search_syntactic_definition kn in - let c = Notation_ops.glob_constr_of_notation_constr Loc.ghost a in + let c = Notation_ops.glob_constr_of_notation_constr a in hov 2 (hov 4 (str "Notation " ++ pr_qualid qid ++ @@ -711,12 +711,12 @@ let read_sec_context r = let dir = try Nametab.locate_section qid with Not_found -> - user_err ~loc ~hdr:"read_sec_context" (str "Unknown section.") in + user_err ?loc ~hdr:"read_sec_context" (str "Unknown section.") in let rec get_cxt in_cxt = function | (_,Lib.OpenedSection ((dir',_),_) as hd)::rest -> if DirPath.equal dir dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest | (_,Lib.ClosedSection _)::rest -> - error "Cannot print the contents of a closed section." + user_err Pp.(str "Cannot print the contents of a closed section.") (* LEM: Actually, we could if we wanted to. *) | [] -> [] | hd::rest -> get_cxt (hd::in_cxt) rest @@ -750,9 +750,9 @@ let print_any_name = function ~hdr:"print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") let print_name = function - | ByNotation (loc,ntn,sc) -> + | ByNotation (loc,(ntn,sc)) -> print_any_name - (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true) + (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc)) | AN ref -> print_any_name (locate_any_name ref) @@ -765,7 +765,7 @@ let print_opaque_name qid = if Declareops.constant_has_body cb then print_constant_with_infos cst else - error "Not a defined constant." + user_err Pp.(str "Not a defined constant.") | IndRef (sp,_) -> print_inductive sp | ConstructRef cstr as gr -> @@ -776,11 +776,11 @@ let print_opaque_name qid = | VarRef id -> env |> lookup_named id |> NamedDecl.set_id id |> print_named_decl -let print_about_any loc k = +let print_about_any ?loc k = match k with | Term ref -> let rb = Reductionops.ReductionBehaviour.print ref in - Dumpglob.add_glob loc ref; + Dumpglob.add_glob ?loc ref; pr_infos_list (print_ref false ref :: blankline :: print_name_infos ref @ @@ -789,7 +789,7 @@ let print_about_any loc k = [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 kn ++ fnl () ++ @@ -798,12 +798,12 @@ let print_about_any loc k = hov 0 (pr_located_qualid k) let print_about = function - | ByNotation (loc,ntn,sc) -> - print_about_any loc - (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true) + | ByNotation (loc,(ntn,sc)) -> + print_about_any ?loc + (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc)) | AN ref -> - print_about_any (loc_of_reference ref) (locate_any_name ref) + print_about_any ?loc:(loc_of_reference ref) (locate_any_name ref) (* for debug *) let inspect depth = diff --git a/printing/printer.ml b/printing/printer.ml index e0ca51f0c9..ebe68680fb 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -44,8 +44,7 @@ let should_gname() = !enable_goal_names_printing let _ = let open Goptions in declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "printing of unfocused goal"; optkey = ["Printing";"Unfocused"]; optread = (fun () -> !enable_unfocused_goal_printing); @@ -56,8 +55,7 @@ let _ = let _ = let open Goptions in declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "printing of goal tags"; optkey = ["Printing";"Goal";"Tags"]; optread = (fun () -> !enable_goal_tags_printing); @@ -67,8 +65,7 @@ let _ = let _ = let open Goptions in declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "printing of goal names"; optkey = ["Printing";"Goal";"Names"]; optread = (fun () -> !enable_goal_names_printing); @@ -237,10 +234,10 @@ let qualid_of_global env r = let safe_gen f env sigma c = let orig_extern_ref = Constrextern.get_extern_reference () in - let extern_ref loc vars r = - try orig_extern_ref loc vars r + let extern_ref ?loc vars r = + try orig_extern_ref ?loc vars r with e when CErrors.noncritical e -> - Libnames.Qualid (loc, qualid_of_global env r) + Libnames.Qualid (Loc.tag ?loc @@ qualid_of_global env r) in Constrextern.set_extern_reference extern_ref; try @@ -449,8 +446,7 @@ let print_hyps_limit = ref (None : int option) let _ = let open Goptions in declare_int_option - { optsync = false; - optdepr = false; + { optdepr = false; optname = "the hypotheses limit"; optkey = ["Hyps";"Limit"]; optread = (fun () -> !print_hyps_limit); @@ -570,7 +566,7 @@ let pr_selected_subgoal name sigma g = let default_pr_subgoal n sigma = let rec prrec p = function - | [] -> error "No such goal." + | [] -> user_err Pp.(str "No such goal.") | g::rest -> if Int.equal p 1 then pr_selected_subgoal (int n) sigma g @@ -635,8 +631,7 @@ let should_print_dependent_evars = ref false let _ = let open Goptions in declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "Printing Dependent Evars Line"; optkey = ["Printing";"Dependent";"Evars";"Line"]; optread = (fun () -> !should_print_dependent_evars); @@ -833,7 +828,7 @@ let pr_goal_by_id id = Proof.in_proof p (fun sigma -> let g = Evd.evar_key id sigma in pr_selected_subgoal (pr_id id) sigma g) - with Not_found -> error "No such goal." + with Not_found -> user_err Pp.(str "No such goal.") let pr_goal_by_uid uid = let p = Proof_global.give_me_the_proof () in @@ -844,7 +839,7 @@ let pr_goal_by_uid uid = in try Proof.in_proof p (fun sigma -> pr {it=g;sigma=sigma;}) - with Not_found -> error "Invalid goal identifier." + with Not_found -> user_err Pp.(str "Invalid goal identifier.") (* Elementary tactics *) diff --git a/printing/printmod.ml b/printing/printmod.ml index 6f4b162d70..c4affd4acd 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -42,8 +42,7 @@ let short = ref false let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "short module printing"; optkey = ["Short";"Module";"Printing"]; optread = (fun () -> !short) ; diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 605914a015..87b31849ee 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -163,7 +163,7 @@ let error_incompatible_inst clenv mv = let clenv_assign mv rhs clenv = let rhs_fls = mk_freelisted rhs in if Metaset.exists (mentions clenv mv) rhs_fls.freemetas then - error "clenv_assign: circularity in unification"; + user_err Pp.(str "clenv_assign: circularity in unification"); try if meta_defined clenv.evd mv then if not (EConstr.eq_constr clenv.evd (EConstr.of_constr (fst (meta_fvalue clenv.evd mv)).rebus) rhs) then @@ -174,7 +174,7 @@ let clenv_assign mv rhs clenv = let st = (Conv,TypeNotProcessed) in {clenv with evd = meta_assign mv (EConstr.Unsafe.to_constr rhs_fls.rebus,st) clenv.evd} with Not_found -> - error "clenv_assign: undefined meta" + user_err Pp.(str "clenv_assign: undefined meta") @@ -416,7 +416,7 @@ let qhyp_eq h1 h2 = match h1, h2 with | _ -> false let check_bindings bl = - match List.duplicates qhyp_eq (List.map pi2 bl) with + match List.duplicates qhyp_eq (List.map (fun x -> fst (snd x)) bl) with | NamedHyp s :: _ -> user_err (str "The variable " ++ pr_id s ++ @@ -433,7 +433,7 @@ let explain_no_such_bound_variable evd id = | Cltyp (na, _) -> na | Clval (na, _, _) -> na in - if na != Anonymous then out_name na :: l else l + if na != Anonymous then Name.get_id na :: l else l in let mvl = List.fold_left fold [] (Evd.meta_list evd) in user_err ~hdr:"Evd.meta_with_name" @@ -512,7 +512,7 @@ let clenv_match_args bl clenv = let mvs = clenv_independent clenv in check_bindings bl; List.fold_left - (fun clenv (loc,b,c) -> + (fun clenv (loc,(b,c)) -> let k = meta_of_binder clenv loc mvs b in if meta_defined clenv.evd k then if EConstr.eq_constr clenv.evd (EConstr.of_constr (fst (meta_fvalue clenv.evd k)).rebus) c then clenv @@ -676,7 +676,7 @@ let define_with_type sigma env ev c = let t = Retyping.get_type_of env sigma ev in let ty = Retyping.get_type_of env sigma c in let j = Environ.make_judge c ty in - let (sigma, j) = Coercion.inh_conv_coerce_to true (Loc.ghost) env sigma j t in + let (sigma, j) = Coercion.inh_conv_coerce_to true env sigma j t in let (ev, _) = destEvar sigma ev in let sigma = Evd.define ev (EConstr.Unsafe.to_constr j.Environ.uj_val) sigma in sigma @@ -711,7 +711,7 @@ let solve_evar_clause env sigma hyp_only clause = function error_not_right_number_missing_arguments len | ExplicitBindings lbind -> let () = check_bindings lbind in - let fold sigma (_, binder, c) = + let fold sigma (_, (binder, c)) = let ev = evar_of_binder clause.cl_holes binder in define_with_type sigma env ev c in diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 8367c09b8f..b1fe128a24 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -39,11 +39,11 @@ let define_and_solve_constraints evk c env evd = pbs with | Success evd -> evd - | UnifFailure _ -> error "Instance does not satisfy the constraints." + | UnifFailure _ -> user_err Pp.(str "Instance does not satisfy the constraints.") let w_refine (evk,evi) (ltac_var,rawc) sigma = if Evd.is_defined sigma evk then - error "Instantiate called on already-defined evar"; + user_err Pp.(str "Instantiate called on already-defined evar"); let env = Evd.evar_filtered_env evi in let sigma',typed_c = let flags = { @@ -56,7 +56,7 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = env sigma ltac_var (Pretyping.OfType (EConstr.of_constr evi.evar_concl)) rawc with e when CErrors.noncritical e -> let loc = Glob_ops.loc_of_glob_constr rawc in - user_err ~loc + user_err ?loc (str "Instance is not well-typed in the environment of " ++ Termops.pr_existential_key sigma evk ++ str ".") in diff --git a/proofs/goal.ml b/proofs/goal.ml index fc8e635a07..5a717f1662 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -68,7 +68,7 @@ module V82 = struct Evd.evar_concl = concl; Evd.evar_filter = Evd.Filter.identity; Evd.evar_body = Evd.Evar_empty; - Evd.evar_source = (Loc.ghost,Evar_kinds.GoalEvar); + Evd.evar_source = (Loc.tag Evar_kinds.GoalEvar); Evd.evar_candidates = None; Evd.evar_extra = extra } in diff --git a/proofs/logic.ml b/proofs/logic.ml index 54345abd97..cd2cfbd32f 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -141,7 +141,7 @@ let occur_vars_in_decl env sigma hyps d = let reorder_context env sigma sign ord = let ords = List.fold_right Id.Set.add ord Id.Set.empty in if not (Int.equal (List.length ord) (Id.Set.cardinal ords)) then - error "Order list has duplicates"; + user_err Pp.(str "Order list has duplicates"); let rec step ord expected ctxt_head moved_hyps ctxt_tail = match ord with | [] -> List.rev ctxt_tail @ ctxt_head diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 7e8ed31d1d..aaceb7b762 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -15,7 +15,7 @@ open Evd let use_unification_heuristics_ref = ref true let _ = Goptions.declare_bool_option { - Goptions.optsync = true; Goptions.optdepr = false; + Goptions.optdepr = false; Goptions.optname = "Solve unification constraints at every \".\""; Goptions.optkey = ["Solve";"Unification";"Constraints"]; Goptions.optread = (fun () -> !use_unification_heuristics_ref); @@ -71,7 +71,7 @@ let get_universe_binders () = exception NoSuchGoal let _ = CErrors.register_handler begin function - | NoSuchGoal -> CErrors.error "No such goal." + | NoSuchGoal -> CErrors.user_err Pp.(str "No such goal.") | _ -> raise CErrors.Unhandled end let get_nth_V82_goal i = @@ -87,12 +87,12 @@ let get_goal_context_gen i = let get_goal_context i = try get_goal_context_gen i - with Proof_global.NoCurrentProof -> CErrors.error "No focused proof." - | NoSuchGoal -> CErrors.error "No such goal." + with Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof.") + | NoSuchGoal -> CErrors.user_err Pp.(str "No such goal.") let get_current_goal_context () = try get_goal_context_gen 1 - with Proof_global.NoCurrentProof -> CErrors.error "No focused proof." + with Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof.") | NoSuchGoal -> (* spiwack: returning empty evar_map, since if there is no goal, under focus, there is no accessible evar either *) @@ -143,7 +143,7 @@ let solve ?with_end_tac gi info_lvl tac pr = in (p,status) with - Proof_global.NoCurrentProof -> CErrors.error "No focused proof" + Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof") let by tac = Proof_global.with_current_proof (fun _ -> solve (Vernacexpr.SelectNth 1) None tac) diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 7622a87768..1bf65b8aed 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -130,7 +130,7 @@ val set_end_tac : Genarg.glob_generic_argument -> unit (** [set_used_variables l] declares that section variables [l] will be used in the proof *) val set_used_variables : - Id.t list -> Context.Named.t * (Loc.t * Names.Id.t) list + Id.t list -> Context.Named.t * Names.Id.t Loc.located list val get_used_variables : unit -> Context.Named.t option (** {6 Universe binders } *) diff --git a/proofs/proof.ml b/proofs/proof.ml index b2103489a7..2aa620c1da 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -66,14 +66,14 @@ exception FullyUnfocused let _ = CErrors.register_handler begin function | CannotUnfocusThisWay -> - CErrors.error "This proof is focused, but cannot be unfocused this way" + CErrors.user_err Pp.(str "This proof is focused, but cannot be unfocused this way") | NoSuchGoals (i,j) when Int.equal i j -> CErrors.user_err ~hdr:"Focus" Pp.(str"No such goal (" ++ int i ++ str").") | NoSuchGoals (i,j) -> CErrors.user_err ~hdr:"Focus" Pp.( str"Not every goal in range ["++ int i ++ str","++int j++str"] exist." ) - | FullyUnfocused -> CErrors.error "The proof is not focused" + | FullyUnfocused -> CErrors.user_err Pp.(str "The proof is not focused") | _ -> raise CErrors.Unhandled end @@ -301,10 +301,10 @@ exception HasShelvedGoals exception HasGivenUpGoals exception HasUnresolvedEvar let _ = CErrors.register_handler begin function - | UnfinishedProof -> CErrors.error "Some goals have not been solved." - | HasShelvedGoals -> CErrors.error "Some goals have been left on the shelf." - | HasGivenUpGoals -> CErrors.error "Some goals have been given up." - | HasUnresolvedEvar -> CErrors.error "Some existential variables are uninstantiated." + | UnfinishedProof -> CErrors.user_err Pp.(str "Some goals have not been solved.") + | HasShelvedGoals -> CErrors.user_err Pp.(str "Some goals have been left on the shelf.") + | HasGivenUpGoals -> CErrors.user_err Pp.(str "Some goals have been given up.") + | HasUnresolvedEvar -> CErrors.user_err Pp.(str "Some existential variables are uninstantiated.") | _ -> raise CErrors.Unhandled end @@ -420,9 +420,9 @@ module V82 = struct let evl = Evarutil.non_instantiated sigma in let evl = Evar.Map.bindings evl in if (n <= 0) then - CErrors.error "incorrect existential variable index" + CErrors.user_err Pp.(str "incorrect existential variable index") else if CList.length evl < n then - CErrors.error "not so many uninstantiated existential variables" + CErrors.user_err Pp.(str "not so many uninstantiated existential variables") else CList.nth evl (n-1) in diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 99fab08486..4d2f534a76 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -36,7 +36,7 @@ let proof_modes = Hashtbl.create 6 let find_proof_mode n = try Hashtbl.find proof_modes n with Not_found -> - CErrors.error (Format.sprintf "No proof mode named \"%s\"." n) + CErrors.user_err Pp.(str (Format.sprintf "No proof mode named \"%s\"." n)) let register_proof_mode ({name = n} as m) = Hashtbl.add proof_modes n (CEphemeron.create m) @@ -52,8 +52,7 @@ let get_default_proof_mode_name () = (CEphemeron.default !default_proof_mode standard).name let _ = - Goptions.declare_string_option {Goptions. - optsync = true ; + Goptions.(declare_string_option { optdepr = false; optname = "default proof mode" ; optkey = ["Default";"Proof";"Mode"] ; @@ -63,7 +62,7 @@ let _ = optwrite = begin fun n -> default_proof_mode := find_proof_mode n end - } + }) (*** Proof Global Environment ***) @@ -82,7 +81,7 @@ type proof_object = { type proof_ending = | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * proof_universes | Proved of Vernacexpr.opacity_flag * - (Vernacexpr.lident * Decl_kinds.theorem_kind option) option * + Vernacexpr.lident option * proof_object type proof_terminator = proof_ending -> unit type closed_proof = proof_object * proof_terminator @@ -125,13 +124,13 @@ let push a l = l := a::!l; exception NoSuchProof let _ = CErrors.register_handler begin function - | NoSuchProof -> CErrors.error "No such proof." + | NoSuchProof -> CErrors.user_err Pp.(str "No such proof.") | _ -> raise CErrors.Unhandled end exception NoCurrentProof let _ = CErrors.register_handler begin function - | NoCurrentProof -> CErrors.error "No focused proof (No proof-editing in progress)." + | NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof (No proof-editing in progress).") | _ -> raise CErrors.Unhandled end @@ -207,7 +206,7 @@ let discard (loc,id) = let n = List.length !pstates in discard_gen id; if Int.equal (List.length !pstates) n then - CErrors.user_err ~loc + CErrors.user_err ?loc ~hdr:"Pfedit.delete_proof" (str"No such proof" ++ msg_proofs ()) let discard_current () = @@ -268,8 +267,7 @@ let get_universe_binders () = (cur_pstate ()).universe_binders let proof_using_auto_clear = ref false let _ = Goptions.declare_bool_option - { Goptions.optsync = true; - Goptions.optdepr = false; + { Goptions.optdepr = false; Goptions.optname = "Proof using Clear Unused"; Goptions.optkey = ["Proof";"Using";"Clear";"Unused"]; Goptions.optread = (fun () -> !proof_using_auto_clear); @@ -287,13 +285,13 @@ let set_used_variables l = match entry with | LocalAssum (x,_) -> if Id.Set.mem x all_safe then orig - else (ctx, all_safe, (Loc.ghost,x)::to_clear) + else (ctx, all_safe, (Loc.tag x)::to_clear) | LocalDef (x,bo, ty) as decl -> if Id.Set.mem x all_safe then orig else let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in if Id.Set.subset vars all_safe then (decl :: ctx, Id.Set.add x all_safe, to_clear) - else (ctx, all_safe, (Loc.ghost,x) :: to_clear) in + else (ctx, all_safe, (Loc.tag x) :: to_clear) in let ctx, _, to_clear = Environ.fold_named_context aux env ~init:(ctx,ctx_set,[]) in let to_clear = if !proof_using_auto_clear then to_clear else [] in @@ -301,7 +299,7 @@ let set_used_variables l = | [] -> raise NoCurrentProof | p :: rest -> if not (Option.is_empty p.section_vars) then - CErrors.error "Used section variables can be declared only once"; + CErrors.user_err Pp.(str "Used section variables can be declared only once"); pstates := { p with section_vars = Some ctx} :: rest; ctx, to_clear @@ -628,8 +626,7 @@ module Bullet = struct let current_behavior = ref Strict.strict let _ = - Goptions.declare_string_option {Goptions. - optsync = true; + Goptions.(declare_string_option { optdepr = false; optname = "bullet behavior"; optkey = ["Bullet";"Behavior"]; @@ -640,9 +637,9 @@ module Bullet = struct current_behavior := try Hashtbl.find behaviors n with Not_found -> - CErrors.error ("Unknown bullet behavior: \"" ^ n ^ "\".") + CErrors.user_err Pp.(str ("Unknown bullet behavior: \"" ^ n ^ "\".")) end - } + }) let put p b = (!current_behavior).put p b @@ -690,15 +687,13 @@ let parse_goal_selector = function let err_msg = "The default selector must be \"all\" or a natural number." in begin try let i = int_of_string i in - if i < 0 then CErrors.error err_msg; + if i < 0 then CErrors.user_err Pp.(str err_msg); Vernacexpr.SelectNth i - with Failure _ -> CErrors.error err_msg + with Failure _ -> CErrors.user_err Pp.(str err_msg) end let _ = - Goptions.declare_string_option {Goptions. - optsync = true ; - optdepr = false; + Goptions.(declare_string_option{optdepr = false; optname = "default goal selector" ; optkey = ["Default";"Goal";"Selector"] ; optread = begin fun () -> @@ -708,7 +703,7 @@ let _ = optwrite = begin fun n -> default_goal_selector := parse_goal_selector n end - } + }) module V82 = struct diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 6bb6f5e2cb..52bbd9ac56 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -70,7 +70,7 @@ type proof_ending = | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * proof_universes | Proved of Vernacexpr.opacity_flag * - (Vernacexpr.lident * Decl_kinds.theorem_kind option) option * + Vernacexpr.lident option * proof_object type proof_terminator type closed_proof = proof_object * proof_terminator @@ -140,7 +140,7 @@ val set_endline_tactic : Genarg.glob_generic_argument -> unit * (w.r.t. type dependencies and let-ins covered by it) + a list of * ids to be cleared *) val set_used_variables : - Names.Id.t list -> Context.Named.t * (Loc.t * Names.Id.t) list + Names.Id.t list -> Context.Named.t * Names.Id.t Loc.located list val get_used_variables : unit -> Context.Named.t option val get_universe_binders : unit -> universe_binders option diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml index 2c489d6ded..f701f7cfed 100644 --- a/proofs/proof_using.ml +++ b/proofs/proof_using.ml @@ -76,7 +76,7 @@ and full_set env = List.fold_right Id.Set.add (List.map NamedDecl.get_id (named_context env)) Id.Set.empty let process_expr env e ty = - let ty_expr = SsSingl(Loc.ghost, Id.of_string "Type") in + let ty_expr = SsSingl(Loc.tag @@ Id.of_string "Type") in let v_ty = process_expr env ty_expr ty in let s = Id.Set.union v_ty (process_expr env e ty) in Id.Set.elements s @@ -144,8 +144,7 @@ let value = ref false let _ = Goptions.declare_bool_option - { Goptions.optsync = true; - Goptions.optdepr = false; + { Goptions.optdepr = false; Goptions.optname = "suggest Proof using"; Goptions.optkey = ["Suggest";"Proof";"Using"]; Goptions.optread = (fun () -> !value); @@ -159,8 +158,7 @@ let value = ref None let _ = Goptions.declare_stringopt_option - { Goptions.optsync = true; - Goptions.optdepr = false; + { Goptions.optdepr = false; Goptions.optname = "default value for Proof using"; Goptions.optkey = ["Default";"Proof";"Using"]; Goptions.optread = (fun () -> !value); diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index cb35384227..7cd526843a 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -52,7 +52,7 @@ let strong_cbn flags = let simplIsCbn = ref (false) let _ = Goptions.declare_bool_option { - Goptions.optsync = true; Goptions.optdepr = false; + Goptions.optdepr = false; Goptions.optname = "Plug the simpl tactic to the new cbn mechanism"; Goptions.optkey = ["SimplIsCbn"]; diff --git a/proofs/refine.ml b/proofs/refine.ml index 1ee6e0ca5f..63ae41075c 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -70,8 +70,7 @@ let add_side_effect env = function let add_side_effects env effects = List.fold_left (fun env eff -> add_side_effect env eff) env effects -let make_refine_enter ?(unsafe = true) f = - { enter = fun gl -> +let generic_refine ?(unsafe = true) f gl = let gl = Proofview.Goal.assume gl in let sigma = Proofview.Goal.sigma gl in let sigma = Sigma.to_evar_map sigma in @@ -82,7 +81,10 @@ let make_refine_enter ?(unsafe = true) f = let prev_future_goals = Evd.future_goals sigma in let prev_principal_goal = Evd.principal_future_goal sigma in (** Create the refinement term *) - let ((v,c), sigma) = Sigma.run (Evd.reset_future_goals sigma) f in + Proofview.Unsafe.tclEVARS (Evd.reset_future_goals sigma) >>= fun () -> + f >>= fun (v, c) -> + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.V82.wrap_exceptions begin fun () -> let evs = Evd.future_goals sigma in let evkmain = Evd.principal_future_goal sigma in (** Redo the effects in sigma in the monad's env *) @@ -122,7 +124,18 @@ let make_refine_enter ?(unsafe = true) f = Proofview.Unsafe.tclEVARS sigma <*> Proofview.Unsafe.tclSETGOALS comb <*> Proofview.tclUNIT v - } + end + +let lift c = + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.V82.wrap_exceptions begin fun () -> + let Sigma (c, sigma, _) = c.run (Sigma.Unsafe.of_evar_map sigma) in + Proofview.Unsafe.tclEVARS (Sigma.to_evar_map sigma) >>= fun () -> + Proofview.tclUNIT c + end + +let make_refine_enter ?unsafe f = + { enter = fun gl -> generic_refine ?unsafe (lift f) gl } let refine_one ?(unsafe = true) f = Proofview.Goal.enter_one (make_refine_enter ~unsafe f) @@ -137,7 +150,7 @@ let with_type env evd c t = let my_type = Retyping.get_type_of env evd c in let j = Environ.make_judge c my_type in let (evd,j') = - Coercion.inh_conv_coerce_to true (Loc.ghost) env evd j t + Coercion.inh_conv_coerce_to true env evd j t in evd , j'.Environ.uj_val diff --git a/proofs/refine.mli b/proofs/refine.mli index 1a254d578c..5098f246a0 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -31,7 +31,11 @@ val refine : ?unsafe:bool -> EConstr.t Sigma.run -> unit tactic type-checked beforehand. *) val refine_one : ?unsafe:bool -> ('a * EConstr.t) Sigma.run -> 'a tactic -(** A generalization of [refine] which assumes exactly one goal under focus *) +(** A variant of [refine] which assumes exactly one goal under focus *) + +val generic_refine : ?unsafe:bool -> ('a * EConstr.t) tactic -> + ([ `NF ], 'r) Proofview.Goal.t -> 'a tactic +(** The general version of refine. *) (** {7 Helper functions} *) diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 97c5cda770..66d91c634a 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -75,7 +75,7 @@ let pf_get_new_ids ids gls = (fun id acc -> (next_ident_away id (acc@avoid))::acc) ids [] -let pf_global gls id = EConstr.of_constr (Constrintern.construct_reference (pf_hyps gls) id) +let pf_global gls id = EConstr.of_constr (Universes.constr_of_global (Constrintern.construct_reference (pf_hyps gls) id)) let pf_reduction_of_red_expr gls re c = let (redfun, _) = reduction_of_red_expr (pf_env gls) re in @@ -171,7 +171,7 @@ module New = struct (** We only check for the existence of an [id] in [hyps] *) let gl = Proofview.Goal.assume gl in let hyps = Proofview.Goal.hyps gl in - EConstr.of_constr (Constrintern.construct_reference hyps id) + Constrintern.construct_reference hyps id let pf_env = Proofview.Goal.env let pf_concl = Proofview.Goal.concl diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index e6e60e27f7..1172e55ac6 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -100,7 +100,7 @@ val pr_glls : goal list sigma -> Pp.std_ppcmds (* Variants of [Tacmach] functions built with the new proof engine *) module New : sig val pf_apply : (env -> evar_map -> 'a) -> ('b, 'r) Proofview.Goal.t -> 'a - val pf_global : identifier -> ('a, 'r) Proofview.Goal.t -> constr + val pf_global : identifier -> ('a, 'r) Proofview.Goal.t -> Globnames.global_reference (** FIXME: encapsulate the level in an existential type. *) val of_old : (Proof_type.goal Evd.sigma -> 'a) -> ([ `NF ], 'r) Proofview.Goal.t -> 'a diff --git a/stm/stm.ml b/stm/stm.ml index 84c8aa9a99..b98cb312ed 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -7,13 +7,14 @@ (************************************************************************) (* enable in case of stm problems *) -let stm_debug = false +(* let stm_debug () = !Flags.debug *) +let stm_debug () = !Flags.stm_debug -let stm_pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr -let stm_pp_err pp = Format.eprintf "%s] @[%a@]\n" (System.process_id ()) Pp.pp_with pp; flush stderr +let stm_pr_err s = Format.eprintf "%s] %s\n%!" (System.process_id ()) s +let stm_pp_err pp = Format.eprintf "%s] @[%a@]\n%!" (System.process_id ()) Pp.pp_with pp -let stm_prerr_endline s = if stm_debug then begin stm_pr_err (s ()) end else () -let stm_pperr_endline s = if stm_debug then begin stm_pp_err (s ()) end else () +let stm_prerr_endline s = if stm_debug () then begin stm_pr_err (s ()) end else () +let stm_pperr_endline s = if stm_debug () then begin stm_pp_err (s ()) end else () let stm_prerr_debug s = if !Flags.debug then begin stm_pr_err (s ()) end else () @@ -23,9 +24,9 @@ open Feedback open Vernacexpr open Vernac_classifier -let execution_error state_id loc msg = +let execution_error ?loc state_id msg = feedback ~id:state_id - (Message (Error, Some loc, msg)) + (Message (Error, loc, msg)) module Hooks = struct @@ -72,7 +73,7 @@ let async_proofs_workers_extra_env = ref [||] type aast = { verbose : bool; - loc : Loc.t; + loc : Loc.t option; indentation : int; strlen : int; mutable expr : vernac_expr; (* mutable: Proof using hinted by aux file *) @@ -126,8 +127,9 @@ type qed_t = { brname : Vcs_.Branch.t; brinfo : branch_type Vcs_.branch_info } -type seff_t = aast option +type seff_t = ReplayCommand of aast | CherryPickEnv type alias_t = Stateid.t * aast + type transaction = | Cmd of cmd_t | Fork of fork_t @@ -139,7 +141,7 @@ type step = [ `Cmd of cmd_t | `Fork of fork_t * Stateid.t option | `Qed of qed_t * Stateid.t - | `Sideff of [ `Ast of aast * Stateid.t | `Id of Stateid.t ] + | `Sideff of seff_t * Stateid.t | `Alias of alias_t ] type visit = { step : step; next : Stateid.t } @@ -238,11 +240,11 @@ end = struct (* {{{ *) | [p, Noop; n, Fork x] -> { step = `Fork (x,Some p); next = n } | [n, Qed x; p, Noop] | [p, Noop; n, Qed x] -> { step = `Qed (x,p); next = n } - | [n, Sideff None; p, Noop] - | [p, Noop; n, Sideff None]-> { step = `Sideff (`Id p); next = n } - | [n, Sideff (Some x); p, Noop] - | [p, Noop; n, Sideff (Some x)]-> { step = `Sideff(`Ast (x,p)); next = n } - | [n, Sideff (Some x)]-> {step = `Sideff(`Ast (x,Stateid.dummy)); next=n} + | [n, Sideff CherryPickEnv; p, Noop] + | [p, Noop; n, Sideff CherryPickEnv]-> { step = `Sideff (CherryPickEnv, p); next = n } + | [n, Sideff (ReplayCommand x); p, Noop] + | [p, Noop; n, Sideff (ReplayCommand x)]-> { step = `Sideff(ReplayCommand x,p); next = n } + | [n, Sideff (ReplayCommand x)]-> {step = `Sideff(ReplayCommand x, Stateid.dummy); next=n} | _ -> anomaly (Pp.str ("Malformed VCS at node "^Stateid.to_string id)) with Not_found -> raise Expired @@ -304,7 +306,7 @@ module VCS : sig val proof_nesting : unit -> int val checkout_shallowest_proof_branch : unit -> unit - val propagate_sideff : replay:aast option -> unit + val propagate_sideff : action:seff_t -> unit val gc : unit -> unit @@ -330,17 +332,17 @@ end = struct (* {{{ *) In case you are hitting the race enable stm_debug. *) - if stm_debug then Flags.we_are_parsing := false; + if stm_debug () then Flags.we_are_parsing := false; let fname = "stm_" ^ Str.global_replace (Str.regexp " ") "_" (System.process_id ()) in let string_of_transaction = function | Cmd { cast = t } | Fork (t, _,_,_) -> (try Pp.string_of_ppcmds (pr_ast t) with _ -> "ERR") - | Sideff (Some t) -> + | Sideff (ReplayCommand t) -> sprintf "Sideff(%s)" (try Pp.string_of_ppcmds (pr_ast t) with _ -> "ERR") - | Sideff None -> "EnvChange" + | Sideff CherryPickEnv -> "EnvChange" | Noop -> " " | Alias (id,_) -> sprintf "Alias(%s)" (Stateid.to_string id) | Qed { qast } -> Pp.string_of_ppcmds (pr_ast qast) in @@ -513,11 +515,11 @@ end = struct (* {{{ *) Proof_global.disactivate_current_proof_mode () (* copies the transaction on every open branch *) - let propagate_sideff ~replay:t = + let propagate_sideff ~action = List.iter (fun b -> checkout b; let id = new_node () in - merge id ~ours:(Sideff t) ~into:b Branch.master) + merge id ~ours:(Sideff action) ~into:b Branch.master) (List.filter (fun b -> not (Branch.equal b Branch.master)) (branches ())) let visit id = Vcs_aux.visit !vcs id @@ -528,8 +530,8 @@ end = struct (* {{{ *) match visit id with | { next = n; step = `Cmd x } -> (id,Cmd x) :: aux n | { next = n; step = `Alias x } -> (id,Alias x) :: aux n - | { next = n; step = `Sideff (`Ast (x,_)) } -> - (id,Sideff (Some x)) :: aux n + | { next = n; step = `Sideff (ReplayCommand x,_) } -> + (id,Sideff (ReplayCommand x)) :: aux n | _ -> anomaly Pp.(str("Cannot slice from "^ Stateid.to_string block_start ^ " to "^Stateid.to_string block_stop)) in aux block_stop @@ -801,9 +803,9 @@ end = struct (* {{{ *) match Stateid.get info with | Some _ -> (e, info) | None -> - let loc = Option.default Loc.ghost (Loc.get_loc info) in + let loc = Loc.get_loc info in let (e, info) = Hooks.(call_process_error_once (e, info)) in - execution_error id loc (iprint (e, info)); + execution_error ?loc id (iprint (e, info)); (e, Stateid.add info ~valid id) let same_env { system = s1 } { system = s2 } = @@ -912,9 +914,9 @@ let get_script prf = match view.step with | `Fork((_,_,_,ns), _) when test ns -> acc | `Qed (qed, proof) -> find [qed.qast.expr, (VCS.get_info id).n_goals] proof - | `Sideff (`Ast (x,_)) -> + | `Sideff (ReplayCommand x,_) -> find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next - | `Sideff (`Id id) -> find acc id + | `Sideff (CherryPickEnv, id) -> find acc id | `Cmd {cast = x; ctac} when ctac -> (* skip non-tactics *) find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next | `Cmd _ -> find acc view.next @@ -949,7 +951,7 @@ let stm_vernac_interp ?proof id ?route { verbose; loc; expr } = the whole document state, such as backtrack, etc... so we start to design the stm command interpreter now *) set_id_for_feedback ?route id; - Aux_file.record_in_aux_set_at loc; + Aux_file.record_in_aux_set_at ?loc (); (* We need to check if a command should be filtered from * vernac_entries, as it cannot handle it. This should go away in * future refactorings. @@ -968,7 +970,7 @@ let stm_vernac_interp ?proof id ?route { verbose; loc; expr } = | VernacShow ShowScript -> ShowScript.show_script () | expr -> stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); - try Vernacentries.interp ?verbosely:(Some verbose) ?proof (loc, expr) + try Vernacentries.interp ?verbosely:(Some verbose) ?proof (Loc.tag ?loc expr) with e -> let e = CErrors.push e in Exninfo.iraise Hooks.(call_process_error_once e) @@ -1105,11 +1107,11 @@ let hints = ref Aux_file.empty_aux_file let set_compilation_hints file = hints := Aux_file.load_aux_file_for file let get_hint_ctx loc = - let s = Aux_file.get !hints loc "context_used" in + let s = Aux_file.get ?loc !hints "context_used" in match Str.split (Str.regexp ";") s with | ids :: _ -> let ids = List.map Names.Id.of_string (Str.split (Str.regexp " ") ids) in - let ids = List.map (fun id -> Loc.ghost, id) ids in + let ids = List.map (fun id -> Loc.tag id) ids in begin match ids with | [] -> SsEmpty | x :: xs -> @@ -1118,15 +1120,15 @@ let get_hint_ctx loc = | _ -> raise Not_found let get_hint_bp_time proof_name = - try float_of_string (Aux_file.get !hints Loc.ghost proof_name) + try float_of_string (Aux_file.get !hints proof_name) with Not_found -> 1.0 -let record_pb_time proof_name loc time = +let record_pb_time ?loc proof_name time = let proof_build_time = Printf.sprintf "%.3f" time in - Aux_file.record_in_aux_at loc "proof_build_time" proof_build_time; + Aux_file.record_in_aux_at ?loc "proof_build_time" proof_build_time; if proof_name <> "" then begin - Aux_file.record_in_aux_at Loc.ghost proof_name proof_build_time; - hints := Aux_file.set !hints Loc.ghost proof_name proof_build_time + Aux_file.record_in_aux_at proof_name proof_build_time; + hints := Aux_file.set !hints proof_name proof_build_time end exception RemoteException of Pp.std_ppcmds @@ -1170,7 +1172,7 @@ let register_proof_block_delimiter name static dynamic = let mk_doc_node id = function | { step = `Cmd { ctac; cast = { indentation; expr }}; next } when ctac -> Some { indentation; ast = expr; id } - | { step = `Sideff (`Ast ({ indentation; expr }, _)); next } -> + | { step = `Sideff (ReplayCommand { indentation; expr }, _); next } -> Some { indentation; ast = expr; id } | _ -> None let prev_node { id } = @@ -1217,7 +1219,7 @@ module rec ProofTask : sig t_drop : bool; t_states : competence; t_assign : Proof_global.closed_proof_output Future.assignement -> unit; - t_loc : Loc.t; + t_loc : Loc.t option; t_uuid : Future.UUID.t; t_name : string } @@ -1235,8 +1237,9 @@ module rec ProofTask : sig and type request := request val build_proof_here : + ?loc:Loc.t -> drop_pt:bool -> - Stateid.t * Stateid.t -> Loc.t -> Stateid.t -> + Stateid.t * Stateid.t -> Stateid.t -> Proof_global.closed_proof_output Future.computation (* If set, only tasks overlapping with this list are processed *) @@ -1254,7 +1257,7 @@ end = struct (* {{{ *) t_drop : bool; t_states : competence; t_assign : Proof_global.closed_proof_output Future.assignement -> unit; - t_loc : Loc.t; + t_loc : Loc.t option; t_uuid : Future.UUID.t; t_name : string } @@ -1322,7 +1325,7 @@ end = struct (* {{{ *) RespBuiltProof (pl, time) -> feedback (InProgress ~-1); t_assign (`Val pl); - record_pb_time t_name t_loc time; + record_pb_time ?loc:t_loc t_name time; if !Flags.async_proofs_full || t_drop then `Stay(t_states,[States t_states]) else `End @@ -1343,16 +1346,16 @@ end = struct (* {{{ *) let info = Stateid.add ~valid:start Exninfo.null start in let e = (RemoteException (Pp.strbrk s), info) in t_assign (`Exn e); - execution_error start Loc.ghost (Pp.strbrk s); + execution_error start (Pp.strbrk s); feedback (InProgress ~-1) - let build_proof_here ~drop_pt (id,valid) loc eop = + let build_proof_here ?loc ~drop_pt (id,valid) eop = Future.create (State.exn_on id ~valid) (fun () -> let wall_clock1 = Unix.gettimeofday () in if !Flags.batch_mode then Reach.known_state ~cache:`No eop else Reach.known_state ~cache:`Shallow eop; let wall_clock2 = Unix.gettimeofday () in - Aux_file.record_in_aux_at loc "proof_build_time" + Aux_file.record_in_aux_at ?loc "proof_build_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); let p = Proof_global.return_proof ~allow_partial:drop_pt () in if drop_pt then feedback ~id Complete; @@ -1364,7 +1367,7 @@ end = struct (* {{{ *) VCS.print (); let proof, future_proof, time = let wall_clock = Unix.gettimeofday () in - let fp = build_proof_here ~drop_pt:drop exn_info loc stop in + let fp = build_proof_here ?loc ~drop_pt:drop exn_info stop in let proof = Future.force fp in proof, fp, Unix.gettimeofday () -. wall_clock in (* We typecheck the proof with the kernel (in the worker) to spot @@ -1446,7 +1449,7 @@ end = struct (* {{{ *) msg_error(Pp.strbrk("Marshalling error: "^s^". "^ "The system state could not be sent to the worker process. "^ "Falling back to local, lazy, evaluation.")); - t_assign(`Comp(build_proof_here ~drop_pt t_exn_info t_loc t_stop)); + t_assign(`Comp(build_proof_here ?loc:t_loc ~drop_pt t_exn_info t_stop)); feedback (InProgress ~-1) end (* }}} *) @@ -1456,7 +1459,7 @@ and Slaves : sig (* (eventually) remote calls *) val build_proof : - loc:Loc.t -> drop_pt:bool -> + ?loc:Loc.t -> drop_pt:bool -> exn_info:(Stateid.t * Stateid.t) -> block_start:Stateid.t -> block_stop:Stateid.t -> name:string -> future_proof * cancel_switch @@ -1535,8 +1538,8 @@ end = struct (* {{{ *) | { step = `Cmd { cast = { loc } } } | { step = `Fork (( { loc }, _, _, _), _) } | { step = `Qed ( { qast = { loc } }, _) } - | { step = `Sideff (`Ast ( { loc }, _)) } -> - let start, stop = Loc.unloc loc in + | { step = `Sideff (ReplayCommand { loc }, _) } -> + let start, stop = Option.cata Loc.unloc (0,0) loc in msg_error Pp.( str"File " ++ str name ++ str ": proof of " ++ str r_name ++ str ": chars " ++ int start ++ str "-" ++ int stop ++ @@ -1592,10 +1595,10 @@ end = struct (* {{{ *) let info_tasks l = CList.map_i (fun i ({ Stateid.loc; name }, _) -> let time1 = - try float_of_string (Aux_file.get !hints loc "proof_build_time") + try float_of_string (Aux_file.get ?loc !hints "proof_build_time") with Not_found -> 0.0 in let time2 = - try float_of_string (Aux_file.get !hints loc "proof_check_time") + try float_of_string (Aux_file.get ?loc !hints "proof_check_time") with Not_found -> 0.0 in name, max (time1 +. time2) 0.0001,i) 0 l @@ -1616,7 +1619,7 @@ end = struct (* {{{ *) BuildProof { t_states = s2 } -> overlap_rel s1 s2 | _ -> 0) - let build_proof ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name:pname = + let build_proof ?loc ~drop_pt ~exn_info ~block_start ~block_stop ~name:pname = let id, valid as t_exn_info = exn_info in let cancel_switch = ref false in if TaskQueue.n_workers (Option.get !queue) = 0 then @@ -1631,7 +1634,7 @@ end = struct (* {{{ *) TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch); f, cancel_switch end else - ProofTask.build_proof_here ~drop_pt t_exn_info loc block_stop, cancel_switch + ProofTask.build_proof_here ?loc ~drop_pt t_exn_info block_stop, cancel_switch else let f, t_assign = Future.create_delegate ~name:pname (State.exn_on id ~valid) in let t_uuid = Future.uuid f in @@ -2001,10 +2004,10 @@ let collect_proof keep cur hd brkind id = let rec collect last accn id = let view = VCS.visit id in match view.step with - | (`Sideff (`Ast(x,_)) | `Cmd { cast = x }) + | (`Sideff (ReplayCommand x,_) | `Cmd { cast = x }) when too_complex_to_delegate x -> `Sync(no_name,None,`Print) | `Cmd { cast = x } -> collect (Some (id,x)) (id::accn) view.next - | `Sideff (`Ast(x,_)) -> collect (Some (id,x)) (id::accn) view.next + | `Sideff (ReplayCommand x,_) -> collect (Some (id,x)) (id::accn) view.next (* An Alias could jump everywhere... we hope we can ignore it*) | `Alias _ -> `Sync (no_name,None,`Alias) | `Fork((_,_,_,_::_::_), _) -> @@ -2116,7 +2119,7 @@ let known_state ?(redefine_qed=false) ~cache id = feedback ~id:id Feedback.AddedAxiom; fst (Pfedit.solve Vernacexpr.SelectAll None tac p), ()); Option.iter (fun expr -> stm_vernac_interp id { - verbose = true; loc = Loc.ghost; expr; indentation = 0; + verbose = true; loc = None; expr; indentation = 0; strlen = 0 }) recovery_command | _ -> assert false @@ -2238,7 +2241,7 @@ let known_state ?(redefine_qed=false) ~cache id = ^"the proof's statement to avoid that.")); let fp, cancel = Slaves.build_proof - ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name in + ?loc ~drop_pt ~exn_info ~block_start ~block_stop ~name in Future.replace ofp fp; qed.fproof <- Some (fp, cancel); (* We don't generate a new state, but we still need @@ -2250,10 +2253,10 @@ let known_state ?(redefine_qed=false) ~cache id = let fp, cancel = if delegate then Slaves.build_proof - ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name + ?loc ~drop_pt ~exn_info ~block_start ~block_stop ~name else - ProofTask.build_proof_here - ~drop_pt exn_info loc block_stop, ref false + ProofTask.build_proof_here ?loc + ~drop_pt exn_info block_stop, ref false in qed.fproof <- Some (fp, cancel); let proof = @@ -2273,7 +2276,7 @@ let known_state ?(redefine_qed=false) ~cache id = log_processing_sync id name reason; reach eop; let wall_clock = Unix.gettimeofday () in - record_pb_time name x.loc (wall_clock -. !wall_clock_last_fork); + record_pb_time name ?loc:x.loc (wall_clock -. !wall_clock_last_fork); let proof = match keep with | VtDrop -> None @@ -2290,7 +2293,7 @@ let known_state ?(redefine_qed=false) ~cache id = let wall_clock2 = Unix.gettimeofday () in stm_vernac_interp id ?proof x; let wall_clock3 = Unix.gettimeofday () in - Aux_file.record_in_aux_at x.loc "proof_check_time" + Aux_file.record_in_aux_at ?loc:x.loc "proof_check_time" (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2)); Proof_global.discard_all () ), `Yes, true @@ -2303,10 +2306,10 @@ let known_state ?(redefine_qed=false) ~cache id = ), (if redefine_qed then `No else `Yes), true in aux (collect_proof keep (view.next, x) brname brinfo eop) - | `Sideff (`Ast (x,_)) -> (fun () -> + | `Sideff (ReplayCommand x,_) -> (fun () -> reach view.next; stm_vernac_interp id x; update_global_env () ), cache, true - | `Sideff (`Id origin) -> (fun () -> + | `Sideff (CherryPickEnv, origin) -> (fun () -> reach view.next; inject_non_pstate (pure_cherry_pick_non_pstate view.next origin); ), cache, true @@ -2427,7 +2430,7 @@ let merge_proof_branch ~valid ?id qast keep brname = let id = VCS.new_node ?id () in VCS.merge id ~ours:(Qed (qed None)) brname; VCS.delete_branch brname; - VCS.propagate_sideff ~replay:None; + VCS.propagate_sideff ~action:CherryPickEnv; `Ok | { VCS.kind = `Edit (mode, qed_id, master_id, _,_) } -> let ofp = @@ -2598,10 +2601,10 @@ let process_transaction ?(newtip=Stateid.fresh ()) VCS.commit id (mkTransCmd x l in_proof `MainQueue); (* We can't replay a Definition since universes may be differently * inferred. This holds in Coq >= 8.5 *) - let replay = match x.expr with - | VernacDefinition(_, _, DefineBody _) -> None - | _ -> Some x in - VCS.propagate_sideff ~replay; + let action = match x.expr with + | VernacDefinition(_, _, DefineBody _) -> CherryPickEnv + | _ -> ReplayCommand x in + VCS.propagate_sideff ~action; VCS.checkout_shallowest_proof_branch (); Backtrack.record (); if w == VtNow then finish (); `Ok @@ -2632,7 +2635,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) end else begin VCS.commit id (mkTransCmd x [] in_proof `MainQueue); (* We hope it can be replayed, but we can't really know *) - VCS.propagate_sideff ~replay:(Some x); + VCS.propagate_sideff ~action:(ReplayCommand x); VCS.checkout_shallowest_proof_branch (); end in State.define ~safe_id:head_id ~cache:`Yes step id; @@ -2641,7 +2644,11 @@ let process_transaction ?(newtip=Stateid.fresh ()) | VtUnknown, VtLater -> anomaly(str"classifier: VtUnknown must imply VtNow") end in - stm_prerr_endline (fun () -> "processed }}}"); + let pr_rc rc = match rc with + | `Ok -> Pp.(seq [str "newtip ("; str (Stateid.to_string (VCS.cur_tip ())); str ")"]) + | _ -> Pp.(str "unfocus") + in + stm_pperr_endline (fun () -> str "processed with " ++ pr_rc rc ++ str " }}}"); VCS.print (); rc with e -> @@ -2653,7 +2660,7 @@ let get_ast id = | { step = `Cmd { cast = { loc; expr } } } | { step = `Fork (({ loc; expr }, _, _, _), _) } | { step = `Qed ({ qast = { loc; expr } }, _) } -> - Some (expr, loc) + Some (Loc.tag ?loc expr) | _ -> None let stop_worker n = Slaves.cancel_worker n @@ -2681,7 +2688,7 @@ let parse_sentence sid pa = (str "Currently, the parsing api only supports parsing at the tip of the document." ++ fnl () ++ str "You wanted to parse at: " ++ str (Stateid.to_string sid) ++ str " but the current tip is: " ++ str (Stateid.to_string cur_tip)) ; - if not (Stateid.equal sid real_tip) && !Flags.debug && stm_debug then + if not (Stateid.equal sid real_tip) && !Flags.debug && stm_debug () then Feedback.msg_debug (str "Warning, the real tip doesn't match the current tip." ++ str "You wanted to parse at: " ++ str (Stateid.to_string sid) ++ @@ -2691,8 +2698,8 @@ let parse_sentence sid pa = Flags.with_option Flags.we_are_parsing (fun () -> try match Pcoq.Gram.entry_parse Pcoq.main_entry pa with - | None -> raise End_of_input - | Some com -> com + | None -> raise End_of_input + | Some (loc, cmd) -> Loc.tag ~loc cmd with e when CErrors.noncritical e -> let (e, info) = CErrors.push e in Exninfo.iraise (e, info)) @@ -2717,7 +2724,7 @@ let ind_len_loc_of_id sid = Note, this could maybe improved by handling more cases in compute_indentation. *) -let compute_indentation sid loc = +let compute_indentation ?loc sid = Option.cata (fun loc -> let open Loc in (* The effective lenght is the lenght on the last line *) let len = loc.ep - loc.bp in @@ -2731,16 +2738,16 @@ let compute_indentation sid loc = eff_indent + prev_indent, len else eff_indent, len - + ) (0, 0) loc let add ~ontop ?newtip verb (loc, ast) = let cur_tip = VCS.cur_tip () in if not (Stateid.equal ontop cur_tip) then - user_err ~hdr:"Stm.add" + user_err ?loc ~hdr:"Stm.add" (str "Stm.add called for a different state (" ++ str (Stateid.to_string ontop) ++ str ") than the tip: " ++ str (Stateid.to_string cur_tip) ++ str "." ++ fnl () ++ str "This is not supported yet, sorry."); - let indentation, strlen = compute_indentation ontop loc in + let indentation, strlen = compute_indentation ?loc ontop in CWarnings.set_current_loc loc; (* XXX: Classifiy vernac should be moved inside process transaction *) let clas = classify_vernac ast in @@ -2762,7 +2769,7 @@ let query ~at ?(report_with=(Stateid.dummy,default_route)) s = if Stateid.equal at Stateid.dummy then finish () else Reach.known_state ~cache:`Yes at; let loc, ast = parse_sentence at s in - let indentation, strlen = compute_indentation at loc in + let indentation, strlen = compute_indentation ?loc at in CWarnings.set_current_loc loc; let clas = classify_vernac ast in let aast = { verbose = true; indentation; strlen; loc; expr = ast } in @@ -2805,7 +2812,7 @@ let edit_at id = if Stateid.equal tip Stateid.initial then tip else match VCS.visit tip with | { step = (`Fork _ | `Qed _) } -> tip - | { step = `Sideff (`Ast(_,id)) } -> id + | { step = `Sideff (ReplayCommand _,id) } -> id | { step = `Sideff _ } -> tip | { next } -> master_for_br root next in let reopen_branch start at_id mode qed_id tip old_branch = diff --git a/stm/stm.mli b/stm/stm.mli index d2bee44964..b150f97489 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -84,7 +84,7 @@ val get_current_state : unit -> Stateid.t val init : unit -> unit (* This returns the node at that position *) -val get_ast : Stateid.t -> (Vernacexpr.vernac_expr * Loc.t) option +val get_ast : Stateid.t -> (Vernacexpr.vernac_expr Loc.located) option (* Filename *) val set_compilation_hints : string -> unit diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index a6237daa04..9f50ab589d 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -24,7 +24,7 @@ end module Pool = Map.Make(IntOT) let schedule_vio_checking j fs = - if j < 1 then CErrors.error "The number of workers must be bigger than 0"; + if j < 1 then CErrors.user_err Pp.(str "The number of workers must be bigger than 0"); let jobs = ref [] in List.iter (fun f -> let f = @@ -98,7 +98,7 @@ let schedule_vio_checking j fs = exit !rc let schedule_vio_compilation j fs = - if j < 1 then CErrors.error "The number of workers must be bigger than 0"; + if j < 1 then CErrors.user_err Pp.(str "The number of workers must be bigger than 0"); let jobs = ref [] in List.iter (fun f -> let f = @@ -107,7 +107,7 @@ let schedule_vio_compilation j fs = let long_f_dot_v = Loadpath.locate_file (f^".v") in let aux = Aux_file.load_aux_file_for long_f_dot_v in let eta = - try float_of_string (Aux_file.get aux Loc.ghost "vo_compile_time") + try float_of_string (Aux_file.get aux "vo_compile_time") with Not_found -> 0.0 in jobs := (f, eta) :: !jobs) fs; diff --git a/tactics/auto.ml b/tactics/auto.ml index c2d12ebd08..b76c0a96ae 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -174,8 +174,7 @@ let global_info_auto = ref false let add_option ls refe = let _ = Goptions.declare_bool_option - { Goptions.optsync = true; - Goptions.optdepr = false; + { Goptions.optdepr = false; Goptions.optname = String.concat " " ls; Goptions.optkey = ls; Goptions.optread = (fun () -> !refe); diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 2d54b61c72..de544fe5f9 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -84,7 +84,7 @@ let print_rewrite_hintdb bas = Pputils.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) -type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option +type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) Loc.located (* Applies all the rules of one base *) let one_base general_rewrite_maybe_in tac_main bas = @@ -257,12 +257,12 @@ let decompose_applied_relation metas env sigma c ctype left2right = | Some c -> Some c | None -> None -let find_applied_relation metas loc env sigma c left2right = +let find_applied_relation ?loc metas env sigma c left2right = let ctype = Typing.unsafe_type_of env sigma (EConstr.of_constr c) in match decompose_applied_relation metas env sigma c ctype left2right with | Some c -> c | None -> - user_err ~loc ~hdr:"decompose_applied_relation" + user_err ?loc ~hdr:"decompose_applied_relation" (str"The type" ++ spc () ++ Printer.pr_econstr_env env sigma ctype ++ spc () ++ str"of this term does not end with an applied relation.") @@ -271,13 +271,13 @@ let add_rew_rules base lrul = let counter = ref 0 in let env = Global.env () in let sigma = Evd.from_env env in - let ist = { Genintern.ltacvars = Id.Set.empty; genv = Global.env () } in + let ist = Genintern.empty_glob_sign (Global.env ()) in let intern tac = snd (Genintern.generic_intern ist tac) in let lrul = List.fold_left - (fun dn (loc,(c,ctx),b,t) -> + (fun dn (loc,((c,ctx),b,t)) -> let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in - let info = find_applied_relation false loc env sigma c b in + let info = find_applied_relation ?loc false env sigma c b in let pat = if b then info.hyp_left else info.hyp_right in let rul = { rew_lemma = c; rew_type = info.hyp_ty; rew_pat = pat; rew_ctx = ctx; rew_l2r = b; diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index 49e8588da3..f765318d04 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -12,7 +12,7 @@ open Term open Equality (** Rewriting rules before tactic interpretation *) -type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option +type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) Loc.located (** To add rewriting rules to a base *) val add_rew_rules : string -> raw_rew_rule list -> unit @@ -56,7 +56,7 @@ type hypinfo = { hyp_right : constr; } -val find_applied_relation : bool -> - Loc.t -> +val find_applied_relation : + ?loc:Loc.t -> bool -> Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 05eb0a9760..46d66b9d06 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -92,8 +92,7 @@ open Goptions let _ = declare_bool_option - { optsync = true; - optdepr = true; + { optdepr = true; optname = "do typeclass search modulo eta conversion"; optkey = ["Typeclasses";"Modulo";"Eta"]; optread = get_typeclasses_modulo_eta; @@ -101,8 +100,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "do typeclass search avoiding eta-expansions " ^ " in proof terms (expensive)"; optkey = ["Typeclasses";"Limit";"Intros"]; @@ -111,8 +109,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "during typeclass resolution, solve instances according to their dependency order"; optkey = ["Typeclasses";"Dependency";"Order"]; optread = get_typeclasses_dependency_order; @@ -120,8 +117,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "use iterative deepening strategy"; optkey = ["Typeclasses";"Iterative";"Deepening"]; optread = get_typeclasses_iterative_deepening; @@ -129,8 +125,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "compat"; optkey = ["Typeclasses";"Legacy";"Resolution"]; optread = get_typeclasses_legacy_resolution; @@ -138,8 +133,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "compat"; optkey = ["Typeclasses";"Filtered";"Unification"]; optread = get_typeclasses_filtered_unification; @@ -147,8 +141,7 @@ let _ = let set_typeclasses_debug = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "debug output for typeclasses proof search"; optkey = ["Typeclasses";"Debug"]; optread = get_typeclasses_debug; @@ -156,8 +149,7 @@ let set_typeclasses_debug = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "debug output for typeclasses proof search"; optkey = ["Debug";"Typeclasses"]; optread = get_typeclasses_debug; @@ -165,8 +157,7 @@ let _ = let _ = declare_int_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "verbosity of debug output for typeclasses proof search"; optkey = ["Typeclasses";"Debug";"Verbosity"]; optread = get_typeclasses_verbose; @@ -174,8 +165,7 @@ let _ = let set_typeclasses_depth = declare_int_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "depth for typeclasses proof search"; optkey = ["Typeclasses";"Depth"]; optread = get_typeclasses_depth; @@ -948,7 +938,7 @@ module V85 = struct | Some (evd', fk) -> if unique then (match get_result (fk NotApplicable) with - | Some (evd'', fk') -> error "Typeclass resolution gives multiple solutions" + | Some (evd'', fk') -> user_err Pp.(str "Typeclass resolution gives multiple solutions") | None -> evd') else evd' diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 63f923dfd3..5e7090ded1 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -19,10 +19,9 @@ module NamedDecl = Context.Named.Declaration (* Absurd *) -let mk_absurd_proof t = - let build_coq_not () = EConstr.of_constr (build_coq_not ()) in +let mk_absurd_proof coq_not t = let id = Namegen.default_dependent_ident in - mkLambda (Names.Name id,mkApp(build_coq_not (),[|t|]), + mkLambda (Names.Name id,mkApp(coq_not,[|t|]), mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|]))) let absurd c = @@ -31,12 +30,14 @@ let absurd c = let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let j = Retyping.get_judgment_of env sigma c in - let sigma, j = Coercion.inh_coerce_to_sort Loc.ghost env sigma j in + let sigma, j = Coercion.inh_coerce_to_sort env sigma j in let t = j.Environ.utj_val in let tac = + Tacticals.New.pf_constr_of_global (build_coq_not ()) >>= fun coqnot -> + Tacticals.New.pf_constr_of_global (build_coq_False ()) >>= fun coqfalse -> Tacticals.New.tclTHENLIST [ - elim_type (EConstr.of_constr (build_coq_False ())); - Simple.apply (mk_absurd_proof t) + elim_type coqfalse; + Simple.apply (mk_absurd_proof coqnot t) ] in Sigma.Unsafe.of_pair (tac, sigma) end } diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 8d1e0e507a..986f531397 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -62,7 +62,7 @@ let registered_e_assumption = let first_goal gls = let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in - if List.is_empty gl then error "first_goal"; + if List.is_empty gl then user_err Pp.(str "first_goal"); { Evd.it = List.hd gl; Evd.sigma = sig_0; } (* tactic -> tactic_list : Apply a tactic to the first goal in the list *) @@ -73,7 +73,7 @@ let apply_tac_list tac glls = | (g1::rest) -> let gl = apply_sig_tac sigr tac g1 in repackage sigr (gl@rest) - | _ -> error "apply_tac_list" + | _ -> user_err Pp.(str "apply_tac_list") let one_step l gl = [Proofview.V82.of_tactic Tactics.intro] @@ -82,7 +82,7 @@ let one_step l gl = @ (List.map (fun c -> Proofview.V82.of_tactic (assumption c)) (pf_ids_of_hyps gl)) let rec prolog l n gl = - if n <= 0 then error "prolog - failure"; + if n <= 0 then user_err Pp.(str "prolog - failure"); let prol = (prolog l (n-1)) in (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl @@ -331,8 +331,7 @@ let global_info_eauto = ref false let _ = Goptions.declare_bool_option - { Goptions.optsync = true; - Goptions.optdepr = false; + { Goptions.optdepr = false; Goptions.optname = "Debug Eauto"; Goptions.optkey = ["Debug";"Eauto"]; Goptions.optread = (fun () -> !global_debug_eauto); @@ -340,8 +339,7 @@ let _ = let _ = Goptions.declare_bool_option - { Goptions.optsync = true; - Goptions.optdepr = false; + { Goptions.optdepr = false; Goptions.optname = "Info Eauto"; Goptions.optkey = ["Info";"Eauto"]; Goptions.optread = (fun () -> !global_info_eauto); @@ -404,7 +402,7 @@ let e_search_auto debug (in_depth,p) lems db_list gl = s.tacres with Not_found -> pr_info_nop d; - error "eauto: search failed" + user_err Pp.(str "eauto: search failed") (* let e_search_auto_key = Profile.declare_profile "e_search_auto" *) (* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *) diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 641929a77b..48ce52f092 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -104,14 +104,9 @@ let solveNoteqBranch side = (* Constructs the type {c1=c2}+{~c1=c2} *) -let make_eq () = -(*FIXME*) EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ())) -let build_coq_not () = EConstr.of_constr (build_coq_not ()) -let build_coq_sumbool () = EConstr.of_constr (build_coq_sumbool ()) - -let mkDecideEqGoal eqonleft op rectype c1 c2 = - let equality = mkApp(make_eq(), [|rectype; c1; c2|]) in - let disequality = mkApp(build_coq_not (), [|equality|]) in +let mkDecideEqGoal eqonleft (op,eq,neg) rectype c1 c2 = + let equality = mkApp(eq, [|rectype; c1; c2|]) in + let disequality = mkApp(neg, [|equality|]) in if eqonleft then mkApp(op, [|equality; disequality |]) else mkApp(op, [|disequality; equality |]) @@ -121,13 +116,13 @@ let mkDecideEqGoal eqonleft op rectype c1 c2 = let idx = Id.of_string "x" let idy = Id.of_string "y" -let mkGenDecideEqGoal rectype g = +let mkGenDecideEqGoal rectype ops g = let hypnames = pf_ids_of_hyps g in let xname = next_ident_away idx hypnames and yname = next_ident_away idy hypnames in (mkNamedProd xname rectype (mkNamedProd yname rectype - (mkDecideEqGoal true (build_coq_sumbool ()) + (mkDecideEqGoal true ops rectype (mkVar xname) (mkVar yname)))) let rec rewrite_and_clear hyps = match hyps with @@ -256,9 +251,9 @@ let decideGralEquality = let decideEqualityGoal = tclTHEN intros decideGralEquality -let decideEquality rectype = +let decideEquality rectype ops = Proofview.Goal.enter { enter = begin fun gl -> - let decide = mkGenDecideEqGoal rectype gl in + let decide = mkGenDecideEqGoal rectype ops gl in (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) end } @@ -266,11 +261,15 @@ let decideEquality rectype = (* The tactic Compare *) let compare c1 c2 = + pf_constr_of_global (build_coq_sumbool ()) >>= fun opc -> + pf_constr_of_global (Coqlib.build_coq_eq ()) >>= fun eqc -> + pf_constr_of_global (build_coq_not ()) >>= fun notc -> Proofview.Goal.enter { enter = begin fun gl -> let rectype = pf_unsafe_type_of gl c1 in - let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in + let ops = (opc,eqc,notc) in + let decide = mkDecideEqGoal true ops rectype c1 c2 in (tclTHENS (cut decide) [(tclTHEN intro (tclTHEN (onLastHyp simplest_case) clear_last)); - decideEquality rectype]) + decideEquality rectype ops]) end } diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index d023b45682..bcd31cb7e7 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -103,7 +103,7 @@ let get_coq_eq ctx = (Universes.fresh_inductive_instance (Global.env ()) eq) in mkIndU eq, mkConstructUi (eq,1), ctx with Not_found -> - error "eq not found." + user_err Pp.(str "eq not found.") let univ_of_eq env eq = let eq = EConstr.of_constr eq in @@ -120,6 +120,8 @@ let univ_of_eq env eq = (* in which case, a symmetry lemma is definable *) (**********************************************************************) +let error msg = user_err Pp.(str msg) + let get_sym_eq_data env (ind,u) = let (mib,mip as specif) = lookup_mind_specif env ind in if not (Int.equal (Array.length mib.mind_packets) 1) || diff --git a/tactics/equality.ml b/tactics/equality.ml index 18a1f02011..268daf6b62 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -57,8 +57,7 @@ let discr_do_intro () = open Goptions let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "automatic introduction of hypotheses by discriminate"; optkey = ["Discriminate";"Introduction"]; optread = (fun () -> !discriminate_introduction); @@ -72,8 +71,7 @@ let use_injection_pattern_l2r_order () = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "injection left-to-right pattern order and clear by default when with introduction pattern"; optkey = ["Injection";"L2R";"Pattern";"Order"]; optread = (fun () -> !injection_pattern_l2r_order) ; @@ -87,8 +85,7 @@ let use_injection_in_context () = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "injection in context"; optkey = ["Structural";"Injection"]; optread = (fun () -> !injection_in_context) ; @@ -167,7 +164,7 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl = let eqclause = pf_apply Clenv.make_clenv_binding gl (c,ty) l in let (equiv, args) = decompose_app_vect sigma (Clenv.clenv_type eqclause) in let arglen = Array.length args in - let () = if arglen < 2 then error "The term provided is not an applied relation." in + let () = if arglen < 2 then user_err Pp.(str "The term provided is not an applied relation.") in let c1 = args.(arglen - 2) in let c2 = args.(arglen - 1) in let try_occ (evd', c') = @@ -444,7 +441,7 @@ let adjust_rewriting_direction args lft2rgt = (* equality to a constant, like in eq_true *) (* more natural to see -> as the rewriting to the constant *) if not lft2rgt then - error "Rewriting non-symmetric equality not allowed from right-to-left."; + user_err Pp.(str "Rewriting non-symmetric equality not allowed from right-to-left."); None | _ -> (* other equality *) @@ -729,8 +726,7 @@ let keep_proof_equalities_for_injection = ref false let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "injection on prop arguments"; optkey = ["Keep";"Proof";"Equalities"]; optread = (fun () -> !keep_proof_equalities_for_injection) ; @@ -869,7 +865,7 @@ let descend_then env sigma head dirn = let IndType (indf,_) = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> - error "Cannot project on an inductive type derived from a dependency." in + user_err Pp.(str "Cannot project on an inductive type derived from a dependency.") in let indp,_ = (dest_ind_family indf) in let ind, _ = check_privacy env indp in let (mib,mip) = lookup_mind_specif env ind in @@ -878,7 +874,7 @@ let descend_then env sigma head dirn = let dirn_env = Environ.push_rel_context cstr.(dirn-1).cs_args env in (dirn_nlams, dirn_env, - (fun dirnval (dfltval,resty) -> + (fun sigma dirnval (dfltval,resty) -> let deparsign = make_arity_signature env sigma true indf in let p = it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in @@ -891,7 +887,7 @@ let descend_then env sigma head dirn = List.map build_branch (List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in - Inductiveops.make_case_or_project env sigma indf ci p head (Array.of_list brl))) + sigma, Inductiveops.make_case_or_project env sigma indf ci p head (Array.of_list brl))) (* Now we need to construct the discriminator, given a discriminable position. This boils down to: @@ -936,23 +932,28 @@ let build_selector env sigma dirn c ind special default = let brl = List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in - mkCase (ci, p, c, Array.of_list brl) + sigma, mkCase (ci, p, c, Array.of_list brl) -let build_coq_False () = EConstr.of_constr (build_coq_False ()) -let build_coq_True () = EConstr.of_constr (build_coq_True ()) -let build_coq_I () = EConstr.of_constr (build_coq_I ()) +let new_global sigma gr = + let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map sigma) gr + in Sigma.to_evar_map sigma, c + +let build_coq_False sigma = new_global sigma (build_coq_False ()) +let build_coq_True sigma = new_global sigma (build_coq_True ()) +let build_coq_I sigma = new_global sigma (build_coq_I ()) let rec build_discriminator env sigma dirn c = function | [] -> let ind = get_type_of env sigma c in - let true_0,false_0 = - build_coq_True(),build_coq_False() in + let sigma, true_0 = build_coq_True sigma in + let sigma, false_0 = build_coq_False sigma in build_selector env sigma dirn c ind true_0 false_0 | ((sp,cnum),argnum)::l -> + let sigma, false_0 = build_coq_False sigma in let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in - let subval = build_discriminator cnum_env sigma dirn newc l in - kont subval (build_coq_False (),mkSort (Prop Null)) + let sigma, subval = build_discriminator cnum_env sigma dirn newc l in + kont sigma subval (false_0,mkSort (Prop Null)) (* Note: discrimination could be more clever: if some elimination is not allowed because of a large impredicative constructor in the @@ -995,9 +996,9 @@ let ind_scheme_of_eq lbeq = let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq = - let i = build_coq_I () in - let absurd_term = build_coq_False () in - let eq_elim, eff = ind_scheme_of_eq lbeq in + let sigma, i = build_coq_I sigma in + let sigma, absurd_term = build_coq_False sigma in + let eq_elim, eff = ind_scheme_of_eq lbeq in let sigma, eq_elim = Evd.fresh_global (Global.env ()) sigma eq_elim in let eq_elim = EConstr.of_constr eq_elim in sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), @@ -1017,7 +1018,7 @@ let apply_on_clause (f,t) clause = let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in - let discriminator = + let sigma, discriminator = build_discriminator e_env sigma dirn (mkVar e) cpath in let sigma,(pf, absurd_term), eff = discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in @@ -1206,7 +1207,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = evdref := Evarconv.solve_unif_constraints_with_heuristics env !evdref in dflt with Evarconv.UnableToUnify _ -> - error "Cannot solve a unification problem." + user_err Pp.(str "Cannot solve a unification problem.") else let (a,p_i_minus_1) = match whd_beta_stack !evdref p_i with | (_sigS,[a;p]) -> (a, p) @@ -1223,7 +1224,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let exist_term = EConstr.of_constr exist_term in applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) else - error "Cannot solve a unification problem." + user_err Pp.(str "Cannot solve a unification problem.") | None -> (* This at least happens if what has been detected as a dependency is not one; use an evasive error message; @@ -1231,7 +1232,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = tried in the first place in make_iterated_tuple instead of approximatively computing the free rels; then unsolved evars would mean not binding rel *) - error "Cannot solve a unification problem." + user_err Pp.(str "Cannot solve a unification problem.") in let scf = sigrec_clausal_form siglen ty in !evdref, Evarutil.nf_evar !evdref scf @@ -1313,7 +1314,8 @@ let rec build_injrec env sigma dflt c = function let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in let sigma, (subval,tuplety,dfltval) = build_injrec cnum_env sigma dflt newc l in - sigma, (kont subval (dfltval,tuplety), tuplety,dfltval) + let sigma, res = kont sigma subval (dfltval,tuplety) in + sigma, (res, tuplety,dfltval) with UserError _ -> failwith "caught" @@ -1330,8 +1332,6 @@ let inject_if_homogenous_dependent_pair ty = let sigma = Tacmach.New.project gl in let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in (* fetch the informations of the pair *) - let ceq = Universes.constr_of_global Coqlib.glob_eq in - let ceq = EConstr.of_constr ceq in let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in let existTconstr () = (Coqlib.build_sigma_type()).Coqlib.intro in (* check whether the equality deals with dep pairs or not *) @@ -1350,17 +1350,18 @@ let inject_if_homogenous_dependent_pair ty = pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit; Coqlib.check_required_library ["Coq";"Logic";"Eqdep_dec"]; let new_eq_args = [|pf_unsafe_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in - let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" - ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in - let inj2 = EConstr.of_constr inj2 in + let inj2 = Coqlib.coq_reference "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] + "inj_pair2_eq_dec" in let c, eff = find_scheme (!eq_dec_scheme_kind_name()) ind in (* cut with the good equality and prove the requested goal *) tclTHENLIST [Proofview.tclEFFECTS eff; intro; onLastHyp (fun hyp -> + Tacticals.New.pf_constr_of_global Coqlib.glob_eq >>= fun ceq -> tclTHENS (cut (mkApp (ceq,new_eq_args))) [clear [destVar sigma hyp]; + Tacticals.New.pf_constr_of_global inj2 >>= fun inj2 -> Proofview.V82.tactic (Tacmach.refine (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|]))) ])] @@ -1478,7 +1479,7 @@ let simpleInjClause with_evars = function | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (injEq ~old:true with_evars clear_flag None)) c let injConcl = injClause None false None -let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.ghost,id))) +let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.tag id))) let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = Proofview.Goal.enter { enter = begin fun gl -> @@ -1680,8 +1681,7 @@ let regular_subst_tactic = ref true let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "more regular behavior of tactic subst"; optkey = ["Regular";"Subst";"Tactic"]; optread = (fun () -> !regular_subst_tactic); @@ -1892,7 +1892,7 @@ let cond_eq_term c t gl = let rewrite_assumption_cond cond_eq_term cl = let rec arec hyps gl = match hyps with - | [] -> error "No such assumption." + | [] -> user_err Pp.(str "No such assumption.") | hyp ::rest -> let id = NamedDecl.get_id hyp in begin diff --git a/tactics/equality.mli b/tactics/equality.mli index b47be3bbc0..27be5affb1 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -126,4 +126,4 @@ val set_eq_dec_scheme_kind : mutual scheme_kind -> unit (* [build_selector env sigma i c t u v] matches on [c] of type [t] and returns [u] in branch [i] and [v] on other branches *) val build_selector : env -> evar_map -> int -> constr -> types -> - constr -> constr -> constr + constr -> constr -> evar_map * constr diff --git a/tactics/hints.ml b/tactics/hints.ml index c5bacc5a20..48a7b3f75c 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -59,7 +59,7 @@ let head_constr_bound sigma t = | _ -> raise Bound let head_constr sigma c = - try head_constr_bound sigma c with Bound -> error "Bound head variable." + try head_constr_bound sigma c with Bound -> user_err Pp.(str "Bound head variable.") let decompose_app_bound sigma t = let t = strip_outer_cast sigma t in @@ -167,12 +167,11 @@ let write_warn_hint = function | "Lax" -> warn_hint := `LAX | "Warn" -> warn_hint := `WARN | "Strict" -> warn_hint := `STRICT -| _ -> error "Only the following flags are accepted: Lax, Warn, Strict." +| _ -> user_err Pp.(str "Only the following flags are accepted: Lax, Warn, Strict.") let _ = Goptions.declare_string_option - { Goptions.optsync = true; - Goptions.optdepr = false; + { Goptions.optdepr = false; Goptions.optname = "behavior of non-imported hints"; Goptions.optkey = ["Loose"; "Hint"; "Behavior"]; Goptions.optread = read_warn_hint; @@ -768,7 +767,7 @@ let rec nb_hyp sigma c = match EConstr.kind sigma c with let try_head_pattern c = try head_pattern_bound c - with BoundPattern -> error "Bound head variable." + with BoundPattern -> user_err Pp.(str "Bound head variable.") let with_uid c = { obj = c; uid = fresh_key () } @@ -981,8 +980,8 @@ let get_db dbname = let add_hint dbname hintlist = let check (_, h) = let () = if KNmap.mem h.code.uid !statustable then - error "Conflicting hint keys. This can happen when including \ - twice the same module." + user_err Pp.(str "Conflicting hint keys. This can happen when including \ + twice the same module.") in statustable := KNmap.add h.code.uid false !statustable in @@ -1247,10 +1246,10 @@ let prepare_hint check (poly,local) env init (sigma,c) = let t = Evarutil.nf_evar sigma (existential_type sigma ev) in let t = List.fold_right (fun (e,id) c -> replace_term sigma e id c) !subst t in if not (closed0 sigma c) then - error "Hints with holes dependent on a bound variable not supported."; + user_err Pp.(str "Hints with holes dependent on a bound variable not supported."); if occur_existential sigma t then (* Not clever enough to construct dependency graph of evars *) - error "Not clever enough to deal with evars dependent in other evars."; + user_err Pp.(str "Not clever enough to deal with evars dependent in other evars."); raise (Found (c,t)) | _ -> EConstr.iter sigma find_next_evar c in let rec iter c = @@ -1277,7 +1276,7 @@ let interp_hints poly = prepare_hint true (poly,false) (Global.env()) Evd.empty (evd,c) in let fref r = let gr = global_with_alias r in - Dumpglob.add_glob (loc_of_reference r) gr; + Dumpglob.add_glob ?loc:(loc_of_reference r) gr; gr in let fr r = evaluable_of_global_reference (Global.env()) (fref r) @@ -1306,7 +1305,7 @@ let interp_hints poly = let constr_hints_of_ind qid = let ind = global_inductive_with_alias qid in let mib,_ = Global.lookup_inductive ind in - Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind"; + Dumpglob.dump_reference ?loc:(fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind"; List.init (nconstructors ind) (fun i -> let c = (ind,i+1) in let gr = ConstructRef c in @@ -1317,13 +1316,13 @@ let interp_hints poly = let pat = Option.map fp patcom in let l = match pat with None -> [] | Some (l, _) -> l in let ltacvars = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in - let env = Genintern.({ genv = env; ltacvars }) in + let env = Genintern.({ (empty_glob_sign env) with ltacvars }) in let _, tacexp = Genintern.generic_intern env tacexp in HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp) let add_hints local dbnames0 h = if String.List.mem "nocore" dbnames0 then - error "The hint database \"nocore\" is meant to stay empty."; + user_err Pp.(str "The hint database \"nocore\" is meant to stay empty."); let dbnames = if List.is_empty dbnames0 then ["core"] else dbnames0 in let env = Global.env() in let sigma = Evd.from_env env in @@ -1472,7 +1471,7 @@ let pr_applicable_hint () = let pts = get_pftreestate () in let glss = Proof.V82.subgoals pts in match glss.Evd.it with - | [] -> CErrors.error "No focused goal." + | [] -> CErrors.user_err Pp.(str "No focused goal.") | g::_ -> pr_hint_term glss.Evd.sigma (Goal.V82.concl glss.Evd.sigma g) diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 15b40b42d1..2ba18ceb42 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -252,16 +252,16 @@ open Decl_kinds open Evar_kinds let mkPattern c = snd (Patternops.pattern_of_glob_constr c) -let mkGApp f args = GApp (Loc.ghost, f, args) -let mkGHole = - GHole (Loc.ghost, QuestionMark (Define false), Misctypes.IntroAnonymous, None) -let mkGProd id c1 c2 = - GProd (Loc.ghost, Name (Id.of_string id), Explicit, c1, c2) -let mkGArrow c1 c2 = - GProd (Loc.ghost, Anonymous, Explicit, c1, c2) -let mkGVar id = GVar (Loc.ghost, Id.of_string id) -let mkGPatVar id = GPatVar(Loc.ghost, (false, Id.of_string id)) -let mkGRef r = GRef (Loc.ghost, Lazy.force r, None) +let mkGApp f args = CAst.make @@ GApp (f, args) +let mkGHole = CAst.make @@ + GHole (QuestionMark (Define false,Anonymous), Misctypes.IntroAnonymous, None) +let mkGProd id c1 c2 = CAst.make @@ + GProd (Name (Id.of_string id), Explicit, c1, c2) +let mkGArrow c1 c2 = CAst.make @@ + GProd (Anonymous, Explicit, c1, c2) +let mkGVar id = CAst.make @@ GVar (Id.of_string id) +let mkGPatVar id = CAst.make @@ GPatVar((false, Id.of_string id)) +let mkGRef r = CAst.make @@ GRef (Lazy.force r, None) let mkGAppRef r args = mkGApp (mkGRef r) args (** forall x : _, _ x x *) @@ -460,7 +460,7 @@ let find_this_eq_data_decompose gl eqn = let eq_args = try extract_eq_args gl eq_args with PatternMatchingFailure -> - error "Don't know what to do with JMeq on arguments not of same type." in + user_err Pp.(str "Don't know what to do with JMeq on arguments not of same type.") in (lbeq,u,eq_args) let match_eq_nf gls eqn (ref, hetero) = @@ -477,7 +477,7 @@ let dest_nf_eq gls eqn = try snd (first_match (match_eq_nf gls eqn) equalities) with PatternMatchingFailure -> - error "Not an equality." + user_err Pp.(str "Not an equality.") (*** Sigma-types *) @@ -544,7 +544,7 @@ let match_eqdec sigma t = false,op_or,matches sigma (Lazy.force coq_eqdec_rev_pattern) t in match Id.Map.bindings subst with | [(_,typ);(_,c1);(_,c2)] -> - eqonleft, EConstr.of_constr (Universes.constr_of_global (Lazy.force op)), c1, c2, typ + eqonleft, Lazy.force op, c1, c2, typ | _ -> anomaly (Pp.str "Unexpected pattern") (* Patterns "~ ?" and "? -> False" *) diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 82a3d47b59..9110830aae 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -142,7 +142,7 @@ val is_matching_sigma : evar_map -> constr -> bool (** Match a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns [t,u,T] and a boolean telling if equality is on the left side *) -val match_eqdec : evar_map -> constr -> bool * constr * constr * constr * constr +val match_eqdec : evar_map -> constr -> bool * Globnames.global_reference * constr * constr * constr (** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) val dest_nf_eq : ('a, 'r) Proofview.Goal.t -> constr -> (constr * constr * constr) diff --git a/tactics/inv.ml b/tactics/inv.ml index 266cac5c7d..b951e7ceba 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -282,9 +282,9 @@ let generalizeRewriteIntros as_mode tac depids id = end } let error_too_many_names pats = - let loc = Loc.join_loc (fst (List.hd pats)) (fst (List.last pats)) in + let loc = Loc.merge_opt (fst (List.hd pats)) (fst (List.last pats)) in Proofview.tclENV >>= fun env -> - tclZEROMSG ~loc ( + tclZEROMSG ?loc ( str "Unexpected " ++ str (String.plural (List.length pats) "introduction pattern") ++ str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (EConstr.Unsafe.to_constr (fst (run_delayed env Evd.empty c))))) pats ++ @@ -292,27 +292,27 @@ let error_too_many_names pats = let get_names (allow_conj,issimple) (loc, pat as x) = match pat with | IntroNaming IntroAnonymous | IntroForthcoming _ -> - error "Anonymous pattern not allowed for inversion equations." + user_err Pp.(str "Anonymous pattern not allowed for inversion equations.") | IntroNaming (IntroFresh _) -> - error "Fresh pattern not allowed for inversion equations." + user_err Pp.(str "Fresh pattern not allowed for inversion equations.") | IntroAction IntroWildcard -> - error "Discarding pattern not allowed for inversion equations." + user_err Pp.(str "Discarding pattern not allowed for inversion equations.") | IntroAction (IntroRewrite _) -> - error "Rewriting pattern not allowed for inversion equations." + user_err Pp.(str "Rewriting pattern not allowed for inversion equations.") | IntroAction (IntroOrAndPattern (IntroAndPattern [])) when allow_conj -> (None, []) | IntroAction (IntroOrAndPattern (IntroAndPattern ((_,IntroNaming (IntroIdentifier id)) :: _ as l) | IntroOrPattern [(_,IntroNaming (IntroIdentifier id)) :: _ as l ])) when allow_conj -> (Some id,l) | IntroAction (IntroOrAndPattern (IntroAndPattern _)) -> if issimple then - error"Conjunctive patterns not allowed for simple inversion equations." + user_err Pp.(str"Conjunctive patterns not allowed for simple inversion equations.") else - error"Nested conjunctive patterns not allowed for inversion equations." + user_err Pp.(str"Nested conjunctive patterns not allowed for inversion equations.") | IntroAction (IntroInjection l) -> - error "Injection patterns not allowed for inversion equations." + user_err Pp.(str "Injection patterns not allowed for inversion equations.") | IntroAction (IntroOrAndPattern (IntroOrPattern _)) -> - error "Disjunctive patterns not allowed for inversion equations." + user_err Pp.(str "Disjunctive patterns not allowed for inversion equations.") | IntroAction (IntroApplyOn (c,pat)) -> - error "Apply patterns not allowed for inversion equations." + user_err Pp.(str "Apply patterns not allowed for inversion equations.") | IntroNaming (IntroIdentifier id) -> (Some id,[x]) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index c8441a8cc9..c495b5ece2 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -69,7 +69,7 @@ let tclTHENSEQ = tclTHENLIST let nthDecl m gl = try List.nth (pf_hyps gl) (m-1) - with Failure _ -> error "No such assumption." + with Failure _ -> user_err Pp.(str "No such assumption.") let nthHypId m gl = nthDecl m gl |> NamedDecl.get_id let nthHyp m gl = mkVar (nthHypId m gl) @@ -80,7 +80,7 @@ let lastHyp gl = nthHyp 1 gl let nLastDecls n gl = try List.firstn n (pf_hyps gl) - with Failure _ -> error "Not enough hypotheses in the goal." + with Failure _ -> user_err Pp.(str "Not enough hypotheses in the goal.") let nLastHypsId n gl = List.map (NamedDecl.get_id) (nLastDecls n gl) let nLastHyps n gl = List.map mkVar (nLastHypsId n gl) @@ -169,23 +169,23 @@ let fix_empty_or_and_pattern nv l = | IntroOrPattern [[]] -> IntroOrPattern (List.make nv []) | _ -> l -let check_or_and_pattern_size check_and loc names branchsigns = +let check_or_and_pattern_size ?loc check_and names branchsigns = let n = Array.length branchsigns in let msg p1 p2 = strbrk "a conjunctive pattern made of " ++ int p1 ++ (if p1 == p2 then mt () else str " or " ++ int p2) ++ str " patterns" in let err1 p1 p2 = - user_err ~loc (str "Expects " ++ msg p1 p2 ++ str ".") in + user_err ?loc (str "Expects " ++ msg p1 p2 ++ str ".") in let errn n = - user_err ~loc (str "Expects a disjunctive pattern with " ++ int n + user_err ?loc (str "Expects a disjunctive pattern with " ++ int n ++ str " branches.") in let err1' p1 p2 = - user_err ~loc (strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in - let errforthcoming loc = - user_err ~loc (strbrk "Unexpected non atomic pattern.") in + user_err ?loc (strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in + let errforthcoming ?loc = + user_err ?loc (strbrk "Unexpected non atomic pattern.") in match names with | IntroAndPattern l -> if not (Int.equal n 1) then errn n; let l' = List.filter (function _,IntroForthcoming _ -> true | _,IntroNaming _ | _,IntroAction _ -> false) l in - if l' != [] then errforthcoming (fst (List.hd l')); + if l' != [] then errforthcoming ?loc:(fst (List.hd l')); if check_and then let p1 = List.count (fun x -> x) branchsigns.(0) in let p2 = List.length branchsigns.(0) in @@ -193,7 +193,7 @@ let check_or_and_pattern_size check_and loc names branchsigns = if not (Int.equal p p1 || Int.equal p p2) then err1 p1 p2; if Int.equal p p1 then IntroAndPattern - (List.extend branchsigns.(0) (Loc.ghost,IntroNaming IntroAnonymous) l) + (List.extend branchsigns.(0) (Loc.tag @@ IntroNaming IntroAnonymous) l) else names else @@ -206,20 +206,20 @@ let check_or_and_pattern_size check_and loc names branchsigns = err1' p1 p2 else errn n; names -let get_and_check_or_and_pattern_gen check_and loc names branchsigns = - let names = check_or_and_pattern_size check_and loc names branchsigns in +let get_and_check_or_and_pattern_gen ?loc check_and names branchsigns = + let names = check_or_and_pattern_size ?loc check_and names branchsigns in match names with | IntroAndPattern l -> [|l|] | IntroOrPattern l -> Array.of_list l -let get_and_check_or_and_pattern = get_and_check_or_and_pattern_gen true +let get_and_check_or_and_pattern ?loc = get_and_check_or_and_pattern_gen ?loc true let compute_induction_names_gen check_and branchletsigns = function | None -> Array.make (Array.length branchletsigns) [] | Some (loc,names) -> let names = fix_empty_or_and_pattern (Array.length branchletsigns) names in - get_and_check_or_and_pattern_gen check_and loc names branchletsigns + get_and_check_or_and_pattern_gen check_and ?loc names branchletsigns let compute_induction_names = compute_induction_names_gen true @@ -490,7 +490,7 @@ module New = struct | [] -> () | (evk,evi) :: _ -> let (loc,_) = evi.Evd.evar_source in - Pretype_errors.error_unsolvable_implicit ~loc env sigma evk None + Pretype_errors.error_unsolvable_implicit ?loc env sigma evk None let tclWITHHOLES accept_unresolved_holes tac sigma = tclEVARMAP >>= fun sigma_initial -> @@ -533,11 +533,11 @@ module New = struct let hyps = Proofview.Goal.hyps gl in try List.nth hyps (m-1) - with Failure _ -> CErrors.error "No such assumption." + with Failure _ -> CErrors.user_err Pp.(str "No such assumption.") let nLastDecls gl n = try List.firstn n (Proofview.Goal.hyps gl) - with Failure _ -> error "Not enough hypotheses in the goal." + with Failure _ -> CErrors.user_err Pp.(str "Not enough hypotheses in the goal.") let nthHypId m gl = (** We only use [id] *) diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 5a4ecbac75..96270f748e 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -114,7 +114,7 @@ type branch_assumptions = private { error message if |pats| <> |branchsign|; extends them if no pattern is given for let-ins in the case of a conjunctive pattern *) val get_and_check_or_and_pattern : - Loc.t -> delayed_open_constr or_and_intro_pattern_expr -> + ?loc:Loc.t -> delayed_open_constr or_and_intro_pattern_expr -> bool list array -> intro_patterns array (** Tolerate "[]" to mean a disjunctive pattern of any length *) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 15cef676e6..6e45739ec3 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -53,8 +53,6 @@ module NamedDecl = Context.Named.Declaration let inj_with_occurrences e = (AllOccurrences,e) -let dloc = Loc.ghost - let typ_of env sigma c = let open Retyping in try get_type_of ~lax:true env (Sigma.to_evar_map sigma) c @@ -72,8 +70,7 @@ let use_dependent_propositions_elimination () = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "dependent-propositions-elimination tactic"; optkey = ["Dependent";"Propositions";"Elimination"]; optread = (fun () -> !dependent_propositions_elimination) ; @@ -81,8 +78,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "trigger bugged context matching compatibility"; optkey = ["Tactic";"Compat";"Context"]; optread = (fun () -> !Flags.tactic_context_compat) ; @@ -90,7 +86,7 @@ let _ = let apply_solve_class_goals = ref (false) let _ = Goptions.declare_bool_option { - Goptions.optsync = true; Goptions.optdepr = true; + Goptions.optdepr = true; Goptions.optname = "Perform typeclass resolution on apply-generated subgoals."; Goptions.optkey = ["Typeclass";"Resolution";"After";"Apply"]; @@ -104,8 +100,7 @@ let use_clear_hyp_by_default () = !clear_hyp_by_default let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "default clearing of hypotheses after use"; optkey = ["Default";"Clearing";"Used";"Hypotheses"]; optread = (fun () -> !clear_hyp_by_default) ; @@ -121,8 +116,7 @@ let accept_universal_lemma_under_conjunctions () = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "trivial unification in tactics applying under conjunctions"; optkey = ["Universal";"Lemma";"Under";"Conjunction"]; optread = (fun () -> !universal_lemma_under_conjunctions) ; @@ -134,8 +128,7 @@ let shrink_abstract = ref true let _ = declare_bool_option - { optsync = true; - optdepr = true; + { optdepr = true; optname = "shrinking of abstracted proofs"; optkey = ["Shrink"; "Abstract"]; optread = (fun () -> !shrink_abstract) ; @@ -155,8 +148,7 @@ let use_bracketing_last_or_and_intro_pattern () = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "bracketing last or-and introduction pattern"; optkey = ["Bracketing";"Last";"Introduction";"Pattern"]; optread = (fun () -> !bracketing_last_or_and_intro_pattern); @@ -203,6 +195,7 @@ let introduction ?(check=true) id = end } let refine = Tacmach.refine +let error msg = CErrors.user_err Pp.(str msg) let convert_concl ?(check=true) ty k = Proofview.Goal.enter { enter = begin fun gl -> @@ -427,11 +420,11 @@ let default_id env sigma decl = type name_flag = | NamingAvoid of Id.t list | NamingBasedOn of Id.t * Id.t list - | NamingMustBe of Loc.t * Id.t + | NamingMustBe of Id.t Loc.located let naming_of_name = function | Anonymous -> NamingAvoid [] - | Name id -> NamingMustBe (dloc,id) + | Name id -> NamingMustBe (Loc.tag id) let find_name mayrepl decl naming gl = match naming with | NamingAvoid idl -> @@ -445,7 +438,7 @@ let find_name mayrepl decl naming gl = match naming with let ids_of_hyps = Tacmach.New.pf_ids_of_hyps gl in let id' = next_ident_away id ids_of_hyps in if not mayrepl && not (Id.equal id' id) then - user_err ~loc (pr_id id ++ str" is already used."); + user_err ?loc (pr_id id ++ str" is already used."); id (**************************************************************) @@ -469,7 +462,7 @@ let assert_before_gen b naming t = assert_before_then_gen b naming t (fun _ -> Proofview.tclUNIT ()) let assert_before na = assert_before_gen false (naming_of_name na) -let assert_before_replacing id = assert_before_gen true (NamingMustBe (dloc,id)) +let assert_before_replacing id = assert_before_gen true (NamingMustBe (Loc.tag id)) let assert_after_then_gen b naming t tac = let open Context.Rel.Declaration in @@ -488,7 +481,7 @@ let assert_after_gen b naming t = assert_after_then_gen b naming t (fun _ -> (Proofview.tclUNIT ())) let assert_after na = assert_after_gen false (naming_of_name na) -let assert_after_replacing id = assert_after_gen true (NamingMustBe (dloc,id)) +let assert_after_replacing id = assert_after_gen true (NamingMustBe (Loc.tag id)) (**************************************************************) (* Fixpoints and CoFixpoints *) @@ -972,7 +965,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = end } let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ()) -let intro_mustbe_force id = intro_gen (NamingMustBe (dloc,id)) MoveLast true false +let intro_mustbe_force id = intro_gen (NamingMustBe (Loc.tag id)) MoveLast true false let intro_using id = intro_gen (NamingBasedOn (id,[])) MoveLast false false let intro_then = intro_then_gen (NamingAvoid []) MoveLast false false @@ -982,7 +975,7 @@ let intro_avoiding l = intro_gen (NamingAvoid l) MoveLast false false let intro_move_avoid idopt avoid hto = match idopt with | None -> intro_gen (NamingAvoid avoid) hto true false - | Some id -> intro_gen (NamingMustBe (dloc,id)) hto true false + | Some id -> intro_gen (NamingMustBe (Loc.tag id)) hto true false let intro_move idopt hto = intro_move_avoid idopt [] hto @@ -1142,7 +1135,7 @@ let try_intros_until tac = function let rec intros_move = function | [] -> Proofview.tclUNIT () | (hyp,destopt) :: rest -> - Tacticals.New.tclTHEN (intro_gen (NamingMustBe (dloc,hyp)) destopt false false) + Tacticals.New.tclTHEN (intro_gen (NamingMustBe (Loc.tag hyp)) destopt false false) (intros_move rest) let run_delayed env sigma c = @@ -1294,7 +1287,7 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in let exact_tac = Proofview.V82.tactic (Tacmach.refine_no_check new_hyp_prf) in - let naming = NamingMustBe (dloc,targetid) in + let naming = NamingMustBe (Loc.tag targetid) in let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS (clear_metas clenv.evd)) @@ -1739,7 +1732,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : with Redelimination -> (* Last chance: if the head is a variable, apply may try second order unification *) - let info = Loc.add_loc info loc in + let info = Option.cata (fun loc -> Loc.add_loc info loc) info loc in let tac = if with_destruct then descend_in_conjunctions [] @@ -1801,13 +1794,13 @@ let apply_with_delayed_bindings_gen b e l = (one k f) (aux cbl) in aux l -let apply_with_bindings cb = apply_with_bindings_gen false false [None,(dloc,cb)] +let apply_with_bindings cb = apply_with_bindings_gen false false [None,(Loc.tag cb)] -let eapply_with_bindings cb = apply_with_bindings_gen false true [None,(dloc,cb)] +let eapply_with_bindings cb = apply_with_bindings_gen false true [None,(Loc.tag cb)] -let apply c = apply_with_bindings_gen false false [None,(dloc,(c,NoBindings))] +let apply c = apply_with_bindings_gen false false [None,(Loc.tag (c,NoBindings))] -let eapply c = apply_with_bindings_gen false true [None,(dloc,(c,NoBindings))] +let eapply c = apply_with_bindings_gen false true [None,(Loc.tag (c,NoBindings))] let apply_list = function | c::l -> apply_with_bindings (c,ImplicitBindings l) @@ -1843,8 +1836,8 @@ let progress_with_clause flags innerclause clause = try List.find_map f ordered_metas with Not_found -> raise UnableToApply -let explain_unable_to_apply_lemma loc env sigma thm innerclause = - user_err ~loc (hov 0 +let explain_unable_to_apply_lemma ?loc env sigma thm innerclause = + user_err ?loc (hov 0 (Pp.str "Unable to apply lemma of type" ++ brk(1,1) ++ Pp.quote (Printer.pr_leconstr_env env sigma thm) ++ spc() ++ str "on hypothesis of type" ++ brk(1,1) ++ @@ -1860,7 +1853,7 @@ let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = try aux (clenv_push_prod clause) with NotExtensibleClause -> match e with - | UnableToApply -> explain_unable_to_apply_lemma loc env sigma thm innerclause + | UnableToApply -> explain_unable_to_apply_lemma ?loc env sigma thm innerclause | _ -> iraise e' in aux (make_clenv_binding env sigma (d,thm) lbind) @@ -2219,7 +2212,7 @@ let constructor_tac with_evars expctdnumopt i lbind = (Proofview.Goal.env gl) sigma (fst mind, i) in let cons = mkConstructU (cons, EInstance.make u) in - let apply_tac = general_apply true false with_evars None (dloc,(cons,lbind)) in + let apply_tac = general_apply true false with_evars None (Loc.tag (cons,lbind)) in let tac = (Tacticals.New.tclTHENLIST [ @@ -2286,7 +2279,7 @@ let error_unexpected_extra_pattern loc bound pat = | IntroNaming (IntroIdentifier _) -> "name", (String.plural nb " introduction pattern"), "no" | _ -> "introduction pattern", "", "none" in - user_err ~loc (str "Unexpected " ++ str s1 ++ str " (" ++ + user_err ?loc (str "Unexpected " ++ str s1 ++ str " (" ++ (if Int.equal nb 0 then (str s3 ++ str s2) else (str "at most " ++ int nb ++ str s2)) ++ spc () ++ str (if Int.equal nb 1 then "was" else "were") ++ @@ -2304,7 +2297,7 @@ let my_find_eq_data_decompose gl t = -> None | Constr_matching.PatternMatchingFailure -> None -let intro_decomp_eq loc l thin tac id = +let intro_decomp_eq ?loc l thin tac id = Proofview.Goal.enter { enter = begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in @@ -2312,13 +2305,13 @@ let intro_decomp_eq loc l thin tac id = match my_find_eq_data_decompose gl t with | Some (eq,u,eq_args) -> !intro_decomp_eq_function - (fun n -> tac ((dloc,id)::thin) (Some (true,n)) l) + (fun n -> tac ((Loc.tag id)::thin) (Some (true,n)) l) (eq,t,eq_args) (c, t) | None -> Tacticals.New.tclZEROMSG (str "Not a primitive equality here.") end } -let intro_or_and_pattern loc with_evars bracketed ll thin tac id = +let intro_or_and_pattern ?loc with_evars bracketed ll thin tac id = Proofview.Goal.enter { enter = begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in @@ -2326,7 +2319,7 @@ let intro_or_and_pattern loc with_evars bracketed ll thin tac id = let branchsigns = compute_constructor_signatures false ind in let nv_with_let = Array.map List.length branchsigns in let ll = fix_empty_or_and_pattern (Array.length branchsigns) ll in - let ll = get_and_check_or_and_pattern loc ll branchsigns in + let ll = get_and_check_or_and_pattern ?loc ll branchsigns in Tacticals.New.tclTHENLASTn (Tacticals.New.tclTHEN (simplest_ecase c) (clear [id])) (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l) @@ -2375,8 +2368,8 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = Tacticals.New.tclTHENFIRST eqtac (tac thin) end } -let prepare_naming loc = function - | IntroIdentifier id -> NamingMustBe (loc,id) +let prepare_naming ?loc = function + | IntroIdentifier id -> NamingMustBe (Loc.tag ?loc id) | IntroAnonymous -> NamingAvoid [] | IntroFresh id -> NamingBasedOn (id,[]) @@ -2400,10 +2393,10 @@ let rec check_name_unicity env ok seen = function | (loc, IntroNaming (IntroIdentifier id)) :: l -> (try ignore (if List.mem_f Id.equal id ok then raise Not_found else lookup_named id env); - user_err ~loc (pr_id id ++ str" is already used.") + user_err ?loc (pr_id id ++ str" is already used.") with Not_found -> if List.mem_f Id.equal id seen then - user_err ~loc (pr_id id ++ str" is used twice.") + user_err ?loc (pr_id id ++ str" is used twice.") else check_name_unicity env ok (id::seen) l) | (_, IntroAction (IntroOrAndPattern l)) :: l' -> @@ -2441,7 +2434,7 @@ let make_tmp_naming avoid l = function 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,avoid@explicit_intro_names l) - | pat -> NamingAvoid(avoid@explicit_intro_names ((dloc,IntroAction pat)::l)) + | pat -> NamingAvoid(avoid@explicit_intro_names ((Loc.tag @@ IntroAction pat)::l)) let fit_bound n = function | None -> true @@ -2477,7 +2470,7 @@ let rec intro_patterns_core with_evars b avoid ids thin destopt bound n tac = | [] -> (* Behave as IntroAnonymous *) intro_patterns_core with_evars b avoid ids thin destopt bound n tac - [dloc,IntroNaming IntroAnonymous] + [Loc.tag @@ IntroNaming IntroAnonymous] | (loc,pat) :: l -> if exceed_bound n bound then error_unexpected_extra_pattern loc bound pat else match pat with @@ -2489,7 +2482,7 @@ let rec intro_patterns_core with_evars b avoid ids thin destopt bound n tac = | IntroAction pat -> intro_then_gen (make_tmp_naming avoid l pat) destopt true false - (intro_pattern_action loc with_evars (b || not (List.is_empty l)) false + (intro_pattern_action ?loc with_evars (b || not (List.is_empty l)) false pat thin destopt (fun thin bound' -> intro_patterns_core with_evars b avoid ids thin destopt bound' 0 (fun ids thin -> @@ -2514,21 +2507,21 @@ and intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound n tac destopt true false (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) -and intro_pattern_action loc with_evars b style pat thin destopt tac id = +and intro_pattern_action ?loc with_evars b style pat thin destopt tac id = match pat with | IntroWildcard -> - tac ((loc,id)::thin) None [] + tac ((Loc.tag ?loc id)::thin) None [] | IntroOrAndPattern ll -> - intro_or_and_pattern loc with_evars b ll thin tac id + intro_or_and_pattern ?loc with_evars b ll thin tac id | IntroInjection l' -> - intro_decomp_eq loc l' thin tac id + intro_decomp_eq ?loc l' thin tac id | IntroRewrite l2r -> rewrite_hyp_then style with_evars thin l2r id (fun thin -> tac thin None []) | IntroApplyOn ((loc',f),(loc,pat)) -> let naming,tac_ipat = - prepare_intros_loc loc with_evars (IntroIdentifier id) destopt pat in + prepare_intros ?loc with_evars (IntroIdentifier id) destopt pat in let doclear = - if naming = NamingMustBe (loc,id) then + if naming = NamingMustBe (Loc.tag ?loc id) then Proofview.tclUNIT () (* apply_in_once do a replacement *) else clear [id] in @@ -2539,18 +2532,18 @@ and intro_pattern_action loc with_evars b style pat thin destopt tac id = apply_in_delayed_once false true true with_evars naming id (None,(loc',f)) (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) -and prepare_intros_loc loc with_evars dft destopt = function +and prepare_intros ?loc with_evars dft destopt = function | IntroNaming ipat -> - prepare_naming loc ipat, + prepare_naming ?loc ipat, (fun id -> move_hyp id destopt) | IntroAction ipat -> - prepare_naming loc dft, + prepare_naming ?loc dft, (let tac thin bound = intro_patterns_core with_evars true [] [] thin destopt bound 0 (fun _ l -> clear_wildcards l) in fun id -> - intro_pattern_action loc with_evars true true ipat [] destopt tac id) - | IntroForthcoming _ -> user_err ~loc + intro_pattern_action ?loc with_evars true true ipat [] destopt tac id) + | IntroForthcoming _ -> user_err ?loc (str "Introduction pattern for one hypothesis expected.") let intro_patterns_head_core with_evars b destopt bound pat = @@ -2570,7 +2563,7 @@ let intro_patterns_to with_evars destopt = destopt None let intro_pattern_to with_evars destopt pat = - intro_patterns_to with_evars destopt [dloc,pat] + intro_patterns_to with_evars destopt [Loc.tag pat] let intro_patterns with_evars = intro_patterns_to with_evars MoveLast @@ -2583,20 +2576,20 @@ let intros_patterns with_evars = function (* Forward reasoning *) (**************************) -let prepare_intros with_evars dft destopt = function - | None -> prepare_naming dloc dft, (fun _id -> Proofview.tclUNIT ()) - | Some (loc,ipat) -> prepare_intros_loc loc with_evars dft destopt ipat +let prepare_intros_opt with_evars dft destopt = function + | None -> prepare_naming dft, (fun _id -> Proofview.tclUNIT ()) + | Some (loc,ipat) -> prepare_intros ?loc with_evars dft destopt ipat let ipat_of_name = function | Anonymous -> None - | Name id -> Some (dloc, IntroNaming (IntroIdentifier id)) + | Name id -> Some (Loc.tag @@ IntroNaming (IntroIdentifier id)) let head_ident sigma c = let c = fst (decompose_app sigma (snd (decompose_lam_assum sigma c))) in if isVar sigma c then Some (destVar sigma c) else None let assert_as first hd ipat t = - let naming,tac = prepare_intros false IntroAnonymous MoveLast ipat in + let naming,tac = prepare_intros_opt false IntroAnonymous MoveLast ipat in let repl = do_replace hd naming in let tac = if repl then (fun id -> Proofview.tclUNIT ()) else tac in if first then assert_before_then_gen repl naming t tac @@ -2614,10 +2607,10 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars if with_evars then MoveLast (* evars would depend on the whole context *) else get_previous_hyp_position id gl in let naming,ipat_tac = - prepare_intros with_evars (IntroIdentifier id) destopt ipat in + prepare_intros_opt with_evars (IntroIdentifier id) destopt ipat in let lemmas_target, last_lemma_target = let last,first = List.sep_last lemmas in - List.map (fun lem -> (NamingMustBe (dloc,id),lem)) first, (naming,last) + List.map (fun lem -> (NamingMustBe (Loc.tag id),lem)) first, (naming,last) in (* We chain apply_in_once, ending with an intro pattern *) List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id @@ -2695,7 +2688,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = let tac = Tacticals.New.tclTHENLIST [ convert_concl_no_check newcl DEFAULTcast; - intro_gen (NamingMustBe (dloc,id)) (decode_hyp lastlhyp) true false; + intro_gen (NamingMustBe (Loc.tag id)) (decode_hyp lastlhyp) true false; Tacticals.New.tclMAP convert_hyp_no_check depdecls; eq_tac ] in @@ -2728,7 +2721,7 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = | IntroFresh heq_base -> fresh_id_in_env [id] heq_base env | IntroIdentifier id -> if List.mem id (ids_of_named_context (named_context env)) then - user_err ~loc (pr_id id ++ str" is already used."); + user_err ?loc (pr_id id ++ str" is already used."); id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in @@ -2763,7 +2756,7 @@ let letin_tac with_eq id c ty occs = Sigma (tac, sigma, p) end } -let letin_pat_tac with_eq id c occs = +let letin_pat_tac with_evars with_eq id c occs = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in @@ -2772,7 +2765,7 @@ let letin_pat_tac with_eq id c occs = let abs = AbstractPattern (false,check,id,c,occs,false) in let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in let Sigma (c, sigma, p) = match res with - | None -> finish_evar_resolution ~flags:(tactic_infer_flags false) env sigma c + | None -> finish_evar_resolution ~flags:(tactic_infer_flags with_evars) env sigma c | Some res -> res in let tac = (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None) @@ -2967,8 +2960,7 @@ let specialize (c,lbind) ipat = let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let sigma, term = if lbind == NoBindings then - let sigma = Typeclasses.resolve_typeclasses env sigma in - sigma, nf_evar sigma c + sigma, c else let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma c) lbind in let flags = { (default_unify_flags ()) with resolve_evars = true } in @@ -2983,7 +2975,7 @@ let specialize (c,lbind) ipat = if occur_meta clause.evd term then user_err (str "Cannot infer an instance for " ++ - pr_name (meta_name clause.evd (List.hd (collect_metas clause.evd term))) ++ + Name.print (meta_name clause.evd (List.hd (collect_metas clause.evd term))) ++ str "."); clause.evd, term in let typ = Retyping.get_type_of env sigma term in @@ -2992,7 +2984,7 @@ let specialize (c,lbind) ipat = | 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 false (IntroIdentifier id) MoveLast ipat in + 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) @@ -3006,7 +2998,7 @@ let specialize (c,lbind) ipat = | Some (loc,ipat) -> (* Like pose proof with extra support for "with" bindings *) (* even though the "with" bindings forces full application *) - let naming,tac = prepare_intros_loc loc false IntroAnonymous MoveLast ipat in + let naming,tac = prepare_intros ?loc false IntroAnonymous MoveLast ipat in Tacticals.New.tclTHENFIRST (assert_before_then_gen false naming typ tac) (exact_no_check term) @@ -3094,7 +3086,7 @@ let intropattern_of_name gl avoid = function | Name id -> IntroNaming (IntroIdentifier (new_fresh_id avoid id gl)) let rec consume_pattern avoid na isdep gl = function - | [] -> ((dloc, intropattern_of_name gl avoid na), []) + | [] -> ((Loc.tag @@ intropattern_of_name gl avoid na), []) | (loc,IntroForthcoming true)::names when not isdep -> consume_pattern avoid na isdep gl names | (loc,IntroForthcoming _)::names as fullpat -> @@ -3171,7 +3163,7 @@ let induct_discharge with_evars dests avoid' tac (avoid,ra) names = let (recpat,names) = match names with | [loc,IntroNaming (IntroIdentifier id) as pat] -> let id' = next_ident_away (add_prefix "IH" id) avoid in - (pat, [dloc, IntroNaming (IntroIdentifier id')]) + (pat, [Loc.tag @@ IntroNaming (IntroIdentifier id')]) | _ -> consume_pattern avoid (Name recvarname) deprec gl names in let dest = get_recarg_dest dests in dest_intro_patterns with_evars avoid thin dest [recpat] (fun ids thin -> @@ -3527,28 +3519,32 @@ let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in user_err ~hdr:"Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") -let glob c = EConstr.of_constr (Universes.constr_of_global c) - -let coq_eq = lazy (glob (Coqlib.build_coq_eq ())) -let coq_eq_refl = lazy (glob (Coqlib.build_coq_eq_refl ())) +let glob sigma gr = + let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map sigma) gr + in Sigma.to_evar_map sigma, c -let coq_heq = lazy (EConstr.of_constr (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq")) -let coq_heq_refl = lazy (EConstr.of_constr (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl")) +let coq_eq sigma = glob sigma (Coqlib.build_coq_eq ()) +let coq_eq_refl sigma = glob sigma (Coqlib.build_coq_eq_refl ()) +let coq_heq_ref = lazy (Coqlib.coq_reference"mkHEq" ["Logic";"JMeq"] "JMeq") +let coq_heq sigma = glob sigma (Lazy.force coq_heq_ref) +let coq_heq_refl sigma = glob sigma (Coqlib.coq_reference "mkHEq" ["Logic";"JMeq"] "JMeq_refl") -let mkEq t x y = - mkApp (Lazy.force coq_eq, [| t; x; y |]) +let mkEq sigma t x y = + let sigma, eq = coq_eq sigma in + sigma, mkApp (eq, [| t; x; y |]) -let mkRefl t x = - mkApp (Lazy.force coq_eq_refl, [| t; x |]) +let mkRefl sigma t x = + let sigma, refl = coq_eq_refl sigma in + sigma, mkApp (refl, [| t; x |]) -let mkHEq t x u y = - mkApp (Lazy.force coq_heq, - [| t; x; u; y |]) +let mkHEq sigma t x u y = + let sigma, c = coq_heq sigma in + sigma, mkApp (c,[| t; x; u; y |]) -let mkHRefl t x = - mkApp (Lazy.force coq_heq_refl, - [| t; x |]) +let mkHRefl sigma t x = + let sigma, c = coq_heq_refl sigma in + sigma, mkApp (c, [| t; x |]) let lift_togethern n l = let l', _ = @@ -3586,23 +3582,30 @@ let decompose_indapp sigma f args = mkApp (f, pars), args | _ -> f, args -let mk_term_eq env sigma ty t ty' t' = +let mk_term_eq homogeneous env sigma ty t ty' t' = let sigma = Sigma.to_evar_map sigma in - if Reductionops.is_conv env sigma ty ty' then - mkEq ty t t', mkRefl ty' t' + if homogeneous then + let sigma, eq = mkEq sigma ty t t' in + let sigma, refl = mkRefl sigma ty' t' in + Sigma.Unsafe.of_evar_map sigma, (eq, refl) else - mkHEq ty t ty' t', mkHRefl ty' t' + let sigma, heq = mkHEq sigma ty t ty' t' in + let sigma, hrefl = mkHRefl sigma ty' t' in + Sigma.Unsafe.of_evar_map sigma, (heq, hrefl) let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = let open Context.Rel.Declaration in Refine.refine { run = begin fun sigma -> let eqslen = List.length eqs in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) - let abshypeq, abshypt = + let sigma, abshypeq, abshypt = if dep then - let eq, refl = mk_term_eq (push_rel_context ctx env) sigma (lift 1 c) (mkRel 1) typ (mkVar id) in - mkProd (Anonymous, eq, lift 1 concl), [| refl |] - else concl, [||] + let ty = lift 1 c in + let homogeneous = Reductionops.is_conv env (Sigma.to_evar_map sigma) ty typ in + let sigma, (eq, refl) = + mk_term_eq homogeneous (push_rel_context ctx env) sigma ty (mkRel 1) typ (mkVar id) in + sigma, mkProd (Anonymous, eq, lift 1 concl), [| refl |] + else sigma, concl, [||] in (* Abstract by equalities *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) @@ -3708,9 +3711,13 @@ let abstract_args gl generalize_vars dep id defined f args = let liftarg = lift (List.length ctx) arg in let eq, refl = if leq then - mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl (lift (-lenctx) ty) arg + let sigma', eq = mkEq !sigma (lift 1 ty) (mkRel 1) liftarg in + let sigma', refl = mkRefl sigma' (lift (-lenctx) ty) arg in + sigma := sigma'; eq, refl else - mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg + let sigma', eq = mkHEq !sigma (lift 1 ty) (mkRel 1) liftargty liftarg in + let sigma', refl = mkHRefl sigma' argty arg in + sigma := sigma'; eq, refl in let eqs = eq :: lift_list eqs in let refls = refl :: refls in @@ -3810,17 +3817,19 @@ let specialize_eqs id gl = match EConstr.kind !evars ty with | Prod (na, t, b) -> (match EConstr.kind !evars t with - | App (eq, [| eqty; x; y |]) when EConstr.eq_constr !evars (Lazy.force coq_eq) eq -> + | App (eq, [| eqty; x; y |]) when EConstr.is_global !evars (Lazy.force coq_eq_ref) eq -> let c = if noccur_between !evars 1 (List.length ctx) x then y else x in - let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in - let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in + let pt = mkApp (eq, [| eqty; c; c |]) in + let ind = destInd !evars eq in + let p = mkApp (mkConstructUi (ind,0), [| eqty; c |]) in if unif (push_rel_context ctx env) evars pt t then aux true ctx (mkApp (acc, [| p |])) (subst1 p b) else acc, in_eqs, ctx, ty - | App (heq, [| eqty; x; eqty'; y |]) when EConstr.eq_constr !evars heq (Lazy.force coq_heq) -> + | App (heq, [| eqty; x; eqty'; y |]) when EConstr.is_global !evars (Lazy.force coq_heq_ref) heq -> let eqt, c = if noccur_between !evars 1 (List.length ctx) x then eqty', y else eqty, x in - let pt = mkApp (Lazy.force coq_heq, [| eqt; c; eqt; c |]) in - let p = mkApp (Lazy.force coq_heq_refl, [| eqt; c |]) in + let pt = mkApp (heq, [| eqt; c; eqt; c |]) in + let ind = destInd !evars heq in + let p = mkApp (mkConstructUi (ind,0), [| eqt; c |]) in if unif (push_rel_context ctx env) evars pt t then aux true ctx (mkApp (acc, [| p |])) (subst1 p b) else acc, in_eqs, ctx, ty @@ -4501,7 +4510,7 @@ let induction_gen_l isrec with_evars elim names lc = let lc = List.map (function | (c,None) -> c | (c,Some(loc,eqname)) -> - user_err ~loc (str "Do not know what to do with " ++ + user_err ?loc (str "Do not know what to do with " ++ Miscprint.pr_intro_pattern_naming eqname)) lc in let rec atomize_list l = match l with @@ -5068,14 +5077,14 @@ module Simple = struct let intro x = intro_move (Some x) MoveLast let apply c = - apply_with_bindings_gen false false [None,(Loc.ghost,(c,NoBindings))] + apply_with_bindings_gen false false [None,(Loc.tag (c,NoBindings))] let eapply c = - apply_with_bindings_gen false true [None,(Loc.ghost,(c,NoBindings))] + apply_with_bindings_gen false true [None,(Loc.tag (c,NoBindings))] let elim c = elim false None (c,NoBindings) None let case c = general_case_analysis false None (c,NoBindings) let apply_in id c = - apply_in false false id [None,(Loc.ghost, (c, NoBindings))] None + apply_in false false id [None,(Loc.tag (c, NoBindings))] None end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 07a8035427..0dbcce02c5 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -385,7 +385,7 @@ val letin_tac : (bool * intro_pattern_naming) option -> (** Common entry point for user-level "set", "pose" and "remember" *) -val letin_pat_tac : (bool * intro_pattern_naming) option -> +val letin_pat_tac : evars_flag -> (bool * intro_pattern_naming) option -> Name.t -> (evar_map * constr) -> clause -> unit Proofview.tactic (** {6 Generalize tactics. } *) diff --git a/test-suite/.csdp.cache b/test-suite/.csdp.cache Binary files differindex b99d80e95f..ba85286dd3 100644 --- a/test-suite/.csdp.cache +++ b/test-suite/.csdp.cache diff --git a/test-suite/Makefile b/test-suite/Makefile index afaa48463b..a26f66285f 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -27,10 +27,10 @@ # Default value when called from a freshly compiled Coq, but can be # easily overridden -BIN := ../bin/ LIB := $(shell cd ..; pwd) +BIN := $(LIB)/bin/ -coqtop := $(BIN)coqtop -boot -q -batch -test-mode -R prerequisite TestSuite +coqtop := $(BIN)coqtop -coqlib $(LIB) -boot -q -batch -test-mode -R prerequisite TestSuite coqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite coqchk := $(BIN)coqchk -coqlib $(LIB) -R prerequisite TestSuite coqtopbyte := $(BIN)coqtop.byte @@ -45,7 +45,7 @@ REDIR := $(if $(VERBOSE),,> /dev/null 2>&1) # read out an emacs config and look for coq-prog-args; if such exists, return it get_coq_prog_args_helper = sed -n s'/^.*coq-prog-args:[[:space:]]*(\([^)]*\)).*/\1/p' $(1) -get_coq_prog_args = $(strip $(filter-out "-emacs-U" "-emacs",$(shell $(call get_coq_prog_args_helper,$(1))))) +get_coq_prog_args = $(strip $(shell $(call get_coq_prog_args_helper,$(1)))) SINGLE_QUOTE=" #" # double up on the quotes, in a comment, to appease the emacs syntax highlighter # wrap the arguments in parens, but only if they exist @@ -87,7 +87,7 @@ VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ output-modulo-time interactive micromega $(COMPLEXITY) modules stm # All subsystems -SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk +SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coq-makefile PREREQUISITELOG = prerequisite/admit.v.log \ prerequisite/make_local.v.log prerequisite/make_notation.v.log @@ -151,6 +151,7 @@ summary: $(call summary_dir, "IDE tests", ide); \ $(call summary_dir, "VI tests", vio); \ $(call summary_dir, "Coqchk tests", coqchk); \ + $(call summary_dir, "Coq makefile", coq-makefile); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ nb_failure=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_failure) | wc -l`; \ nb_tests=`expr $$nb_success + $$nb_failure`; \ @@ -439,7 +440,7 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake)) @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ - $(BIN)fake_ide $< "$(BIN)coqtop -boot -async-proofs on -async-proofs-tactic-error-resilience off -async-proofs-command-error-resilience off" 2>&1; \ + $(BIN)fake_ide $< "$(BIN)coqtop -coqlib $(LIB) -boot -async-proofs on -async-proofs-tactic-error-resilience off -async-proofs-command-error-resilience off" 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -481,3 +482,20 @@ coqchk: $(patsubst %.v,%.chk.log,$(wildcard coqchk/*.v)) echo " $<...Error!"; \ fi; \ } > "$@" + +coq-makefile: $(patsubst %/run.sh,%.log,$(wildcard coq-makefile/*/run.sh)) + +coq-makefile/%.log : coq-makefile/%/run.sh + @echo "TEST coq-makefile/$*" + $(HIDE)(\ + export COQBIN=$(BIN);\ + cd coq-makefile/$* && \ + ./run.sh 2>&1; \ + if [ $$? = 0 ]; then \ + echo $(log_success); \ + echo " $<...Ok"; \ + else \ + echo $(log_failure); \ + echo " $<...Error!"; \ + fi; \ + ) > "$@" diff --git a/test-suite/bugs/closed/348.v b/test-suite/bugs/closed/348.v index 28cc5cb1e6..48f0b55129 100644 --- a/test-suite/bugs/closed/348.v +++ b/test-suite/bugs/closed/348.v @@ -9,5 +9,5 @@ End D. Module D' (M:S). Import M. - Definition empty:Set. exact nat. Save. + Definition empty:Set. exact nat. Qed. End D'. diff --git a/test-suite/bugs/closed/38.v b/test-suite/bugs/closed/38.v index 4fc8d7c97d..6b6e83779f 100644 --- a/test-suite/bugs/closed/38.v +++ b/test-suite/bugs/closed/38.v @@ -14,7 +14,7 @@ Definition same := fun (l m : liste) => forall (x : A), e x l <-> e x m. Definition same_refl (x:liste) : (same x x). unfold same; split; intros; trivial. -Save. +Qed. Goal forall (x:liste), (same x x). intro. diff --git a/test-suite/bugs/closed/5153.v b/test-suite/bugs/closed/5153.v new file mode 100644 index 0000000000..be6407b5fa --- /dev/null +++ b/test-suite/bugs/closed/5153.v @@ -0,0 +1,8 @@ +(* An example where it does not hurt having more type-classes resolution *) +Class some_type := { Ty : Type }. +Instance: some_type := { Ty := nat }. +Arguments Ty : clear implicits. +Goal forall (H : forall t : some_type, @Ty t -> False) (H' : False -> 1 = 2), 1 = 2. +Proof. +intros H H'. +specialize (H' (@H _ O)). (* was failing *) diff --git a/test-suite/bugs/closed/5523.v b/test-suite/bugs/closed/5523.v new file mode 100644 index 0000000000..d7582a3797 --- /dev/null +++ b/test-suite/bugs/closed/5523.v @@ -0,0 +1,6 @@ +(* Support for complex constructions in recursive notations, especially "match". *) + +Definition Let_In {A P} (x : A) (f : forall a : A, P a) : P x := let y := x in f y. +Notation "'dlet' x , y := v 'in' ( a , b , .. , c )" + := (Let_In v (fun '(x, y) => pair .. (pair a b) .. c)) + (at level 0). diff --git a/test-suite/coq-makefile/arg/_CoqProject b/test-suite/coq-makefile/arg/_CoqProject new file mode 100644 index 0000000000..afdb32e7cf --- /dev/null +++ b/test-suite/coq-makefile/arg/_CoqProject @@ -0,0 +1,11 @@ +-R theories test +-R src test +-I src +-arg "-compat 8.4" + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/arg/run.sh b/test-suite/coq-makefile/arg/run.sh new file mode 100755 index 0000000000..e98da17c78 --- /dev/null +++ b/test-suite/coq-makefile/arg/run.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make diff --git a/test-suite/coq-makefile/compat-subdirs/_CoqProject b/test-suite/coq-makefile/compat-subdirs/_CoqProject new file mode 100644 index 0000000000..4f44bde22a --- /dev/null +++ b/test-suite/coq-makefile/compat-subdirs/_CoqProject @@ -0,0 +1,11 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v +subdir/ diff --git a/test-suite/coq-makefile/compat-subdirs/run.sh b/test-suite/coq-makefile/compat-subdirs/run.sh new file mode 100755 index 0000000000..28d9878f9b --- /dev/null +++ b/test-suite/coq-makefile/compat-subdirs/run.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh +coq_makefile -f _CoqProject -o Makefile +make +exec test -f "subdir/done" diff --git a/test-suite/coq-makefile/compat-subdirs/subdir/Makefile b/test-suite/coq-makefile/compat-subdirs/subdir/Makefile new file mode 100644 index 0000000000..846c9b791b --- /dev/null +++ b/test-suite/coq-makefile/compat-subdirs/subdir/Makefile @@ -0,0 +1,3 @@ +all: + test -f ../theories/test.vo + touch done diff --git a/test-suite/coq-makefile/coqdoc1/_CoqProject b/test-suite/coq-makefile/coqdoc1/_CoqProject new file mode 100644 index 0000000000..35792066bb --- /dev/null +++ b/test-suite/coq-makefile/coqdoc1/_CoqProject @@ -0,0 +1,11 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v +theories/sub/testsub.v diff --git a/test-suite/coq-makefile/coqdoc1/run.sh b/test-suite/coq-makefile/coqdoc1/run.sh new file mode 100755 index 0000000000..d6bb52bb4a --- /dev/null +++ b/test-suite/coq-makefile/coqdoc1/run.sh @@ -0,0 +1,54 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make +make html mlihtml +make install DSTROOT="$PWD/tmp" +make install-doc DSTROOT="$PWD/tmp" +#make debug +(for d in `find tmp -name user-contrib`; do pushd $d >/dev/null; find .; popd >/dev/null; done) | sort -u > actual +sort -u > desired <<EOT +. +./test +./test/test_plugin.cma +./test/test_plugin.cmi +./test/test_plugin.cmo +./test/test_plugin.cmx +./test/test_plugin.cmxs +./test/test.glob +./test/test.v +./test/test.vo +./test/sub +./test/sub/testsub.glob +./test/sub/testsub.v +./test/sub/testsub.vo +./test/mlihtml +./test/mlihtml/index_exceptions.html +./test/mlihtml/index.html +./test/mlihtml/index_class_types.html +./test/mlihtml/type_Test_aux.html +./test/mlihtml/index_module_types.html +./test/mlihtml/index_classes.html +./test/mlihtml/type_Test.html +./test/mlihtml/style.css +./test/mlihtml/index_attributes.html +./test/mlihtml/index_types.html +./test/mlihtml/Test_aux.html +./test/mlihtml/index_values.html +./test/mlihtml/Test.html +./test/mlihtml/index_extensions.html +./test/mlihtml/index_methods.html +./test/mlihtml/index_modules.html +./test/html +./test/html/index.html +./test/html/test.sub.testsub.html +./test/html/toc.html +./test/html/coqdoc.css +./test/html/test.test.html +EOT +exec diff -u desired actual diff --git a/test-suite/coq-makefile/coqdoc2/_CoqProject b/test-suite/coq-makefile/coqdoc2/_CoqProject new file mode 100644 index 0000000000..d2a547d47b --- /dev/null +++ b/test-suite/coq-makefile/coqdoc2/_CoqProject @@ -0,0 +1,11 @@ +-R src/ test +-R theories/ test +-I src/ + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v +theories/sub/testsub.v diff --git a/test-suite/coq-makefile/coqdoc2/run.sh b/test-suite/coq-makefile/coqdoc2/run.sh new file mode 100755 index 0000000000..d6bb52bb4a --- /dev/null +++ b/test-suite/coq-makefile/coqdoc2/run.sh @@ -0,0 +1,54 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make +make html mlihtml +make install DSTROOT="$PWD/tmp" +make install-doc DSTROOT="$PWD/tmp" +#make debug +(for d in `find tmp -name user-contrib`; do pushd $d >/dev/null; find .; popd >/dev/null; done) | sort -u > actual +sort -u > desired <<EOT +. +./test +./test/test_plugin.cma +./test/test_plugin.cmi +./test/test_plugin.cmo +./test/test_plugin.cmx +./test/test_plugin.cmxs +./test/test.glob +./test/test.v +./test/test.vo +./test/sub +./test/sub/testsub.glob +./test/sub/testsub.v +./test/sub/testsub.vo +./test/mlihtml +./test/mlihtml/index_exceptions.html +./test/mlihtml/index.html +./test/mlihtml/index_class_types.html +./test/mlihtml/type_Test_aux.html +./test/mlihtml/index_module_types.html +./test/mlihtml/index_classes.html +./test/mlihtml/type_Test.html +./test/mlihtml/style.css +./test/mlihtml/index_attributes.html +./test/mlihtml/index_types.html +./test/mlihtml/Test_aux.html +./test/mlihtml/index_values.html +./test/mlihtml/Test.html +./test/mlihtml/index_extensions.html +./test/mlihtml/index_methods.html +./test/mlihtml/index_modules.html +./test/html +./test/html/index.html +./test/html/test.sub.testsub.html +./test/html/toc.html +./test/html/coqdoc.css +./test/html/test.test.html +EOT +exec diff -u desired actual diff --git a/test-suite/coq-makefile/extend-subdirs/Makefile.local b/test-suite/coq-makefile/extend-subdirs/Makefile.local new file mode 100644 index 0000000000..b031d30dbd --- /dev/null +++ b/test-suite/coq-makefile/extend-subdirs/Makefile.local @@ -0,0 +1,4 @@ +pre-all:: + $(MAKE) -C subdir pre +post-all:: + $(MAKE) -C subdir post diff --git a/test-suite/coq-makefile/extend-subdirs/_CoqProject b/test-suite/coq-makefile/extend-subdirs/_CoqProject new file mode 100644 index 0000000000..69f47302e1 --- /dev/null +++ b/test-suite/coq-makefile/extend-subdirs/_CoqProject @@ -0,0 +1,10 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/extend-subdirs/run.sh b/test-suite/coq-makefile/extend-subdirs/run.sh new file mode 100755 index 0000000000..ea5792a937 --- /dev/null +++ b/test-suite/coq-makefile/extend-subdirs/run.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make +exec test -f "subdir/done" diff --git a/test-suite/coq-makefile/extend-subdirs/subdir/Makefile b/test-suite/coq-makefile/extend-subdirs/subdir/Makefile new file mode 100644 index 0000000000..23f52b154a --- /dev/null +++ b/test-suite/coq-makefile/extend-subdirs/subdir/Makefile @@ -0,0 +1,5 @@ +pre: + test ! -f ../theories/test.vo +post: + test -f ../theories/test.vo + touch done diff --git a/test-suite/coq-makefile/latex1/_CoqProject b/test-suite/coq-makefile/latex1/_CoqProject new file mode 100644 index 0000000000..35792066bb --- /dev/null +++ b/test-suite/coq-makefile/latex1/_CoqProject @@ -0,0 +1,11 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v +theories/sub/testsub.v diff --git a/test-suite/coq-makefile/latex1/run.sh b/test-suite/coq-makefile/latex1/run.sh new file mode 100755 index 0000000000..214a9d5b28 --- /dev/null +++ b/test-suite/coq-makefile/latex1/run.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash + +#set -x +set -e + +if which pdflatex; then + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make +exec make all.pdf + +fi +exit 0 # test skipped diff --git a/test-suite/coq-makefile/merlin1/_CoqProject b/test-suite/coq-makefile/merlin1/_CoqProject new file mode 100644 index 0000000000..69f47302e1 --- /dev/null +++ b/test-suite/coq-makefile/merlin1/_CoqProject @@ -0,0 +1,10 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/merlin1/run.sh b/test-suite/coq-makefile/merlin1/run.sh new file mode 100755 index 0000000000..752c0c2cea --- /dev/null +++ b/test-suite/coq-makefile/merlin1/run.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make .merlin +cat > desired <<EOT +B src +S src +EOT +tail -2 .merlin > actual +exec diff -u desired actual diff --git a/test-suite/coq-makefile/mlpack1/_CoqProject b/test-suite/coq-makefile/mlpack1/_CoqProject new file mode 100644 index 0000000000..69f47302e1 --- /dev/null +++ b/test-suite/coq-makefile/mlpack1/_CoqProject @@ -0,0 +1,10 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/mlpack1/run.sh b/test-suite/coq-makefile/mlpack1/run.sh new file mode 100755 index 0000000000..f6fb3bcb42 --- /dev/null +++ b/test-suite/coq-makefile/mlpack1/run.sh @@ -0,0 +1,26 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make +make html mlihtml +make install DSTROOT="$PWD/tmp" +#make debug +(cd `find tmp -name user-contrib`; find .) | sort > actual +sort > desired <<EOT +. +./test +./test/test.glob +./test/test_plugin.cma +./test/test_plugin.cmi +./test/test_plugin.cmo +./test/test_plugin.cmx +./test/test_plugin.cmxs +./test/test.v +./test/test.vo +EOT +exec diff -u desired actual diff --git a/test-suite/coq-makefile/mlpack2/_CoqProject b/test-suite/coq-makefile/mlpack2/_CoqProject new file mode 100644 index 0000000000..51864a87ae --- /dev/null +++ b/test-suite/coq-makefile/mlpack2/_CoqProject @@ -0,0 +1,10 @@ +-R src/ test +-R theories/ test +-I src/ + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/mlpack2/run.sh b/test-suite/coq-makefile/mlpack2/run.sh new file mode 100755 index 0000000000..f6fb3bcb42 --- /dev/null +++ b/test-suite/coq-makefile/mlpack2/run.sh @@ -0,0 +1,26 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make +make html mlihtml +make install DSTROOT="$PWD/tmp" +#make debug +(cd `find tmp -name user-contrib`; find .) | sort > actual +sort > desired <<EOT +. +./test +./test/test.glob +./test/test_plugin.cma +./test/test_plugin.cmi +./test/test_plugin.cmo +./test/test_plugin.cmx +./test/test_plugin.cmxs +./test/test.v +./test/test.vo +EOT +exec diff -u desired actual diff --git a/test-suite/coq-makefile/multiroot/_CoqProject b/test-suite/coq-makefile/multiroot/_CoqProject new file mode 100644 index 0000000000..b384bb6d97 --- /dev/null +++ b/test-suite/coq-makefile/multiroot/_CoqProject @@ -0,0 +1,12 @@ +-R theories/ test +-R theories2 test2 +-R src/ test +-I src/ + +./src/test_plugin.mllib +./src/test.ml4 +./src/test.mli +./src/test_aux.ml +./src/test_aux.mli +./theories/test.v +./theories2/test.v diff --git a/test-suite/coq-makefile/multiroot/run.sh b/test-suite/coq-makefile/multiroot/run.sh new file mode 100755 index 0000000000..863c39f500 --- /dev/null +++ b/test-suite/coq-makefile/multiroot/run.sh @@ -0,0 +1,61 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +cp -r theories theories2 +mv src/test_plugin.mlpack src/test_plugin.mllib +coq_makefile -f _CoqProject -o Makefile +make +make html mlihtml +make install DSTROOT="$PWD/tmp" +make install-doc DSTROOT="$PWD/tmp" +#make debug +(for d in `find tmp -name user-contrib`; do pushd $d >/dev/null; find .; popd >/dev/null; done) | sort -u > actual +sort > desired <<EOT +. +./test +./test/test.glob +./test/test.cmi +./test/test.cmo +./test/test.cmx +./test/test_aux.cmi +./test/test_aux.cmo +./test/test_aux.cmx +./test/test_plugin.cma +./test/test_plugin.cmxa +./test/test_plugin.cmxs +./test/test.v +./test/test.vo +./test2 +./test2/test.glob +./test2/test.v +./test2/test.vo +./orphan_test_test2_test +./orphan_test_test2_test/html +./orphan_test_test2_test/html/coqdoc.css +./orphan_test_test2_test/html/index.html +./orphan_test_test2_test/html/test2.test.html +./orphan_test_test2_test/html/test.test.html +./orphan_test_test2_test/html/toc.html +./orphan_test_test2_test/mlihtml +./orphan_test_test2_test/mlihtml/index_attributes.html +./orphan_test_test2_test/mlihtml/index_classes.html +./orphan_test_test2_test/mlihtml/index_class_types.html +./orphan_test_test2_test/mlihtml/index_exceptions.html +./orphan_test_test2_test/mlihtml/index_extensions.html +./orphan_test_test2_test/mlihtml/index.html +./orphan_test_test2_test/mlihtml/index_methods.html +./orphan_test_test2_test/mlihtml/index_modules.html +./orphan_test_test2_test/mlihtml/index_module_types.html +./orphan_test_test2_test/mlihtml/index_types.html +./orphan_test_test2_test/mlihtml/index_values.html +./orphan_test_test2_test/mlihtml/style.css +./orphan_test_test2_test/mlihtml/Test_aux.html +./orphan_test_test2_test/mlihtml/Test.html +./orphan_test_test2_test/mlihtml/type_Test_aux.html +./orphan_test_test2_test/mlihtml/type_Test.html +EOT +exec diff -u desired actual diff --git a/test-suite/coq-makefile/native1/_CoqProject b/test-suite/coq-makefile/native1/_CoqProject new file mode 100644 index 0000000000..a6fa17348c --- /dev/null +++ b/test-suite/coq-makefile/native1/_CoqProject @@ -0,0 +1,11 @@ +-R src test +-R theories test +-I src +-arg -native-compiler + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/native1/run.sh b/test-suite/coq-makefile/native1/run.sh new file mode 100755 index 0000000000..bc9f846dda --- /dev/null +++ b/test-suite/coq-makefile/native1/run.sh @@ -0,0 +1,35 @@ +#!/usr/bin/env bash + +#set -x +set -e + +if which ocamlopt; then + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make +make html mlihtml +make install DSTROOT="$PWD/tmp" +#make debug +(cd `find tmp -name user-contrib`; find .) | sort > actual +sort > desired <<EOT +. +./test +./test/test.glob +./test/test_plugin.cma +./test/test_plugin.cmi +./test/test_plugin.cmo +./test/test_plugin.cmx +./test/test_plugin.cmxs +./test/test.v +./test/test.vo +./test/.coq-native +./test/.coq-native/Ntest_test.cmi +./test/.coq-native/Ntest_test.cmx +./test/.coq-native/Ntest_test.cmxs +EOT +exec diff -u desired actual + +fi +exit 0 # test skipped diff --git a/test-suite/coq-makefile/only/_CoqProject b/test-suite/coq-makefile/only/_CoqProject new file mode 100644 index 0000000000..357384fddf --- /dev/null +++ b/test-suite/coq-makefile/only/_CoqProject @@ -0,0 +1,11 @@ +-R theories/ test +-R src/ test +-I src/ + +./src/test_plugin.mlpack +./src/test.ml4 +./src/test.mli +./src/test_aux.ml +./src/test_aux.mli +./theories/test.v +./theories/sub/testsub.v diff --git a/test-suite/coq-makefile/only/run.sh b/test-suite/coq-makefile/only/run.sh new file mode 100755 index 0000000000..2ea3deffb7 --- /dev/null +++ b/test-suite/coq-makefile/only/run.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make only TGTS="src/test.cmi src/test_aux.cmi" -j2 +test -f src/test.cmi +test -f src/test_aux.cmi +! test -f src/test.cmo diff --git a/test-suite/coq-makefile/plugin1/_CoqProject b/test-suite/coq-makefile/plugin1/_CoqProject new file mode 100644 index 0000000000..4eddc9d708 --- /dev/null +++ b/test-suite/coq-makefile/plugin1/_CoqProject @@ -0,0 +1,10 @@ +-R theories test +-R src test +-I src + +src/test_plugin.mllib +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/plugin1/run.sh b/test-suite/coq-makefile/plugin1/run.sh new file mode 100755 index 0000000000..24ef8c891b --- /dev/null +++ b/test-suite/coq-makefile/plugin1/run.sh @@ -0,0 +1,31 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +mv src/test_plugin.mlpack src/test_plugin.mllib +coq_makefile -f _CoqProject -o Makefile +make +make html mlihtml +make install DSTROOT="$PWD/tmp" +#make debug +(cd `find tmp -name user-contrib`; find .) | sort > actual +sort > desired <<EOT +. +./test +./test/test.glob +./test/test.cmi +./test/test.cmo +./test/test.cmx +./test/test_aux.cmi +./test/test_aux.cmo +./test/test_aux.cmx +./test/test_plugin.cma +./test/test_plugin.cmxa +./test/test_plugin.cmxs +./test/test.v +./test/test.vo +EOT +exec diff -u desired actual diff --git a/test-suite/coq-makefile/plugin2/_CoqProject b/test-suite/coq-makefile/plugin2/_CoqProject new file mode 100644 index 0000000000..0bf1e07f25 --- /dev/null +++ b/test-suite/coq-makefile/plugin2/_CoqProject @@ -0,0 +1,10 @@ +-R theories/ test +-R src/ test +-I src/ + +src/test_plugin.mllib +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/plugin2/run.sh b/test-suite/coq-makefile/plugin2/run.sh new file mode 100755 index 0000000000..24ef8c891b --- /dev/null +++ b/test-suite/coq-makefile/plugin2/run.sh @@ -0,0 +1,31 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +mv src/test_plugin.mlpack src/test_plugin.mllib +coq_makefile -f _CoqProject -o Makefile +make +make html mlihtml +make install DSTROOT="$PWD/tmp" +#make debug +(cd `find tmp -name user-contrib`; find .) | sort > actual +sort > desired <<EOT +. +./test +./test/test.glob +./test/test.cmi +./test/test.cmo +./test/test.cmx +./test/test_aux.cmi +./test/test_aux.cmo +./test/test_aux.cmx +./test/test_plugin.cma +./test/test_plugin.cmxa +./test/test_plugin.cmxs +./test/test.v +./test/test.vo +EOT +exec diff -u desired actual diff --git a/test-suite/coq-makefile/plugin3/_CoqProject b/test-suite/coq-makefile/plugin3/_CoqProject new file mode 100644 index 0000000000..2028d49a8b --- /dev/null +++ b/test-suite/coq-makefile/plugin3/_CoqProject @@ -0,0 +1,10 @@ +-R theories/ test +-R src/ test +-I src/ + +./src/test_plugin.mllib +./src/test.ml4 +./src/test.mli +./src/test_aux.ml +./src/test_aux.mli +./theories/test.v diff --git a/test-suite/coq-makefile/plugin3/run.sh b/test-suite/coq-makefile/plugin3/run.sh new file mode 100755 index 0000000000..24ef8c891b --- /dev/null +++ b/test-suite/coq-makefile/plugin3/run.sh @@ -0,0 +1,31 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +mv src/test_plugin.mlpack src/test_plugin.mllib +coq_makefile -f _CoqProject -o Makefile +make +make html mlihtml +make install DSTROOT="$PWD/tmp" +#make debug +(cd `find tmp -name user-contrib`; find .) | sort > actual +sort > desired <<EOT +. +./test +./test/test.glob +./test/test.cmi +./test/test.cmo +./test/test.cmx +./test/test_aux.cmi +./test/test_aux.cmo +./test/test_aux.cmx +./test/test_plugin.cma +./test/test_plugin.cmxa +./test/test_plugin.cmxs +./test/test.v +./test/test.vo +EOT +exec diff -u desired actual diff --git a/test-suite/coq-makefile/template/init.sh b/test-suite/coq-makefile/template/init.sh new file mode 100755 index 0000000000..c952d41a30 --- /dev/null +++ b/test-suite/coq-makefile/template/init.sh @@ -0,0 +1,16 @@ + +export PATH=$COQBIN:$PATH + +rm -rf theories src Makefile Makefile.conf tmp +git clean -dfx || true + +mkdir -p src +mkdir -p theories/sub + +cp ../template/theories/sub/testsub.v theories/sub +cp ../template/theories/test.v theories +cp ../template/src/test.ml4 src +cp ../template/src/test_aux.mli src +cp ../template/src/test.mli src +cp ../template/src/test_plugin.mlpack src +cp ../template/src/test_aux.ml src diff --git a/test-suite/coq-makefile/template/src/test.ml4 b/test-suite/coq-makefile/template/src/test.ml4 new file mode 100644 index 0000000000..72765abe04 --- /dev/null +++ b/test-suite/coq-makefile/template/src/test.ml4 @@ -0,0 +1,14 @@ +open Ltac_plugin +DECLARE PLUGIN "test_plugin" +let () = Mltop.add_known_plugin (fun () -> ()) "test_plugin";; + +VERNAC COMMAND EXTEND Test CLASSIFIED AS SIDEFF + | [ "TestCommand" ] -> [ () ] +END + +TACTIC EXTEND test +| [ "test_tactic" ] -> [ Test_aux.tac ] +END + + + diff --git a/test-suite/coq-makefile/template/src/test.mli b/test-suite/coq-makefile/template/src/test.mli new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/test-suite/coq-makefile/template/src/test.mli diff --git a/test-suite/coq-makefile/template/src/test_aux.ml b/test-suite/coq-makefile/template/src/test_aux.ml new file mode 100644 index 0000000000..a01d0865a8 --- /dev/null +++ b/test-suite/coq-makefile/template/src/test_aux.ml @@ -0,0 +1 @@ +let tac = Proofview.tclUNIT () diff --git a/test-suite/coq-makefile/template/src/test_aux.mli b/test-suite/coq-makefile/template/src/test_aux.mli new file mode 100644 index 0000000000..10020f27de --- /dev/null +++ b/test-suite/coq-makefile/template/src/test_aux.mli @@ -0,0 +1 @@ +val tac : unit Proofview.tactic diff --git a/test-suite/coq-makefile/template/src/test_plugin.mlpack b/test-suite/coq-makefile/template/src/test_plugin.mlpack new file mode 100644 index 0000000000..cf94d851bb --- /dev/null +++ b/test-suite/coq-makefile/template/src/test_plugin.mlpack @@ -0,0 +1,2 @@ +Test_aux +Test diff --git a/test-suite/coq-makefile/template/theories/sub/testsub.v b/test-suite/coq-makefile/template/theories/sub/testsub.v new file mode 100644 index 0000000000..755fc343f2 --- /dev/null +++ b/test-suite/coq-makefile/template/theories/sub/testsub.v @@ -0,0 +1 @@ +Require Import test. diff --git a/test-suite/coq-makefile/template/theories/test.v b/test-suite/coq-makefile/template/theories/test.v new file mode 100644 index 0000000000..744b5aad78 --- /dev/null +++ b/test-suite/coq-makefile/template/theories/test.v @@ -0,0 +1,7 @@ +Declare ML Module "test_plugin". +TestCommand. +Goal True. +Proof. +test_tactic. +exact I. +Qed. diff --git a/test-suite/coq-makefile/uninstall1/_CoqProject b/test-suite/coq-makefile/uninstall1/_CoqProject new file mode 100644 index 0000000000..35792066bb --- /dev/null +++ b/test-suite/coq-makefile/uninstall1/_CoqProject @@ -0,0 +1,11 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v +theories/sub/testsub.v diff --git a/test-suite/coq-makefile/uninstall1/run.sh b/test-suite/coq-makefile/uninstall1/run.sh new file mode 100755 index 0000000000..e525e12086 --- /dev/null +++ b/test-suite/coq-makefile/uninstall1/run.sh @@ -0,0 +1,20 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make +make html mlihtml +make install DSTROOT="$PWD/tmp" +make install-doc DSTROOT="$PWD/tmp" +make uninstall DSTROOT="$PWD/tmp" +make uninstall-doc DSTROOT="$PWD/tmp" +#make debug +(for d in `find tmp -name user-contrib`; do pushd $d >/dev/null; find .; popd >/dev/null; done) | sort -u > actual +sort -u > desired <<EOT +. +EOT +exec diff -u desired actual diff --git a/test-suite/coq-makefile/uninstall2/_CoqProject b/test-suite/coq-makefile/uninstall2/_CoqProject new file mode 100644 index 0000000000..d2a547d47b --- /dev/null +++ b/test-suite/coq-makefile/uninstall2/_CoqProject @@ -0,0 +1,11 @@ +-R src/ test +-R theories/ test +-I src/ + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v +theories/sub/testsub.v diff --git a/test-suite/coq-makefile/uninstall2/run.sh b/test-suite/coq-makefile/uninstall2/run.sh new file mode 100755 index 0000000000..e525e12086 --- /dev/null +++ b/test-suite/coq-makefile/uninstall2/run.sh @@ -0,0 +1,20 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make +make html mlihtml +make install DSTROOT="$PWD/tmp" +make install-doc DSTROOT="$PWD/tmp" +make uninstall DSTROOT="$PWD/tmp" +make uninstall-doc DSTROOT="$PWD/tmp" +#make debug +(for d in `find tmp -name user-contrib`; do pushd $d >/dev/null; find .; popd >/dev/null; done) | sort -u > actual +sort -u > desired <<EOT +. +EOT +exec diff -u desired actual diff --git a/test-suite/coq-makefile/validate1/_CoqProject b/test-suite/coq-makefile/validate1/_CoqProject new file mode 100644 index 0000000000..69f47302e1 --- /dev/null +++ b/test-suite/coq-makefile/validate1/_CoqProject @@ -0,0 +1,10 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/validate1/run.sh b/test-suite/coq-makefile/validate1/run.sh new file mode 100755 index 0000000000..aaa4194b38 --- /dev/null +++ b/test-suite/coq-makefile/validate1/run.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +#set -x +set -e + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +make +exec make validate diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 4d59a92cbf..f4ecfd7362 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -98,5 +98,10 @@ fun n : nat => foo4 n (fun _ y : nat => ETA z : nat, (fun _ : nat => y = 0)) : nat -> Prop tele (t : Type) '(y, z) (x : t0) := tt : forall t : Type, nat * nat -> t -> fpack +[fun x : nat => x + 0;; fun x : nat => x + 1;; fun x : nat => x + 2] + : (nat -> nat) * + ((nat -> nat) * + ((nat -> nat) * + ((nat -> nat) * ((nat -> nat) * ((nat -> nat) * (nat -> nat)))))) foo5 x nat x : nat -> nat diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 96d831944f..71536c68fb 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -140,6 +140,12 @@ Notation "'tele' x .. z := b" := Check tele (t:Type) '((y,z):nat*nat) (x:t) := tt. +(* Checking that "fun" in a notation does not mixed up with the + detection of a recursive binder *) + +Notation "[ x ;; .. ;; y ]" := ((x,((fun u => S u), .. (y,(fun u => S u,fun v:nat => v)) ..))). +Check [ fun x => x+0 ;; fun x => x+1 ;; fun x => x+2 ]. + (* Cyprien's part of bug #4765 *) Notation foo5 x T y := (fun x : T => y). diff --git a/test-suite/output/Show.out b/test-suite/output/Show.out new file mode 100644 index 0000000000..8acfed5d00 --- /dev/null +++ b/test-suite/output/Show.out @@ -0,0 +1,12 @@ +3 subgoals (ID 31) + + H : 0 = 0 + ============================ + 1 = 1 + +subgoal 2 (ID 35) is: + 1 = S (S m') +subgoal 3 (ID 22) is: + S (S n') = S m + +(dependent evars: (printing disabled) ) diff --git a/test-suite/output/Show.v b/test-suite/output/Show.v new file mode 100644 index 0000000000..60faac8dd9 --- /dev/null +++ b/test-suite/output/Show.v @@ -0,0 +1,11 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs") -*- *) + +(* tests of Show output with -emacs flag to coqtop; see bug 5535 *) + +Theorem nums : forall (n m : nat), n = m -> (S n) = (S m). +Proof. + intros. + induction n as [| n']. + induction m as [| m']. + Show. +Admitted. diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index c70467912f..d28ee42761 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -6,13 +6,13 @@ fun e : option L => match e with : option L -> option L fun (m n p : nat) (H : S m <= S n + p) => le_S_n m (n + p) H : forall m n p : nat, S m <= S n + p -> m <= n + p -fun n : nat => let x : T n := A n in ?t ?y : T n +fun n : nat => let y : T n := A n in ?t ?x : T n : forall n : nat, T n where -?t : [n : nat x := A n : T n |- ?T -> T n] -?y : [n : nat x := A n : T n |- ?T] -fun n : nat => ?t ?y : T n +?t : [n : nat y := A n : T n |- ?T -> T n] +?x : [n : nat y := A n : T n |- ?T] +fun n : nat => ?t ?x : T n : forall n : nat, T n where ?t : [n : nat |- ?T -> T n] -?y : [n : nat |- ?T] +?x : [n : nat |- ?T] diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v index 1825db1676..f761a4dc5a 100644 --- a/test-suite/output/inference.v +++ b/test-suite/output/inference.v @@ -27,5 +27,5 @@ Check (fun m n p (H : S m <= (S n) + p) => le_S_n _ _ H). (* Note: exact numbers of evars are not important... *) Inductive T (n:nat) : Type := A : T n. -Check fun n (x:=A n:T n) => _ _ : T n. +Check fun n (y:=A n:T n) => _ _ : T n. Check fun n => _ _ : T n. diff --git a/test-suite/output/names.out b/test-suite/output/names.out index 9471b892dd..48be63a46a 100644 --- a/test-suite/output/names.out +++ b/test-suite/output/names.out @@ -3,3 +3,9 @@ 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 +(shelved: 1) + + H : ?n <= 3 -> 3 <= ?n -> ?n = 3 + ============================ + True diff --git a/test-suite/output/names.v b/test-suite/output/names.v index b3b5071a03..f1efd0df2a 100644 --- a/test-suite/output/names.v +++ b/test-suite/output/names.v @@ -3,3 +3,7 @@ Parameter a : forall x, {y:nat|x=y}. Fail Definition b y : {x:nat|x=y} := a y. + +Goal (forall n m, n <= m -> m <= n -> n = m) -> True. +intro H; epose proof (H _ 3) as H. +Show. diff --git a/test-suite/success/Abstract.v b/test-suite/success/Abstract.v index ffd50f6efd..69dc9aca78 100644 --- a/test-suite/success/Abstract.v +++ b/test-suite/success/Abstract.v @@ -1,4 +1,3 @@ - (* Cf coqbugs #546 *) Require Import Omega. diff --git a/test-suite/success/ROmega0.v b/test-suite/success/ROmega0.v index 1348bb6238..42730f2e16 100644 --- a/test-suite/success/ROmega0.v +++ b/test-suite/success/ROmega0.v @@ -135,11 +135,13 @@ Qed. (* Magaud #240 *) Lemma test_romega_8 : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. +Proof. intros. romega. Qed. Lemma test_romega_8b : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. +Proof. intros x y. romega. Qed. @@ -147,6 +149,20 @@ Qed. (* Besson #1298 *) Lemma test_romega9 : forall z z':Z, z<>z' -> z'=z -> False. +Proof. intros. romega. Qed. + +(* Letouzey, May 2017 *) + +Lemma test_romega10 : forall x a a' b b', + a' <= b -> + a <= b' -> + b < b' -> + a < a' -> + a <= x < b' <-> a <= x < b \/ a' <= x < b'. +Proof. + intros. + romega. +Qed. diff --git a/test-suite/success/change.v b/test-suite/success/change.v index 1f0b7d38a9..a9821b027f 100644 --- a/test-suite/success/change.v +++ b/test-suite/success/change.v @@ -59,3 +59,12 @@ unfold x. (* check that n in 0+n is not interpreted as the n from "fun n" *) change n with (0+n). Abort. + +(* Check non-collision of non-normalized defined evars with pattern variables *) + +Goal exists x, 1=1 -> x=1/\x=1. +eexists ?[n]; intros; split. +eassumption. +match goal with |- ?x=1 => change (x=1) with (0+x=1) end. +match goal with |- 0+1=1 => trivial end. +Qed. diff --git a/test-suite/success/dependentind.v b/test-suite/success/dependentind.v index 12ddbda84e..f5bb884d27 100644 --- a/test-suite/success/dependentind.v +++ b/test-suite/success/dependentind.v @@ -15,7 +15,7 @@ Proof. intros n H. dependent destruction H. assumption. -Save. +Qed. Require Import ProofIrrelevance. @@ -25,7 +25,7 @@ Proof. dependent destruction v. exists v ; exists a. reflexivity. -Save. +Qed. (* Extraction Unnamed_thm. *) diff --git a/test-suite/success/forward.v b/test-suite/success/forward.v new file mode 100644 index 0000000000..0ed5b524f3 --- /dev/null +++ b/test-suite/success/forward.v @@ -0,0 +1,18 @@ +(* Testing forward reasoning *) + +Goal 0=0. +Fail assert (_ = _). +eassert (_ = _)by reflexivity. +eassumption. +Qed. + +Goal 0=0. +Fail set (S ?[nl]). +eset (S ?[n]). +remember (S ?n) as x. +instantiate (n:=0). +Fail remember (S (S _)). +eremember (S (S ?[x])). +instantiate (x:=0). +reflexivity. +Qed. diff --git a/test-suite/success/specialize.v b/test-suite/success/specialize.v index fba05cd902..4b41a509e5 100644 --- a/test-suite/success/specialize.v +++ b/test-suite/success/specialize.v @@ -72,3 +72,11 @@ intros. specialize (H 1) as ->. reflexivity. Qed. + +(* A test from corn *) + +Goal (forall x y, x=0 -> y=0 -> True) -> True. +intros. +specialize (fun z => H 0 z eq_refl). +exact (H 0 eq_refl). +Qed. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in new file mode 100644 index 0000000000..fb064c495f --- /dev/null +++ b/tools/CoqMakefile.in @@ -0,0 +1,631 @@ +############################################################################### +## v # The Coq Proof Assistant ## +## <O___,, # INRIA - CNRS - LIX - LRI - PPS ## +## \VV/ # ## +## // # ## +############################################################################### +## GNUMakefile for Coq @COQ_VERSION@ + +# For debugging purposes (must stay here, don't move below) +INITIAL_VARS := $(.VARIABLES) +# To implement recursion we save the name of the main Makefile +SELF := $(lastword $(MAKEFILE_LIST)) + +# This file is generated by coq_makefile and contains many variable +# definitions, like the list of .v files or the path to Coq +include @CONF_FILE@ + +# Put in place old names +VFILES := $(COQMF_VFILES) +MLIFILES := $(COQMF_MLIFILES) +MLFILES := $(COQMF_MLFILES) +ML4FILES := $(COQMF_ML4FILES) +MLPACKFILES := $(COQMF_MLPACKFILES) +MLLIBFILES := $(COQMF_MLLIBFILES) +INSTALLCOQDOCROOT := $(COQMF_INSTALLCOQDOCROOT) +OTHERFLAGS := $(COQMF_OTHERFLAGS) +COQ_SRC_SUBDIRS := $(COQMF_COQ_SRC_SUBDIRS) +OCAMLLIBS := $(COQMF_OCAMLLIBS) +SRC_SUBDIRS := $(COQMF_SRC_SUBDIRS) +COQLIBS := $(COQMF_COQLIBS) +COQLIBS_NOML := $(COQMF_COQLIBS_NOML) +LOCAL := $(COQMF_LOCAL) +COQLIB := $(COQMF_COQLIB) +DOCDIR := $(COQMF_DOCDIR) +OCAMLFIND := $(COQMF_OCAMLFIND) +CAMLP4 := $(COQMF_CAMLP4) +CAMLP4O := $(COQMF_CAMLP4O) +CAMLP4BIN := $(COQMF_CAMLP4BIN) +CAMLP4LIB := $(COQMF_CAMLP4LIB) +CAMLP4OPTIONS := $(COQMF_CAMLP4OPTIONS) +HASNATDYNLINK := $(COQMF_HASNATDYNLINK) +COQ_SRC_SUBDIRS := $(COQMF_COQ_SRC_SUBDIRS) + +@CONF_FILE@: @PROJECT_FILE@ + @COQ_MAKEFILE_INVOCATION@ + +# This file can be created by the user to hook into double colon rules or +# add any other Makefile code he may need +-include @LOCAL_FILE@ + +# Parameters ################################################################## +# +# Parameters are make variable assignments. +# They can be passed to (each call to) make on the command line. +# They can also be put in @LOCAL_FILE@ once an forall. +# For retro-compatibility reasons they can be put in the _CoqProject, but this +# practice is discouraged since _CoqProject better not contain make specific +# code (be nice to user interfaces). + +# Print shell commands (set to non empty) +VERBOSE ?= + +# Time the Coq process (set to non empty), and how (see default value) +TIMED?= +TIMECMD?= +STDTIME?=/usr/bin/time -f "$* (user: %U mem: %M ko)" + +# Coq binaries +COQC ?= $(TIMER) "$(COQBIN)coqc" +COQCHK ?= $(TIMER) "$(COQBIN)coqchk" +COQDEP ?= "$(COQBIN)coqdep" +GALLINA ?= "$(COQBIN)gallina" +COQDOC ?= "$(COQBIN)coqdoc" +COQMKTOP ?= "$(COQBIN)coqmktop" + +# OCaml binaries +CAMLC ?= $(OCAMLFIND) ocamlc -c -rectypes -thread +CAMLOPTC ?= $(OCAMLFIND) opt -c -rectypes -thread +CAMLLINK ?= $(OCAMLFIND) ocamlc -rectypes -thread +CAMLOPTLINK ?= $(OCAMLFIND) opt -rectypes -thread +CAMLDEP ?= $(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack + +# DESTDIR is prepended to all installation paths +DESTDIR ?= + +# Debug builds, typically -g to OCaml, -debug to Coq. +CAMLDEBUG ?= +COQDEBUG ?= + + + +########## End of parameters ################################################## +# What follows may be relevant to you only if you need to +# extend this Makefile. If so, look for 'Extension point' here and +# put in @LOCAL_FILE@ double colon rules accordingly. +# E.g. to perform some work after the all target completes you can write +# +# post-all:: +# echo "All done!" +# +# in @LOCAL_FILE@ +# +############################################################################### + + + + +# Flags ####################################################################### +# +# We define a bunch of variables combining the parameters + +SHOW := $(if $(VERBOSE),@true "",@echo "") +HIDE := $(if $(VERBOSE),,@) + +TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) + +OPT?= + +COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) +COQCHKFLAGS?=-silent -o $(COQLIBS) +COQDOCFLAGS?=-interpolate -utf8 $(COQLIBS_NOML) + +# The version of Coq being run and the version of coq_makefile that +# generated this makefile +COQ_VERSION:=$(shell $(COQC) --print-version | cut -d ' ' -f 1) +COQMAKEFILE_VERSION:=@COQ_VERSION@ + +COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)$(d)") + +CAMLFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB) + +CAMLLIB:=$(shell $(OCAMLFIND) printconf stdlib) + +# FIXME This should be generated by Coq +GRAMMARS:=grammar.cma +ifeq ($(CAMLP4),camlp5) +CAMLP4EXTEND=pa_extend.cmo q_MLast.cmo pa_macro.cmo +else +CAMLP4EXTEND= +endif + +PP:=-pp '$(CAMLP4O) -I $(CAMLLIB) -I $(COQLIB)/grammar compat5.cmo $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl' + +COQLIBINSTALL = $(COQLIB)user-contrib +COQDOCINSTALL = $(DOCDIR)user-contrib +COQTOPINSTALL = $(COQLIB)toploop + +# Retro compatibility (DESTDIR is standard on Unix, DESTROOT is not) +ifneq "$(DSTROOT)" "" +DESTDIR := $(DSTROOT) +endif + +# Files ####################################################################### +# +# We here define a bunch of variables about the files being part of the +# Coq project in order to ease the writing of build target and build rules + +ALLSRCFILES := \ + $(VFILES) \ + $(ML4FILES) \ + $(MLFILES) \ + $(MLPACKFILES) \ + $(MLLIBFILES) \ + $(MLIFILES) + +# helpers +vo_to_obj = $(addsuffix .o,\ + $(filter-out Warning: Error:,\ + $(shell $(COQBIN)coqtop -q -noinit -batch -quiet -print-mod-uid $(1)))) +strip_dotslash = $(patsubst ./%,%,$(1)) +VO = vo + +VOFILES = $(VFILES:.v=.$(VO)) +GLOBFILES = $(VFILES:.v=.glob) +GFILES = $(VFILES:.v=.g) +HTMLFILES = $(VFILES:.v=.html) +GHTMLFILES = $(VFILES:.v=.g.html) +BEAUTYFILES = $(addsuffix .beautified,$(VFILES)) +TEXFILES = $(VFILES:.v=.tex) +GTEXFILES = $(VFILES:.v=.g.tex) +CMOFILES = \ + $(ML4FILES:.ml4=.cmo) \ + $(MLFILES:.ml=.cmo) \ + $(MLPACKFILES:.mlpack=.cmo) +CMXFILES = $(CMOFILES:.cmo=.cmx) +OFILES = $(CMXFILES:.cmx=.o) +CMAFILES = $(MLLIBFILES:.mllib=.cma) $(MLPACKFILES:.mlpack=.cma) +CMXAFILES = $(CMAFILES:.cma=.cmxa) +CMIFILES = \ + $(CMOFILES:.cmo=.cmi) \ + $(MLIFILES:.mli=.cmi) +# the /if/ is because old _CoqProject did not list a .ml(pack|lib) but just +# a .ml4 file +CMXSFILES = \ + $(MLPACKFILES:.mlpack=.cmxs) \ + $(CMXAFILES:.cmxa=.cmxs) \ + $(if $(MLPACKFILES)$(CMXAFILES),,\ + $(ML4FILES:.ml4=.cmxs) $(MLFILES:.ml=.cmxs)) + +# files that are packed into a plugin (no extension) +PACKEDFILES = \ + $(call strip_dotslash, \ + $(foreach lib, \ + $(call strip_dotslash, \ + $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES)),$($(lib)))) +# files that are archived into a .cma (mllib) +LIBEDFILES = \ + $(call strip_dotslash, \ + $(foreach lib, \ + $(call strip_dotslash, \ + $(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES)),$($(lib)))) +CMIFILESTOINSTALL = $(filter-out $(addsuffix .cmi,$(PACKEDFILES)),$(CMIFILES)) +CMOFILESTOINSTALL = $(filter-out $(addsuffix .cmo,$(PACKEDFILES)),$(CMOFILES)) +OBJFILES = $(call vo_to_obj,$(VOFILES)) +ALLNATIVEFILES = \ + $(OBJFILES:.o=.cmi) \ + $(OBJFILES:.o=.cmo) \ + $(OBJFILES:.o=.cmx) \ + $(OBJFILES:.o=.cmxs) +# trick: wildcard filters out non-existing files +NATIVEFILESTOINSTALL = $(foreach f, $(ALLNATIVEFILES), $(wildcard $f)) +FILESTOINSTALL = \ + $(VOFILES) \ + $(VFILES) \ + $(GLOBFILES) \ + $(NATIVEFILESTOINSTALL) \ + $(CMOFILESTOINSTALL) \ + $(CMIFILESTOINSTALL) \ + $(CMAFILES) +ifeq '$(HASNATDYNLINK)' 'true' +DO_NATDYNLINK = yes +FILESTOINSTALL += $(CMXSFILES) $(CMXAFILES) $(CMOFILESTOINSTALL:.cmo=.cmx) +else +DO_NATDYNLINK = +endif + +ALLDFILES = $(addsuffix .d,$(ALLSRCFILES)) + +# Compilation targets ######################################################### + +all: + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all +.PHONY: all + +# Extension points for actions to be performed before/after the all target +pre-all:: + @# Extension point + $(HIDE)if [ "$(COQMAKEFILE_VERSION)" != "$(COQ_VERSION)" ]; then\ + echo "W: This Makefile was generated by Coq $(COQMAKEFILE_VERSION)";\ + echo "W: while the current Coq version is $(COQ_VERSION)";\ + fi +.PHONY: pre-all + +post-all:: + @# Extension point +.PHONY: post-all + +real-all: $(VOFILES) $(CMOFILES) $(CMAFILES) $(if $(DO_NATDYNLINK),$(CMXSFILES)) +.PHONY: real-all + +# FIXME, see Ralph's bugreport +quick: $(VOFILES:.vo=.vio) +.PHONY: quick + +vio2vo: + $(COQC) $(COQDEBUG) $(COQFLAGS) \ + -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio) +.PHONY: vio2vo + +checkproofs: + $(COQC) $(COQDEBUG) $(COQFLAGS) \ + -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio) +.PHONY: checkproofs + +validate: $(VOFILES) + $(COQCHK) $(COQCHKFLAGS) $(notdir $(^:.vo=)) +.PHONY: validate + +only: $(TGTS) +.PHONY: only + +# Documentation targets ####################################################### + +html: $(GLOBFILES) $(VFILES) + $(SHOW)'COQDOC -d html $(GAL)' + $(HIDE)mkdir -p html + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -html $(GAL) $(COQDOCLIBS) -d html $(VFILES) + +mlihtml: $(MLIFILES:.mli=.cmi) + $(SHOW)'OCAMLDOC -d $@' + $(HIDE)mkdir $@ || rm -rf $@/* + $(HIDE)$(OCAMLFIND) ocamldoc -html -rectypes \ + -d $@ -m A $(CAMLDEBUG) $(CAMLFLAGS) $(MLIFILES) + +all-mli.tex: $(MLIFILES:.mli=.cmi) + $(SHOW)'OCAMLDOC -latex $@' + $(OCAMLFIND) ocamldoc -latex -rectypes \ + -o $@ -m A $(CAMLDEBUG) $(CAMLFLAGS) $(MLIFILES) + +gallina: $(GFILES) + +all.ps: $(VFILES) + $(SHOW)'COQDOC -ps $(GAL)' + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -ps $(GAL) $(COQDOCLIBS) \ + -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)` + +all.pdf: $(VFILES) + $(SHOW)'COQDOC -pdf $(GAL)' + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -pdf $(GAL) $(COQDOCLIBS) \ + -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)` + +# FIXME: not quite right, since the output name is different +gallinahtml: GAL=g +gallinahtml: html + +all-gal.ps: GAL=-g +all-gal.ps: all.ps + +all-gal.pdf: GAL=-g +all-gal.pdf: all.pdf + +# ? +beautify: $(BEAUTYFILES) + for file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done + @echo 'Do not do "make clean" until you are sure that everything went well!' + @echo 'If there were a problem, execute "for file in $$(find . -name \*.v.old -print); do mv $${file} $${file%.old}; done" in your shell/' +.PHONY: beautify + +# Installation targets ######################################################## +# +# There rules can be extended in @LOCAL_FILE@ +# Extensions can't assume when they run. + +install: install-extra + $(HIDE)for f in $(FILESTOINSTALL); do\ + df="`$(COQMF_MAKEFILE) -destination-of "$$f" $(COQLIBS)`";\ + if [ -z "$$df" ]; then\ + echo SKIP "$$f" since it has no logical path;\ + else\ + install -d "$(DESTDIR)$(COQLIBINSTALL)/$$df"; \ + install -m 0644 "$$f" "$(DESTDIR)$(COQLIBINSTALL)/$$df"; \ + echo INSTALL "$$f" "$(DESTDIR)$(COQLIBINSTALL)/$$df";\ + fi;\ + done +install-extra:: + @# Extension point +.PHONY: install install-extra + +install-doc:: html mlihtml + @# Extension point + $(HIDE)install -d "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" + $(HIDE)for i in html/*; do \ + dest="$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ + install -m 0644 "$$i" "$$dest";\ + echo INSTALL "$$i" "$$dest";\ + done + $(HIDE)install -d \ + "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" + $(HIDE)for i in mlihtml/*; do \ + dest="$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ + install -m 0644 "$$i" "$$dest";\ + echo INSTALL "$$i" "$$dest";\ + done +.PHONY: install-doc + +uninstall:: + @# Extension point + $(HIDE)for f in $(FILESTOINSTALL); do \ + df="`$(COQMF_MAKEFILE) -destination-of "$$f" $(COQLIBS)`";\ + instf="$(DESTDIR)$(COQLIBINSTALL)/$$df/`basename $$f`"; \ + rm -f "$$instf";\ + echo RM "$$instf"; \ + rmdir --ignore-fail-on-non-empty "$(DESTDIR)$(COQLIBINSTALL)/$$df/"; \ + done +.PHONY: uninstall + +uninstall-doc:: + @# Extension point + $(SHOW)'RM $(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html' + $(HIDE)rm -rf "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" + $(SHOW)'RM $(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml' + $(HIDE)rm -rf "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" + $(HIDE)rmdir --ignore-fail-on-non-empty \ + "$(DESTDIR)$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/" +.PHONY: uninstall-doc + +# Cleaning #################################################################### +# +# There rules can be extended in @LOCAL_FILE@ +# Extensions can't assume when they run. + +clean:: + @# Extension point + $(SHOW)'CLEAN' + $(HIDE)rm -f $(CMOFILES) + $(HIDE)rm -f $(CMIFILES) + $(HIDE)rm -f $(CMAFILES) + $(HIDE)rm -f $(CMOFILES:.cmo=.cmx) + $(HIDE)rm -f $(CMXAFILES) + $(HIDE)rm -f $(CMXSFILES) + $(HIDE)rm -f $(CMOFILES:.cmo=.o) + $(HIDE)rm -f $(CMXAFILES:.cmxa=.a) + $(HIDE)rm -f $(ALLDFILES) + $(HIDE)rm -f $(ALLNATIVEFILES) + $(HIDE)find . -name .coq-native -type d -empty -delete + $(HIDE)rm -f $(VOFILES) + $(HIDE)rm -f $(VOFILES:.vo=.vio) + $(HIDE)rm -f $(GFILES) + $(HIDE)rm -f $(BEAUTYFILES) $(VFILES:=.old) + $(HIDE)rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob all-mli.tex + $(HIDE)rm -f $(VFILES:.v=.glob) + $(HIDE)rm -f $(VFILES:.v=.tex) + $(HIDE)rm -f $(VFILES:.v=.g.tex) + $(HIDE)rm -rf html mlihtml +.PHONY: clean + +cleanall:: clean + @# Extension point + $(SHOW)'CLEAN *.aux' + $(HIDE)rm -f $(foreach f,$(VFILES:.v=),$(dir $(f)).$(notdir $(f)).aux) +.PHONY: cleanall + +archclean:: + @# Extension point + $(SHOW)'CLEAN *.cmx *.o' + $(HIDE)rm -f $(ALLNATIVEFILES) + $(HIDE)rm -f $(CMOFILES:%.cmo=%.cmx) +.PHONY: archclean + + +# Compilation rules ########################################################### + +$(MLIFILES:.mli=.cmi): %.cmi: %.mli + $(SHOW)'CAMLC -c $<' + $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $< + +$(ML4FILES:.ml4=.cmo): %.cmo: %.ml4 + $(SHOW)'CAMLC -pp -c $<' + $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(PP) -impl $< + +$(ML4FILES:.ml4=.cmx): %.cmx: %.ml4 + $(SHOW)'CAMLOPT -pp -c $(FOR_PACK) $<' + $(HIDE)$(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(PP) $(FOR_PACK) -impl $< + +$(MLFILES:.ml=.cmo): %.cmo: %.ml + $(SHOW)'CAMLC -c $<' + $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $< + +$(MLFILES:.ml=.cmx): %.cmx: %.ml + $(SHOW)'CAMLOPT -c $(FOR_PACK) $<' + $(HIDE)$(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(FOR_PACK) $< + + +$(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa + $(SHOW)'CAMLOPT -shared -o $@' + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) \ + -linkall -shared -o $@ $< + +$(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib + $(SHOW)'CAMLC -a -o $@' + $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ + +$(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib + $(SHOW)'CAMLOPT -a -o $@' + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ + + +$(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmx + $(SHOW)'CAMLOPT -shared -o $@' + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -shared -o $@ $< + +$(MLPACKFILES:.mlpack=.cma): %.cma: %.cmo | %.mlpack + $(SHOW)'CAMLC -a -o $@' + $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ + +$(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack + $(SHOW)'CAMLC -pack -o $@' + $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ + +$(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack + $(SHOW)'CAMLOPT -pack -o $@' + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ + +# This rule is for _CoqProject with no .mllib nor .mlpack +$(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(ML4FILES:.ml4=.cmxs)): %.cmxs: %.cmx + $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -shared -o $@ $< + +$(VOFILES): %.vo: %.v + $(SHOW)COQC $< + $(HIDE)$(COQC) $(COQDEBUG) $(COQFLAGS) $< + +# FIXME ?merge with .vo / .vio ? +$(GLOBFILES): %.glob: %.v + $(COQC) $(COQDEBUG) $(COQFLAGS) $< + +$(VFILES:.v=.vio): %.vio: %.v + $(SHOW)COQC -quick $< + $(HIDE)$(COQC) -quick $(COQDEBUG) $(COQFLAGS) $< + +$(BEAUTYFILES): %.v.beautified: %.v + $(SHOW)'BEAUTIFY $<' + $(HIDE)$(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $< + +$(GFILES): %.g: %.v + $(SHOW)'GALLINA $<' + $(HIDE)$(GALLINA) $< + +$(TEXFILES): %.tex: %.v + $(SHOW)'COQDOC -latex $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ + +$(GTEXFILES): %.g.tex: %.v + $(SHOW)'COQDOC -latex -g $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ + +$(HTMLFILES): %.html: %.v %.glob + $(SHOW)'COQDOC -html $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html $< -o $@ + +$(GHTMLFILES): %.g.html: %.v %.glob + $(SHOW)'COQDOC -html -g $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@ + +# Dependency files ############################################################ + +ifneq ($(filter-out archclean clean cleanall printenv,$(MAKECMDGOALS)),) + -include $(ALLDFILES) +else + ifeq ($(MAKECMDGOALS),) + -include $(ALLDFILES) + endif +endif + +.SECONDARY: $(ALLDFILES) + +redir_if_ok = > "$@" || ( RV=$$?; rm -f "$@"; exit $$RV ) + +$(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(ML4FILES)): %.ml4.d: %.ml4 + $(SHOW)'CAMLDEP -pp $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) $(PP) -impl "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLFILES)): %.ml.d: %.ml + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib + $(SHOW)'COQDEP $<' + $(HIDE)$(COQDEP) $(OCAMLLIBS) -c "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack + $(SHOW)'COQDEP $<' + $(HIDE)$(COQDEP) $(OCAMLLIBS) -c "$<" $(redir_if_ok) + +$(addsuffix .d,$(VFILES)): %.v.d: %.v + $(SHOW)'COQDEP $<' + $(HIDE)$(COQDEP) $(COQLIBS) -c "$<" $(redir_if_ok) + +# Misc ######################################################################## + +byte: + $(HIDE)$(MAKE) all "OPT:=-byte" -f "$(SELF)" +.PHONY: byte + +opt: + $(HIDE)$(MAKE) all "OPT:=-opt" -f "$(SELF)" +.PHONY: opt + +# This is deprecated. To extend this makefile use +# extension points and @LOCAL_FILE@ +printenv:: + $(warning printenv is deprecated) + $(warning write extensions in @LOCAL_FILE@ or include @CONF_FILE@) + @echo 'LOCAL = $(LOCAL)' + @echo 'COQLIB = $(COQLIB)' + @echo 'DOCDIR = $(DOCDIR)' + @echo 'OCAMLFIND = $(OCAMLFIND)' + @echo 'CAMLP4 = $(CAMLP4)' + @echo 'CAMLP4O = $(CAMLP4O)' + @echo 'CAMLP4BIN = $(CAMLP4BIN)' + @echo 'CAMLP4LIB = $(CAMLP4LIB)' + @echo 'CAMLP4OPTIONS = $(CAMLP4OPTIONS)' + @echo 'HASNATDYNLINK = $(HASNATDYNLINK)' + @echo 'SRC_SUBDIRS = $(SRC_SUBDIRS)' + @echo 'COQ_SRC_SUBDIRS = $(COQ_SRC_SUBDIRS)' + @echo 'OCAMLFIND = $(OCAMLFIND)' + @echo 'PP = $(PP)' + @echo 'COQFLAGS = $(COQFLAGS)' + @echo 'COQLIBINSTALL = $(COQLIBINSTALL)' + @echo 'COQDOCINSTALL = $(COQDOCINSTALL)' +.PHONY: printenv + +# Generate a .merlin file. If you need to append directives to this +# file you can extend the merlin-hook target in @LOCAL_FILE@ +.merlin: + $(SHOW)'FILL .merlin' + $(HIDE)echo 'FLG -rectypes' > .merlin + $(HIDE)echo "B $(COQLIB)" >> .merlin + $(HIDE)echo "S $(COQLIB)" >> .merlin + $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ + echo "B $(COQLIB)$(d)" >> .merlin;) + $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ + echo "S $(COQLIB)$(d)" >> .merlin;) + $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo "B $(d)" >> .merlin;) + $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo "S $(d)" >> .merlin;) + $(HIDE)$(MAKE) merlin-hook -f "$(SELF)" +.PHONY: merlin + +merlin-hook:: + @# Extension point +.PHONY: merlin-hook + +# prints all variables +debug: + $(foreach v,\ + $(sort $(filter-out $(INITIAL_VARS) INITIAL_VARS,\ + $(.VARIABLES))),\ + $(info $(v) = $($(v)))) +.PHONY: debug + +.DEFAULT_GOAL := all + diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 4875cb62bf..8e2f75fc9c 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -8,17 +8,13 @@ (* Coq_makefile: automatically create a Makefile for a Coq development *) +open CoqProject_file +open Printf + let output_channel = ref stdout let makefile_name = ref "Makefile" let make_name = ref "" -let some_vfile = ref false -let some_mlfile = ref false -let some_mlifile = ref false -let some_ml4file = ref false -let some_mllibfile = ref false -let some_mlpackfile = ref false - let print x = output_string !output_channel x let printf x = Printf.fprintf !output_channel x @@ -31,29 +27,10 @@ let rec print_prefix_list sep = function | x :: l -> print sep; print x; print_prefix_list sep l | [] -> () -let section s = - let l = String.length s in - let print_com s = - print "#"; - print s; - print "#\n" in - print_com (String.make (l+2) '#'); - print_com (String.make (l+2) ' '); - print "# "; print s; print " #\n"; - print_com (String.make (l+2) ' '); - print_com (String.make (l+2) '#'); - print "\n" - (* These are the Coq library directories that are used for * plugin development *) -let lib_dirs = - ["kernel"; "lib"; "library"; "parsing"; - "pretyping"; "interp"; "printing"; "intf"; - "proofs"; "tactics"; "tools"; - "vernac"; "stm"; "toplevel"; "grammar"; "config"; - "engine"] - +let lib_dirs = Envars.coq_src_subdirs let usage () = output_string stderr "Usage summary:\ @@ -104,12 +81,6 @@ let is_genrule r = (* generic rule (like bar%foo: ...) *) let genrule = Str.regexp("%") in Str.string_match genrule r 0 -let string_prefix a b = - let rec aux i = - try if a.[i] = b.[i] then aux (i+1) else i with Invalid_argument _ -> i - in - String.sub a 0 (aux 0) - let is_prefix dir1 dir2 = let l1 = String.length dir1 in let l2 = String.length dir2 in @@ -122,830 +93,335 @@ let is_prefix dir1 dir2 = else false let physical_dir_of_logical_dir ldir = - let le = String.length ldir - 1 in + let ldir = Bytes.of_string ldir in + let le = Bytes.length ldir - 1 in let pdir = - if le >= 0 && ldir.[le] = '.' then String.sub ldir 0 (le - 1) - else ldir - in - String.map (fun c -> if c = '.' then '/' else c) pdir - -let standard opt = - print "byte:\n"; - print "\t$(MAKE) all \"OPT:=-byte\"\n\n"; - print "opt:\n"; - if not opt then print "\t@echo \"WARNING: opt is disabled\"\n"; - print "\t$(MAKE) all \"OPT:="; print (if opt then "-opt" else "-byte"); - print "\"\n\n" - -let classify_files_by_root var files (inc_ml,inc_i,inc_r) = - if List.exists (fun (pdir,_,_) -> pdir = ".") inc_r || - List.exists (fun (pdir,_,_) -> pdir = ".") inc_i - then () - else - let absdir_of_files =List.rev_map - (fun x -> CUnix.canonical_path_name (Filename.dirname x)) - files - in - (* files in scope of a -I option (assuming they are no overlapping) *) - if List.exists (fun (_,a) -> List.mem a absdir_of_files) inc_ml then - begin - printf "%sINC=" var; - List.iter (fun (pdir,absdir) -> - if List.mem absdir absdir_of_files - then printf "$(filter $(wildcard %s/*),$(%s)) " pdir var) - inc_ml; - printf "\n"; - end; - (* Files in the scope of a -R option (assuming they are disjoint) *) - List.iteri (fun i (pdir,_,abspdir) -> - if List.exists (is_prefix abspdir) absdir_of_files then - printf "%s%d=$(patsubst %s/%%,%%,$(filter %s/%%,$(%s)))\n" - var i pdir pdir var) - (inc_i@inc_r) - -let vars_to_put_by_root var_x_files_l (inc_ml,inc_i,inc_r) = - let var_x_absdirs_l = - List.rev_map - (fun (v,l) -> - (v,List.rev_map - (fun x -> CUnix.canonical_path_name (Filename.dirname x)) l)) - var_x_files_l + if le >= 0 && Bytes.get ldir le = '.' then Bytes.sub ldir 0 (le - 1) + else Bytes.copy ldir in - let var_filter f g = - List.fold_left - (fun acc (var,dirs) -> if f dirs then (g var)::acc else acc) - [] var_x_absdirs_l - in - (* All files caught by a -R . option (assuming it is the only one) *) - match inc_i@inc_r with - |[(".",t,_)] -> - (None,[".",physical_dir_of_logical_dir t,List.rev_map fst var_x_files_l]) - |l -> - try - let out = List.assoc "." (List.rev_map (fun (p,l,_) -> (p,l)) l) in - let () = prerr_string "Warning: install rule assumes that -R/-Q . _ is the only -R/-Q option\n" - in - (None,[".",physical_dir_of_logical_dir out,List.rev_map fst var_x_files_l]) - with Not_found -> - (* vars for -Q options *) - let varq = var_filter - (fun l -> List.exists (fun (_,a) -> List.mem a l) inc_ml) - (fun x -> x) - in - (* (physical dir, physical dir of logical path,vars) for -R options - (assuming physical dirs are disjoint) *) - let other = - if l = [] then - [".","$(INSTALLDEFAULTROOT)",[]] - else - Util.List.fold_left_i (fun i out (pdir,ldir,abspdir) -> - let vars_r = var_filter - (List.exists (is_prefix abspdir)) - (fun x -> x^string_of_int i) - in - let pdir' = physical_dir_of_logical_dir ldir in - (pdir,pdir',vars_r)::out) 0 [] l - in (Some varq, other) - -let install_include_by_root perms = - let install_dir for_i (pdir,pdir',vars) = - let b = vars <> [] in - if b then begin - printf "\tcd \"%s\" && for i in " pdir; - print_list " " (List.rev_map (Format.sprintf "$(%s)") vars); - print "; do \\\n"; - printf "\t install -d \"`dirname \"$(DSTROOT)\"$(COQLIBINSTALL)/%s/$$i`\"; \\\n" pdir'; - printf "\t install -m %s $$i \"$(DSTROOT)\"$(COQLIBINSTALL)/%s/$$i; \\\n" perms pdir'; - printf "\tdone\n"; - end; - for_i b pdir' in - let install_i = function - |[] -> fun _ _ -> () - |l -> fun b d -> - if not b then printf "\tinstall -d \"$(DSTROOT)\"$(COQLIBINSTALL)/%s; \\\n" d; - print "\tfor i in "; - print_list " " (List.rev_map (Format.sprintf "$(%sINC)") l); - print "; do \\\n"; - printf "\t install -m %s $$i \"$(DSTROOT)\"$(COQLIBINSTALL)/%s/`basename $$i`; \\\n" perms d; - printf "\tdone\n" - in function - |None,l -> List.iter (install_dir (fun _ _ -> ())) l - |Some v_i,l -> List.iter (install_dir (install_i v_i)) l - -let uninstall_by_root = - let uninstall_dir for_i (pdir,pdir',vars) = - printf "\tprintf 'cd \"$${DSTROOT}\"$(COQLIBINSTALL)/%s" pdir'; - if vars <> [] then begin - print " && rm -f "; - print_list " " (List.rev_map (Format.sprintf "$(%s)") vars); - end; - for_i (); - print " && find . -type d -and -empty -delete\\n"; - print "cd \"$${DSTROOT}\"$(COQLIBINSTALL) && "; - printf "find \"%s\" -maxdepth 0 -and -empty -exec rmdir -p \\{\\} \\;\\n' >> \"$@\"\n" pdir' -in - let uninstall_i = function - |[] -> () - |l -> - print " && \\\\\\nfor i in "; - print_list " " (List.rev_map (Format.sprintf "$(%sINC)") l); - print "; do rm -f \"`basename \"$$i\"`\"; done" - in function - |None,l -> List.iter (uninstall_dir (fun _ -> ())) l - |Some v_i,l -> List.iter (uninstall_dir (fun () -> uninstall_i v_i)) l - -let where_put_doc = function - |_,[],[] -> "$(INSTALLDEFAULTROOT)"; - |_,((_,lp,_)::q as inc_i),[] -> - let pr = List.fold_left (fun a (_,b,_) -> string_prefix a b) lp q in - if (pr <> "") && - ((List.exists (fun(_,b,_) -> b = pr) inc_i) - || pr.[String.length pr - 1] = '.') - then - physical_dir_of_logical_dir pr - else - let () = prerr_string ("Warning: -Q options don't have a correct common prefix," - ^ " install-doc will put anything in $INSTALLDEFAULTROOT\n") in - "$(INSTALLDEFAULTROOT)" - |_,inc_i,((_,lp,_)::q as inc_r) -> - let pr = List.fold_left (fun a (_,b,_) -> string_prefix a b) lp q in - let pr = List.fold_left (fun a (_,b,_) -> string_prefix a b) pr inc_i in - if (pr <> "") && - ((List.exists (fun(_,b,_) -> b = pr) inc_r) - || (List.exists (fun(_,b,_) -> b = pr) inc_i) - || pr.[String.length pr - 1] = '.') - then - physical_dir_of_logical_dir pr - else - let () = prerr_string ("Warning: -R/-Q options don't have a correct common prefix," - ^ " install-doc will put anything in $INSTALLDEFAULTROOT\n") in - "$(INSTALLDEFAULTROOT)" - -let install (vfiles,(mlis,ml4s,mls,mllibs,mlpacks),_,sds) inc = function - |Project_file.NoInstall -> () - |is_install -> - let not_empty = function |[] -> false |_::_ -> true in - let cmos = List.rev_append mlpacks (List.rev_append mls ml4s) in - let cmis = List.rev_append mlis cmos in - let cmxss = List.rev_append cmos mllibs in - let where_what_cmxs = vars_to_put_by_root [("CMXSFILES",cmxss)] inc in - let where_what_oth = vars_to_put_by_root - [("VOFILES",vfiles);("VFILES",vfiles); - ("GLOBFILES",vfiles);("NATIVEFILES",vfiles); - ("CMOFILES",cmos);("CMIFILES",cmis);("CMAFILES",mllibs)] - inc in - let doc_dir = where_put_doc inc in - if is_install = Project_file.UnspecInstall then begin - print "userinstall:\n\t+$(MAKE) USERINSTALL=true install\n\n" - end; - if not_empty cmxss then begin - print "install-natdynlink:\n"; - install_include_by_root "0755" where_what_cmxs; - print "\n"; + for i = 0 to le - 1 do + if Bytes.get pdir i = '.' then Bytes.set pdir i '/'; + done; + Bytes.to_string pdir + +let read_whole_file s = + let ic = open_in s in + let b = Buffer.create (1 lsl 12) in + try + while true do + let s = input_line ic in + Buffer.add_string b s; + Buffer.add_char b '\n'; + done; + assert false; + with End_of_file -> + close_in ic; + Buffer.contents b + +let makefile_template = + let template = "/tools/CoqMakefile.in" in + Coq_config.coqlib ^ template + +let quote s = if String.contains s ' ' then "\"" ^ s ^ "\"" else s + +let generate_makefile oc conf_file local_file args project = + let s = read_whole_file makefile_template in + let s = List.fold_left + (fun s (k,v) -> Str.global_replace (Str.regexp_string k) v s) s + [ "@CONF_FILE@", conf_file; + "@LOCAL_FILE@", local_file; + "@COQ_VERSION@", Coq_config.version; + "@PROJECT_FILE@", (Option.default "" project.project_file); + "@COQ_MAKEFILE_INVOCATION@",String.concat " " (List.map quote args); + ] in + output_string oc s +;; + +let section oc s = + let pad = String.make (76 - String.length s) ' ' in + let sharps = String.make 79 '#' in + let spaces = "#" ^ String.make 77 ' ' ^ "#" in + fprintf oc "\n%s\n" sharps; + fprintf oc "%s\n" spaces; + fprintf oc "# %s%s#\n" s pad; + fprintf oc "%s\n" spaces; + fprintf oc "%s\n\n" sharps +;; + +let clean_tgts = ["clean"; "cleanall"; "archclean"] + +let generate_conf_extra_target oc sps = + let pr_path { target; dependencies; phony; command } = + let target = if target = "all" then "custom-all" else target in + if phony then fprintf oc ".PHONY: %s\n" target; + if not (is_genrule target) && not phony then begin + fprintf oc "post-all::\n\t$(MAKE) -f $(SELF) %s\n" target; + if not phony then + fprintf oc "clean::\n\trm -f %s\n" target; end; - if not_empty cmxss then begin - print "install-toploop: $(MLLIBFILES:.mllib=.cmxs)\n"; - printf "\t install -d \"$(DSTROOT)\"$(COQTOPINSTALL)/\n"; - printf "\t install -m 0755 $? \"$(DSTROOT)\"$(COQTOPINSTALL)/\n"; - print "\n"; - end; - print "install:"; - if not_empty cmxss then begin - print "$(if $(HASNATDYNLINK_OR_EMPTY),install-natdynlink)"; - end; - print "\n"; - install_include_by_root "0644" where_what_oth; - List.iter - (fun x -> - printf "\t+cd %s && $(MAKE) DSTROOT=\"$(DSTROOT)\" INSTALLDEFAULTROOT=\"$(INSTALLDEFAULTROOT)/%s\" install\n" x x) - sds; - print "\n"; - let install_one_kind kind dir = - printf "\tinstall -d \"$(DSTROOT)\"$(COQDOCINSTALL)/%s/%s\n" dir kind; - printf "\tfor i in %s/*; do \\\n" kind; - printf "\t install -m 0644 $$i \"$(DSTROOT)\"$(COQDOCINSTALL)/%s/$$i;\\\n" dir; - print "\tdone\n" in - print "install-doc:\n"; - if not_empty vfiles then install_one_kind "html" doc_dir; - if not_empty mlis then install_one_kind "mlihtml" doc_dir; - print "\n"; - let uninstall_one_kind kind dir = - printf "\tprintf 'cd \"$${DSTROOT}\"$(COQDOCINSTALL)/%s \\\\\\n' >> \"$@\"\n" dir; - printf "\tprintf '&& rm -f $(shell find \"%s\" -maxdepth 1 -and -type f -print)\\n' >> \"$@\"\n" kind; - print "\tprintf 'cd \"$${DSTROOT}\"$(COQDOCINSTALL) && "; - printf "find %s/%s -maxdepth 0 -and -empty -exec rmdir -p \\{\\} \\;\\n' >> \"$@\"\n" dir kind - in - printf "uninstall_me.sh: %s\n" !makefile_name; - print "\techo '#!/bin/sh' > $@\n"; - if not_empty cmxss then uninstall_by_root where_what_cmxs; - uninstall_by_root where_what_oth; - if not_empty vfiles then uninstall_one_kind "html" doc_dir; - if not_empty mlis then uninstall_one_kind "mlihtml" doc_dir; - print "\tchmod +x $@\n"; - print "\n"; - print "uninstall: uninstall_me.sh\n"; - print "\tsh $<\n\n" - -let make_makefile sds = - if !make_name <> "" then begin - printf "%s: %s\n" !makefile_name !make_name; - print "\tmv -f $@ $@.bak\n"; - print "\t\"$(COQBIN)coq_makefile\" -f $< -o $@\n\n"; - List.iter - (fun x -> print "\t+cd "; print x; print " && $(MAKE) Makefile\n") - sds; - print "\n"; - end - -let clean sds sps = - print "clean::\n"; - if !some_mlfile || !some_mlifile || !some_ml4file - || !some_mllibfile || !some_mlpackfile - then - begin - print "\trm -f $(ALLCMOFILES) $(CMIFILES) $(CMAFILES)\n"; - print "\trm -f $(ALLCMOFILES:.cmo=.cmx) $(CMXAFILES) $(CMXSFILES) $(ALLCMOFILES:.cmo=.o) $(CMXAFILES:.cmxa=.a)\n"; - print "\trm -f $(addsuffix .d,$(MLFILES) $(MLIFILES) $(ML4FILES) $(MLLIBFILES) $(MLPACKFILES))\n"; - end; - if !some_vfile then - begin - print "\trm -f $(OBJFILES) $(OBJFILES:.o=.native) $(NATIVEFILES)\n"; - print "\tfind . -name .coq-native -type d -empty -delete\n"; - print "\trm -f $(VOFILES) $(VOFILES:.vo=.vio) $(GFILES) $(VFILES:.v=.v.d) $(VFILES:=.beautified) $(VFILES:=.old)\n" - end; - print "\trm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) all-mli.tex\n"; - print "\t- rm -rf html mlihtml uninstall_me.sh\n"; - List.iter - (fun (file,_,is_phony,_) -> - if not (is_phony || is_genrule file) then - (print "\t- rm -rf "; print file; print "\n")) - sps; - List.iter - (fun x -> print "\t+cd "; print x; print " && $(MAKE) clean\n") - sds; - print "\n"; - let () = - if !some_vfile then - let () = print "cleanall:: clean\n" in - print "\trm -f $(foreach f,$(VFILES:.v=),$(dir $(f)).$(notdir $(f)).aux)\n\n" in - print "archclean::\n"; - print "\trm -f *.cmx *.o\n"; - List.iter - (fun x -> print "\t+cd "; print x; print " && $(MAKE) archclean\n") - sds; - print "\n"; - print "printenv:\n\t@\"$(COQBIN)coqtop\" -config\n"; - print "\t@echo 'OCAMLFIND =\t$(OCAMLFIND)'\n\t@echo 'PP =\t$(PP)'\n\t@echo 'COQFLAGS =\t$(COQFLAGS)'\n"; - print "\t@echo 'COQLIBINSTALL =\t$(COQLIBINSTALL)'\n\t@echo 'COQDOCINSTALL =\t$(COQDOCINSTALL)'\n\n" - -let header_includes () = () - -let implicit () = - section "Implicit rules."; - let mli_rules () = - print "$(MLIFILES:.mli=.cmi): %.cmi: %.mli\n"; - print "\t$(SHOW)'CAMLC -c $<'\n"; - print "\t$(HIDE)$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; - print "$(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli\n"; - print "\t$(SHOW)'CAMLDEP $<'\n"; - print "\t$(HIDE)$(CAMLDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" - in - let ml4_rules () = - print "$(ML4FILES:.ml4=.cmo): %.cmo: %.ml4\n"; - print "\t$(SHOW)'CAMLC -pp -c $<'\n"; - print "\t$(HIDE)$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; - print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(ML4FILES:.ml4=.cmx)): %.cmx: %.ml4\n"; - print "\t$(SHOW)'CAMLOPT -pp -c $<'\n"; - print "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; - print "$(addsuffix .d,$(ML4FILES)): %.ml4.d: %.ml4\n"; - print "\t$(SHOW)'CAMLDEP -pp $<'\n"; - print "\t$(HIDE)$(CAMLDEP) $(OCAMLLIBS) $(PP) -impl \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in - let ml_rules () = - print "$(MLFILES:.ml=.cmo): %.cmo: %.ml\n"; - print "\t$(SHOW)'CAMLC -c $<'\n"; - print "\t$(HIDE)$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; - print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(MLFILES:.ml=.cmx)): %.cmx: %.ml\n"; - print "\t$(SHOW)'CAMLOPT -c $<'\n"; - print "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; - print "$(addsuffix .d,$(MLFILES)): %.ml.d: %.ml\n"; - print "\t$(SHOW)'CAMLDEP $<'\n"; - print "\t$(HIDE)$(CAMLDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in - let cmxs_rules () = (* order is important here when there is foo.ml and foo.mllib *) - print "$(filter-out $(MLLIBFILES:.mllib=.cmxs),$(MLFILES:.ml=.cmxs) $(ML4FILES:.ml4=.cmxs) $(MLPACKFILES:.mlpack=.cmxs)): %.cmxs: %.cmx\n"; - print "\t$(SHOW)'CAMLOPT -shared -o $@'\n"; - print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $<\n\n"; - print "$(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa\n"; - print "\t$(SHOW)'CAMLOPT -shared -o $@'\n"; - print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -linkall -shared -o $@ $<\n\n" - in - let mllib_rules () = - print "$(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib\n"; - print "\t$(SHOW)'CAMLC -a -o $@'\n"; - print "\t$(HIDE)$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n"; - print "$(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib\n"; - print "\t$(SHOW)'CAMLOPT -a -o $@'\n"; - print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n"; - print "$(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib\n"; - print "\t$(SHOW)'COQDEP $<'\n"; - print "\t$(HIDE)$(COQDEP) $(OCAMLLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" - in - let mlpack_rules () = - print "$(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack\n"; - print "\t$(SHOW)'CAMLC -pack -o $@'\n"; - print "\t$(HIDE)$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n"; - print "$(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack\n"; - print "\t$(SHOW)'CAMLOPT -pack -o $@'\n"; - print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n"; - print "$(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack\n"; - print "\t$(SHOW)'COQDEP $<'\n"; - print "\t$(HIDE)$(COQDEP) $(OCAMLLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" - in - let v_rules () = - print "$(VOFILES): %.vo: %.v\n"; - print "\t$(SHOW)COQC $<\n"; - print "\t$(HIDE)$(COQC) $(COQDEBUG) $(COQFLAGS) $<\n\n"; - print "$(GLOBFILES): %.glob: %.v\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $<\n\n"; - print "$(VFILES:.v=.vio): %.vio: %.v\n\t$(COQC) -quick $(COQDEBUG) $(COQFLAGS) $<\n\n"; - print "$(GFILES): %.g: %.v\n\t$(GALLINA) $<\n\n"; - print "$(VFILES:.v=.tex): %.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@\n\n"; - print "$(HTMLFILES): %.html: %.v %.glob\n\t$(COQDOC) $(COQDOCFLAGS) -html $< -o $@\n\n"; - print "$(VFILES:.v=.g.tex): %.g.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@\n\n"; - print "$(GHTMLFILES): %.g.html: %.v %.glob\n\t$(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@\n\n"; - print "$(addsuffix .d,$(VFILES)): %.v.d: %.v\n"; - print "\t$(SHOW)'COQDEP $<'\n"; - print "\t$(HIDE)$(COQDEP) $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"; - print "$(addsuffix .beautified,$(VFILES)): %.v.beautified:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $*.v\n\n" - in - if !some_mlifile then mli_rules (); - if !some_ml4file then ml4_rules (); - if !some_mlfile then ml_rules (); - if !some_mlfile || !some_ml4file then cmxs_rules (); - if !some_mllibfile then mllib_rules (); - if !some_mlpackfile then mlpack_rules (); - if !some_vfile then v_rules () - -let variables is_install opt (args,defs) = - let var_aux (v,def) = print v; print "="; print def; print "\n" in - section "Variables definitions."; - List.iter var_aux defs; - print "\n"; - if not opt then - print "override OPT:=-byte\n" - else - print "OPT?=\n"; - begin - match args with - |[] -> () - |h::t -> print "OTHERFLAGS="; - print h; - List.iter (fun s -> print " ";print s) t; - print "\n"; - end; - (* Coq executables and relative variables *) - if !some_vfile || !some_mlpackfile || !some_mllibfile then - print "COQDEP?=\"$(COQBIN)coqdep\" -c\n"; - if !some_vfile then begin - print "COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)\n"; - print "COQCHKFLAGS?=-silent -o\n"; - print "COQDOCFLAGS?=-interpolate -utf8\n"; - print "COQC?=$(TIMER) \"$(COQBIN)coqc\"\n"; - print "GALLINA?=\"$(COQBIN)gallina\"\n"; - print "COQDOC?=\"$(COQBIN)coqdoc\"\n"; - print "COQCHK?=\"$(COQBIN)coqchk\"\n"; - print "COQMKTOP?=\"$(COQBIN)coqmktop\"\n\n"; - end; - (* Caml executables and relative variables *) - if !some_ml4file || !some_mlfile || !some_mlifile then begin - print "COQSRCLIBS?=" ; - List.iter (fun c -> print "-I \"$(COQLIB)"; print c ; print "\" \\\n") lib_dirs ; - List.iter (fun c -> print " \\\ -\n -I \"$(COQLIB)/"; print c; print "\"") Coq_config.plugins_dirs; print "\n"; - print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n\n"; - print "CAMLC?=$(OCAMLFIND) ocamlc -c -rectypes -thread -safe-string\n"; - print "CAMLOPTC?=$(OCAMLFIND) opt -c -rectypes -thread -safe-string\n"; - print "CAMLLINK?=$(OCAMLFIND) ocamlc -rectypes -thread -safe-string\n"; - print "CAMLOPTLINK?=$(OCAMLFIND) opt -rectypes -thread -safe-string\n"; - print "CAMLDEP?=$(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack\n"; - print "CAMLLIB?=$(shell $(OCAMLFIND) printconf stdlib)\n"; - print "GRAMMARS?=grammar.cma\n"; - print "CAMLP4EXTEND=pa_extend.cmo q_MLast.cmo pa_macro.cmo\n"; - print "PP?=-pp '$(CAMLP4O) -I $(CAMLLIB) -I $(COQLIB)/grammar compat5.cmo \\\ -\n $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl'\n\n"; - end; - match is_install with - | Project_file.NoInstall -> () - | Project_file.UnspecInstall -> - section "Install Paths."; - print "ifdef USERINSTALL\n"; - print "XDG_DATA_HOME?=\"$(HOME)/.local/share\"\n"; - print "COQLIBINSTALL=$(XDG_DATA_HOME)/coq\n"; - print "COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq\n"; - print "else\n"; - print "COQLIBINSTALL=\"${COQLIB}user-contrib\"\n"; - print "COQDOCINSTALL=\"${DOCDIR}user-contrib\"\n"; - print "COQTOPINSTALL=\"${COQLIB}toploop\"\n"; - print "endif\n\n" - | Project_file.TraditionalInstall -> - section "Install Paths."; - print "COQLIBINSTALL=\"${COQLIB}user-contrib\"\n"; - print "COQDOCINSTALL=\"${DOCDIR}user-contrib\"\n"; - print "COQTOPINSTALL=\"${COQLIB}toploop\"\n"; - print "\n" - | Project_file.UserInstall -> - section "Install Paths."; - print "XDG_DATA_HOME?=\"$(HOME)/.local/share\"\n"; - print "COQLIBINSTALL=$(XDG_DATA_HOME)/coq\n"; - print "COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq\n"; - print "COQTOPINSTALL=$(XDG_DATA_HOME)/coq/toploop\n"; - print "\n" - -let parameters () = - print ".DEFAULT_GOAL := all\n\n"; - print "# This Makefile may take arguments passed as environment variables:\n"; - print "# COQBIN to specify the directory where Coq binaries resides;\n"; - print "# TIMECMD set a command to log .v compilation time;\n"; - print "# TIMED if non empty, use the default time command as TIMECMD;\n"; - print "# ZDEBUG/COQDEBUG to specify debug flags for ocamlc&ocamlopt/coqc;\n"; - print "# DSTROOT to specify a prefix to install path.\n"; - print "# VERBOSE to disable the short display of compilation rules.\n\n"; - print "VERBOSE?=\n"; - print "SHOW := $(if $(VERBOSE),@true \"\",@echo \"\")\n"; - print "HIDE := $(if $(VERBOSE),,@)\n\n"; - print "# Here is a hack to make $(eval $(shell works:\n"; - print "define donewline\n\n\nendef\n"; - print "includecmdwithout@ = $(eval $(subst @,$(donewline),$(shell { $(1) | tr -d '\\r' | tr '\\n' '@'; })))\n"; - print "$(call includecmdwithout@,$(COQBIN)coqtop -config)\n\n"; - print "TIMED?=\nTIMECMD?=\nSTDTIME?=/usr/bin/time -f \"$* (user: %U mem: %M ko)\"\n"; - print "TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD))\n\n"; - print "vo_to_obj = $(addsuffix .o,\\\n"; - print " $(filter-out Warning: Error:,\\\n"; - print " $(shell $(COQBIN)coqtop -q -noinit -batch -quiet -print-mod-uid $(1))))\n\n" - -let include_dirs (inc_ml,inc_q,inc_r) = - let parse_ml_includes l = List.map (fun (x,_) -> "-I \"" ^ x ^ "\"") l in - let includes = - List.map (fun (p,l,_) -> - let l' = if l = "" then "\"\"" else l in - " \"" ^ p ^ "\" " ^ l' ^"") in - let str_ml = parse_ml_includes inc_ml in - section "Libraries definitions."; - if !some_ml4file || !some_mlfile || !some_mlifile then begin - print "OCAMLLIBS?="; print_list "\\\n " str_ml; print "\n"; - end; - if !some_vfile || !some_mllibfile || !some_mlpackfile then begin - print "COQLIBS?="; - print_prefix_list "\\\n -Q" (includes inc_q); - print_prefix_list "\\\n -R" (includes inc_r); - print_prefix_list "\\\n " str_ml; - print "\n"; - end; - if !some_vfile then begin - print "COQCHKLIBS?="; - print_prefix_list "\\\n -R" (includes inc_q); - print_prefix_list "\\\n -R" (includes inc_r); - print "\n"; - print "COQDOCLIBS?="; - print_prefix_list "\\\n -R" (includes inc_q); - print_prefix_list "\\\n -R" (includes inc_r); - print "\n"; - end; - print "\n" - -let double_colon = ["clean"; "cleanall"; "archclean"] - -let custom sps = - let pr_path (file,dependencies,is_phony,com) = - print file; - print (if List.mem file double_colon then ":: " else ": "); - print dependencies; print "\n"; - if com <> "" then (print "\t"; print com; print "\n"); - print "\n" + fprintf oc "%s %s %s\n\t%s\n\n" + target + (if List.mem target clean_tgts then ":: " else ": ") + dependencies + command in - if sps <> [] then section "Custom targets."; + if sps <> [] then + section oc "Extra targets. (-extra and -extra-phony, DEPRECATED)"; List.iter pr_path sps -let subdirs sds = - let pr_subdir s = - print s; print ":\n\t+cd \""; print s; print "\" && $(MAKE) all\n\n" - in - if sds <> [] then - let () = - Format.eprintf "@[Warning: Targets for subdirectories are very fragile.@ " in - let () = - Format.eprintf "For example,@ nothing is done to handle dependencies@ with them.@]@." in - section "Subdirectories."; - List.iter pr_subdir sds - -let forpacks l = - let () = if l <> [] then section "Ad-hoc implicit rules for mlpack." in - List.iter (fun it -> - let h = Filename.chop_extension it in - let pk = String.capitalize (Filename.basename h) in - printf "$(addsuffix .cmx,$(filter $(basename $(MLFILES)),$(%s_MLPACK_DEPENDENCIES))): %%.cmx: %%.ml\n" h; - printf "\t$(SHOW)'CAMLOPT -c -for-pack %s $<'\n" pk; - printf "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $<\n\n" pk; - printf "$(addsuffix .cmx,$(filter $(basename $(ML4FILES)),$(%s_MLPACK_DEPENDENCIES))): %%.cmx: %%.ml4\n" h; - printf "\t$(SHOW)'CAMLOPT -c -pp -for-pack %s $<'\n" pk; - printf "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $(PP) -impl $<\n\n" pk - ) l - -let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other_targets inc = - let decl_var var = function - |[] -> () - |l -> - printf "%s:=" var; print_list "\\\n " l; print "\n\n"; - print "ifneq ($(filter-out archclean clean cleanall printenv,$(MAKECMDGOALS)),)\n"; - printf "-include $(addsuffix .d,$(%s))\n" var; - print "else\nifeq ($(MAKECMDGOALS),)\n"; - printf "-include $(addsuffix .d,$(%s))\n" var; - print "endif\nendif\n\n"; - printf ".SECONDARY: $(addsuffix .d,$(%s))\n\n" var - in - section "Files dispatching."; - decl_var "VFILES" vfiles; - begin match vfiles with - |[] -> () - |l -> - print "VO=vo\n"; - print "VOFILES:=$(VFILES:.v=.$(VO))\n"; - classify_files_by_root "VOFILES" l inc; - classify_files_by_root "VFILES" l inc; - print "GLOBFILES:=$(VFILES:.v=.glob)\n"; - print "GFILES:=$(VFILES:.v=.g)\n"; - print "HTMLFILES:=$(VFILES:.v=.html)\n"; - print "GHTMLFILES:=$(VFILES:.v=.g.html)\n"; - print "OBJFILES=$(call vo_to_obj,$(VOFILES))\n"; - print "ALLNATIVEFILES=$(OBJFILES:.o=.cmi) $(OBJFILES:.o=.cmo) $(OBJFILES:.o=.cmx) $(OBJFILES:.o=.cmxs)\n"; - print "NATIVEFILES=$(foreach f, $(ALLNATIVEFILES), $(wildcard $f))\n"; - classify_files_by_root "NATIVEFILES" l inc - end; - decl_var "ML4FILES" ml4files; - decl_var "MLFILES" mlfiles; - decl_var "MLPACKFILES" mlpackfiles; - decl_var "MLLIBFILES" mllibfiles; - decl_var "MLIFILES" mlifiles; - let mlsfiles = match ml4files,mlfiles,mlpackfiles with - |[],[],[] -> [] - |[],[],_ -> Printf.eprintf "Mlpack cannot work without ml[4]?"; [] - |[],ml,[] -> - print "ALLCMOFILES:=$(MLFILES:.ml=.cmo)\n"; - ml - |ml4,[],[] -> - print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo)\n"; - ml4 - |ml4,ml,[] -> - print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo) $(MLFILES:.ml=.cmo)\n"; - List.rev_append ml ml4 - |[],ml,mlpack -> - print "ALLCMOFILES:=$(MLFILES:.ml=.cmo) $(MLPACKFILES:.mlpack=.cmo)\n"; - List.rev_append mlpack ml - |ml4,[],mlpack -> - print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo) $(MLPACKFILES:.mlpack=.cmo)\n"; - List.rev_append mlpack ml4 - |ml4,ml,mlpack -> - print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo) $(MLFILES:.ml=.cmo) $(MLPACKFILES:.mlpack=.cmo)\n"; - List.rev_append mlpack (List.rev_append ml ml4) in - begin match mlsfiles with - |[] -> () - |l -> - print "CMOFILES=$(filter-out $(addsuffix .cmo,$(foreach lib,$(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES) $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(ALLCMOFILES))\n"; - classify_files_by_root "CMOFILES" l inc; - print "CMXFILES=$(CMOFILES:.cmo=.cmx)\n"; - print "OFILES=$(CMXFILES:.cmx=.o)\n"; - end; - begin match mllibfiles with - |[] -> () - |l -> - print "CMAFILES:=$(MLLIBFILES:.mllib=.cma)\n"; - classify_files_by_root "CMAFILES" l inc; - print "CMXAFILES:=$(CMAFILES:.cma=.cmxa)\n"; - end; - begin match mlifiles,mlsfiles with - |[],[] -> () - |l,[] -> - print "CMIFILES:=$(MLIFILES:.mli=.cmi)\n"; - classify_files_by_root "CMIFILES" l inc; - |[],l -> - print "CMIFILES=$(ALLCMOFILES:.cmo=.cmi)\n"; - classify_files_by_root "CMIFILES" l inc; - |l1,l2 -> - print "CMIFILES=$(sort $(ALLCMOFILES:.cmo=.cmi) $(MLIFILES:.mli=.cmi))\n"; - classify_files_by_root "CMIFILES" (l1@l2) inc; - end; - begin match mllibfiles,mlsfiles with - |[],[] -> () - |l,[] -> - print "CMXSFILES:=$(CMXAFILES:.cmxa=.cmxs)\n"; - classify_files_by_root "CMXSFILES" l inc; - |[],l -> - print "CMXSFILES=$(CMXFILES:.cmx=.cmxs)\n"; - classify_files_by_root "CMXSFILES" l inc; - |l1,l2 -> - print "CMXSFILES=$(CMXFILES:.cmx=.cmxs) $(CMXAFILES:.cmxa=.cmxs)\n"; - classify_files_by_root "CMXSFILES" (l1@l2) inc; - end; - print "ifeq '$(HASNATDYNLINK)' 'true'\n"; - print "HASNATDYNLINK_OR_EMPTY := yes\n"; - print "else\n"; - print "HASNATDYNLINK_OR_EMPTY :=\n"; - print "endif\n\n"; - section "Definition of the toplevel targets."; - print "all: "; - if !some_vfile then print "$(VOFILES) "; - if !some_mlfile || !some_ml4file || !some_mlpackfile then print "$(CMOFILES) "; - if !some_mllibfile then print "$(CMAFILES) "; - if !some_mlfile || !some_ml4file || !some_mllibfile || !some_mlpackfile - then print "$(if $(HASNATDYNLINK_OR_EMPTY),$(CMXSFILES)) "; - print_list "\\\n " other_targets; print "\n\n"; - if !some_mlifile then - begin - print "mlihtml: $(MLIFILES:.mli=.cmi)\n"; - print "\t mkdir $@ || rm -rf $@/*\n"; - print "\t$(OCAMLFIND) ocamldoc -html -safe-string -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; - print "all-mli.tex: $(MLIFILES:.mli=.cmi)\n"; - print "\t$(OCAMLFIND) ocamldoc -latex -safe-string -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; - end; - if !some_vfile then - begin - print "quick: $(VOFILES:.vo=.vio)\n\n"; - print "vio2vo:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio)\n"; - print "checkproofs:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio)\n"; - print "gallina: $(GFILES)\n\n"; - print "html: $(GLOBFILES) $(VFILES)\n"; - print "\t- mkdir -p html\n"; - print "\t$(COQDOC) -toc $(COQDOCFLAGS) -html $(COQDOCLIBS) -d html $(VFILES)\n\n"; - print "gallinahtml: $(GLOBFILES) $(VFILES)\n"; - print "\t- mkdir -p html\n"; - print "\t$(COQDOC) -toc $(COQDOCFLAGS) -html -g $(COQDOCLIBS) -d html $(VFILES)\n\n"; - print "all.ps: $(VFILES)\n"; - print "\t$(COQDOC) -toc $(COQDOCFLAGS) -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; - print "all-gal.ps: $(VFILES)\n"; - print "\t$(COQDOC) -toc $(COQDOCFLAGS) -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; - print "all.pdf: $(VFILES)\n"; - print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; - print "all-gal.pdf: $(VFILES)\n"; - print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; - print "validate: $(VOFILES)\n"; - print "\t$(COQCHK) $(COQCHKFLAGS) $(COQCHKLIBS) $(notdir $(^:.vo=))\n\n"; - print "beautify: $(VFILES:=.beautified)\n"; - print "\tfor file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done\n"; - print "\t@echo \'Do not do \"make clean\" until you are sure that everything went well!\'\n"; - print "\t@echo \'If there were a problem, execute \"for file in $$(find . -name \\*.v.old -print); do mv $${file} $${file%.old}; done\" in your shell/'\n\n" - end - -let all_target (vfiles, (_,_,_,_,mlpackfiles as mlfiles), sps, sds) inc = - let other_targets = - CList.map_filter - (fun (n,_,is_phony,_) -> if not (is_phony || is_genrule n) then Some n else None) - sps @ sds in - main_targets vfiles mlfiles other_targets inc; - print ".PHONY: "; - print_list - " " - ("all" :: "archclean" :: "beautify" :: "byte" :: "clean" :: "cleanall" - :: "gallina" :: "gallinahtml" :: "html" :: "install" :: "install-doc" - :: "install-natdynlink" :: "install-toploop" :: "opt" :: "printenv" - :: "quick" :: "uninstall" :: "userinstall" :: "validate" :: "vio2vo" - :: (sds@(CList.map_filter - (fun (n,_,is_phony,_) -> - if is_phony then Some n else None) sps))); - print "\n\n"; - custom sps; - subdirs sds; - forpacks mlpackfiles - -let banner () = - print (Printf.sprintf -"#############################################################################\ -\n## v # The Coq Proof Assistant ##\ -\n## <O___,, # INRIA - CNRS - LIX - LRI - PPS ##\ -\n## \\VV/ # ##\ -\n## // # Makefile automagically generated by coq_makefile V%s ##\ -\n#############################################################################\ -\n\n" -(Coq_config.version ^ String.make (10 - String.length Coq_config.version) ' ')) - -let warning () = - print "# WARNING\n#\n"; - print "# This Makefile has been automagically generated\n"; - print "# Edit at your own risks !\n"; - print "#\n# END OF WARNING\n\n" - -let print_list l = List.iter (fun x -> print x; print " ") l - -let command_line args = - print "#\n# This Makefile was generated by the command line :\n"; - print "# coq_makefile "; - print_list args; - print "\n#\n\n" - -let ensure_root_dir (vfiles,(mlis,ml4s,mls,mllibs,mlpacks),_,_) inc = - let (ml_inc,i_inc,r_inc) = inc in +let generate_conf_subdirs oc sds = + if sds <> [] then section oc "Subdirectories. (DEPRECATED)"; + List.iter (fprintf oc ".PHONY:%s\n") sds; + List.iter (fprintf oc "post-all::\n\tcd \"%s\" && $(MAKE) all\n") sds; + List.iter (fprintf oc "clean::\n\tcd \"%s\" && $(MAKE) clean\n") sds; + List.iter (fprintf oc "archclean::\n\tcd \"%s\" && $(MAKE) archclean\n") sds; + List.iter (fprintf oc "install-extra::\n\tcd \"%s\" && $(MAKE) install\n") sds + + +let generate_conf_includes oc { ml_includes; r_includes; q_includes } = + section oc "Path directives (-I, -R, -Q)."; + let module S = String in + let open List in + let dash1 opt v = sprintf "-%s %s" opt (quote v) in + let dash2 opt v1 v2 = sprintf "-%s %s %s" opt (quote v1) (quote v2) in + fprintf oc "COQMF_OCAMLLIBS = %s\n" + (S.concat " " (map (fun { path } -> dash1 "I" path) ml_includes)); + fprintf oc "COQMF_SRC_SUBDIRS = %s\n" + (S.concat " " (map (fun { path } -> quote path) ml_includes)); + fprintf oc "COQMF_COQLIBS = %s %s %s\n" + (S.concat " " (map (fun { path } -> dash1 "I" path) ml_includes)) + (S.concat " " (map (fun ({ path },l) -> dash2 "Q" path l) q_includes)) + (S.concat " " (map (fun ({ path },l) -> dash2 "R" path l) r_includes)); + fprintf oc "COQMF_COQLIBS_NOML = %s %s\n" + (S.concat " " (map (fun ({ path },l) -> dash2 "Q" path l) q_includes)) + (S.concat " " (map (fun ({ path },l) -> dash2 "R" path l) r_includes)) +;; + +let generate_conf_coq_config oc args = + section oc "Coq configuration."; + Envars.print_config ~prefix_var_name:"COQMF_" oc; + fprintf oc "COQMF_MAKEFILE=%s\n" (quote (List.hd args)); +;; + +let generate_conf_files oc + { v_files; mli_files; ml4_files; ml_files; mllib_files; mlpack_files } += + let module S = String in + let open List in + section oc "Project files."; + fprintf oc "COQMF_VFILES = %s\n" (S.concat " " (map quote v_files)); + fprintf oc "COQMF_MLIFILES = %s\n" (S.concat " " (map quote mli_files)); + fprintf oc "COQMF_MLFILES = %s\n" (S.concat " " (map quote ml_files)); + fprintf oc "COQMF_ML4FILES = %s\n" (S.concat " " (map quote ml4_files)); + fprintf oc "COQMF_MLPACKFILES = %s\n" (S.concat " " (map quote mlpack_files)); + fprintf oc "COQMF_MLLIBFILES = %s\n" (S.concat " " (map quote mllib_files)); +;; + +let rec all_start_with prefix = function + | [] -> true + | [] :: _ -> false + | (x :: _) :: rest -> x = prefix && all_start_with prefix rest + +let rec logic_gcd acc = function + | [] -> acc + | [] :: _ -> acc + | (hd :: tl) :: rest -> + if all_start_with hd rest + then logic_gcd (acc @ [hd]) (tl :: List.map List.tl rest) + else acc + +let generate_conf_doc oc { defs; q_includes; r_includes } = + let includes = List.map snd (q_includes @ r_includes) in + let logpaths = List.map (CString.split '.') includes in + let gcd = logic_gcd [] logpaths in + let root = + if gcd = [] then + if not (List.mem_assoc "INSTALLDEFAULTROOT" defs) then begin + let destination = "orphan_" ^ (String.concat "_" includes) in + eprintf "Warning: no common logical root\n"; + eprintf "Warning: in such case INSTALLDEFAULTROOT must be defined\n"; + eprintf "Warning: the install-doc target is going to install files\n"; + eprintf "Warning: in %s\n" destination; + destination + end else "$(INSTALLDEFAULTROOT)" + else String.concat "/" gcd in + Printf.fprintf oc "COQMF_INSTALLCOQDOCROOT = %s\n" (quote root) + +let generate_conf_defs oc { defs; extra_args } = + section oc "Extra variables."; + List.iter (fun (k,v) -> Printf.fprintf oc "%s = %s\n" k v) defs; + Printf.fprintf oc "COQMF_OTHERFLAGS = %s\n" + (String.concat " " extra_args) + +let generate_conf oc project args = + fprintf oc "# This configuration file was generated by running:\n"; + fprintf oc "# %s\n\n" (String.concat " " (List.map quote args)); + generate_conf_files oc project; + generate_conf_includes oc project; + generate_conf_coq_config oc args; + generate_conf_defs oc project; + generate_conf_doc oc project; + generate_conf_extra_target oc project.extra_targets; + generate_conf_subdirs oc project.subdirs; +;; + +let ensure_root_dir + ({ ml_includes; r_includes; + v_files; ml_files; mli_files; ml4_files; + mllib_files; mlpack_files } as project) += + let open List in let here = Sys.getcwd () in - let not_tops = List.for_all (fun s -> s <> Filename.basename s) in - if List.exists (fun (_,_,x) -> x = here) i_inc - || List.exists (fun (_,_,x) -> is_prefix x here) r_inc - || (not_tops vfiles && not_tops mlis && not_tops ml4s && not_tops mls - && not_tops mllibs && not_tops mlpacks) + let not_tops = List.for_all (fun s -> s <> Filename.basename s) in + if exists (fun { canonical_path = x } -> x = here) ml_includes + || exists (fun ({ canonical_path = x },_) -> is_prefix x here) r_includes + || (not_tops v_files && + not_tops mli_files && not_tops ml4_files && not_tops ml_files && + not_tops mllib_files && not_tops mlpack_files) then - inc + project else - ((".",here)::ml_inc,i_inc,(".","Top",here)::r_inc) - -let warn_install_at_root_directory (vfiles,(mlis,ml4s,mls,mllibs,mlpacks),_,_) inc = - let (inc_ml,inc_i,inc_r) = inc in - let inc_top = List.filter (fun (_,ldir,_) -> ldir = "") (inc_r@inc_i) in - let inc_top_p = List.map (fun (p,_,_) -> p) inc_top in - let files = vfiles @ mlis @ ml4s @ mls @ mllibs @ mlpacks in - if List.exists (fun f -> List.mem (Filename.dirname f) inc_top_p) files - then - Printf.eprintf "Warning: install target will copy files at the first level of the coq contributions installation directory; option -R or -Q %sis recommended\n" - (if inc_top = [] then "" else "with non trivial logical root ") + let here_path = { path = "."; canonical_path = here } in + { project with + ml_includes = here_path :: ml_includes; + r_includes = (here_path, "Top") :: r_includes } +;; + +let warn_install_at_root_directory + { q_includes; r_includes; + v_files; ml_files; mli_files; ml4_files; + mllib_files; mlpack_files } += + let open CList in + let inc_top_p = + map_filter + (fun ({ path } ,ldir) -> if ldir = "" then Some path else None) + (r_includes @ q_includes) in + let files = + v_files @ mli_files @ ml4_files @ ml_files @ mllib_files @ mlpack_files in + let bad = filter (fun f -> mem (Filename.dirname f) inc_top_p) files in + if bad <> [] then begin + eprintf "Warning: No file should be installed at the root of Coq's library.\n"; + eprintf "Warning: No logical path (-R, -Q) applies to these files:\n"; + List.iter (fun x -> eprintf "Warning: %s\n" x) bad; + eprintf "\n"; + end +;; -let check_overlapping_include (_,inc_i,inc_r) = +let check_overlapping_include { q_includes; r_includes } = let pwd = Sys.getcwd () in let aux = function | [] -> () - | (pdir,_,abspdir)::l -> - if not (is_prefix pwd abspdir) then - Printf.eprintf "Warning: in option -R/-Q, %s is not a subdirectory of the current directory\n" pdir; - List.iter (fun (pdir',_,abspdir') -> - if is_prefix abspdir abspdir' || is_prefix abspdir' abspdir then - Printf.eprintf "Warning: in options -R/-Q, %s and %s overlap\n" pdir pdir') l; - in aux (inc_i@inc_r) - -(* Generate a .merlin file that references the standard library and - * any -I included paths. - *) -let merlin targets (ml_inc,_,_) = - print ".merlin:\n"; - print "\t@echo 'FLG -rectypes -safe-string' > .merlin\n" ; - List.iter (fun c -> - printf "\t@echo \"B $(COQLIB)%s\" >> .merlin\n" c) - lib_dirs ; - List.iter (fun (_,c) -> - printf "\t@echo \"B %s\" >> .merlin\n" c; - printf "\t@echo \"S %s\" >> .merlin\n" c) - ml_inc; - print "\n" - -let do_makefile args = - let has_file var = function - |[] -> var := false - |_::_ -> var := true in - let (project_file,makefile,is_install,opt),l = - try - Project_file.process_cmd_line Filename.current_dir_name - (None,None,Project_file.UnspecInstall,true) [] args - with Project_file.Parsing_error -> usage () in - let (v_f,(mli_f,ml4_f,ml_f,mllib_f,mlpack_f),sps,sds as targets), inc, defs = - Project_file.split_arguments l in - - let () = match project_file with |None -> () |Some f -> make_name := f in - let () = match makefile with - |None -> () - |Some f -> makefile_name := f; output_channel := open_out f in - has_file some_vfile v_f; has_file some_mlifile mli_f; - has_file some_mlfile ml_f; has_file some_ml4file ml4_f; - has_file some_mllibfile mllib_f; has_file some_mlpackfile mlpack_f; - let check_dep f = - if Filename.check_suffix f ".v" then some_vfile := true - else if (Filename.check_suffix f ".mli") then some_mlifile := true - else if (Filename.check_suffix f ".ml4") then some_ml4file := true - else if (Filename.check_suffix f ".ml") then some_mlfile := true - else if (Filename.check_suffix f ".mllib") then some_mllibfile := true - else if (Filename.check_suffix f ".mlpack") then some_mlpackfile := true + | ({ path; canonical_path }, _) :: l -> + if not (is_prefix pwd canonical_path) then + eprintf "Warning: %s (used in -R or -Q) is not a subdirectory of the current directory\n\n" path; + List.iter (fun ({ path = p; canonical_path = cp }, _) -> + if is_prefix canonical_path cp || is_prefix cp canonical_path then + eprintf "Warning: %s and %s overlap (used in -R or -Q)\n\n" + path p) l in - List.iter (fun (_,dependencies,_,_) -> - List.iter check_dep (Str.split (Str.regexp "[ \t]+") dependencies)) sps; + aux (q_includes @ r_includes) +;; + +let chop_prefix p f = + let len_p = String.length p in + let len_f = String.length f in + String.sub f len_p (len_f - len_p) + +let clean_path p = + Str.global_replace (Str.regexp_string "//") "/" p + +let destination_of { ml_includes; q_includes; r_includes; } file = + let file_dir = CUnix.canonical_path_name (Filename.dirname file) in + let includes = q_includes @ r_includes in + let mk_destination logic canonical_path = + clean_path (physical_dir_of_logical_dir logic ^ "/" ^ + chop_prefix canonical_path file_dir ^ "/") in + let candidates = + CList.map_filter (fun ({ canonical_path }, logic) -> + if is_prefix canonical_path file_dir then + Some(mk_destination logic canonical_path) + else None) includes + in + match candidates with + | [] -> + (* BACKWARD COMPATIBILITY: -I into the only logical root *) + begin match + r_includes, + List.find (fun { canonical_path = p } -> is_prefix p file_dir) + ml_includes + with + | [{ canonical_path }, logic], { canonical_path = p } -> + let destination = + clean_path (physical_dir_of_logical_dir logic ^ "/" ^ + chop_prefix p file_dir ^ "/") in + Printf.printf "%s" (quote destination) + | _ -> () (* skip *) + | exception Not_found -> () (* skip *) + end + | [s] -> Printf.printf "%s" (quote s) + | _ -> assert false + +let share_prefix s1 s2 = + let s1 = CString.split '.' s1 in + let s2 = CString.split '.' s2 in + match s1, s2 with + | x :: _ , y :: _ -> x = y + | _ -> false + +let _ = + let prog, args = + if Array.length Sys.argv = 1 then usage (); + let args = Array.to_list Sys.argv in + let prog = List.hd args in + prog, List.tl args in - let inc = ensure_root_dir targets inc in - if is_install <> Project_file.NoInstall then begin - warn_install_at_root_directory targets inc; + let only_destination, args = match args with + | "-destination-of" :: tgt :: rest -> Some tgt, rest + | _ -> None, args in + + let project = + try cmdline_args_to_project ~curdir:Filename.current_dir_name args + with Parsing_error s -> prerr_endline s; usage () in + + if only_destination <> None then begin + destination_of project (Option.get only_destination); + exit 0 + end; + + if project.makefile = None then + eprintf "Warning: Omitting -o is deprecated\n\n"; + (* We want to know the name of the Makefile (say m) in order to + * generate m.conf and include m.local *) + + let conf_file = Option.default "CoqMakefile" project.makefile ^ ".conf" in + let local_file = Option.default "CoqMakefile" project.makefile ^ ".local" in + + if project.extra_targets <> [] then begin + eprintf "Warning: -extra and -extra-phony are deprecated.\n"; + eprintf "Warning: Write the extra targets in %s.\n\n" local_file; + end; + + if project.subdirs <> [] then begin + eprintf "Warning: Subdirectories are deprecated.\n"; + eprintf "Warning: Use double colon rules in %s.\n\n" local_file; end; - check_overlapping_include inc; - banner (); - header_includes (); - warning (); - command_line args; - parameters (); - include_dirs inc; - variables is_install opt defs; - all_target targets inc; - section "Special targets."; - standard opt; - install targets inc is_install; - merlin targets inc; - clean sds sps; - make_makefile sds; - implicit (); - warning (); - if not (makefile = None) then close_out !output_channel; + + let project = ensure_root_dir project in + + if project.install_kind <> (Some CoqProject_file.NoInstall) then begin + warn_install_at_root_directory project; + end; + + check_overlapping_include project; + + Envars.set_coqlib ~fail:(fun x -> x); + + let ocm = Option.cata open_out stdout project.makefile in + generate_makefile ocm conf_file local_file (prog :: args) project; + close_out ocm; + let occ = open_out conf_file in + generate_conf occ project (prog :: args); + close_out occ; exit 0 -let _ = - let args = - if Array.length Sys.argv = 1 then usage (); - List.tl (Array.to_list Sys.argv) - in - do_makefile args diff --git a/tools/coqc.ml b/tools/coqc.ml index 552a943c8c..240531f123 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -83,8 +83,11 @@ let parse_args () = | ("-config" | "--config") :: _ -> Envars.set_coqlib ~fail:(fun x -> x); - Usage.print_config (); + Envars.print_config stdout; exit 0 + + |"--print-version" :: _ -> + Usage.machine_readable_version 0 (* Options for coqtop : a) options with 0 argument *) @@ -96,6 +99,7 @@ let parse_args () = |"-impredicative-set"|"-vm"|"-native-compiler" |"-indices-matter"|"-quick"|"-type-in-type" |"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch" + |"-stm-debug" as o) :: rem -> parse (cfiles,o::args) rem diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 1c1c1be6aa..044399544a 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -435,7 +435,7 @@ let usage () = ML Module\" commands in coq files.\n"; *) (* Does not work anymore: *) (* eprintf " -D : Prints the missing ocmal module names. No dependency computed.\n"; *) - eprintf " -boot : For coq developpers, prints dependencies over coq library files (omitted by default).\n"; + eprintf " -boot : For coq developers, prints dependencies over coq library files (omitted by default).\n"; eprintf " -sort : output the given file name ordered by dependencies\n"; eprintf " -noglob | -no-glob : \n"; eprintf " -I dir -as logname : add (non recursively) dir to coq load path under logical name logname\n"; @@ -495,7 +495,7 @@ let coqdep () = add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; end else begin - Envars.set_coqlib ~fail:CErrors.error; + Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); let coqlib = Envars.coqlib () in add_rec_dir_import add_coqlib_known (coqlib//"theories") ["Coq"]; add_rec_dir_import add_coqlib_known (coqlib//"plugins") ["Coq"]; diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index 93b25e2ede..f5e93527c9 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -36,6 +36,10 @@ let norec_dirs = ref StrSet.empty let suffixe = ref ".vo" +[@@@ocaml.warning "-3"] (* String.capitalize_ascii since 4.03.0 GPR#124 *) +let capitalize = String.capitalize +[@@@ocaml.warning "+3"] + type dir = string option (** [get_extension f l] checks whether [f] has one of the extensions @@ -219,7 +223,6 @@ let register_dir_logpath,find_dir_logpath = let file_name s = function | None -> s - | Some "." -> s | Some d -> d // s let depend_ML str = @@ -293,15 +296,15 @@ let traite_fichier_modules md ext = (fun a_faire str -> match search_mlpack_known str with | Some mldir -> let file = file_name str mldir in - a_faire^" "^file + a_faire @ [file] | None -> match search_ml_known str with | Some mldir -> let file = file_name str mldir in - a_faire^" "^file - | None -> a_faire) "" list + a_faire @ [file] + | None -> a_faire) [] list with - | Sys_error _ -> "" + | Sys_error _ -> [] | Syntax_error (i,j) -> error_cannot_parse (md^ext) (i,j) (* Makefile's escaping rules are awful: $ is escaped by doubling and @@ -443,7 +446,7 @@ let mL_dependencies () = let fullname = file_name name dirname in let dep = traite_fichier_modules fullname ".mllib" in let efullname = escape fullname in - printf "%s_MLLIB_DEPENDENCIES:=%s\n" efullname dep; + printf "%s_MLLIB_DEPENDENCIES:=%s\n" efullname (String.concat " " dep); printf "%s.cma:$(addsuffix .cmo,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname; printf "%s.cmxa:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname; flush stdout) @@ -453,9 +456,13 @@ let mL_dependencies () = let fullname = file_name name dirname in let dep = traite_fichier_modules fullname ".mlpack" in let efullname = escape fullname in - printf "%s_MLPACK_DEPENDENCIES:=%s\n" efullname dep; + printf "%s_MLPACK_DEPENDENCIES:=%s\n" efullname (String.concat " " dep); printf "%s.cmo:$(addsuffix .cmo,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname; printf "%s.cmx:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname; + let efullname_capital = capitalize (Filename.basename efullname) in + List.iter (fun dep -> + printf "%s.cmx : FOR_PACK=-for-pack %s\n" dep efullname_capital) + dep; flush stdout) (List.rev !mlpackAccu) diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll index eb233b8f94..c68c34bbbd 100644 --- a/tools/coqdep_lexer.mll +++ b/tools/coqdep_lexer.mll @@ -39,6 +39,10 @@ let syntax_error lexbuf = raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) + + [@@@ocaml.warning "-3"] (* String.uncapitalize_ascii since 4.03.0 GPR#124 *) + let uncapitalize = String.uncapitalize + [@@@ocaml.warning "+3"] } let space = [' ' '\t' '\n' '\r'] @@ -154,7 +158,7 @@ and caml_action = parse | space + { caml_action lexbuf } | "open" space* (caml_up_ident as id) - { Use_module (String.uncapitalize id) } + { Use_module (uncapitalize id) } | "module" space+ caml_up_ident { caml_action lexbuf } | caml_low_ident { caml_action lexbuf } @@ -321,12 +325,12 @@ and modules mllist = parse and qual_id ml_module_name = parse | '.' [^ '.' '(' '['] - { Use_module (String.uncapitalize ml_module_name) } + { Use_module (uncapitalize ml_module_name) } | eof { raise Fin_fichier } | _ { caml_action lexbuf } and mllib_list = parse - | caml_up_ident { let s = String.uncapitalize (Lexing.lexeme lexbuf) + | caml_up_ident { let s = uncapitalize (Lexing.lexeme lexbuf) in s :: mllib_list lexbuf } | "*predef*" { mllib_list lexbuf } | space+ { mllib_list lexbuf } diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml index 3d92c9356b..6a6db95567 100644 --- a/tools/coqdoc/alpha.ml +++ b/tools/coqdoc/alpha.ml @@ -8,7 +8,11 @@ open Cdglobals -let norm_char_latin1 c = match Char.uppercase c with +[@@@ocaml.warning "-3"] (* Char.uppercase_ascii since 4.03.0 GPR#124 *) +let uppercase = Char.uppercase +[@@@ocaml.warning "+3"] + +let norm_char_latin1 c = match uppercase c with | '\192'..'\198' -> 'A' | '\199' -> 'C' | '\200'..'\203' -> 'E' @@ -19,12 +23,12 @@ let norm_char_latin1 c = match Char.uppercase c with | '\221' -> 'Y' | c -> c -let norm_char_utf8 c = Char.uppercase c +let norm_char_utf8 c = uppercase c let norm_char c = if !utf8 then norm_char_utf8 c else if !latin1 then norm_char_latin1 c else - Char.uppercase c + uppercase c let norm_string = String.map (fun s -> norm_char s) diff --git a/tools/coqdoc/cdglobals.ml b/tools/coqdoc/cdglobals.ml index 5d48473d8c..ef203960b5 100644 --- a/tools/coqdoc/cdglobals.ml +++ b/tools/coqdoc/cdglobals.ml @@ -70,23 +70,21 @@ let normalize_filename f = let dirname = Filename.dirname f in normalize_path dirname, basename +(** Add a local installation suffix (unless the suffix is itself + absolute in which case the prefix does not matter) *) +let use_suffix prefix suffix = + if String.length suffix > 0 && suffix.[0] = '/' then suffix else prefix / suffix + (** A weaker analog of the function in Envars *) let guess_coqlib () = let file = "theories/Init/Prelude.vo" in - match Coq_config.coqlib with - | Some coqlib when Sys.file_exists (coqlib / file) -> coqlib - | Some _ | None -> - let coqbin = normalize_path (Filename.dirname Sys.executable_name) in - let prefix = Filename.dirname coqbin in - let rpath = - if Coq_config.local then [] - else if Coq_config.arch_is_win32 then ["lib"] - else ["lib/coq"] - in - let coqlib = List.fold_left (/) prefix rpath in - if Sys.file_exists (coqlib / file) then coqlib - else prefix + let coqbin = normalize_path (Filename.dirname Sys.executable_name) in + let prefix = Filename.dirname coqbin in + let coqlib = use_suffix prefix Coq_config.coqlibsuffix in + if Sys.file_exists (coqlib / file) then coqlib else + if not Coq_config.local && Sys.file_exists (Coq_config.coqlib / file) + then Coq_config.coqlib else prefix let header_trailer = ref true let header_file = ref "" diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index 34108eff42..4d118b9788 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -155,10 +155,14 @@ let sort_entries el = let display_letter c = if c = '*' then "other" else String.make 1 c +[@@@ocaml.warning "-3"] (* String.lowercase_ascii since 4.03.0 GPR#124 *) +let lowercase = String.lowercase +[@@@ocaml.warning "+3"] + let type_name = function | Library -> let ln = !lib_name in - if ln <> "" then String.lowercase ln else "library" + if ln <> "" then lowercase ln else "library" | Module -> "module" | Definition -> "definition" | Inductive -> "inductive" diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 82d3d62b59..9723905790 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -19,6 +19,10 @@ let printf s = Printf.fprintf !out_channel s let sprintf = Printf.sprintf +[@@@ocaml.warning "-3"] (* String.{capitalize,lowercase}_ascii since 4.03.0 GPR#124 *) +let capitalize = String.capitalize +let lowercase = String.lowercase +[@@@ocaml.warning "+3"] (*s Coq keywords *) @@ -36,7 +40,7 @@ let is_keyword = "Hypothesis"; "Hypotheses"; "Resolve"; "Unfold"; "Immediate"; "Extern"; "Constructors"; "Rewrite"; "Implicit"; "Import"; "Inductive"; - "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac"; + "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Locate"; "Ltac"; "Module"; "Module Type"; "Declare Module"; "Include"; "Mutual"; "Parameter"; "Parameters"; "Print"; "Printing"; "All"; "Proof"; "Proof with"; "Qed"; "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; "Assumptions"; "Axioms"; "Universes"; @@ -58,9 +62,9 @@ let is_keyword = (*i (* coq terms *) *) "forall"; "match"; "as"; "in"; "return"; "with"; "end"; "let"; "fun"; "if"; "then"; "else"; "Prop"; "Set"; "Type"; ":="; "where"; "struct"; "wf"; "measure"; - "fix"; "cofix"; + "fix"; "cofix"; "is"; (* Ltac *) - "before"; "after"; "constr"; "ltac"; "goal"; "context"; "beta"; "delta"; "iota"; "zeta"; "lazymatch"; + "before"; "after"; "constr"; "ltac"; "goal"; "context"; "beta"; "delta"; "iota"; "zeta"; "lazymatch"; "type"; "of"; "rec"; (* Notations *) "level"; "associativity"; "no" ] @@ -70,7 +74,7 @@ let is_tactic = [ "intro"; "intros"; "apply"; "rewrite"; "refine"; "case"; "clear"; "injection"; "elimtype"; "progress"; "setoid_rewrite"; "left"; "right"; "constructor"; "econstructor"; "decide equality"; "abstract"; "exists"; "cbv"; "simple destruct"; - "info"; "fourier"; "field"; "specialize"; "evar"; "solve"; "instanciate"; + "info"; "fourier"; "field"; "specialize"; "evar"; "solve"; "instanciate"; "info_auto"; "info_eauto"; "quote"; "eexact"; "autorewrite"; "destruct"; "destruction"; "destruct_call"; "dependent"; "elim"; "extensionality"; "f_equal"; "generalize"; "generalize_eqs"; "generalize_eqs_vars"; "induction"; "rename"; "move"; "omega"; @@ -846,7 +850,7 @@ module Html = struct if t = Library then let ln = !lib_name in if ln <> "" then - "[" ^ String.lowercase ln ^ "]", m ^ ".html", t + "[" ^ lowercase ln ^ "]", m ^ ".html", t else "[library]", m ^ ".html", t else @@ -864,7 +868,7 @@ module Html = struct (* Impression de la table d'index *) let print_index_table_item i = - printf "<tr>\n<td>%s Index</td>\n" (String.capitalize i.idx_name); + printf "<tr>\n<td>%s Index</td>\n" (capitalize i.idx_name); List.iter (fun (c,l) -> if l <> [] then @@ -912,7 +916,7 @@ module Html = struct let print_table () = print_index_table all_index in let print_one_index i = if i.idx_size > 0 then begin - printf "<hr/>\n<h1>%s Index</h1>\n" (String.capitalize i.idx_name); + printf "<hr/>\n<h1>%s Index</h1>\n" (capitalize i.idx_name); all_letters i end in diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml index 7fa8fd58db..cd04665cc1 100644 --- a/tools/coqmktop.ml +++ b/tools/coqmktop.ml @@ -20,6 +20,10 @@ let split_list = let spaces = Str.regexp "[ \t\n]+" in fun str -> Str.split spaces str +[@@@ocaml.warning "-3"] (* String.uncapitalize_ascii since 4.03.0 GPR#124 *) +let capitalize = String.capitalize +[@@@ocaml.warning "+3"] + let (/) = Filename.concat (** Which user files do we support (and propagate to ocamlopt) ? @@ -39,8 +43,7 @@ let native_suffix f = match CUnix.get_extension f with (** Transforms a file name in the corresponding Caml module name. *) let module_of_file name = - String.capitalize - (try Filename.chop_extension name with Invalid_argument _ -> name) + capitalize (try Filename.chop_extension name with Invalid_argument _ -> name) (** Run a command [prog] with arguments [args]. We do not use [Sys.command] anymore, see comment in [CUnix.sys_command]. @@ -227,7 +230,7 @@ let declare_loading_string () = \n Mltop.set_top\ \n {Mltop.load_obj=\ \n (fun f -> if not (Topdirs.load_file ppf f)\ -\n then CErrors.error (\"Could not load plugin \"^f));\ +\n then CErrors.user_err Pp.(str (\"Could not load plugin \"^f)));\ \n Mltop.use_file=Topdirs.dir_use ppf;\ \n Mltop.add_dir=Topdirs.dir_directory;\ \n Mltop.ml_loop=(fun () -> Toploop.loop ppf) };;\ @@ -257,7 +260,7 @@ let create_tmp_main_file modules = let main () = let (options, userfiles) = parse_args () in (* Directories: *) - let () = Envars.set_coqlib ~fail:CErrors.error in + let () = Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)) in let basedir = if !Flags.boot then None else Some (Envars.coqlib ()) in (* Which ocaml compiler to invoke *) let prog = if !opt then "opt" else "ocamlc" in diff --git a/tools/gallina-syntax.el b/tools/gallina-syntax.el index c25abece15..662762b08c 100644 --- a/tools/gallina-syntax.el +++ b/tools/gallina-syntax.el @@ -390,7 +390,7 @@ ("Corollary" "cor" "Corollary # : #.\nProof.\n#\nQed." t "Corollary") ("Declare Module :" "dmi" "Declare Module # : #.\n#\nEnd #." t) ("Declare Module <:" "dmi2" "Declare Module # <: #.\n#\nEnd #." t) - ("Definition goal" "defg" "Definition #:#.\n#\nSave." t);; careful + ("Definition goal" "defg" "Definition #:#.\n#\nQed." t);; careful ("Fact" "fct" "Fact # : #." t "Fact") ("Goal" nil "Goal #." t "Goal") ("Lemma" "l" "Lemma # : #.\nProof.\n#\nQed." t "Lemma") @@ -492,7 +492,6 @@ ("Require" nil "Require #." t "Require") ("Reserved Notation" nil "Reserved Notation" nil "Reserved\\s-+Notation") ("Reset Extraction Inline" nil "Reset Extraction Inline." t "Reset\\s-+Extraction\\s-+Inline") - ("Save" nil "Save." t "Save") ("Search" nil "Search #" nil "Search") ("SearchAbout" nil "SearchAbout #" nil "SearchAbout") ("SearchPattern" nil "SearchPattern #" nil "SearchPattern") @@ -710,7 +709,6 @@ Used by `coq-goal-command-p'" (defvar coq-keywords-save-strict '("Defined" - "Save" "Qed" "End" "Admitted" diff --git a/tools/gallina_lexer.mll b/tools/gallina_lexer.mll index 449efd57cd..432b18e645 100644 --- a/tools/gallina_lexer.mll +++ b/tools/gallina_lexer.mll @@ -105,7 +105,6 @@ and end_of_line = parse | _ { print (Lexing.lexeme lexbuf) } and skip_proof = parse - | "Save." { end_of_line lexbuf } | "Save" space { skip_until_point lexbuf } | "Qed." { end_of_line lexbuf } diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll index bf82be09f1..5d11e30089 100644 --- a/tools/ocamllibdep.mll +++ b/tools/ocamllibdep.mll @@ -11,6 +11,12 @@ let syntax_error lexbuf = raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) + + [@@@ocaml.warning "-3"] (* String.(un)capitalize_ascii since 4.03.0 GPR#124 *) + let uncapitalize = String.uncapitalize + + let capitalize = String.capitalize + [@@@ocaml.warning "+3"] } let space = [' ' '\t' '\n' '\r'] @@ -22,7 +28,9 @@ let caml_up_ident = uppercase identchar* let caml_low_ident = lowercase identchar* rule mllib_list = parse - | caml_up_ident { let s = String.uncapitalize (Lexing.lexeme lexbuf) + | uppercase+ { let s = Lexing.lexeme lexbuf in + s :: mllib_list lexbuf } + | caml_up_ident { let s = uncapitalize (Lexing.lexeme lexbuf) in s :: mllib_list lexbuf } | "*predef*" { mllib_list lexbuf } | space+ { mllib_list lexbuf } @@ -185,7 +193,7 @@ let mlpack_dependencies () = List.iter (fun (name,dirname) -> let fullname = file_name name dirname in - let modname = String.capitalize name in + let modname = capitalize name in let deps = traite_fichier_modules fullname ".mlpack" in let sdeps = String.concat " " deps in let efullname = escape fullname in diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 2b9a04dad8..8fca302687 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -121,14 +121,10 @@ let init_library_roots () = find the "include" file in the *source* directory *) let init_ocaml_path () = let add_subdir dl = - Mltop.add_ml_dir (List.fold_left (/) Envars.coqroot dl) + Mltop.add_ml_dir (List.fold_left (/) Envars.coqroot [dl]) in Mltop.add_ml_dir (Envars.coqlib ()); - List.iter add_subdir - [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ]; - [ "engine" ]; [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ]; - [ "tactics" ]; [ "toplevel" ]; [ "printing" ]; [ "intf" ]; - [ "grammar" ]; [ "ide" ]; [ "ltac" ]; [ "vernac" ]; ] + List.iter add_subdir Envars.coq_src_subdirs let get_compat_version = function | "8.7" -> Flags.Current diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index a80599cd57..ab5104c78c 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -146,7 +146,6 @@ let print_highlight_location ib loc = highlight_lines let valid_buffer_loc ib loc = - not (Loc.is_ghost loc) && let (b,e) = Loc.unloc loc in b-ib.start >= 0 && e-ib.start < ib.len && b<=e (* Toplevel error explanation. *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 41d370ea57..7834b5113b 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -133,7 +133,7 @@ let set_batch_mode () = batch_mode := true let toplevel_default_name = Names.(DirPath.make [Id.of_string "Top"]) let toplevel_name = ref toplevel_default_name let set_toplevel_name dir = - if Names.DirPath.is_empty dir then error "Need a non empty toplevel module name"; + if Names.DirPath.is_empty dir then user_err Pp.(str "Need a non empty toplevel module name"); toplevel_name := dir let remove_top_ml () = Mltop.remove () @@ -185,7 +185,7 @@ let load_vernacular sid = let load_vernacular_obj = ref ([] : string list) let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj let load_vernac_obj () = - let map dir = Qualid (Loc.ghost, qualid_of_string dir) in + let map dir = Qualid (Loc.tag @@ qualid_of_string dir) in Vernacentries.vernac_require None None (List.rev_map map !load_vernacular_obj) let require_prelude () = @@ -200,7 +200,7 @@ let require_list = ref ([] : string list) let add_require s = require_list := s :: !require_list let require () = let () = if !load_init then silently require_prelude () in - let map dir = Qualid (Loc.ghost, qualid_of_string dir) in + let map dir = Qualid (Loc.tag @@ qualid_of_string dir) in Vernacentries.vernac_require None (Some false) (List.rev_map map !require_list) let add_compat_require v = @@ -245,7 +245,7 @@ let compile_files () = let set_emacs () = if not (Option.is_empty !toploop) then - error "Flag -emacs is incompatible with a custom toplevel loop"; + user_err Pp.(str "Flag -emacs is incompatible with a custom toplevel loop"); Flags.print_emacs := true; Printer.enable_goal_tags_printing := true; color := `OFF @@ -253,14 +253,14 @@ let set_emacs () = (** Options for CoqIDE *) let set_ideslave () = - if !Flags.print_emacs then error "Flags -ideslave and -emacs are incompatible"; + if !Flags.print_emacs then user_err Pp.(str "Flags -ideslave and -emacs are incompatible"); toploop := Some "coqidetop"; Flags.ide_slave := true (** Options for slaves *) let set_toploop name = - if !Flags.print_emacs then error "Flags -toploop and -emacs are incompatible"; + if !Flags.print_emacs then user_err Pp.(str "Flags -toploop and -emacs are incompatible"); toploop := Some name (** GC tweaking *) @@ -555,6 +555,7 @@ let parse_args arglist = |"-color" -> set_color (next ()) |"-config"|"--config" -> print_config := true |"-debug" -> set_debug () + |"-stm-debug" -> Flags.stm_debug := true |"-emacs" -> set_emacs () |"-filteropts" -> filter_opts := true |"-h"|"-H"|"-?"|"-help"|"--help" -> usage () @@ -590,7 +591,7 @@ let parse_args arglist = |"-notactics" -> warning "Obsolete option \"-notactics\"."; remove_top_ml () |"-emacs-U" -> warning "Obsolete option \"-emacs-U\", use -emacs instead."; set_emacs () - |"-v7" -> error "This version of Coq does not support v7 syntax" + |"-v7" -> user_err Pp.(str "This version of Coq does not support v7 syntax") |"-v8" -> warning "Obsolete option \"-v8\"." |"-lazy-load-proofs" -> warning "Obsolete option \"-lazy-load-proofs\"." |"-dont-load-proofs" -> warning "Obsolete option \"-dont-load-proofs\"." @@ -618,9 +619,9 @@ let init_toplevel arglist = (* If we have been spawned by the Spawn module, this has to be done * early since the master waits us to connect back *) Spawned.init_channels (); - Envars.set_coqlib ~fail:CErrors.error; + Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); if !print_where then (print_endline(Envars.coqlib ()); exit(exitcode ())); - if !print_config then (Usage.print_config (); exit (exitcode ())); + if !print_config then (Envars.print_config stdout; exit (exitcode ())); if !print_tags then (print_style_tags (); exit (exitcode ())); if !filter_opts then (print_string (String.concat "\n" extras); exit 0); init_load_path (); diff --git a/toplevel/usage.ml b/toplevel/usage.ml index e290480354..b50fbfda0a 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -56,7 +56,8 @@ let print_usage_channel co command = \n\ \n -where print Coq's standard library location and exit\ \n -config, --config print Coq's configuration information and exit\ -\n -v print Coq version and exit\ +\n -v, --version print Coq version and exit\ +\n --print-version print Coq version in easy to parse format and exit\ \n -list-tags print highlight color tags known by Coq and exit\ \n\ \n -quiet unset display of extra information (implies -w \"-all\")\ @@ -69,6 +70,7 @@ let print_usage_channel co command = \n -boot boot mode (implies -q and -batch)\ \n -bt print backtraces (requires configure debug flag)\ \n -debug debug mode (implies -bt)\ +\n -stm-debug STM debug mode (will trace every transaction) \ \n -emacs tells Coq it is executed under Emacs\ \n -noglob do not dump globalizations\ \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ @@ -115,16 +117,3 @@ let print_usage_coqc () = flush stderr ; exit 1 -(* Print the configuration information *) - -let print_config () = - if Coq_config.local then Printf.printf "LOCAL=1\n" else Printf.printf "LOCAL=0\n"; - Printf.printf "COQLIB=%s/\n" (Envars.coqlib ()); - Printf.printf "DOCDIR=%s/\n" (Envars.docdir ()); - Printf.printf "OCAMLFIND=%s\n" (Envars.ocamlfind ()); - Printf.printf "CAMLP4=%s\n" Coq_config.camlp4; - Printf.printf "CAMLP4O=%s\n" Coq_config.camlp4o; - Printf.printf "CAMLP4BIN=%s/\n" (Envars.camlp4bin ()); - Printf.printf "CAMLP4LIB=%s\n" (Envars.camlp4lib ()); - Printf.printf "CAMLP4OPTIONS=%s\n" Coq_config.camlp4compat; - Printf.printf "HASNATDYNLINK=%s\n" (if Coq_config.has_natdynlink then "true" else "false") diff --git a/toplevel/usage.mli b/toplevel/usage.mli index dccb40e713..c46c7a79c0 100644 --- a/toplevel/usage.mli +++ b/toplevel/usage.mli @@ -21,5 +21,3 @@ val add_to_usage : string -> string -> unit val print_usage_coqtop : unit -> unit val print_usage_coqc : unit -> unit -(** {6 Prints the configuration information } *) -val print_config : unit -> unit diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index deb2cc1e3f..a61ade7849 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -21,22 +21,25 @@ open Vernacprop let checknav_simple (loc, cmd) = if is_navigation_vernac cmd && not (is_reset cmd) then - CErrors.user_err ~loc (str "Navigation commands forbidden in files.") + CErrors.user_err ?loc (str "Navigation commands forbidden in files.") let checknav_deep (loc, ast) = if is_deep_navigation_vernac ast then - CErrors.user_err ~loc (str "Navigation commands forbidden in nested commands.") + CErrors.user_err ?loc (str "Navigation commands forbidden in nested commands.") + let disable_drop = function - | Drop -> CErrors.error "Drop is forbidden." + | Drop -> CErrors.user_err Pp.(str "Drop is forbidden.") | e -> e (* Echo from a buffer based on position. XXX: Should move to utility file. *) -let vernac_echo loc in_chan = let open Loc in - let len = loc.ep - loc.bp in - seek_in in_chan loc.bp; - Feedback.msg_notice @@ str @@ really_input_string in_chan len +let vernac_echo ?loc in_chan = let open Loc in + Option.iter (fun loc -> + let len = loc.ep - loc.bp in + seek_in in_chan loc.bp; + Feedback.msg_notice @@ str @@ really_input_string in_chan len + ) loc (* vernac parses the given stream, executes interpfun on the syntax tree it * parses, and is verbose on "primitives" commands if verbosely is true *) @@ -48,8 +51,8 @@ let set_formatter_translator ch = Format.set_formatter_output_functions out (fun () -> flush ch); Format.set_max_boxes max_int -let pr_new_syntax_in_context loc chan_beautify ocom = - let loc = Loc.unloc loc in +let pr_new_syntax_in_context ?loc chan_beautify ocom = + let loc = Option.cata Loc.unloc (0,0) loc in if !beautify_file then set_formatter_translator chan_beautify; let fs = States.freeze ~marshallable:`No in (* The content of this is not supposed to fail, but if ever *) @@ -71,14 +74,14 @@ let pr_new_syntax_in_context loc chan_beautify ocom = States.unfreeze fs; Format.set_formatter_out_channel stdout -let pr_new_syntax po loc chan_beautify ocom = +let pr_new_syntax ?loc po chan_beautify ocom = (* Reinstall the context of parsing which includes the bindings of comments to locations *) - Pcoq.Gram.with_parsable po (pr_new_syntax_in_context chan_beautify loc) ocom + Pcoq.Gram.with_parsable po (pr_new_syntax_in_context ?loc chan_beautify) ocom (* For coqtop -time, we display the position in the file, and a glimpse of the executed command *) -let pp_cmd_header loc com = +let pp_cmd_header ?loc com = let shorten s = if Unicode.utf8_length s > 33 then (Unicode.utf8_sub s 0 30) ^ "..." else s in @@ -88,7 +91,7 @@ let pp_cmd_header loc com = | x -> x ) s in - let (start,stop) = Loc.unloc loc in + let (start,stop) = Option.cata Loc.unloc (0,0) loc in let safe_pr_vernac x = try Ppvernac.pr_vernac x with e -> str (Printexc.to_string e) in @@ -99,9 +102,8 @@ let pp_cmd_header loc com = (* This is a special case where we assume we are in console batch mode and take control of the console. *) -(* FIXME *) -let print_cmd_header loc com = - Pp.pp_with !Topfmt.std_ft (pp_cmd_header loc com); +let print_cmd_header ?loc com = + Pp.pp_with !Topfmt.std_ft (pp_cmd_header ?loc com); Format.pp_print_flush !Topfmt.std_ft () let pr_open_cur_subgoals () = @@ -160,7 +162,7 @@ let rec interp_vernac sid (loc,com) = try (* The -time option is only supported from console-based clients due to the way it prints. *) - if !Flags.time then print_cmd_header loc com; + if !Flags.time then print_cmd_header ?loc com; let com = if !Flags.time then VernacTime (loc,com) else com in interp com with reraise -> @@ -168,9 +170,11 @@ let rec interp_vernac sid (loc,com) = things, so we better avoid it while we investigate *) if not !Flags.batch_mode then ignore(Stm.edit_at sid); let (reraise, info) = CErrors.push reraise in - let loc' = Option.default Loc.ghost (Loc.get_loc info) in - if Loc.is_ghost loc' then iraise (reraise, Loc.add_loc info loc) - else iraise (reraise, info) + let info = begin + match Loc.get_loc info with + | None -> Option.cata (Loc.add_loc info) info loc + | Some _ -> info + end in iraise (reraise, info) (* Load a vernac file. CErrors are annotated with file and location *) and load_vernac verbosely sid file = @@ -205,8 +209,8 @@ and load_vernac verbosely sid file = *) in (* Printing of vernacs *) - if !beautify then pr_new_syntax in_pa chan_beautify loc (Some ast); - Option.iter (vernac_echo loc) in_echo; + if !beautify then pr_new_syntax ?loc in_pa chan_beautify (Some ast); + Option.iter (vernac_echo ?loc) in_echo; checknav_simple (loc, ast); let nsid = Flags.silently (interp_vernac !rsid) (loc, ast) in @@ -221,7 +225,7 @@ and load_vernac verbosely sid file = | Stm.End_of_input -> (* Is this called so comments at EOF are printed? *) if !beautify then - pr_new_syntax in_pa chan_beautify (Loc.make_loc (max_int,max_int)) None; + pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) in_pa chan_beautify None; if !Flags.beautify_file then close_out chan_beautify; !rsid | reraise -> @@ -306,7 +310,7 @@ let compile verbosely f = let wall_clock2 = Unix.gettimeofday () in check_pending_proofs (); Library.save_library_to ldir long_f_dot_vo (Global.opaque_tables ()); - Aux_file.record_in_aux_at Loc.ghost "vo_compile_time" + Aux_file.record_in_aux_at "vo_compile_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); Aux_file.stop_aux_file (); if !Flags.xml_export then Hook.get f_xml_end_library (); diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index f363deac69..b99ccbf4a2 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -57,16 +57,15 @@ exception NonSingletonProp of inductive exception DecidabilityMutualNotSupported exception NoDecidabilityCoInductive -let dl = Loc.ghost - let constr_of_global g = lazy (Universes.constr_of_global g) (* Some pre declaration of constant we are going to use *) let bb = constr_of_global Coqlib.glob_bool -let andb_prop = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb_prop +let andb_prop = fun _ -> Universes.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb_prop let andb_true_intro = fun _ -> + Universes.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb_true_intro let tt = constr_of_global Coqlib.glob_true @@ -75,9 +74,9 @@ let ff = constr_of_global Coqlib.glob_false let eq = constr_of_global Coqlib.glob_eq -let sumbool = Coqlib.build_coq_sumbool +let sumbool () = Universes.constr_of_global (Coqlib.build_coq_sumbool ()) -let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb +let andb = fun _ -> Universes.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb let induct_on c = induction false None c None None @@ -85,12 +84,12 @@ let destruct_on c = destruct false None c None None let destruct_on_using c id = destruct false None c - (Some (dl,IntroOrPattern [[dl,IntroNaming IntroAnonymous]; - [dl,IntroNaming (IntroIdentifier id)]])) + (Some (Loc.tag @@ IntroOrPattern [[Loc.tag @@ IntroNaming IntroAnonymous]; + [Loc.tag @@ IntroNaming (IntroIdentifier id)]])) None let destruct_on_as c l = - destruct false None c (Some (dl,l)) None + destruct false None c (Some (Loc.tag l)) None (* reconstruct the inductive with the correct de Bruijn indexes *) let mkFullInd (ind,u) n = @@ -534,7 +533,7 @@ open Namegen let compute_bl_goal ind lnamesparrec nparrec = let eqI, eff = eqI ind lnamesparrec in let list_id = list_id lnamesparrec in - let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in + let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in let create_input c = let x = next_ident_away (Id.of_string "x") avoid and y = next_ident_away (Id.of_string "y") avoid in @@ -608,8 +607,8 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). Proofview.Goal.enter { enter = begin fun gl -> let fresht = fresh_id (Id.of_string "Z") gl in destruct_on_as (EConstr.mkVar freshz) - (IntroOrPattern [[dl,IntroNaming (IntroIdentifier fresht); - dl,IntroNaming (IntroIdentifier freshz)]]) + (IntroOrPattern [[Loc.tag @@ IntroNaming (IntroIdentifier fresht); + Loc.tag @@ IntroNaming (IntroIdentifier freshz)]]) end } ]); (* @@ -677,7 +676,7 @@ let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in - let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in + let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in let eqI, eff = eqI ind lnamesparrec in let create_input c = let x = next_ident_away (Id.of_string "x") avoid and @@ -807,7 +806,7 @@ let compute_dec_goal ind lnamesparrec nparrec = check_not_is_defined (); let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in let list_id = list_id lnamesparrec in - let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in + let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in let create_input c = let x = next_ident_away (Id.of_string "x") avoid and y = next_ident_away (Id.of_string "y") avoid in @@ -851,7 +850,7 @@ let compute_dec_goal ind lnamesparrec nparrec = create_input ( mkNamedProd n (mkFullInd ind (2*nparrec)) ( mkNamedProd m (mkFullInd ind (2*nparrec+1)) ( - mkApp(sumbool(),[|eqnm;mkApp (Coqlib.build_coq_not(),[|eqnm|])|]) + mkApp(sumbool(),[|eqnm;mkApp (Universes.constr_of_global @@ Coqlib.build_coq_not(),[|eqnm|])|]) ) ) ) diff --git a/vernac/classes.ml b/vernac/classes.ml index d515b0c9b2..004083dcf9 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -32,7 +32,6 @@ open Entries let refine_instance = ref true let _ = Goptions.declare_bool_option { - Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = "definition of instances by refining"; Goptions.optkey = ["Refine";"Instance";"Mode"]; @@ -75,7 +74,7 @@ let existing_instance glob g info = match class_of_constr Evd.empty (EConstr.of_constr r) with | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info glob (*FIXME*) (Flags.use_polymorphic_flag ()) c) - | None -> user_err ~loc:(loc_of_reference g) + | None -> user_err ?loc:(loc_of_reference g) ~hdr:"declare_instance" (Pp.str "Constant does not build instances of a declared type class.") @@ -145,14 +144,14 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p (fun avoid (clname, _) -> match clname with | Some (cl, b) -> - let t = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) in + let t = CAst.make @@ CHole (None, Misctypes.IntroAnonymous, None) in t, avoid | None -> failwith ("new instance: under-applied typeclass")) cl | Explicit -> cl, Id.Set.empty in let tclass = - if generalize then CGeneralization (Loc.ghost, Implicit, Some AbsPi, tclass) + if generalize then CAst.make @@ CGeneralization (Implicit, Some AbsPi, tclass) else tclass in let k, u, cty, ctx', ctx, len, imps, subst = @@ -215,7 +214,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p else ( let props = match props with - | Some (true, CRecord (loc, fs)) -> + | Some (true, { CAst.v = CRecord fs }) -> if List.length fs > List.length k.cl_props then mismatched_props env' (List.map snd fs) k.cl_props; Some (Inl fs) @@ -235,7 +234,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p let get_id = function | Ident id' -> id' - | Qualid (loc,id') -> (loc, snd (repr_qualid id')) + | Qualid (loc,id') -> (Loc.tag ?loc @@ snd (repr_qualid id')) in let props, rest = List.fold_left @@ -255,11 +254,11 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p let (loc, mid) = get_id loc_mid in List.iter (fun (n, _, x) -> if Name.equal n (Name mid) then - Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x) + Option.iter (fun x -> Dumpglob.add_glob ?loc (ConstRef x)) x) k.cl_projs; c :: props, rest' with Not_found -> - (CHole (Loc.ghost, None(* Some Evar_kinds.GoalEvar *), Misctypes.IntroAnonymous, None) :: props), rest + ((CAst.make @@ CHole (None(* Some Evar_kinds.GoalEvar *), Misctypes.IntroAnonymous, None)) :: props), rest else props, rest) ([], props) k.cl_props in @@ -354,7 +353,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p (match tac with Some tac -> ignore (Pfedit.by tac) | None -> ())) (); id) end - else CErrors.error "Unsolved obligations remaining.") + else CErrors.user_err Pp.(str "Unsolved obligations remaining.")) let named_of_rel_context l = let acc, ctx = @@ -380,7 +379,7 @@ let context poly l = let ctx = try named_of_rel_context fullctx with e when CErrors.noncritical e -> - error "Anonymous variables not allowed in contexts." + user_err Pp.(str "Anonymous variables not allowed in contexts.") in let uctx = ref (Evd.universe_context_set !evars) in let fn status (id, b, t) = @@ -406,7 +405,7 @@ let context poly l = let decl = (Discharge, poly, Definitional) in let nstatus = pi3 (Command.declare_assumption false decl (t, !uctx) [] [] impl - Vernacexpr.NoInline (Loc.ghost, id)) + Vernacexpr.NoInline (Loc.tag id)) in let () = uctx := Univ.ContextSet.empty in status && nstatus diff --git a/vernac/command.ml b/vernac/command.ml index 2fa2aa4e33..87e7e50ec2 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -53,18 +53,19 @@ let rec under_binders env sigma f n c = mkLetIn (x,b,t,under_binders (push_rel (LocalDef (x,b,t)) env) sigma f (n-1) c) | _ -> assert false -let rec complete_conclusion a cs = function - | CProdN (loc,bl,c) -> CProdN (loc,bl,complete_conclusion a cs c) - | CLetIn (loc,na,b,t,c) -> CLetIn (loc,na,b,t,complete_conclusion a cs c) - | CHole (loc, k, _, _) -> +let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function + | CProdN (bl,c) -> CProdN (bl,complete_conclusion a cs c) + | CLetIn (na,b,t,c) -> CLetIn (na,b,t,complete_conclusion a cs c) + | CHole (k, _, _) -> let (has_no_args,name,params) = a in if not has_no_args then - user_err ~loc + user_err ?loc (strbrk"Cannot infer the non constant arguments of the conclusion of " ++ pr_id cs ++ str "."); - let args = List.map (fun id -> CRef(Ident(loc,id),None)) params in - CAppExpl (loc,(None,Ident(loc,name),None),List.rev args) + let args = List.map (fun id -> CAst.make ?loc @@ CRef(Ident(loc,id),None)) params in + CAppExpl ((None,Ident(loc,name),None),List.rev args) | c -> c + ) (* Commands of the interface *) @@ -210,7 +211,7 @@ let do_definition ident k pl bl red_option c ctypopt hook = assert(Univ.ContextSet.is_empty ctx); let typ = match ce.const_entry_type with | Some t -> t - | None -> EConstr.Unsafe.to_constr (Retyping.get_type_of env evd (EConstr.of_constr c)) + | None -> EConstr.to_constr evd (Retyping.get_type_of env evd (EConstr.of_constr c)) in Obligations.check_evars env evd; let obls, _, c, cty = @@ -266,7 +267,7 @@ match local with (gr,inst,Lib.is_modtype_strict ()) let interp_assumption evdref env impls bl c = - let c = mkCProdN (local_binders_loc bl) bl c in + let c = mkCProdN ?loc:(local_binders_loc bl) bl c in let ty, impls = interp_type_evars_impls env evdref ~impls c in let ty = EConstr.Unsafe.to_constr ty in (ty, impls) @@ -343,7 +344,7 @@ let do_assumptions kind nl l = match l with | (Discharge, _, _) when Lib.sections_are_opened () -> let loc = fst id in let msg = Pp.str "Section variables cannot be polymorphic." in - user_err ~loc msg + user_err ?loc msg | _ -> () in do_assumptions_bound_univs coe kind nl id (Some pl) c @@ -355,7 +356,7 @@ let do_assumptions kind nl l = match l with let loc = fst id in let msg = Pp.str "Assumptions with bound universes can only be defined one at a time." in - user_err ~loc msg + user_err ?loc msg in (coe, (List.map map idl, c)) in @@ -381,7 +382,7 @@ type structured_inductive_expr = local_binder_expr list * structured_one_inductive_expr list let minductive_message warn = function - | [] -> error "No inductive definition." + | [] -> user_err Pp.(str "No inductive definition.") | [x] -> (pr_id x ++ str " is defined" ++ if warn then str " as a non-primitive record" else mt()) | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++ @@ -410,8 +411,8 @@ let mk_mltype_data evdref env assums arity indname = (is_ml_type,indname,assums) let prepare_param = function - | LocalAssum (na,t) -> out_name na, LocalAssumEntry t - | LocalDef (na,b,_) -> out_name na, LocalDefEntry b + | LocalAssum (na,t) -> Name.get_id na, LocalAssumEntry t + | LocalDef (na,b,_) -> Name.get_id na, LocalDefEntry b (** Make the arity conclusion flexible to avoid generating an upper bound universe now, only if the universe does not appear anywhere else. @@ -421,13 +422,13 @@ let prepare_param = function let rec check_anonymous_type ind = let open Glob_term in - match ind with - | GSort (_, GType []) -> true - | GProd (_, _, _, _, e) - | GLetIn (_, _, _, _, e) - | GLambda (_, _, _, _, e) - | GApp (_, e, _) - | GCast (_, e, _) -> check_anonymous_type e + match ind.CAst.v with + | GSort (GType []) -> true + | GProd ( _, _, _, e) + | GLetIn (_, _, _, e) + | GLambda (_, _, _, e) + | GApp (e, _) + | GCast (e, _) -> check_anonymous_type e | _ -> false let make_conclusion_flexible evdref ty poly = @@ -451,7 +452,7 @@ let interp_ind_arity env evdref ind = let t, impls = understand_tcc_evars env evdref ~expected_type:IsType c, imps in let pseudo_poly = check_anonymous_type c in let () = if not (Reductionops.is_arity env !evdref t) then - user_err ~loc:(constr_loc ind.ind_arity) (str "Not an arity") + user_err ?loc:(constr_loc ind.ind_arity) (str "Not an arity") in let t = EConstr.Unsafe.to_constr t in t, pseudo_poly, impls @@ -565,7 +566,7 @@ let check_named (loc, na) = match na with | Name _ -> () | Anonymous -> let msg = str "Parameters must be named." in - user_err ~loc msg + user_err ?loc msg let check_param = function @@ -589,7 +590,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = (* Names of parameters as arguments of the inductive type (defs removed) *) let assums = List.filter is_local_assum ctx_params in - let params = List.map (RelDecl.get_name %> out_name) assums in + let params = List.map (RelDecl.get_name %> Name.get_id) assums in (* Interpret the arities *) let arities = List.map (interp_ind_arity env_params evdref) indl in @@ -675,14 +676,14 @@ let extract_params indl = match paramsl with | [] -> anomaly (Pp.str "empty list of inductive types") | params::paramsl -> - if not (List.for_all (eq_local_binders params) paramsl) then error - "Parameters should be syntactically the same for each inductive type."; + if not (List.for_all (eq_local_binders params) paramsl) then user_err Pp.(str + "Parameters should be syntactically the same for each inductive type."); params let extract_inductive indl = List.map (fun (((_,indname),pl),_,ar,lc) -> { ind_name = indname; ind_univs = pl; - ind_arity = Option.cata (fun x -> x) (CSort (Loc.ghost,GType [])) ar; + ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (GType [])) ar; ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc }) indl @@ -714,9 +715,9 @@ let declare_mutual_inductive_with_eliminations mie pl impls = begin match mie.mind_entry_finite with | BiFinite when is_recursive mie -> if Option.has_some mie.mind_entry_record then - error "Records declared with the keywords Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command." + user_err Pp.(str "Records declared with the keywords Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command.") else - error ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.") + user_err Pp.(str ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.")) | _ -> () end; let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in @@ -905,23 +906,27 @@ let subtac_dir = [contrib_name] let fixsub_module = subtac_dir @ ["Wf"] let tactics_module = subtac_dir @ ["Tactics"] -let init_reference dir s () = Coqlib.gen_reference "Command" dir s -let init_constant dir s () = EConstr.of_constr (Coqlib.gen_constant "Command" dir s) +let init_reference dir s () = Coqlib.coq_reference "Command" dir s +let init_constant dir s evdref = + let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map !evdref) + (Coqlib.coq_reference "Command" dir s) + in evdref := Sigma.to_evar_map sigma; c + let make_ref l s = init_reference l s let fix_proto = init_constant tactics_module "fix_proto" let fix_sub_ref = make_ref fixsub_module "Fix_sub" let measure_on_R_ref = make_ref fixsub_module "MR" let well_founded = init_constant ["Init"; "Wf"] "well_founded" -let mkSubset name typ prop = +let mkSubset evdref name typ prop = let open EConstr in - mkApp (EConstr.of_constr (Universes.constr_of_global (delayed_force build_sigma).typ), + mkApp (Evarutil.e_new_global evdref (delayed_force build_sigma).typ, [| typ; mkLambda (name, typ, prop) |]) let sigT = Lazy.from_fun build_sigma_type -let make_qref s = Qualid (Loc.ghost, qualid_of_string s) +let make_qref s = Qualid (Loc.tag @@ qualid_of_string s) let lt_ref = make_qref "Init.Peano.lt" -let rec telescope l = +let rec telescope evdref l = let open EConstr in let open Vars in match l with @@ -933,10 +938,8 @@ let rec telescope l = (fun (ty, tys, (k, constr)) decl -> let t = RelDecl.get_type decl in let pred = mkLambda (RelDecl.get_name decl, t, ty) in - let ty = Universes.constr_of_global (Lazy.force sigT).typ in - let ty = EConstr.of_constr ty in - let intro = Universes.constr_of_global (Lazy.force sigT).intro in - let intro = EConstr.of_constr intro in + let ty = Evarutil.e_new_global evdref (Lazy.force sigT).typ in + let intro = Evarutil.e_new_global evdref (Lazy.force sigT).intro in let sigty = mkApp (ty, [|t; pred|]) in let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in (sigty, pred :: tys, (succ k, intro))) @@ -945,17 +948,15 @@ let rec telescope l = let (last, subst) = List.fold_right2 (fun pred decl (prev, subst) -> let t = RelDecl.get_type decl in - let p1 = Universes.constr_of_global (Lazy.force sigT).proj1 in - let p1 = EConstr.of_constr p1 in - let p2 = Universes.constr_of_global (Lazy.force sigT).proj2 in - let p2 = EConstr.of_constr p2 in + let p1 = Evarutil.e_new_global evdref (Lazy.force sigT).proj1 in + let p2 = Evarutil.e_new_global evdref (Lazy.force sigT).proj2 in let proj1 = applist (p1, [t; pred; prev]) in let proj2 = applist (p2, [t; pred; prev]) in (lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst)) (List.rev tys) tl (mkRel 1, []) in ty, (LocalDef (n, last, t) :: subst), constr - | LocalDef (n, b, t) :: tl -> let ty, subst, term = telescope tl in + | LocalDef (n, b, t) :: tl -> let ty, subst, term = telescope evdref tl in ty, (LocalDef (n, b, t) :: subst), lift 1 term let nf_evar_context sigma ctx = @@ -974,7 +975,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let top_env = push_rel_context binders_rel env in let top_arity = interp_type_evars top_env evdref arityc in let full_arity = it_mkProd_or_LetIn top_arity binders_rel in - let argtyp, letbinders, make = telescope binders_rel in + let argtyp, letbinders, make = telescope evdref binders_rel in let argname = Id.of_string "recarg" in let arg = LocalAssum (Name argname, argtyp) in let binders = letbinders @ [arg] in @@ -983,7 +984,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let relty = Typing.unsafe_type_of env !evdref rel in let relargty = let error () = - user_err ~loc:(constr_loc r) + user_err ?loc:(constr_loc r) ~hdr:"Command.build_wellfounded" (Printer.pr_econstr_env env !evdref rel ++ str " is not an homogeneous binary relation.") in @@ -1002,7 +1003,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = it_mkLambda_or_LetIn measure letbinders, it_mkLambda_or_LetIn measure binders in - let comb = EConstr.of_constr (Universes.constr_of_global (delayed_force measure_on_R_ref)) in + let comb = Evarutil.e_new_global evdref (delayed_force measure_on_R_ref) in let relargty = EConstr.of_constr relargty in let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in let wf_rel_fun x y = @@ -1010,15 +1011,15 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = subst1 y measure_body |]) in wf_rel, wf_rel_fun, measure in - let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in + let wf_proof = mkApp (well_founded evdref, [| argtyp ; wf_rel |]) in let argid' = Id.of_string (Id.to_string argname ^ "'") in let wfarg len = LocalAssum (Name argid', - mkSubset (Name argid') argtyp + mkSubset evdref (Name argid') argtyp (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) in let intern_bl = wfarg 1 :: [arg] in let _intern_env = push_rel_context intern_bl env in - let proj = (*FIXME*)EConstr.of_constr (Universes.constr_of_global (delayed_force build_sigma).Coqlib.proj1) in + let proj = Evarutil.e_new_global evdref (delayed_force build_sigma).Coqlib.proj1 in let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in let projection = (* in wfarg :: arg :: before *) mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) @@ -1031,7 +1032,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), intern_fun_arity_prod) in let curry_fun = let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in - let intro = (*FIXME*)EConstr.of_constr (Universes.constr_of_global (delayed_force build_sigma).Coqlib.intro) in + let intro = Evarutil.e_new_global evdref (delayed_force build_sigma).Coqlib.intro in let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in let rcurry = mkApp (rel, [| measure; lift len measure |]) in @@ -1057,10 +1058,10 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in let prop = mkLambda (Name argname, argtyp, top_arity_let) in let def = - mkApp (EConstr.of_constr (Universes.constr_of_global (delayed_force fix_sub_ref)), + mkApp (Evarutil.e_new_global evdref (delayed_force fix_sub_ref), [| argtyp ; wf_rel ; Evarutil.e_new_evar env evdref - ~src:(Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false)) wf_proof; + ~src:(Loc.tag @@ Evar_kinds.QuestionMark (Evar_kinds.Define false,Anonymous)) wf_proof; prop |]) in let def = Typing.e_solve_evars env evdref def in @@ -1073,12 +1074,12 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = if List.length binders_rel > 1 then let name = add_suffix recname "_func" in let hook l gr _ = - let body = it_mkLambda_or_LetIn (mkApp (EConstr.of_constr (Universes.constr_of_global gr), [|make|])) binders_rel in + let body = it_mkLambda_or_LetIn (mkApp (Evarutil.e_new_global evdref gr, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in let ty = EConstr.Unsafe.to_constr ty in let pl, univs = Evd.universe_context ?names:pl !evdref in (*FIXME poly? *) - let ce = definition_entry ~poly ~types:ty ~univs (EConstr.Unsafe.to_constr (Evarutil.nf_evar !evdref body)) in + let ce = definition_entry ~poly ~types:ty ~univs (EConstr.to_constr !evdref body) in (** FIXME: include locality *) let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in @@ -1095,10 +1096,8 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = in hook, recname, typ in let hook = Lemmas.mk_hook hook in - let fullcoqc = Evarutil.nf_evar !evdref def in - let fullctyp = Evarutil.nf_evar !evdref typ in - let fullcoqc = EConstr.Unsafe.to_constr fullcoqc in - let fullctyp = EConstr.Unsafe.to_constr fullctyp in + let fullcoqc = EConstr.to_constr !evdref def in + let fullctyp = EConstr.to_constr !evdref typ in Obligations.check_evars env !evdref; let evars, _, evars_def, evars_typ = Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp @@ -1121,7 +1120,7 @@ let interp_recursive isfix fixl notations = | x , None -> x | Some ls , Some us -> if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) ls us) then - error "(co)-recursive definitions should all have the same universe binders"; + user_err Pp.(str "(co)-recursive definitions should all have the same universe binders"); Some us) fixl None in let ctx = Evd.make_evar_universe_context env all_universes in let evdref = ref (Evd.from_ctx ctx) in @@ -1141,7 +1140,7 @@ let interp_recursive isfix fixl notations = let sort = Evarutil.evd_comb1 (Typing.type_of ~refresh:true env) evdref t in let fixprot = try - let app = mkApp (delayed_force fix_proto, [|sort; t|]) in + let app = mkApp (fix_proto evdref, [|sort; t|]) in Typing.e_solve_evars env evdref app with e when CErrors.noncritical e -> t in @@ -1210,7 +1209,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind let fixdefs = List.map Option.get fixdefs in let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in let env = Global.env() in - let indexes = search_guard Loc.ghost env indexes fixdecls in + let indexes = search_guard env indexes fixdecls in let fiximps = List.map (fun (n,r,p) -> r) fiximps in let vars = Universes.universes_of_constr (mkFix ((indexes,0),fixdecls)) in let fixdecls = @@ -1261,8 +1260,8 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n let extract_decreasing_argument limit = function | (na,CStructRec) -> na | (na,_) when not limit -> na - | _ -> error - "Only structural decreasing is supported for a non-Program Fixpoint" + | _ -> user_err Pp.(str + "Only structural decreasing is supported for a non-Program Fixpoint") let extract_fixpoint_components limit l = let fixl, ntnl = List.split l in @@ -1281,7 +1280,7 @@ let extract_cofixpoint_components l = let out_def = function | Some def -> def - | None -> error "Program Fixpoint needs defined bodies." + | None -> user_err Pp.(str "Program Fixpoint needs defined bodies.") let collect_evars_of_term evd c ty = let evars = Evar.Set.union (Evd.evars_of_term c) (Evd.evars_of_term ty) in @@ -1301,9 +1300,9 @@ let do_program_recursive local p fixkind fixl ntns = let collect_evars id def typ imps = (* Generalize by the recursive prototypes *) let def = - EConstr.Unsafe.to_constr (nf_evar evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign)) + EConstr.to_constr evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign) and typ = - EConstr.Unsafe.to_constr (nf_evar evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign)) + EConstr.to_constr evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign) in let evm = collect_evars_of_term evd def typ in let evars, _, def, typ = @@ -1322,8 +1321,7 @@ let do_program_recursive local p fixkind fixl ntns = Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) in let indexes = - Pretyping.search_guard - Loc.ghost (Global.env ()) possible_indexes fixdecls in + Pretyping.search_guard (Global.env ()) possible_indexes fixdecls in List.iteri (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) @@ -1350,7 +1348,7 @@ let do_program_fixpoint local poly l = | [(n, CMeasureRec (m, r))], [((((_,id),pl),_,bl,typ,def),ntn)] -> build_wellfounded (id, pl, n, bl, typ, out_def def) poly - (Option.default (CRef (lt_ref,None)) r) m ntn + (Option.default (CAst.make @@ CRef (lt_ref,None)) r) m ntn | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g -> let fixl,ntns = extract_fixpoint_components true l in diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 04841c922e..040c86805e 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -117,8 +117,9 @@ let process_vernac_interp_error ?(allow_uncaught=true) (exc, info) = try Some (CList.find_map (fun f -> f e) !additional_error_info) with _ -> None in + let add_loc_opt ?loc info = Option.cata (fun l -> Loc.add_loc info l) info loc in match e' with | None -> e - | Some (None, loc) -> (fst e, Loc.add_loc (snd e) loc) - | Some (Some msg, loc) -> - (EvaluatedError (msg, Some (fst e)), Loc.add_loc (snd e) loc) + | Some (loc, None) -> (fst e, add_loc_opt ?loc (snd e)) + | Some (loc, Some msg) -> + (EvaluatedError (msg, Some (fst e)), add_loc_opt ?loc (snd e)) diff --git a/vernac/explainErr.mli b/vernac/explainErr.mli index 370ad7e3b5..9202729cee 100644 --- a/vernac/explainErr.mli +++ b/vernac/explainErr.mli @@ -18,4 +18,4 @@ val process_vernac_interp_error : ?allow_uncaught:bool -> Util.iexn -> Util.iexn val explain_exn_default : exn -> Pp.std_ppcmds -val register_additional_error_info : (Util.iexn -> (Pp.std_ppcmds option * Loc.t) option) -> unit +val register_additional_error_info : (Util.iexn -> (Pp.std_ppcmds option Loc.located) option) -> unit diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 17bb87f2aa..6d8dd82ac6 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -682,12 +682,12 @@ let explain_wrong_abstraction_type env sigma na abs expected result = let explain_abstraction_over_meta _ m n = strbrk "Too complex unification problem: cannot find a solution for both " ++ - pr_name m ++ spc () ++ str "and " ++ pr_name n ++ str "." + Name.print m ++ spc () ++ str "and " ++ Name.print n ++ str "." let explain_non_linear_unification env sigma m t = let t = EConstr.to_constr sigma t in strbrk "Cannot unambiguously instantiate " ++ - pr_name m ++ str ":" ++ + Name.print m ++ str ":" ++ strbrk " which would require to abstract twice on " ++ pr_lconstr_env env sigma t ++ str "." @@ -1055,7 +1055,7 @@ let explain_refiner_bad_type arg ty conclty = let explain_refiner_unresolved_bindings l = str "Unable to find an instance for the " ++ str (String.plural (List.length l) "variable") ++ spc () ++ - prlist_with_sep pr_comma pr_name l ++ str"." + prlist_with_sep pr_comma Name.print l ++ str"." let explain_refiner_cannot_apply t harg = str "In refiner, a term of type" ++ brk(1,1) ++ diff --git a/vernac/ind_tables.ml b/vernac/ind_tables.ml index c6588684a4..f3259f1f3b 100644 --- a/vernac/ind_tables.ml +++ b/vernac/ind_tables.ml @@ -81,7 +81,7 @@ let scheme_object_table = let declare_scheme_object s aux f = let () = if not (Id.is_valid ("ind" ^ s)) then - error ("Illegal induction scheme suffix: " ^ s) + user_err Pp.(str ("Illegal induction scheme suffix: " ^ s)) in let key = if String.is_empty aux then s else aux in try diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 9ba4e46e48..a678d20bba 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -45,8 +45,7 @@ open Context.Rel.Declaration let elim_flag = ref true let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "automatic declaration of induction schemes"; optkey = ["Elimination";"Schemes"]; optread = (fun () -> !elim_flag) ; @@ -55,16 +54,14 @@ let _ = let bifinite_elim_flag = ref false let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "automatic declaration of induction schemes for non-recursive types"; optkey = ["Nonrecursive";"Elimination";"Schemes"]; optread = (fun () -> !bifinite_elim_flag) ; optwrite = (fun b -> bifinite_elim_flag := b) } let _ = declare_bool_option - { optsync = true; - optdepr = true; (* compatibility 2014-09-03*) + { optdepr = true; (* compatibility 2014-09-03*) optname = "automatic declaration of induction schemes for non-recursive types"; optkey = ["Record";"Elimination";"Schemes"]; optread = (fun () -> !bifinite_elim_flag) ; @@ -73,8 +70,7 @@ let _ = let case_flag = ref false let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "automatic declaration of case analysis schemes"; optkey = ["Case";"Analysis";"Schemes"]; optread = (fun () -> !case_flag) ; @@ -83,16 +79,14 @@ let _ = let eq_flag = ref false let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "automatic declaration of boolean equality"; optkey = ["Boolean";"Equality";"Schemes"]; optread = (fun () -> !eq_flag) ; optwrite = (fun b -> eq_flag := b) } let _ = (* compatibility *) declare_bool_option - { optsync = true; - optdepr = true; + { optdepr = true; optname = "automatic declaration of boolean equality"; optkey = ["Equality";"Scheme"]; optread = (fun () -> !eq_flag) ; @@ -103,8 +97,7 @@ let is_eq_flag () = !eq_flag && Flags.version_strictly_greater Flags.V8_2 let eq_dec_flag = ref false let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "automatic declaration of decidable equality"; optkey = ["Decidable";"Equality";"Schemes"]; optread = (fun () -> !eq_dec_flag) ; @@ -113,8 +106,7 @@ let _ = let rewriting_flag = ref false let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname ="automatic declaration of rewriting schemes for equality types"; optkey = ["Rewriting";"Schemes"]; optread = (fun () -> !rewriting_flag) ; @@ -379,7 +371,7 @@ requested | InType -> recs ^ "t_nodep") ) in let newid = add_suffix (basename_of_global (IndRef ind)) suffix in - let newref = (Loc.ghost,newid) in + let newref = Loc.tag newid in ((newref,isdep,ind,z)::l1),l2 in match t with @@ -426,7 +418,7 @@ let get_common_underlying_mutual_inductive = function raise (RecursionSchemeError (NotMutualInScheme (ind,ind'))) | [] -> if not (List.distinct_f Int.compare (List.map snd (List.map snd all))) - then error "A type occurs twice"; + then user_err Pp.(str "A type occurs twice"); mind, List.map_filter (function (Some id,(_,i)) -> Some (i,snd id) | (None,_) -> None) all @@ -437,7 +429,7 @@ let do_scheme l = tried to declare different schemes at once *) if not (List.is_empty ischeme) && not (List.is_empty escheme) then - error "Do not declare equality and induction scheme at the same time." + user_err Pp.(str "Do not declare equality and induction scheme at the same time.") else ( if not (List.is_empty ischeme) then do_mutual_induction_scheme ischeme else @@ -461,11 +453,19 @@ let fold_left' f = function [] -> invalid_arg "fold_left'" | hd :: tl -> List.fold_left f hd tl +let new_global sigma gr = + let open Sigma in + let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map sigma) gr + in Sigma.to_evar_map sigma, c + +let mk_coq_and sigma = new_global sigma (Coqlib.build_coq_and ()) +let mk_coq_conj sigma = new_global sigma (Coqlib.build_coq_conj ()) + let build_combined_scheme env schemes = - let defs = List.map (fun cst -> (* FIXME *) - let evd, c = Evd.fresh_constant_instance env (Evd.from_env env) cst in - (c, Typeops.type_of_constant_in env c)) schemes in -(* let nschemes = List.length schemes in *) + let evdref = ref (Evd.from_env env) in + let defs = List.map (fun cst -> + let evd, c = Evd.fresh_constant_instance env !evdref cst in + evdref := evd; (c, Typeops.type_of_constant_in env c)) schemes in let find_inductive ty = let (ctx, arity) = decompose_prod ty in let (_, last) = List.hd ctx in @@ -479,25 +479,27 @@ let build_combined_scheme env schemes = let (c, t) = List.hd defs in let ctx, ind, nargs = find_inductive t in (* Number of clauses, including the predicates quantification *) - let prods = nb_prod Evd.empty (EConstr.of_constr t) - (nargs + 1) (** FIXME *) in - let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in + let prods = nb_prod !evdref (EConstr.of_constr t) - (nargs + 1) in + let sigma, coqand = mk_coq_and !evdref in + let sigma, coqconj = mk_coq_conj sigma in + let () = evdref := sigma in let relargs = rel_vect 0 prods in let concls = List.rev_map - (fun (cst, t) -> (* FIXME *) + (fun (cst, t) -> mkApp(mkConstU cst, relargs), snd (decompose_prod_n prods t)) defs in let concl_bod, concl_typ = fold_left' (fun (accb, acct) (cst, x) -> - mkApp (coqconj, [| x; acct; cst; accb |]), - mkApp (coqand, [| x; acct |])) concls + mkApp (EConstr.to_constr !evdref coqconj, [| x; acct; cst; accb |]), + mkApp (EConstr.to_constr !evdref coqand, [| x; acct |])) concls in let ctx, _ = list_split_rev_at prods (List.rev_map (fun (x, y) -> LocalAssum (x, y)) ctx) in let typ = List.fold_left (fun d c -> Term.mkProd_wo_LetIn c d) concl_typ ctx in let body = it_mkLambda_or_LetIn concl_bod ctx in - (body, typ) + (!evdref, body, typ) let do_combined_scheme name schemes = let csts = @@ -505,12 +507,12 @@ let do_combined_scheme name schemes = let refe = Ident x in let qualid = qualid_of_reference refe in try Nametab.locate_constant (snd qualid) - with Not_found -> error ((string_of_qualid (snd qualid))^" is not declared.")) + with Not_found -> user_err Pp.(pr_qualid (snd qualid) ++ str " is not declared.")) schemes in - let body,typ = build_combined_scheme (Global.env ()) csts in + let sigma,body,typ = build_combined_scheme (Global.env ()) csts in let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in - ignore (define (snd name) UserIndividualRequest Evd.empty proof_output (Some typ)); + ignore (define (snd name) UserIndividualRequest sigma proof_output (Some typ)); fixpoint_message None [snd name] (**********************************************************************) diff --git a/vernac/indschemes.mli b/vernac/indschemes.mli index e5d79fd514..0f559d2bd8 100644 --- a/vernac/indschemes.mli +++ b/vernac/indschemes.mli @@ -40,7 +40,7 @@ val do_scheme : (Id.t located option * scheme) list -> unit (** Combine a list of schemes into a conjunction of them *) -val build_combined_scheme : env -> constant list -> constr * types +val build_combined_scheme : env -> constant list -> Evd.evar_map * constr * types val do_combined_scheme : Id.t located -> Id.t located list -> unit diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index b79795aebd..d6ae0ea86f 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -79,7 +79,7 @@ let adjust_guardness_conditions const = function List.fold_left (fun e (_,c,cb,_) -> add c cb e) env l) env (Safe_typing.side_effects_of_private_constants eff) in let indexes = - search_guard Loc.ghost env + search_guard env possible_indexes fixdecls in (mkFix ((indexes,0),fixdecls), ctx), eff | _ -> (body, ctx), eff) } @@ -153,9 +153,9 @@ let find_mutually_recursive_statements thms = (* assume the largest indices as possible *) List.last common_same_indhyp, false, possible_guards | _, [] -> - error + user_err Pp.(str ("Cannot find common (mutual) inductive premises or coinductive" ^ - " conclusions in the statements.") + " conclusions in the statements.")) in (finite,guard,None), ordered_inds @@ -206,7 +206,7 @@ let compute_proof_name locality = function if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) then - user_err ~loc (pr_id id ++ str " already exists."); + user_err ?loc (pr_id id ++ str " already exists."); id, pl | None -> next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()), None @@ -273,20 +273,13 @@ let save_named ?export_seff proof = let check_anonymity id save_ident = if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then - error "This command can only be used for unnamed theorem." + user_err Pp.(str "This command can only be used for unnamed theorem.") let save_anonymous ?export_seff proof save_ident = let id,const,(cstrs,pl),do_guard,persistence,hook = proof in check_anonymity id save_ident; save ?export_seff save_ident const cstrs pl do_guard persistence hook -let save_anonymous_with_strength ?export_seff proof kind save_ident = - let id,const,(cstrs,pl),do_guard,_,hook = proof in - check_anonymity id save_ident; - (* we consider that non opaque behaves as local for discharge *) - save ?export_seff save_ident const cstrs pl do_guard - (Global, const.const_entry_polymorphic, Proof kind) hook - (* Admitted *) let warn_let_as_axiom = @@ -319,7 +312,7 @@ let get_proof proof do_guard hook opacity = let check_exist = List.iter (fun (loc,id) -> if not (Nametab.exists_cci (Lib.make_path id)) then - user_err ~loc (pr_id id ++ str " does not exist.") + user_err ?loc (pr_id id ++ str " does not exist.") ) let universe_proof_terminator compute_guard hook = @@ -337,9 +330,7 @@ let universe_proof_terminator compute_guard hook = (hook (Some (fst proof.Proof_global.universes))) is_opaque in begin match idopt with | None -> save_named ~export_seff proof - | Some ((_,id),None) -> save_anonymous ~export_seff proof id - | Some ((_,id),Some kind) -> - save_anonymous_with_strength ~export_seff proof kind id + | Some (_,id) -> save_anonymous ~export_seff proof id end; check_exist exports end @@ -474,8 +465,7 @@ let keep_admitted_vars = ref true let _ = let open Goptions in declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "keep section variables in admitted proofs"; optkey = ["Keep"; "Admitted"; "Variables"]; optread = (fun () -> !keep_admitted_vars); @@ -488,10 +478,10 @@ let save_proof ?proof = function match proof with | Some ({ id; entries; persistence = k; universes }, _) -> if List.length entries <> 1 then - error "Admitted does not support multiple statements"; + user_err Pp.(str "Admitted does not support multiple statements"); let { const_entry_secctx; const_entry_type } = List.hd entries in if const_entry_type = None then - error "Admitted requires an explicit statement"; + user_err Pp.(str "Admitted requires an explicit statement"); let typ = Option.get const_entry_type in let ctx = Evd.evar_context_universe_context (fst universes) in let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in diff --git a/vernac/locality.ml b/vernac/locality.ml index 03640676e6..a25acb0d34 100644 --- a/vernac/locality.ml +++ b/vernac/locality.ml @@ -35,9 +35,9 @@ let enforce_locality_full locality_flag local = let local = match locality_flag with | Some false when local -> - CErrors.error "Cannot be simultaneously Local and Global." + CErrors.user_err Pp.(str "Cannot be simultaneously Local and Global.") | Some true when local -> - CErrors.error "Use only prefix \"Local\"." + CErrors.user_err Pp.(str "Use only prefix \"Local\".") | None -> if local then begin warn_deprecated_local_syntax (); @@ -66,7 +66,7 @@ let enforce_locality_exp locality_flag local = | None, Some local -> local | Some b, None -> local_of_bool b | None, None -> Decl_kinds.Global - | Some _, Some _ -> CErrors.error "Local non allowed in this case" + | Some _, Some _ -> CErrors.user_err Pp.(str "Local non allowed in this case") (* For commands whose default is to not discharge but to export: Global in sections forces discharge, Global not in section is the default; @@ -87,8 +87,8 @@ let enforce_section_locality locality_flag local = let make_module_locality = function | Some false -> if Lib.sections_are_opened () then - CErrors.error - "This command does not support the Global option in sections."; + CErrors.user_err Pp.(str + "This command does not support the Global option in sections."); false | Some true -> true | None -> false diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index bb5be4cb05..42494dd28a 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -60,7 +60,7 @@ let pr_entry e = let pr_registered_grammar name = let gram = try Some (String.Map.find name !grammars) with Not_found -> None in match gram with - | None -> error "Unknown or unprintable grammar entry." + | None -> user_err Pp.(str "Unknown or unprintable grammar entry.") | Some entries -> let pr_one (AnyEntry e) = str "Entry " ++ str (Pcoq.Gram.Entry.name e) ++ str " is" ++ fnl () ++ @@ -107,11 +107,11 @@ let parse_format ((loc, str) : lstring) = if Int.equal n 0 then l else push_token (UnpTerminal (String.make n ' ')) l in let close_box i b = function | a::(_::_ as l) -> push_token (UnpBox (b,a)) l - | _ -> error "Non terminated box in format." in + | _ -> user_err Pp.(str "Non terminated box in format.") in let close_quotation i = if i < String.length str && str.[i] == '\'' && (Int.equal (i+1) l || str.[i+1] == ' ') then i+1 - else error "Incorrectly terminated quoted expression." in + else user_err Pp.(str "Incorrectly terminated quoted expression.") in let rec spaces n i = if i < String.length str && str.[i] == ' ' then spaces (n+1) (i+1) else n in @@ -119,10 +119,10 @@ let parse_format ((loc, str) : lstring) = if i < String.length str && str.[i] != ' ' then if str.[i] == '\'' && quoted && (i+1 >= String.length str || str.[i+1] == ' ') - then if Int.equal n 0 then error "Empty quoted token." else n + then if Int.equal n 0 then user_err Pp.(str "Empty quoted token.") else n else nonspaces quoted (n+1) (i+1) else - if quoted then error "Spaces are not allowed in (quoted) symbols." + if quoted then user_err Pp.(str "Spaces are not allowed in (quoted) symbols.") else n in let rec parse_non_format i = let n = nonspaces false 0 i in @@ -153,8 +153,8 @@ let parse_format ((loc, str) : lstring) = (* Parse " [ .. ", *) | ' ' | '\'' -> parse_box (fun n -> PpHOVB n) (i+1) - | _ -> error "\"v\", \"hv\", \" \" expected after \"[\" in format." - else error "\"v\", \"hv\" or \" \" expected after \"[\" in format." + | _ -> user_err Pp.(str "\"v\", \"hv\", \" \" expected after \"[\" in format.") + else user_err Pp.(str "\"v\", \"hv\" or \" \" expected after \"[\" in format.") (* Parse "]" *) | ']' -> ([] :: parse_token (close_quotation (i+1))) @@ -165,7 +165,7 @@ let parse_format ((loc, str) : lstring) = (parse_token (close_quotation (i+n)))) else if Int.equal n 0 then [] - else error "Ending spaces non part of a format annotation." + else user_err Pp.(str "Ending spaces non part of a format annotation.") and parse_box box i = let n = spaces 0 i in close_box i (box n) (parse_token (close_quotation (i+n))) @@ -187,12 +187,12 @@ let parse_format ((loc, str) : lstring) = try if not (String.is_empty str) then match parse_token 0 with | [l] -> l - | _ -> error "Box closed without being opened in format." + | _ -> user_err Pp.(str "Box closed without being opened in format.") else - error "Empty format." + user_err Pp.(str "Empty format.") with reraise -> let (e, info) = CErrors.push reraise in - let info = Loc.add_loc info loc in + let info = Option.cata (Loc.add_loc info) info loc in iraise (e, info) (***********************) @@ -243,19 +243,19 @@ let rec find_pattern nt xl = function | [], NonTerminal x' :: l' -> (out_nt nt,x',List.rev xl),l' | _, Break s :: _ | Break s :: _, _ -> - error ("A break occurs on one side of \"..\" but not on the other side.") + user_err Pp.(str ("A break occurs on one side of \"..\" but not on the other side.")) | _, Terminal s :: _ | Terminal s :: _, _ -> user_err ~hdr:"Metasyntax.find_pattern" (str "The token \"" ++ str s ++ str "\" occurs on one side of \"..\" but not on the other side.") | _, [] -> - error msg_expected_form_of_recursive_notation + user_err Pp.(str msg_expected_form_of_recursive_notation) | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) -> anomaly (Pp.str "Only Terminal or Break expected on left, non-SProdList on right") let rec interp_list_parser hd = function | [] -> [], List.rev hd | NonTerminal id :: tl when Id.equal id ldots_var -> - if List.is_empty hd then error msg_expected_form_of_recursive_notation; + if List.is_empty hd then user_err Pp.(str msg_expected_form_of_recursive_notation); let hd = List.rev hd in let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in let xyl,tl'' = interp_list_parser [] tl' in @@ -286,7 +286,7 @@ let quote_notation_token x = let rec raw_analyze_notation_tokens = function | [] -> [] | String ".." :: sl -> NonTerminal ldots_var :: raw_analyze_notation_tokens sl - | String "_" :: _ -> error "_ must be quoted." + | String "_" :: _ -> user_err Pp.(str "_ must be quoted.") | String x :: sl when CLexer.is_ident x -> NonTerminal (Names.Id.of_string x) :: raw_analyze_notation_tokens sl | String s :: sl -> @@ -487,7 +487,7 @@ let make_hunks etyps symbols from = (* Build default printing rules from explicit format *) -let error_format () = error "The format does not match the notation." +let error_format () = user_err Pp.(str "The format does not match the notation.") let rec split_format_at_ldots hd = function | UnpTerminal s :: fmt when String.equal s (Id.to_string ldots_var) -> List.rev hd, fmt @@ -500,7 +500,7 @@ and check_no_ldots_in_box = function | UnpBox (_,fmt) -> (try let _ = split_format_at_ldots [] fmt in - error ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.") + user_err Pp.(str ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.")) with Exit -> ()) | _ -> () @@ -518,7 +518,7 @@ let read_recursive_format sl fmt = let rec get_tail = function | a :: sepfmt, b :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *) | [], tail -> skip_var_in_recursive_format tail - | _ -> error "The format is not the same on the right and left hand side of the special token \"..\"." in + | _ -> user_err Pp.(str "The format is not the same on the right and left hand side of the special token \"..\".") in let slfmt, fmt = get_head fmt in slfmt, get_tail (slfmt, fmt) @@ -652,7 +652,7 @@ let make_production etyps symbols = distribute [GramConstrNonTerminal (ETBinderList (o,tkl), Some x)] ll | _ -> - error "Components of recursive patterns in notation must be terms or binders.") + user_err Pp.(str "Components of recursive patterns in notation must be terms or binders.")) symbols [[]] in List.map define_keywords prod @@ -811,7 +811,7 @@ let interp_modifiers modl = let open NotationMods in interp { acc with level = Some n; } l | SetAssoc a :: l -> - if not (Option.is_empty acc.assoc) then error "An associativity is given more than once."; + if not (Option.is_empty acc.assoc) then user_err Pp.(str "An associativity is given more than once."); interp { acc with assoc = Some a; } l | SetOnlyParsing :: l -> interp { acc with only_parsing = true; } l @@ -820,7 +820,7 @@ let interp_modifiers modl = let open NotationMods in | SetCompatVersion v :: l -> interp { acc with compat = Some v; } l | SetFormat ("text",s) :: l -> - if not (Option.is_empty acc.format) then error "A format is given more than once."; + if not (Option.is_empty acc.format) then user_err Pp.(str "A format is given more than once."); interp { acc with format = Some s; } l | SetFormat (k,(_,s)) :: l -> interp { acc with extra = (k,s)::acc.extra; } l @@ -829,7 +829,7 @@ let interp_modifiers modl = let open NotationMods in let check_infix_modifiers modifiers = let t = (interp_modifiers modifiers).NotationMods.etyps in if not (List.is_empty t) then - error "Explicit entry level or type unexpected in infix notation." + user_err Pp.(str "Explicit entry level or type unexpected in infix notation.") let check_useless_entry_types recvars mainvars etyps = let vars = let (l1,l2) = List.split recvars in l1@l2@mainvars in @@ -901,7 +901,7 @@ let internalization_type_of_entry_type = function | ETBigint | ETReference -> NtnInternTypeConstr | ETBinder _ -> NtnInternTypeBinder | ETName -> NtnInternTypeIdent - | ETPattern | ETOther _ -> error "Not supported." + | ETPattern | ETOther _ -> user_err Pp.(str "Not supported.") | ETBinderList _ | ETConstrList _ -> assert false let set_internalization_type typs = @@ -917,7 +917,7 @@ let make_interpretation_type isrec isonlybinding = function | NtnInternTypeConstr | NtnInternTypeIdent -> if isonlybinding then NtnTypeOnlyBinder else NtnTypeConstr | NtnInternTypeBinder when isrec -> NtnTypeBinderList - | NtnInternTypeBinder -> error "Type binder is only for use in recursive notations for binders." + | NtnInternTypeBinder -> user_err Pp.(str "Type binder is only for use in recursive notations for binders.") let make_interpretation_vars recvars allvars = let eq_subscope (sc1, l1) (sc2, l2) = @@ -938,9 +938,9 @@ let make_interpretation_vars recvars allvars = let check_rule_productivity l = if List.for_all (function NonTerminal _ | Break _ -> true | _ -> false) l then - error "A notation must include at least one symbol."; + user_err Pp.(str "A notation must include at least one symbol."); if (match l with SProdList _ :: _ -> true | _ -> false) then - error "A recursive notation must start with at least one symbol." + user_err Pp.(str "A recursive notation must start with at least one symbol.") let warn_notation_bound_to_variable = CWarnings.create ~name:"notation-bound-to-variable" ~category:"parsing" @@ -980,7 +980,7 @@ let find_precedence lev etyps symbols = | Some (NonTerminal x) -> (try match List.assoc x etyps with | ETConstr _ -> - error "The level of the leftmost non-terminal cannot be changed." + user_err Pp.(str "The level of the leftmost non-terminal cannot be changed.") | ETName | ETBigint | ETReference -> begin match lev with | None -> @@ -988,31 +988,31 @@ let find_precedence lev etyps symbols = | Some 0 -> ([],0) | _ -> - error "A notation starting with an atomic expression must be at level 0." + user_err Pp.(str "A notation starting with an atomic expression must be at level 0.") end | ETPattern | ETBinder _ | ETOther _ -> (* Give a default ? *) if Option.is_empty lev then - error "Need an explicit level." + user_err Pp.(str "Need an explicit level.") else [],Option.get lev | ETConstrList _ | ETBinderList _ -> assert false (* internally used in grammar only *) with Not_found -> if Option.is_empty lev then - error "A left-recursive notation must have an explicit level." + user_err Pp.(str "A left-recursive notation must have an explicit level.") else [],Option.get lev) | Some (Terminal _) when last_is_terminal () -> if Option.is_empty lev then ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."], 0) else [],Option.get lev | Some _ -> - if Option.is_empty lev then error "Cannot determine the level."; + if Option.is_empty lev then user_err Pp.(str "Cannot determine the level."); [],Option.get lev let check_curly_brackets_notation_exists () = try let _ = Notation.level_of_notation "{ _ }" in () with Not_found -> - error "Notations involving patterns of the form \"{ _ }\" are treated \n\ -specially and require that the notation \"{ _ }\" is already reserved." + user_err Pp.(str "Notations involving patterns of the form \"{ _ }\" are treated \n\ +specially and require that the notation \"{ _ }\" is already reserved.") (* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *) let remove_curly_brackets l = @@ -1081,7 +1081,7 @@ let compute_syntax_data df modifiers = let mods = interp_modifiers modifiers in let onlyprint = mods.only_printing in let onlyparse = mods.only_parsing in - if onlyprint && onlyparse then error "A notation cannot be both 'only printing' and 'only parsing'."; + if onlyprint && onlyparse then user_err (str "A notation cannot be both 'only printing' and 'only parsing'."); let assoc = Option.append mods.assoc (Some NonA) in let toks = split_notation_string df in let recvars,mainvars,symbols = analyze_notation_tokens toks in @@ -1385,7 +1385,7 @@ let set_notation_for_interpretation impls ((_,df),c,sc) = (try ignore (silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ()); with NoSyntaxRule -> - error "Parsing rule for this notation has to be previously declared."); + user_err Pp.(str "Parsing rule for this notation has to be previously declared.")); Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc (* Main entry point *) @@ -1416,7 +1416,7 @@ let add_notation_extra_printing_rule df k v = (* Infix notations *) -let inject_var x = CRef (Ident (Loc.ghost, Id.of_string x),None) +let inject_var x = CAst.make @@ CRef (Ident (Loc.tag @@ Id.of_string x),None) let add_infix local ((loc,inf),modifiers) pr sc = check_infix_modifiers modifiers; @@ -1477,7 +1477,7 @@ let add_class_scope scope cl = (* Check if abbreviation to a name and avoid early insertion of maximal implicit arguments *) let try_interp_name_alias = function - | [], CRef (ref,_) -> intern_reference ref + | [], { CAst.v = CRef (ref,_) } -> intern_reference ref | _ -> raise Not_found let add_syntactic_definition ident (vars,c) local onlyparse = diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 24cb9c886e..47ac16f9c7 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -38,7 +38,7 @@ let check_evars env evm = | Evar_kinds.QuestionMark _ | Evar_kinds.ImplicitArg (_,_,false) -> () | _ -> - Pretype_errors.error_unsolvable_implicit ~loc env evm key None) + Pretype_errors.error_unsolvable_implicit ?loc env evm key None) (Evd.undefined_map evm) type oblinfo = @@ -221,7 +221,7 @@ let eterm_obligations env name evm fs ?status t ty = in let loc, k = evar_source id evm in let status = match k with - | Evar_kinds.QuestionMark o -> o + | Evar_kinds.QuestionMark (o,_) -> o | _ -> match status with | Some o -> o | None -> Evar_kinds.Define (not (Program.get_proofs_transparency ())) @@ -260,7 +260,7 @@ let eterm_obligations env name evm fs ?status t ty = let tactics_module = ["Program";"Tactics"] let safe_init_constant md name () = Coqlib.check_required_library ("Coq"::md); - Coqlib.gen_constant "Obligations" md name + Universes.constr_of_global (Coqlib.coq_reference "Obligations" md name) let hide_obligation = safe_init_constant tactics_module "obligation" let pperror cmd = CErrors.user_err ~hdr:"Program" cmd @@ -340,8 +340,7 @@ let get_hide_obligations () = !hide_obligations open Goptions let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "Hidding of Program obligations"; optkey = ["Hide";"Obligations"]; optread = get_hide_obligations; @@ -354,8 +353,7 @@ let get_shrink_obligations () = !shrink_obligations let _ = declare_bool_option - { optsync = true; - optdepr = true; + { optdepr = true; optname = "Shrinking of Program obligations"; optkey = ["Shrink";"Obligations"]; optread = get_shrink_obligations; @@ -558,8 +556,7 @@ let declare_mutual_definition l = List.map3 compute_possible_guardness_evidences wfl fixdefs fixtypes in let indexes = - Pretyping.search_guard - Loc.ghost (Global.env()) + Pretyping.search_guard (Global.env()) possible_indexes fixdecls in Some indexes, List.map_i (fun i _ -> @@ -684,7 +681,7 @@ let init_prog_info ?(opaque = false) sign n pl b t ctx deps fixkind assert(Int.equal (Array.length obls) 0); let n = Nameops.add_suffix n "_obligation" in [| { obl_name = n; obl_body = None; - obl_location = Loc.ghost, Evar_kinds.InternalHole; obl_type = t; + obl_location = Loc.tag Evar_kinds.InternalHole; obl_type = t; obl_status = false, Evar_kinds.Expand; obl_deps = Int.Set.empty; obl_tac = None } |], mkVar n @@ -1002,7 +999,7 @@ and solve_obligation_by_tac prg obls i tac = let (e, _) = CErrors.push e in match e with | Refiner.FailError (_, s) -> - user_err ~loc:(fst obl.obl_location) ~hdr:"solve_obligation" (Lazy.force s) + user_err ?loc:(fst obl.obl_location) ~hdr:"solve_obligation" (Lazy.force s) | e -> None (* FIXME really ? *) and solve_prg_obligations prg ?oblset tac = diff --git a/vernac/record.ml b/vernac/record.ml index 53722b8f61..5accc8e379 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -35,8 +35,7 @@ module RelDecl = Context.Rel.Declaration let primitive_flag = ref false let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "use of primitive projections"; optkey = ["Primitive";"Projections"]; optread = (fun () -> !primitive_flag) ; @@ -45,8 +44,7 @@ let _ = let typeclasses_strict = ref false let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "strict typeclass resolution"; optkey = ["Typeclasses";"Strict";"Resolution"]; optread = (fun () -> !typeclasses_strict); @@ -55,8 +53,7 @@ let _ = let typeclasses_unique = ref false let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "unique typeclass instances"; optkey = ["Typeclasses";"Unique";"Instances"]; optread = (fun () -> !typeclasses_unique); @@ -93,7 +90,8 @@ let compute_constructor_level evars env l = let binder_of_decl = function | Vernacexpr.AssumExpr(n,t) -> (n,None,t) - | Vernacexpr.DefExpr(n,c,t) -> (n,Some c, match t with Some c -> c | None -> CHole (fst n, None, Misctypes.IntroAnonymous, None)) + | Vernacexpr.DefExpr(n,c,t) -> (n,Some c, match t with Some c -> c + | None -> CAst.make ?loc:(fst n) @@ CHole (None, Misctypes.IntroAnonymous, None)) let binders_of_decls = List.map binder_of_decl @@ -105,14 +103,14 @@ let typecheck_params_and_fields def id pl t ps nots fs = let error bk (loc, name) = match bk, name with | Default _, Anonymous -> - user_err ~loc ~hdr:"record" (str "Record parameters must be named") + user_err ?loc ~hdr:"record" (str "Record parameters must be named") | _ -> () in List.iter (function CLocalDef (b, _, _) -> error default_binder_kind b | CLocalAssum (ls, bk, ce) -> List.iter (error bk) ls - | CLocalPattern (loc,_,_) -> - Loc.raise ~loc (Stream.Error "pattern with quote not allowed in record parameters.")) ps + | CLocalPattern (loc,(_,_)) -> + Loc.raise ?loc (Stream.Error "pattern with quote not allowed in record parameters.")) ps in let impls_env, ((env1,newps), imps) = interp_context_evars env0 evars ps in let newps = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) newps in @@ -121,7 +119,7 @@ let typecheck_params_and_fields def id pl t ps nots fs = let env = push_rel_context newps env0 in let poly = match t with - | CSort (_, Misctypes.GType []) -> true | _ -> false in + | { CAst.v = CSort (Misctypes.GType []) } -> true | _ -> false in let s = interp_type_evars env evars ~impls:empty_internalization_env t in let sred = Reductionops.whd_all env !evars s in let s = EConstr.Unsafe.to_constr s in @@ -134,7 +132,7 @@ let typecheck_params_and_fields def id pl t ps nots fs = sred, true | None -> s, false else s, false) - | _ -> user_err ~loc:(constr_loc t) (str"Sort expected.")) + | _ -> user_err ?loc:(constr_loc t) (str"Sort expected.")) | None -> let uvarkind = Evd.univ_flexible_alg in mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars), true @@ -563,7 +561,7 @@ let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,id in let isnot_class = match kind with Class false -> false | _ -> true in if isnot_class && List.exists (fun opt -> not (Option.is_empty opt)) priorities then - error "Priorities only allowed for type class substructures"; + user_err Pp.(str "Priorities only allowed for type class substructures"); (* Now, younger decl in params and fields is on top *) let (pl, ctx), arity, template, implpars, params, implfs, fields = States.with_state_protection (fun () -> diff --git a/vernac/search.ml b/vernac/search.ml index 5b6e9a9c3c..9160158003 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -40,7 +40,6 @@ module SearchBlacklist = let title = "Current search blacklist : " let member_message s b = str "Search blacklist does " ++ (if b then mt () else str "not ") ++ str "include " ++ str s - let synchronous = true end) (* The functions iter_constructors and iter_declarations implement the behavior diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 6d9d71a62b..bbf2ed4fcf 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -260,8 +260,6 @@ let emacs_logger = gen_logger Emacs.quote_info Emacs.quote_warning (* This is specific to the toplevel *) let pr_loc loc = - if Loc.is_ghost loc then str"<unknown>" - else let fname = loc.Loc.fname in if CString.equal fname "" then Loc.(str"Toplevel input, characters " ++ int loc.bp ++ @@ -275,7 +273,7 @@ let pr_loc loc = let print_err_exn ?extra any = let (e, info) = CErrors.push any in let loc = Loc.get_loc info in - let msg_loc = pr_loc (Option.default Loc.ghost loc) in + let msg_loc = Option.cata pr_loc (mt ()) loc in let pre_hdr = pr_opt_no_spc (fun x -> x) extra ++ msg_loc in let msg = CErrors.iprint (e, info) ++ fnl () in std_logger ~pre_hdr Feedback.Error msg diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index d4e6af9959..77be7f454a 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -139,7 +139,7 @@ let make_cases s = let show_match id = let patterns = try make_cases_aux (Nametab.global id) - with Not_found -> error "Unknown inductive type." + with Not_found -> user_err Pp.(str "Unknown inductive type.") in let pr_branch l = str "| " ++ hov 1 (prlist_with_sep spc str l) ++ str " =>" @@ -305,7 +305,7 @@ let print_strategy r = let key = match r with | VarRef id -> VarKey id | ConstRef cst -> ConstKey cst - | IndRef _ | ConstructRef _ -> error "The reference is not unfoldable" + | IndRef _ | ConstructRef _ -> user_err Pp.(str "The reference is not unfoldable") in let lvl = get_strategy oracle key in Feedback.msg_notice (pr_strategy (r, lvl)) @@ -364,43 +364,43 @@ let msg_found_library = function Feedback.msg_info (hov 0 (pr_dirpath fulldir ++ strbrk " is bound to file " ++ str file)) -let err_unmapped_library loc ?from qid = +let err_unmapped_library ?loc ?from qid = let dir = fst (repr_qualid qid) in let prefix = match from with | None -> str "." | Some from -> str " and prefix " ++ pr_dirpath from ++ str "." in - user_err ~loc + user_err ?loc ~hdr:"locate_library" (strbrk "Cannot find a physical path bound to logical path matching suffix " ++ pr_dirpath dir ++ prefix) -let err_notfound_library loc ?from qid = +let err_notfound_library ?loc ?from qid = let prefix = match from with | None -> str "." | Some from -> str " with prefix " ++ pr_dirpath from ++ str "." in - user_err ~loc ~hdr:"locate_library" + user_err ?loc ~hdr:"locate_library" (strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) let print_located_library r = let (loc,qid) = qualid_of_reference r in try msg_found_library (Library.locate_qualified_library ~warn:false qid) with - | Library.LibUnmappedDir -> err_unmapped_library loc qid - | Library.LibNotFound -> err_notfound_library loc qid + | Library.LibUnmappedDir -> err_unmapped_library ?loc qid + | Library.LibNotFound -> err_notfound_library ?loc qid let smart_global r = let gr = Smartlocate.smart_global r in - Dumpglob.add_glob (Stdarg.loc_of_or_by_notation loc_of_reference r) gr; + Dumpglob.add_glob ?loc:(Stdarg.loc_of_or_by_notation loc_of_reference r) gr; gr let dump_global r = try let gr = Smartlocate.smart_global r in - Dumpglob.add_glob (Stdarg.loc_of_or_by_notation loc_of_reference r) gr + Dumpglob.add_glob ?loc:(Stdarg.loc_of_or_by_notation loc_of_reference r) gr with e when CErrors.noncritical e -> () (**********) (* Syntax *) @@ -451,8 +451,8 @@ let start_proof_and_print k l hook = concl (Tacticals.New.tclCOMPLETE tac) in Evd.set_universe_context sigma ctx, EConstr.of_constr c with Logic_monad.TacticFailure e when Logic.catchable_exception e -> - error "The statement obligations could not be resolved \ - automatically, write a statement definition first." + user_err Pp.(str "The statement obligations could not be resolved \ + automatically, write a statement definition first.") in Some hook else None in @@ -551,9 +551,9 @@ let vernac_inductive poly lo finite indl = indl; match indl with | [ ( _ , _ , _ ,(Record|Structure), Constructors _ ),_ ] -> - CErrors.error "The Record keyword is for types defined using the syntax { ... }." + user_err Pp.(str "The Record keyword is for types defined using the syntax { ... }.") | [ (_ , _ , _ ,Variant, RecordDecl _),_ ] -> - CErrors.error "The Variant keyword does not support syntax { ... }." + user_err Pp.(str "The Variant keyword does not support syntax { ... }.") | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> vernac_record (match b with Class _ -> Class false | _ -> b) poly finite id bl c oc fs @@ -564,16 +564,16 @@ let vernac_inductive poly lo finite indl = (((coe', AssumExpr ((loc, Name id), ce)), None), []) in vernac_record (Class true) poly finite id bl c None [f] | [ ( _ , _, _, Class _, Constructors _), [] ] -> - CErrors.error "Inductive classes not supported" + user_err Pp.(str "Inductive classes not supported") | [ ( id , bl , c , Class _, _), _ :: _ ] -> - CErrors.error "where clause not supported for classes" + user_err Pp.(str "where clause not supported for classes") | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] -> - CErrors.error "where clause not supported for (co)inductive records" + user_err Pp.(str "where clause not supported for (co)inductive records") | _ -> let unpack = function | ( (false, id) , bl , c , _ , Constructors l ) , ntn -> ( id , bl , c , l ) , ntn | ( (true,_),_,_,_,Constructors _),_ -> - CErrors.error "Variant types do not handle the \"> Name\" syntax, which is reserved for records. Use the \":>\" syntax on constructors instead." - | _ -> CErrors.error "Cannot handle mutually (co)inductive records." + user_err Pp.(str "Variant types do not handle the \"> Name\" syntax, which is reserved for records. Use the \":>\" syntax on constructors instead.") + | _ -> user_err Pp.(str "Cannot handle mutually (co)inductive records.") in let indl = List.map unpack indl in do_mutual_inductive indl poly lo finite @@ -608,14 +608,14 @@ let vernac_combined_scheme lid l = let vernac_universe loc poly l = if poly && not (Lib.sections_are_opened ()) then - user_err ~loc ~hdr:"vernac_universe" + user_err ?loc ~hdr:"vernac_universe" (str"Polymorphic universes can only be declared inside sections, " ++ str "use Monomorphic Universe instead"); do_universe poly l let vernac_constraint loc poly l = if poly && not (Lib.sections_are_opened ()) then - user_err ~loc ~hdr:"vernac_constraint" + user_err ?loc ~hdr:"vernac_constraint" (str"Polymorphic universe constraints can only be declared" ++ str " inside sections, use Monomorphic Constraint instead"); do_constraint poly l @@ -631,25 +631,25 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast = (* We check the state of the system (in section, in module type) and what module information is supplied *) if Lib.sections_are_opened () then - error "Modules and Module Types are not allowed inside sections."; + user_err Pp.(str "Modules and Module Types are not allowed inside sections."); let binders_ast = List.map (fun (export,idl,ty) -> if not (Option.is_empty export) then - error "Arguments of a functor declaration cannot be exported. Remove the \"Export\" and \"Import\" keywords from every functor argument." + user_err Pp.(str "Arguments of a functor declaration cannot be exported. Remove the \"Export\" and \"Import\" keywords from every functor argument.") else (idl,ty)) binders_ast in let mp = Declaremods.declare_module Modintern.interp_module_ast id binders_ast (Enforce mty_ast) [] in - Dumpglob.dump_moddef loc mp "mod"; + Dumpglob.dump_moddef ?loc mp "mod"; if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is declared"); - Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export + Option.iter (fun export -> vernac_import export [Ident (Loc.tag id)]) export let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = (* We check the state of the system (in section, in module type) and what module information is supplied *) if Lib.sections_are_opened () then - error "Modules and Module Types are not allowed inside sections."; + user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mexpr_ast_l with | [] -> check_no_pending_proofs (); @@ -662,39 +662,39 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = Declaremods.start_module Modintern.interp_module_ast export id binders_ast mty_ast_o in - Dumpglob.dump_moddef loc mp "mod"; + Dumpglob.dump_moddef ?loc mp "mod"; if_verbose Feedback.msg_info (str "Interactive Module " ++ pr_id id ++ str " started"); List.iter (fun (export,id) -> Option.iter - (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export + (fun export -> vernac_import export [Ident (Loc.tag id)]) export ) argsexport | _::_ -> let binders_ast = List.map (fun (export,idl,ty) -> if not (Option.is_empty export) then - error "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument." + user_err Pp.(str "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument.") else (idl,ty)) binders_ast in let mp = Declaremods.declare_module Modintern.interp_module_ast id binders_ast mty_ast_o mexpr_ast_l in - Dumpglob.dump_moddef loc mp "mod"; + Dumpglob.dump_moddef ?loc mp "mod"; if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined"); - Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) + Option.iter (fun export -> vernac_import export [Ident (Loc.tag id)]) export let vernac_end_module export (loc,id as lid) = let mp = Declaremods.end_module () in - Dumpglob.dump_modref loc mp "mod"; + Dumpglob.dump_modref ?loc mp "mod"; if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined"); Option.iter (fun export -> vernac_import export [Ident lid]) export let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = if Lib.sections_are_opened () then - error "Modules and Module Types are not allowed inside sections."; + user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mty_ast_l with | [] -> @@ -709,32 +709,32 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = Declaremods.start_modtype Modintern.interp_module_ast id binders_ast mty_sign in - Dumpglob.dump_moddef loc mp "modtype"; + Dumpglob.dump_moddef ?loc mp "modtype"; if_verbose Feedback.msg_info (str "Interactive Module Type " ++ pr_id id ++ str " started"); List.iter (fun (export,id) -> Option.iter - (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export + (fun export -> vernac_import export [Ident (Loc.tag id)]) export ) argsexport | _ :: _ -> let binders_ast = List.map (fun (export,idl,ty) -> if not (Option.is_empty export) then - error "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument." + user_err Pp.(str "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument.") else (idl,ty)) binders_ast in let mp = Declaremods.declare_modtype Modintern.interp_module_ast id binders_ast mty_sign mty_ast_l in - Dumpglob.dump_moddef loc mp "modtype"; + Dumpglob.dump_moddef ?loc mp "modtype"; if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined") let vernac_end_modtype (loc,id) = let mp = Declaremods.end_modtype () in - Dumpglob.dump_modref loc mp "modtype"; + Dumpglob.dump_modref ?loc mp "modtype"; if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined") let vernac_include l = @@ -751,7 +751,7 @@ let vernac_begin_section (_, id as lid) = Lib.open_section id let vernac_end_section (loc,_) = - Dumpglob.dump_reference loc + Dumpglob.dump_reference ?loc (DirPath.to_string (Lib.current_dirpath true)) "<>" "sec"; Lib.close_section () @@ -784,12 +784,12 @@ let vernac_require from import qidl = let (_, dir, f) = Library.locate_qualified_library ?root ~warn qid in (dir, f) with - | Library.LibUnmappedDir -> err_unmapped_library loc ?from:root qid - | Library.LibNotFound -> err_notfound_library loc ?from:root qid + | Library.LibUnmappedDir -> err_unmapped_library ?loc ?from:root qid + | Library.LibNotFound -> err_notfound_library ?loc ?from:root qid in let modrefl = List.map locate qidl in if Dumpglob.dump () then - List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl); + List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref ?loc dp "lib") qidl (List.map fst modrefl); Library.require_library_from_dirpath modrefl import (* Coercions and canonical structures *) @@ -843,11 +843,10 @@ let focus_command_cond = Proof.no_cond command_focus let vernac_solve_existential = instantiate_nth_evar_com let vernac_set_end_tac tac = - let open Genintern in - let env = { genv = Global.env (); ltacvars = Id.Set.empty } in + let env = Genintern.empty_glob_sign (Global.env ()) in let _, tac = Genintern.generic_intern env tac in if not (refining ()) then - error "Unknown command of the non proof-editing mode."; + user_err Pp.(str "Unknown command of the non proof-editing mode."); set_end_tac tac (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) @@ -904,7 +903,7 @@ let vernac_chdir = function (* Cd is typically used to control the output directory of extraction. A failed Cd could lead to overwriting .ml files so we make it an error. *) - CErrors.error ("Cd failed: " ^ err) + user_err Pp.(str ("Cd failed: " ^ err)) end; if_verbose Feedback.msg_info (str (Sys.getcwd())) @@ -973,7 +972,7 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags let never_unfold_flag = List.mem `ReductionNeverUnfold flags in let err_incompat x y = - error ("Options \""^x^"\" and \""^y^"\" are incompatible.") in + user_err Pp.(str ("Options \""^x^"\" and \""^y^"\" are incompatible.")) in if assert_flag && rename_flag then err_incompat "assert" "rename"; @@ -1004,12 +1003,12 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags let err_extra_args names = user_err ~hdr:"vernac_declare_arguments" (strbrk "Extra arguments: " ++ - prlist_with_sep pr_comma pr_name names ++ str ".") + prlist_with_sep pr_comma Name.print names ++ str ".") in let err_missing_args names = user_err ~hdr:"vernac_declare_arguments" (strbrk "The following arguments are not declared: " ++ - prlist_with_sep pr_comma pr_name names ++ str ".") + prlist_with_sep pr_comma Name.print names ++ str ".") in let rec check_extra_args extra_args = @@ -1019,7 +1018,7 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags | { name = Anonymous; notation_scope = Some _ } :: args -> check_extra_args args | _ -> - error "Extra notation scopes can be set on anonymous and explicit arguments only." + user_err Pp.(str "Extra notation scopes can be set on anonymous and explicit arguments only.") in let args, scopes = @@ -1033,12 +1032,12 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags in if Option.cata (fun n -> n > num_args) false nargs_for_red then - error "The \"/\" modifier should be put before any extra scope."; + user_err Pp.(str "The \"/\" modifier should be put before any extra scope."); let scopes_specified = List.exists Option.has_some scopes in if scopes_specified && clear_scopes_flag then - error "The \"clear scopes\" flag is incompatible with scope annotations."; + user_err Pp.(str "The \"clear scopes\" flag is incompatible with scope annotations."); let names = List.map (fun { name } -> name) args in let names = names :: List.map (List.map fst) more_implicits in @@ -1063,7 +1062,7 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags | name1 :: names1, name2 :: names2 -> if Name.equal name1 name2 then name1 :: names_union names1 names2 - else error "Argument lists should agree on the names they provide." + else user_err Pp.(str "Argument lists should agree on the names they provide.") in let names = List.fold_left names_union [] names in @@ -1094,14 +1093,14 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags match !example_renaming with | None -> mt () | Some (o,n) -> - str "Argument " ++ pr_name o ++ - str " renamed to " ++ pr_name n ++ str "."); + str "Argument " ++ Name.print o ++ + str " renamed to " ++ Name.print n ++ str "."); let duplicate_names = List.duplicates Name.equal (List.filter ((!=) Anonymous) names) in if not (List.is_empty duplicate_names) then begin - let duplicates = prlist_with_sep pr_comma pr_name duplicate_names in + let duplicates = prlist_with_sep pr_comma Name.print duplicate_names in user_err (strbrk "Some argument names are duplicated: " ++ duplicates) end; @@ -1130,7 +1129,7 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags anonymous argument implicit *) | Anonymous :: _, (name, _) :: _ -> user_err ~hdr:"vernac_declare_arguments" - (strbrk"Argument "++ pr_name name ++ + (strbrk"Argument "++ Name.print name ++ strbrk " cannot be declared implicit.") | Name id :: inf_names, (name, impl) :: implicits -> @@ -1144,10 +1143,10 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags let implicits_specified = match implicits with [[]] -> false | _ -> true in if implicits_specified && clear_implicits_flag then - error "The \"clear implicits\" flag is incompatible with implicit annotations"; + user_err Pp.(str "The \"clear implicits\" flag is incompatible with implicit annotations"); if implicits_specified && default_implicits_flag then - error "The \"default implicits\" flag is incompatible with implicit annotations"; + user_err Pp.(str "The \"default implicits\" flag is incompatible with implicit annotations"); let rargs = Util.List.map_filter (function (n, true) -> Some n | _ -> None) @@ -1176,10 +1175,10 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags end; if scopes_specified || clear_scopes_flag then begin - let scopes = List.map (Option.map (fun (o,k) -> + let scopes = List.map (Option.map (fun (loc,k) -> try ignore (Notation.find_scope k); k with UserError _ -> - Notation.find_delimiters_scope o k)) scopes + Notation.find_delimiters_scope ?loc k)) scopes in vernac_arguments_scope locality reference scopes end; @@ -1228,8 +1227,7 @@ let vernac_generalizable locality = let _ = declare_bool_option - { optsync = false; - optdepr = false; + { optdepr = false; optname = "silent"; optkey = ["Silent"]; optread = (fun () -> !Flags.quiet); @@ -1237,8 +1235,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "implicit arguments"; optkey = ["Implicit";"Arguments"]; optread = Impargs.is_implicit_args; @@ -1246,8 +1243,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "strict implicit arguments"; optkey = ["Strict";"Implicit"]; optread = Impargs.is_strict_implicit_args; @@ -1255,8 +1251,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "strong strict implicit arguments"; optkey = ["Strongly";"Strict";"Implicit"]; optread = Impargs.is_strongly_strict_implicit_args; @@ -1264,8 +1259,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "contextual implicit arguments"; optkey = ["Contextual";"Implicit"]; optread = Impargs.is_contextual_implicit_args; @@ -1273,8 +1267,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "implicit status of reversible patterns"; optkey = ["Reversible";"Pattern";"Implicit"]; optread = Impargs.is_reversible_pattern_implicit_args; @@ -1282,8 +1275,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "maximal insertion of implicit"; optkey = ["Maximal";"Implicit";"Insertion"]; optread = Impargs.is_maximal_implicit_args; @@ -1291,8 +1283,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "automatic introduction of variables"; optkey = ["Automatic";"Introduction"]; optread = Flags.is_auto_intros; @@ -1300,8 +1291,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "coercion printing"; optkey = ["Printing";"Coercions"]; optread = (fun () -> !Constrextern.print_coercions); @@ -1309,8 +1299,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "printing of existential variable instances"; optkey = ["Printing";"Existential";"Instances"]; optread = (fun () -> !Detyping.print_evar_arguments); @@ -1318,8 +1307,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "implicit arguments printing"; optkey = ["Printing";"Implicit"]; optread = (fun () -> !Constrextern.print_implicits); @@ -1327,8 +1315,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "implicit arguments defensive printing"; optkey = ["Printing";"Implicit";"Defensive"]; optread = (fun () -> !Constrextern.print_implicits_defensive); @@ -1336,8 +1323,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "projection printing using dot notation"; optkey = ["Printing";"Projections"]; optread = (fun () -> !Constrextern.print_projections); @@ -1345,8 +1331,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "notations printing"; optkey = ["Printing";"Notations"]; optread = (fun () -> not !Constrextern.print_no_symbol); @@ -1354,8 +1339,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "raw printing"; optkey = ["Printing";"All"]; optread = (fun () -> !Flags.raw_print); @@ -1363,8 +1347,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "use of the program extension"; optkey = ["Program";"Mode"]; optread = (fun () -> !Flags.program_mode); @@ -1372,8 +1355,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "universe polymorphism"; optkey = ["Universe"; "Polymorphism"]; optread = Flags.is_universe_polymorphism; @@ -1381,8 +1363,7 @@ let _ = let _ = declare_int_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "the level of inlining during functor application"; optkey = ["Inline";"Level"]; optread = (fun () -> Some (Flags.get_inline_level ())); @@ -1392,8 +1373,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "kernel term sharing"; optkey = ["Kernel"; "Term"; "Sharing"]; optread = (fun () -> !CClosure.share); @@ -1404,8 +1384,7 @@ let _ = let _ = declare_int_option - { optsync = false; - optdepr = true; + { optdepr = true; optname = "the undo limit (OBSOLETE)"; optkey = ["Undo"]; optread = (fun _ -> None); @@ -1413,8 +1392,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "display compact goal contexts"; optkey = ["Printing";"Compact";"Contexts"]; optread = (fun () -> Printer.get_compact_context()); @@ -1422,8 +1400,7 @@ let _ = let _ = declare_int_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "the printing depth"; optkey = ["Printing";"Depth"]; optread = Topfmt.get_depth_boxes; @@ -1431,8 +1408,7 @@ let _ = let _ = declare_int_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "the printing width"; optkey = ["Printing";"Width"]; optread = Topfmt.get_margin; @@ -1440,8 +1416,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "printing of universes"; optkey = ["Printing";"Universes"]; optread = (fun () -> !Constrextern.print_universes); @@ -1449,8 +1424,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "dumping bytecode after compilation"; optkey = ["Dump";"Bytecode"]; optread = Flags.get_dump_bytecode; @@ -1458,8 +1432,7 @@ let _ = let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "explicitly parsing implicit arguments"; optkey = ["Parsing";"Explicit"]; optread = (fun () -> !Constrintern.parsing_explicit); @@ -1467,8 +1440,7 @@ let _ = let _ = declare_string_option ~preprocess:CWarnings.normalize_flags_string - { optsync = true; - optdepr = false; + { optdepr = false; optname = "warnings display"; optkey = ["Warnings"]; optread = CWarnings.get_flags; @@ -1480,8 +1452,8 @@ let vernac_set_strategy locality l = match smart_global r with | ConstRef sp -> EvalConstRef sp | VarRef id -> EvalVarRef id - | _ -> error - "cannot set an inductive type or a constructor as transparent" in + | _ -> user_err Pp.(str + "cannot set an inductive type or a constructor as transparent") in let l = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) l in Redexpr.set_strategy local l @@ -1491,8 +1463,8 @@ let vernac_set_opacity locality (v,l) = match smart_global r with | ConstRef sp -> EvalConstRef sp | VarRef id -> EvalVarRef id - | _ -> error - "cannot set an inductive type or a constructor as transparent" in + | _ -> user_err Pp.(str + "cannot set an inductive type or a constructor as transparent") in let l = List.map glob_ref l in Redexpr.set_strategy local [v,l] @@ -1542,14 +1514,14 @@ let get_current_context_of_args = function | Some n -> get_goal_context n | None -> get_current_context () -let query_command_selector ~loc = function +let query_command_selector ?loc = function | None -> None | Some (SelectNth n) -> Some n - | _ -> user_err ~loc ~hdr:"query_command_selector" + | _ -> user_err ?loc ~hdr:"query_command_selector" (str "Query commands only support the single numbered goal selector.") -let vernac_check_may_eval ~loc redexp glopt rc = - let glopt = query_command_selector ~loc glopt in +let vernac_check_may_eval ?loc redexp glopt rc = + let glopt = query_command_selector ?loc glopt in let (sigma, env) = get_current_context_of_args glopt in let sigma', c = interp_open_constr env sigma rc in let c = EConstr.Unsafe.to_constr c in @@ -1611,10 +1583,10 @@ exception NoHyp (* Printing "About" information of a hypothesis of the current goal. We only print the type and a small statement to this comes from the goal. Precondition: there must be at least one current goal. *) -let print_about_hyp_globs ~loc ref_or_by_not glopt = +let print_about_hyp_globs ?loc ref_or_by_not glopt = let open Context.Named.Declaration in try - let glnumopt = query_command_selector ~loc glopt in + let glnumopt = query_command_selector ?loc glopt in let gl,id = match glnumopt,ref_or_by_not with | None,AN (Ident (_loc,id)) -> (* goal number not given, catch any failure *) @@ -1622,7 +1594,7 @@ let print_about_hyp_globs ~loc ref_or_by_not glopt = | Some n,AN (Ident (_loc,id)) -> (* goal number given, catch if wong *) (try get_nth_goal n,id with - Failure _ -> user_err ~loc ~hdr:"print_about_hyp_globs" + Failure _ -> user_err ?loc ~hdr:"print_about_hyp_globs" (str "No such goal: " ++ int n ++ str ".")) | _ , _ -> raise NoHyp in let hyps = pf_hyps gl in @@ -1636,7 +1608,7 @@ let print_about_hyp_globs ~loc ref_or_by_not glopt = | NoHyp | Not_found -> print_about ref_or_by_not -let vernac_print ~loc = let open Feedback in function +let vernac_print ?loc = let open Feedback in function | PrintTables -> msg_notice (print_tables ()) | PrintFullContext-> msg_notice (print_full_context_typ ()) | PrintSectionContext qid -> msg_notice (print_sec_context_typ qid) @@ -1681,7 +1653,7 @@ let vernac_print ~loc = let open Feedback in function | PrintVisibility s -> msg_notice (Notation.pr_visibility (Constrextern.without_symbols pr_lglob_constr) s) | PrintAbout (ref_or_by_not,glnumopt) -> - msg_notice (print_about_hyp_globs ~loc ref_or_by_not glnumopt) + msg_notice (print_about_hyp_globs ?loc ref_or_by_not glnumopt) | PrintImplicit qid -> dump_global qid; msg_notice (print_impargs qid) | PrintAssumptions (o,t,r) -> @@ -1698,7 +1670,7 @@ let global_module r = let (loc,qid) = qualid_of_reference r in try Nametab.full_name_module qid with Not_found -> - user_err ~loc ~hdr:"global_module" + user_err ?loc ~hdr:"global_module" (str "Module/section " ++ pr_qualid qid ++ str " not found.") let interp_search_restriction = function @@ -1717,7 +1689,7 @@ let interp_search_about_item env = | SearchString (s,sc) -> try let ref = - Notation.interp_notation_as_global_reference Loc.ghost + Notation.interp_notation_as_global_reference (fun _ -> true) s sc in GlobSearchSubPattern (Pattern.PRef ref) with UserError _ -> @@ -1739,15 +1711,14 @@ let search_output_name_only = ref false let _ = declare_bool_option - { optsync = true; - optdepr = false; + { optdepr = false; optname = "output-name-only search"; optkey = ["Search";"Output";"Name";"Only"]; optread = (fun () -> !search_output_name_only); optwrite = (:=) search_output_name_only } -let vernac_search ~loc s gopt r = - let gopt = query_command_selector ~loc gopt in +let vernac_search ?loc s gopt r = + let gopt = query_command_selector ?loc gopt in let r = interp_search_restriction r in let env,gopt = match gopt with | None -> @@ -1781,8 +1752,8 @@ let vernac_search ~loc s gopt r = let vernac_locate = let open Feedback in function | LocateAny (AN qid) -> msg_notice (print_located_qualid qid) | LocateTerm (AN qid) -> msg_notice (print_located_term qid) - | LocateAny (ByNotation (_, ntn, sc)) (** TODO : handle Ltac notations *) - | LocateTerm (ByNotation (_, ntn, sc)) -> + | LocateAny (ByNotation (_, (ntn, sc))) (** TODO : handle Ltac notations *) + | LocateTerm (ByNotation (_, (ntn, sc))) -> msg_notice (Notation.locate_notation (Constrextern.without_symbols pr_lglob_constr) ntn sc) @@ -1793,13 +1764,12 @@ let vernac_locate = let open Feedback in function let vernac_register id r = if Pfedit.refining () then - error "Cannot register a primitive while in proof editing mode."; - let t = (Constrintern.global_reference (snd id)) in - if not (isConst t) then - error "Register inline: a constant is expected"; - let kn = destConst t in + user_err Pp.(str "Cannot register a primitive while in proof editing mode."); + let kn = Constrintern.global_reference (snd id) in + if not (isConstRef kn) then + user_err Pp.(str "Register inline: a constant is expected"); match r with - | RegisterInline -> Global.register_inline (Univ.out_punivs kn) + | RegisterInline -> Global.register_inline (destConstRef kn) (********************) (* Proof management *) @@ -1809,7 +1779,7 @@ let vernac_focus gln = match gln with | None -> Proof.focus focus_command_cond () 1 p | Some 0 -> - CErrors.error "Invalid goal number: 0. Goal numbering starts with 1." + user_err Pp.(str "Invalid goal number: 0. Goal numbering starts with 1.") | Some n -> Proof.focus focus_command_cond () n p) @@ -1824,7 +1794,7 @@ let vernac_unfocused () = if Proof.unfocused p then Feedback.msg_notice (str"The proof is indeed fully unfocused.") else - error "The proof is not fully unfocused." + user_err Pp.(str "The proof is not fully unfocused.") (* BeginSubproof / EndSubproof. @@ -1922,7 +1892,7 @@ let vernac_load interp fname = * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) -let interp ?proof ~loc locality poly c = +let interp ?proof ?loc locality poly c = vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac c); match c with (* The below vernac are candidates for removal from the main type @@ -2054,11 +2024,11 @@ let interp ?proof ~loc locality poly c = | VernacAddOption (key,v) -> vernac_add_option key v | VernacMemOption (key,v) -> vernac_mem_option key v | VernacPrintOption key -> vernac_print_option key - | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval ~loc r g c + | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval ?loc r g c | VernacDeclareReduction (s,r) -> vernac_declare_reduction locality s r | VernacGlobalCheck c -> vernac_global_check c - | VernacPrint p -> vernac_print ~loc p - | VernacSearch (s,g,r) -> vernac_search ~loc s g r + | VernacPrint p -> vernac_print ?loc p + | VernacSearch (s,g,r) -> vernac_search ?loc s g r | VernacLocate l -> vernac_locate l | VernacRegister (id, r) -> vernac_register id r | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n") @@ -2074,15 +2044,15 @@ let interp ?proof ~loc locality poly c = | VernacShow s -> vernac_show s | VernacCheckGuard -> vernac_check_guard () | VernacProof (None, None) -> - Aux_file.record_in_aux_at loc "VernacProof" "tac:no using:no" + Aux_file.record_in_aux_at ?loc "VernacProof" "tac:no using:no" | VernacProof (Some tac, None) -> - Aux_file.record_in_aux_at loc "VernacProof" "tac:yes using:no"; + Aux_file.record_in_aux_at ?loc "VernacProof" "tac:yes using:no"; vernac_set_end_tac tac | VernacProof (None, Some l) -> - Aux_file.record_in_aux_at loc "VernacProof" "tac:no using:yes"; + Aux_file.record_in_aux_at ?loc "VernacProof" "tac:no using:yes"; vernac_set_used_variables l | VernacProof (Some tac, Some l) -> - Aux_file.record_in_aux_at loc "VernacProof" "tac:yes using:yes"; + Aux_file.record_in_aux_at ?loc "VernacProof" "tac:yes using:yes"; vernac_set_end_tac tac; vernac_set_used_variables l | VernacProofMode mn -> Proof_global.set_proof_mode mn @@ -2110,7 +2080,7 @@ let check_vernac_supports_locality c l = | VernacDeclareReduction _ | VernacExtend _ | VernacInductive _) -> () - | Some _, _ -> CErrors.error "This command does not support Locality" + | Some _, _ -> user_err Pp.(str "This command does not support Locality") (* Vernaculars that take a polymorphism flag *) let check_vernac_supports_polymorphism c p = @@ -2124,7 +2094,7 @@ let check_vernac_supports_polymorphism c p = | VernacInstance _ | VernacDeclareInstances _ | VernacHints _ | VernacContext _ | VernacExtend _ | VernacUniverse _ | VernacConstraint _) -> () - | Some _, _ -> CErrors.error "This command does not support Polymorphism" + | Some _, _ -> user_err Pp.(str "This command does not support Polymorphism") let enforce_polymorphism = function | None -> Flags.is_universe_polymorphism () @@ -2137,8 +2107,7 @@ let default_timeout = ref None let _ = Goptions.declare_int_option - { Goptions.optsync = true; - Goptions.optdepr = false; + { Goptions.optdepr = false; Goptions.optname = "the default timeout"; Goptions.optkey = ["Default";"Timeout"]; Goptions.optread = (fun () -> !default_timeout); @@ -2158,10 +2127,10 @@ let vernac_timeout f = let restore_timeout () = current_timeout := None -let locate_if_not_already loc (e, info) = +let locate_if_not_already ?loc (e, info) = match Loc.get_loc info with - | None -> (e, Loc.add_loc info loc) - | Some l -> if Loc.is_ghost l then (e, Loc.add_loc info loc) else (e, info) + | None -> (e, Option.cata (Loc.add_loc info) info loc) + | Some l -> (e, info) exception HasNotFailed exception HasFailed of std_ppcmds @@ -2202,13 +2171,13 @@ let interp ?(verbosely=true) ?proof (loc,c) = | VernacStm _ -> assert false (* Done by Stm *) | VernacProgram c when not isprogcmd -> aux ?locality ?polymorphism true c - | VernacProgram _ -> CErrors.error "Program mode specified twice" + | VernacProgram _ -> user_err Pp.(str "Program mode specified twice") | VernacLocal (b, c) when Option.is_empty locality -> aux ~locality:b ?polymorphism isprogcmd c | VernacPolymorphic (b, c) when polymorphism = None -> aux ?locality ~polymorphism:b isprogcmd c - | VernacPolymorphic (b, c) -> CErrors.error "Polymorphism specified twice" - | VernacLocal _ -> CErrors.error "Locality specified twice" + | VernacPolymorphic (b, c) -> user_err Pp.(str "Polymorphism specified twice") + | VernacLocal _ -> user_err Pp.(str "Locality specified twice") | VernacFail v -> with_fail true (fun () -> aux ?locality ?polymorphism isprogcmd v) | VernacTimeout (n,v) -> @@ -2228,8 +2197,8 @@ let interp ?(verbosely=true) ?proof (loc,c) = try vernac_timeout begin fun () -> if verbosely - then Flags.verbosely (interp ?proof ~loc locality poly) c - else Flags.silently (interp ?proof ~loc locality poly) c; + then Flags.verbosely (interp ?proof ?loc locality poly) c + else Flags.silently (interp ?proof ?loc locality poly) c; if orig_program_mode || not !Flags.program_mode || isprogcmd then Flags.program_mode := orig_program_mode; ignore (Flags.use_polymorphic_flag ()) @@ -2241,7 +2210,7 @@ let interp ?(verbosely=true) ?proof (loc,c) = | e -> CErrors.noncritical e) -> let e = CErrors.push reraise in - let e = locate_if_not_already loc e in + let e = locate_if_not_already ?loc e in let () = restore_timeout () in Flags.program_mode := orig_program_mode; ignore (Flags.use_polymorphic_flag ()); diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index fb2899515f..f75f7656db 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -18,7 +18,7 @@ val vernac_require : val interp : ?verbosely:bool -> ?proof:Proof_global.closed_proof -> - Loc.t * Vernacexpr.vernac_expr -> unit + Vernacexpr.vernac_expr Loc.located -> unit (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name |