diff options
304 files changed, 6642 insertions, 2542 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 65a8a0cb88..108ecb5a04 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -9,7 +9,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2018-11-08-V1" + CACHEKEY: "bionic_coq-V2018-12-14-V1" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -89,18 +89,37 @@ after_script: - set +e +# Template for building Coq + stdlib, typical use: overload the switch .dune-template: &dune-template - dependencies: [] stage: build + dependencies: [] + script: + - set -e + - make -f Makefile.dune world + - set +e + variables: + OPAM_SWITCH: edge artifacts: name: "$CI_JOB_NAME" paths: - _build/ expire_in: 1 week + +.dune-ci-template: &dune-ci-template + stage: test + dependencies: + - build:egde:dune:dev script: - set -e + - echo 'start:coq.test' - make -f Makefile.dune "$DUNE_TARGET" + - echo 'end:coq.test' - set +e + variables: &dune-ci-template-vars + OPAM_SWITCH: edge + artifacts: &dune-ci-template-artifacts + name: "$CI_JOB_NAME" + expire_in: 1 month # every non build job must set dependencies otherwise all build # artifacts are used together and we may get some random Coq. To that @@ -221,9 +240,13 @@ build:edge+flambda: build:egde:dune:dev: <<: *dune-template + +build:base+async: + <<: *build-template + stage: test variables: - OPAM_SWITCH: edge - DUNE_TARGET: world + COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" + COQUSERFLAGS: "-async-proofs on" windows64: <<: *windows-template @@ -284,15 +307,23 @@ doc:refman: dependencies: - build:base +doc:refman:dune: + <<: *dune-ci-template + variables: + <<: *dune-ci-template-vars + DUNE_TARGET: refman-html + artifacts: + <<: *dune-ci-template-artifacts + paths: + - _build/default/doc/sphinx_build/html + doc:ml-api:odoc: - stage: test - dependencies: - - build:egde:dune:dev - script: make -f Makefile.dune apidoc + <<: *dune-ci-template variables: - OPAM_SWITCH: edge + <<: *dune-ci-template-vars + DUNE_TARGET: apidoc artifacts: - name: "$CI_JOB_NAME" + <<: *dune-ci-template-artifacts paths: - _build/default/_doc/ @@ -336,6 +367,57 @@ test-suite:egde:dune:dev: paths: - _build/default/test-suite/logs +test-suite:edge+trunk+make: + stage: test + dependencies: [] + script: + - opam switch create 4.08.0 --empty + - eval $(opam env) + - opam repo add ocaml-pr https://github.com/ocaml/ocaml-pr-repository.git + - opam update + - opam install ocaml-variants=4.08.0 num + - eval $(opam env) + # We avoid problems with warnings: + - ./configure -profile devel -warn-error no + - make -j "$NJOBS" world + - make -j "$NJOBS" test-suite UNIT_TESTS= + variables: + OPAM_SWITCH: edge + artifacts: + name: "$CI_JOB_NAME.logs" + when: always + paths: + - test-suite/logs + expire_in: 1 week + allow_failure: true + +test-suite:edge+trunk+dune: + stage: test + dependencies: [] + script: + - opam switch create 4.08.0 --empty + - eval $(opam env) + - opam repo add ocaml-pr https://github.com/ocaml/ocaml-pr-repository.git + - opam update + - opam install ocaml-variants=4.08.0 num + - opam pin add dune --dev # ounit lablgtk conf-gtksourceview + - opam install dune + - eval $(opam env) + # We use the release profile to avoid problems with warnings + - make -f Makefile.dune trunk + - export COQ_UNIT_TEST=noop + - dune runtest --profile=ocaml408 + variables: + OPAM_SWITCH: edge + artifacts: + name: "$CI_JOB_NAME.logs" + when: always + paths: + - _build/log + - _build/default/test-suite/logs + expire_in: 1 week + allow_failure: true + validate:base: <<: *validate-template dependencies: diff --git a/.merlin.in b/.merlin.in index 4d646842d8..fa3473765d 100644 --- a/.merlin.in +++ b/.merlin.in @@ -1,4 +1,4 @@ -FLG -rectypes -thread -safe-string -w +a-4-9-27-41-42-44-45-48-50 +FLG -rectypes -thread -safe-string -w +a-4-9-27-41-42-44-45-48 S clib B clib diff --git a/CHANGES.md b/CHANGES.md index 75a29de8e9..4fafb9a18a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -46,6 +46,9 @@ Notations `Bind Scope`, `Delimit Scope`, `Undelimit Scope`, or `Notation` is deprecated. +- New command `String Notation` to register string syntax for custom + inductive types. + Plugins - The quote plugin (https://coq.inria.fr/distrib/V8.8.1/refman/proof-engine/detailed-tactic-examples.html#quote) @@ -85,6 +88,8 @@ Vernacular commands - The `Automatic Introduction` option has been removed and is now the default. +- `Arguments` now accepts names for arguments provided with `extra_scopes`. + Tools - The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: diff --git a/META.coq.in b/META.coq.in index c2d3f85b9f..159984d87a 100644 --- a/META.coq.in +++ b/META.coq.in @@ -459,28 +459,16 @@ package "plugins" ( archive(native) = "int31_syntax_plugin.cmx" ) - package "asciisyntax" ( + package "string_notation" ( - description = "Coq asciisyntax plugin" + description = "Coq string_notation plugin" version = "8.10" requires = "" directory = "syntax" - archive(byte) = "ascii_syntax_plugin.cmo" - archive(native) = "ascii_syntax_plugin.cmx" - ) - - package "stringsyntax" ( - - description = "Coq stringsyntax plugin" - version = "8.10" - - requires = "coq.plugins.asciisyntax" - directory = "syntax" - - archive(byte) = "string_syntax_plugin.cmo" - archive(native) = "string_syntax_plugin.cmx" + archive(byte) = "string_notation_plugin.cmo" + archive(native) = "string_notation_plugin.cmx" ) package "derive" ( diff --git a/Makefile.build b/Makefile.build index ec9b81dba4..34d7ce42f7 100644 --- a/Makefile.build +++ b/Makefile.build @@ -44,6 +44,9 @@ NO_RECALC_DEPS ?= # Non-empty runs the checker on all produced .vo files: VALIDATE ?= +# When non-empty, passed as extra arguments to coqtop/coqc: +COQUSERFLAGS ?= + # Output file names for timed builds TIME_OF_BUILD_FILE ?= time-of-build.log TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log @@ -191,7 +194,7 @@ TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) # the output format of the unix command time. For instance: # TIME="%C (%U user, %S sys, %e total, %M maxres)" -COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) +COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) $(COQUSERFLAGS) BOOTCOQC=$(TIMER) $(COQTOPBEST) -boot $(COQOPTS) -compile LOCALINCLUDES=$(addprefix -I ,$(SRCDIRS)) @@ -572,11 +575,11 @@ module Gramext = Gramlib__Gramext \ module Grammar = Gramlib__Grammar" > $@ gramlib/.pack/gramlib__P%: gramlib/p% | gramlib/.pack - cp -a $< $@ - sed -e "1i # 1 \"$<\"" -i $@ + printf '# 1 "%s"\n' $< > $@ + cat $< >> $@ gramlib/.pack/gramlib__G%: gramlib/g% | gramlib/.pack - cp -a $< $@ - sed -e "1i # 1 \"$<\"" -i $@ + printf '# 1 "%s"\n' $< > $@ + cat $< >> $@ # Specific rules for gramlib to pack it Dune / OCaml 4.08 style GRAMOBJS=$(addsuffix .cmo, $(GRAMFILES)) diff --git a/Makefile.ci b/Makefile.ci index 956e3ee58f..2df6a792b6 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -60,6 +60,7 @@ ci-math-classes: ci-bignums ci-corn: ci-math-classes +ci-simple-io: ci-ext-lib ci-quickchick: ci-ext-lib ci-simple-io ci-formal-topology: ci-corn diff --git a/Makefile.common b/Makefile.common index a59fbe676e..9f7ed9d46e 100644 --- a/Makefile.common +++ b/Makefile.common @@ -140,9 +140,8 @@ RTAUTOCMO:=plugins/rtauto/rtauto_plugin.cmo SYNTAXCMO:=$(addprefix plugins/syntax/, \ r_syntax_plugin.cmo \ int31_syntax_plugin.cmo \ - ascii_syntax_plugin.cmo \ - string_syntax_plugin.cmo \ - numeral_notation_plugin.cmo) + numeral_notation_plugin.cmo \ + string_notation_plugin.cmo) DERIVECMO:=plugins/derive/derive_plugin.cmo LTACCMO:=plugins/ltac/ltac_plugin.cmo plugins/ltac/tauto_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo diff --git a/Makefile.dune b/Makefile.dune index 2293c69c38..22e3271260 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -1,7 +1,10 @@ # -*- mode: makefile -*- # Dune Makefile for Coq -.PHONY: help voboot states world watch check quickbyte quickopt test-suite release apidoc ocheck ireport clean +.PHONY: help voboot states world watch check # Main developer targets +.PHONY: quickbyte quickopt # Partial / quick developer targets +.PHONY: test-suite refman-html apidoc release # Accesory targets +.PHONY: ocheck trunk ireport clean # Maintenance targets # use DUNEOPT=--display=short for a more verbose build # DUNEOPT=--display=short @@ -10,16 +13,22 @@ BUILD_CONTEXT=_build/default help: @echo "Welcome to Coq's Dune-based build system. Targets are:" - @echo " - states: build a minimal functional coqtop" - @echo " - world: build all binaries and libraries" - @echo " - watch: build all binaries and libraries [continuous build]" - @echo " - check: build all ML files as fast as possible [requires Dune >= 1.5.0]" - @echo " - quickbyte: build main ML files [coqtop + plugins + ide + printers] using the bytecode compiler" - @echo " - quickopt: build main ML files [coqtop + plugins + ide + printers] using the optimizing compiler" - @echo " - test-suite: run Coq's test suite" - @echo " - release: build Coq in release mode" - @echo " - apidoc: build ML API documentation" + @echo "" + @echo " - states: build a minimal functional coqtop" + @echo " - world: build all binaries and libraries" + @echo " - watch: build all binaries and libraries [continuous build]" + @echo " - check: build all ML files as fast as possible" + @echo "" + @echo " - quickbyte: build main ML files [coqtop + plugins + ide + printers] using the bytecode compiler" + @echo " - quickopt: build main ML files [coqtop + plugins + ide + printers] using the optimizing compiler" + @echo "" + @echo " - test-suite: run Coq's test suite" + @echo " - refman-html: build Coq's reference manual [HTML version]" + @echo " - apidoc: build ML API documentation" + @echo " - release: build Coq in release mode" + @echo "" @echo " - ocheck: build for all supported OCaml versions [requires OPAM]" + @echo " - trunk: build with a configuration compatible with OCaml trunk" @echo " - ireport: build with optimized flambda settings and emit an inline report" @echo " - clean: remove build directory and autogenerated files" @echo " - help: show this message" @@ -55,15 +64,23 @@ quickopt: voboot test-suite: voboot dune runtest $(DUNEOPT) -release: voboot - dune build $(DUNEOPT) -p coq +refman-html: voboot + dune build @refman-html apidoc: voboot dune build $(DUNEOPT) @doc +release: voboot + dune build $(DUNEOPT) -p coq + ocheck: voboot dune build $(DUNEOPT) @install --workspace=dev/dune-workspace.all +trunk: + dune build $(DUNEOPT) --profile=ocaml408 @vodeps + dune exec coq_dune $(BUILD_CONTEXT)/.vfiles.d + dune build $(DUNEOPT) --profile=ocaml408 coq.install coqide-server.install + ireport: dune clean dune build $(DUNEOPT) @vodeps --profile=ireport diff --git a/checker/analyze.ml b/checker/analyze.ml index 7047d8a149..63324bff20 100644 --- a/checker/analyze.ml +++ b/checker/analyze.ml @@ -396,7 +396,7 @@ let parse_string s = PString.parse (s, ref 0) let instantiate (p, mem) = let len = LargeArray.length mem in let ans = LargeArray.make len (Obj.repr 0) in - (** First pass: initialize the subobjects *) + (* First pass: initialize the subobjects *) for i = 0 to len - 1 do let obj = match LargeArray.get mem i with | Struct (tag, blk) -> Obj.new_block tag (Array.length blk) @@ -408,9 +408,9 @@ let instantiate (p, mem) = | Int n -> Obj.repr n | Ptr p -> LargeArray.get ans p | Atm tag -> Obj.new_block tag 0 - | Fun _ -> assert false (** We shouldn't serialize closures *) + | Fun _ -> assert false (* We shouldn't serialize closures *) in - (** Second pass: set the pointers *) + (* Second pass: set the pointers *) for i = 0 to len - 1 do match LargeArray.get mem i with | Struct (_, blk) -> diff --git a/checker/analyze.mli b/checker/analyze.mli index 9c837643fa..d7770539df 100644 --- a/checker/analyze.mli +++ b/checker/analyze.mli @@ -30,6 +30,7 @@ sig type t val input_byte : t -> int (** Input a single byte *) + val input_binary_int : t -> int (** Input a big-endian 31-bits signed integer *) end diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index 4e026d6f60..c823db956d 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -8,264 +8,155 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Sorts -open Pp open Declarations open Environ open Names -open CErrors open Univ open Util -open Constr -let check_kind env ar u = - match Constr.kind (snd (Reduction.dest_prod env ar)) with - | Sort (Sorts.Type u') when Univ.Universe.equal u' (Univ.Universe.make u) -> () - | _ -> failwith "not the correct sort" +[@@@ocaml.warning "+9+27"] -let check_polymorphic_arity env params par = - let pl = par.template_param_levels in - let rec check_p env pl params = - let open Context.Rel.Declaration in - match pl, params with - Some u::pl, LocalAssum (na,ty)::params -> - check_kind env ty u; - check_p (push_rel (LocalAssum (na,ty)) env) pl params - | None::pl,d::params -> check_p (push_rel d env) pl params - | [], _ -> () - | _ -> failwith "check_poly: not the right number of params" in - check_p env pl (List.rev params) +exception InductiveMismatch of MutInd.t * string -let conv_ctxt_prefix env (ctx1:rel_context) ctx2 = - let rec chk env rctx1 rctx2 = - let open Context.Rel.Declaration in - match rctx1, rctx2 with - (LocalAssum (_,ty1) as d1)::rctx1', LocalAssum (_,ty2)::rctx2' -> - Reduction.conv env ty1 ty2; - chk (push_rel d1 env) rctx1' rctx2' - | (LocalDef (_,bd1,ty1) as d1)::rctx1', LocalDef (_,bd2,ty2)::rctx2' -> - Reduction.conv env ty1 ty2; - Reduction.conv env bd1 bd2; - chk (push_rel d1 env) rctx1' rctx2' - | [],_ -> () - | _ -> failwith "non convertible contexts" in - chk env (List.rev ctx1) (List.rev ctx2) +let check mind field b = if not b then raise (InductiveMismatch (mind,field)) -(* check information related to inductive arity *) -let typecheck_arity env params inds = - let nparamargs = Context.Rel.nhyps params in - let nparamdecls = Context.Rel.length params in - let check_arity arctxt = function - | RegularArity mar -> - let ar = mar.mind_user_arity in - let _ = Typeops.infer_type env ar in - Reduction.conv env (Term.it_mkProd_or_LetIn (Constr.mkSort mar.mind_sort) arctxt) ar; - ar - | TemplateArity par -> - check_polymorphic_arity env params par; - Term.it_mkProd_or_LetIn (Constr.mkSort(Sorts.Type par.template_level)) arctxt +let to_entry (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = + let open Entries in + let nparams = List.length mb.mind_params_ctxt in (* include letins *) + let mind_entry_record = match mb.mind_record with + | NotRecord -> None | FakeRecord -> Some None + | PrimRecord data -> Some (Some (Array.map pi1 data)) in - let env_arities = - Array.fold_left - (fun env_ar ind -> - let ar_ctxt = ind.mind_arity_ctxt in - let _ = Typeops.check_context env ar_ctxt in - conv_ctxt_prefix env params ar_ctxt; - (* Arities (with params) are typed-checked here *) - let arity = check_arity ar_ctxt ind.mind_arity in - (* mind_nrealargs *) - let nrealargs = Context.Rel.nhyps ar_ctxt - nparamargs in - if ind.mind_nrealargs <> nrealargs then - failwith "bad number of real inductive arguments"; - let nrealargs_ctxt = Context.Rel.length ar_ctxt - nparamdecls in - if ind.mind_nrealdecls <> nrealargs_ctxt then - failwith "bad length of real inductive arguments signature"; - (* We do not need to generate the universe of full_arity; if - later, after the validation of the inductive definition, - full_arity is used as argument or subject to cast, an - upper universe will be generated *) - let id = ind.mind_typename in - let env_ar' = push_rel (Context.Rel.Declaration.LocalAssum (Name id, arity)) env_ar in - env_ar') - env - inds in - let env_ar_par = push_rel_context params env_arities in - env_arities, env_ar_par - -(* Check that the subtyping information inferred for inductive types in the block is correct. *) -(* This check produces a value of the unit type if successful or raises an anomaly if check fails. *) -let check_subtyping cumi paramsctxt env arities = - let numparams = Context.Rel.nhyps paramsctxt in - (** In [env] we already have [ Var(0) ... Var(n-1) |- cst ] available. - We must produce the substitution σ : [ Var(i) -> Var (i + n) | 0 <= i < n] - and push the constraints [ Var(n) ... Var(2n - 1) |- cst{σ} ], together - with the cumulativity constraints [ cumul_cst ]. *) - let uctx = ACumulativityInfo.univ_context cumi in - let len = AUContext.size uctx in - let inst = Instance.of_array @@ Array.init len (fun i -> Level.var (i + len)) in - - let other_context = ACumulativityInfo.univ_context cumi in - let uctx_other = UContext.make (inst, AUContext.instantiate inst other_context) in - let cumul_cst = - Array.fold_left_i (fun i csts var -> - match var with - | Variance.Irrelevant -> csts - | Variance.Covariant -> Constraint.add (Level.var i,Le,Level.var (i+len)) csts - | Variance.Invariant -> Constraint.add (Level.var i,Eq,Level.var (i+len)) csts) - Constraint.empty (ACumulativityInfo.variance cumi) + let mind_entry_universes = match mb.mind_universes with + | Monomorphic_ind univs -> Monomorphic_ind_entry univs + | Polymorphic_ind auctx -> Polymorphic_ind_entry (AUContext.names auctx, AUContext.repr auctx) + | Cumulative_ind auctx -> + Cumulative_ind_entry (AUContext.names (ACumulativityInfo.univ_context auctx), + ACumulativityInfo.repr auctx) in - let env = Environ.push_context uctx_other env in - let env = Environ.add_constraints cumul_cst env in - let dosubst = Vars.subst_instance_constr inst in - (* process individual inductive types: *) - Array.iter (fun { mind_user_lc = lc; mind_arity = arity } -> - match arity with - | RegularArity { mind_user_arity = full_arity} -> - Indtypes.check_subtyping_arity_constructor env dosubst full_arity numparams true; - Array.iter (fun cnt -> Indtypes.check_subtyping_arity_constructor env dosubst cnt numparams false) lc - | TemplateArity _ -> - anomaly ~label:"check_subtyping" - Pp.(str "template polymorphism and cumulative polymorphism are not compatible") - ) arities - -(* An inductive definition is a "unit" if it has only one constructor - and that all arguments expected by this constructor are - logical, this is the case for equality, conjunction of logical properties -*) -let is_unit constrsinfos = - match constrsinfos with (* One info = One constructor *) - | [|constrinfos|] -> Univ.is_type0m_univ constrinfos - | [||] -> (* type without constructors *) true - | _ -> false - -let small_unit constrsinfos = - let issmall = Array.for_all Univ.is_small_univ constrsinfos - and isunit = is_unit constrsinfos in - issmall, isunit - -let all_sorts = [InProp;InSet;InType] -let small_sorts = [InProp;InSet] -let logical_sorts = [InProp] - -let allowed_sorts issmall isunit s = - match Sorts.family s with - (* Type: all elimination allowed *) - | InType -> all_sorts - - (* Small Set is predicative: all elimination allowed *) - | InSet when issmall -> all_sorts + let mind_entry_inds = Array.map_to_list (fun ind -> + let mind_entry_arity, mind_entry_template = match ind.mind_arity with + | RegularArity ar -> + let ctx, arity = Term.decompose_prod_n_assum nparams ar.mind_user_arity in + ignore ctx; (* we will check that the produced user_arity is equal to the input *) + arity, false + | TemplateArity ar -> + let ctx = ind.mind_arity_ctxt in + let ctx = List.firstn (List.length ctx - nparams) ctx in + Term.mkArity (ctx, Sorts.sort_of_univ ar.template_level), true + in + { + mind_entry_typename = ind.mind_typename; + mind_entry_arity; + mind_entry_template; + mind_entry_consnames = Array.to_list ind.mind_consnames; + mind_entry_lc = Array.map_to_list (fun c -> + let ctx, c = Term.decompose_prod_n_assum nparams c in + ignore ctx; (* we will check that the produced user_lc is equal to the input *) + c + ) ind.mind_user_lc; + }) + mb.mind_packets + in + { + mind_entry_record; + mind_entry_finite = mb.mind_finite; + mind_entry_params = mb.mind_params_ctxt; + mind_entry_inds; + mind_entry_universes; + mind_entry_private = mb.mind_private; + } + +let check_arity env ar1 ar2 = match ar1, ar2 with + | RegularArity ar, RegularArity {mind_user_arity;mind_sort} -> + Constr.equal ar.mind_user_arity mind_user_arity && + Sorts.equal ar.mind_sort mind_sort + | TemplateArity ar, TemplateArity {template_param_levels;template_level} -> + List.equal (Option.equal Univ.Level.equal) ar.template_param_levels template_param_levels && + UGraph.check_leq (universes env) template_level ar.template_level + (* template_level is inferred by indtypes, so functor application can produce a smaller one *) + | (RegularArity _ | TemplateArity _), _ -> false + +(* Use [eq_ind_chk] because when we rebuild the recargs we have lost + the knowledge of who is the canonical version. + Try with to see test-suite/coqchk/include.v *) +let eq_recarg a1 a2 = match a1, a2 with + | Norec, Norec -> true + | Mrec i1, Mrec i2 -> eq_ind_chk i1 i2 + | Imbr i1, Imbr i2 -> eq_ind_chk i1 i2 + | (Norec | Mrec _ | Imbr _), _ -> false + +let eq_reloc_tbl = Array.equal (fun x y -> Int.equal (fst x) (fst y) && Int.equal (snd x) (snd y)) + +let check_packet env mind ind + { mind_typename; mind_arity_ctxt; mind_arity; mind_consnames; mind_user_lc; + mind_nrealargs; mind_nrealdecls; mind_kelim; mind_nf_lc; + mind_consnrealargs; mind_consnrealdecls; mind_recargs; mind_nb_constant; + mind_nb_args; mind_reloc_tbl } = + let check = check mind in + + ignore mind_typename; (* passed through *) + check "mind_arity_ctxt" (Context.Rel.equal Constr.equal ind.mind_arity_ctxt mind_arity_ctxt); + check "mind_arity" (check_arity env ind.mind_arity mind_arity); + ignore mind_consnames; (* passed through *) + check "mind_user_lc" (Array.equal Constr.equal ind.mind_user_lc mind_user_lc); + check "mind_nrealargs" Int.(equal ind.mind_nrealargs mind_nrealargs); + check "mind_nrealdecls" Int.(equal ind.mind_nrealdecls mind_nrealdecls); + check "mind_kelim" (List.equal Sorts.family_equal ind.mind_kelim mind_kelim); + + check "mind_nf_lc" (Array.equal Constr.equal ind.mind_nf_lc mind_nf_lc); + (* NB: here syntactic equality is not just an optimisation, we also + care about the shape of the terms *) + + check "mind_consnrealargs" (Array.equal Int.equal ind.mind_consnrealargs mind_consnrealargs); + check "mind_consnrealdecls" (Array.equal Int.equal ind.mind_consnrealdecls mind_consnrealdecls); + + check "mind_recargs" (Rtree.equal eq_recarg ind.mind_recargs mind_recargs); + + check "mind_nb_args" Int.(equal ind.mind_nb_args mind_nb_args); + check "mind_nb_constant" Int.(equal ind.mind_nb_constant mind_nb_constant); + check "mind_reloc_tbl" (eq_reloc_tbl ind.mind_reloc_tbl mind_reloc_tbl); - (* Large Set is necessarily impredicative: forbids large elimination *) - | InSet -> small_sorts + () - (* Unitary/empty Prop: elimination to all sorts are realizable *) - (* unless the type is large. If it is large, forbids large elimination *) - (* which otherwise allows simulating the inconsistent system Type:Type *) - | InProp when isunit -> if issmall then all_sorts else small_sorts +let check_same_record r1 r2 = match r1, r2 with + | NotRecord, NotRecord | FakeRecord, FakeRecord -> true + | PrimRecord r1, PrimRecord r2 -> + (* The kernel doesn't care about the names, we just need to check + that the saved types are correct. *) + Array.for_all2 (fun (_,_,tys1) (_,_,tys2) -> + Array.equal Constr.equal tys1 tys2) + r1 r2 + | (NotRecord | FakeRecord | PrimRecord _), _ -> false + +let check_inductive env mind mb = + let entry = to_entry mb in + let { mind_packets; mind_record; mind_finite; mind_ntypes; mind_hyps; + mind_nparams; mind_nparams_rec; mind_params_ctxt; mind_universes; + mind_private; mind_typing_flags; } + = + (* Locally set the oracle for further typechecking *) + let env = Environ.set_oracle env mb.mind_typing_flags.conv_oracle in + Indtypes.check_inductive env mind entry + in + let check = check mind in - (* Other propositions: elimination only to Prop *) - | InProp -> logical_sorts + Array.iter2 (check_packet env mind) mb.mind_packets mind_packets; + check "mind_record" (check_same_record mb.mind_record mind_record); + check "mind_finite" (mb.mind_finite == mind_finite); + check "mind_ntypes" Int.(equal mb.mind_ntypes mind_ntypes); + check "mind_hyps" (Context.Named.equal Constr.equal mb.mind_hyps mind_hyps); + check "mind_nparams" Int.(equal mb.mind_nparams mind_nparams); -let check_predicativity env s small level = - match s, engagement env with - Type u, _ -> - (* let u' = fresh_local_univ () in *) - (* let cst = *) - (* merge_constraints (enforce_leq u u' empty_constraint) *) - (* (universes env) in *) - if not (UGraph.check_leq (universes env) level u) then - failwith "impredicative Type inductive type" - | Set, ImpredicativeSet -> () - | Set, _ -> - if not small then failwith "impredicative Set inductive type" - | Prop,_ -> () + check "mind_nparams_rec" (mb.mind_nparams_rec <= mind_nparams_rec); + (* module substitution can increase the real number of recursively + uniform parameters, so be tolerant and use [<=]. *) -let sort_of_ind = function - | RegularArity mar -> mar.mind_sort - | TemplateArity par -> Type par.template_level + check "mind_params_ctxt" (Context.Rel.equal Constr.equal mb.mind_params_ctxt mind_params_ctxt); + ignore mind_universes; (* Indtypes did the necessary checking *) + ignore mind_private; (* passed through Indtypes *) -let compute_elim_sorts env_ar params arity lc = - let inst = Context.Rel.to_extended_list Constr.mkRel 0 params in - let env_params = push_rel_context params env_ar in - let lc = Array.map - (fun c -> - Reduction.hnf_prod_applist env_params (Vars.lift (Context.Rel.length params) c) inst) - lc in - let s = sort_of_ind arity in - let infos = Array.map (Indtypes.infos_and_sort env_params) lc in - let (small,unit) = small_unit infos in - (* We accept recursive unit types... *) - (* compute the max of the sorts of the products of the constructor type *) - let min = if Array.length lc > 1 then Universe.type0 else Universe.type0m in - let level = Array.fold_left (fun max l -> Universe.sup max l) min infos in - check_predicativity env_ar s small level; - allowed_sorts small unit s + ignore mind_typing_flags; + (* TODO non oracle flags *) -let typecheck_one_inductive env params mip = - (* mind_typename and mind_consnames not checked *) - (* mind_reloc_tbl, mind_nb_constant, mind_nb_args not checked (VM) *) - (* mind_arity_ctxt, mind_arity, mind_nrealargs DONE (typecheck_arity) *) - (* mind_user_lc *) - let _ = Array.map (Typeops.infer_type env) mip.mind_user_lc in - (* mind_nf_lc *) - let _ = Array.map (Typeops.infer_type env) mip.mind_nf_lc in - Array.iter2 (Reduction.conv env) mip.mind_nf_lc mip.mind_user_lc; - (* mind_consnrealdecls *) - let check_cons_args c n = - let ctx,_ = Term.decompose_prod_assum c in - if n <> Context.Rel.length ctx - Context.Rel.length params then - failwith "bad number of real constructor arguments" in - Array.iter2 check_cons_args mip.mind_nf_lc mip.mind_consnrealdecls; - (* mind_kelim: checked by positivity criterion ? *) - let sorts = - compute_elim_sorts env params mip.mind_arity mip.mind_nf_lc in - let reject_sort s = not (List.mem_f Sorts.family_equal s sorts) in - if List.exists reject_sort mip.mind_kelim then - failwith "elimination not allowed"; - (* mind_recargs: checked by positivity criterion *) - () - -let check_inductive env kn mib = - Flags.if_verbose Feedback.msg_notice (str " checking mutind block: " ++ MutInd.print kn); - (* check mind_constraints: should be consistent with env *) - let env0 = - match mib.mind_universes with - | Monomorphic_ind _ -> env - | Polymorphic_ind auctx -> - let uctx = Univ.AUContext.repr auctx in - Environ.push_context uctx env - | Cumulative_ind cumi -> - let uctx = Univ.AUContext.repr (Univ.ACumulativityInfo.univ_context cumi) in - Environ.push_context uctx env - in - (** Locally set the oracle for further typechecking *) - let env0 = Environ.set_oracle env0 mib.mind_typing_flags.conv_oracle in - (* check mind_record : TODO ? check #constructor = 1 ? *) - (* check mind_finite : always OK *) - (* check mind_ntypes *) - if Array.length mib.mind_packets <> mib.mind_ntypes then - user_err Pp.(str "not the right number of packets"); - (* check mind_params_ctxt *) - let params = mib.mind_params_ctxt in - let _ = Typeops.check_context env0 params in - (* check mind_nparams *) - if Context.Rel.nhyps params <> mib.mind_nparams then - user_err Pp.(str "number the right number of parameters"); - (* mind_packets *) - (* - check arities *) - let env_ar, env_ar_par = typecheck_arity env0 params mib.mind_packets in - (* - check constructor types *) - Array.iter (typecheck_one_inductive env_ar params) mib.mind_packets; - (* check the inferred subtyping relation *) - let () = - match mib.mind_universes with - | Monomorphic_ind _ | Polymorphic_ind _ -> () - | Cumulative_ind acumi -> - check_subtyping acumi params env_ar mib.mind_packets - in - (* check mind_nparams_rec: positivity condition *) - let packets = Array.map (fun p -> (p.mind_typename, Array.to_list p.mind_consnames, p.mind_user_lc, (p.mind_arity_ctxt,p.mind_arity))) mib.mind_packets in - let _ = Indtypes.check_positivity ~chkpos:true kn env_ar_par mib.mind_params_ctxt mib.mind_finite packets in - (* check mind_equiv... *) - (* Now we can add the inductive *) - add_mind kn mib env + add_mind mind mb env diff --git a/checker/checkInductive.mli b/checker/checkInductive.mli index 17ca0d4583..ab54190967 100644 --- a/checker/checkInductive.mli +++ b/checker/checkInductive.mli @@ -8,10 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(*i*) open Names open Environ -(*i*) + +exception InductiveMismatch of MutInd.t * string +(** Some field of the inductive is different from what the kernel infers. *) (*s The following function does checks on inductive declarations. *) diff --git a/checker/checker.ml b/checker/checker.ml index da6a61de1c..167258f8bb 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -302,6 +302,10 @@ let explain_exn = function (* let ctx = Check.get_env() in hov 0 (str "Error:" ++ spc () ++ Himsg.explain_inductive_error ctx e)*) + + | CheckInductive.InductiveMismatch (mind,field) -> + hov 0 (MutInd.print mind ++ str ": field " ++ str field ++ str " is incorrect.") + | Assert_failure (s,b,e) -> hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++ (if s = "" then mt () diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index b83fe831bb..086dd17e39 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -10,10 +10,10 @@ open Environ let check_constant_declaration env kn cb = Flags.if_verbose Feedback.msg_notice (str " checking cst:" ++ Constant.print kn); - (** Locally set the oracle for further typechecking *) + (* Locally set the oracle for further typechecking *) let oracle = env.env_typing_flags.conv_oracle in let env = Environ.set_oracle env cb.const_typing_flags.conv_oracle in - (** [env'] contains De Bruijn universe variables *) + (* [env'] contains De Bruijn universe variables *) let poly, env' = match cb.const_universes with | Monomorphic_const ctx -> false, push_context_set ~strict:true ctx env @@ -40,7 +40,7 @@ let check_constant_declaration env kn cb = if poly then add_constant kn cb env else add_constant kn cb env' in - (** Reset the value of the oracle *) + (* Reset the value of the oracle *) Environ.set_oracle env oracle (** {6 Checking modules } *) diff --git a/checker/values.ml b/checker/values.ml index dcb2bca81a..1afe764ca4 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -93,9 +93,9 @@ let v_cons = v_tuple "constructor" [|v_ind;Int|] (** kernel/univ *) - +let v_level_global = v_tuple "Level.Global.t" [|v_dp;Int|] let v_raw_level = v_sum "raw_level" 2 (* Prop, Set *) - [|(*Level*)[|Int;v_dp|]; (*Var*)[|Int|]|] + [|(*Level*)[|v_level_global|]; (*Var*)[|Int|]|] let v_level = v_tuple "level" [|Int;v_raw_level|] let v_expr = v_tuple "levelexpr" [|v_level;Int|] let v_univ = List v_expr @@ -168,8 +168,10 @@ let v_section_ctxt = v_enum "emptylist" 1 (** kernel/mod_subst *) +let v_univ_abstracted v = v_tuple "univ_abstracted" [|v;v_abs_context|] + let v_delta_hint = - v_sum "delta_hint" 0 [|[|Int; Opt (v_pair v_abs_context v_constr)|];[|v_kn|]|] + v_sum "delta_hint" 0 [|[|Int; Opt (v_univ_abstracted v_constr)|];[|v_kn|]|] let v_resolver = v_tuple "delta_resolver" diff --git a/checker/votour.ml b/checker/votour.ml index 1ea0de456e..3c088b59b5 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -366,7 +366,7 @@ let visit_vo f = |] in let repr = if Sys.word_size = 64 then (module ReprMem : S) else (module ReprObj : S) - (** On 32-bit machines, representation may exceed the max size of arrays *) + (* On 32-bit machines, representation may exceed the max size of arrays *) in let module Repr = (val repr : S) in let module Visit = Visit(Repr) in diff --git a/clib/backtrace.ml b/clib/backtrace.ml index 27ed6fbf72..64faa5fd2e 100644 --- a/clib/backtrace.ml +++ b/clib/backtrace.ml @@ -87,8 +87,8 @@ let get_backtrace e = let add_backtrace e = if !is_recording then - (** This must be the first function call, otherwise the stack may be - destroyed *) + (* This must be the first function call, otherwise the stack may be + destroyed *) let current = get_exception_backtrace () in let info = Exninfo.info e in begin match current with diff --git a/clib/bigint.mli b/clib/bigint.mli index ac66b41fb7..88297c353d 100644 --- a/clib/bigint.mli +++ b/clib/bigint.mli @@ -25,6 +25,7 @@ val one : bigint val two : bigint val div2_with_rest : bigint -> bigint * bool (** true=odd; false=even *) + val add_1 : bigint -> bigint val sub_1 : bigint -> bigint val mult_2 : bigint -> bigint diff --git a/clib/cArray.ml b/clib/cArray.ml index c3a693ff16..e0a1859184 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -451,7 +451,7 @@ struct end done; if !i < len then begin - (** The array is not the same as the original one *) + (* The array is not the same as the original one *) let ans : 'a array = Array.copy ar in let v = match !temp with None -> assert false | Some x -> x in Array.unsafe_set ans !i v; @@ -483,7 +483,7 @@ struct end done; if !i < len then begin - (** The array is not the same as the original one *) + (* The array is not the same as the original one *) let ans : 'a array = Array.copy ar in let v = match !temp with None -> assert false | Some x -> x in Array.unsafe_set ans !i v; @@ -504,7 +504,7 @@ struct let i = ref 0 in let break = ref true in let r = ref accu in - (** This variable is never accessed unset *) + (* This variable is never accessed unset *) let temp = ref None in while !break && (!i < len) do let v = Array.unsafe_get ar !i in @@ -539,7 +539,7 @@ struct let i = ref 0 in let break = ref true in let r = ref accu in - (** This variable is never accessed unset *) + (* This variable is never accessed unset *) let temp = ref None in while !break && (!i < len) do let v = Array.unsafe_get ar !i in @@ -620,7 +620,7 @@ struct end done; if !i < len then begin - (** The array is not the same as the original one *) + (* The array is not the same as the original one *) let ans : 'a array = Array.copy ar in let v = match !temp with None -> assert false | Some x -> x in Array.unsafe_set ans !i v; diff --git a/clib/cString.mli b/clib/cString.mli index a73c2729d0..364b6a34b1 100644 --- a/clib/cString.mli +++ b/clib/cString.mli @@ -31,8 +31,8 @@ sig (** [implode [s1; ...; sn]] returns [s1 ^ ... ^ sn] *) val strip : string -> string - (** Alias for [String.trim] *) [@@ocaml.deprecated "Use [trim]"] + (** Alias for [String.trim] *) val drop_simple_quotes : string -> string (** Remove the eventual first surrounding simple quotes of a string. *) @@ -53,8 +53,8 @@ sig (** Generate the ordinal number in English. *) val split : char -> string -> string list - (** [split c s] alias of [String.split_on_char] *) [@@ocaml.deprecated "Use [split_on_char]"] + (** [split c s] alias of [String.split_on_char] *) val is_sub : string -> string -> int -> bool (** [is_sub p s off] tests whether [s] contains [p] at offset [off]. *) diff --git a/clib/exninfo.ml b/clib/exninfo.ml index 2d13049882..78ebd81f7e 100644 --- a/clib/exninfo.ml +++ b/clib/exninfo.ml @@ -89,18 +89,18 @@ let find_and_remove () = let info e = let (src, data) = find_and_remove () in if src == e then - (** Slightly unsound, some exceptions may not be unique up to pointer - equality. Though, it should be quite exceptional to be in a situation - where the following holds: - - 1. An argument-free exception is raised through the enriched {!raise}; - 2. It is not captured by any enriched with-clause (which would reset - the current data); - 3. The same exception is raised through the standard raise, accessing - the wrong data. + (* Slightly unsound, some exceptions may not be unique up to pointer + equality. Though, it should be quite exceptional to be in a situation + where the following holds: + + 1. An argument-free exception is raised through the enriched {!raise}; + 2. It is not captured by any enriched with-clause (which would reset + the current data); + 3. The same exception is raised through the standard raise, accessing + the wrong data. . *) data else - (** Mismatch: the raised exception is not the one stored, either because the - previous raise was not instrumented, or because something went wrong. *) + (* Mismatch: the raised exception is not the one stored, either because the + previous raise was not instrumented, or because something went wrong. *) Store.empty diff --git a/clib/hMap.mli b/clib/hMap.mli index b26d0e04e3..ab2a6bbf15 100644 --- a/clib/hMap.mli +++ b/clib/hMap.mli @@ -13,6 +13,7 @@ sig type t val compare : t -> t -> int (** Total ordering *) + val hash : t -> int (** Hashing function compatible with [compare], i.e. [compare x y = 0] implies [hash x = hash y]. *) diff --git a/clib/hashcons.mli b/clib/hashcons.mli index 223dd2a4d2..e97708cdf3 100644 --- a/clib/hashcons.mli +++ b/clib/hashcons.mli @@ -29,17 +29,21 @@ module type HashconsedType = type t (** Type of objects to hashcons. *) + type u (** Type of hashcons functions for the sub-structures contained in [t]. Usually a tuple of functions. *) + val hashcons : u -> t -> t (** The actual hashconsing function, using its fist argument to recursively hashcons substructures. It should be compatible with [eq], that is [eq x (hashcons f x) = true]. *) + val eq : t -> t -> bool (** A comparison function. It is allowed to use physical equality on the sub-terms hashconsed by the [hashcons] function, but it should be insensible to shallow copy of the compared object. *) + val hash : t -> int (** A hash function passed to the underlying hashtable structure. [hash] should be compatible with [eq], i.e. if [eq x y = true] then @@ -50,14 +54,19 @@ module type S = sig type t (** Type of objects to hashcons. *) + type u (** Type of hashcons functions for the sub-structures contained in [t]. *) + type table (** Type of hashconsing tables *) + val generate : u -> table (** This create a hashtable of the hashconsed objects. *) + val hcons : table -> t -> t (** Perform the hashconsing of the given object within the table. *) + val stats : table -> Hashset.statistics (** Recover statistics of the hashconsing table. *) end diff --git a/clib/hashset.mli b/clib/hashset.mli index 0699d4e848..6ed93d5fe7 100644 --- a/clib/hashset.mli +++ b/clib/hashset.mli @@ -31,18 +31,23 @@ type statistics = { module type S = sig type elt (** Type of hashsets elements. *) + type t (** Type of hashsets. *) + val create : int -> t (** [create n] creates a fresh hashset with initial size [n]. *) + val clear : t -> unit (** Clear the contents of a hashset. *) + val repr : int -> elt -> t -> elt (** [repr key constr set] uses [key] to look for [constr] in the hashet [set]. If [constr] is in [set], returns the specific representation that is stored in [set]. Otherwise, [constr] is stored in [set] and will be used as the canonical representation of this value in the future. *) + val stats : t -> statistics (** Recover statistics on the table. *) end diff --git a/clib/int.ml b/clib/int.ml index 3ae836aec9..fa21379565 100644 --- a/clib/int.ml +++ b/clib/int.ml @@ -114,8 +114,8 @@ struct let () = t := DSet (i, old, res) in res else match v with - | None -> t (** Nothing to do! *) - | Some _ -> (** we must resize *) + | None -> t (* Nothing to do! *) + | Some _ -> (* we must resize *) let nlen = next len (succ i) in let nlen = min nlen Sys.max_array_length in let () = assert (i < nlen) in diff --git a/clib/int.mli b/clib/int.mli index 76aecf057b..e02ca90916 100644 --- a/clib/int.mli +++ b/clib/int.mli @@ -33,10 +33,13 @@ sig type 'a t (** Persistent, auto-resizable arrays. The [get] and [set] functions never fail whenever the index is between [0] and [Sys.max_array_length - 1]. *) + val empty : int -> 'a t (** The empty array, with a given starting size. *) + val get : 'a t -> int -> 'a option (** Get a value at the given index. Returns [None] if undefined. *) + val set : 'a t -> int -> 'a option -> 'a t (** Set/unset a value at the given index. *) end diff --git a/clib/segmenttree.ml b/clib/segmenttree.ml index 24243b7a99..c3f1b44ef4 100644 --- a/clib/segmenttree.ml +++ b/clib/segmenttree.ml @@ -34,16 +34,16 @@ type elt = int integers which are _not_ in the set of keys handled by the tree. On leaves, a domain represents the st of integers which are in the set of keys. *) -type domain = - (** On internal nodes, a domain [Interval (a, b)] represents - the interval [a + 1; b - 1]. On leaves, it represents [a; b]. - We always have [a] <= [b]. *) +type domain = | Interval of elt * elt - (** On internal node or root, a domain [Universe] represents all - the integers. When the tree is not a trivial root, - [Universe] has no interpretation on leaves. (The lookup - function should never reach the leaves.) *) + (** On internal nodes, a domain [Interval (a, b)] represents + the interval [a + 1; b - 1]. On leaves, it represents [a; b]. + We always have [a] <= [b]. *) | Universe + (** On internal node or root, a domain [Universe] represents all + the integers. When the tree is not a trivial root, + [Universe] has no interpretation on leaves. (The lookup + function should never reach the leaves.) *) (** We use an array to store the almost complete tree. This array contains at least one element. *) @@ -71,26 +71,26 @@ let make segments = let tree = create nsegments (Universe, None) in let leaves_offset = (1 lsl (log2n nsegments)) - 1 in - (** The algorithm proceeds in two steps using an intermediate tree - to store minimum and maximum of each subtree as annotation of - the node. *) + (* The algorithm proceeds in two steps using an intermediate tree + to store minimum and maximum of each subtree as annotation of + the node. *) - (** We start from leaves: the last level of the tree is initialized - with the given segments... *) - list_iteri + (* We start from leaves: the last level of the tree is initialized + with the given segments... *) + list_iteri (fun i ((start, stop), value) -> let k = leaves_offset + i in let i = Interval (start, stop) in tree.(k) <- (i, Some i)) segments; - (** ... the remaining leaves are initialized with neutral information. *) + (* ... the remaining leaves are initialized with neutral information. *) for k = leaves_offset + nsegments to Array.length tree -1 do tree.(k) <- (Universe, Some Universe) done; - (** We traverse the tree bottom-up and compute the interval and - annotation associated to each node from the annotations of its - children. *) + (* We traverse the tree bottom-up and compute the interval and + annotation associated to each node from the annotations of its + children. *) for k = leaves_offset - 1 downto 0 do let node, annotation = match value_of (left_child k) tree, value_of (right_child k) tree with @@ -104,7 +104,7 @@ let make segments = tree.(k) <- (node, Some annotation) done; - (** Finally, annotation are replaced with the image related to each leaf. *) + (* Finally, annotation are replaced with the image related to each leaf. *) let final_tree = Array.mapi (fun i (segment, value) -> (segment, None)) tree in diff --git a/clib/trie.ml b/clib/trie.ml index ea43e9e0bd..96de2b920c 100644 --- a/clib/trie.ml +++ b/clib/trie.ml @@ -51,7 +51,7 @@ let next (Node (_,m)) lbl = T_codom.find lbl m let get (Node (hereset,_)) = hereset let labels (Node (_,m)) = - (** FIXME: this is order-dependent. Try to find a more robust presentation? *) + (* FIXME: this is order-dependent. Try to find a more robust presentation? *) List.rev (T_codom.fold (fun x _ acc -> x::acc) m []) let is_empty_node (Node(a,b)) = (X.is_nil a) && (T_codom.is_empty b) diff --git a/config/dune b/config/dune index cc993b97c9..c146e7df67 100644 --- a/config/dune +++ b/config/dune @@ -7,7 +7,7 @@ ; Dune doesn't use configure's output, but it is still necessary for ; some Coq files to work; will be fixed in the future. (rule - (targets coq_config.ml Makefile) + (targets coq_config.ml coq_config.py Makefile) (mode fallback) (deps %{project_root}/configure.ml %{project_root}/dev/ocamldebug-coq.run (env_var COQ_CONFIGURE_PREFIX)) (action (chdir %{project_root} (run %{ocaml} configure.ml -no-ask -native-compiler no)))) diff --git a/configure.ml b/configure.ml index 2559e0a473..33f76078cf 100644 --- a/configure.ml +++ b/configure.ml @@ -610,10 +610,9 @@ let camltag = match caml_version_list with 44: "open" shadowing already defined identifier: too common, especially when some are aliases 45: "open" shadowing a label or constructor: see 44 48: implicit elimination of optional arguments: too common - 50: unexpected documentation comment: too common and annoying to avoid 58: "no cmx file was found in path": See https://github.com/ocaml/num/issues/9 *) -let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-50-58" +let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-58" let coq_warn_error = if !prefs.warn_error then "-warn-error +a" diff --git a/coq-refman.opam b/coq-refman.opam new file mode 100644 index 0000000000..b9500243a3 --- /dev/null +++ b/coq-refman.opam @@ -0,0 +1,39 @@ +synopsis: "The Coq Proof Assistant --- Reference Manual" +description: """ +Coq is a formal proof management system. It provides +a formal language to write mathematical definitions, executable +algorithms and theorems together with an environment for +semi-interactive development of machine-checked proofs. + +This package provides the Coq Reference Manual. +""" +opam-version: "2.0" +maintainer: "The Coq development team <coqdev@inria.fr>" +authors: "The Coq development team, INRIA, CNRS, and contributors." +homepage: "https://coq.inria.fr/" +bug-reports: "https://github.com/coq/coq/issues" +dev-repo: "https://github.com/coq/coq.git" +license: "Open Publication License" + +depends: [ + "dune" { build } + "coq" { build } +] + +build-env: [ + [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] +] + +build: [ + [ "dune" "build" "@refman" "-j" jobs ] +] + +# Would be better to have a *-conf package? +depexts: [ + [ "sphinx" ] + [ "sphinx_rtd_theme" ] + [ "beautifulsoup4" ] + [ "antlr4-python3-runtime"] + [ "pexpect" ] + [ "sphinxcontrib-bibtex" ] +] diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 8d728b5b51..cc76c44651 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -26,7 +26,7 @@ let pr_loc loc = let print_code fmt c = let loc = c.loc.loc_start in - (** Print the line location as a source annotation *) + (* Print the line location as a source annotation *) let padding = String.make (loc.pos_cnum - loc.pos_bol + 1) ' ' in let code_insert = asprintf "\n# %i \"%s\"\n%s%s" loc.pos_lnum loc.pos_fname padding c.code in fprintf fmt "@[@<0>%s@]@\n" code_insert @@ -471,16 +471,16 @@ let parse_rule self r = (symbs, vars, r.tac_body) let print_rules fmt (name, rules) = - (** Rules are reversed. *) + (* Rules are reversed. *) let rules = List.rev rules in let rules = List.map (fun r -> parse_rule name r) rules in let pr fmt l = print_list fmt (fun fmt r -> fprintf fmt "(%a)" GramExt.print_extrule r) l in match rules with | [([SymbEntry (e, None)], [Some s], { code = c } )] when String.trim c = s -> - (** This is a horrible hack to work aroud limitations of camlp5 regarding - factorization of parsing rules. It allows to recognize rules of the - form [ entry(x) ] -> [ x ] so as not to generate a proxy entry and - reuse the same entry directly. *) + (* This is a horrible hack to work aroud limitations of camlp5 regarding + factorization of parsing rules. It allows to recognize rules of the + form [ entry(x) ] -> [ x ] so as not to generate a proxy entry and + reuse the same entry directly. *) fprintf fmt "@[Vernacextend.Arg_alias (%s)@]" e | _ -> fprintf fmt "@[Vernacextend.Arg_rules (%a)@]" pr rules diff --git a/default.nix b/default.nix index eeab388cb4..89d69cc40f 100644 --- a/default.nix +++ b/default.nix @@ -23,8 +23,8 @@ { pkgs ? (import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/69522a0acf8e840e8b6ac0a9752a034ab74eb3c0.tar.gz"; - sha256 = "12k80gd4lkw9h9y1szvmh0jmh055g3b6wnphmx4ab1qdwlfaylnx"; + url = "https://github.com/NixOS/nixpkgs/archive/958a6c6dd39b0d6628e1408e798a8f1308f2f3e1.tar.gz"; + sha256 = "0vs6k4jn0rbdfzaxmh3xh64q213326680i9g3cjgr7l9y6h6m5sy"; }) {}) , ocamlPackages ? pkgs.ocaml-ng.ocamlPackages_4_06 , buildIde ? true diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index 33feeed45c..8489bcfc3a 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -55,7 +55,7 @@ IF DEFINED HTTP_PROXY ( )
REM see -cygrepo in ReadMe.txt
-SET CYGWIN_REPOSITORY=http://ftp.inf.tu-dresden.de/software/windows/cygwin32
+SET CYGWIN_REPOSITORY=http://mirror.easyname.at/cygwin
REM see -cygcache in ReadMe.txt
SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache
diff --git a/dev/ci/appveyor.sh b/dev/ci/appveyor.sh index cda369fb1b..470d07b27d 100644 --- a/dev/ci/appveyor.sh +++ b/dev/ci/appveyor.sh @@ -13,4 +13,4 @@ eval "$(opam env)" opam install -y num ocamlfind ounit # Full regular Coq Build -cd "$APPVEYOR_BUILD_FOLDER" && ./configure -local && make && make byte && make -C test-suite all INTERACTIVE= # && make validate +cd "$APPVEYOR_BUILD_FOLDER" && ./configure -local && make && make byte # && make -C test-suite all INTERACTIVE= # && make validate diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 3fc6dce4e5..baf470e021 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2018-11-08-V1" +# CACHEKEY: "bionic_coq-V2018-12-14-V1" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -37,7 +37,7 @@ ENV COMPILER="4.05.0" # Common OPAM packages. # `num` does not have a version number as the right version to install varies # with the compiler version. -ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.4.0 ounit.2.0.8 odoc.1.3.0" \ +ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.3.0" \ CI_OPAM="menhir.20180530 elpi.1.1.0 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. diff --git a/dev/ci/user-overlays/09150-ejgallego-build+warn_50.sh b/dev/ci/user-overlays/09150-ejgallego-build+warn_50.sh new file mode 100644 index 0000000000..f2a113b118 --- /dev/null +++ b/dev/ci/user-overlays/09150-ejgallego-build+warn_50.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "9150" ] || [ "$CI_BRANCH" = "build+warn_50" ]; then + + mtac2_CI_REF=build+warn_50 + mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 + +fi diff --git a/dev/ci/user-overlays/09172-ejgallego-proof_rework.sh b/dev/ci/user-overlays/09172-ejgallego-proof_rework.sh new file mode 100644 index 0000000000..f532fdfc52 --- /dev/null +++ b/dev/ci/user-overlays/09172-ejgallego-proof_rework.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "9172" ] || [ "$CI_BRANCH" = "proof_rework" ]; then + + ltac2_CI_REF=proof_rework + ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + + mtac2_CI_REF=proof_rework + mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 + +fi diff --git a/dev/ci/user-overlays/09220-maximedenes-stm-shallow-logic.sh b/dev/ci/user-overlays/09220-maximedenes-stm-shallow-logic.sh new file mode 100644 index 0000000000..efcdd2e97f --- /dev/null +++ b/dev/ci/user-overlays/09220-maximedenes-stm-shallow-logic.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "9220" ] || [ "$CI_BRANCH" = "stm-shallow-logic" ]; then + + paramcoq_CI_REF=stm-shallow-logic + paramcoq_CI_GITURL=https://github.com/maximedenes/paramcoq + +fi diff --git a/dev/core.dbg b/dev/core.dbg index f676b643e4..ec946e2df0 100644 --- a/dev/core.dbg +++ b/dev/core.dbg @@ -1,10 +1,10 @@ load_printer threads.cma load_printer str.cma -load_printer gramlib.cma load_printer config.cma load_printer clib.cma load_printer dynlink.cma load_printer lib.cma +load_printer gramlib.cma load_printer kernel.cma load_printer library.cma load_printer engine.cma diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index 3609171b82..01c32041d2 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -10,9 +10,9 @@ Coq can now be built using [Dune](https://github.com/ocaml/dune). ## Quick Start -Dune >= 1.5.0 is recommended, see `dune-project` for the minimum -required version; type `dune build` to build the base Coq -libraries. No call to `./configure` is needed. +Usually, using the latest version of Dune is recommended, see +`dune-project` for the minimum required version; type `dune build` to +build the base Coq libraries. No call to `./configure` is needed. Dune will get confused if it finds leftovers of in-tree compilation, so please be sure your tree is clean from objects files generated by @@ -63,11 +63,16 @@ ml files in quick mode. Dune also provides targets for documentation, testing, and release builds, please see below. -## Documentation and test targets +## Documentation and testing targets Coq's test-suite can be run with `dune runtest`. -The documentation target is not implemented in Dune yet. +There is preliminary support to build the API documentation and +reference manual in HTML format, use `dune build {@doc,@refman-html}` +to generate them. + +So far these targets will build the documentation artifacts, however +no install rules are generated yet. ## Developer shell diff --git a/dev/doc/changes.md b/dev/doc/changes.md index c0f15f02a5..e7d4b605c7 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -52,6 +52,26 @@ Macros: where `atts : Vernacexpr.vernac_flags` was bound in the expression and had to be manually parsed. +Libobject + +- A Higher-level API for objects with fixed scope was introduced. It supports the following kinds of objects: + + * Local objects, meaning that objects cannot be imported from outside. + * Global objects, meaning that they can be imported (by importing the module that contains the object). + * Superglobal objects, meaning that objects survive to closing a module, and + are imported when the file which contains them is Required (even without + Import). + * Objects that survive section closing or don't (see `nodischarge` variants, + however we discourage defining such objects) + + This API is made of the following functions: + * `Libobject.local_object` + * `Libobject.local_object_nodischarge` + * `Libobject.global_object` + * `Libobject.global_object_nodischarge` + * `Libobject.superglobal_object` + * `Libobject.superglobal_object_nodischarge` + ## Changes between Coq 8.8 and Coq 8.9 ### ML API diff --git a/dev/top_printers.ml b/dev/top_printers.ml index b90a53220d..8f207d1e0a 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -476,7 +476,7 @@ let pp_generic_argument arg = let prgenarginfo arg = let Geninterp.Val.Dyn (tag, _) = arg in let tpe = Geninterp.Val.pr tag in - (** FIXME *) + (* FIXME *) (* try *) (* let data = Pptactic.pr_top_generic (Global.env ()) arg in *) (* str "<genarg:" ++ tpe ++ str " := [ " ++ data ++ str " ] >" *) diff --git a/doc/dune b/doc/dune new file mode 100644 index 0000000000..54ffa87205 --- /dev/null +++ b/doc/dune @@ -0,0 +1,24 @@ +(rule + (targets sphinx_build) + (deps + ; We could use finer dependencies here so the build is faster: + ; + ; - vo files: generated by sphinx after parsing the doc, promoted, + ; - Static files: + ; + %{bin:coqdoc} etc... + ; + config/coq_config.py + ; + tools/coqdoc/coqdoc.css + (package coq) + (source_tree sphinx) + (source_tree tools)) + (action (run sphinx-build -j4 -b html -d sphinx_build/doctrees sphinx sphinx_build/html))) + +(alias + (name refman-html) + (deps sphinx_build)) + +; The install target still needs more work. +; (install +; (section doc) +; (package coq-refman) +; (files sphinx_build)) diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index e681d0f3ff..39047f4f23 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -61,7 +61,7 @@ extensions = [ # Change this to "info" or "warning" to get notifications about undocumented Coq # objects (objects with no contents). -report_undocumented_coq_objects = None +report_undocumented_coq_objects = "warning" # Add any paths that contain templates here, relative to this directory. templates_path = ['_templates'] diff --git a/doc/sphinx/dune b/doc/sphinx/dune new file mode 100644 index 0000000000..fff025c919 --- /dev/null +++ b/doc/sphinx/dune @@ -0,0 +1 @@ +(dirs :standard _static) diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 9fbac95f0c..b664eb4ec5 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -418,30 +418,29 @@ each point of use, e.g., the above definition can be written: Prenex Implicits null. Definition all_null (s : list T) := all null s. -Better yet, it can be omitted entirely, since ``all_null s`` isn’t much of -an improvement over ``all null s``. +Better yet, it can be omitted entirely, since :g:`all_null s` isn’t much of +an improvement over :g:`all null s`. The syntax of the new declaration is -.. cmd:: Prenex Implicits {+ @ident} +.. cmd:: Prenex Implicits {+ @ident__i} -Let us denote :math:`c_1` … :math:`c_n` the list of identifiers given to a -``Prenex Implicits`` command. The command checks that each ci is the name of -a functional constant, whose implicit arguments are prenex, i.e., the first -:math:`n_i > 0` arguments of :math:`c_i` are implicit; then it assigns -``Maximal Implicit`` status to these arguments. + This command checks that each :n:`@ident__i` is the name of a functional + constant, whose implicit arguments are prenex, i.e., the first + :math:`n_i > 0` arguments of :n:`@ident__i` are implicit; then it assigns + ``Maximal Implicit`` status to these arguments. -As these prenex implicit arguments are ubiquitous and have often large -display strings, it is strongly recommended to change the default -display settings of |Coq| so that they are not printed (except after -a ``Set Printing All`` command). All |SSR| library files thus start -with the incantation + As these prenex implicit arguments are ubiquitous and have often large + display strings, it is strongly recommended to change the default + display settings of |Coq| so that they are not printed (except after + a ``Set Printing All`` command). All |SSR| library files thus start + with the incantation -.. coqtop:: all undo + .. coqtop:: all undo - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. Anonymous arguments @@ -601,25 +600,21 @@ resemble ML-like definitions of polymorphic functions. Abbreviations ~~~~~~~~~~~~~ -The |SSR| set tactic performs abbreviations: it introduces a -defined constant for a subterm appearing in the goal and/or in the -context. - -|SSR| extends the set tactic by supplying: - - -+ an open syntax, similarly to the pose tactic; -+ a more aggressive matching algorithm; -+ an improved interpretation of wildcards, taking advantage of the - matching algorithm; -+ an improved occurrence selection mechanism allowing to abstract only - selected occurrences of a term. +.. tacn:: set @ident {? : @term } := {? @occ_switch } @term + :name: set (ssreflect) + The |SSR| ``set`` tactic performs abbreviations: it introduces a + defined constant for a subterm appearing in the goal and/or in the + context. -The general syntax of this tactic is + |SSR| extends the :tacn:`set` tactic by supplying: -.. tacn:: set @ident {? : @term } := {? @occ_switch } @term - :name: set (ssreflect) + + an open syntax, similarly to the :tacn:`pose (ssreflect)` tactic; + + a more aggressive matching algorithm; + + an improved interpretation of wildcards, taking advantage of the + matching algorithm; + + an improved occurrence selection mechanism allowing to abstract only + selected occurrences of a term. .. prodn:: occ_switch ::= { {? + %| - } {* @num } } @@ -903,23 +898,15 @@ Basic localization ~~~~~~~~~~~~~~~~~~ It is possible to define an abbreviation for a term appearing in the -context of a goal thanks to the in tactical. - -A tactic of the form: +context of a goal thanks to the ``in`` tactical. .. tacv:: set @ident := @term in {+ @ident} -introduces a defined constant called ``x`` in the context, and folds it in -the context entries mentioned on the right hand side of ``in``. -The body of ``x`` is the first subterm matching these context entries -(taken in the given order). - -A tactic of the form: - -.. tacv:: set @ident := @term in {+ @ident} * - -matches term and then folds ``x`` similarly in all the given context entries -but also folds ``x`` in the goal. + This variant of :tacn:`set (ssreflect)` introduces a defined constant + called :token:`ident` in the context, and folds it in + the context entries mentioned on the right hand side of ``in``. + The body of :token:`ident` is the first subterm matching these context + entries (taken in the given order). .. example:: @@ -932,7 +919,10 @@ but also folds ``x`` in the goal. Lemma test x t (Hx : x = 3) : x + t = 4. set z := 3 in Hx. -If the localization also mentions the goal, then the result is the following one: +.. tacv:: set @ident := @term in {+ @ident} * + + This variant matches :token:`term` and then folds :token:`ident` similarly + in all the given context entries but also folds :token:`ident` in the goal. .. example:: @@ -945,7 +935,7 @@ If the localization also mentions the goal, then the result is the following one Lemma test x t (Hx : x = 3) : x + t = 4. set z := 3 in Hx * . -Indeed, remember that 4 is just a notation for (S 3). + Indeed, remember that 4 is just a notation for (S 3). The use of the ``in`` tactical is not limited to the localization of abbreviations: for a complete description of the in tactical, see @@ -1202,77 +1192,82 @@ context manipulations and the main backward chaining tool. The move tactic. ```````````````` -The move tactic, in its defective form, behaves like the primitive ``hnf`` -|Coq| tactic. For example, such a defective: - .. tacn:: move :name: move -exposes the first assumption in the goal, i.e. its changes the -goal ``not False`` into ``False -> False``. + This tactic, in its defective form, behaves like the :tacn:`hnf` tactic. + + .. example:: -More precisely, the ``move`` tactic inspects the goal and does nothing -(``idtac``) if an introduction step is possible, i.e. if the goal is a -product or a ``let…in``, and performs ``hnf`` otherwise. + .. coqtop:: reset all -Of course this tactic is most often used in combination with the -bookkeeping tacticals (see section :ref:`introduction_ssr` and :ref:`discharge_ssr`). These -combinations mostly subsume the :tacn:`intros`, :tacn:`generalize`, :tacn:`revert`, :tacn:`rename`, -:tacn:`clear` and :tacn:`pattern` tactics. + Require Import ssreflect. + Goal not False. + move. + + More precisely, the :tacn:`move` tactic inspects the goal and does nothing + (:tacn:`idtac`) if an introduction step is possible, i.e. if the goal is a + product or a ``let … in``, and performs :tacn:`hnf` otherwise. + + Of course this tactic is most often used in combination with the bookkeeping + tacticals (see section :ref:`introduction_ssr` and :ref:`discharge_ssr`). + These combinations mostly subsume the :tacn:`intros`, :tacn:`generalize`, + :tacn:`revert`, :tacn:`rename`, :tacn:`clear` and :tacn:`pattern` tactics. The case tactic ``````````````` -The ``case`` tactic performs *primitive case analysis* on (co)inductive -types; specifically, it destructs the top variable or assumption of -the goal, exposing its constructor(s) and its arguments, as well as -setting the value of its type family indices if it belongs to a type -family (see section :ref:`type_families_ssr`). +.. tacn:: case + :name: case (ssreflect) + + This tactic performs *primitive case analysis* on (co)inductive + types; specifically, it destructs the top variable or assumption of + the goal, exposing its constructor(s) and its arguments, as well as + setting the value of its type family indices if it belongs to a type + family (see section :ref:`type_families_ssr`). -The |SSR| case tactic has a special behavior on equalities. If the -top assumption of the goal is an equality, the case tactic “destructs” -it as a set of equalities between the constructor arguments of its -left and right hand sides, as per the tactic injection. For example, -``case`` changes the goal:: + The |SSR| case tactic has a special behavior on equalities. If the + top assumption of the goal is an equality, the case tactic “destructs” + it as a set of equalities between the constructor arguments of its + left and right hand sides, as per the tactic injection. For example, + ``case`` changes the goal:: - (x, y) = (1, 2) -> G. + (x, y) = (1, 2) -> G. -into:: + into:: - x = 1 -> y = 2 -> G. + x = 1 -> y = 2 -> G. -Note also that the case of |SSR| performs ``False`` elimination, even -if no branch is generated by this case operation. Hence the command: -``case.`` on a goal of the form ``False -> G`` will succeed and -prove the goal. + Note also that the case of |SSR| performs :g:`False` elimination, even + if no branch is generated by this case operation. Hence the tactic + :tacn:`case` on a goal of the form :g:`False -> G` will succeed and + prove the goal. The elim tactic ``````````````` -The ``elim`` tactic performs inductive elimination on inductive types. The -defective: - .. tacn:: elim :name: elim (ssreflect) -tactic performs inductive elimination on a goal whose top assumption -has an inductive type. + This tactic performs inductive elimination on inductive types. In its + defective form, the tactic performs inductive elimination on a goal whose + top assumption has an inductive type. -.. example:: + .. example:: - .. coqtop:: reset + .. coqtop:: reset - From Coq Require Import ssreflect. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. - .. coqtop:: all + .. coqtop:: all - Lemma test m : forall n : nat, m <= n. - elim. + Lemma test m : forall n : nat, m <= n. + elim. .. _apply_ssr: @@ -1280,27 +1275,25 @@ has an inductive type. The apply tactic ```````````````` -The ``apply`` tactic is the main backward chaining tactic of the proof -system. It takes as argument any :token:`term` and applies it to the goal. -Assumptions in the type of :token:`term` that don’t directly match the goal -may generate one or more subgoals. - -In fact the |SSR| tactic: - -.. tacn:: apply +.. tacn:: apply {? @term } :name: apply (ssreflect) -is a synonym for:: + This is the main backward chaining tactic of the proof system. + It takes as argument any :token:`term` and applies it to the goal. + Assumptions in the type of :token:`term` that don’t directly match the goal + may generate one or more subgoals. + + In its defective form, this tactic is a synonym for:: - intro top; first [refine top | refine (top _) | refine (top _ _) | …]; clear top. + intro top; first [refine top | refine (top _) | refine (top _ _) | …]; clear top. -where ``top`` is a fresh name, and the sequence of refine tactics tries to -catch the appropriate number of wildcards to be inserted. Note that -this use of the refine tactic implies that the tactic tries to match -the goal up to expansion of constants and evaluation of subterms. + where :g:`top` is a fresh name, and the sequence of :tacn:`refine` tactics + tries to catch the appropriate number of wildcards to be inserted. Note that + this use of the :tacn:`refine` tactic implies that the tactic tries to match + the goal up to expansion of constants and evaluation of subterms. -|SSR|’s apply has a special behavior on goals containing -existential metavariables of sort Prop. +:tacn:`apply (ssreflect)` has a special behavior on goals containing +existential metavariables of sort :g:`Prop`. .. example:: @@ -1348,6 +1341,7 @@ The general syntax of the discharging tactical ``:`` is: .. tacn:: @tactic {? @ident } : {+ @d_item } {? @clear_switch } :name: ... : ... (ssreflect) + :undocumented: .. prodn:: d_item ::= {? @occ_switch %| @clear_switch } @term @@ -1502,8 +1496,8 @@ The abstract tactic .. tacn:: abstract: {+ d_item} :name: abstract (ssreflect) -This tactic assigns an abstract constant previously introduced with the ``[: -name ]`` intro pattern (see section :ref:`introduction_ssr`). + This tactic assigns an abstract constant previously introduced with the + :n:`[: @ident ]` intro pattern (see section :ref:`introduction_ssr`). In a goal like the following:: @@ -1553,6 +1547,7 @@ whose general syntax is .. tacn:: @tactic => {+ @i_item } :name: => + :undocumented: .. prodn:: i_item ::= @i_pattern %| @s_item %| @clear_switch %| {? %{%} } /@term @@ -1803,136 +1798,132 @@ Type families ~~~~~~~~~~~~~ When the top assumption of a goal has an inductive type, two specific -operations are possible: the case analysis performed by the ``case`` +operations are possible: the case analysis performed by the :tacn:`case` tactic, and the application of an induction principle, performed by -the ``elim`` tactic. When this top assumption has an inductive type, which +the :tacn:`elim` tactic. When this top assumption has an inductive type, which is moreover an instance of a type family, |Coq| may need help from the user to specify which occurrences of the parameters of the type should be substituted. -A specific ``/`` switch indicates the type family parameters of the type -of a :token:`d_item` immediately following this ``/`` switch, -using the syntax: - .. tacv:: case: {+ @d_item } / {+ @d_item } - :name: case (ssreflect) + elim: {+ @d_item } / {+ @d_item } + + A specific ``/`` switch indicates the type family parameters of the type + of a :token:`d_item` immediately following this ``/`` switch. + The :token:`d_item` on the right side of the ``/`` switch are discharged as + described in section :ref:`discharge_ssr`. The case analysis or elimination + will be done on the type of the top assumption after these discharge + operations. + + Every :token:`d_item` preceding the ``/`` is interpreted as arguments of this + type, which should be an instance of an inductive type family. These terms + are not actually generalized, but rather selected for substitution. + Occurrence switches can be used to restrict the substitution. If a term is + left completely implicit (e.g. writing just ``_``), then a pattern is + inferred looking at the type of the top assumption. This allows for the + compact syntax: -.. tacv:: elim: {+ @d_item } / {+ @d_item } + .. coqtop:: in -The :token:`d_item` on the right side of the ``/`` switch are discharged as -described in section :ref:`discharge_ssr`. The case analysis or elimination -will be done on the type of the top assumption after these discharge -operations. + case: {2}_ / eqP. -Every :token:`d_item` preceding the ``/`` is interpreted as arguments of this -type, which should be an instance of an inductive type family. These terms -are not actually generalized, but rather selected for substitution. -Occurrence switches can be used to restrict the substitution. If a term is -left completely implicit (e.g. writing just ``_``), then a pattern is -inferred looking at the type of the top assumption. This allows for the -compact syntax: + where ``_`` is interpreted as ``(_ == _)`` since + ``eqP T a b : reflect (a = b) (a == b)`` and reflect is a type family with + one index. -.. coqtop:: in + Moreover if the :token:`d_item` list is too short, it is padded with an + initial sequence of ``_`` of the right length. - case: {2}_ / eqP. + .. example:: -where ``_`` is interpreted as ``(_ == _)`` since -``eqP T a b : reflect (a = b) (a == b)`` and reflect is a type family with -one index. + Here is a small example on lists. We define first a function which + adds an element at the end of a given list. -Moreover if the :token:`d_item` list is too short, it is padded with an -initial sequence of ``_`` of the right length. + .. coqtop:: reset -.. example:: + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. - Here is a small example on lists. We define first a function which - adds an element at the end of a given list. + .. coqtop:: all - .. coqtop:: reset + Require Import List. + Section LastCases. + Variable A : Type. + Implicit Type l : list A. + Fixpoint add_last a l : list A := + match l with + | nil => a :: nil + | hd :: tl => hd :: (add_last a tl) end. - From Coq Require Import ssreflect. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. + Then we define an inductive predicate for case analysis on lists + according to their last element: - .. coqtop:: all + .. coqtop:: all - Require Import List. - Section LastCases. - Variable A : Type. - Implicit Type l : list A. - Fixpoint add_last a l : list A := - match l with - | nil => a :: nil - | hd :: tl => hd :: (add_last a tl) end. + Inductive last_spec : list A -> Type := + | LastSeq0 : last_spec nil + | LastAdd s x : last_spec (add_last x s). - Then we define an inductive predicate for case analysis on lists - according to their last element: + Theorem lastP : forall l : list A, last_spec l. + Admitted. - .. coqtop:: all + We are now ready to use ``lastP`` in conjunction with ``case``. - Inductive last_spec : list A -> Type := - | LastSeq0 : last_spec nil - | LastAdd s x : last_spec (add_last x s). + .. coqtop:: all - Theorem lastP : forall l : list A, last_spec l. - Admitted. + Lemma test l : (length l) * 2 = length (l ++ l). + case: (lastP l). - We are now ready to use ``lastP`` in conjunction with ``case``. + Applied to the same goal, the command: + ``case: l / (lastP l).`` + generates the same subgoals but ``l`` has been cleared from both contexts. - .. coqtop:: all + Again applied to the same goal, the command. - Lemma test l : (length l) * 2 = length (l ++ l). - case: (lastP l). + .. coqtop:: none - Applied to the same goal, the command: - ``case: l / (lastP l).`` - generates the same subgoals but ``l`` has been cleared from both contexts. + Abort. - Again applied to the same goal, the command. + .. coqtop:: all - .. coqtop:: none + Lemma test l : (length l) * 2 = length (l ++ l). + case: {1 3}l / (lastP l). - Abort. - - .. coqtop:: all - - Lemma test l : (length l) * 2 = length (l ++ l). - case: {1 3}l / (lastP l). - - Note that selected occurrences on the left of the ``/`` - switch have been substituted with l instead of being affected by - the case analysis. + Note that selected occurrences on the left of the ``/`` + switch have been substituted with l instead of being affected by + the case analysis. -The equation name generation feature combined with a type family / -switch generates an equation for the *first* dependent :token:`d_item` -specified by the user. Again starting with the above goal, the -command: + The equation name generation feature combined with a type family ``/`` + switch generates an equation for the *first* dependent :token:`d_item` + specified by the user. Again starting with the above goal, the + command: -.. example:: + .. example:: - .. coqtop:: none + .. coqtop:: none - Abort. + Abort. - .. coqtop:: all + .. coqtop:: all - Lemma test l : (length l) * 2 = length (l ++ l). - case E: {1 3}l / (lastP l) => [|s x]. - Show 2. + Lemma test l : (length l) * 2 = length (l ++ l). + case E: {1 3}l / (lastP l) => [|s x]. + Show 2. -There must be at least one :token:`d_item` to the left of the / switch; this -prevents any confusion with the view feature. However, the :token:`d_item` -to the right of the ``/`` are optional, and if they are omitted the first -assumption provides the instance of the type family. + There must be at least one :token:`d_item` to the left of the ``/`` switch; this + prevents any confusion with the view feature. However, the :token:`d_item` + to the right of the ``/`` are optional, and if they are omitted the first + assumption provides the instance of the type family. -The equation always refers to the first :token:`d_item` in the actual tactic -call, before any padding with initial ``_``. Thus, if an inductive type -has two family parameters, it is possible to have|SSR| generate an -equation for the second one by omitting the pattern for the first; -note however that this will fail if the type of the second parameter -depends on the value of the first parameter. + The equation always refers to the first :token:`d_item` in the actual tactic + call, before any padding with initial ``_``. Thus, if an inductive type + has two family parameters, it is possible to have|SSR| generate an + equation for the second one by omitting the pattern for the first; + note however that this will fail if the type of the second parameter + depends on the value of the first parameter. Control flow @@ -1991,13 +1982,14 @@ closed tactic fails to prove its subgoal. It is hence recommended practice that the proof of any subgoal should end with a tactic which *fails if it does not solve the current goal*, -like discriminate, contradiction or assumption. +like :tacn:`discriminate`, :tacn:`contradiction` or :tacn:`assumption`. In fact, |SSR| provides a generic tactical which turns any tactic -into a closing one (similar to now). Its general syntax is: +into a closing one (similar to :tacn:`now`). Its general syntax is: .. tacn:: by @tactic :name: by + :undocumented: The Ltac expression :n:`by [@tactic | [@tactic | …]` is equivalent to :n:`[by @tactic | by @tactic | ...]` and this form should be preferred @@ -2014,39 +2006,29 @@ with a ``by``, like in: .. tacn:: done :name: done -The :tacn:`by` tactical is implemented using the user-defined, and extensible -:tacn:`done` tactic. This :tacn:`done` tactic tries to solve the current goal by some -trivial means and fails if it doesn’t succeed. Indeed, the tactic -expression :n:`by @tactic` is equivalent to :n:`@tactic; done`. + The :tacn:`by` tactical is implemented using the user-defined, and extensible + :tacn:`done` tactic. This :tacn:`done` tactic tries to solve the current goal by some + trivial means and fails if it doesn’t succeed. Indeed, the tactic + expression :n:`by @tactic` is equivalent to :n:`@tactic; done`. -Conversely, the tactic + Conversely, the tactic ``by [ ]`` is equivalent to :tacn:`done`. -.. coqtop:: + The default implementation of the done tactic, in the ``ssreflect.v`` + file, is: - by [ ]. + .. coqdoc:: -is equivalent to: + Ltac done := + trivial; hnf; intros; solve + [ do ![solve [trivial | apply: sym_equal; trivial] + | discriminate | contradiction | split] + | case not_locked_false_eq_true; assumption + | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. -.. coqtop:: - - done. - -The default implementation of the done tactic, in the ``ssreflect.v`` -file, is: - -.. coqtop:: in - - Ltac done := - trivial; hnf; intros; solve - [ do ![solve [trivial | apply: sym_equal; trivial] - | discriminate | contradiction | split] - | case not_locked_false_eq_true; assumption - | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. - -The lemma ``not_locked_false_eq_true`` is needed to discriminate -*locked* boolean predicates (see section :ref:`locking_ssr`). The iterator -tactical do is presented in section :ref:`iteration_ssr`. This tactic can be -customized by the user, for instance to include an ``auto`` tactic. + The lemma :g:`not_locked_false_eq_true` is needed to discriminate + *locked* boolean predicates (see section :ref:`locking_ssr`). The iterator + tactical do is presented in section :ref:`iteration_ssr`. This tactic can be + customized by the user, for instance to include an :tacn:`auto` tactic. A natural and common way of closing a goal is to apply a lemma which is the exact one needed for the goal to be solved. The defective form @@ -2063,7 +2045,7 @@ is equivalent to: do [done | by move=> top; apply top]. where ``top`` is a fresh name assigned to the top assumption of the goal. -This applied form is supported by the : discharge tactical, and the +This applied form is supported by the ``:`` discharge tactical, and the tactic: .. coqtop:: in @@ -2106,57 +2088,47 @@ is equivalent to: Selectors ~~~~~~~~~ -When composing tactics, the two tacticals ``first`` and ``last`` let the user -restrict the application of a tactic to only one of the subgoals -generated by the previous tactic. This covers the frequent cases where -a tactic generates two subgoals one of which can be easily disposed -of. - -This is another powerful way of linearization of scripts, since it -happens very often that a trivial subgoal can be solved in a less than -one line tactic. For instance, the tactic: - -.. tacn:: @tactic ; last by @tactic - :name: last - -tries to solve the last subgoal generated by the first -tactic using the given second tactic, and fails if it does not succeed. -Its analogue - -.. tacn:: @tactic ; first by @tactic - :name: first (ssreflect) - -tries to solve the first subgoal generated by the first tactic using the -second given tactic, and fails if it does not succeed. +.. tacn:: last + first + :name: last; first (ssreflect) + + When composing tactics, the two tacticals ``first`` and ``last`` let the user + restrict the application of a tactic to only one of the subgoals + generated by the previous tactic. This covers the frequent cases where + a tactic generates two subgoals one of which can be easily disposed + of. + + This is another powerful way of linearization of scripts, since it + happens very often that a trivial subgoal can be solved in a less than + one line tactic. For instance, :n:`@tactic ; last by @tactic` + tries to solve the last subgoal generated by the first + tactic using the given second tactic, and fails if it does not succeed. + Its analogue :n:`@tactic ; first by @tactic` + tries to solve the first subgoal generated by the first tactic using the + second given tactic, and fails if it does not succeed. |SSR| also offers an extension of this facility, by supplying -tactics to *permute* the subgoals generated by a tactic. The tactic: - -.. tacv:: @tactic; last first - -inverts the order of the subgoals generated by tactic. It is -equivalent to: - -.. tacv:: @tactic; first last +tactics to *permute* the subgoals generated by a tactic. -More generally, the tactic: +.. tacv:: last first + first last + :name: last first; first last -.. tacn:: @tactic; last @num first - :name: last first + These two equivalent tactics invert the order of the subgoals in focus. -where :token:`num` is a |Coq| numeral, or an Ltac variable -denoting a |Coq| -numeral, having the value k. It rotates the n subgoals G1 , …, Gn -generated by tactic. The first subgoal becomes Gn + 1 − k and the -circular order of subgoals remains unchanged. + .. tacv:: last @num first -Conversely, the tactic: + If :token:`num`\'s value is :math:`k`, + this tactic rotates the :math:`n` subgoals :math:`G_1` , …, :math:`G_n` + in focus. The first subgoal becomes :math:`G_{n + 1 − k}` and the + circular order of subgoals remains unchanged. -.. tacn:: @tactic; first @num last - :name: first last + .. tacn:: first @num last -rotates the n subgoals G1 , …, Gn generated by tactic in order that -the first subgoal becomes Gk . + If :token:`num`\'s value is :math:`k`, + this tactic rotates the :math:`n` subgoals :math:`G_1` , …, :math:`G_n` + in focus. The first subgoal becomes :math:`G_k` and the circular order + of subgoals remains unchanged. Finally, the tactics ``last`` and ``first`` combine with the branching syntax of Ltac: if the tactic generates n subgoals on a given goal, @@ -2200,16 +2172,14 @@ to the others. Iteration ~~~~~~~~~ -|SSR| offers an accurate control on the repetition of tactics, -thanks to the do tactical, whose general syntax is: - -.. tacn:: do {? @mult } ( @tactic | [ {+| @tactic } ] ) +.. tacn:: do {? @num } ( @tactic | [ {+| @tactic } ] ) :name: do (ssreflect) -where :token:`mult` is a *multiplier*. + This tactical offers an accurate control on the repetition of tactics. + :token:`mult` is a *multiplier*. -Brackets can only be omitted if a single tactic is given *and* a -multiplier is present. + Brackets can only be omitted if a single tactic is given *and* a + multiplier is present. A tactic of the form: @@ -2274,6 +2244,7 @@ already presented the *localization* tactical in, whose general syntax is: .. tacn:: @tactic in {+ @ident} {? * } :name: in + :undocumented: where :token:`ident` is a name in the context. On the left side of ``in``, @@ -2318,17 +2289,15 @@ of a local definition during the generalization phase, the name of the local definition must be written between parentheses, like in ``rewrite H in H1 (def_n) H2.`` -From |SSR| 1.5 the grammar for the in tactical has been extended -to the following one: - .. tacv:: @tactic in {+ @clear_switch | {? @ } @ident | ( @ident ) | ( {? @ } @ident := @c_pattern ) } {? * } -In its simplest form the last option lets one rename hypotheses that -can’t be cleared (like section variables). For example, ``(y := x)`` -generalizes over ``x`` and reintroduces the generalized variable under the -name ``y`` (and does not clear ``x``). -For a more precise description of this form of localization refer -to :ref:`advanced_generalization_ssr`. + This is the most general form of the ``in`` tactical. + In its simplest form the last option lets one rename hypotheses that + can’t be cleared (like section variables). For example, ``(y := x)`` + generalizes over ``x`` and reintroduces the generalized variable under the + name ``y`` (and does not clear ``x``). + For a more precise description of this form of localization refer + to :ref:`advanced_generalization_ssr`. .. _structure_ssr: @@ -2352,25 +2321,23 @@ intermediate statement. The have tactic. ```````````````` -The main |SSR| forward reasoning tactic is the ``have`` tactic. It can -be use in two modes: one starts a new (sub)proof for an intermediate -result in the main proof, and the other provides explicitly a proof -term for this intermediate step. - -In the first mode, the syntax of have in its defective form is: - .. tacn:: have : @term :name: have -This tactic supports open syntax for :token:`term`. Applied to a goal ``G``, it -generates a first subgoal requiring a proof of ``term`` in the context of -``G``. The second generated subgoal is of the form ``term -> G``, where term -becomes the new top assumption, instead of being introduced with a -fresh name. At the proof-term level, the have tactic creates a β -redex, and introduces the lemma under a fresh name, automatically -chosen. + This is the main |SSR| forward reasoning tactic. It can + be used in two modes: one starts a new (sub)proof for an intermediate + result in the main proof, and the other provides explicitly a proof + term for this intermediate step. + + This tactic supports open syntax for :token:`term`. Applied to a goal ``G``, it + generates a first subgoal requiring a proof of :token:`term` in the context of + ``G``. The second generated subgoal is of the form :n:`term -> G`, where term + becomes the new top assumption, instead of being introduced with a + fresh name. At the proof-term level, the have tactic creates a β + redex, and introduces the lemma under a fresh name, automatically + chosen. -Like in the case of the ``pose`` tactic (see section :ref:`definitions_ssr`), the types of +Like in the case of the :n:`pose (ssreflect)` tactic (see section :ref:`definitions_ssr`), the types of the holes are abstracted in term. .. example:: @@ -2425,6 +2392,7 @@ The behavior of the defective have tactic makes it possible to generalize it in the following general construction: .. tacn:: have {* @i_item } {? @i_pattern } {? @s_item | {+ @ssr_binder } } {? : @term } {? := @term | by @tactic } + :undocumented: Open syntax is supported for both :token:`term`. For the description of :token:`i_item` and :token:`s_item` see section @@ -2433,6 +2401,7 @@ have tactic, which opens a sub-proof for an intermediate result, uses tactics of the form: .. tacv:: have @clear_switch @i_item : @term by @tactic + :undocumented: which behave like: @@ -2446,7 +2415,7 @@ allows to reuse a name of the context, possibly used by the proof of the assumption, to introduce the new assumption itself. -The``by`` feature is especially convenient when the proof script of the +The ``by`` feature is especially convenient when the proof script of the statement is very short, basically when it fits in one line like in: .. coqtop:: in @@ -2503,13 +2472,13 @@ term for the intermediate lemma, using tactics of the form: .. tacv:: have {? @ident } := term -This tactic creates a new assumption of type the type of :token:`term`. -If the -optional :token:`ident` is present, this assumption is introduced under the -name :token:`ident`. Note that the body of the constant is lost for the user. + This tactic creates a new assumption of type the type of :token:`term`. + If the + optional :token:`ident` is present, this assumption is introduced under the + name :token:`ident`. Note that the body of the constant is lost for the user. -Again, non inferred implicit arguments and explicit holes are -abstracted. + Again, non inferred implicit arguments and explicit holes are + abstracted. .. example:: @@ -2781,9 +2750,9 @@ hypothesis and by pointing at the elements of the initial goals which should be generalized. The general syntax of without loss is: .. tacn:: wlog {? suff } {? @clear_switch } {? @i_item } : {* @ident } / @term - :name: wlog -.. tacv:: without loss {? suff } {? @clear_switch } {? @i_item } : {* @ident } / @term - :name: without loss + without loss {? suff } {? @clear_switch } {? @i_item } : {* @ident } / @term + :name: wlog; without loss + :undocumented: where each :token:`ident` is a constant in the context of the goal. Open syntax is supported for :token:`term`. @@ -2791,8 +2760,8 @@ of the goal. Open syntax is supported for :token:`term`. In its defective form: .. tacv:: wlog: / @term -.. tacv:: without loss: / @term - + without loss: / @term + :undocumented: on a goal G, it creates two subgoals: a first one to prove the formula (term -> G) -> G and a second one to prove the formula @@ -2873,6 +2842,7 @@ The complete syntax for the items on the left hand side of the ``/`` separator is the following one: .. tacv:: wlog … : {? @clear_switch | {? @ } @ident | ( {? @ } @ident := @c_pattern) } / @term + :undocumented: Clear operations are intertwined with generalization operations. This helps in particular avoiding dependency issues while generalizing some @@ -2957,8 +2927,9 @@ The general form of an |SSR| rewrite tactic is: .. tacn:: rewrite {+ @rstep } :name: rewrite (ssreflect) + :undocumented: -The combination of a rewrite tactic with the in tactical (see section +The combination of a rewrite tactic with the ``in`` tactical (see section :ref:`localization_ssr`) performs rewriting in both the context and the goal. A rewrite step :token:`rstep` has the general form: @@ -3692,14 +3663,12 @@ definition. rewrite /=. unlock lid. -We provide a special tactic unlock for unfolding such definitions -while removing “locks”, e.g., the tactic: - .. tacn:: unlock {? @occ_switch } @ident :name: unlock -replaces the occurrence(s) of :token:`ident` coded by the -:token:`occ_switch` with the corresponding body. + This tactic unfolds such definitions while removing “locks”, i.e. it + replaces the occurrence(s) of :token:`ident` coded by the + :token:`occ_switch` with the corresponding body. We found that it was usually preferable to prevent the expansion of some functions by the partial evaluation switch ``/=``, unless this @@ -3775,103 +3744,102 @@ which the function is supplied: .. tacn:: congr {? @num } @term :name: congr -This tactic: - + This tactic: + checks that the goal is a Leibniz equality; + matches both sides of this equality with “term applied to some arguments”, inferring the right number of arguments from the goal and the type of term. This may expand some definitions or fixpoints; + generates the subgoals corresponding to pairwise equalities of the arguments present in the goal. -The goal can be a non dependent product ``P -> Q``. In that case, the -system asserts the equation ``P = Q``, uses it to solve the goal, and -calls the ``congr`` tactic on the remaining goal ``P = Q``. This can be useful -for instance to perform a transitivity step, like in the following -situation. + The goal can be a non dependent product ``P -> Q``. In that case, the + system asserts the equation ``P = Q``, uses it to solve the goal, and + calls the ``congr`` tactic on the remaining goal ``P = Q``. This can be useful + for instance to perform a transitivity step, like in the following + situation. -.. example:: + .. example:: - .. coqtop:: reset + .. coqtop:: reset - From Coq Require Import ssreflect. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. - Section Test. + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. + Section Test. - .. coqtop:: all + .. coqtop:: all - Lemma test (x y z : nat) (H : x = y) : x = z. - congr (_ = _) : H. - Abort. + Lemma test (x y z : nat) (H : x = y) : x = z. + congr (_ = _) : H. + Abort. - Lemma test (x y z : nat) : x = y -> x = z. - congr (_ = _). + Lemma test (x y z : nat) : x = y -> x = z. + congr (_ = _). -The optional :token:`num` forces the number of arguments for which the -tactic should generate equality proof obligations. + The optional :token:`num` forces the number of arguments for which the + tactic should generate equality proof obligations. -This tactic supports equalities between applications with dependent -arguments. Yet dependent arguments should have exactly the same -parameters on both sides, and these parameters should appear as first -arguments. + This tactic supports equalities between applications with dependent + arguments. Yet dependent arguments should have exactly the same + parameters on both sides, and these parameters should appear as first + arguments. -.. example:: + .. example:: - .. coqtop:: reset + .. coqtop:: reset - From Coq Require Import ssreflect. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. - Section Test. + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. + Section Test. - .. coqtop:: all + .. coqtop:: all - Definition f n := - if n is 0 then plus else mult. - Definition g (n m : nat) := plus. + Definition f n := + if n is 0 then plus else mult. + Definition g (n m : nat) := plus. - Lemma test x y : f 0 x y = g 1 1 x y. - congr plus. + Lemma test x y : f 0 x y = g 1 1 x y. + congr plus. - This script shows that the ``congr`` tactic matches ``plus`` - with ``f 0`` on the left hand side and ``g 1 1`` on the right hand - side, and solves the goal. + This script shows that the ``congr`` tactic matches ``plus`` + with ``f 0`` on the left hand side and ``g 1 1`` on the right hand + side, and solves the goal. -.. example:: + .. example:: - .. coqtop:: reset + .. coqtop:: reset - From Coq Require Import ssreflect. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. - Section Test. + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. + Section Test. - .. coqtop:: all + .. coqtop:: all - Lemma test n m (Hnm : m <= n) : S m + (S n - S m) = S n. - congr S; rewrite -/plus. + Lemma test n m (Hnm : m <= n) : S m + (S n - S m) = S n. + congr S; rewrite -/plus. - The tactic ``rewrite -/plus`` folds back the expansion of plus - which was necessary for matching both sides of the equality with - an application of ``S``. + The tactic ``rewrite -/plus`` folds back the expansion of plus + which was necessary for matching both sides of the equality with + an application of ``S``. -Like most |SSR| arguments, term can contain wildcards. + Like most |SSR| arguments, :token:`term` can contain wildcards. -.. example:: + .. example:: - .. coqtop:: reset + .. coqtop:: reset - From Coq Require Import ssreflect. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. - Section Test. + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. + Section Test. - .. coqtop:: all + .. coqtop:: all - Lemma test x y : x + (y * (y + x - x)) = x * 1 + (y + 0) * y. - congr ( _ + (_ * _)). + Lemma test x y : x + (y * (y + x - x)) = x * 1 + (y + 0) * y. + congr ( _ + (_ * _)). .. _contextual_patterns_ssr: @@ -4883,6 +4851,7 @@ Interpreting assumptions The general form of an assumption view tactic is: .. tacv:: [move | case] / @term + :undocumented: The term , called the *view lemma* can be: @@ -4997,6 +4966,7 @@ Interpreting goals A goal interpretation view tactic of the form: .. tacv:: apply/@term + :undocumented: applied to a goal ``top`` is interpreted in the following way: @@ -5027,6 +4997,7 @@ both sides. The syntax of double views is: .. tacv:: apply/@term/@term + :undocumented: The first term is the view lemma applied to the left hand side of the equality, while the second term is the one applied to the right hand side. @@ -5074,31 +5045,30 @@ In this context, the identity view can be used when no view has to be applied: Declaring new Hint Views ~~~~~~~~~~~~~~~~~~~~~~~~ -The database of hints for the view mechanism is extensible via a -dedicated vernacular command. As library ``ssrbool.v`` already declares a -corpus of hints, this feature is probably useful only for users who -define their own logical connectives. Users can declare their own -hints following the syntax used in ``ssrbool.v``: - .. cmd:: Hint View for move / @ident {? | @num } -.. cmd:: Hint View for apply / @ident {? | @num } + Hint View for apply / @ident {? | @num } + + This command can be used to extend the database of hints for the view + mechanism. -The :token:`ident` is the name of the lemma to be -declared as a hint. If `move` is used as -tactic, the hint is declared for assumption interpretation tactics, -`apply` declares hints for goal interpretations. Goal interpretation -view hints are declared for both simple views and left hand side -views. The optional natural number is the number of implicit -arguments to be considered for the declared hint view lemma. + As library ``ssrbool.v`` already declares a + corpus of hints, this feature is probably useful only for users who + define their own logical connectives. -The command: + The :token:`ident` is the name of the lemma to be + declared as a hint. If ``move`` is used as + tactic, the hint is declared for assumption interpretation tactics, + ``apply`` declares hints for goal interpretations. Goal interpretation + view hints are declared for both simple views and left hand side + views. The optional natural number is the number of implicit + arguments to be considered for the declared hint view lemma. -.. cmd:: Hint View for apply//@ident {? | @num } + .. cmdv:: Hint View for apply//@ident {? | @num } -with a double slash ``//``, declares hint views for right hand sides of -double views. + This variant with a double slash ``//``, declares hint views for right + hand sides of double views. -See the files ``ssreflect.v`` and ``ssrbool.v`` for examples. + See the files ``ssreflect.v`` and ``ssrbool.v`` for examples. Multiple views @@ -5157,73 +5127,66 @@ equivalences are indeed taken into account, otherwise only single |SSR| searching tool -------------------- -|SSR| proposes an extension of the Search command. Its syntax is: - .. cmd:: Search {? @pattern } {* {? - } %( @string %| @pattern %) {? % @ident} } {? in {+ {? - } @qualid } } :name: Search (ssreflect) -where :token:`qualid` is the name of an open module. This command returns -the list of lemmas: - + This is the |SSR| extension of the Search command. :token:`qualid` is the + name of an open module. This command returns the list of lemmas: + + + whose *conclusion* contains a subterm matching the optional first + pattern. A - reverses the test, producing the list of lemmas whose + conclusion does not contain any subterm matching the pattern; + + whose name contains the given string. A ``-`` prefix reverses the test, + producing the list of lemmas whose name does not contain the string. A + string that contains symbols or is followed by a scope key, is + interpreted as the constant whose notation involves that string (e.g., + :g:`+` for :g:`addn`), if this is unambiguous; otherwise the diagnostic + includes the output of the :cmd:`Locate` vernacular command. + + whose statement, including assumptions and types, contains a subterm + matching the next patterns. If a pattern is prefixed by ``-``, the test is + reversed; + + contained in the given list of modules, except the ones in the + modules prefixed by a ``-``. + +.. note:: + + + As for regular terms, patterns can feature scope indications. For + instance, the command: ``Search _ (_ + _)%N.`` lists all the lemmas whose + statement (conclusion or hypotheses) involves an application of the + binary operation denoted by the infix ``+`` symbol in the ``N`` scope (which is + |SSR| scope for natural numbers). + + Patterns with holes should be surrounded by parentheses. + + Search always volunteers the expansion of the notation, avoiding the + need to execute Locate independently. Moreover, a string fragment + looks for any notation that contains fragment as a substring. If the + ``ssrbool.v`` library is imported, the command: ``Search "~~".`` answers : -+ whose *conclusion* contains a subterm matching the optional first - pattern. A - reverses the test, producing the list of lemmas whose - conclusion does not contain any subterm matching the pattern; -+ whose name contains the given string. A ``-`` prefix reverses the test, - producing the list of lemmas whose name does not contain the string. A - string that contains symbols or is followed by a scope key, is - interpreted as the constant whose notation involves that string (e.g., - `+` for `addn`), if this is unambiguous; otherwise the diagnostic - includes the output of the ``Locate`` vernacular command. -+ whose statement, including assumptions and types, contains a subterm - matching the next patterns. If a pattern is prefixed by ``-``, the test is - reversed; -+ contained in the given list of modules, except the ones in the - modules prefixed by a ``-``. - - -Note that: - - -+ As for regular terms, patterns can feature scope indications. For - instance, the command: ``Search _ (_ + _)%N.`` lists all the lemmas whose - statement (conclusion or hypotheses) involves an application of the - binary operation denoted by the infix ``+`` symbol in the ``N`` scope (which is - |SSR| scope for natural numbers). -+ Patterns with holes should be surrounded by parentheses. -+ Search always volunteers the expansion of the notation, avoiding the - need to execute Locate independently. Moreover, a string fragment - looks for any notation that contains fragment as a substring. If the - ``ssrbool.v`` library is imported, the command: ``Search "~~".`` answers : - - .. example:: - - .. coqtop:: reset + .. coqtop:: reset - From Coq Require Import ssreflect ssrbool. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. + From Coq Require Import ssreflect ssrbool. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. - .. coqtop:: all + .. coqtop:: all - Search "~~". + Search "~~". -+ A diagnostic is issued if there are different matching notations; it - is an error if all matches are partial. -+ Similarly, a diagnostic warns about multiple interpretations, and - signals an error if there is no default one. -+ The command ``Search in M.`` is a way of obtaining the complete - signature of the module ``M``. -+ Strings and pattern indications can be interleaved, but the first - indication has a special status if it is a pattern, and only filters - the conclusion of lemmas: + + A diagnostic is issued if there are different matching notations; it + is an error if all matches are partial. + + Similarly, a diagnostic warns about multiple interpretations, and + signals an error if there is no default one. + + The command ``Search in M.`` is a way of obtaining the complete + signature of the module ``M``. + + Strings and pattern indications can be interleaved, but the first + indication has a special status if it is a pattern, and only filters + the conclusion of lemmas: - + The command : ``Search (_ =1 _) "bij".`` lists all the lemmas whose - conclusion features a ``=1`` and whose name contains the string ``bij``. - + The command : ``Search "bij" (_ =1 _).`` lists all the lemmas whose - statement, including hypotheses, features a ``=1`` and whose name - contains the string ``bij``. + + The command : ``Search (_ =1 _) "bij".`` lists all the lemmas whose + conclusion features a ``=1`` and whose name contains the string ``bij``. + + The command : ``Search "bij" (_ =1 _).`` lists all the lemmas whose + statement, including hypotheses, features a ``=1`` and whose name + contains the string ``bij``. Synopsis and Index ------------------ @@ -5327,80 +5290,78 @@ respectively. .. tacn:: move -idtac or hnf see :ref:`bookkeeping_ssr` + :tacn:`idtac` or :tacn:`hnf` (see :ref:`bookkeeping_ssr`) .. tacn:: apply -.. tacn:: exact + exact -application see :ref:`the_defective_tactics_ssr` + application (see :ref:`the_defective_tactics_ssr`) .. tacn:: abstract - see :ref:`abstract_ssr` and :ref:`generating_let_ssr` + see :ref:`abstract_ssr` and :ref:`generating_let_ssr` .. tacn:: elim -induction see :ref:`the_defective_tactics_ssr` + induction (see :ref:`the_defective_tactics_ssr`) .. tacn:: case -case analysis see :ref:`the_defective_tactics_ssr` + case analysis (see :ref:`the_defective_tactics_ssr`) .. tacn:: rewrite {+ @r_step } -rewrite see :ref:`rewriting_ssr` + rewrite (see :ref:`rewriting_ssr`) .. tacn:: have {* @i_item } {? @i_pattern } {? @s_item %| {+ @ssr_binder } } {? : @term } := @term -.. tacv:: have {* @i_item } {? @i_pattern } {? @s_item %| {+ @ssr_binder } } : @term {? by @tactic } -.. tacn:: have suff {? @clear_switch } {? @i_pattern } {? : @term } := @term -.. tacv:: have suff {? @clear_switch } {? @i_pattern } : @term {? by @tactic } -.. tacv:: gen have {? @ident , } {? @i_pattern } : {+ @gen_item } / @term {? by @tactic } -.. tacv:: generally have {? @ident , } {? @i_pattern } : {+ @gen_item } / @term {? by @tactic } - :name: generally have - -forward chaining see :ref:`structure_ssr` + have {* @i_item } {? @i_pattern } {? @s_item %| {+ @ssr_binder } } : @term {? by @tactic } + have suff {? @clear_switch } {? @i_pattern } {? : @term } := @term + have suff {? @clear_switch } {? @i_pattern } : @term {? by @tactic } + gen have {? @ident , } {? @i_pattern } : {+ @gen_item } / @term {? by @tactic } + generally have {? @ident , } {? @i_pattern } : {+ @gen_item } / @term {? by @tactic } + :name: _; _; _; _; _; generally have + forward chaining (see :ref:`structure_ssr`) .. tacn:: wlog {? suff } {? @i_item } : {* @gen_item %| @clear_switch } / @term -specializing see :ref:`structure_ssr` + specializing (see :ref:`structure_ssr`) .. tacn:: suff {* @i_item } {? @i_pattern } {+ @ssr_binder } : @term {? by @tactic } - :name: suff -.. tacv:: suffices {* @i_item } {? @i_pattern } {+ @ssr_binder } : @term {? by @tactic } - :name: suffices -.. tacv:: suff {? have } {? @clear_switch } {? @i_pattern } : @term {? by @tactic } -.. tacv:: suffices {? have } {? @clear_switch } {? @i_pattern } : @term {? by @tactic } + suffices {* @i_item } {? @i_pattern } {+ @ssr_binder } : @term {? by @tactic } + suff {? have } {? @clear_switch } {? @i_pattern } : @term {? by @tactic } + suffices {? have } {? @clear_switch } {? @i_pattern } : @term {? by @tactic } + :name: suff; suffices; _; _ -backchaining see :ref:`structure_ssr` + backchaining (see :ref:`structure_ssr`) .. tacn:: pose @ident := @term -local definition :ref:`definitions_ssr` + local definition (see :ref:`definitions_ssr`) .. tacv:: pose @ident {+ @ssr_binder } := @term -local function definition + local function definition .. tacv:: pose fix @fix_body -local fix definition + local fix definition .. tacv:: pose cofix @fix_body -local cofix definition + local cofix definition .. tacn:: set @ident {? : @term } := {? @occ_switch } %( @term %| ( @c_pattern) %) -abbreviation see :ref:`abbreviations_ssr` + abbreviation (see :ref:`abbreviations_ssr`) .. tacn:: unlock {* {? @r_prefix } @ident } -unlock see :ref:`locking_ssr` + unlock (see :ref:`locking_ssr`) .. tacn:: congr {? @num } @term -congruence :ref:`congruence_ssr` + congruence (see :ref:`congruence_ssr`) Tacticals @@ -5439,15 +5400,15 @@ Commands .. cmd:: Hint View for %( move %| apply %) / @ident {? | @num } -view hint declaration see :ref:`declaring_new_hints_ssr` + view hint declaration (see :ref:`declaring_new_hints_ssr`) .. cmd:: Hint View for apply // @ident {? @num } -right hand side double , view hint declaration see :ref:`declaring_new_hints_ssr` + right hand side double , view hint declaration (see :ref:`declaring_new_hints_ssr`) .. cmd:: Prenex Implicits {+ @ident } -prenex implicits declaration see :ref:`parametric_polymorphism_ssr` + prenex implicits declaration (see :ref:`parametric_polymorphism_ssr`) Settings ~~~~~~~~ diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index ad80cb62e1..59602581c7 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3425,7 +3425,9 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. cmdv:: Hint @hint_definition - No database name is given: the hint is registered in the core database. + No database name is given: the hint is registered in the ``core`` database. + + .. deprecated:: 8.10 .. cmdv:: Local Hint @hint_definition : {+ @ident} diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index a5869055fa..47afa5ba0c 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -70,7 +70,7 @@ associativity rules have to be given. The right-hand side of a notation is interpreted at the time the notation is given. In particular, disambiguation of constants, :ref:`implicit arguments - <ImplicitArguments>`, :ref:`coercions <Coercions>`, etc. are resolved at the + <ImplicitArguments>` and other notations are resolved at the time of the declaration of the notation. Precedences and associativity @@ -1583,6 +1583,104 @@ Numeral notations As noted above, the :n:`(abstract after @num)` directive has no effect when :n:`@ident__2` lands in an :g:`option` type. +String notations +----------------- + +.. cmd:: String Notation @ident__1 @ident__2 @ident__3 : @scope. + :name: String Notation + + This command allows the user to customize the way strings are parsed + and printed. + + The token :n:`@ident__1` should be the name of an inductive type, + while :n:`@ident__2` and :n:`@ident__3` should be the names of the + parsing and printing functions, respectively. The parsing function + :n:`@ident__2` should have one of the following types: + + * :n:`Byte.byte -> @ident__1` + * :n:`Byte.byte -> option @ident__1` + * :n:`list Byte.byte -> @ident__1` + * :n:`list Byte.byte -> option @ident__1` + + And the printing function :n:`@ident__3` should have one of the + following types: + + * :n:`@ident__1 -> Byte.byte` + * :n:`@ident__1 -> option Byte.byte` + * :n:`@ident__1 -> list Byte.byte` + * :n:`@ident__1 -> option (list Byte.byte)` + + When parsing, the application of the parsing function + :n:`@ident__2` to the string will be fully reduced, and universes + of the resulting term will be refreshed. + + .. exn:: Cannot interpret this string as a value of type @type + + The string notation registered for :token:`type` does not support + the given string. This error is given when the interpretation + function returns :g:`None`. + + .. exn:: @ident should go from Byte.byte or (list Byte.byte) to @type or (option @type). + + The parsing function given to the :cmd:`String Notation` + vernacular is not of the right type. + + .. exn:: @ident should go from @type to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)). + + The printing function given to the :cmd:`String Notation` + vernacular is not of the right type. + + .. exn:: @type is not an inductive type. + + String notations can only be declared for inductive types with no + arguments. + + .. exn:: Unexpected term @term while parsing a string notation. + + Parsing functions must always return ground terms, made up of + applications of constructors and inductive types. Parsing + functions may not return terms containing axioms, bare + (co)fixpoints, lambdas, etc. + + .. exn:: Unexpected non-option term @term while parsing a string notation. + + Parsing functions expected to return an :g:`option` must always + return a concrete :g:`Some` or :g:`None` when applied to a + concrete string expressed as a decimal. They may not return + opaque constants. + + .. exn:: Cannot interpret in @scope because @ident could not be found in the current environment. + + The inductive type used to register the string notation is no + longer available in the environment. Most likely, this is because + the string notation was declared inside a functor for an + inductive type inside the functor. This use case is not currently + supported. + + Alternatively, you might be trying to use a primitive token + notation from a plugin which forgot to specify which module you + must :g:`Require` for access to that notation. + + .. exn:: Syntax error: [prim:reference] expected after 'Notation' (in [vernac:command]). + + The type passed to :cmd:`String Notation` must be a single + identifier. + + .. exn:: Syntax error: [prim:reference] expected after [prim:reference] (in [vernac:command]). + + Both functions passed to :cmd:`String Notation` must be single + identifiers. + + .. exn:: The reference @ident was not found in the current environment. + + Identifiers passed to :cmd:`String Notation` must exist in the + global environment. + + .. exn:: @ident is bound to a notation that does not denote a reference. + + Identifiers passed to :cmd:`String Notation` must be global + references, or notations which denote to single identifiers. + .. _TacticNotation: Tactic Notations diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 4fc9bf9e19..51f94d7e5a 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -17,6 +17,7 @@ through the <tt>Require Import</tt> command.</p> theories/Init/Datatypes.v theories/Init/Logic.v theories/Init/Logic_Type.v + theories/Init/Byte.v theories/Init/Nat.v theories/Init/Decimal.v theories/Init/Peano.v @@ -497,6 +498,7 @@ through the <tt>Require Import</tt> command.</p> Implementation of string as list of ascii characters </dt> <dd> + theories/Strings/Byte.v theories/Strings/Ascii.v theories/Strings/String.v theories/Strings/BinaryString.v diff --git a/doc/tools/coqrst/coqdoc/main.py b/doc/tools/coqrst/coqdoc/main.py index 57adcb287c..1de9890992 100644 --- a/doc/tools/coqrst/coqdoc/main.py +++ b/doc/tools/coqrst/coqdoc/main.py @@ -35,7 +35,7 @@ COQDOC_HEADER = "".join("(** remove printing {} *)".format(s) for s in COQDOC_SY def coqdoc(coq_code, coqdoc_bin=None): """Get the output of coqdoc on coq_code.""" - coqdoc_bin = coqdoc_bin or os.path.join(os.getenv("COQBIN"), "coqdoc") + coqdoc_bin = coqdoc_bin or os.path.join(os.getenv("COQBIN", ""), "coqdoc") fd, filename = mkstemp(prefix="coqdoc-", suffix=".v") if platform.system().startswith("CYGWIN"): # coqdoc currently doesn't accept cygwin style paths in the form "/cygdrive/c/..." diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 2c69dcfe08..827b7c13c1 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -198,6 +198,25 @@ class CoqObject(ObjectDescription): self._add_index_entry(name, target) return target + def _prepare_names(self): + sigs = self.get_signatures() + names = self.options.get("name") + if names is None: + self._names = {} + else: + names = [n.strip() for n in names.split(";")] + if len(names) != len(sigs): + ERR = ("Expected {} semicolon-separated names, got {}. " + + "Please provide one name per signature line.") + raise self.error(ERR.format(len(names), len(sigs))) + self._names = dict(zip(sigs, names)) + + def run(self): + self._prepare_names() + return super().run() + +class DocumentableObject(CoqObject): + def _warn_if_undocumented(self): document = self.state.document config = document.settings.env.config @@ -212,30 +231,16 @@ class CoqObject(ObjectDescription): if report == "warning": raise self.warning(msg) - def _prepare_names(self): - sigs = self.get_signatures() - names = self.options.get("name") - if names is None: - self._names = {} - else: - names = [n.strip() for n in names.split(";")] - if len(names) != len(sigs): - ERR = ("Expected {} semicolon-separated names, got {}. " + - "Please provide one name per signature line.") - raise self.error(ERR.format(len(names), len(sigs))) - self._names = dict(zip(sigs, names)) - def run(self): self._warn_if_undocumented() - self._prepare_names() return super().run() -class PlainObject(CoqObject): +class PlainObject(DocumentableObject): """A base class for objects whose signatures should be rendered literally.""" def _render_signature(self, signature, signode): signode += addnodes.desc_name(signature, signature) -class NotationObject(CoqObject): +class NotationObject(DocumentableObject): """A base class for objects whose signatures should be rendered as nested boxes. Objects that inherit from this class can use the notation grammar (“{+ …}”, @@ -1,10 +1,12 @@ ; Default flags for all Coq libraries. (env - (dev (flags :standard -rectypes -w -9-27-50+40+60)) + (dev (flags :standard -rectypes -w -9-27+40+60)) (release (flags :standard -rectypes) (ocamlopt_flags -O3 -unbox-closures)) - (ireport (flags :standard -rectypes -w -9-27-50+40+60) - (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report))) + (ireport (flags :standard -rectypes -w -9-27-40+60) + (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report)) + (ocaml408 + (flags :standard -strict-sequence -strict-formats -short-paths -keep-locs -rectypes -w -9-27+40+60 -warn-error -5 -alert --deprecated))) ; The _ profile could help factoring the above, however it doesn't ; seem to work like we'd expect/like: diff --git a/dune-project b/dune-project index 85238c70c5..f0ac11ba61 100644 --- a/dune-project +++ b/dune-project @@ -1,3 +1,2 @@ -(lang dune 1.4) - +(lang dune 1.6) (name coq) diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 96f1ce5e60..24d161d00a 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -606,6 +606,7 @@ let subst_var subst c = of_constr (Vars.subst_var subst (to_constr c)) let subst_univs_level_constr subst c = of_constr (Vars.subst_univs_level_constr subst (to_constr c)) + (** Operations that dot NOT commute with evar-normalization *) let noccurn sigma n term = let rec occur_rec n c = match kind sigma c with diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 69ee5223c4..db56d0628f 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -155,7 +155,7 @@ let is_ground_env = memo is_ground_env exception NoHeadEvar let head_evar sigma c = - (** FIXME: this breaks if using evar-insensitive code *) + (* FIXME: this breaks if using evar-insensitive code *) let c = EConstr.Unsafe.to_constr c in let rec hrec c = match kind c with | Evar (evk,_) -> evk @@ -288,7 +288,7 @@ let empty_csubst = { } let csubst_subst { csubst_len = k; csubst_var = v; csubst_rel = s } c = - (** Safe because this is a substitution *) + (* Safe because this is a substitution *) let c = EConstr.Unsafe.to_constr c in let rec subst n c = match Constr.kind c with | Rel m -> @@ -318,7 +318,7 @@ let update_var src tgt subst = in match cur with | None -> - (** Missing keys stand for identity substitution [src ↦ src] *) + (* Missing keys stand for identity substitution [src ↦ src] *) let csubst_var = Id.Map.add src (Constr.mkVar tgt) subst.csubst_var in let csubst_rev = Id.Map.add tgt (SVar src) subst.csubst_rev in { subst with csubst_var; csubst_rev } @@ -366,8 +366,8 @@ let push_rel_decl_to_named_context about this whole name generation problem. *) if Flags.is_program_mode () then next_name_away na avoid else - (** id_of_name_using_hdchar only depends on the rel context which is empty - here *) + (* id_of_name_using_hdchar only depends on the rel context which is empty + here *) next_ident_away (id_of_name_using_hdchar empty_env sigma (RelDecl.get_type decl) na) avoid in match extract_if_neq id na with @@ -540,8 +540,8 @@ let restrict_evar evd evk filter ?src candidates = | Some [] -> raise (ClearDependencyError (*FIXME*)(Id.of_string "blah", (NoCandidatesLeft evk), None)) | _ -> let evd, evk' = Evd.restrict evk filter ?candidates ?src evd in - (** Mark new evar as future goal, removing previous one, - circumventing Proofview.advance but making Proof.run_tactic catch these. *) + (* Mark new evar as future goal, removing previous one, + circumventing Proofview.advance but making Proof.run_tactic catch these. *) let future_goals = Evd.save_future_goals evd in let future_goals = Evd.filter_future_goals (fun evk' -> not (Evar.equal evk evk')) future_goals in let evd = Evd.restore_future_goals evd future_goals in @@ -779,7 +779,7 @@ let cached_evar_of_hyp cache sigma decl accu = match cache with let r = try Id.Map.find id cache.cache with Not_found -> - (** Dummy value *) + (* Dummy value *) let r = ref (NamedDecl.LocalAssum (id, EConstr.mkProp), Evar.Set.empty) in let () = cache.cache <- Id.Map.add id r cache.cache in r diff --git a/engine/evd.ml b/engine/evd.ml index 6345046431..7bc3be87a4 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -89,8 +89,8 @@ struct | Some f2 -> normalize (CList.filter_with f1 f2) let apply_subfilter_array filter subfilter = - (** In both cases we statically know that the argument will contain at - least one [false] *) + (* In both cases we statically know that the argument will contain at + least one [false] *) match filter with | None -> Some (Array.to_list subfilter) | Some f -> @@ -395,7 +395,7 @@ let rename evk id (evtoid, idtoev) = let reassign_name_defined evk evk' (evtoid, idtoev as names) = let id = try Some (EvMap.find evk evtoid) with Not_found -> None in match id with - | None -> names (** evk' must not be defined *) + | None -> names (* evk' must not be defined *) | Some id -> (EvMap.add evk' id (EvMap.remove evk evtoid), Id.Map.add id evk' (Id.Map.remove id idtoev)) @@ -416,7 +416,7 @@ type evar_flags = typeclass_evars : Evar.Set.t } type evar_map = { - (** Existential variables *) + (* Existential variables *) defn_evars : evar_info EvMap.t; undf_evars : evar_info EvMap.t; evar_names : EvNames.t; @@ -520,7 +520,7 @@ let inherit_evar_flags evar_flags evk evk' = let remove_evar_flags evk evar_flags = { typeclass_evars = Evar.Set.remove evk evar_flags.typeclass_evars; obligation_evars = Evar.Set.remove evk evar_flags.obligation_evars; - (** Restriction information is kept. *) + (* Restriction information is kept. *) restricted_evars = evar_flags.restricted_evars } (** New evars *) @@ -1341,14 +1341,14 @@ module MiniEConstr = struct | None -> c end | App (f, args) when isEvar f -> - (** Enforce smart constructor invariant on applications *) + (* Enforce smart constructor invariant on applications *) let ev = destEvar f in begin match safe_evar_value sigma ev with | None -> c | Some f -> whd_evar sigma (mkApp (f, args)) end | Cast (c0, k, t) when isEvar c0 -> - (** Enforce smart constructor invariant on casts. *) + (* Enforce smart constructor invariant on casts. *) let ev = destEvar c0 in begin match safe_evar_value sigma ev with | None -> c diff --git a/engine/evd.mli b/engine/evd.mli index 0a8d1f3287..7560d68805 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -86,7 +86,7 @@ type evar_body = type evar_info = { evar_concl : econstr; (** Type of the evar. *) - evar_hyps : named_context_val; (** TODO econstr? *) + evar_hyps : named_context_val; (* TODO econstr? *) (** Context of the evar. *) evar_body : evar_body; (** Optional content of the evar. *) @@ -546,6 +546,7 @@ val univ_flexible_alg : rigid type 'a in_evar_universe_context = 'a * UState.t val restrict_universe_context : evar_map -> Univ.LSet.t -> evar_map + (** Raises Not_found if not a name for a universe in this map. *) val universe_of_name : evar_map -> Id.t -> Univ.Level.t @@ -567,6 +568,7 @@ val make_nonalgebraic_variable : evar_map -> Univ.Level.t -> evar_map val is_sort_variable : evar_map -> Sorts.t -> Univ.Level.t option (** [is_sort_variable evm s] returns [Some u] or [None] if [s] is not a local sort variable declared in [evm] *) + val is_flexible_level : evar_map -> Univ.Level.t -> bool (* val normalize_universe_level : evar_map -> Univ.Level.t -> Univ.Level.t *) diff --git a/engine/ftactic.ml b/engine/ftactic.ml index b371884ba4..ac0344148a 100644 --- a/engine/ftactic.ml +++ b/engine/ftactic.ml @@ -29,8 +29,8 @@ let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function | Depends l -> let f arg = f arg >>= function | Uniform x -> - (** We dispatch the uniform result on each goal under focus, as we know - that the [m] argument was actually dependent. *) + (* We dispatch the uniform result on each goal under focus, as we know + that the [m] argument was actually dependent. *) Proofview.Goal.goals >>= fun goals -> let ans = List.map (fun g -> (g,x)) goals in Proofview.tclUNIT ans diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index 4afa817b27..e0c24f049f 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -28,8 +28,10 @@ from the IO monad ([Proofview] catches errors in its compatibility layer, and when lifting goal-level expressions). *) exception Exception of exn + (** This exception is used to signal abortion in [timeout] functions. *) exception Timeout + (** This exception is used by the tactics to signal failure by lack of successes, rather than some other exceptions (like system interrupts). *) diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli index 545334ce9a..3e57baab26 100644 --- a/engine/logic_monad.mli +++ b/engine/logic_monad.mli @@ -28,8 +28,10 @@ from the IO monad ([Proofview] catches errors in its compatibility layer, and when lifting goal-level expressions). *) exception Exception of exn + (** This exception is used to signal abortion in [timeout] functions. *) exception Timeout + (** This exception is used by the tactics to signal failure by lack of successes, rather than some other exceptions (like system interrupts). *) @@ -51,8 +53,10 @@ module NonLogical : sig val ref : 'a -> 'a ref t (** [Pervasives.(:=)] *) + val (:=) : 'a ref -> 'a -> unit t (** [Pervasives.(!)] *) + val (!) : 'a ref -> 'a t val read_line : string t @@ -67,6 +71,7 @@ module NonLogical : sig (** [Pervasives.raise]. Except that exceptions are wrapped with {!Exception}. *) val raise : ?info:Exninfo.info -> exn -> 'a t + (** [try ... with ...] but restricted to {!Exception}. *) val catch : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t val timeout : int -> 'a t -> 'a t diff --git a/engine/namegen.ml b/engine/namegen.ml index a67ff6965b..018eca1ba2 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -358,7 +358,7 @@ let next_name_away_with_default_using_types default na avoid t = let next_name_away = next_name_away_with_default default_non_dependent_string let make_all_name_different env sigma = - (** FIXME: this is inefficient, but only used in printing *) + (* FIXME: this is inefficient, but only used in printing *) let avoid = ref (ids_of_named_context_val (named_context_val env)) in let sign = named_context_val env in let rels = rel_context env in diff --git a/engine/nameops.mli b/engine/nameops.mli index 8a93fad8cc..a5308904f5 100644 --- a/engine/nameops.mli +++ b/engine/nameops.mli @@ -16,6 +16,7 @@ val make_ident : string -> int option -> Id.t val repr_ident : Id.t -> string * int option val atompart_of_id : Id.t -> string (** remove trailing digits *) + val root_of_id : Id.t -> Id.t (** remove trailing digits, ' and _ *) val add_suffix : Id.t -> string -> Id.t diff --git a/engine/proofview.ml b/engine/proofview.ml index 304b2dff84..8c15579bb0 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -660,9 +660,9 @@ let unifiable_delayed g l = let free_evars sigma l = let cache = Evarutil.create_undefined_evars_cache () in let map ev = - (** Computes the set of evars appearing in the hypotheses, the conclusion or - the body of the evar_info [evi]. Note: since we want to use it on goals, - the body is actually supposed to be empty. *) + (* Computes the set of evars appearing in the hypotheses, the conclusion or + the body of the evar_info [evi]. Note: since we want to use it on goals, + the body is actually supposed to be empty. *) let evi = Evd.find sigma ev in let fevs = lazy (Evarutil.filtered_undefined_evars_of_evar_info ~cache sigma evi) in (ev, fevs) @@ -672,9 +672,9 @@ let free_evars sigma l = let free_evars_with_state sigma l = let cache = Evarutil.create_undefined_evars_cache () in let map ev = - (** Computes the set of evars appearing in the hypotheses, the conclusion or - the body of the evar_info [evi]. Note: since we want to use it on goals, - the body is actually supposed to be empty. *) + (* Computes the set of evars appearing in the hypotheses, the conclusion or + the body of the evar_info [evi]. Note: since we want to use it on goals, + the body is actually supposed to be empty. *) let ev = drop_state ev in let evi = Evd.find sigma ev in let fevs = lazy (Evarutil.filtered_undefined_evars_of_evar_info ~cache sigma evi) in @@ -1157,7 +1157,7 @@ module Goal = struct let sigma = step.solution in let map goal = match cleared_alias sigma goal with - | None -> None (** ppedrot: Is this check really necessary? *) + | None -> None (* ppedrot: Is this check really necessary? *) | Some goal -> let gl = Env.get >>= fun env -> diff --git a/engine/proofview.mli b/engine/proofview.mli index cda4808a23..28e793f0fc 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -398,6 +398,7 @@ val tclPROGRESS : 'a tactic -> 'a tactic val tclCHECKINTERRUPT : unit tactic exception Timeout + (** [tclTIMEOUT n t] can have only one success. In case of timeout if fails with [tclZERO Timeout]. *) val tclTIMEOUT : int -> 'a tactic -> 'a tactic @@ -517,8 +518,8 @@ module Goal : sig (** Like {!nf_enter}, but does not normalize the goal beforehand. *) val enter : (t -> unit tactic) -> unit tactic - (** Like {!enter}, but assumes exactly one goal under focus, raising *) - (** a fatal error otherwise. *) + (** Like {!enter}, but assumes exactly one goal under focus, raising + a fatal error otherwise. *) val enter_one : ?__LOC__:string -> (t -> 'a tactic) -> 'a tactic (** Recover the list of current goals under focus, without evar-normalization. @@ -612,8 +613,10 @@ module Notations : sig (** {!tclBIND} *) val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic + (** {!tclTHEN} *) val (<*>) : unit tactic -> 'a tactic -> 'a tactic + (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) val (<+>) : 'a tactic -> 'a tactic -> 'a tactic diff --git a/engine/termops.ml b/engine/termops.ml index 98300764df..137770d8f0 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -197,8 +197,8 @@ let compute_evar_dependency_graph sigma = let evar_dependency_closure n sigma = let open Evd in - (** Create the DAG of depth [n] representing the recursive dependencies of - undefined evars. *) + (* Create the DAG of depth [n] representing the recursive dependencies of + undefined evars. *) let graph = compute_evar_dependency_graph sigma in let rec aux n curr accu = if Int.equal n 0 then Evar.Set.union curr accu @@ -209,9 +209,9 @@ let evar_dependency_closure n sigma = Evar.Set.union deps accu with Not_found -> accu in - (** Consider only the newly added evars *) + (* Consider only the newly added evars *) let ncurr = Evar.Set.fold fold curr Evar.Set.empty in - (** Merge the others *) + (* Merge the others *) let accu = Evar.Set.union curr accu in aux (n - 1) ncurr accu in @@ -261,13 +261,13 @@ let print_env_short env sigma = let pr_evar_constraints sigma pbs = let pr_evconstr (pbty, env, t1, t2) = let env = - (** We currently allow evar instances to refer to anonymous de - Bruijn indices, so we protect the error printing code in this - case by giving names to every de Bruijn variable in the - rel_context of the conversion problem. MS: we should rather - stop depending on anonymous variables, they can be used to - indicate independency. Also, this depends on a strategy for - naming/renaming. *) + (* We currently allow evar instances to refer to anonymous de + Bruijn indices, so we protect the error printing code in this + case by giving names to every de Bruijn variable in the + rel_context of the conversion problem. MS: we should rather + stop depending on anonymous variables, they can be used to + indicate independency. Also, this depends on a strategy for + naming/renaming. *) Namegen.make_all_name_different env sigma in print_env_short env sigma ++ spc () ++ str "|-" ++ spc () ++ diff --git a/engine/termops.mli b/engine/termops.mli index eef8452e64..7920af8e0e 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -290,7 +290,7 @@ val is_Prop : Evd.evar_map -> constr -> bool val is_Set : Evd.evar_map -> constr -> bool val is_Type : Evd.evar_map -> constr -> bool -val reference_of_level : Evd.evar_map -> Univ.Level.t -> Libnames.qualid +val reference_of_level : Evd.evar_map -> Univ.Level.t -> Libnames.qualid option (** Combinators on judgments *) diff --git a/engine/uState.ml b/engine/uState.ml index 6aecc368e6..6969d2ba44 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -197,7 +197,7 @@ let process_universe_constraints ctx cstrs = | Some l -> Inr l in let equalize_variables fo l l' r r' local = - (** Assumes l = [l',0] and r = [r',0] *) + (* Assumes l = [l',0] and r = [r',0] *) let () = if is_local l' then instantiate_variable l' r vars @@ -235,8 +235,8 @@ let process_universe_constraints ctx cstrs = match cst with | ULe (l, r) -> if UGraph.check_leq univs l r then - (** Keep Prop/Set <= var around if var might be instantiated by prop or set - later. *) + (* Keep Prop/Set <= var around if var might be instantiated by prop or set + later. *) match Univ.Universe.level l, Univ.Universe.level r with | Some l, Some r -> Univ.Constraint.add (l, Univ.Le, r) local @@ -324,12 +324,14 @@ let constrain_variables diff ctx = let qualid_of_level uctx = let map, map_rev = uctx.uctx_names in fun l -> - try Libnames.qualid_of_ident (Option.get (Univ.LMap.find l map_rev).uname) + try Some (Libnames.qualid_of_ident (Option.get (Univ.LMap.find l map_rev).uname)) with Not_found | Option.IsNone -> UnivNames.qualid_of_level l let pr_uctx_level uctx l = - Libnames.pr_qualid (qualid_of_level uctx l) + match qualid_of_level uctx l with + | Some qid -> Libnames.pr_qualid qid + | None -> Univ.Level.pr l type ('a, 'b) gen_universe_decl = { univdecl_instance : 'a; (* Declared universes *) @@ -533,7 +535,7 @@ let emit_side_effects eff u = let new_univ_variable ?loc rigid name ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = - let u = UnivGen.new_univ_level () in + let u = UnivGen.fresh_level () in let ctx' = Univ.ContextSet.add_universe u ctx in let uctx', pred = match rigid with diff --git a/engine/uState.mli b/engine/uState.mli index ad0cd5c1bb..5170184ef4 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -188,6 +188,6 @@ val update_sigma_env : t -> Environ.env -> t (** {5 Pretty-printing} *) val pr_uctx_level : t -> Univ.Level.t -> Pp.t -val qualid_of_level : t -> Univ.Level.t -> Libnames.qualid +val qualid_of_level : t -> Univ.Level.t -> Libnames.qualid option val pr_weak : (Univ.Level.t -> Pp.t) -> t -> Pp.t diff --git a/engine/univGen.ml b/engine/univGen.ml index 130aa06f53..40c4c909fe 100644 --- a/engine/univGen.ml +++ b/engine/univGen.ml @@ -13,26 +13,25 @@ open Names open Constr open Univ +type univ_unique_id = int (* Generator of levels *) -type universe_id = DirPath.t * int - let new_univ_id, set_remote_new_univ_id = RemoteCounter.new_counter ~name:"Universes" 0 ~incr:((+) 1) - ~build:(fun n -> Global.current_dirpath (), n) + ~build:(fun n -> n) -let new_univ_level () = - let dp, id = new_univ_id () in - Univ.Level.make dp id +let new_univ_global () = + Univ.Level.UGlobal.make (Global.current_dirpath ()) (new_univ_id ()) -let fresh_level () = new_univ_level () +let fresh_level () = + Univ.Level.make (new_univ_global ()) (* TODO: remove *) -let new_univ dp = Univ.Universe.make (new_univ_level dp) -let new_Type dp = mkType (new_univ dp) -let new_Type_sort dp = Type (new_univ dp) +let new_univ () = Univ.Universe.make (fresh_level ()) +let new_Type () = mkType (new_univ ()) +let new_Type_sort () = Type (new_univ ()) let fresh_instance auctx = - let inst = Array.init (AUContext.size auctx) (fun _ -> new_univ_level()) in + let inst = Array.init (AUContext.size auctx) (fun _ -> fresh_level()) in let ctx = Array.fold_right LSet.add inst LSet.empty in let inst = Instance.of_array inst in inst, (ctx, AUContext.instantiate inst auctx) diff --git a/engine/univGen.mli b/engine/univGen.mli index 8af5f8fdb0..b4598e10d0 100644 --- a/engine/univGen.mli +++ b/engine/univGen.mli @@ -15,14 +15,14 @@ open Univ (** The global universe counter *) -type universe_id = DirPath.t * int - -val set_remote_new_univ_id : universe_id RemoteCounter.installer +type univ_unique_id +val set_remote_new_univ_id : univ_unique_id RemoteCounter.installer +val new_univ_id : unit -> univ_unique_id (** for the stm *) (** Side-effecting functions creating new universe levels. *) -val new_univ_id : unit -> universe_id -val new_univ_level : unit -> Level.t +val new_univ_global : unit -> Level.UGlobal.t +val fresh_level : unit -> Level.t val new_univ : unit -> Universe.t [@@ocaml.deprecated "Use [new_univ_level]"] diff --git a/engine/univMinim.ml b/engine/univMinim.ml index e20055b133..1619ac3d34 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -32,15 +32,15 @@ let add_list_map u t map = let choose_canonical ctx flexible algs s = let global = LSet.diff s ctx in let flexible, rigid = LSet.partition flexible (LSet.inter s ctx) in - (** If there is a global universe in the set, choose it *) + (* If there is a global universe in the set, choose it *) if not (LSet.is_empty global) then let canon = LSet.choose global in canon, (LSet.remove canon global, rigid, flexible) - else (** No global in the equivalence class, choose a rigid one *) + else (* No global in the equivalence class, choose a rigid one *) if not (LSet.is_empty rigid) then let canon = LSet.choose rigid in canon, (global, LSet.remove canon rigid, flexible) - else (** There are only flexible universes in the equivalence + else (* There are only flexible universes in the equivalence class, choose a non-algebraic. *) let algs, nonalgs = LSet.partition (fun x -> LSet.mem x algs) flexible in if not (LSet.is_empty nonalgs) then @@ -94,8 +94,8 @@ let find_inst insts v = with Found (f,l) -> (f,l) let compute_lbound left = - (** The universe variable was not fixed yet. - Compute its level using its lower bound. *) + (* The universe variable was not fixed yet. + Compute its level using its lower bound. *) let sup l lbound = match lbound with | None -> Some l @@ -154,9 +154,10 @@ let not_lower lower (d,l) = * constraints we must keep it. *) compare_constraint_type d d' > 0 with Not_found -> - (** No constraint existing on l *) true) l + (* No constraint existing on l *) true) l exception UpperBoundedAlg + (** [enforce_uppers upper lbound cstrs] interprets [upper] as upper constraints to [lbound], adding them to [cstrs]. @@ -269,7 +270,7 @@ module UPairSet = Set.Make (UPairs) let normalize_context_set g ctx us algs weak = let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in - (** Keep the Prop/Set <= i constraints separate for minimization *) + (* Keep the Prop/Set <= i constraints separate for minimization *) let smallles, csts = Constraint.partition (fun (l,d,r) -> d == Le && Level.is_small l) csts in diff --git a/engine/univNames.ml b/engine/univNames.ml index 1019f8f0c2..7e6ed5e4c0 100644 --- a/engine/univNames.ml +++ b/engine/univNames.ml @@ -15,17 +15,15 @@ open Univ let qualid_of_level l = match Level.name l with - | Some (d, n as na) -> - begin - try Nametab.shortest_qualid_of_universe na - with Not_found -> - let name = Id.of_string_soft (string_of_int n) in - Libnames.make_qualid d name - end - | None -> - Libnames.qualid_of_ident @@ Id.of_string_soft (Level.to_string l) + | Some qid -> + (try Some (Nametab.shortest_qualid_of_universe qid) + with Not_found -> None) + | None -> None -let pr_with_global_universes l = Libnames.pr_qualid (qualid_of_level l) +let pr_with_global_universes l = + match qualid_of_level l with + | Some qid -> Libnames.pr_qualid qid + | None -> Level.pr l (** Global universe information outside the kernel, to handle polymorphic universe names in sections that have to be discharged. *) @@ -37,8 +35,8 @@ type universe_binders = Univ.Level.t Names.Id.Map.t let empty_binders = Id.Map.empty let name_universe lvl = - (** Best-effort naming from the string representation of the level. This is - completely hackish and should be solved in upper layers instead. *) + (* Best-effort naming from the string representation of the level. This is + completely hackish and should be solved in upper layers instead. *) Id.of_string_soft (Level.to_string lvl) let compute_instance_binders inst ubinders = diff --git a/engine/univNames.mli b/engine/univNames.mli index 6e68153ac2..e9c517babf 100644 --- a/engine/univNames.mli +++ b/engine/univNames.mli @@ -11,7 +11,7 @@ open Univ val pr_with_global_universes : Level.t -> Pp.t -val qualid_of_level : Level.t -> Libnames.qualid +val qualid_of_level : Level.t -> Libnames.qualid option (** Local universe name <-> level mapping *) diff --git a/gramlib/ploc.mli b/gramlib/ploc.mli index 766e96fdfc..100fbc7271 100644 --- a/gramlib/ploc.mli +++ b/gramlib/ploc.mli @@ -10,6 +10,7 @@ exception Exc of Loc.t * exn for an error. This exception must not be raised by [raise] but rather by [Ploc.raise] (see below), to prevent the risk of several encapsulations of [Ploc.Exc]. *) + val raise : Loc.t -> exn -> 'a (** [Ploc.raise loc e], if [e] is already the exception [Ploc.Exc], re-raise it (ignoring the new location [loc]), else raise the @@ -29,9 +30,11 @@ val sub : Loc.t -> int -> int -> Loc.t (** [Ploc.sub loc sh len] is the location [loc] shifted with [sh] characters and with length [len]. The previous ending position of the location is lost. *) + val after : Loc.t -> int -> int -> Loc.t (** [Ploc.after loc sh len] is the location just after loc (starting at the end position of [loc]) shifted with [sh] characters and of length [len]. *) + val with_comment : Loc.t -> string -> Loc.t (** Change the comment part of the given location *) diff --git a/ide/configwin_ihm.ml b/ide/configwin_ihm.ml index 91695e944e..8420d930d5 100644 --- a/ide/configwin_ihm.ml +++ b/ide/configwin_ihm.ml @@ -209,7 +209,8 @@ class ['a] list_selection_box () initializer - (** create the functions called when the buttons are clicked *) + + (* create the functions called when the buttons are clicked *) let f_add () = (* get the files to add with the function provided *) let l = add_function () in @@ -300,8 +301,10 @@ class string_param_box param (tt:GData.tooltips) = let _ = we#set_text (param.string_to_string param.string_value) in object (self) + (** This method returns the main box ready to be packed. *) method box = hbox#coerce + (** This method applies the new value of the parameter. *) method apply = let new_value = param.string_of_string we#text in @@ -347,9 +350,11 @@ class combo_param_box param (tt:GData.tooltips) = fun () -> wc#entry#text in object (self) + (** This method returns the main box ready to be packed. *) method box = hbox#coerce - (** This method applies the new value of the parameter. *) + + (** This method applies the new value of the parameter. *) method apply = let new_value = get_value () in if new_value <> param.combo_value then @@ -404,8 +409,10 @@ class text_param_box param (tt:GData.tooltips) = let _ = dbg "text_param_box: object(self)" in object (self) val wview = wview + (** This method returns the main box ready to be packed. *) method box = wf#coerce + (** This method applies the new value of the parameter. *) method apply = let v = param.string_of_string (buffer#get_text ()) in @@ -435,8 +442,10 @@ class bool_param_box param (tt:GData.tooltips) = let _ = wchk#misc#set_sensitive param.bool_editable in object (self) + (** This method returns the check button ready to be packed. *) method box = wchk#coerce + (** This method applies the new value of the parameter. *) method apply = let new_value = wchk#active in @@ -471,8 +480,10 @@ class modifiers_param_box param = tooltips#set_tip wev#coerce ~text: help ~privat: help in object (self) + (** This method returns the main box ready to be packed. *) method box = hbox#coerce + (** This method applies the new value of the parameter. *) method apply = let new_value = !value in @@ -500,8 +511,10 @@ class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) = in object (self) + (** This method returns the main box ready to be packed. *) method box = frame_selection#box#coerce + (** This method applies the new value of the parameter. *) method apply = param.list_f_apply !listref ; diff --git a/ide/coq.ml b/ide/coq.ml index 88ffb4f0b7..91cd448eda 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -334,8 +334,8 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all = (* Parsing error at the end of s : we have only received a part of an xml answer. We store the current fragment for later *) let l_end = Lexing.lexeme_end lex in - (** Heuristic hack not to reimplement the lexer: if ever the lexer dies - twice at the same place, then this is a non-recoverable error *) + (* Heuristic hack not to reimplement the lexer: if ever the lexer dies + twice at the same place, then this is a non-recoverable error *) if state.lexerror = Some l_end then raise e; state.lexerror <- Some l_end @@ -496,7 +496,7 @@ let init_coqtop coqtop task = type 'a query = 'a Interface.value task let eval_call call handle k = - (** Send messages to coqtop and prepare the decoding of the answer *) + (* Send messages to coqtop and prepare the decoding of the answer *) Minilib.log ("Start eval_call " ^ Xmlprotocol.pr_call call); assert (handle.alive && handle.waiting_for = None); handle.waiting_for <- Some (mk_ccb (call,k)); diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 6c3438a4b0..8da9900724 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -255,8 +255,8 @@ object(self) let sentence = Doc.find document find in let mark = sentence.start in let iter = script#buffer#get_iter_at_mark mark in - (** Sentence starts tend to be at the end of a line, so we rather choose - the first non-line-ending position. *) + (* Sentence starts tend to be at the end of a line, so we rather choose + the first non-line-ending position. *) let rec sentence_start iter = if iter#ends_line then sentence_start iter#forward_line else iter diff --git a/ide/coqide.ml b/ide/coqide.ml index 40b8d2f484..48c08899e0 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -566,7 +566,7 @@ let update_status sn = Coq.bind (Coq.status false) next let find_next_occurrence ~backward sn = - (** go to the next occurrence of the current word, forward or backward *) + (* go to the next occurrence of the current word, forward or backward *) let b = sn.buffer in let start = find_word_start (b#get_iter_at_mark `INSERT) in let stop = find_word_end start in @@ -613,11 +613,11 @@ let printopts_callback opts v = (** Templates menu *) let get_current_word term = - (** First look to find if autocompleting *) + (* First look to find if autocompleting *) match term.script#complete_popup#proposal with | Some p -> p | None -> - (** Then look at the current selected word *) + (* Then look at the current selected word *) let buf1 = term.script#buffer in let buf2 = term.proof#buffer in if buf1#has_selection then @@ -628,7 +628,7 @@ let get_current_word term = buf2#get_text ~slice:true ~start ~stop () else if term.messages#has_selection then term.messages#get_selected_text - (** Otherwise try to find the word around the cursor *) + (* Otherwise try to find the word around the cursor *) else let it = term.script#buffer#get_iter_at_mark `INSERT in let start = find_word_start it in @@ -772,11 +772,11 @@ let uncomment = cb_on_current_term (fun t -> t.script#uncomment ()) let coqtop_arguments sn = let dialog = GWindow.dialog ~title:"Coqtop arguments" () in let coqtop = sn.coqtop in - (** Text entry *) + (* Text entry *) let args = Coq.get_arguments coqtop in let text = String.concat " " args in let entry = GEdit.entry ~text ~packing:dialog#vbox#add () in - (** Buttons *) + (* Buttons *) let box = dialog#action_area in let ok = GButton.button ~stock:`OK ~packing:box#add () in let ok_cb () = diff --git a/ide/fake_ide.ml b/ide/fake_ide.ml index 521aff6bf6..8b0c736f50 100644 --- a/ide/fake_ide.ml +++ b/ide/fake_ide.ml @@ -11,7 +11,7 @@ (** Fake_ide : Simulate a [coqide] talking to a [coqidetop] *) let error s = - prerr_endline ("fake_id: error: "^s); + prerr_endline ("fake_ide: error: "^s); exit 1 let pperr_endline pp = Format.eprintf "@[%a@]\n%!" Pp.pp_with pp @@ -22,7 +22,7 @@ type coqtop = { } let print_error msg = - Format.eprintf "fake_id: error: @[%a@]\n%!" Pp.pp_with msg + Format.eprintf "fake_ide: error: @[%a@]\n%!" Pp.pp_with msg let base_eval_call ?(print=true) ?(fail=true) call coqtop = if print then prerr_endline (Xmlprotocol.pr_call call); @@ -257,10 +257,15 @@ let eval_print l coq = eval_call (wait ()) coq | [ Tok(_,"JOIN") ] -> eval_call (status true) coq + | [ Tok(_,"FAILJOIN") ] -> + after_fail coq (base_eval_call ~fail:false (status true) coq) | [ Tok(_,"ASSERT"); Tok(_,"TIP"); Tok(_,id) ] -> let to_id, _ = get_id id in if not(Stateid.equal (Document.tip doc) to_id) then error "Wrong tip" else prerr_endline "Good tip" + | [ Tok(_,"ABORT") ] -> + prerr_endline "Quitting fake_ide"; + exit 0 | Tok("#[^\n]*",_) :: _ -> () | _ -> error "syntax error" @@ -276,6 +281,8 @@ let grammar = ; Seq [Item (eat_rex "JOIN")] ; Seq [Item (eat_rex "GOALS")] ; Seq [Item (eat_rex "FAILGOALS")] + ; Seq [Item (eat_rex "FAILJOIN")] + ; Seq [Item (eat_rex "ABORT")] ; Seq [Item (eat_rex "ASSERT"); Item (eat_rex "TIP"); Item eat_id ] ; Item (eat_rex "#[^\n]*") ] @@ -305,6 +312,8 @@ let main = Array.of_list (def_args @ ct), f | _ -> usage () in let inc = if input_file = "-" then stdin else open_in input_file in + prerr_endline ("Running: "^idetop_name^" "^ + (String.concat " " (Array.to_list coqtop_args))); let coq = let _p, cin, cout = Coqide.spawn idetop_name coqtop_args in let ip = Xml_parser.make (Xml_parser.SChannel cin) in diff --git a/ide/idetop.ml b/ide/idetop.ml index a2b85041e8..716a942d5c 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -196,12 +196,24 @@ let process_goal sigma g = (Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in { Interface.goal_hyp = List.rev hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; } -let export_pre_goals pgs = - { - Interface.fg_goals = pgs.Proof.fg_goals; - Interface.bg_goals = pgs.Proof.bg_goals; - Interface.shelved_goals = pgs.Proof.shelved_goals; - Interface.given_up_goals = pgs.Proof.given_up_goals +let process_goal_diffs diff_goal_map oldp nsigma ng = + let open Evd in + let og_s = match oldp with + | Some oldp -> + let Proof.{ sigma=osigma } = Proof.data oldp in + (try Some { it = Evar.Map.find ng diff_goal_map; sigma = osigma } + with Not_found -> None) + | None -> None + in + let (hyps_pp_list, concl_pp) = Proof_diffs.diff_goal_ide og_s ng nsigma in + { Interface.goal_hyp = hyps_pp_list; Interface.goal_ccl = concl_pp; Interface.goal_id = Goal.uid ng } + +let export_pre_goals Proof.{ sigma; goals; stack; shelf; given_up } process = + let process = List.map (process sigma) in + { Interface.fg_goals = process goals + ; Interface.bg_goals = List.(map (fun (lg,rg) -> process lg, process rg)) stack + ; Interface.shelved_goals = process shelf + ; Interface.given_up_goals = process given_up } let goals () = @@ -212,22 +224,9 @@ let goals () = if Proof_diffs.show_diffs () then begin let oldp = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in let diff_goal_map = Proof_diffs.make_goal_map oldp newp in - - let process_goal_diffs nsigma ng = - let open Evd in - let og_s = match oldp with - | Some oldp -> - let (_,_,_,_,osigma) = Proof.proof oldp in - (try Some { it = Evar.Map.find ng diff_goal_map; sigma = osigma } - with Not_found -> raise (Pp_diff.Diff_Failure "Unable to match goals between old and new proof states (6)")) - | None -> None - in - let (hyps_pp_list, concl_pp) = Proof_diffs.diff_goal_ide og_s ng nsigma in - { Interface.goal_hyp = hyps_pp_list; Interface.goal_ccl = concl_pp; Interface.goal_id = Goal.uid ng } - in - Some (export_pre_goals (Proof.map_structured_proof newp process_goal_diffs)) + Some (export_pre_goals Proof.(data newp) (process_goal_diffs diff_goal_map oldp)) end else - Some (export_pre_goals (Proof.map_structured_proof newp process_goal)) + Some (export_pre_goals Proof.(data newp) process_goal) with Proof_global.NoCurrentProof -> None;; let evars () = @@ -235,7 +234,7 @@ let evars () = let doc = get_doc () in set_doc @@ Stm.finish ~doc; let pfts = Proof_global.give_me_the_proof () in - let all_goals, _, _, _, sigma = Proof.proof pfts in + let Proof.{ sigma } = Proof.data pfts in let exl = Evar.Map.bindings (Evd.undefined_map sigma) in let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar sigma ev); } in let el = List.map map_evar exl in @@ -245,8 +244,8 @@ let evars () = let hints () = try let pfts = Proof_global.give_me_the_proof () in - let all_goals, _, _, _, sigma = Proof.proof pfts in - match all_goals with + let Proof.{ goals; sigma } = Proof.data pfts in + match goals with | [] -> None | g :: _ -> let env = Goal.V82.env sigma g in @@ -263,9 +262,9 @@ let wait () = set_doc (Stm.wait ~doc) let status force = - (** We remove the initial part of the current [DirPath.t] - (usually Top in an interactive session, cf "coqtop -top"), - and display the other parts (opened sections and modules) *) + (* We remove the initial part of the current [DirPath.t] + (usually Top in an interactive session, cf "coqtop -top"), + and display the other parts (opened sections and modules) *) set_doc (Stm.finish ~doc:(get_doc ())); if force then set_doc (Stm.join ~doc:(get_doc ())); @@ -408,14 +407,12 @@ let interp ((_raw, verbose), s) = (** When receiving the Quit call, we don't directly do an [exit 0], but rather set this reference, in order to send a final answer before exiting. *) - let quit = ref false (** Disabled *) let print_ast id = Xml_datatype.PCData "ERROR" (** Grouping all call handlers together + error handling *) - let eval_call c = let interruptible f x = catch_break := true; diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 7044263b94..c14af7d21d 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -43,10 +43,10 @@ color on Windows. A clean fix, if ever needed, would be to combine the attribut of the tags into a single composite tag before applying. This is left as an exercise for the reader. *) let insert_with_tags (buf : #GText.buffer_skel) mark rmark tags text = - (** FIXME: LablGTK2 does not export the C insert_with_tags function, so that - it has to reimplement its own helper function. Unluckily, it relies on - a slow algorithm, so that we have to have our own quicker version here. - Alas, it is still much slower than the native version... *) + (* FIXME: LablGTK2 does not export the C insert_with_tags function, so that + it has to reimplement its own helper function. Unluckily, it relies on + a slow algorithm, so that we have to have our own quicker version here. + Alas, it is still much slower than the native version... *) if CList.is_empty tags then buf#insert ~iter:(buf#get_iter_at_mark mark) text else let it = buf#get_iter_at_mark mark in diff --git a/ide/protocol/interface.ml b/ide/protocol/interface.ml index debbc8301e..ccb6bedaf6 100644 --- a/ide/protocol/interface.ml +++ b/ide/protocol/interface.ml @@ -78,16 +78,20 @@ type option_state = { } type search_constraint = -(** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) | Name_Pattern of string -(** Whether the object type satisfies a pattern *) +(** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) + | Type_Pattern of string -(** Whether some subtype of object type satisfies a pattern *) +(** Whether the object type satisfies a pattern *) + | SubType_Pattern of string -(** Whether the object pertains to a module *) +(** Whether some subtype of object type satisfies a pattern *) + | In_Module of string list -(** Bypass the Search blacklist *) +(** Whether the object pertains to a module *) + | Include_Blacklist +(** Bypass the Search blacklist *) (** A list of search constraints; the boolean flag is set to [false] whenever the flag should be negated. *) diff --git a/ide/protocol/richpp.ml b/ide/protocol/richpp.ml index 19e9799c19..b2ce55e89a 100644 --- a/ide/protocol/richpp.ml +++ b/ide/protocol/richpp.ml @@ -46,7 +46,7 @@ let rich_pp width ppcmds = let pp_buffer = Buffer.create 180 in let push_pcdata () = - (** Push the optional PCData on the above node *) + (* Push the optional PCData on the above node *) let len = Buffer.length pp_buffer in if len = 0 then () else match context.stack with @@ -77,7 +77,7 @@ let rich_pp width ppcmds = let xml = Element (node, annotation, List.rev child) in match ctx with | Leaf -> - (** Final node: we keep the result in a dummy context *) + (* Final node: we keep the result in a dummy context *) context.stack <- Node ("", [xml], 0, Leaf) | Node (node, child, pos, ctx) -> context.stack <- Node (node, xml :: child, pos, ctx) @@ -104,15 +104,15 @@ let rich_pp width ppcmds = pp_set_max_boxes ft 50 ; pp_set_ellipsis_text ft "..."; - (** The whole output must be a valid document. To that - end, we nest the document inside <pp> tags. *) + (* The whole output must be a valid document. To that + end, we nest the document inside <pp> tags. *) pp_open_box ft 0; pp_open_tag ft "pp"; Pp.(pp_with ft ppcmds); pp_close_tag ft (); pp_close_box ft (); - (** Get the resulting XML tree. *) + (* Get the resulting XML tree. *) let () = pp_print_flush ft () in let () = assert (Buffer.length pp_buffer = 0) in match context.stack with diff --git a/ide/sentence.ml b/ide/sentence.ml index 2f7820a77c..2e508969aa 100644 --- a/ide/sentence.ml +++ b/ide/sentence.ml @@ -91,8 +91,8 @@ let tag_on_insert buffer = in try let start = grab_sentence_start prev soi in - (** The status of "{" "}" as sentence delimiters is too fragile. - We retag up to the next "." instead. *) + (* The status of "{" "}" as sentence delimiters is too fragile. + We retag up to the next "." instead. *) let stop = grab_ending_dot insert in try split_slice_lax buffer start#backward_char stop with Coq_lex.Unterminated -> diff --git a/ide/session.ml b/ide/session.ml index be2bfe060c..805e1d38a7 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -217,7 +217,7 @@ let set_buffer_handlers | Some s -> Minilib.log (s^" moved") | None -> () in - (** Pluging callbacks *) + (* Pluging callbacks *) let _ = buffer#connect#insert_text ~callback:insert_cb in let _ = buffer#connect#delete_range ~callback:delete_cb in let _ = buffer#connect#begin_user_action ~callback:begin_action_cb in @@ -427,7 +427,7 @@ let build_layout (sn:session) = GPack.vbox ~packing:(session_paned#pack1 ~shrink:false ~resize:true) () in - (** Right part of the window. *) + (* Right part of the window. *) let eval_paned = GPack.paned `HORIZONTAL ~border_width:5 ~packing:(session_box#pack ~expand:true) () in @@ -438,7 +438,7 @@ let build_layout (sn:session) = let state_paned = GPack.paned `VERTICAL ~packing:eval_paned#add2 () in - (** Proof buffer. *) + (* Proof buffer. *) let title = Printf.sprintf "Proof (%s)" sn.tab_label#text in let proof_detachable = Wg_Detachable.detachable ~title () in @@ -454,7 +454,7 @@ let build_layout (sn:session) = let proof_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:proof_detachable#pack () in - (** Message buffer. *) + (* Message buffer. *) let message_frame = GPack.notebook ~packing:state_paned#add () in let add_msg_page pos name text (w : GObj.widget) = @@ -514,14 +514,14 @@ let build_layout (sn:session) = let detach, _ = add_msg_page 0 sn.tab_label#text "Messages" sn.messages#default_route#coerce in let _, label = add_msg_page 1 sn.tab_label#text "Errors" sn.errpage#coerce in let _, _ = add_msg_page 2 sn.tab_label#text "Jobs" sn.jobpage#coerce in - (** When a message is received, focus on the message pane *) + (* When a message is received, focus on the message pane *) let _ = sn.messages#default_route#connect#pushed ~callback:(fun _ _ -> let num = message_frame#page_num detach#coerce in if 0 <= num then message_frame#goto_page num ) in - (** When an error occurs, paint the error label in red *) + (* When an error occurs, paint the error label in red *) let txt = label#text in let red s = "<span foreground=\"#FF0000\">" ^ s ^ "</span>" in sn.errpage#on_update ~callback:(fun l -> diff --git a/ide/wg_Completion.ml b/ide/wg_Completion.ml index 6a9317bc2f..c39d6d0563 100644 --- a/ide/wg_Completion.ml +++ b/ide/wg_Completion.ml @@ -40,7 +40,7 @@ let get_syntactic_completion (buffer : GText.buffer) pattern accu = (** Retrieve completion proposals in Coq libraries *) let get_semantic_completion pattern accu = let flags = [Interface.Name_Pattern ("^" ^ pattern), true] in - (** Only get the last part of the qualified name *) + (* Only get the last part of the qualified name *) let rec last accu = function | [] -> accu | [basename] -> Proposals.add basename accu @@ -199,15 +199,15 @@ object (self) let () = self#init_proposals w props in update_completion_signal#call (start_offset, w, props) in - (** If not in the cache, we recompute it: first syntactic *) + (* If not in the cache, we recompute it: first syntactic *) let synt = get_syntactic_completion buffer w Proposals.empty in - (** Then semantic *) + (* Then semantic *) let next prop = let () = update prop in Coq.lift k in let query = Coq.bind (get_semantic_completion w synt) next in - (** If coqtop is computing, do the syntactic completion altogether *) + (* If coqtop is computing, do the syntactic completion altogether *) let occupied () = let () = update synt in k () @@ -264,20 +264,20 @@ object (self) renderer#set_properties [`FONT_DESC font; `XPAD 10] method private coordinates pos = - (** Toplevel position w.r.t. screen *) + (* Toplevel position w.r.t. screen *) let (x, y) = Gdk.Window.get_position view#misc#toplevel#misc#window in - (** Position of view w.r.t. window *) + (* Position of view w.r.t. window *) let (ux, uy) = Gdk.Window.get_position view#misc#window in - (** Relative buffer position to view *) + (* Relative buffer position to view *) let (dx, dy) = view#window_to_buffer_coords ~tag:`WIDGET ~x:0 ~y:0 in - (** Iter position *) + (* Iter position *) let iter = view#buffer#get_iter pos in let coords = view#get_iter_location iter in let lx = Gdk.Rectangle.x coords in let ly = Gdk.Rectangle.y coords in let w = Gdk.Rectangle.width coords in let h = Gdk.Rectangle.height coords in - (** Absolute position *) + (* Absolute position *) (x + lx + ux - dx, y + ly + uy - dy, w, h) method private select_any f = @@ -374,9 +374,9 @@ object (self) else None method private manage_scrollbar () = - (** HACK: we don't have access to the treeview size because of the lack of - LablGTK binding for certain functions, so we bypass it by approximating - it through the size of the proposals *) + (* HACK: we don't have access to the treeview size because of the lack of + LablGTK binding for certain functions, so we bypass it by approximating + it through the size of the proposals *) let height = match model#store#get_iter_first with | None -> -1 | Some iter -> @@ -434,18 +434,18 @@ object (self) else false else false in - (** Style handling *) + (* Style handling *) let _ = view#misc#connect#style_set ~callback:self#refresh_style in let _ = self#refresh_style () in let _ = data#set_resize_mode `PARENT in let _ = frame#set_resize_mode `PARENT in - (** Callback to model *) + (* Callback to model *) let _ = model#connect#start_completion ~callback:self#start_callback in let _ = model#connect#update_completion ~callback:self#update_callback in let _ = model#connect#end_completion ~callback:self#end_callback in - (** Popup interaction *) + (* Popup interaction *) let _ = view#event#connect#key_press ~callback:key_cb in - (** Hiding the popup when necessary*) + (* Hiding the popup when necessary*) let _ = view#misc#connect#hide ~callback:obj#misc#hide in let _ = view#event#connect#button_press ~callback:(fun _ -> self#hide (); false) in let _ = view#connect#move_cursor ~callback:move_cb in diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml index 296a942321..7d2d7da570 100644 --- a/ide/wg_Find.ml +++ b/ide/wg_Find.ml @@ -212,13 +212,13 @@ class finder name (view : GText.view) = initializer let _ = self#hide () in - (** Widget button interaction *) + (* Widget button interaction *) let _ = next_button#connect#clicked ~callback:self#find_forward in let _ = previous_button#connect#clicked ~callback:self#find_backward in let _ = replace_button#connect#clicked ~callback:self#replace in let _ = replace_all_button#connect#clicked ~callback:self#replace_all in - (** Keypress interaction *) + (* Keypress interaction *) let generic_cb esc_cb ret_cb ev = let ev_key = GdkEvent.Key.keyval ev in let (return, _) = GtkData.AccelGroup.parse "Return" in @@ -232,7 +232,7 @@ class finder name (view : GText.view) = let _ = find_entry#event#connect#key_press ~callback:find_cb in let _ = replace_entry#event#connect#key_press ~callback:replace_cb in - (** TextView interaction *) + (* TextView interaction *) let view_cb ev = if widget#visible then let ev_key = GdkEvent.Key.keyval ev in diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index a79a093e32..6b09b344b5 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -36,6 +36,7 @@ class type message_view = method refresh : bool -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) + method has_selection : bool method get_selected_text : string end diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli index 472aaf5ed4..613f1b4190 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -26,6 +26,7 @@ class type message_view = method refresh : bool -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) + method has_selection : bool method get_selected_text : string end diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 74bc0b8d53..5e26c50797 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -152,11 +152,11 @@ object(self) if self#process_delete_action del then (`OK, `WRITE) else (`FAIL, `NOOP) | Action lst -> let fold accu action = match accu with - | (`FAIL, _) -> accu (** we stop now! *) + | (`FAIL, _) -> accu (* we stop now! *) | (`OK, status) -> let (res, nstatus) = self#process_action action in let merge op1 op2 = match op1, op2 with - | `NOOP, `NOOP -> `NOOP (** only a noop when both are *) + | `NOOP, `NOOP -> `NOOP (* only a noop when both are *) | _ -> `WRITE in (res, merge status nstatus) @@ -172,8 +172,8 @@ object(self) | (`OK, _) -> history <- rem; redo <- (negate_action action) :: redo - | (`FAIL, `NOOP) -> () (** we do nothing *) - | (`FAIL, `WRITE) -> self#clear_undo () (** we don't know how we failed, so start off *) + | (`FAIL, `NOOP) -> () (* we do nothing *) + | (`FAIL, `WRITE) -> self#clear_undo () (* we don't know how we failed, so start off *) end method perform_redo () = match redo with @@ -184,8 +184,8 @@ object(self) | (`OK, _) -> redo <- rem; history <- (negate_action action) :: history; - | (`FAIL, `NOOP) -> () (** we do nothing *) - | (`FAIL, `WRITE) -> self#clear_undo () (** we don't know how we failed *) + | (`FAIL, `NOOP) -> () (* we do nothing *) + | (`FAIL, `WRITE) -> self#clear_undo () (* we don't know how we failed *) end method undo () = @@ -212,9 +212,9 @@ object(self) self#with_lock_undo self#process_begin_user_action () method process_end_user_action () = - (** Search for the pending action *) + (* Search for the pending action *) let rec split accu = function - | [] -> raise Not_found (** no pending begin action! *) + | [] -> raise Not_found (* no pending begin action! *) | EndGrp :: rem -> let grp = List.rev accu in let rec flatten = function @@ -240,7 +240,7 @@ object(self) (* Save the insert action *) let len = Glib.Utf8.length s in let mergeable = - (** heuristic: split at newline and atomic pastes *) + (* heuristic: split at newline and atomic pastes *) len = 1 && (s <> "\n") in let ins = { @@ -460,7 +460,7 @@ object (self) if not proceed then GtkSignal.stop_emit () in let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in - (** Plug on preferences *) + (* Plug on preferences *) let cb clr = self#misc#modify_base [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:cb in let _ = self#misc#connect#realize ~callback:(fun () -> cb background_color#get) in diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml index 0f5ed8d896..3b2572f9d2 100644 --- a/ide/wg_Segment.ml +++ b/ide/wg_Segment.ml @@ -70,7 +70,7 @@ object (self) let cb rect = let w = rect.Gtk.width in let h = rect.Gtk.height in - (** Only refresh when size actually changed, otherwise loops *) + (* Only refresh when size actually changed, otherwise loops *) if self#misc#visible && (width <> w || height <> h) then begin width <- w; height <- h; @@ -91,7 +91,7 @@ object (self) let _ = eventbox#event#connect#button_press ~callback:clicked_cb in let cb show = if show then self#misc#show () else self#misc#hide () in stick show_progress_bar self cb; - (** Initial pixmap *) + (* Initial pixmap *) draw#set_pixmap pixmap; refresh_timer.Ideutils.run ~ms:300 ~callback:(fun () -> if need_refresh then self#refresh (); true) diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 77d612cfd9..757d186c8b 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -80,8 +80,8 @@ type cases_pattern_expr_r = 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 *) + cases_pattern_expr list * (* for constr subterms *) + cases_pattern_expr list list (* for recursive notations *) and constr_expr_r = | CRef of qualid * instance_expr option @@ -142,10 +142,10 @@ and local_binder_expr = | CLocalPattern of (cases_pattern_expr * constr_expr option) CAst.t and constr_notation_substitution = - constr_expr list * (** for constr subterms *) - constr_expr list list * (** for recursive notations *) - cases_pattern_expr list * (** for binders *) - local_binder_expr list list (** for binder lists (recursive notations) *) + constr_expr list * (* for constr subterms *) + constr_expr list list * (* for recursive notations *) + cases_pattern_expr list * (* for binders *) + local_binder_expr list list (* for binder lists (recursive notations) *) type constr_pattern_expr = constr_expr diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 3a4969a3ee..3a5af1dd5f 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -140,7 +140,7 @@ let rec constr_expr_eq e1 e2 = in List.equal field_eq l1 l2 | CCases(_,r1,a1,brl1), CCases(_,r2,a2,brl2) -> - (** Don't care about the case_style *) + (* 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 @@ -220,7 +220,7 @@ and local_binder_eq l1 l2 = match l1, l2 with | CLocalDef (n1, e1, t1), CLocalDef (n2, e2, t2) -> eq_ast Name.equal n1 n2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq t1 t2 | CLocalAssum (n1, _, e1), CLocalAssum (n2, _, e2) -> - (** Don't care about the [binder_kind] *) + (* Don't care about the [binder_kind] *) List.equal (eq_ast Name.equal) n1 n2 && constr_expr_eq e1 e2 | _ -> false @@ -258,7 +258,6 @@ let local_binders_loc bll = match bll with | h :: l -> Loc.merge_opt (local_binder_loc h) (local_binder_loc (List.last bll)) (** Folds and maps *) - let is_constructor id = try Globnames.isConstructRef (Smartlocate.global_of_extended_global diff --git a/interp/constrextern.ml b/interp/constrextern.ml index fba03b9de9..0d0b6158d9 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -960,7 +960,7 @@ let rec extern inctx (custom,scopes as allscopes) vars r = | GSort s -> CSort (extern_glob_sort s) - | GHole (e,naming,_) -> CHole (Some e, naming, None) (** TODO: extern tactics. *) + | GHole (e,naming,_) -> CHole (Some e, naming, None) (* TODO: extern tactics. *) | GCast (c, c') -> CCast (sub_extern true scopes vars c, diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 6313f2d7ba..7aa85a0810 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1507,7 +1507,7 @@ let drop_notations_pattern looked_for genv = 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] *) + (* [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *) let rec rcp_of_glob scopes x = DAst.(map (function | GVar id -> RCPatAtom (Some (CAst.make ?loc:x.loc id,scopes)) | GHole (_,_,_) -> RCPatAtom (None) @@ -1527,8 +1527,8 @@ let drop_notations_pattern looked_for genv = try match Nametab.locate_extended qid with | SynDef sp -> - let (vars,a) = Syntax_def.search_syntactic_definition sp in - (match a with + let filter (vars,a) = + try match a with | NRef g -> (* Convention: do not deactivate implicit arguments and scopes for further arguments *) test_kind top g; @@ -1549,7 +1549,9 @@ let drop_notations_pattern looked_for genv = let idspl1 = List.map (in_not false qid.loc scopes (subst, Id.Map.empty) []) args in let (_,argscs) = find_remaining_scopes pats1 pats2 g in Some (g, idspl1, List.map2 (in_pat_sc scopes) argscs pats2) - | _ -> raise Not_found) + | _ -> raise Not_found + with Not_found -> None in + Syntax_def.search_filtered_syntactic_definition filter sp | TrueGlobal g -> test_kind top g; Dumpglob.add_glob ?loc:qid.loc g; diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 035e4bc644..61acd09d65 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -45,13 +45,15 @@ type var_internalization_type = type var_internalization_data = var_internalization_type * - (** type of the "free" variable, for coqdoc, e.g. while typing the - constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) + (* type of the "free" variable, for coqdoc, e.g. while typing the + constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) + Id.t list * - (** impargs to automatically add to the variable, e.g. for "JMeq A a B b" - in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *) - Impargs.implicit_status list * (** signature of impargs of the variable *) - Notation_term.scope_name option list (** subscopes of the args of the variable *) + (* impargs to automatically add to the variable, e.g. for "JMeq A a B b" + in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *) + + Impargs.implicit_status list * (* signature of impargs of the variable *) + Notation_term.scope_name option list (* subscopes of the args of the variable *) (** A map of free variables to their implicit arguments and scopes *) type internalization_env = var_internalization_data Id.Map.t diff --git a/interp/declare.ml b/interp/declare.ml index 1e972d3e35..6778fa1e7a 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -56,7 +56,7 @@ let load_constant i ((sp,kn), obj) = (* Opening means making the name without its module qualification available *) let open_constant i ((sp,kn), obj) = - (** Never open a local definition *) + (* Never open a local definition *) if obj.cst_locl then () else let con = Global.constant_of_delta_kn kn in @@ -166,9 +166,9 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e export_seff || not de.const_entry_opaque || is_poly de -> - (** This globally defines the side-effects in the environment. We mark - exported constants as being side-effect not to redeclare them at - caching time. *) + (* This globally defines the side-effects in the environment. We mark + exported constants as being side-effect not to redeclare them at + caching time. *) let de, export = Global.export_private_constants ~in_section de in export, ConstantEntry (PureEntry, DefinitionEntry de) | _ -> [], ConstantEntry (EffectEntry, cd) @@ -191,7 +191,6 @@ let declare_definition ?(internal=UserIndividualRequest) (Entries.DefinitionEntry cb, Decl_kinds.IsDefinition kind) (** Declaration of section variables and local definitions *) - type section_variable_entry = | SectionLocalDef of Safe_typing.private_constants definition_entry | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) @@ -214,16 +213,16 @@ let cache_variable ((sp,_),o) = | SectionLocalDef (de) -> let (de, eff) = Global.export_private_constants ~in_section:true de in let () = List.iter register_side_effect eff in - (** The body should already have been forced upstream because it is a - section-local definition, but it's not enforced by typing *) + (* The body should already have been forced upstream because it is a + section-local definition, but it's not enforced by typing *) let (body, uctx), () = Future.force de.const_entry_body in let poly, univs = match de.const_entry_universes with | Monomorphic_const_entry uctx -> false, uctx | Polymorphic_const_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx in let univs = Univ.ContextSet.union uctx univs in - (** We must declare the universe constraints before type-checking the - term. *) + (* We must declare the universe constraints before type-checking the + term. *) let () = Global.push_context_set (not poly) univs in let se = { secdef_body = body; @@ -262,7 +261,6 @@ let declare_variable id obj = oname (** Declaration of inductive blocks *) - let declare_inductive_argument_scopes kn mie = List.iteri (fun i {mind_entry_consnames=lc} -> Notation.declare_ref_arguments_scope Evd.empty (IndRef (kn,i)); @@ -360,7 +358,7 @@ let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (ter let id = Label.to_id label in let univs = match univs with | Monomorphic_ind_entry _ -> - (** Global constraints already defined through the inductive *) + (* Global constraints already defined through the inductive *) Monomorphic_const_entry Univ.ContextSet.empty | Polymorphic_ind_entry (nas, ctx) -> Polymorphic_const_entry (nas, ctx) @@ -447,11 +445,9 @@ let assumption_message id = (** Monomorphic universes need to survive sections. *) let input_universe_context : Univ.ContextSet.t -> Libobject.obj = - declare_object - { (default_object "Monomorphic section universes") with - cache_function = (fun (na, uctx) -> Global.push_context_set false uctx); - discharge_function = (fun (_, x) -> Some x); - classify_function = (fun a -> Dispose) } + declare_object @@ local_object "Monomorphic section universes" + ~cache:(fun (na, uctx) -> Global.push_context_set false uctx) + ~discharge:(fun (_, x) -> Some x) let declare_universe_context poly ctx = if poly then @@ -469,7 +465,7 @@ type universe_source = | QualifiedUniv of Id.t (* global universe introduced by some global value *) | UnqualifiedUniv (* other global universe *) -type universe_name_decl = universe_source * (Id.t * Nametab.universe_id) list +type universe_name_decl = universe_source * (Id.t * Univ.Level.UGlobal.t) list let check_exists sp = if Nametab.exists_universe sp then @@ -511,7 +507,7 @@ let input_univ_names : universe_name_decl -> Libobject.obj = load_function = load_univ_names; open_function = open_univ_names; discharge_function = discharge_univ_names; - subst_function = (fun (subst, a) -> (** Actually the name is generated once and for all. *) a); + subst_function = (fun (subst, a) -> (* Actually the name is generated once and for all. *) a); classify_function = (fun a -> Substitute a) } let declare_univ_binders gr pl = @@ -540,12 +536,8 @@ let do_universe poly l = user_err ~hdr:"Constraint" (str"Cannot declare polymorphic universes outside sections") in - let l = - List.map (fun {CAst.v=id} -> - let lev = UnivGen.new_univ_id () in - (id, lev)) l - in - let ctx = List.fold_left (fun ctx (_,(dp,i)) -> Univ.LSet.add (Univ.Level.make dp i) ctx) + let l = List.map (fun {CAst.v=id} -> (id, UnivGen.new_univ_global ())) l in + let ctx = List.fold_left (fun ctx (_,qid) -> Univ.LSet.add (Univ.Level.make qid) ctx) Univ.LSet.empty l, Univ.Constraint.empty in let () = declare_universe_context poly ctx in diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 931d05a975..554da7603f 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -18,6 +18,7 @@ val dump : unit -> bool val noglob : unit -> unit val dump_into_file : string -> unit (** special handling of "stdout" *) + val dump_to_dotglob : unit -> unit val feedback_glob : unit -> unit diff --git a/interp/impargs.ml b/interp/impargs.ml index d024a9e808..8a89bcdf26 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -448,7 +448,7 @@ let compute_mib_implicits flags kn = Array.to_list (Array.mapi (* No need to lift, arities contain no de Bruijn *) (fun i mip -> - (** No need to care about constraints here *) + (* No need to care about constraints here *) let ty, _ = Typeops.type_of_global_in_context env (IndRef (kn,i)) in Context.Rel.Declaration.LocalAssum (Name mip.mind_typename, ty)) mib.mind_packets) in diff --git a/interp/impargs.mli b/interp/impargs.mli index ea5aa90f68..4afc2af5e9 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -65,6 +65,7 @@ type implicit_explanation = operational only if [conclusion_matters] is true. *) type maximal_insertion = bool (** true = maximal contextual insertion *) + type force_inference = bool (** true = always infer, never turn into evar/subgoal *) type implicit_status = (Id.t * implicit_explanation * diff --git a/interp/notation.ml b/interp/notation.ml index 0af75b5bfa..b0854de4a3 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -308,7 +308,7 @@ let declare_delimiters scope key = | None -> scope_map := String.Map.add scope newsc !scope_map | Some oldkey when String.equal oldkey key -> () | Some oldkey -> - (** FIXME: implement multikey scopes? *) + (* FIXME: implement multikey scopes? *) Flags.if_verbose Feedback.msg_info (str "Overwriting previous delimiting key " ++ str oldkey ++ str " in scope " ++ str scope); scope_map := String.Map.add scope newsc !scope_map @@ -530,11 +530,11 @@ let prim_token_uninterpreters = (*******************************************************) (* Numeral notation interpretation *) -type numeral_notation_error = +type prim_token_notation_error = | UnexpectedTerm of Constr.t | UnexpectedNonOptionTerm of Constr.t -exception NumeralNotationError of Environ.env * Evd.evar_map * numeral_notation_error +exception PrimTokenNotationError of string * Environ.env * Evd.evar_map * prim_token_notation_error type numnot_option = | Nop @@ -554,20 +554,26 @@ type target_kind = | UInt of Names.inductive (* Coq.Init.Decimal.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) +type string_target_kind = + | ListByte + | Byte + type option_kind = Option | Direct -type conversion_kind = target_kind * option_kind +type 'target conversion_kind = 'target * option_kind -type numeral_notation_obj = - { to_kind : conversion_kind; +type ('target, 'warning) prim_token_notation_obj = + { to_kind : 'target conversion_kind; to_ty : GlobRef.t; - of_kind : conversion_kind; + of_kind : 'target conversion_kind; of_ty : GlobRef.t; - num_ty : Libnames.qualid; (* for warnings / error messages *) - warning : numnot_option } + ty_name : Libnames.qualid; (* for warnings / error messages *) + warning : 'warning } -module Numeral = struct -(** * Numeral notation *) +type numeral_notation_obj = (target_kind, numnot_option) prim_token_notation_obj +type string_notation_obj = (string_target_kind, unit) prim_token_notation_obj +module PrimTokenNotation = struct +(** * Code shared between Numeral notation and String notation *) (** Reduction The constr [c] below isn't necessarily well-typed, since we @@ -596,7 +602,69 @@ let eval_constr env sigma (c : Constr.t) = let eval_constr_app env sigma c1 c2 = eval_constr env sigma (mkApp (c1,[| c2 |])) -exception NotANumber +exception NotAValidPrimToken + +(** The uninterp function below work at the level of [glob_constr] + which is too low for us here. So here's a crude conversion back + to [constr] for the subset that concerns us. *) + +let rec constr_of_glob env sigma g = match DAst.get g with + | Glob_term.GRef (ConstructRef c, _) -> + let sigma,c = Evd.fresh_constructor_instance env sigma c in + sigma,mkConstructU c + | Glob_term.GApp (gc, gcl) -> + let sigma,c = constr_of_glob env sigma gc in + let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in + sigma,mkApp (c, Array.of_list cl) + | _ -> + raise NotAValidPrimToken + +let rec glob_of_constr token_kind ?loc env sigma c = match Constr.kind c with + | App (c, ca) -> + let c = glob_of_constr token_kind ?loc env sigma c in + let cel = List.map (glob_of_constr token_kind ?loc env sigma) (Array.to_list ca) in + DAst.make ?loc (Glob_term.GApp (c, cel)) + | Construct (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstructRef c, None)) + | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstRef c, None)) + | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (IndRef ind, None)) + | Var id -> DAst.make ?loc (Glob_term.GRef (VarRef id, None)) + | _ -> Loc.raise ?loc (PrimTokenNotationError(token_kind,env,sigma,UnexpectedTerm c)) + +let no_such_prim_token uninterpreted_token_kind ?loc ty = + CErrors.user_err ?loc + (str ("Cannot interpret this "^uninterpreted_token_kind^" as a value of type ") ++ + pr_qualid ty) + +let interp_option uninterpreted_token_kind token_kind ty ?loc env sigma c = + match Constr.kind c with + | App (_Some, [| _; c |]) -> glob_of_constr token_kind ?loc env sigma c + | App (_None, [| _ |]) -> no_such_prim_token uninterpreted_token_kind ?loc ty + | x -> Loc.raise ?loc (PrimTokenNotationError(token_kind,env,sigma,UnexpectedNonOptionTerm c)) + +let uninterp_option c = + match Constr.kind c with + | App (_Some, [| _; x |]) -> x + | _ -> raise NotAValidPrimToken + +let uninterp to_raw o (Glob_term.AnyGlobConstr n) = + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma,of_ty = Evd.fresh_global env sigma o.of_ty in + let of_ty = EConstr.Unsafe.to_constr of_ty in + try + let sigma,n = constr_of_glob env sigma n in + let c = eval_constr_app env sigma of_ty n in + let c = if snd o.of_kind == Direct then c else uninterp_option c in + Some (to_raw (fst o.of_kind, c)) + with + | Type_errors.TypeError _ | Pretype_errors.PretypeError _ -> None (* cf. eval_constr_app *) + | NotAValidPrimToken -> None (* all other functions except big2raw *) + +end + +module Numeral = struct +(** * Numeral notation *) +open PrimTokenNotation let warn_large_num = CWarnings.create ~name:"large-number" ~category:"numbers" @@ -670,15 +738,15 @@ let rawnum_of_coquint c = | Construct ((_,n), _) (* D0 to D9 *) -> let () = Buffer.add_char buf (char_of_digit n) in of_uint_loop a buf - | _ -> raise NotANumber) - | _ -> raise NotANumber + | _ -> raise NotAValidPrimToken) + | _ -> raise NotAValidPrimToken in let buf = Buffer.create 64 in let () = of_uint_loop c buf in if Int.equal (Buffer.length buf) 0 then (* To avoid ambiguities between Nil and (D0 Nil), we choose to not display Nil alone as "0" *) - raise NotANumber + raise NotAValidPrimToken else Buffer.contents buf let rawnum_of_coqint c = @@ -687,8 +755,8 @@ let rawnum_of_coqint c = (match Constr.kind c with | Construct ((_,1), _) (* Pos *) -> (rawnum_of_coquint c', true) | Construct ((_,2), _) (* Neg *) -> (rawnum_of_coquint c', false) - | _ -> raise NotANumber) - | _ -> raise NotANumber + | _ -> raise NotAValidPrimToken) + | _ -> raise NotAValidPrimToken (***********************************************************************) @@ -718,9 +786,9 @@ let rec bigint_of_pos c = match Constr.kind c with | 2 -> (* xO *) Bigint.mult_2 (bigint_of_pos d) | n -> assert false (* no other constructor of type positive *) end - | x -> raise NotANumber + | x -> raise NotAValidPrimToken end - | x -> raise NotANumber + | x -> raise NotAValidPrimToken (** Now, [Z] from/to bigint *) @@ -745,51 +813,9 @@ let bigint_of_z z = match Constr.kind z with | 3 -> (* Zneg *) Bigint.neg (bigint_of_pos d) | n -> assert false (* no other constructor of type Z *) end - | _ -> raise NotANumber + | _ -> raise NotAValidPrimToken end - | _ -> raise NotANumber - -(** The uninterp function below work at the level of [glob_constr] - which is too low for us here. So here's a crude conversion back - to [constr] for the subset that concerns us. *) - -let rec constr_of_glob env sigma g = match DAst.get g with - | Glob_term.GRef (ConstructRef c, _) -> - let sigma,c = Evd.fresh_constructor_instance env sigma c in - sigma,mkConstructU c - | Glob_term.GApp (gc, gcl) -> - let sigma,c = constr_of_glob env sigma gc in - let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in - sigma,mkApp (c, Array.of_list cl) - | _ -> - raise NotANumber - -let rec glob_of_constr ?loc env sigma c = match Constr.kind c with - | App (c, ca) -> - let c = glob_of_constr ?loc env sigma c in - let cel = List.map (glob_of_constr ?loc env sigma) (Array.to_list ca) in - DAst.make ?loc (Glob_term.GApp (c, cel)) - | Construct (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstructRef c, None)) - | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstRef c, None)) - | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (IndRef ind, None)) - | Var id -> DAst.make ?loc (Glob_term.GRef (VarRef id, None)) - | _ -> Loc.raise ?loc (NumeralNotationError(env,sigma,UnexpectedTerm c)) - -let no_such_number ?loc ty = - CErrors.user_err ?loc - (str "Cannot interpret this number as a value of type " ++ - pr_qualid ty) - -let interp_option ty ?loc env sigma c = - match Constr.kind c with - | App (_Some, [| _; c |]) -> glob_of_constr ?loc env sigma c - | App (_None, [| _ |]) -> no_such_number ?loc ty - | x -> Loc.raise ?loc (NumeralNotationError(env,sigma,UnexpectedNonOptionTerm c)) - -let uninterp_option c = - match Constr.kind c with - | App (_Some, [| _; x |]) -> x - | _ -> raise NotANumber + | _ -> raise NotAValidPrimToken let big2raw n = if Bigint.is_pos_or_zero n then (Bigint.to_string n, true) @@ -801,13 +827,13 @@ let raw2big (n,s) = let interp o ?loc n = begin match o.warning with | Warning threshold when snd n && rawnum_compare (fst n) threshold >= 0 -> - warn_large_num o.num_ty + warn_large_num o.ty_name | _ -> () end; let c = match fst o.to_kind with | Int int_ty -> coqint_of_rawnum int_ty n | UInt uint_ty when snd n -> coquint_of_rawnum uint_ty (fst n) - | UInt _ (* n <= 0 *) -> no_such_number ?loc o.num_ty + | UInt _ (* n <= 0 *) -> no_such_prim_token "number" ?loc o.ty_name | Z z_pos_ty -> z_of_bigint z_pos_ty (raw2big n) in let env = Global.env () in @@ -816,30 +842,120 @@ let interp o ?loc n = let to_ty = EConstr.Unsafe.to_constr to_ty in match o.warning, snd o.to_kind with | Abstract threshold, Direct when rawnum_compare (fst n) threshold >= 0 -> - warn_abstract_large_num (o.num_ty,o.to_ty); - glob_of_constr ?loc env sigma (mkApp (to_ty,[|c|])) + warn_abstract_large_num (o.ty_name,o.to_ty); + glob_of_constr "numeral" ?loc env sigma (mkApp (to_ty,[|c|])) | _ -> let res = eval_constr_app env sigma to_ty c in match snd o.to_kind with - | Direct -> glob_of_constr ?loc env sigma res - | Option -> interp_option o.num_ty ?loc env sigma res + | Direct -> glob_of_constr "numeral" ?loc env sigma res + | Option -> interp_option "number" "numeral" o.ty_name ?loc env sigma res + +let uninterp o n = + PrimTokenNotation.uninterp + begin function + | (Int _, c) -> rawnum_of_coqint c + | (UInt _, c) -> (rawnum_of_coquint c, true) + | (Z _, c) -> big2raw (bigint_of_z c) + end o n +end + +module Strings = struct +(** * String notation *) +open PrimTokenNotation + +let qualid_of_ref n = + n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty + +let q_list () = qualid_of_ref "core.list.type" +let q_byte () = qualid_of_ref "core.byte.type" + +let unsafe_locate_ind q = + match Nametab.locate q with + | IndRef i -> i + | _ -> raise Not_found + +let locate_list () = unsafe_locate_ind (q_list ()) +let locate_byte () = unsafe_locate_ind (q_byte ()) + +(***********************************************************************) + +(** ** Conversion between Coq [list Byte.byte] and internal raw string *) + +let coqbyte_of_char_code byte c = + mkConstruct (byte, 1 + c) + +let coqbyte_of_string ?loc byte 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 ~hdr:"coqbyte_of_string" + (str "Expects a single character or a three-digits ascii code.") in + coqbyte_of_char_code byte p + +let coqbyte_of_char byte c = coqbyte_of_char_code byte (Char.code c) + +let make_ascii_string n = + if n>=32 && n<=126 then String.make 1 (char_of_int n) + else Printf.sprintf "%03d" n + +let char_code_of_coqbyte c = + match Constr.kind c with + | Construct ((_,c), _) -> c - 1 + | _ -> raise NotAValidPrimToken + +let string_of_coqbyte c = make_ascii_string (char_code_of_coqbyte c) + +let coqlist_byte_of_string byte_ty list_ty str = + let cbyte = mkInd byte_ty in + let nil = mkApp (mkConstruct (list_ty, 1), [|cbyte|]) in + let cons x xs = mkApp (mkConstruct (list_ty, 2), [|cbyte; x; xs|]) in + let rec do_chars s i acc = + if i < 0 then acc + else + let b = coqbyte_of_char byte_ty s.[i] in + do_chars s (i-1) (cons b acc) + in + do_chars str (String.length str - 1) nil + +(* N.B. We rely on the fact that [nil] is the first constructor and [cons] is the second constructor, for [list] *) +let string_of_coqlist_byte c = + let rec of_coqlist_byte_loop c buf = + match Constr.kind c with + | App (_nil, [|_ty|]) -> () + | App (_cons, [|_ty;b;c|]) -> + let () = Buffer.add_char buf (Char.chr (char_code_of_coqbyte b)) in + of_coqlist_byte_loop c buf + | _ -> raise NotAValidPrimToken + in + let buf = Buffer.create 64 in + let () = of_coqlist_byte_loop c buf in + Buffer.contents buf -let uninterp o (Glob_term.AnyGlobConstr n) = +let interp o ?loc n = + let byte_ty = locate_byte () in + let list_ty = locate_list () in + let c = match fst o.to_kind with + | ListByte -> coqlist_byte_of_string byte_ty list_ty n + | Byte -> coqbyte_of_string ?loc byte_ty n + in let env = Global.env () in let sigma = Evd.from_env env in - let sigma,of_ty = Evd.fresh_global env sigma o.of_ty in - let of_ty = EConstr.Unsafe.to_constr of_ty in - try - let sigma,n = constr_of_glob env sigma n in - let c = eval_constr_app env sigma of_ty n in - let c = if snd o.of_kind == Direct then c else uninterp_option c in - match fst o.of_kind with - | Int _ -> Some (rawnum_of_coqint c) - | UInt _ -> Some (rawnum_of_coquint c, true) - | Z _ -> Some (big2raw (bigint_of_z c)) - with - | Type_errors.TypeError _ | Pretype_errors.PretypeError _ -> None (* cf. eval_constr_app *) - | NotANumber -> None (* all other functions except big2raw *) + let sigma,to_ty = Evd.fresh_global env sigma o.to_ty in + let to_ty = EConstr.Unsafe.to_constr to_ty in + let res = eval_constr_app env sigma to_ty c in + match snd o.to_kind with + | Direct -> glob_of_constr "string" ?loc env sigma res + | Option -> interp_option "string" "string" o.ty_name ?loc env sigma res + +let uninterp o n = + PrimTokenNotation.uninterp + begin function + | (ListByte, c) -> string_of_coqlist_byte c + | (Byte, c) -> string_of_coqbyte c + end o n end (* A [prim_token_infos], which is synchronized with the document @@ -853,6 +969,7 @@ end type prim_token_interp_info = Uid of prim_token_uid | NumeralNotation of numeral_notation_obj + | StringNotation of string_notation_obj type prim_token_infos = { pt_local : bool; (** Is this interpretation local? *) @@ -1081,6 +1198,7 @@ let find_prim_token check_allowed ?loc p sc = let interp = match info with | Uid uid -> Hashtbl.find prim_token_interpreters uid | NumeralNotation o -> InnerPrimToken.RawNumInterp (Numeral.interp o) + | StringNotation o -> InnerPrimToken.StringInterp (Strings.interp o) in let pat = InnerPrimToken.do_interp ?loc interp p in check_allowed pat; @@ -1270,6 +1388,7 @@ let uninterp_prim_token c = let uninterp = match info with | Uid uid -> Hashtbl.find prim_token_uninterpreters uid | NumeralNotation o -> InnerPrimToken.RawNumUninterp (Numeral.uninterp o) + | StringNotation o -> InnerPrimToken.StringUninterp (Strings.uninterp o) in match InnerPrimToken.do_uninterp uninterp (AnyGlobConstr c) with | None -> raise Notation_ops.No_match @@ -1289,6 +1408,8 @@ let availability_of_prim_token n printer_scope local_scopes = match n, uid with | Numeral _, NumeralNotation _ -> true | _, NumeralNotation _ -> false + | String _, StringNotation _ -> true + | _, StringNotation _ -> false | _, Uid uid -> let interp = Hashtbl.find prim_token_interpreters uid in match n, interp with @@ -1781,7 +1902,7 @@ let pr_visibility prglob = function (**********************************************************************) (* Synchronisation with reset *) -let freeze _ = +let freeze ~marshallable = (!scope_map, !scope_stack, !uninterp_scope_stack, !arguments_scope, !delimiters_map, !notations_key_table, !scope_class_map, !prim_token_interp_infos, !prim_token_uninterp_infos, @@ -1818,7 +1939,7 @@ let _ = Summary.init_function = init } let with_notation_protection f x = - let fs = freeze false in + let fs = freeze ~marshallable:false in try let a = f x in unfreeze fs; a with reraise -> let reraise = CErrors.push reraise in diff --git a/interp/notation.mli b/interp/notation.mli index 3480d1c8f2..75034cad70 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -54,7 +54,7 @@ val scope_is_open : scope_name -> bool (** Open scope *) val open_close_scope : - (** locality *) bool * (* open *) bool * scope_name -> unit + (* locality *) bool * (* open *) bool * scope_name -> unit (** Extend a list of scopes *) val empty_scope_stack : scopes @@ -104,11 +104,11 @@ val register_string_interpretation : (** * Numeral notation *) -type numeral_notation_error = +type prim_token_notation_error = | UnexpectedTerm of Constr.t | UnexpectedNonOptionTerm of Constr.t -exception NumeralNotationError of Environ.env * Evd.evar_map * numeral_notation_error +exception PrimTokenNotationError of string * Environ.env * Evd.evar_map * prim_token_notation_error type numnot_option = | Nop @@ -128,20 +128,28 @@ type target_kind = | UInt of Names.inductive (* Coq.Init.Decimal.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) +type string_target_kind = + | ListByte + | Byte + type option_kind = Option | Direct -type conversion_kind = target_kind * option_kind +type 'target conversion_kind = 'target * option_kind -type numeral_notation_obj = - { to_kind : conversion_kind; +type ('target, 'warning) prim_token_notation_obj = + { to_kind : 'target conversion_kind; to_ty : GlobRef.t; - of_kind : conversion_kind; + of_kind : 'target conversion_kind; of_ty : GlobRef.t; - num_ty : Libnames.qualid; (* for warnings / error messages *) - warning : numnot_option } + ty_name : Libnames.qualid; (* for warnings / error messages *) + warning : 'warning } + +type numeral_notation_obj = (target_kind, numnot_option) prim_token_notation_obj +type string_notation_obj = (string_target_kind, unit) prim_token_notation_obj type prim_token_interp_info = Uid of prim_token_uid | NumeralNotation of numeral_notation_obj + | StringNotation of string_notation_obj type prim_token_infos = { pt_local : bool; (** Is this interpretation local? *) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 7a525f84a5..8d225fe683 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -37,7 +37,7 @@ let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with | _ -> false) | NApp (t1, a1), NApp (t2, a2) -> (eq_notation_constr vars) t1 t2 && List.equal (eq_notation_constr vars) a1 a2 -| NHole (_, _, _), NHole (_, _, _) -> true (** FIXME? *) +| NHole (_, _, _), NHole (_, _, _) -> true (* FIXME? *) | NList (i1, j1, t1, u1, b1), NList (i2, j2, t2, u2, b2) -> Id.equal i1 i2 && Id.equal j1 j2 && (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2 && b1 == b2 @@ -51,7 +51,7 @@ let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with | NLetIn (na1, b1, t1, u1), NLetIn (na2, b2, t2, u2) -> Name.equal na1 na2 && eq_notation_constr vars b1 b2 && Option.equal (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2 -| NCases (_, o1, r1, p1), NCases (_, o2, r2, p2) -> (** FIXME? *) +| NCases (_, o1, r1, p1), NCases (_, o2, r2, p2) -> (* FIXME? *) let eqpat (p1, t1) (p2, t2) = List.equal cases_pattern_eq p1 p2 && (eq_notation_constr vars) t1 t2 @@ -75,7 +75,7 @@ let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with Option.equal (eq_notation_constr vars) o1 o2 && (eq_notation_constr vars) u1 u2 && (eq_notation_constr vars) r1 r2 -| NRec (_, ids1, ts1, us1, rs1), NRec (_, ids2, ts2, us2, rs2) -> (** FIXME? *) +| NRec (_, ids1, ts1, us1, rs1), NRec (_, ids2, ts2, us2, rs2) -> (* FIXME? *) let eq (na1, o1, t1) (na2, o2, t2) = Name.equal na1 na2 && Option.equal (eq_notation_constr vars) o1 o2 && @@ -530,8 +530,10 @@ let rec subst_notation_constr subst bound raw = match raw with | NRef ref -> let ref',t = subst_global subst ref in - if ref' == ref then raw else - fst (notation_constr_of_constr bound t) + if ref' == ref then raw else (match t with + | None -> NRef ref' + | Some t -> + fst (notation_constr_of_constr bound t.Univ.univ_abstracted_value)) | NVar _ -> raw diff --git a/interp/notation_term.ml b/interp/notation_term.ml index 5fb0ca1b43..0ef1f267f6 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -20,13 +20,13 @@ open Glob_term as well as non global expressions such as existential variables. *) type notation_constr = - (** Part common to [glob_constr] and [cases_pattern] *) + (* Part common to [glob_constr] and [cases_pattern] *) | NRef of GlobRef.t | NVar of Id.t | NApp of notation_constr * notation_constr list | NHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option | NList of Id.t * Id.t * notation_constr * notation_constr * (* associativity: *) bool - (** Part only in [glob_constr] *) + (* Part only in [glob_constr] *) | NLambda of Name.t * notation_constr * notation_constr | NProd of Name.t * notation_constr * notation_constr | NBinderList of Id.t * Id.t * notation_constr * notation_constr * (* associativity: *) bool diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index b73d238c22..49273c4146 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -105,3 +105,10 @@ let search_syntactic_definition ?loc kn = let def = out_pat pat in verbose_compat ?loc kn def v; def + +let search_filtered_syntactic_definition ?loc filter kn = + let pat,v = KNmap.find kn !syntax_table in + let def = out_pat pat in + let res = filter def in + (match res with Some _ -> verbose_compat ?loc kn def v | None -> ()); + res diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index c5b6655ff8..77873f8f67 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -19,3 +19,6 @@ val declare_syntactic_definition : bool -> Id.t -> Flags.compat_version option -> syndef_interpretation -> unit val search_syntactic_definition : ?loc:Loc.t -> KerName.t -> syndef_interpretation + +val search_filtered_syntactic_definition : ?loc:Loc.t -> + (syndef_interpretation -> 'a option) -> KerName.t -> 'a option diff --git a/kernel/.merlin.in b/kernel/.merlin.in index 912ff61496..29da7d2cf6 100644 --- a/kernel/.merlin.in +++ b/kernel/.merlin.in @@ -1,4 +1,4 @@ -FLG -rectypes -thread -safe-string -w +a-4-44-50 +FLG -rectypes -thread -safe-string -w +a-4-44 S ../clib B ../clib diff --git a/kernel/constr.ml b/kernel/constr.ml index 8e5d15dd2d..d67d15b23b 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -1361,7 +1361,7 @@ type rel_context = rel_declaration list type named_context = named_declaration list type compacted_context = compacted_declaration list -(* Sorts and sort family *) +(** Minimalistic constr printer, typically for debugging *) let debug_print_fix pr_constr ((t,i),(lna,tl,bl)) = let open Pp in @@ -1377,8 +1377,6 @@ let pr_puniverses p u = if Univ.Instance.is_empty u then p else Pp.(p ++ str"(*" ++ Univ.Instance.pr Univ.Level.pr u ++ str"*)") -(* Minimalistic constr printer, typically for debugging *) - let rec debug_print c = let open Pp in match kind c with diff --git a/kernel/dune b/kernel/dune index 4f2e0e4e28..01abdb8f67 100644 --- a/kernel/dune +++ b/kernel/dune @@ -18,3 +18,4 @@ ; warnings. (env (dev (flags :standard -w +a-4-44-50))) + ; (ocaml408 (flags :standard -w +a-3-4-44-50))) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index a4a02791b4..68d44f8782 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -218,7 +218,9 @@ let check_subtyping_arity_constructor env (subst : constr -> constr) (arcn : typ let check_subtyping cumi paramsctxt env_ar inds = let numparams = Context.Rel.nhyps paramsctxt in let uctx = CumulativityInfo.univ_context cumi in - let new_levels = Array.init (UContext.size uctx) (Level.make DirPath.empty) in + let new_levels = Array.init (UContext.size uctx) + (fun i -> Level.make (Level.UGlobal.make DirPath.empty i)) + in let lmap = Array.fold_left2 (fun lmap u u' -> LMap.add u u' lmap) LMap.empty (Instance.to_array @@ UContext.instance uctx) new_levels in diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 9bbcf07f7e..05c5c0e821 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -593,10 +593,10 @@ let rec ienv_decompose_prod (env,_ as ienv) n c = ienv_decompose_prod ienv' (n-1) b | _ -> assert false +let dummy_univ = Level.(make (UGlobal.make (DirPath.make [Id.of_string "implicit"]) 0)) +let dummy_implicit_sort = mkType (Universe.make dummy_univ) let lambda_implicit_lift n a = - let level = Level.make (DirPath.make [Id.of_string "implicit"]) 0 in - let implicit_sort = mkType (Universe.make level) in - let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in + let lambda_implicit a = mkLambda (Anonymous, dummy_implicit_sort, a) in iterate lambda_implicit n (lift n a) (* This removes global parameters of the inductive types in lc (for diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 2a91c7dab0..52fb39e1d0 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -24,7 +24,7 @@ open Constr is the term into which we should inline. *) type delta_hint = - | Inline of int * (Univ.AUContext.t * constr) option + | Inline of int * constr Univ.univ_abstracted option | Equiv of KerName.t (* NB: earlier constructor Prefix_equiv of ModPath.t @@ -164,7 +164,7 @@ let find_prefix resolve mp = (** Applying a resolver to a kernel name *) -exception Change_equiv_to_inline of (int * (Univ.AUContext.t * constr)) +exception Change_equiv_to_inline of (int * constr Univ.univ_abstracted) let solve_delta_kn resolve kn = try @@ -294,43 +294,34 @@ let subst_ind sub (ind,i as indi) = let subst_pind sub (ind,u) = (subst_ind sub ind, u) -let subst_con0 sub (cst,u) = +let subst_con0 sub cst = let mpu,l = Constant.repr2 cst in let mpc = KerName.modpath (Constant.canonical cst) in let mpu,mpc,resolve,user = subst_dual_mp sub mpu mpc in let knu = KerName.make mpu l in let knc = if mpu == mpc then knu else KerName.make mpc l in match search_delta_inline resolve knu knc with - | Some (ctx, t) -> + | Some t -> (* In case of inlining, discard the canonical part (cf #2608) *) - let () = assert (Int.equal (Univ.AUContext.size ctx) (Univ.Instance.length u)) in - Constant.make1 knu, Vars.subst_instance_constr u t + Constant.make1 knu, Some t | None -> let knc' = progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc in let cst' = Constant.make knu knc' in - cst', mkConstU (cst',u) + cst', None let subst_con sub cst = try subst_con0 sub cst - with No_subst -> fst cst, mkConstU cst + with No_subst -> cst, None -let subst_con_kn sub con = - subst_con sub (con,Univ.Instance.empty) - -let subst_pcon sub (_con,u as pcon) = - try let con', _can = subst_con0 sub pcon in +let subst_pcon sub (con,u as pcon) = + try let con', _can = subst_con0 sub con in con',u with No_subst -> pcon -let subst_pcon_term sub (_con,u as pcon) = - try let con', can = subst_con0 sub pcon in - (con',u), can - with No_subst -> pcon, mkConstU pcon - let subst_constant sub con = - try fst (subst_con0 sub (con,Univ.Instance.empty)) + try fst (subst_con0 sub con) with No_subst -> con let subst_proj_repr sub p = @@ -351,7 +342,7 @@ let subst_evaluable_reference subst = function let rec map_kn f f' c = let func = map_kn f f' in match kind c with - | Const kn -> (try snd (f' kn) with No_subst -> c) + | Const kn -> (try f' kn with No_subst -> c) | Proj (p,t) -> let p' = Projection.map f p in let t' = func t in @@ -420,8 +411,14 @@ let rec map_kn f f' c = | _ -> c let subst_mps sub c = + let subst_pcon_term sub (con,u) = + let con', can = subst_con0 sub con in + match can with + | None -> mkConstU (con',u) + | Some t -> Vars.univ_instantiate_constr u t + in if is_empty_subst sub then c - else map_kn (subst_mind sub) (subst_con0 sub) c + else map_kn (subst_mind sub) (subst_pcon_term sub) c let rec replace_mp_in_mp mpfrom mpto mp = match mp with @@ -486,7 +483,7 @@ let gen_subst_delta_resolver dom subst resolver = | Equiv kequ -> (try Equiv (subst_kn_delta subst kequ) with Change_equiv_to_inline (lev,c) -> Inline (lev,Some c)) - | Inline (lev,Some (ctx, t)) -> Inline (lev,Some (ctx, subst_mps subst t)) + | Inline (lev,Some t) -> Inline (lev,Some (Univ.map_univ_abstracted (subst_mps subst) t)) | Inline (_,None) -> hint in Deltamap.add_kn kkey' hint' rslv diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 8416094063..ea391b3de7 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -28,7 +28,7 @@ val add_kn_delta_resolver : KerName.t -> KerName.t -> delta_resolver -> delta_resolver val add_inline_delta_resolver : - KerName.t -> (int * (Univ.AUContext.t * constr) option) -> delta_resolver -> delta_resolver + KerName.t -> (int * constr Univ.univ_abstracted option) -> delta_resolver -> delta_resolver val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver @@ -133,17 +133,11 @@ val subst_kn : substitution -> KerName.t -> KerName.t val subst_con : - substitution -> pconstant -> Constant.t * constr + substitution -> Constant.t -> Constant.t * constr Univ.univ_abstracted option val subst_pcon : substitution -> pconstant -> pconstant -val subst_pcon_term : - substitution -> pconstant -> pconstant * constr - -val subst_con_kn : - substitution -> Constant.t -> Constant.t * constr - val subst_constant : substitution -> Constant.t -> Constant.t diff --git a/kernel/modops.ml b/kernel/modops.ml index f43dbd88f9..97ac3cdebb 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -403,7 +403,8 @@ let inline_delta_resolver env inl mp mbid mtb delta = | Def body -> let constr = Mod_subst.force_constr body in let ctx = Declareops.constant_polymorphic_context constant in - add_inline_delta_resolver kn (lev, Some (ctx, constr)) l + let constr = Univ.{univ_abstracted_value=constr; univ_abstracted_binder=ctx} in + add_inline_delta_resolver kn (lev, Some constr) l with Not_found -> error_no_such_label_sub (Constant.label con) (ModPath.to_string (Constant.modpath con)) diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index afdc8f1511..5fc8d0297f 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -921,7 +921,7 @@ let sort_universes g = let types = Array.init (max_lvl + 1) (function | 0 -> Level.prop | 1 -> Level.set - | n -> Level.make mp (n-2)) + | n -> Level.make (Level.UGlobal.make mp (n-2))) in let g = Array.fold_left (fun g u -> let g, u = safe_repr g u in diff --git a/kernel/univ.ml b/kernel/univ.ml index 2b3b4f9486..d7c0cf13ec 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -36,10 +36,26 @@ open Util module RawLevel = struct open Names + + module UGlobal = struct + type t = DirPath.t * int + + let make dp i = (DirPath.hcons dp,i) + + let equal (d, i) (d', i') = DirPath.equal d d' && Int.equal i i' + + let hash (d,i) = Hashset.Combine.combine i (DirPath.hash d) + + let compare (d, i) (d', i') = + let c = Int.compare i i' in + if Int.equal c 0 then DirPath.compare d d' + else c + end + type t = | Prop | Set - | Level of int * DirPath.t + | Level of UGlobal.t | Var of int (* Hash-consing *) @@ -49,8 +65,7 @@ struct match x, y with | Prop, Prop -> true | Set, Set -> true - | Level (n,d), Level (n',d') -> - Int.equal n n' && DirPath.equal d d' + | Level l, Level l' -> UGlobal.equal l l' | Var n, Var n' -> Int.equal n n' | _ -> false @@ -62,7 +77,7 @@ struct | Set, Set -> 0 | Set, _ -> -1 | _, Set -> 1 - | Level (i1, dp1), Level (i2, dp2) -> + | Level (dp1, i1), Level (dp2, i2) -> if i1 < i2 then -1 else if i1 > i2 then 1 else DirPath.compare dp1 dp2 @@ -83,9 +98,9 @@ struct let hcons = function | Prop as x -> x | Set as x -> x - | Level (n,d) as x -> + | Level (d,n) as x -> let d' = Names.DirPath.hcons d in - if d' == d then x else Level (n,d') + if d' == d then x else Level (d',n) | Var _n as x -> x open Hashset.Combine @@ -94,18 +109,18 @@ struct | Prop -> combinesmall 1 0 | Set -> combinesmall 1 1 | Var n -> combinesmall 2 n - | Level (n, d) -> combinesmall 3 (combine n (Names.DirPath.hash d)) + | Level (d, n) -> combinesmall 3 (combine n (Names.DirPath.hash d)) end module Level = struct - open Names + module UGlobal = RawLevel.UGlobal type raw_level = RawLevel.t = | Prop | Set - | Level of int * DirPath.t + | Level of UGlobal.t | Var of int (** Embed levels with their hash value *) @@ -166,7 +181,7 @@ module Level = struct match data x with | Prop -> "Prop" | Set -> "Set" - | Level (n,d) -> Names.DirPath.to_string d^"."^string_of_int n + | Level (d,n) -> Names.DirPath.to_string d^"."^string_of_int n | Var n -> "Var(" ^ string_of_int n ^ ")" let pr u = str (to_string u) @@ -185,11 +200,11 @@ module Level = struct match data u with | Var n -> Some n | _ -> None - let make m n = make (Level (n, Names.DirPath.hcons m)) + let make qid = make (Level qid) let name u = match data u with - | Level (n, d) -> Some (d, n) + | Level (d, n) -> Some (d, n) | _ -> None end @@ -963,6 +978,15 @@ struct end +type 'a univ_abstracted = { + univ_abstracted_value : 'a; + univ_abstracted_binder : AUContext.t; +} + +let map_univ_abstracted f {univ_abstracted_value;univ_abstracted_binder} = + let univ_abstracted_value = f univ_abstracted_value in + {univ_abstracted_value;univ_abstracted_binder} + let hcons_abstract_universe_context = AUContext.hcons (** Universe info for cumulative inductive types: A context of @@ -1010,6 +1034,8 @@ module ACumulativityInfo = struct type t = AUContext.t * Variance.t array + let repr (auctx,var) = AUContext.repr auctx, var + let pr prl (univs, variance) = AUContext.pr prl ~variance univs diff --git a/kernel/univ.mli b/kernel/univ.mli index de7b334ae4..d7097be570 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -11,9 +11,22 @@ (** Universes. *) module Level : sig + + module UGlobal : sig + type t + + val make : Names.DirPath.t -> int -> t + val equal : t -> t -> bool + val hash : t -> int + val compare : t -> t -> int + + end + (** Qualified global universe level *) + type t (** Type of universe levels. A universe level is essentially a unique name - that will be associated to constraints later on. *) + that will be associated to constraints later on. A level can be local to a + definition or global. *) val set : t val prop : t @@ -34,9 +47,7 @@ sig val hash : t -> int - val make : Names.DirPath.t -> int -> t - (** Create a new universe level from a unique identifier and an associated - module path. *) + val make : UGlobal.t -> t val pr : t -> Pp.t (** Pretty-printing *) @@ -48,7 +59,7 @@ sig val var_index : t -> int option - val name : t -> (Names.DirPath.t * int) option + val name : t -> UGlobal.t option end (** Sets of universe levels *) @@ -349,6 +360,14 @@ sig end +type 'a univ_abstracted = { + univ_abstracted_value : 'a; + univ_abstracted_binder : AUContext.t; +} +(** A value with bound universe levels. *) + +val map_univ_abstracted : ('a -> 'b) -> 'a univ_abstracted -> 'b univ_abstracted + (** Universe info for cumulative inductive types: A context of universe levels with universe constraints, representing local universe variables and constraints, together with an array of @@ -381,6 +400,7 @@ module ACumulativityInfo : sig type t + val repr : t -> CumulativityInfo.t val univ_context : t -> AUContext.t val variance : t -> Variance.t array val leq_constraints : t -> Instance.t constraint_function diff --git a/kernel/vars.ml b/kernel/vars.ml index f9c576ca4a..bd56d60053 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -295,6 +295,11 @@ let subst_instance_constr subst c = in aux c +let univ_instantiate_constr u c = + let open Univ in + assert (Int.equal (Instance.length u) (AUContext.size c.univ_abstracted_binder)); + subst_instance_constr u c.univ_abstracted_value + (* let substkey = CProfile.declare_profile "subst_instance_constr";; *) (* let subst_instance_constr inst c = CProfile.profile2 substkey subst_instance_constr inst c;; *) diff --git a/kernel/vars.mli b/kernel/vars.mli index 7c928e2694..f2c32b3625 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -140,4 +140,7 @@ val subst_univs_level_context : Univ.universe_level_subst -> Constr.rel_context val subst_instance_constr : Instance.t -> constr -> constr val subst_instance_context : Instance.t -> Constr.rel_context -> Constr.rel_context +val univ_instantiate_constr : Instance.t -> constr univ_abstracted -> constr +(** Ignores the constraints carried by [univ_abstracted]. *) + val universes_of_constr : constr -> Univ.LSet.t diff --git a/lib/control.ml b/lib/control.ml index 3fbeb168c4..e09068740d 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -62,8 +62,8 @@ let windows_timeout n f x e = let res = f x in let () = killed := true in let cur = Unix.gettimeofday () in - (** The thread did not interrupt, but the computation took longer than - expected. *) + (* The thread did not interrupt, but the computation took longer than + expected. *) let () = if float_of_int n <= cur -. init then begin exited := true; raise Sys.Break @@ -71,7 +71,7 @@ let windows_timeout n f x e = res with | Sys.Break -> - (** Just in case, it could be a regular Ctrl+C *) + (* Just in case, it could be a regular Ctrl+C *) if not !exited then begin killed := true; raise Sys.Break end else raise e | e -> diff --git a/lib/system.mli b/lib/system.mli index f13fd30923..a3b79ee528 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -102,6 +102,7 @@ type time val get_time : unit -> time val time_difference : time -> time -> float (** in seconds *) + val fmt_time_difference : time -> time -> Pp.t val with_time : batch:bool -> ('a -> 'b) -> 'a -> 'b diff --git a/library/coqlib.mli b/library/coqlib.mli index 351a0a7e84..f6779dbbde 100644 --- a/library/coqlib.mli +++ b/library/coqlib.mli @@ -190,12 +190,18 @@ val build_bool_type : coq_bool_data delayed val build_prod : coq_sigma_data delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] -val build_coq_eq : GlobRef.t delayed (** = [(build_coq_eq_data()).eq] *) +val build_coq_eq : GlobRef.t delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] -val build_coq_eq_refl : GlobRef.t delayed (** = [(build_coq_eq_data()).refl] *) +(** = [(build_coq_eq_data()).eq] *) + +val build_coq_eq_refl : GlobRef.t delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] -val build_coq_eq_sym : GlobRef.t delayed (** = [(build_coq_eq_data()).sym] *) +(** = [(build_coq_eq_data()).refl] *) + +val build_coq_eq_sym : GlobRef.t delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] +(** = [(build_coq_eq_data()).sym] *) + val build_coq_f_equal2 : GlobRef.t delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] @@ -222,8 +228,8 @@ val build_coq_inversion_eq_true_data : coq_inversion_data delayed val build_coq_sumbool : GlobRef.t delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] -(** {6 ... } *) -(** Connectives +(** {6 ... } + Connectives The False proposition *) val build_coq_False : GlobRef.t delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml index c1a673edf0..171d51800e 100644 --- a/library/decl_kinds.ml +++ b/library/decl_kinds.ml @@ -57,7 +57,6 @@ type assumption_object_kind = Definitional | Logical | Conjectural *) type assumption_kind = locality * polymorphic * assumption_object_kind - type definition_kind = locality * polymorphic * definition_object_kind (** Kinds used in proofs *) diff --git a/library/declaremods.ml b/library/declaremods.ml index d20775a0d7..8699583cdf 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -845,7 +845,7 @@ end (** {6 Module operations handling summary freeze/unfreeze} *) let protect_summaries f = - let fs = Summary.freeze_summaries ~marshallable:`No in + let fs = Summary.freeze_summaries ~marshallable:false in try f fs with reraise -> (* Something wrong: undo the whole process *) diff --git a/library/decls.mli b/library/decls.mli index 401884736e..c0db537427 100644 --- a/library/decls.mli +++ b/library/decls.mli @@ -19,7 +19,7 @@ open Decl_kinds (** Registration and access to the table of variable *) type variable_data = - DirPath.t * bool (** opacity *) * Univ.ContextSet.t * polymorphic * logical_kind + DirPath.t * bool (* opacity *) * Univ.ContextSet.t * polymorphic * logical_kind val add_variable_data : variable -> variable_data -> unit val variable_path : variable -> DirPath.t diff --git a/library/global.ml b/library/global.ml index 67b00cf411..84d2a37170 100644 --- a/library/global.ml +++ b/library/global.ml @@ -36,10 +36,9 @@ let is_joined_environment () = let global_env_summary_tag = Summary.declare_summary_tag global_env_summary_name - { Summary.freeze_function = (function - | `Yes -> join_safe_environment (); !global_env - | `No -> !global_env - | `Shallow -> !global_env); + { Summary.freeze_function = (fun ~marshallable -> if marshallable then + (join_safe_environment (); !global_env) + else !global_env); unfreeze_function = (fun fr -> global_env := fr); init_function = (fun () -> global_env := Safe_typing.empty_environment) } diff --git a/library/globnames.ml b/library/globnames.ml index 9aca7788d2..db2e8bfaed 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -31,8 +31,8 @@ let destConstructRef = function ConstructRef ind -> ind | _ -> failwith "destCon let subst_constructor subst (ind,j as ref) = let ind' = subst_ind subst ind in - if ind==ind' then ref, mkConstruct ref - else (ind',j), mkConstruct (ind',j) + if ind==ind' then ref + else (ind',j) let subst_global_reference subst ref = match ref with | VarRef var -> ref @@ -43,20 +43,20 @@ let subst_global_reference subst ref = match ref with let ind' = subst_ind subst ind in if ind==ind' then ref else IndRef ind' | ConstructRef ((kn,i),j as c) -> - let c',t = subst_constructor subst c in - if c'==c then ref else ConstructRef c' + let c' = subst_constructor subst c in + if c'==c then ref else ConstructRef c' let subst_global subst ref = match ref with - | VarRef var -> ref, mkVar var + | VarRef var -> ref, None | ConstRef kn -> - let kn',t = subst_con_kn subst kn in - if kn==kn' then ref, mkConst kn else ConstRef kn', t + let kn',t = subst_con subst kn in + if kn==kn' then ref, None else ConstRef kn', t | IndRef ind -> let ind' = subst_ind subst ind in - if ind==ind' then ref, mkInd ind else IndRef ind', mkInd ind' + if ind==ind' then ref, None else IndRef ind', None | ConstructRef ((kn,i),j as c) -> - let c',t = subst_constructor subst c in - if c'==c then ref,t else ConstructRef c', t + let c' = subst_constructor subst c in + if c'==c then ref,None else ConstructRef c', None let canonical_gr = function | ConstRef con -> ConstRef(Constant.make1 (Constant.canonical con)) diff --git a/library/globnames.mli b/library/globnames.mli index a96a42ced2..d49ed453f5 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -36,8 +36,8 @@ val destConstructRef : GlobRef.t -> constructor val is_global : GlobRef.t -> constr -> bool -val subst_constructor : substitution -> constructor -> constructor * constr -val subst_global : substitution -> GlobRef.t -> GlobRef.t * constr +val subst_constructor : substitution -> constructor -> constructor +val subst_global : substitution -> GlobRef.t -> GlobRef.t * constr Univ.univ_abstracted option val subst_global_reference : substitution -> GlobRef.t -> GlobRef.t (** This constr is not safe to be typechecked, universe polymorphism is not diff --git a/library/goptions.ml b/library/goptions.ml index 98efb512ab..1b907fd966 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -235,7 +235,7 @@ let declare_option cast uncast append ?(preprocess = fun x -> x) let default = read() in let change = let _ = Summary.declare_summary (nickname key) - { Summary.freeze_function = (fun _ -> read ()); + { Summary.freeze_function = (fun ~marshallable -> read ()); Summary.unfreeze_function = write; Summary.init_function = (fun () -> write default) } in let cache_options (_,(l,m,v)) = @@ -246,14 +246,14 @@ let declare_option cast uncast append ?(preprocess = fun x -> x) | OptGlobal -> cache_options o | OptExport -> () | OptLocal | OptDefault -> - (** Ruled out by classify_function *) + (* Ruled out by classify_function *) assert false in let open_options i (_, (l, _, _) as o) = match l with | OptExport -> if Int.equal i 1 then cache_options o | OptGlobal -> () | OptLocal | OptDefault -> - (** Ruled out by classify_function *) + (* Ruled out by classify_function *) assert false in let subst_options (subst,obj) = obj in diff --git a/library/keys.ml b/library/keys.ml index 53447a679a..58883ccc88 100644 --- a/library/keys.ml +++ b/library/keys.ml @@ -100,18 +100,13 @@ let discharge_keys (_,(k,k')) = | Some x, Some y -> Some (x, y) | _ -> None -let rebuild_keys (ref,ref') = (ref, ref') - type key_obj = key * key let inKeys : key_obj -> obj = - declare_object {(default_object "KEYS") with - cache_function = cache_keys; - load_function = load_keys; - subst_function = subst_keys; - classify_function = (fun x -> Substitute x); - discharge_function = discharge_keys; - rebuild_function = rebuild_keys } + declare_object @@ superglobal_object "KEYS" + ~cache:cache_keys + ~subst:(Some subst_keys) + ~discharge:discharge_keys let declare_equiv_keys ref ref' = Lib.add_anonymous_leaf (inKeys (ref,ref')) diff --git a/library/lib.ml b/library/lib.ml index 9c13cdafdb..d4381a6923 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -481,8 +481,8 @@ let named_of_variable_context = List.map fst let name_instance inst = - (** FIXME: this should probably be done at an upper level, by storing the - name information in the section data structure. *) + (* FIXME: this should probably be done at an upper level, by storing the + name information in the section data structure. *) let map lvl = match Univ.Level.name lvl with | None -> (* Having Prop/Set/Var as section universes makes no sense *) assert false @@ -491,8 +491,8 @@ let name_instance inst = let qid = Nametab.shortest_qualid_of_universe na in Name (Libnames.qualid_basename qid) with Not_found -> - (** Best-effort naming from the string representation of the level. - See univNames.ml for a similar hack. *) + (* Best-effort naming from the string representation of the level. + See univNames.ml for a similar hack. *) Name (Id.of_string_soft (Univ.Level.to_string lvl)) in Array.map map (Univ.Instance.to_array inst) @@ -571,7 +571,7 @@ let open_section id = let prefix = Nametab.{ obj_dir; obj_mp = opp.obj_mp; obj_sec = add_dirpath_suffix opp.obj_sec id } in if Nametab.exists_section obj_dir then user_err ~hdr:"open_section" (Id.print id ++ str " already exists."); - let fs = Summary.freeze_summaries ~marshallable:`No in + let fs = Summary.freeze_summaries ~marshallable:false in add_entry (make_foname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) Nametab.(push_dir (Until 1) obj_dir (GlobDirRef.DirOpenSection prefix)); @@ -608,24 +608,21 @@ let close_section () = type frozen = lib_state -let freeze ~marshallable = - match marshallable with - | `Shallow -> - (* TASSI: we should do something more sensible here *) - let lib_stk = - CList.map_filter (function +let freeze ~marshallable = !lib_state + +let unfreeze st = lib_state := st + +let drop_objects st = + let lib_stk = + CList.map_filter (function | _, Leaf _ -> None | n, (CompilingLibrary _ as x) -> Some (n,x) | n, OpenedModule (it,e,op,_) -> - Some(n,OpenedModule(it,e,op,Summary.empty_frozen)) + Some(n,OpenedModule(it,e,op,Summary.empty_frozen)) | n, OpenedSection (op, _) -> - Some(n,OpenedSection(op,Summary.empty_frozen))) - !lib_state.lib_stk in - { !lib_state with lib_stk } - | _ -> - !lib_state - -let unfreeze st = lib_state := st + Some(n,OpenedSection(op,Summary.empty_frozen))) + st.lib_stk in + { st with lib_stk } let init () = unfreeze initial_lib_state; diff --git a/library/lib.mli b/library/lib.mli index d1b4977dd5..30569197bc 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -148,9 +148,12 @@ val close_section : unit -> unit type frozen -val freeze : marshallable:Summary.marshallable -> frozen +val freeze : marshallable:bool -> frozen val unfreeze : frozen -> unit +(** Keep only the libobject structure, not the objects themselves *) +val drop_objects : frozen -> frozen + val init : unit -> unit (** {6 Section management for discharge } *) diff --git a/library/libnames.mli b/library/libnames.mli index 9960603cbb..bbb4d2a058 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -94,8 +94,8 @@ val qualid_basename : qualid -> Id.t val default_library : DirPath.t (** This is the root of the standard library of Coq *) -val coq_root : module_ident (** "Coq" *) -val coq_string : string (** "Coq" *) +val coq_root : module_ident (* "Coq" *) +val coq_string : string (* "Coq" *) (** This is the default root prefix for developments which doesn't mention a root *) diff --git a/library/libobject.ml b/library/libobject.ml index c153e9a09a..3d17b4a605 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -129,3 +129,46 @@ let rebuild_object lobj = apply_dyn_fun (fun d -> d.dyn_rebuild_function lobj) lobj let dump = Dyn.dump + +let local_object_nodischarge s ~cache = + { (default_object s) with + cache_function = cache; + classify_function = (fun _ -> Dispose); + } + +let local_object s ~cache ~discharge = + { (local_object_nodischarge s ~cache) with + discharge_function = discharge } + +let global_object_nodischarge s ~cache ~subst = + let import i o = if Int.equal i 1 then cache o in + { (default_object s) with + cache_function = cache; + open_function = import; + subst_function = (match subst with + | None -> fun _ -> CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!") + | Some subst -> subst; + ); + classify_function = + if Option.has_some subst then (fun o -> Substitute o) else (fun o -> Keep o); + } + +let global_object s ~cache ~subst ~discharge = + { (global_object_nodischarge s ~cache ~subst) with + discharge_function = discharge } + +let superglobal_object_nodischarge s ~cache ~subst = + { (default_object s) with + load_function = (fun _ x -> cache x); + cache_function = cache; + subst_function = (match subst with + | None -> fun _ -> CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!") + | Some subst -> subst; + ); + classify_function = + if Option.has_some subst then (fun o -> Substitute o) else (fun o -> Keep o); + } + +let superglobal_object s ~cache ~subst ~discharge = + { (superglobal_object_nodischarge s ~cache ~subst) with + discharge_function = discharge } diff --git a/library/libobject.mli b/library/libobject.mli index 32ffc5b79e..00515bd273 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -119,6 +119,51 @@ val classify_object : obj -> obj substitutivity val discharge_object : object_name * obj -> obj option val rebuild_object : obj -> obj +(** Higher-level API for objects with fixed scope. + +- Local means that the object cannot be imported from outside. +- Global means that it can be imported (by importing the module that contains the +object). +- Superglobal means that the object survives to closing a module, and is imported +when the file which contains it is Required (even without Import). +- With the nodischarge variants, the object does not survive section closing. + With the normal variants, it does. + +We recommend to avoid declaring superglobal objects and using the nodischarge +variants. +*) + +val local_object : string -> + cache:(object_name * 'a -> unit) -> + discharge:(object_name * 'a -> 'a option) -> + 'a object_declaration + +val local_object_nodischarge : string -> + cache:(object_name * 'a -> unit) -> + 'a object_declaration + +val global_object : string -> + cache:(object_name * 'a -> unit) -> + subst:(Mod_subst.substitution * 'a -> 'a) option -> + discharge:(object_name * 'a -> 'a option) -> + 'a object_declaration + +val global_object_nodischarge : string -> + cache:(object_name * 'a -> unit) -> + subst:(Mod_subst.substitution * 'a -> 'a) option -> + 'a object_declaration + +val superglobal_object : string -> + cache:(object_name * 'a -> unit) -> + subst:(Mod_subst.substitution * 'a -> 'a) option -> + discharge:(object_name * 'a -> 'a option) -> + 'a object_declaration + +val superglobal_object_nodischarge : string -> + cache:(object_name * 'a -> unit) -> + subst:(Mod_subst.substitution * 'a -> 'a) option -> + 'a object_declaration + (** {6 Debug} *) val dump : unit -> (int * string) list diff --git a/library/library.mli b/library/library.mli index d298a371b5..c016352808 100644 --- a/library/library.mli +++ b/library/library.mli @@ -19,8 +19,8 @@ open Libnames written at various dates. *) -(** {6 ... } *) -(** Require = load in the environment + open (if the optional boolean +(** {6 ... } + Require = load in the environment + open (if the optional boolean is not [None]); mark also for export if the boolean is [Some true] *) val require_library_from_dirpath : (DirPath.t * string) list -> bool option -> unit diff --git a/library/nametab.ml b/library/nametab.ml index e29c7b2960..95890b2edf 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -107,6 +107,7 @@ module type NAMETREE = sig val user_name : qualid -> t -> user_name val shortest_qualid : ?loc:Loc.t -> Id.Set.t -> user_name -> t -> qualid val find_prefixes : qualid -> t -> elt list + (** Matches a prefix of [qualid], useful for completion *) val match_prefixes : qualid -> t -> elt list end @@ -347,12 +348,10 @@ module DirTab = Make(DirPath')(GlobDirRef) type dirtab = DirTab.t let the_dirtab = Summary.ref ~name:"dirtab" (DirTab.empty : dirtab) -type universe_id = DirPath.t * int - module UnivIdEqual = struct - type t = universe_id - let equal (d, i) (d', i') = DirPath.equal d d' && Int.equal i i' + type t = Univ.Level.UGlobal.t + let equal = Univ.Level.UGlobal.equal end module UnivTab = Make(FullPath)(UnivIdEqual) type univtab = UnivTab.t @@ -375,12 +374,9 @@ let the_modtyperevtab = Summary.ref ~name:"modtyperevtab" (MPmap.empty : mptrevt module UnivIdOrdered = struct - type t = universe_id - let hash (d, i) = i + DirPath.hash d - let compare (d, i) (d', i') = - let c = Int.compare i i' in - if Int.equal c 0 then DirPath.compare d d' - else c + type t = Univ.Level.UGlobal.t + let hash = Univ.Level.UGlobal.hash + let compare = Univ.Level.UGlobal.compare end module UnivIdMap = HMap.Make(UnivIdOrdered) diff --git a/library/nametab.mli b/library/nametab.mli index 24af07619d..fccb8fd918 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -120,11 +120,9 @@ val push_modtype : visibility -> full_path -> ModPath.t -> unit val push_dir : visibility -> DirPath.t -> GlobDirRef.t -> unit val push_syndef : visibility -> full_path -> syndef_name -> unit -type universe_id = DirPath.t * int +module UnivIdMap : CMap.ExtS with type key = Univ.Level.UGlobal.t -module UnivIdMap : CMap.ExtS with type key = universe_id - -val push_universe : visibility -> full_path -> universe_id -> unit +val push_universe : visibility -> full_path -> Univ.Level.UGlobal.t -> unit (** {6 The following functions perform globalization of qualified names } *) @@ -139,7 +137,7 @@ val locate_modtype : qualid -> ModPath.t val locate_dir : qualid -> GlobDirRef.t val locate_module : qualid -> ModPath.t val locate_section : qualid -> DirPath.t -val locate_universe : qualid -> universe_id +val locate_universe : qualid -> Univ.Level.UGlobal.t (** These functions globalize user-level references into global references, like [locate] and co, but raise a nice error message @@ -173,7 +171,9 @@ val exists_cci : full_path -> bool val exists_modtype : full_path -> bool val exists_dir : DirPath.t -> bool val exists_section : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) + val exists_module : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) + val exists_universe : full_path -> bool (** {6 These functions locate qualids into full user names } *) @@ -196,7 +196,7 @@ val path_of_modtype : ModPath.t -> full_path (** A universe_id might not be registered with a corresponding user name. @raise Not_found if the universe was not introduced by the user. *) -val path_of_universe : universe_id -> full_path +val path_of_universe : Univ.Level.UGlobal.t -> full_path (** Returns in particular the dirpath or the basename of the full path associated to global reference *) @@ -218,7 +218,7 @@ val shortest_qualid_of_global : ?loc:Loc.t -> Id.Set.t -> GlobRef.t -> qualid val shortest_qualid_of_syndef : ?loc:Loc.t -> Id.Set.t -> syndef_name -> qualid val shortest_qualid_of_modtype : ?loc:Loc.t -> ModPath.t -> qualid val shortest_qualid_of_module : ?loc:Loc.t -> ModPath.t -> qualid -val shortest_qualid_of_universe : ?loc:Loc.t -> universe_id -> qualid +val shortest_qualid_of_universe : ?loc:Loc.t -> Univ.Level.UGlobal.t -> qualid (** Deprecated synonyms *) diff --git a/library/states.ml b/library/states.ml index ae45b18b9c..92bdc410a3 100644 --- a/library/states.ml +++ b/library/states.ml @@ -13,8 +13,10 @@ open System type state = Lib.frozen * Summary.frozen +let lib_of_state = fst let summary_of_state = snd -let replace_summary (lib,_) s = lib, s +let replace_summary (lib,_) st = lib, st +let replace_lib (_,st) lib = lib, st let freeze ~marshallable = (Lib.freeze ~marshallable, Summary.freeze_summaries ~marshallable) @@ -24,7 +26,7 @@ let unfreeze (fl,fs) = Summary.unfreeze_summaries fs let extern_state s = - System.extern_state Coq_config.state_magic_number s (freeze ~marshallable:`Yes) + System.extern_state Coq_config.state_magic_number s (freeze ~marshallable:true) let intern_state s = unfreeze (with_magic_number_check (System.intern_state Coq_config.state_magic_number) s); @@ -33,7 +35,7 @@ let intern_state s = (* Rollback. *) let with_state_protection f x = - let st = freeze ~marshallable:`No in + let st = freeze ~marshallable:false in try let a = f x in unfreeze st; a with reraise -> diff --git a/library/states.mli b/library/states.mli index 1e0361ea4f..52feb95222 100644 --- a/library/states.mli +++ b/library/states.mli @@ -19,11 +19,13 @@ val intern_state : string -> unit val extern_state : string -> unit type state -val freeze : marshallable:Summary.marshallable -> state +val freeze : marshallable:bool -> state val unfreeze : state -> unit val summary_of_state : state -> Summary.frozen +val lib_of_state : state -> Lib.frozen val replace_summary : state -> Summary.frozen -> state +val replace_lib : state -> Lib.frozen -> state (** {6 Rollback } *) diff --git a/library/summary.ml b/library/summary.ml index 9b22945919..8fbca44353 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -14,10 +14,8 @@ open Util module Dyn = Dyn.Make () -type marshallable = [ `Yes | `No | `Shallow ] - type 'a summary_declaration = { - freeze_function : marshallable -> 'a; + freeze_function : marshallable:bool -> 'a; unfreeze_function : 'a -> unit; init_function : unit -> unit } @@ -31,7 +29,7 @@ let ml_modules = "ML-MODULES" let internal_declare_summary fadd sumname sdecl = let infun, outfun, tag = Dyn.Easy.make_dyn_tag (mangle sumname) in - let dyn_freeze b = infun (sdecl.freeze_function b) + let dyn_freeze ~marshallable = infun (sdecl.freeze_function ~marshallable) and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum) and dyn_init = sdecl.init_function in let ddecl = { @@ -70,9 +68,9 @@ type frozen = { let empty_frozen = { summaries = String.Map.empty; ml_module = None } let freeze_summaries ~marshallable : frozen = - let smap decl = decl.freeze_function marshallable in + let smap decl = decl.freeze_function ~marshallable in { summaries = String.Map.map smap !sum_map; - ml_module = Option.map (fun decl -> decl.freeze_function marshallable) !sum_mod; + ml_module = Option.map (fun decl -> decl.freeze_function ~marshallable) !sum_mod; } let warn_summary_out_of_scope = @@ -92,7 +90,7 @@ let unfreeze_summaries ?(partial=false) { summaries; ml_module } = | None -> anomaly (str "Undeclared summary " ++ str ml_modules ++ str ".") | Some decl -> Option.iter (fun state -> decl.unfreeze_function state) ml_module end; - (** We must be independent on the order of the map! *) + (* We must be independent on the order of the map! *) let ufz name decl = try decl.unfreeze_function String.Map.(find name summaries) with Not_found -> @@ -130,10 +128,10 @@ let remove_from_summary st tag = (** All-in-one reference declaration + registration *) -let ref_tag ?(freeze=fun _ r -> r) ~name x = +let ref_tag ?(freeze=fun ~marshallable r -> r) ~name x = let r = ref x in let tag = declare_summary_tag name - { freeze_function = (fun b -> freeze b !r); + { freeze_function = (fun ~marshallable -> freeze ~marshallable !r); unfreeze_function = ((:=) r); init_function = (fun () -> r := x) } in r, tag @@ -157,7 +155,7 @@ let (!) r = let ref ?(freeze=fun x -> x) ~name init = let r = Pervasives.ref (CEphemeron.create init, name) in declare_summary name - { freeze_function = (fun _ -> freeze !r); + { freeze_function = (fun ~marshallable -> freeze !r); unfreeze_function = ((:=) r); init_function = (fun () -> r := init) }; r diff --git a/library/summary.mli b/library/summary.mli index 7d91a79188..0d77d725ac 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -11,17 +11,12 @@ (** This module registers the declaration of global tables, which will be kept in synchronization during the various backtracks of the system. *) -type marshallable = - [ `Yes (* Full data will be marshalled to disk *) - | `No (* Full data will be store in memory, e.g. for Undo *) - | `Shallow ] (* Only part of the data will be marshalled to a slave process *) - (** Types of global Coq states. The ['a] type should be pure and marshallable by the standard OCaml marshalling function. *) type 'a summary_declaration = { - (** freeze_function [true] is for marshalling to disk. + freeze_function : marshallable:bool -> 'a; + (** freeze_function [true] is for marshalling to disk. * e.g. lazy must be forced *) - freeze_function : marshallable -> 'a; unfreeze_function : 'a -> unit; init_function : unit -> unit } @@ -50,8 +45,8 @@ val declare_summary_tag : string -> 'a summary_declaration -> 'a Dyn.tag The [init_function] restores the reference to its initial value. The [freeze_function] can be overridden *) -val ref : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref -val ref_tag : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref * 'a Dyn.tag +val ref : ?freeze:(marshallable:bool -> 'a -> 'a) -> name:string -> 'a -> 'a ref +val ref_tag : ?freeze:(marshallable:bool -> 'a -> 'a) -> name:string -> 'a -> 'a ref * 'a Dyn.tag (* As [ref] but the value is local to a process, i.e. not sent to, say, proof * workers. It is useful to implement a local cache for example. *) @@ -81,7 +76,7 @@ val nop : unit -> unit type frozen val empty_frozen : frozen -val freeze_summaries : marshallable:marshallable -> frozen +val freeze_summaries : marshallable:bool -> frozen val unfreeze_summaries : ?partial:bool -> frozen -> unit val init_summaries : unit -> unit diff --git a/parsing/extend.ml b/parsing/extend.ml index 050ed49622..9b5537d7f6 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -106,11 +106,11 @@ type 'a production_rule = type 'a single_extend_statement = string option * - (** Level *) + (* Level *) Gramlib.Gramext.g_assoc option * - (** Associativity *) + (* Associativity *) 'a production_rule list - (** Symbol list with the interpretation function *) + (* Symbol list with the interpretation function *) type 'a extend_statement = Gramlib.Gramext.position option * diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 923147ba2e..19ae97da77 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -553,7 +553,7 @@ type frozen_t = (grammar_entry * GramState.t) list * CLexer.keyword_state -let freeze _ : frozen_t = +let freeze ~marshallable : frozen_t = (!grammar_stack, CLexer.get_keyword_state ()) (* We compare the current state of the grammar and the state to unfreeze, @@ -586,7 +586,7 @@ let parser_summary_tag = Summary.init_function = Summary.nop } let with_grammar_rule_protection f x = - let fs = freeze false in + let fs = freeze ~marshallable:false in try let a = f x in unfreeze fs; a with reraise -> let reraise = CErrors.push reraise in diff --git a/parsing/tok.ml b/parsing/tok.ml index 91b4f25ba3..c0d5b6742d 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -36,12 +36,24 @@ let equal t1 t2 = match t1, t2 with | EOI, EOI -> true | _ -> false -let extract_string = function +let extract_string diff_mode = function | KEYWORD s -> s | IDENT s -> s - | STRING s -> s + | STRING s -> + if diff_mode then + let escape_quotes s = + let len = String.length s in + let buf = Buffer.create len in + for i = 0 to len-1 do + let ch = String.get s i in + Buffer.add_char buf ch; + if ch = '"' then Buffer.add_char buf '"' else () + done; + Buffer.contents buf + in + "\"" ^ (escape_quotes s) ^ "\"" else s | PATTERNIDENT s -> s - | FIELD s -> s + | FIELD s -> if diff_mode then "." ^ s else s | INT s -> s | LEFTQMARK -> "?" | BULLET s -> s diff --git a/parsing/tok.mli b/parsing/tok.mli index 9b8c008555..5750096a28 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -22,11 +22,13 @@ type t = | EOI val equal : t -> t -> bool -val extract_string : t -> string +(* pass true for diff_mode *) +val extract_string : bool -> t -> string val to_string : t -> string (* Needed to fit Camlp5 signature *) val print : Format.formatter -> t -> unit val match_keyword : string -> t -> bool + (** for camlp5 *) val of_pattern : string*string -> t val to_pattern : t -> string*string diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 480819ebe1..6f9384941b 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -27,12 +27,12 @@ let start_deriving f suchthat lemma = let sigma = Evd.from_env env in let kind = Decl_kinds.(Global,false,DefinitionBody Definition) in - (** create a sort variable for the type of [f] *) + (* create a sort variable for the type of [f] *) (* spiwack: I don't know what the rigidity flag does, picked the one that looked the most general. *) let (sigma,f_type_sort) = Evd.new_sort_variable Evd.univ_flexible_alg sigma in let f_type_type = EConstr.mkSort f_type_sort in - (** create the initial goals for the proof: |- Type ; |- ?1 ; f:=?2 |- suchthat *) + (* create the initial goals for the proof: |- Type ; |- ?1 ; f:=?2 |- suchthat *) let goals = let open Proofview in TCons ( env , sigma , f_type_type , (fun sigma f_type -> @@ -45,14 +45,14 @@ let start_deriving f suchthat lemma = TNil sigma)))))) in - (** The terminator handles the registering of constants when the proof is closed. *) + (* The terminator handles the registering of constants when the proof is closed. *) let terminator com = let open Proof_global in - (** Extracts the relevant information from the proof. [Admitted] - and [Save] result in user errors. [opaque] is [true] if the - proof was concluded by [Qed], and [false] if [Defined]. [f_def] - and [lemma_def] correspond to the proof of [f] and of - [suchthat], respectively. *) + (* Extracts the relevant information from the proof. [Admitted] + and [Save] result in user errors. [opaque] is [true] if the + proof was concluded by [Qed], and [false] if [Defined]. [f_def] + and [lemma_def] correspond to the proof of [f] and of + [suchthat], respectively. *) let (opaque,f_def,lemma_def) = match com with | Admitted _ -> CErrors.user_err Pp.(str "Admitted isn't supported in Derive.") @@ -64,26 +64,26 @@ let start_deriving f suchthat lemma = opaque <> Proof_global.Transparent , f_def , lemma_def | _ -> assert false in - (** The opacity of [f_def] is adjusted to be [false], as it - must. Then [f] is declared in the global environment. *) + (* The opacity of [f_def] is adjusted to be [false], as it + must. Then [f] is declared in the global environment. *) let f_def = { f_def with Entries.const_entry_opaque = false } in let f_def = Entries.DefinitionEntry f_def , Decl_kinds.(IsDefinition Definition) in let f_kn = Declare.declare_constant f f_def in let f_kn_term = mkConst f_kn in - (** In the type and body of the proof of [suchthat] there can be - references to the variable [f]. It needs to be replaced by - references to the constant [f] declared above. This substitution - performs this precise action. *) + (* In the type and body of the proof of [suchthat] there can be + references to the variable [f]. It needs to be replaced by + references to the constant [f] declared above. This substitution + performs this precise action. *) let substf c = Vars.replace_vars [f,f_kn_term] c in - (** Extracts the type of the proof of [suchthat]. *) + (* Extracts the type of the proof of [suchthat]. *) let lemma_pretype = match Entries.(lemma_def.const_entry_type) with | Some t -> t | None -> assert false (* Proof_global always sets type here. *) in - (** The references of [f] are subsituted appropriately. *) + (* The references of [f] are subsituted appropriately. *) let lemma_type = substf lemma_pretype in - (** The same is done in the body of the proof. *) + (* The same is done in the body of the proof. *) let lemma_body = map_const_entry_body substf Entries.(lemma_def.const_entry_body) in @@ -105,7 +105,3 @@ let start_deriving f suchthat lemma = Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p end in () - - - - diff --git a/plugins/extraction/ExtrHaskellString.v b/plugins/extraction/ExtrHaskellString.v index a4a40d3c5a..8c61f4e96b 100644 --- a/plugins/extraction/ExtrHaskellString.v +++ b/plugins/extraction/ExtrHaskellString.v @@ -6,6 +6,7 @@ Require Coq.extraction.Extraction. Require Import Ascii. Require Import String. +Require Import Coq.Strings.Byte. (** * At the moment, Coq's extraction has no way to add extra import @@ -40,3 +41,22 @@ Extract Inlined Constant Ascii.eqb => "(Prelude.==)". Extract Inductive string => "Prelude.String" [ "([])" "(:)" ]. Extract Inlined Constant String.string_dec => "(Prelude.==)". Extract Inlined Constant String.eqb => "(Prelude.==)". + +(* python -c 'print(" ".join(r""" "%s" """.strip() % (r"'"'\''"'" if chr(i) == "'"'"'" else repr(""" "" """.strip()) if chr(i) == """ " """.strip() else repr(chr(i))) for i in range(256)))' # " to satisfy Coq's comment parser *) +Extract Inductive byte => "Prelude.Char" +["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'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'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'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'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. + +Extract Inlined Constant Byte.eqb => "(Prelude.==)". +Extract Inlined Constant Byte.byte_eq_dec => "(Prelude.==)". +Extract Inlined Constant Ascii.ascii_of_byte => "(\x -> x)". +Extract Inlined Constant Ascii.byte_of_ascii => "(\x -> x)". + +(* +Require Import ExtrHaskellBasic. +Definition test := "ceci est un test"%string. +Definition test2 := List.map (option_map Byte.to_nat) (List.map Byte.of_nat (List.seq 0 256)). +Definition test3 := List.map ascii_of_nat (List.seq 0 256). + +Extraction Language Haskell. +Recursive Extraction test Ascii.zero Ascii.one test2 test3 byte_rect. +*) diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v index a2a6a8fe67..f094d4860e 100644 --- a/plugins/extraction/ExtrOcamlString.v +++ b/plugins/extraction/ExtrOcamlString.v @@ -12,7 +12,7 @@ Require Coq.extraction.Extraction. -Require Import Ascii String. +Require Import Ascii String Coq.Strings.Byte. Extract Inductive ascii => char [ @@ -37,7 +37,19 @@ Extract Inlined Constant Ascii.eqb => "(=)". Extract Inductive string => "char list" [ "[]" "(::)" ]. +(* python -c 'print(" ".join(r""" "%s" """.strip() % (r"'"'\''"'" if chr(i) == "'"'"'" else repr(""" "" """.strip()) if chr(i) == """ " """.strip() else repr(chr(i))) for i in range(256)))' # " to satisfy Coq's comment parser *) +Extract Inductive byte => char +["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'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'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'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'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. + +Extract Inlined Constant Byte.eqb => "(=)". +Extract Inlined Constant Byte.byte_eq_dec => "(=)". +Extract Inlined Constant Ascii.ascii_of_byte => "(fun x -> x)". +Extract Inlined Constant Ascii.byte_of_ascii => "(fun x -> x)". + (* Definition test := "ceci est un test"%string. -Recursive Extraction test Ascii.zero Ascii.one. +Definition test2 := List.map (option_map Byte.to_nat) (List.map Byte.of_nat (List.seq 0 256)). +Definition test3 := List.map ascii_of_nat (List.seq 0 256). + +Recursive Extraction test Ascii.zero Ascii.one test2 test3 byte_rect. *) diff --git a/plugins/extraction/big.ml b/plugins/extraction/big.ml index 9c0f373c6a..c675eacc92 100644 --- a/plugins/extraction/big.ml +++ b/plugins/extraction/big.ml @@ -20,8 +20,10 @@ type big_int = Big_int.big_int let zero = zero_big_int (** The big integer [0]. *) + let one = unit_big_int (** The big integer [1]. *) + let two = big_int_of_int 2 (** The big integer [2]. *) @@ -29,28 +31,39 @@ let two = big_int_of_int 2 let opp = minus_big_int (** Unary negation. *) + let abs = abs_big_int (** Absolute value. *) + let add = add_big_int (** Addition. *) + let succ = succ_big_int (** Successor (add 1). *) + let add_int = add_int_big_int (** Addition of a small integer to a big integer. *) + let sub = sub_big_int (** Subtraction. *) + let pred = pred_big_int (** Predecessor (subtract 1). *) + let mult = mult_big_int (** Multiplication of two big integers. *) + let mult_int = mult_int_big_int (** Multiplication of a big integer by a small integer *) + let square = square_big_int (** Return the square of the given big integer *) + let sqrt = sqrt_big_int (** [sqrt_big_int a] returns the integer square root of [a], that is, the largest big integer [r] such that [r * r <= a]. Raise [Invalid_argument] if [a] is negative. *) + let quomod = quomod_big_int (** Euclidean division of two big integers. The first part of the result is the quotient, @@ -58,14 +71,18 @@ let quomod = quomod_big_int Writing [(q,r) = quomod_big_int a b], we have [a = q * b + r] and [0 <= r < |b|]. Raise [Division_by_zero] if the divisor is zero. *) + let div = div_big_int (** Euclidean quotient of two big integers. This is the first result [q] of [quomod_big_int] (see above). *) + let modulo = mod_big_int (** Euclidean modulus of two big integers. This is the second result [r] of [quomod_big_int] (see above). *) + let gcd = gcd_big_int (** Greatest common divisor of two big integers. *) + let power = power_big_int_positive_big_int (** Exponentiation functions. Return the big integer representing the first argument [a] raised to the power [b] @@ -78,18 +95,22 @@ let power = power_big_int_positive_big_int let sign = sign_big_int (** Return [0] if the given big integer is zero, [1] if it is positive, and [-1] if it is negative. *) + let compare = compare_big_int (** [compare_big_int a b] returns [0] if [a] and [b] are equal, [1] if [a] is greater than [b], and [-1] if [a] is smaller than [b]. *) + let eq = eq_big_int let le = le_big_int let ge = ge_big_int let lt = lt_big_int let gt = gt_big_int (** Usual boolean comparisons between two big integers. *) + let max = max_big_int (** Return the greater of its two arguments. *) + let min = min_big_int (** Return the smaller of its two arguments. *) @@ -98,6 +119,7 @@ let min = min_big_int let to_string = string_of_big_int (** Return the string representation of the given big integer, in decimal (base 10). *) + let of_string = big_int_of_string (** Convert a string to a big integer, in decimal. The string consists of an optional [-] or [+] sign, @@ -107,6 +129,7 @@ let of_string = big_int_of_string let of_int = big_int_of_int (** Convert a small integer to a big integer. *) + let is_int = is_int_big_int (** Test whether the given big integer is small enough to be representable as a small integer (type [int]) @@ -115,6 +138,7 @@ let is_int = is_int_big_int [a] is between 2{^30} and 2{^30}-1. On a 64-bit platform, [is_int_big_int a] returns [true] if and only if [a] is between -2{^62} and 2{^62}-1. *) + let to_int = int_of_big_int (** Convert a big integer to a small integer (type [int]). Raises [Failure "int_of_big_int"] if the big integer diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index bdeb6fca60..59c57cc544 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -125,7 +125,7 @@ module KOrd = struct type t = kind * string let compare (k1, s1) (k2, s2) = - let c = Pervasives.compare k1 k2 (** OK *) in + let c = Pervasives.compare k1 k2 (* OK *) in if c = 0 then String.compare s1 s2 else c end diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 16890ea260..2058837b8e 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -621,10 +621,9 @@ let lang_ref = Summary.ref Ocaml ~name:"ExtrLang" let lang () = !lang_ref let extr_lang : lang -> obj = - declare_object - {(default_object "Extraction Lang") with - cache_function = (fun (_,l) -> lang_ref := l); - load_function = (fun _ (_,l) -> lang_ref := l)} + declare_object @@ superglobal_object_nodischarge "Extraction Lang" + ~cache:(fun (_,l) -> lang_ref := l) + ~subst:None let extraction_language x = Lib.add_anonymous_leaf (extr_lang x) @@ -648,15 +647,10 @@ let add_inline_entries b l = (* Registration of operations for rollback. *) let inline_extraction : bool * GlobRef.t list -> obj = - declare_object - {(default_object "Extraction Inline") with - cache_function = (fun (_,(b,l)) -> add_inline_entries b l); - load_function = (fun _ (_,(b,l)) -> add_inline_entries b l); - classify_function = (fun o -> Substitute o); - discharge_function = (fun (_,x) -> Some x); - subst_function = - (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l))) - } + declare_object @@ superglobal_object "Extraction Inline" + ~cache:(fun (_,(b,l)) -> add_inline_entries b l) + ~subst:(Some (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l)))) + ~discharge:(fun (_,x) -> Some x) (* Grammar entries. *) @@ -685,10 +679,9 @@ let print_extraction_inline () = (* Reset part *) let reset_inline : unit -> obj = - declare_object - {(default_object "Reset Extraction Inline") with - cache_function = (fun (_,_)-> inline_table := empty_inline_table); - load_function = (fun _ (_,_)-> inline_table := empty_inline_table)} + declare_object @@ superglobal_object_nodischarge "Reset Extraction Inline" + ~cache:(fun (_,_)-> inline_table := empty_inline_table) + ~subst:None let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) @@ -731,13 +724,9 @@ let add_implicits r l = (* Registration of operations for rollback. *) let implicit_extraction : GlobRef.t * int_or_id list -> obj = - declare_object - {(default_object "Extraction Implicit") with - cache_function = (fun (_,(r,l)) -> add_implicits r l); - load_function = (fun _ (_,(r,l)) -> add_implicits r l); - classify_function = (fun o -> Substitute o); - subst_function = (fun (s,(r,l)) -> (fst (subst_global s r), l)) - } + declare_object @@ superglobal_object_nodischarge "Extraction Implicit" + ~cache:(fun (_,(r,l)) -> add_implicits r l) + ~subst:(Some (fun (s,(r,l)) -> (fst (subst_global s r), l))) (* Grammar entries. *) @@ -784,12 +773,9 @@ let add_blacklist_entries l = (* Registration of operations for rollback. *) let blacklist_extraction : string list -> obj = - declare_object - {(default_object "Extraction Blacklist") with - cache_function = (fun (_,l) -> add_blacklist_entries l); - load_function = (fun _ (_,l) -> add_blacklist_entries l); - subst_function = (fun (_,x) -> x) - } + declare_object @@ superglobal_object_nodischarge "Extraction Blacklist" + ~cache:(fun (_,l) -> add_blacklist_entries l) + ~subst:None (* Grammar entries. *) @@ -805,10 +791,9 @@ let print_extraction_blacklist () = (* Reset part *) let reset_blacklist : unit -> obj = - declare_object - {(default_object "Reset Extraction Blacklist") with - cache_function = (fun (_,_)-> blacklist_table := Id.Set.empty); - load_function = (fun _ (_,_)-> blacklist_table := Id.Set.empty)} + declare_object @@ superglobal_object_nodischarge "Reset Extraction Blacklist" + ~cache:(fun (_,_)-> blacklist_table := Id.Set.empty) + ~subst:None let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ()) @@ -852,23 +837,14 @@ let find_custom_match pv = (* Registration of operations for rollback. *) let in_customs : GlobRef.t * string list * string -> obj = - declare_object - {(default_object "ML extractions") with - cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s); - load_function = (fun _ (_,(r,ids,s)) -> add_custom r ids s); - classify_function = (fun o -> Substitute o); - subst_function = - (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str)) - } + declare_object @@ superglobal_object_nodischarge "ML extractions" + ~cache:(fun (_,(r,ids,s)) -> add_custom r ids s) + ~subst:(Some (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str))) let in_custom_matchs : GlobRef.t * string -> obj = - declare_object - {(default_object "ML extractions custom matchs") with - cache_function = (fun (_,(r,s)) -> add_custom_match r s); - load_function = (fun _ (_,(r,s)) -> add_custom_match r s); - classify_function = (fun o -> Substitute o); - subst_function = (fun (subs,(r,s)) -> (fst (subst_global subs r), s)) - } + declare_object @@ superglobal_object_nodischarge "ML extractions custom matchs" + ~cache:(fun (_,(r,s)) -> add_custom_match r s) + ~subst:(Some (fun (subs,(r,s)) -> (fst (subst_global subs r), s))) (* Grammar entries. *) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 4cdfc6fac5..12b68e208c 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -41,7 +41,7 @@ let pop t = Vars.lift (-1) t *) let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let princ_type = EConstr.of_constr princ_type in - let princ_type_info = compute_elim_sig Evd.empty princ_type (** FIXME *) in + let princ_type_info = compute_elim_sig Evd.empty princ_type (* FIXME *) in let env = Global.env () in let env_with_params = EConstr.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 19f954c10d..f9938c0356 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -237,7 +237,6 @@ let cache_Function (_,finfos) = from_graph := Indmap.add finfos.graph_ind finfos !from_graph -let load_Function _ = cache_Function let subst_Function (subst,finfos) = let do_subst_con c = Mod_subst.subst_constant subst c and do_subst_ind i = Mod_subst.subst_ind subst i @@ -271,9 +270,6 @@ let subst_Function (subst,finfos) = is_general = finfos.is_general } -let classify_Function infos = Libobject.Substitute infos - - let discharge_Function (_,finfos) = Some finfos let pr_ocst c = @@ -302,15 +298,11 @@ let pr_table tb = Pp.prlist_with_sep fnl pr_info l let in_Function : function_info -> Libobject.obj = - Libobject.declare_object - {(Libobject.default_object "FUNCTIONS_DB") with - Libobject.cache_function = cache_Function; - Libobject.load_function = load_Function; - Libobject.classify_function = classify_Function; - Libobject.subst_function = subst_Function; - Libobject.discharge_function = discharge_Function -(* Libobject.open_function = open_Function; *) - } + let open Libobject in + declare_object @@ superglobal_object "FUNCTIONS_DB" + ~cache:cache_Function + ~subst:(Some subst_Function) + ~discharge:discharge_Function let find_or_none id = @@ -500,7 +492,7 @@ type tcc_lemma_value = (* We only "purify" on exceptions. XXX: What is this doing here? *) let funind_purify f x = - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in try f x with e -> let e = CErrors.push e in diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 603dd60cf2..47f593ff3e 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -306,8 +306,8 @@ let add_rewrite_hint ~poly bases ort t lcsr = let ctx = let ctx = UState.context_set ctx in if poly then ctx - else (** This is a global universe context that shouldn't be - refreshed at every use of the hint, declare it globally. *) + else (* This is a global universe context that shouldn't be + refreshed at every use of the hint, declare it globally. *) (Declare.declare_universe_context false ctx; Univ.ContextSet.empty) in @@ -531,11 +531,9 @@ let cache_transitivity_lemma (_,(left,lem)) = let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) let inTransitivity : bool * Constr.t -> obj = - declare_object {(default_object "TRANSITIVITY-STEPS") with - cache_function = cache_transitivity_lemma; - open_function = (fun i o -> if Int.equal i 1 then cache_transitivity_lemma o); - subst_function = subst_transitivity_lemma; - classify_function = (fun o -> Substitute o) } + declare_object @@ global_object_nodischarge "TRANSITIVITY-STEPS" + ~cache:cache_transitivity_lemma + ~subst:(Some subst_transitivity_lemma) (* Main entry points *) @@ -738,7 +736,8 @@ let mkCaseEq a : unit Proofview.tactic = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in - (** FIXME: this looks really wrong. Does anybody really use this tactic? *) + (* FIXME: this looks really wrong. Does anybody really use + this tactic? *) let (_, c) = Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env (Evd.from_env env) concl in change_concl c end; diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index ef18dd6cdc..1ea6ff84d4 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -24,7 +24,7 @@ let (set_default_tactic, get_default_tactic, print_default_tactic) = Tactic_option.declare_tactic_option "Program tactic" let () = - (** Delay to recover the tactic imperatively *) + (* Delay to recover the tactic imperatively *) let tac = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> snd (get_default_tactic ()) end in diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 8bf1855fe0..5e3f4df192 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -229,8 +229,8 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_tacarg_using_rule pr_gen l = let l = match l with | TacTerm s :: l -> - (** First terminal token should be considered as the name of the tactic, - so we tag it differently than the other terminal tokens. *) + (* First terminal token should be considered as the name of the tactic, + so we tag it differently than the other terminal tokens. *) primitive s :: tacarg_using_rule_token pr_gen l | _ -> tacarg_using_rule_token pr_gen l in @@ -1174,7 +1174,7 @@ let pr_goal_selector ~toplevel s = pr_constant = pr_evaluable_reference_env env; pr_reference = pr_located pr_ltac_constant; pr_name = pr_id; - (** Those are not used by the atomic printer *) + (* Those are not used by the atomic printer *) pr_generic = (fun _ -> assert false); pr_extend = (fun _ _ _ -> assert false); pr_alias = (fun _ _ _ -> assert false); diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 06783de614..4bb52f599a 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -97,7 +97,7 @@ let goalevars evars = fst evars let cstrevars evars = snd evars let new_cstr_evar (evd,cstrs) env t = - (** We handle the typeclass resolution of constraints ourselves *) + (* We handle the typeclass resolution of constraints ourselves *) let (evd', t) = Evarutil.new_evar env evd ~typeclass_candidate:false t in let ev, _ = destEvar evd' t in (evd', Evar.Set.add ev cstrs), t @@ -474,7 +474,7 @@ let get_symmetric_proof b = 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 *) + (* Head normalize for compatibility with the old meta mechanism *) let t = Reductionops.whd_betaiota evd t in match EConstr.kind evd t with | App (f, [||]) -> assert false @@ -613,7 +613,7 @@ let solve_remaining_by env sigma holes by = Some evk | _ -> None in - (** Only solve independent holes *) + (* Only solve independent holes *) let indep = List.map_filter map holes in let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in let solve_tac = match tac with @@ -628,11 +628,12 @@ let solve_remaining_by env sigma holes by = in match evi with | None -> sigma - (** Evar should not be defined, but just in case *) + (* Evar should not be defined, but just in case *) | Some evi -> let env = Environ.reset_with_named_context evi.evar_hyps env in let ty = evi.evar_concl in - let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in + let name, poly = Id.of_string "rewrite", false in + let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma ty solve_tac in Evd.define evk (EConstr.of_constr c) sigma in List.fold_left solve sigma indep @@ -646,6 +647,7 @@ let poly_inverse sort = type rewrite_proof = | RewPrf of constr * constr (** A Relation (R : rew_car -> rew_car -> Prop) and a proof of R rew_from rew_to *) + | RewCast of cast_kind (** A proof of convertibility (with casts) *) @@ -1561,7 +1563,7 @@ let newfail n s = let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in - (** For compatibility *) + (* For compatibility *) let beta = Tactics.reduct_in_concl (Reductionops.nf_betaiota, DEFAULTcast) in let beta_hyp id = Tactics.reduct_in_hyp Reductionops.nf_betaiota (id, InHyp) in let treat sigma res = @@ -1611,7 +1613,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let env = match clause with | None -> env | Some id -> - (** Only consider variables not depending on [id] *) + (* Only consider variables not depending on [id] *) let ctx = named_context env in let filter decl = not (occur_var_in_decl env sigma id decl) in let nctx = List.filter filter ctx in @@ -1623,7 +1625,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = in let sigma = match origsigma with None -> sigma | Some sigma -> sigma in treat sigma res <*> - (** For compatibility *) + (* For compatibility *) beta <*> Proofview.shelve_unifiable with | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) -> diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 2aee809eb6..b770b97384 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -169,7 +169,7 @@ let add_tactic_entry (kn, ml, tg) state = let entry, pos = get_tactic_entry tg.tacgram_level in let mkact loc l = let map arg = - (** HACK to handle especially the tactic(...) entry *) + (* HACK to handle especially the tactic(...) entry *) let wit = Genarg.rawwit Tacarg.wit_tactic in if Genarg.has_type arg wit && not ml then Tacexp (Genarg.out_gen wit arg) @@ -223,7 +223,7 @@ let interp_prod_item = function | Some arg -> arg end | Some n -> - (** FIXME: do better someday *) + (* FIXME: do better someday *) assert (String.equal s "tactic"); begin match Tacarg.wit_tactic with | ExtraArg tag -> ArgT.Any tag @@ -241,9 +241,9 @@ let make_fresh_key = | TacNonTerm _ -> "#" in let prods = String.concat "_" (List.map map prods) in - (** We embed the hash of the kernel name in the label so that the identifier - should be mostly unique. This ensures that including two modules - together won't confuse the corresponding labels. *) + (* We embed the hash of the kernel name in the label so that the identifier + should be mostly unique. This ensures that including two modules + together won't confuse the corresponding labels. *) let hash = (cur lxor (ModPath.hash (Lib.current_mp ()))) land 0x7FFFFFFF in let lbl = Id.of_string_soft (Printf.sprintf "%s_%08X" prods hash) in Lib.make_kn lbl @@ -281,7 +281,7 @@ let open_tactic_notation i (_, tobj) = let load_tactic_notation i (_, tobj) = let key = tobj.tacobj_key in let () = check_key key in - (** Only add the printing and interpretation rules. *) + (* Only add the printing and interpretation rules. *) Tacenv.register_alias key tobj.tacobj_body; Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram); if Int.equal i 1 && not tobj.tacobj_local then @@ -342,7 +342,7 @@ let extend_atomic_tactic name entries = let map_prod prods = let (hd, rem) = match prods with | TacTerm s :: rem -> (s, rem) - | _ -> assert false (** Not handled by the ML extension syntax *) + | _ -> assert false (* Not handled by the ML extension syntax *) in let empty_value = function | TacTerm s -> raise NonEmptyArgument @@ -383,8 +383,8 @@ let add_ml_tactic_notation name ~level ?deprecation prods = add_glob_tactic_notation false ~level ?deprecation prods true ids tac in List.iteri iter (List.rev prods); - (** We call [extend_atomic_tactic] only for "basic tactics" (the ones at - tactic_expr level 0) *) + (* We call [extend_atomic_tactic] only for "basic tactics" (the ones + at tactic_expr level 0) *) if Int.equal level 0 then extend_atomic_tactic name prods (**********************************************************************) @@ -474,8 +474,9 @@ let register_ltac local ?deprecation tacl = (name, body) in let defs () = - (** Register locally the tactic to handle recursivity. This function affects - the whole environment, so that we transactify it afterwards. *) + (* Register locally the tactic to handle recursivity. This + function affects the whole environment, so that we transactify + it afterwards. *) let iter_rec (sp, kn) = Tacenv.push_tactic (Nametab.Until 1) sp kn in let () = List.iter iter_rec recvars in List.map map rfun @@ -557,7 +558,7 @@ let () = register_grammars_by_name "tactic" entries let get_identifier i = - (** Workaround for badly-designed generic arguments lacking a closure *) + (* Workaround for badly-designed generic arguments lacking a closure *) Names.Id.of_string_soft (Printf.sprintf "$%i" i) type _ ty_sig = @@ -650,20 +651,22 @@ let tactic_extend plugin_name tacname ~level ?deprecation sign = in match sign with | [TyML (TyIdent (name, s),tac) as ml_tac] when only_constr s -> - (** The extension is only made of a name followed by constr entries: we do not - add any grammar nor printing rule and add it as a true Ltac definition. *) + (* The extension is only made of a name followed by constr + entries: we do not add any grammar nor printing rule and add it + as a true Ltac definition. *) let vars = mk_sign_vars 1 s in let ml = { Tacexpr.mltac_name = ml_tactic_name; Tacexpr.mltac_index = 0 } in let tac = match s with | TyNil -> eval ml_tac - (** Special handling of tactics without arguments: such tactics do not do - a Proofview.Goal.nf_enter to compute their arguments. It matters for some - whole-prof tactics like [shelve_unifiable]. *) + (* Special handling of tactics without arguments: such tactics do + not do a Proofview.Goal.nf_enter to compute their arguments. It + matters for some whole-prof tactics like [shelve_unifiable]. *) | _ -> lift_constr_tac_to_ml_tac vars (eval ml_tac) in - (** 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. *) + (* 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 = Tacexpr.TacFun (vars, Tacexpr.TacML (CAst.make (ml, [])))in let id = Names.Id.of_string name in let obj () = Tacenv.register_ltac true false id body ?deprecation in diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index b99f956ce0..30e316b36d 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -78,12 +78,12 @@ type ('a,'t) match_rule = (** Extension indentifiers for the TACTIC EXTEND mechanism. *) type ml_tactic_name = { + mltac_plugin : string; (** Name of the plugin where the tactic is defined, typically coming from a DECLARE PLUGIN statement in the source. *) - mltac_plugin : string; + mltac_tactic : string; (** Name of the tactic entry where the tactic is defined, typically found after the TACTIC EXTEND statement in the source. *) - mltac_tactic : string; } type ml_tactic_entry = { diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index bd080bf4f0..8b6b14322b 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -78,12 +78,12 @@ type ('a,'t) match_rule = (** Extension indentifiers for the TACTIC EXTEND mechanism. *) type ml_tactic_name = { + mltac_plugin : string; (** Name of the plugin where the tactic is defined, typically coming from a DECLARE PLUGIN statement in the source. *) - mltac_plugin : string; + mltac_tactic : string; (** Name of the tactic entry where the tactic is defined, typically found after the TACTIC EXTEND statement in the source. *) - mltac_tactic : string; } type ml_tactic_entry = { diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 85c6348b52..a1e21aab04 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -843,8 +843,9 @@ let notation_subst bindings tac = (make ?loc @@ Name id, c) :: accu in let bindings = Id.Map.fold fold bindings [] in - (** This is theoretically not correct due to potential variable capture, but - Ltac has no true variables so one cannot simply substitute *) + (* This is theoretically not correct due to potential variable + capture, but Ltac has no true variables so one cannot simply + substitute *) TacLetIn (false, bindings, tac) let () = Genintern.register_ntn_subst0 wit_tactic notation_subst diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index cf5eb442be..816741b894 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -50,7 +50,7 @@ let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v w let Val.Dyn (t, _) = v in let t' = match val_tag wit with | Val.Base t' -> t' - | _ -> assert false (** not used in this module *) + | _ -> assert false (* not used in this module *) in match Val.eq t t' with | None -> false @@ -68,13 +68,13 @@ let in_list tag v = let in_gen wit v = let t = match val_tag wit with | Val.Base t -> t - | _ -> assert false (** not used in this module *) + | _ -> assert false (* not used in this module *) in Val.Dyn (t, v) let out_gen wit v = let t = match val_tag wit with | Val.Base t -> t - | _ -> assert false (** not used in this module *) + | _ -> assert false (* not used in this module *) in match prj t v with None -> assert false | Some x -> x @@ -585,8 +585,8 @@ let interp_pure_open_constr ist = let interp_typed_pattern ist env sigma (_,c,_) = let sigma, c = interp_gen WithoutTypeConstraint ist true pure_open_constr_flags env sigma c in - (** FIXME: it is necessary to be unsafe here because of the way we handle - evars in the pretyper. Sometimes they get solved eagerly. *) + (* FIXME: it is necessary to be unsafe here because of the way we handle + evars in the pretyper. Sometimes they get solved eagerly. *) pattern_of_constr env sigma (EConstr.Unsafe.to_constr c) (* Interprets a constr expression *) @@ -897,7 +897,7 @@ let interp_destruction_arg ist gl arg = end) in try - (** FIXME: should be moved to taccoerce *) + (* FIXME: should be moved to taccoerce *) let v = Id.Map.find id ist.lfun in if has_type v (topwit wit_intro_pattern) then let v = out_gen (topwit wit_intro_pattern) v in @@ -1020,7 +1020,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr | TacArg {loc;v} -> interp_tacarg ist v | t -> - (** Delayed evaluation *) + (* Delayed evaluation *) Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t))) in let open Ftactic in @@ -1396,12 +1396,12 @@ and interp_match_successes lz ist s = general | Select -> begin - (** Only keep the first matching result, we don't backtrack on it *) + (* Only keep the first matching result, we don't backtrack on it *) let s = Proofview.tclONCE s in s >>= fun ans -> interp_match_success ist ans end | Once -> - (** Once a tactic has succeeded, do not backtrack anymore *) + (* Once a tactic has succeeded, do not backtrack anymore *) Proofview.tclONCE general (* Interprets the Match expressions *) @@ -1438,7 +1438,7 @@ and interp_match_goal ist lz lr lmr = (* Interprets extended tactic generic arguments *) and interp_genarg ist x : Val.t Ftactic.t = let open Ftactic.Notations in - (** Ad-hoc handling of some types. *) + (* Ad-hoc handling of some types. *) let tag = genarg_tag x in if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then interp_genarg_var_list ist x @@ -2031,7 +2031,8 @@ let _ = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in let ist = { lfun = lfun; extra; } in let tac = interp_tactic ist tac in - let (c, sigma) = Pfedit.refine_by_tactic env sigma ty tac in + let name, poly = Id.of_string "ltac_sub", false in + let (c, sigma) = Pfedit.refine_by_tactic ~name ~poly env sigma ty tac in (EConstr.of_constr c, sigma) in GlobEnv.register_constr_interp0 wit_tactic eval diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index c949589e22..54924f1644 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -59,7 +59,7 @@ let id_map_try_add_name id x m = the binding of the right-hand argument shadows that of the left-hand argument. *) let id_map_right_biased_union m1 m2 = - if Id.Map.is_empty m1 then m2 (** Don't reconstruct the whole map *) + if Id.Map.is_empty m1 then m2 (* Don't reconstruct the whole map *) else Id.Map.fold Id.Map.add m2 m1 (** Tests whether the substitution [s] is empty. *) @@ -102,7 +102,7 @@ let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) = else raise Not_coherent_metas in let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 in - (** ppedrot: Is that even correct? *) + (* ppedrot: Is that even correct? *) let merged = ln +++ ln1 in (merged, Id.Map.merge merge lcm lm) @@ -263,8 +263,8 @@ module PatternMatching (E:StaticEnvironment) = struct | All lhs -> wildcard_match_term lhs | Pat ([],pat,lhs) -> pattern_match_term false pat term lhs | Pat _ -> - (** Rules with hypotheses, only work in match goal. *) - fail + (* Rules with hypotheses, only work in match goal. *) + fail (** [match_term term rules] matches the term [term] with the set of matching rules [rules].*) diff --git a/plugins/micromega/itv.ml b/plugins/micromega/itv.ml index dc1df7ec9f..44cad820ed 100644 --- a/plugins/micromega/itv.ml +++ b/plugins/micromega/itv.ml @@ -11,10 +11,11 @@ (** Intervals (extracted from mfourier.ml) *) open Num + (** The type of intervals is *) type interval = num option * num option - (** None models the absence of bound i.e. infinity *) - (** As a result, + (** None models the absence of bound i.e. infinity + As a result, - None , None -> \]-oo,+oo\[ - None , Some v -> \]-oo,v\] - Some v, None -> \[v,+oo\[ diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index f5e9a9f34c..23f3470d77 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -103,7 +103,7 @@ module Poly : sig end -type cstr = {coeffs : Vect.t ; op : op ; cst : Num.num} (** Representation of linear constraints *) +type cstr = {coeffs : Vect.t ; op : op ; cst : Num.num} (* Representation of linear constraints *) and op = Eq | Ge | Gt val eval_op : op -> Num.num -> Num.num -> bool diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index 8d8c6ea90b..4465aa1ee1 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -20,6 +20,7 @@ type iset = unit IMap.t type tableau = Vect.t IMap.t (** Mapping basic variables to their equation. All variables >= than a threshold rst are restricted.*) + module Restricted = struct type t = diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml index f8fc943713..1825a4d77c 100644 --- a/plugins/nsatz/ideal.ml +++ b/plugins/nsatz/ideal.ml @@ -609,7 +609,7 @@ type current_problem = { exception NotInIdealUpdate of current_problem let test_dans_ideal cur_pb table metadata p lp len0 = - (** Invariant: [lp] is [List.tl (Array.to_list table.allpol)] *) + (* Invariant: [lp] is [List.tl (Array.to_list table.allpol)] *) let (c,r) = reduce2 table cur_pb.cur_poly lp in info (fun () -> "remainder: "^(stringPcut metadata r)); let cur_pb = { @@ -657,7 +657,7 @@ let deg_hom p = | (a,m)::_ -> Monomial.deg m let pbuchf table metadata cur_pb homogeneous (lp, lpc) p = - (** Invariant: [lp] is [List.tl (Array.to_list table.allpol)] *) + (* Invariant: [lp] is [List.tl (Array.to_list table.allpol)] *) sinfo "computation of the Groebner basis"; let () = match table.hmon with | None -> () diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index ef60a23e80..1777418ef6 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -374,7 +374,7 @@ let remove_zeros lci = let m = List.length lci in let u = Array.make m false in let rec utiles k = - (** TODO: Find a more reasonable implementation of this traversal. *) + (* TODO: Find a more reasonable implementation of this traversal. *) if k >= m || u.(k) then () else let () = u.(k) <- true in diff --git a/plugins/rtauto/g_rtauto.mlg b/plugins/rtauto/g_rtauto.mlg index 9c9fdcfa2f..d8724eb976 100644 --- a/plugins/rtauto/g_rtauto.mlg +++ b/plugins/rtauto/g_rtauto.mlg @@ -17,6 +17,6 @@ open Ltac_plugin DECLARE PLUGIN "rtauto_plugin" TACTIC EXTEND rtauto -| [ "rtauto" ] -> { Proofview.V82.tactic (Refl_tauto.rtauto_tac) } +| [ "rtauto" ] -> { Refl_tauto.rtauto_tac } END diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index e66fa10d5b..a6b6c57ff9 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -16,7 +16,6 @@ open CErrors open Util open Term open Constr -open Tacmach open Proof_search open Context.Named.Declaration @@ -60,12 +59,11 @@ let l_I_Or_r = gen_constant "plugins.rtauto.I_Or_r" let l_E_Or = gen_constant "plugins.rtauto.E_Or" let l_D_Or = gen_constant "plugins.rtauto.D_Or" +let special_whd env sigma c = + Reductionops.clos_whd_flags CClosure.all env sigma c -let special_whd gl c = - Reductionops.clos_whd_flags CClosure.all (pf_env gl) (Tacmach.project gl) c - -let special_nf gl c = - Reductionops.clos_norm_flags CClosure.betaiotazeta (pf_env gl) (Tacmach.project gl) c +let special_nf env sigma c = + Reductionops.clos_norm_flags CClosure.betaiotazeta env sigma c type atom_env= {mutable next:int; @@ -83,61 +81,58 @@ let make_atom atom_env term= atom_env.next<- i + 1; Atom i -let rec make_form atom_env gls term = +let rec make_form env sigma atom_env term = let open EConstr in let open Vars in - let normalize=special_nf gls in - let cciterm=special_whd gls term in - let sigma = Tacmach.project gls in - match EConstr.kind sigma cciterm with - Prod(_,a,b) -> - if noccurn sigma 1 b && - Retyping.get_sort_family_of - (pf_env gls) sigma a == InProp - then - let fa=make_form atom_env gls a in - let fb=make_form atom_env gls b in - Arrow (fa,fb) - else - make_atom atom_env (normalize term) - | Cast(a,_,_) -> - make_form atom_env gls a - | Ind (ind, _) -> - if Names.eq_ind ind (fst (Lazy.force li_False)) then - Bot - else - make_atom atom_env (normalize term) - | App(hd,argv) when Int.equal (Array.length argv) 2 -> - begin - try - let ind, _ = destInd sigma hd in - if Names.eq_ind ind (fst (Lazy.force li_and)) then - let fa=make_form atom_env gls argv.(0) in - let fb=make_form atom_env gls argv.(1) in - Conjunct (fa,fb) - else if Names.eq_ind ind (fst (Lazy.force li_or)) then - let fa=make_form atom_env gls argv.(0) in - let fb=make_form atom_env gls argv.(1) in - Disjunct (fa,fb) - else make_atom atom_env (normalize term) - with DestKO -> make_atom atom_env (normalize term) - end - | _ -> make_atom atom_env (normalize term) - -let rec make_hyps atom_env gls lenv = function + let normalize = special_nf env sigma in + let cciterm = special_whd env sigma term in + match EConstr.kind sigma cciterm with + Prod(_,a,b) -> + if noccurn sigma 1 b && + Retyping.get_sort_family_of env sigma a == InProp + then + let fa = make_form env sigma atom_env a in + let fb = make_form env sigma atom_env b in + Arrow (fa,fb) + else + make_atom atom_env (normalize term) + | Cast(a,_,_) -> + make_form env sigma atom_env a + | Ind (ind, _) -> + if Names.eq_ind ind (fst (Lazy.force li_False)) then + Bot + else + make_atom atom_env (normalize term) + | App(hd,argv) when Int.equal (Array.length argv) 2 -> + begin + try + let ind, _ = destInd sigma hd in + if Names.eq_ind ind (fst (Lazy.force li_and)) then + let fa = make_form env sigma atom_env argv.(0) in + let fb = make_form env sigma atom_env argv.(1) in + Conjunct (fa,fb) + else if Names.eq_ind ind (fst (Lazy.force li_or)) then + let fa = make_form env sigma atom_env argv.(0) in + let fb = make_form env sigma atom_env argv.(1) in + Disjunct (fa,fb) + else make_atom atom_env (normalize term) + with DestKO -> make_atom atom_env (normalize term) + end + | _ -> make_atom atom_env (normalize term) + +let rec make_hyps env sigma atom_env lenv = function [] -> [] | LocalDef (_,body,typ)::rest -> - make_hyps atom_env gls (typ::body::lenv) rest + make_hyps env sigma atom_env (typ::body::lenv) rest | LocalAssum (id,typ)::rest -> - let hrec= - make_hyps atom_env gls (typ::lenv) rest in - if List.exists (fun c -> Termops.local_occur_var Evd.empty (** FIXME *) id c) lenv || - (Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) typ != InProp) - then - hrec - else - (id,make_form atom_env gls typ)::hrec + let hrec= + make_hyps env sigma atom_env (typ::lenv) rest in + if List.exists (fun c -> Termops.local_occur_var Evd.empty (* FIXME *) id c) lenv || + (Retyping.get_sort_family_of env sigma typ != InProp) + then + hrec + else + (id,make_form env sigma atom_env typ)::hrec let rec build_pos n = if n<=1 then force node_count l_xH @@ -251,73 +246,76 @@ let () = declare_bool_option opt_check open Pp -let rtauto_tac gls= - Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"]; - let gamma={next=1;env=[]} in - let gl=pf_concl gls in - let () = - if Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) gl != InProp - then user_err ~hdr:"rtauto" (Pp.str "goal should be in Prop") in - let glf=make_form gamma gls gl in - let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in - let formula= - List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in - let search_fun = match Tacinterp.get_debug() with - | Tactic_debug.DebugOn 0 -> Search.debug_depth_first - | _ -> Search.depth_first - in - let () = - begin - reset_info (); +let rtauto_tac = + Proofview.Goal.enter begin fun gl -> + let hyps = Proofview.Goal.hyps gl in + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"]; + let gamma={next=1;env=[]} in + let () = + if Retyping.get_sort_family_of env sigma concl != InProp + then user_err ~hdr:"rtauto" (Pp.str "goal should be in Prop") in + let glf = make_form env sigma gamma concl in + let hyps = make_hyps env sigma gamma [concl] hyps in + let formula= + List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in + let search_fun = match Tacinterp.get_debug() with + | Tactic_debug.DebugOn 0 -> Search.debug_depth_first + | _ -> Search.depth_first + in + let () = + begin + reset_info (); + if !verbose then + Feedback.msg_info (str "Starting proof-search ..."); + end in + let search_start_time = System.get_time () in + let prf = + try project (search_fun (init_state [] formula)) + with Not_found -> + user_err ~hdr:"rtauto" (Pp.str "rtauto couldn't find any proof") in + let search_end_time = System.get_time () in + let () = if !verbose then + begin + Feedback.msg_info (str "Proof tree found in " ++ + System.fmt_time_difference search_start_time search_end_time); + pp_info (); + Feedback.msg_info (str "Building proof term ... ") + end in + let build_start_time=System.get_time () in + let () = step_count := 0; node_count := 0 in + let main = mkApp (force node_count l_Reflect, + [|build_env gamma; + build_form formula; + build_proof [] 0 prf|]) in + let term= + applistc main (List.rev_map (fun (id,_) -> mkVar id) hyps) in + let build_end_time=System.get_time () in + let () = if !verbose then + begin + Feedback.msg_info (str "Proof term built in " ++ + System.fmt_time_difference build_start_time build_end_time ++ + fnl () ++ + str "Proof size : " ++ int !step_count ++ + str " steps" ++ fnl () ++ + str "Proof term size : " ++ int (!step_count+ !node_count) ++ + str " nodes (constants)" ++ fnl () ++ + str "Giving proof term to Coq ... ") + end in + let tac_start_time = System.get_time () in + let term = EConstr.of_constr term in + let result= + if !check then + Tactics.exact_check term + else + Tactics.exact_no_check term in + let tac_end_time = System.get_time () in + let () = + if !check then Feedback.msg_info (str "Proof term type-checking is on"); if !verbose then - Feedback.msg_info (str "Starting proof-search ..."); - end in - let search_start_time = System.get_time () in - let prf = - try project (search_fun (init_state [] formula)) - with Not_found -> - user_err ~hdr:"rtauto" (Pp.str "rtauto couldn't find any proof") in - let search_end_time = System.get_time () in - let () = if !verbose then - begin - Feedback.msg_info (str "Proof tree found in " ++ - System.fmt_time_difference search_start_time search_end_time); - pp_info (); - Feedback.msg_info (str "Building proof term ... ") - end in - let build_start_time=System.get_time () in - let () = step_count := 0; node_count := 0 in - let main = mkApp (force node_count l_Reflect, - [|build_env gamma; - build_form formula; - build_proof [] 0 prf|]) in - let term= - applistc main (List.rev_map (fun (id,_) -> mkVar id) hyps) in - let build_end_time=System.get_time () in - let () = if !verbose then - begin - Feedback.msg_info (str "Proof term built in " ++ - System.fmt_time_difference build_start_time build_end_time ++ - fnl () ++ - str "Proof size : " ++ int !step_count ++ - str " steps" ++ fnl () ++ - str "Proof term size : " ++ int (!step_count+ !node_count) ++ - str " nodes (constants)" ++ fnl () ++ - str "Giving proof term to Coq ... ") - end in - let tac_start_time = System.get_time () in - let term = EConstr.of_constr term in - let result= - if !check then - Proofview.V82.of_tactic (Tactics.exact_check term) gls - else - Proofview.V82.of_tactic (Tactics.exact_no_check term) gls in - let tac_end_time = System.get_time () in - let () = - if !check then Feedback.msg_info (str "Proof term type-checking is on"); - if !verbose then - Feedback.msg_info (str "Internal tactic executed in " ++ - System.fmt_time_difference tac_start_time tac_end_time) in + Feedback.msg_info (str "Internal tactic executed in " ++ + System.fmt_time_difference tac_start_time tac_end_time) in result - + end diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli index a91dd666a6..49b5ee5ac7 100644 --- a/plugins/rtauto/refl_tauto.mli +++ b/plugins/rtauto/refl_tauto.mli @@ -14,14 +14,15 @@ type atom_env= {mutable next:int; mutable env:(Constr.t*int) list} -val make_form : atom_env -> - Goal.goal Evd.sigma -> EConstr.types -> Proof_search.form +val make_form + : Environ.env -> Evd.evar_map -> atom_env + -> EConstr.types -> Proof_search.form -val make_hyps : - atom_env -> - Goal.goal Evd.sigma -> - EConstr.types list -> - EConstr.named_context -> - (Names.Id.t * Proof_search.form) list +val make_hyps + : Environ.env -> Evd.evar_map + -> atom_env + -> EConstr.types list + -> EConstr.named_context + -> (Names.Id.t * Proof_search.form) list -val rtauto_tac : Tacmach.tactic +val rtauto_tac : unit Proofview.tactic diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 4109e9cf38..65201d922f 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -194,12 +194,12 @@ let exec_tactic env evd n f args = in let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in - (** Build the getter *) + (* 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 (CAst.make (get_res, [TacGeneric n])) in let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in - (** Evaluate the whole result *) + (* Evaluate the whole result *) let gl = dummy_goal env evd in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in let evd = Evd.minimize_universes (Refiner.project gls) in @@ -394,13 +394,9 @@ let subst_th (subst,th) = let theory_to_obj : ring_info -> obj = let cache_th (name,th) = add_entry name th in - declare_object - {(default_object "tactic-new-ring-theory") with - open_function = (fun i o -> if Int.equal i 1 then cache_th o); - cache_function = cache_th; - subst_function = subst_th; - classify_function = (fun x -> Substitute x)} - + declare_object @@ global_object_nodischarge "tactic-new-ring-theory" + ~cache:cache_th + ~subst:(Some subst_th) let setoid_of_relation env evd a r = try @@ -891,12 +887,9 @@ let subst_th (subst,th) = let ftheory_to_obj : field_info -> obj = let cache_th (name,th) = add_field_entry name th in - declare_object - {(default_object "tactic-new-field-theory") with - open_function = (fun i o -> if Int.equal i 1 then cache_th o); - cache_function = cache_th; - subst_function = subst_th; - classify_function = (fun x -> Substitute x) } + declare_object @@ global_object_nodischarge "tactic-new-field-theory" + ~cache:cache_th + ~subst:(Some subst_th) let field_equality evd r inv req = match EConstr.kind !evd req with diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index bb8a0faf2e..11e282e4f5 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -104,6 +104,7 @@ type ssrintrosarg = Tacexpr.raw_tactic_expr * ssripats type ssrfwdid = Id.t + (** Binders (for fwd tactics) *) type 'term ssrbind = | Bvar of Name.t diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index efc4a2c743..cd9af84ed9 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -263,7 +263,7 @@ let of_ftactic ftac gl = let tac = Proofview.V82.of_tactic tac in let { sigma = sigma } = tac gl in let ans = match !r with - | None -> assert false (** If the tactic failed we should not reach this point *) + | None -> assert false (* If the tactic failed we should not reach this point *) | Some ans -> ans in (sigma, ans) diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 0553260472..18b4aeab1e 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -86,9 +86,9 @@ end (* }}} *************************************************************** *) open State -(** [=> *] ****************************************************************) -(** [nb_assums] returns the number of dependent premises *) -(** Warning: unlike [nb_deps_assums], it does not perform reduction *) +(***[=> *] ****************************************************************) +(** [nb_assums] returns the number of dependent premises + Warning: unlike [nb_deps_assums], it does not perform reduction *) let rec nb_assums cur env sigma t = match EConstr.kind sigma t with | Prod(name,ty,body) -> @@ -148,7 +148,7 @@ let tac_case t = Ssrelim.ssrscasetac t end -(** [=> [: id]] ************************************************************) +(***[=> [: id]] ************************************************************) [@@@ocaml.warning "-3"] let mk_abstract_id = let open Coqlib in diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 4ed75cdbe4..191a4e9a20 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -359,7 +359,7 @@ let coerce_search_pattern_to_sort hpat = Pattern.PApp (fp, args') in let hr, na = splay_search_pattern 0 hpat in let dc, ht = - let hr, _ = Typeops.type_of_global_in_context env hr (** FIXME *) in + let hr, _ = Typeops.type_of_global_in_context env hr (* FIXME *) in Reductionops.splay_prod env sigma (EConstr.of_constr hr) in let np = List.length dc in if np < na then CErrors.user_err (Pp.str "too many arguments in head search pattern") else diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 3f974ea063..1aa64d7141 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -45,16 +45,11 @@ module AdaptorDb = struct let t' = Detyping.subst_glob_constr subst t in if t' == t then a else k, t' - let classify_adaptor x = Libobject.Substitute x - let in_db = - Libobject.declare_object { - (Libobject.default_object "VIEW_ADAPTOR_DB") - with - Libobject.open_function = (fun i o -> if i = 1 then cache_adaptor o); - Libobject.cache_function = cache_adaptor; - Libobject.subst_function = subst_adaptor; - Libobject.classify_function = classify_adaptor } + let open Libobject in + declare_object @@ global_object_nodischarge "VIEW_ADAPTOR_DB" + ~cache:cache_adaptor + ~subst:(Some subst_adaptor) let declare kind terms = List.iter (fun term -> Lib.add_anonymous_leaf (in_db (kind,term))) diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 6497b6ff98..efd65ade15 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -122,6 +122,7 @@ let add_genarg tag pr = (** Constructors for cast type *) let dC t = CastConv t + (** Constructors for constr_expr *) let isCVar = function { CAst.v = CRef (qid,_) } -> qualid_is_ident qid | _ -> false let destCVar = function @@ -139,6 +140,7 @@ let mkCLambda ?loc name ty t = CAst.make ?loc @@ let mkCLetIn ?loc name bo t = CAst.make ?loc @@ CLetIn ((CAst.make ?loc name), bo, None, t) let mkCCast ?loc t ty = CAst.make ?loc @@ CCast (t, dC ty) + (** Constructors for rawconstr *) let mkRHole = DAst.make @@ GHole (InternalHole, IntroAnonymous, None) let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) @@ -925,7 +927,7 @@ let of_ftactic ftac gl = let tac = Proofview.V82.of_tactic tac in let { sigma = sigma } = tac gl in let ans = match !r with - | None -> assert false (** If the tactic failed we should not reach this point *) + | None -> assert false (* If the tactic failed we should not reach this point *) | Some ans -> ans in (sigma, ans) diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 8672c55767..f0bb6f58a6 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -194,6 +194,7 @@ val cpattern_of_term : char * glob_constr_and_expr -> Geninterp.interp_sign -> c (** [do_once r f] calls [f] and updates the ref only once *) val do_once : 'a option ref -> (unit -> 'a) -> unit + (** [assert_done r] return the content of r. @raise Anomaly is r is [None] *) val assert_done : 'a option ref -> 'a diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml deleted file mode 100644 index 94255bab6c..0000000000 --- a/plugins/syntax/ascii_syntax.ml +++ /dev/null @@ -1,100 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - - -(* Poor's man DECLARE PLUGIN *) -let __coq_plugin_name = "ascii_syntax_plugin" -let () = Mltop.add_known_module __coq_plugin_name - -open Pp -open CErrors -open Util -open Names -open Glob_term -open Globnames -open Coqlib - -exception Non_closed_ascii - -let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) - -let is_gr c gr = match DAst.get c with -| GRef (r, _) -> GlobRef.equal r gr -| _ -> false - -let ascii_module = ["Coq";"Strings";"Ascii"] -let ascii_modpath = MPfile (make_dir ascii_module) - -let ascii_path = make_path ascii_module "ascii" - -let ascii_label = Label.make "ascii" -let ascii_kn = MutInd.make2 ascii_modpath ascii_label -let path_of_Ascii = ((ascii_kn,0),1) -let static_glob_Ascii = ConstructRef path_of_Ascii - -let glob_Ascii = lazy (lib_ref "plugins.syntax.Ascii") - -open Lazy - -let interp_ascii ?loc p = - let rec aux n p = - if Int.equal n 0 then [] else - let mp = p mod 2 in - (DAst.make ?loc @@ GRef (lib_ref (if Int.equal mp 0 then "core.bool.false" else "core.bool.true"),None)) - :: (aux (n-1) (p/2)) in - DAst.make ?loc @@ GApp (DAst.make ?loc @@ GRef(force glob_Ascii,None), aux 8 p) - -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 ~hdr:"interp_ascii_string" - (str "Expects a single character or a three-digits ascii code.") in - interp_ascii ?loc p - -let uninterp_ascii r = - let rec uninterp_bool_list n = function - | [] when Int.equal n 0 -> 0 - | r::l when is_gr r (lib_ref "core.bool.true") -> 1+2*(uninterp_bool_list (n-1) l) - | r::l when is_gr r (lib_ref "core.bool.false") -> 2*(uninterp_bool_list (n-1) l) - | _ -> raise Non_closed_ascii in - try - let aux c = match DAst.get c with - | GApp (r, l) when is_gr r (force glob_Ascii) -> uninterp_bool_list 8 l - | _ -> raise Non_closed_ascii in - Some (aux r) - with - Non_closed_ascii -> None - -let make_ascii_string n = - if n>=32 && n<=126 then String.make 1 (char_of_int n) - else Printf.sprintf "%03d" n - -let uninterp_ascii_string (AnyGlobConstr r) = Option.map make_ascii_string (uninterp_ascii r) - -open Notation - -let at_declare_ml_module f x = - Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name - -let _ = - let sc = "char_scope" in - register_string_interpretation sc (interp_ascii_string,uninterp_ascii_string); - at_declare_ml_module enable_prim_token_interpretation - { pt_local = false; - pt_scope = sc; - pt_interp_info = Uid sc; - pt_required = (ascii_path,ascii_module); - pt_refs = [static_glob_Ascii]; - pt_in_match = true } diff --git a/plugins/syntax/ascii_syntax_plugin.mlpack b/plugins/syntax/ascii_syntax_plugin.mlpack deleted file mode 100644 index 7b9213a0e2..0000000000 --- a/plugins/syntax/ascii_syntax_plugin.mlpack +++ /dev/null @@ -1 +0,0 @@ -Ascii_syntax diff --git a/plugins/syntax/g_string.mlg b/plugins/syntax/g_string.mlg new file mode 100644 index 0000000000..1e06cd8ddb --- /dev/null +++ b/plugins/syntax/g_string.mlg @@ -0,0 +1,25 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +DECLARE PLUGIN "string_notation_plugin" + +{ + +open String_notation +open Names +open Stdarg + +} + +VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF + | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" + ident(sc) ] -> + { vernac_string_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) } +END diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 10a0af0b8f..470deb4a60 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -125,7 +125,7 @@ let vernac_numeral_notation local ty f g scope opts = | None -> type_error_of g ty true in let o = { to_kind; to_ty; of_kind; of_ty; - num_ty = ty; + ty_name = ty; warning = opts } in (match opts, to_kind with diff --git a/plugins/syntax/plugin_base.dune b/plugins/syntax/plugin_base.dune index bfdd480fe9..1ab16c700d 100644 --- a/plugins/syntax/plugin_base.dune +++ b/plugins/syntax/plugin_base.dune @@ -6,6 +6,13 @@ (libraries coq.plugins.ltac)) (library + (name string_notation_plugin) + (public_name coq.plugins.string_notation) + (synopsis "Coq string notation plugin") + (modules g_string string_notation) + (libraries coq.vernac)) + +(library (name r_syntax_plugin) (public_name coq.plugins.r_syntax) (synopsis "Coq syntax plugin: reals") @@ -13,23 +20,8 @@ (libraries coq.vernac)) (library - (name ascii_syntax_plugin) - (public_name coq.plugins.ascii_syntax) - (synopsis "Coq syntax plugin: ASCII") - (modules ascii_syntax) - (libraries coq.vernac)) - -(library - (name string_syntax_plugin) - (public_name coq.plugins.string_syntax) - (synopsis "Coq syntax plugin: strings") - (modules string_syntax) - (libraries coq.plugins.ascii_syntax)) - -(library (name int31_syntax_plugin) (public_name coq.plugins.int31_syntax) (synopsis "Coq syntax plugin: int31") (modules int31_syntax) (libraries coq.vernac)) - diff --git a/plugins/syntax/string_notation.ml b/plugins/syntax/string_notation.ml new file mode 100644 index 0000000000..12ee4c6eda --- /dev/null +++ b/plugins/syntax/string_notation.ml @@ -0,0 +1,98 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open Util +open Names +open Libnames +open Globnames +open Constrexpr +open Constrexpr_ops +open Notation + +(** * String notation *) + +let get_constructors ind = + let mib,oib = Global.lookup_inductive ind in + let mc = oib.Declarations.mind_consnames in + Array.to_list + (Array.mapi (fun j c -> ConstructRef (ind, j + 1)) mc) + +let qualid_of_ref n = + n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty + +let q_option () = qualid_of_ref "core.option.type" +let q_list () = qualid_of_ref "core.list.type" +let q_byte () = qualid_of_ref "core.byte.type" + +let has_type f ty = + let (sigma, env) = Pfedit.get_current_context () in + let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in + try let _ = Constrintern.interp_constr env sigma c in true + with Pretype_errors.PretypeError _ -> false + +let type_error_to f ty = + CErrors.user_err + (pr_qualid f ++ str " should go from Byte.byte or (list Byte.byte) to " ++ + pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ").") + +let type_error_of g ty = + CErrors.user_err + (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ + str " to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)).") + +let vernac_string_notation local ty f g scope = + let app x y = mkAppC (x,[y]) in + let cref q = mkRefC q in + let cbyte = cref (q_byte ()) in + let clist = cref (q_list ()) in + let coption = cref (q_option ()) in + let opt r = app coption r in + let clist_byte = app clist cbyte in + let tyc = Smartlocate.global_inductive_with_alias ty in + let to_ty = Smartlocate.global_with_alias f in + let of_ty = Smartlocate.global_with_alias g in + let cty = cref ty in + let arrow x y = + mkProdC ([CAst.make Anonymous],Default Decl_kinds.Explicit, x, y) + in + let constructors = get_constructors tyc in + (* Check the type of f *) + let to_kind = + if has_type f (arrow clist_byte cty) then ListByte, Direct + else if has_type f (arrow clist_byte (opt cty)) then ListByte, Option + else if has_type f (arrow cbyte cty) then Byte, Direct + else if has_type f (arrow cbyte (opt cty)) then Byte, Option + else type_error_to f ty + in + (* Check the type of g *) + let of_kind = + if has_type g (arrow cty clist_byte) then ListByte, Direct + else if has_type g (arrow cty (opt clist_byte)) then ListByte, Option + else if has_type g (arrow cty cbyte) then Byte, Direct + else if has_type g (arrow cty (opt cbyte)) then Byte, Option + else type_error_of g ty + in + let o = { to_kind = to_kind; + to_ty = to_ty; + of_kind = of_kind; + of_ty = of_ty; + ty_name = ty; + warning = () } + in + let i = + { pt_local = local; + pt_scope = scope; + pt_interp_info = StringNotation o; + pt_required = Nametab.path_of_global (IndRef tyc),[]; + pt_refs = constructors; + pt_in_match = true } + in + enable_prim_token_interpretation i diff --git a/plugins/syntax/string_notation.mli b/plugins/syntax/string_notation.mli new file mode 100644 index 0000000000..9a0174abf2 --- /dev/null +++ b/plugins/syntax/string_notation.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Libnames +open Vernacexpr + +(** * String notation *) + +val vernac_string_notation : locality_flag -> qualid -> qualid -> qualid -> Notation_term.scope_name -> unit diff --git a/plugins/syntax/string_notation_plugin.mlpack b/plugins/syntax/string_notation_plugin.mlpack new file mode 100644 index 0000000000..6aa081dab4 --- /dev/null +++ b/plugins/syntax/string_notation_plugin.mlpack @@ -0,0 +1,2 @@ +String_notation +G_string diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml deleted file mode 100644 index 59e65a0672..0000000000 --- a/plugins/syntax/string_syntax.ml +++ /dev/null @@ -1,81 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Names -open Globnames -open Ascii_syntax_plugin.Ascii_syntax -open Glob_term -open Coqlib - -(* Poor's man DECLARE PLUGIN *) -let __coq_plugin_name = "string_syntax_plugin" -let () = Mltop.add_known_module __coq_plugin_name - -exception Non_closed_string - -(* make a string term from the string s *) - -let string_module = ["Coq";"Strings";"String"] - -let string_modpath = MPfile (make_dir string_module) -let string_path = make_path string_module "string" - -let string_kn = MutInd.make2 string_modpath @@ Label.make "string" -let static_glob_EmptyString = ConstructRef ((string_kn,0),1) -let static_glob_String = ConstructRef ((string_kn,0),2) - -let glob_String = lazy (lib_ref "plugins.syntax.String") -let glob_EmptyString = lazy (lib_ref "plugins.syntax.EmptyString") - -let is_gr c gr = match DAst.get c with -| GRef (r, _) -> GlobRef.equal r gr -| _ -> false - -open Lazy - -let interp_string ?loc s = - let le = String.length s in - let rec aux n = - if n = le then DAst.make ?loc @@ GRef (force glob_EmptyString, None) else - DAst.make ?loc @@ GApp (DAst.make ?loc @@ GRef (force glob_String, None), - [interp_ascii ?loc (int_of_char s.[n]); aux (n+1)]) - in aux 0 - -let uninterp_string (AnyGlobConstr r) = - try - let b = Buffer.create 16 in - let rec aux c = match DAst.get c with - | GApp (k,[a;s]) when is_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 GlobRef.equal z (force glob_EmptyString) -> - Some (Buffer.contents b) - | _ -> - raise Non_closed_string - in aux r - with - Non_closed_string -> None - -open Notation - -let at_declare_ml_module f x = - Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name - -let _ = - let sc = "string_scope" in - register_string_interpretation sc (interp_string,uninterp_string); - at_declare_ml_module enable_prim_token_interpretation - { pt_local = false; - pt_scope = sc; - pt_interp_info = Uid sc; - pt_required = (string_path,["Coq";"Strings";"String"]); - pt_refs = [static_glob_String; static_glob_EmptyString]; - pt_in_match = true } diff --git a/plugins/syntax/string_syntax_plugin.mlpack b/plugins/syntax/string_syntax_plugin.mlpack deleted file mode 100644 index 45d6e0fa23..0000000000 --- a/plugins/syntax/string_syntax_plugin.mlpack +++ /dev/null @@ -1 +0,0 @@ -String_syntax diff --git a/pretyping/cases.ml b/pretyping/cases.ml index fe67f5767b..62c27297f3 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1015,9 +1015,9 @@ let add_assert_false_case pb tomatch = let adjust_impossible_cases sigma pb pred tomatch submat = match submat with | [] -> - (** FIXME: This breaks if using evar-insensitive primitives. In particular, - this means that the Evd.define below may redefine an already defined - evar. See e.g. first definition of test for bug #3388. *) + (* FIXME: This breaks if using evar-insensitive primitives. In particular, + this means that the Evd.define below may redefine an already defined + evar. See e.g. first definition of test for bug #3388. *) let pred = EConstr.Unsafe.to_constr pred in begin match Constr.kind pred with | Evar (evk,_) when snd (evar_source evk sigma) == Evar_kinds.ImpossibleCase -> @@ -1684,8 +1684,8 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = convertible subterms of the substitution *) let evdref = ref sigma in let rec aux (k,env,subst as x) t = - (** Use a reference because the [map_constr_with_full_binders] does not - allow threading a state. *) + (* Use a reference because the [map_constr_with_full_binders] does not + allow threading a state. *) let sigma = !evdref in match EConstr.kind sigma t with | Rel n when is_local_def (lookup_rel n !!env) -> t @@ -2021,7 +2021,7 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = 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 + (* If we put the typing constraint in the term, it has to be refreshed to preserve the invariant that no algebraic universe can appear in the term. *) refresh_universes ~status:Evd.univ_flexible ~onlyalg:true (Some true) diff --git a/pretyping/classops.ml b/pretyping/classops.ml index f18040accb..306a76e35e 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -192,9 +192,11 @@ let subst_cl_typ subst ct = match ct with let c' = subst_proj_repr subst c in if c' == c then ct else CL_PROJ c' | CL_CONST c -> - let c',t = subst_con_kn subst c in - if c' == c then ct else - pi1 (find_class_type Evd.empty (EConstr.of_constr t)) + let c',t = subst_con subst c in + if c' == c then ct else (match t with + | None -> CL_CONST c' + | Some t -> + pi1 (find_class_type Evd.empty (EConstr.of_constr t.Univ.univ_abstracted_value))) | CL_IND i -> let i' = subst_ind subst i in if i' == i then ct else CL_IND i' diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index d7118efd7a..032e4bbf85 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -96,8 +96,8 @@ let rec build_lambda sigma vars ctx m = match vars with | (_, id, t) :: suf -> (Name id, t, suf) in - (** Check that the abstraction is legal by generating a transitive closure of - its dependencies. *) + (* Check that the abstraction is legal by generating a transitive closure of + its dependencies. *) let is_nondep t clear = match clear with | [] -> true | _ -> @@ -106,12 +106,12 @@ let rec build_lambda sigma vars ctx m = match vars with List.for_all_i check 1 clear in let fold (_, _, t) clear = is_nondep t clear :: clear in - (** Produce a list of booleans: true iff we keep the hypothesis *) + (* Produce a list of booleans: true iff we keep the hypothesis *) let clear = List.fold_right fold pre [false] in let clear = List.drop_last clear in - (** If the conclusion depends on a variable we cleared, failure *) + (* If the conclusion depends on a variable we cleared, failure *) let () = if not (is_nondep m clear) then raise PatternMatchingFailure in - (** Create the abstracted term *) + (* Create the abstracted term *) let fold (k, accu) keep = if keep then let k = succ k in @@ -121,10 +121,10 @@ let rec build_lambda sigma vars ctx m = match vars with let keep, shift = List.fold_left fold (0, []) clear in let shift = List.rev shift in let map = function - | None -> mkProp (** dummy term *) + | None -> mkProp (* dummy term *) | Some i -> mkRel (i + 1) in - (** [x1 ... xn y z1 ... zm] -> [x1 ... xn f(z1) ... f(zm) y] *) + (* [x1 ... xn y z1 ... zm] -> [x1 ... xn f(z1) ... f(zm) y] *) let subst = List.map map shift @ mkRel 1 :: @@ -143,12 +143,12 @@ let rec build_lambda sigma vars ctx m = match vars with if i > n then i - n + keep else match List.nth shift (i - 1) with | None -> - (** We cleared a variable that we wanted to abstract! *) + (* We cleared a variable that we wanted to abstract! *) raise PatternMatchingFailure | Some k -> k in let vars = List.map map vars in - (** Create the abstraction *) + (* Create the abstraction *) let m = mkLambda (na, Vars.lift keep t, m) in build_lambda sigma vars (pre @ suf) m @@ -377,8 +377,8 @@ let matches_core env sigma allow_bound_rels let () = match ci1.cip_ind with | None -> () | Some ind1 -> - (** ppedrot: Something spooky going here. The comparison used to be - the generic one, so I may have broken something. *) + (* ppedrot: Something spooky going here. The comparison used to be + the generic one, so I may have broken something. *) if not (eq_ind ind1 ci2.ci_ind) then raise PatternMatchingFailure in let () = diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 33ced6d6e0..517834f014 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -589,8 +589,23 @@ let detype_cofix detype avoid env sigma n (names,tys,bodies) = Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) +(* TODO use some algebraic type with a case for unnamed univs so we + can cleanly detype them. NB: this corresponds to a hack in + Pretyping.interp_universe_level_name to convert Foo.xx strings into + universes. *) +let hack_qualid_of_univ_level sigma l = + match Termops.reference_of_level sigma l with + | Some qid -> qid + | None -> + let path = String.split_on_char '.' (Univ.Level.to_string l) in + let path = List.rev_map Id.of_string_soft path in + Libnames.qualid_of_dirpath (DirPath.make path) + let detype_universe sigma u = - let fn (l, n) = Some (Termops.reference_of_level sigma l, n) in + let fn (l, n) = + let qid = hack_qualid_of_univ_level sigma l in + Some (qid, n) + in Univ.Universe.map fn u let detype_sort sigma = function @@ -611,7 +626,7 @@ let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index let set_detype_anonymous f = detype_anonymous := f let detype_level sigma l = - let l = Termops.reference_of_level sigma l in + let l = hack_qualid_of_univ_level sigma l in GType (UNamed l) let detype_instance sigma l = @@ -688,7 +703,7 @@ and detype_r d flags avoid env sigma t = [detype d flags avoid env sigma c]) else if print_primproj_compatibility () && Projection.unfolded p then - (** Print the compatibility match version *) + (* Print the compatibility match version *) let c' = try let ind = Projection.inductive p in @@ -933,10 +948,13 @@ let (f_subst_genarg, subst_genarg_hook) = Hook.make () let rec subst_glob_constr subst = DAst.map (function | GRef (ref,u) as raw -> let ref',t = subst_global subst ref in - if ref' == ref then raw else - let env = Global.env () in - let evd = Evd.from_env env in - DAst.get (detype Now false Id.Set.empty env evd (EConstr.of_constr t)) + if ref' == ref then raw else (match t with + | None -> GRef (ref', u) + | Some t -> + let env = Global.env () in + let evd = Evd.from_env env in + let t = t.Univ.univ_abstracted_value in (* XXX This seems dangerous *) + DAst.get (detype Now false Id.Set.empty env evd (EConstr.of_constr t))) | GSort _ | GVar _ diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 6c268de3b3..e6e1530e36 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1311,10 +1311,10 @@ let max_undefined_with_candidates evd = | None -> () | Some l -> raise (MaxUndefined (evk, evi, l)) in - (** [fold_right] traverses the undefined map in decreasing order of indices. - The evar with candidates of maximum index is thus the first evar with - candidates found by a [fold_right] traversal. This has a significant impact on - performance. *) + (* [fold_right] traverses the undefined map in decreasing order of + indices. The evar with candidates of maximum index is thus the + first evar with candidates found by a [fold_right] + traversal. This has a significant impact on performance. *) try let () = Evar.Map.fold_right fold (Evd.undefined_map evd) () in None diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4692fe0057..4c4a236620 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -80,7 +80,7 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) if v' == v then t else mkProd (na, u, v') | _ -> t in - (** Refresh the types of evars under template polymorphic references *) + (* Refresh the types of evars under template polymorphic references *) let rec refresh_term_evars ~onevars ~top t = match EConstr.kind !evdref t with | App (f, args) when Termops.is_template_polymorphic_ind env !evdref f -> @@ -1385,7 +1385,7 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs = let occur_evar_upto_types sigma n c = let c = EConstr.Unsafe.to_constr c in let seen = ref Evar.Set.empty in - (** FIXME: Is that supposed to be evar-insensitive? *) + (* FIXME: Is that supposed to be evar-insensitive? *) let rec occur_rec c = match Constr.kind c with | Evar (sp,_) when Evar.equal sp n -> raise Occur | Evar (sp,args as e) -> @@ -1581,7 +1581,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = Id.Set.subset (collect_vars evd rhs) !names in let body = - if fast rhs then nf_evar evd rhs (** FIXME? *) + if fast rhs then nf_evar evd rhs (* FIXME? *) else let t' = imitate (env,0) rhs in if !progress then diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 9b2da0b084..e14766f370 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -148,7 +148,7 @@ let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with Array.equal f c1 c2 && Array.equal f t1 t2 | GSort s1, GSort s2 -> glob_sort_eq s1 s2 | GHole (kn1, nam1, gn1), GHole (kn2, nam2, gn2) -> - Option.equal (==) gn1 gn2 (** Only thing sensible *) && + Option.equal (==) gn1 gn2 (* Only thing sensible *) && Namegen.intro_pattern_naming_eq nam1 nam2 | GCast (c1, t1), GCast (c2, t2) -> f c1 c2 && cast_type_eq f t1 t2 diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index c6fdb0ec14..c405fcfc72 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -106,6 +106,7 @@ and 'a tomatch_tuples_g = 'a tomatch_tuple_g list and 'a cases_clause_g = (Id.t list * 'a cases_pattern_g list * 'a glob_constr_g) CAst.t (** [(p,il,cl,t)] = "|'cl' => 't'". Precondition: the free variables of [t] are members of [il]. *) + and 'a cases_clauses_g = 'a cases_clause_g list type glob_constr = [ `any ] glob_constr_g diff --git a/pretyping/heads.ml b/pretyping/heads.ml index e533930267..ccbb2934bc 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -147,13 +147,16 @@ let cache_head o = let subst_head_approximation subst = function | RigidHead (RigidParameter cst) as k -> - let cst,c = subst_con_kn subst cst in - if isConst c && Constant.equal (fst (destConst c)) cst then - (* A change of the prefix of the constant *) - k - else - (* A substitution of the constant by a functor argument *) - kind_of_head (Global.env()) c + let cst',c = subst_con subst cst in + if cst == cst' then k + else + (match c with + | None -> + (* A change of the prefix of the constant *) + RigidHead (RigidParameter cst') + | Some c -> + (* A substitution of the constant by a functor argument *) + kind_of_head (Global.env()) c.Univ.univ_abstracted_value) | x -> x let subst_head (subst,(ref,k)) = diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 10d8451947..ff552c7caf 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -469,9 +469,9 @@ let compute_projections env (kn, i as ind) = let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in - (** We build a substitution smashing the lets in the record parameters so - that typechecking projections requires just a substitution and not - matching with a parameter context. *) + (* We build a substitution smashing the lets in the record parameters so + that typechecking projections requires just a substitution and not + matching with a parameter context. *) let indty = (* [ty] = [Ind inst] is typed in context [params] *) let inst = Context.Rel.to_extended_vect mkRel 0 paramslet in @@ -748,7 +748,7 @@ let type_of_projection_knowing_arg env sigma p c ty = let control_only_guard env sigma c = let c = Evarutil.nf_evar sigma c in let check_fix_cofix e c = - (** [c] has already been normalized upfront *) + (* [c] has already been normalized upfront *) let c = EConstr.Unsafe.to_constr c in match kind c with | CoFix (_,(_,_,_) as cofix) -> diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 022c383f60..dc2663c1ca 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -406,14 +406,15 @@ and nf_evar env sigma evk args = mkEvar (evk, [||]), ty end else - (** Let-bound arguments are present in the evar arguments but not in the - type, so we turn the let into a product. *) + (* Let-bound arguments are present in the evar arguments but not + in the type, so we turn the let into a product. *) let hyps = Context.Named.drop_bodies hyps in let fold accu d = Term.mkNamedProd_or_LetIn d accu in let t = List.fold_left fold ty hyps in let ty, args = nf_args env sigma args t in - (** nf_args takes arguments in the reverse order but produces them in the - correct one, so we have to reverse them again for the evar node *) + (* nf_args takes arguments in the reverse order but produces them + in the correct one, so we have to reverse them again for the + evar node *) mkEvar (evk, Array.rev_of_list args), ty let evars_of_evar_map sigma = diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 3c1c470053..248d5d0a0e 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -256,7 +256,7 @@ let instantiate_pattern env sigma lvar c = ctx in let c = substl inst c in - (** FIXME: Stupid workaround to pattern_of_constr being evar sensitive *) + (* FIXME: Stupid workaround to pattern_of_constr being evar sensitive *) let c = Evarutil.nf_evar sigma c in pattern_of_constr env sigma (EConstr.Unsafe.to_constr c) with Not_found (* List.index failed *) -> @@ -279,10 +279,12 @@ let rec subst_pattern subst pat = match pat with | PRef ref -> let ref',t = subst_global subst ref in - if ref' == ref then pat else - let env = Global.env () in - let evd = Evd.from_env env in - pattern_of_constr env evd t + if ref' == ref then pat else (match t with + | None -> PRef ref' + | Some t -> + let env = Global.env () in + let evd = Evd.from_env env in + pattern_of_constr env evd t.Univ.univ_abstracted_value) | PVar _ | PEvar _ | PRel _ -> pat diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 054f0c76a9..51103ca194 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -38,12 +38,15 @@ type subterm_unification_error = bool * position_reporting * position_reporting type type_error = (constr, types) ptype_error type pretype_error = - (** Old Case *) | CantFindCaseType of constr - (** Type inference unification *) + (** Old Case *) + | ActualTypeNotCoercible of unsafe_judgment * types * unification_error - (** Tactic Unification *) + (** Type inference unification *) + | UnifOccurCheck of Evar.t * constr + (** Tactic Unification *) + | UnsolvableImplicit of Evar.t * Evd.unsolvability_explanation option | CannotUnify of constr * constr * unification_error option | CannotUnifyLocal of constr * constr * constr diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index f5e48bcd39..ace2868255 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -120,8 +120,8 @@ let interp_known_universe_level evd qid = if qualid_is_ident qid then Evd.universe_of_name evd @@ qualid_basename qid else raise Not_found with Not_found -> - let univ, k = Nametab.locate_universe qid in - Univ.Level.make univ k + let qid = Nametab.locate_universe qid in + Univ.Level.make qid let interp_universe_level_name ~anon_rigidity evd qid = try evd, interp_known_universe_level evd qid @@ -140,7 +140,7 @@ let interp_universe_level_name ~anon_rigidity evd qid = user_err ?loc:qid.CAst.loc ~hdr:"interp_universe_level_name" (Pp.(str "Undeclared global universe: " ++ Libnames.pr_qualid qid)) in - let level = Univ.Level.make dp num in + let level = Univ.Level.(make (UGlobal.make dp num)) in let evd = try Evd.add_global_univ evd level with UGraph.AlreadyDeclared -> evd @@ -212,7 +212,7 @@ type frozen = let frozen_and_pending_holes (sigma, sigma') = let undefined0 = Option.cata Evd.undefined_map Evar.Map.empty sigma in - (** Fast path when the undefined evars where not modified *) + (* Fast path when the undefined evars where not modified *) if undefined0 == Evd.undefined_map sigma' then FrozenId undefined0 else @@ -579,7 +579,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma sigma ctxtv vdef in let sigma = Typing.check_type_fixpoint ?loc !!env sigma names ftys vdefj in let nf c = nf_evar sigma c in - let ftys = Array.map nf ftys in (** FIXME *) + let ftys = Array.map nf ftys in (* FIXME *) let fdefs = Array.map (fun x -> nf (j_val x)) vdefj in let fixj = match fixkind with | GFix (vn,i) -> diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index fe9b69dbbc..6e3b19ae61 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -71,12 +71,12 @@ let subst_structure (subst,((kn,i),id,kl,projs as obj)) = (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) List.Smart.map - (Option.Smart.map (fun kn -> fst (subst_con_kn subst kn))) + (Option.Smart.map (subst_constant subst)) projs in - let id' = fst (subst_constructor subst id) in - if projs' == projs && kn' == kn && id' == id then obj else - ((kn',i),id',kl,projs') + let id' = subst_constructor subst id in + if projs' == projs && kn' == kn && id' == id then obj else + ((kn',i),id',kl,projs') let discharge_structure (_,x) = Some x @@ -374,7 +374,7 @@ let decompose_projection sigma c args = match EConstr.kind sigma c with | Const (c, u) -> let n = find_projection_nparams (ConstRef c) in - (** Check if there is some canonical projection attached to this structure *) + (* Check if there is some canonical projection attached to this structure *) let _ = GlobRef.Map.find (ConstRef c) !object_table in let arg = Stack.nth args n in arg diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index a57ee6e292..9c9877fd23 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -69,11 +69,9 @@ let subst_reduction_effect (subst,(con,funkey)) = (subst_constant subst con,funkey) let inReductionEffect : Constant.t * string -> obj = - declare_object {(default_object "REDUCTION-EFFECT") with - cache_function = cache_reduction_effect; - open_function = (fun i o -> if Int.equal i 1 then cache_reduction_effect o); - subst_function = subst_reduction_effect; - classify_function = (fun o -> Substitute o) } + declare_object @@ global_object_nodischarge "REDUCTION-EFFECT" + ~cache:cache_reduction_effect + ~subst:(Some subst_reduction_effect) let declare_reduction_effect funkey f = if String.Map.mem funkey !effect_table then @@ -203,6 +201,7 @@ end (** Machinery about stack of unfolded constants *) module Cst_stack = struct open EConstr + (** constant * params * args - constant applied to params = term in head applied to args @@ -1342,7 +1341,7 @@ let sigma_univ_state = let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=TransparentState.full) env sigma x y = - (** FIXME *) + (* FIXME *) try let ans = match pb with | Reduction.CUMUL -> @@ -1632,7 +1631,7 @@ let meta_reducible_instance evd b = in let metas = Metaset.fold fold fm Metamap.empty in let rec irec u = - let u = whd_betaiota Evd.empty u (** FIXME *) in + let u = whd_betaiota Evd.empty u (* FIXME *) in match EConstr.kind evd u with | Case (ci,p,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> let m = destMeta evd (strip_outer_cast evd c) in diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 088e898a99..a1fd610676 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -77,7 +77,9 @@ module Stack : sig | Case of case_info * 'a * 'a array * Cst_stack.t | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t - | Cst of cst_member * int (** current foccussed arg *) * int list (** remaining args *) + | Cst of cst_member + * int (* current foccussed arg *) + * int list (* remaining args *) * 'a t * Cst_stack.t and 'a t = 'a member list @@ -93,6 +95,7 @@ module Stack : sig val compare_shape : 'a t -> 'a t -> bool exception IncompatibleFold2 + (** [fold2 f x sk1 sk2] folds [f] on any pair of term in [(sk1,sk2)]. @return the result and the lifts to apply on the terms @raise IncompatibleFold2 when [sk1] and [sk2] have incompatible shapes *) @@ -104,6 +107,7 @@ module Stack : sig (** if [strip_app s] = [(a,b)], then [s = a @ b] and [b] does not start by App *) val strip_app : 'a t -> 'a t * 'a t + (** @return (the nth first elements, the (n+1)th element, the remaining stack) *) val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index d9df8c8cf8..2e7176a6b3 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -250,7 +250,7 @@ let invert_name labs l na0 env sigma ref = function let labs',ccl = decompose_lam sigma c in let _, l' = whd_betalet_stack sigma ccl in let labs' = List.map snd labs' in - (** ppedrot: there used to be generic equality on terms here *) + (* ppedrot: there used to be generic equality on terms here *) let eq_constr c1 c2 = EConstr.eq_constr sigma c1 c2 in if List.equal eq_constr labs' labs && List.equal eq_constr l l' then Some (minfxargs,ref) @@ -450,7 +450,7 @@ let substl_checking_arity env subst sigma c = the other ones are replaced by the function symbol *) let rec nf_fix c = match EConstr.kind sigma c with | Evar (i,[|fx;f|]) when Evar.Map.mem i minargs -> - (** FIXME: find a less hackish way of doing this *) + (* FIXME: find a less hackish way of doing this *) begin match EConstr.kind sigma' c with | Evar _ -> f | c -> EConstr.of_kind c @@ -943,7 +943,7 @@ let whd_simpl_orelse_delta_but_fix env sigma c = | _ -> false) -> let npars = Projection.npars p in if List.length stack <= npars then - (** Do not show the eta-expanded form *) + (* Do not show the eta-expanded form *) s' else redrec (applist (c, stack)) | _ -> redrec (applist(c, stack))) @@ -993,7 +993,7 @@ let e_contextually byhead (occs,c) f = begin fun env sigma t -> let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref 1 in - (** FIXME: we do suspicious things with this evarmap *) + (* FIXME: we do suspicious things with this evarmap *) let evd = ref sigma in let rec traverse nested (env,c as envc) t = if nowhere_except_in && (!pos > maxocc) then (* Shortcut *) t diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index d00195678b..f8aedf88c2 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -25,33 +25,33 @@ type hint_info = (Pattern.patvar list * Pattern.constr_pattern) hint_info_gen (** This module defines type-classes *) type typeclass = { + cl_univs : Univ.AUContext.t; (** The toplevel universe quantification in which the typeclass lives. In particular, [cl_props] and [cl_context] are quantified over it. *) - cl_univs : Univ.AUContext.t; + cl_impl : GlobRef.t; (** The class implementation: a record parameterized by the context with defs in it or a definition if the class is a singleton. This acts as the class' global identifier. *) - cl_impl : GlobRef.t; + cl_context : GlobRef.t option list * Constr.rel_context; (** Context in which the definitions are typed. Includes both typeclass parameters and superclasses. The global reference gives a direct link to the class itself. *) - cl_context : GlobRef.t option list * Constr.rel_context; - (** Context of definitions and properties on defs, will not be shared *) cl_props : Constr.rel_context; + (** Context of definitions and properties on defs, will not be shared *) + cl_projs : (Name.t * (direction * hint_info) option * Constant.t option) list; (** The methods implementations of the typeclass as projections. Some may be undefinable due to sorting restrictions or simply undefined if no name is provided. The [int option option] indicates subclasses whose hint has the given priority. *) - cl_projs : (Name.t * (direction * hint_info) option * Constant.t option) list; - (** Whether we use matching or full unification during resolution *) cl_strict : bool; + (** Whether we use matching or full unification during resolution *) + cl_unique : bool; (** Whether we can assume that instances are unique, which allows no backtracking and sharing of resolution. *) - cl_unique : bool; } type instance diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 366af0772f..79f2941554 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -36,8 +36,8 @@ val meta_type : evar_map -> metavariable -> types (** Solve existential variables using typing *) val solve_evars : env -> evar_map -> constr -> evar_map * constr -(** Raise an error message if incorrect elimination for this inductive *) -(** (first constr is term to match, second is return predicate) *) +(** Raise an error message if incorrect elimination for this inductive + (first constr is term to match, second is return predicate) *) val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr -> unit diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 094fcd923e..f0cd5c5f6a 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -76,8 +76,8 @@ let unsafe_occur_meta_or_existential c = let occur_meta_or_undefined_evar evd c = - (** This is performance-critical. Using the evar-insensitive API changes the - resulting heuristic. *) + (* This is performance-critical. Using the evar-insensitive API changes the + resulting heuristic. *) let c = EConstr.Unsafe.to_constr c in let rec occrec c = match Constr.kind c with | Meta _ -> raise Occur @@ -134,7 +134,7 @@ let abstract_list_all env evd typ c l = | UserError _ -> error_cannot_find_well_typed_abstraction env evd p l None | Type_errors.TypeError (env',x) -> - (** FIXME: plug back the typing information *) + (* FIXME: plug back the typing information *) error_cannot_find_well_typed_abstraction env evd p l None | Pretype_errors.PretypeError (env',evd,TypingError x) -> error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in @@ -154,11 +154,9 @@ let abstract_list_all_with_dependencies env evd typ c l = if b then let p = nf_evar evd ev in evd, p - else error_cannot_find_well_typed_abstraction env evd + else error_cannot_find_well_typed_abstraction env evd c l None -(**) - (* A refinement of [conv_pb]: the integers tells how many arguments were applied in the context of the conversion problem; if the number is non zero, steps of eta-expansion will be allowed @@ -598,8 +596,9 @@ let isAllowedEvar sigma flags c = match EConstr.kind sigma c with let subst_defined_metas_evars sigma (bl,el) c = - (** This seems to be performance-critical, and using the evar-insensitive - primitives blow up the time passed in this function. *) + (* This seems to be performance-critical, and using the + evar-insensitive primitives blow up the time passed in this + function. *) let c = EConstr.Unsafe.to_constr c in let rec substrec c = match Constr.kind c with | Meta i -> @@ -656,7 +655,7 @@ let is_eta_constructor_app env sigma ts f l1 term = | PrimRecord info when mib.Declarations.mind_finite == Declarations.BiFinite && let (_, projs, _) = info.(i) in Array.length projs == Array.length l1 - mib.Declarations.mind_nparams -> - (** Check that the other term is neutral *) + (* Check that the other term is neutral *) is_neutral env sigma ts term | _ -> false) | _ -> false @@ -783,7 +782,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e | LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb opt substn (subst1 a c) cN | _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb opt substn cM (subst1 a c) - (** Fast path for projections. *) + (* Fast path for projections. *) | Proj (p1,c1), Proj (p2,c2) when Constant.equal (Projection.constant p1) (Projection.constant p2) -> (try unify_same_proj curenvnb cv_pb {opt with at_top = true} @@ -908,7 +907,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e match EConstr.kind sigma c with | Proj (p, t) when not (Projection.unfolded p) && needs_expansion p c' -> (try destApp sigma (Retyping.expand_projection curenv sigma p t (Array.to_list l)) - with RetypeError _ -> (** Unification can be called on ill-typed terms, due + with RetypeError _ -> (* Unification can be called on ill-typed terms, due to FO and eta in particular, fail gracefully in that case *) (c, l)) | _ -> (c, l) @@ -1604,7 +1603,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = with | PretypeError (_,_,CannotUnify (c1,c2,Some e)) -> raise (NotUnifiable (Some (c1,c2,e))) - (** MS: This is pretty bad, it catches Not_found for example *) + (* MS: This is pretty bad, it catches Not_found for example *) | e when CErrors.noncritical e -> raise (NotUnifiable None) in let merge_fun c1 c2 = match c1, c2 with diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index c30c4f0932..113aac25da 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -207,10 +207,10 @@ and nf_evar env sigma evk stk = nf_stk env sigma (mkEvar (evk, [||])) concl stk else match stk with | Zapp args :: stk -> - (** We assume that there is no consecutive Zapp nodes in a VM stack. Is that - really an invariant? *) - (** Let-bound arguments are present in the evar arguments but not in the - type, so we turn the let into a product. *) + (* We assume that there is no consecutive Zapp nodes in a VM stack. Is that + really an invariant? *) + (* Let-bound arguments are present in the evar arguments but not in the + type, so we turn the let into a product. *) let hyps = Context.Named.drop_bodies hyps in let fold accu d = Term.mkNamedProd_or_LetIn d accu in let t = List.fold_left fold concl hyps in @@ -388,7 +388,7 @@ and nf_cofix env sigma cf = let cbv_vm env sigma c t = if Termops.occur_meta sigma c then CErrors.user_err Pp.(str "vm_compute does not support metas."); - (** This evar-normalizes terms beforehand *) + (* This evar-normalizes terms beforehand *) let c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c in let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in let v = Csymtable.val_of_constr env c in diff --git a/printing/prettyp.ml b/printing/prettyp.ml index f9f4d7f7f8..8f7e4470f9 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -427,7 +427,7 @@ let locate_modtype qid = let all = Nametab.locate_extended_all_modtype qid in let map mp = ModuleType mp, Nametab.shortest_qualid_of_modtype mp in let modtypes = List.map map all in - (** Don't forget the opened module types: they are not part of the same name tab. *) + (* Don't forget the opened module types: they are not part of the same name tab. *) let all = Nametab.locate_extended_all_dir qid in let map dir = let open Nametab.GlobDirRef in match dir with | DirOpenModtype _ -> Some (Dir dir, qid) diff --git a/printing/printer.ml b/printing/printer.ml index 2bbda279bd..be0139da06 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -546,10 +546,10 @@ let rec pr_evars_int_hd pr sigma i = function (hov 0 (pr i evk evi)) ++ (match rest with [] -> mt () | _ -> fnl () ++ pr_evars_int_hd pr sigma (i+1) rest) -let pr_evars_int sigma ~shelf ~givenup i evs = +let pr_evars_int sigma ~shelf ~given_up i evs = let pr_status i = if List.mem i shelf then str " (shelved)" - else if List.mem i givenup then str " (given up)" + else if List.mem i given_up then str " (given up)" else mt () in pr_evars_int_hd (fun i evk evi -> @@ -605,12 +605,12 @@ let print_evar_constraints gl sigma = let t1 = Evarutil.nf_evar sigma t1 and t2 = Evarutil.nf_evar sigma t2 in let env = - (** We currently allow evar instances to refer to anonymous de Bruijn - indices, so we protect the error printing code in this case by giving - names to every de Bruijn variable in the rel_context of the conversion - problem. MS: we should rather stop depending on anonymous variables, they - can be used to indicate independency. Also, this depends on a strategy for - naming/renaming *) + (* We currently allow evar instances to refer to anonymous de Bruijn + indices, so we protect the error printing code in this case by giving + names to every de Bruijn variable in the rel_context of the conversion + problem. MS: we should rather stop depending on anonymous variables, they + can be used to indicate independency. Also, this depends on a strategy for + naming/renaming *) Namegen.make_all_name_different env sigma in str" " ++ hov 2 (pr_env env ++ pr_leconstr_env env sigma t1 ++ spc () ++ @@ -686,7 +686,7 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map | None -> GoalMap.empty in - (** Printing functions for the extra informations. *) + (* Printing functions for the extra informations. *) let rec print_stack a = function | [] -> Pp.int a | b::l -> Pp.int a ++ str"-" ++ print_stack b l @@ -722,11 +722,11 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map let get_ogs g = match os_map with | Some (osigma, _) -> - (* if Not_found, returning None treats the goal as new and it will be highlighted; + (* if Not_found, returning None treats the goal as new and it will be diff highlighted; returning Some { it = g; sigma = sigma } will compare the new goal to itself and it won't be highlighted *) (try Some { it = GoalMap.find g diff_goal_map; sigma = osigma } - with Not_found -> raise (Pp_diff.Diff_Failure "Unable to match goals between old and new proof states (7)")) + with Not_found -> None) | None -> None in let rec pr_rec n = function @@ -753,7 +753,7 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map | None -> () in - (** Main function *) + (* Main function *) match goals with | [] -> begin @@ -761,7 +761,7 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map if Evar.Map.is_empty exl then (str"No more subgoals." ++ print_dependent_evars None sigma seeds) else - let pei = pr_evars_int sigma ~shelf ~givenup:[] 1 exl in + let pei = pr_evars_int sigma ~shelf ~given_up:[] 1 exl in v 0 ((str "No more subgoals," ++ str " but there are non-instantiated existential variables:" ++ cut () ++ (hov 0 pei) @@ -789,7 +789,7 @@ let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?oproof proof = straightforward, but seriously, [Proof.proof] should return [evar_info]-s instead. *) let p = proof in - let (goals , stack , shelf, given_up, sigma ) = Proof.proof p in + let Proof.{goals; stack; shelf; given_up; sigma} = Proof.data p in let stack = List.map (fun (l,r) -> List.length l + List.length r) stack in let seeds = Proof.V82.top_evars p in begin match goals with @@ -821,7 +821,7 @@ let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?oproof proof = let unfocused_if_needed = if should_unfoc() then bgoals_unfocused else [] in let os_map = match oproof with | Some op when diffs -> - let (_,_,_,_, osigma) = Proof.proof op in + let Proof.{sigma=osigma} = Proof.data op in let diff_goal_map = Proof_diffs.make_goal_map oproof proof in Some (osigma, diff_goal_map) | _ -> None @@ -834,8 +834,8 @@ let pr_open_subgoals ~proof = pr_open_subgoals_diff proof let pr_nth_open_subgoal ~proof n = - let gls,_,_,_,sigma = Proof.proof proof in - pr_subgoal n sigma gls + let Proof.{goals;sigma} = Proof.data proof in + pr_subgoal n sigma goals let pr_goal_by_id ~proof id = try diff --git a/printing/printer.mli b/printing/printer.mli index b0232ec4ac..fd4682a086 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -112,6 +112,7 @@ val pr_pconstructor : env -> evar_map -> pconstructor -> Pp.t (** Contexts *) + (** Display compact contexts of goals (simple hyps on the same line) *) val set_compact_context : bool -> unit val get_compact_context : unit -> bool @@ -181,7 +182,7 @@ val pr_open_subgoals_diff : ?quiet:bool -> ?diffs:bool -> ?oproof:Proof.t -> Pr val pr_open_subgoals : proof:Proof.t -> Pp.t val pr_nth_open_subgoal : proof:Proof.t -> int -> Pp.t val pr_evar : evar_map -> (Evar.t * evar_info) -> Pp.t -val pr_evars_int : evar_map -> shelf:Goal.goal list -> givenup:Goal.goal list -> int -> evar_info Evar.Map.t -> Pp.t +val pr_evars_int : evar_map -> shelf:Goal.goal list -> given_up:Goal.goal list -> int -> evar_info Evar.Map.t -> Pp.t val pr_evars : evar_map -> evar_info Evar.Map.t -> Pp.t val pr_ne_evar_set : Pp.t -> Pp.t -> evar_map -> Evar.Set.t -> Pp.t diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index 3e2093db4a..b280ce909b 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -83,7 +83,7 @@ let tokenize_string s = if Tok.(equal e EOI) then List.rev acc else - stream_tok ((Tok.extract_string e) :: acc) str + stream_tok ((Tok.extract_string true e) :: acc) str in let st = CLexer.get_lexer_state () in try @@ -138,13 +138,11 @@ let diff_hyps o_line_idents o_map n_line_idents n_map = let hyp_diffs = diff_str ~tokenize_string o_line n_line in let (has_added, has_removed) = has_changes hyp_diffs in if show_removed () && has_removed then begin - let o_entry = StringMap.find (List.hd old_ids) o_map in - o_entry.done_ <- true; + List.iter (fun x -> (StringMap.find x o_map).done_ <- true) old_ids; rv := (add_diff_tags `Removed o_pp hyp_diffs) :: !rv; end; if n_line <> "" then begin - let n_entry = StringMap.find (List.hd new_ids) n_map in - n_entry.done_ <- true; + List.iter (fun x -> (StringMap.find x n_map).done_ <- true) new_ids; rv := (add_diff_tags `Added n_pp hyp_diffs) :: !rv end in @@ -157,7 +155,7 @@ let diff_hyps o_line_idents o_map n_line_idents n_map = if dtype = `Removed then begin let o_idents = (StringMap.find ident o_map).idents in (* only show lines that have all idents removed here; other removed idents appear later *) - if show_removed () && + if show_removed () && not (is_done ident o_map) && List.for_all (fun x -> not (exists x n_map)) o_idents then output (List.rev o_idents) [] end @@ -399,6 +397,10 @@ let match_goals ot nt = It's set to the old goal's evar name once a rewitten goal is found, at which point the code only searches for the replacing goals (and ot is set to nt). *) + let iter2 f l1 l2 = + if List.length l1 = (List.length l2) then + List.iter2 f l1 l2 + in let rec match_goals_r ogname ot nt = let constr_expr ogname exp exp2 = match_goals_r ogname exp.v exp2.v @@ -434,13 +436,13 @@ let match_goals ot nt = let fix_expr ogname exp exp2 = let (l,(lo,ro),lb,ce1,ce2), (l2,(lo2,ro2),lb2,ce12,ce22) = exp,exp2 in recursion_order_expr ogname ro ro2; - List.iter2 (local_binder_expr ogname) lb lb2; + iter2 (local_binder_expr ogname) lb lb2; constr_expr ogname ce1 ce12; constr_expr ogname ce2 ce22 in let cofix_expr ogname exp exp2 = let (l,lb,ce1,ce2), (l2,lb2,ce12,ce22) = exp,exp2 in - List.iter2 (local_binder_expr ogname) lb lb2; + iter2 (local_binder_expr ogname) lb lb2; constr_expr ogname ce1 ce12; constr_expr ogname ce2 ce22 in @@ -454,38 +456,38 @@ let match_goals ot nt = in let constr_notation_substitution ogname exp exp2 = let (ce, cel, cp, lb), (ce2, cel2, cp2, lb2) = exp, exp2 in - List.iter2 (constr_expr ogname) ce ce2; - List.iter2 (fun a a2 -> List.iter2 (constr_expr ogname) a a2) cel cel2; - List.iter2 (fun a a2 -> List.iter2 (local_binder_expr ogname) a a2) lb lb2 + iter2 (constr_expr ogname) ce ce2; + iter2 (fun a a2 -> iter2 (constr_expr ogname) a a2) cel cel2; + iter2 (fun a a2 -> iter2 (local_binder_expr ogname) a a2) lb lb2 in begin match ot, nt with | CRef (ref,us), CRef (ref2,us2) -> () | CFix (id,fl), CFix (id2,fl2) -> - List.iter2 (fix_expr ogname) fl fl2 + iter2 (fix_expr ogname) fl fl2 | CCoFix (id,cfl), CCoFix (id2,cfl2) -> - List.iter2 (cofix_expr ogname) cfl cfl2 + iter2 (cofix_expr ogname) cfl cfl2 | CProdN (bl,c2), CProdN (bl2,c22) | CLambdaN (bl,c2), CLambdaN (bl2,c22) -> - List.iter2 (local_binder_expr ogname) bl bl2; + iter2 (local_binder_expr ogname) bl bl2; constr_expr ogname c2 c22 | CLetIn (na,c1,t,c2), CLetIn (na2,c12,t2,c22) -> constr_expr ogname c1 c12; constr_expr_opt ogname t t2; constr_expr ogname c2 c22 | CAppExpl ((isproj,ref,us),args), CAppExpl ((isproj2,ref2,us2),args2) -> - List.iter2 (constr_expr ogname) args args2 + iter2 (constr_expr ogname) args args2 | CApp ((isproj,f),args), CApp ((isproj2,f2),args2) -> constr_expr ogname f f2; - List.iter2 (fun a a2 -> let (c, _) = a and (c2, _) = a2 in + iter2 (fun a a2 -> let (c, _) = a and (c2, _) = a2 in constr_expr ogname c c2) args args2 | CRecord fs, CRecord fs2 -> - List.iter2 (fun a a2 -> let (_, c) = a and (_, c2) = a2 in + iter2 (fun a a2 -> let (_, c) = a and (_, c2) = a2 in constr_expr ogname c c2) fs fs2 | CCases (sty,rtnpo,tms,eqns), CCases (sty2,rtnpo2,tms2,eqns2) -> constr_expr_opt ogname rtnpo rtnpo2; - List.iter2 (case_expr ogname) tms tms2; - List.iter2 (branch_expr ogname) eqns eqns2 + iter2 (case_expr ogname) tms tms2; + iter2 (branch_expr ogname) eqns eqns2 | CLetTuple (nal,(na,po),b,c), CLetTuple (nal2,(na2,po2),b2,c2) -> constr_expr_opt ogname po po2; constr_expr ogname b b2; @@ -500,7 +502,7 @@ let match_goals ot nt = | CEvar (n,l), CEvar (n2,l2) -> let oevar = if ogname = "" then Id.to_string n else ogname in nevar_to_oevar := StringMap.add (Id.to_string n2) oevar !nevar_to_oevar; - List.iter2 (fun x x2 -> let (_, g) = x and (_, g2) = x2 in constr_expr ogname g g2) l l2 + iter2 (fun x x2 -> let (_, g) = x and (_, g2) = x2 in constr_expr ogname g g2) l l2 | CEvar (n,l), nt' -> (* pass down the old goal evar name *) match_goals_r (Id.to_string n) nt' nt' @@ -545,19 +547,31 @@ module GoalMap = Evar.Map let goal_to_evar g sigma = Id.to_string (Termops.pr_evar_suggested_name g sigma) +open Goal.Set + [@@@ocaml.warning "-32"] let db_goal_map op np ng_to_og = - Printf.printf "New Goals: "; - let (ngoals,_,_,_,nsigma) = Proof.proof np in - List.iter (fun ng -> Printf.printf "%d -> %s " (Evar.repr ng) (goal_to_evar ng nsigma)) ngoals; + let pr_goals title prf = + Printf.printf "%s: " title; + let Proof.{goals;sigma} = Proof.data prf in + List.iter (fun g -> Printf.printf "%d -> %s " (Evar.repr g) (goal_to_evar g sigma)) goals; + let gs = diff (Proof.all_goals prf) (List.fold_left (fun s g -> add g s) empty goals) in + List.iter (fun g -> Printf.printf "%d " (Evar.repr g)) (elements gs); + in + + pr_goals "New Goals" np; (match op with | Some op -> - let (ogoals,_,_,_,osigma) = Proof.proof op in - Printf.printf "\nOld Goals: "; - List.iter (fun og -> Printf.printf "%d -> %s " (Evar.repr og) (goal_to_evar og osigma)) ogoals + pr_goals "\nOld Goals" op | None -> ()); Printf.printf "\nGoal map: "; - GoalMap.iter (fun og ng -> Printf.printf "%d -> %d " (Evar.repr og) (Evar.repr ng)) ng_to_og; + GoalMap.iter (fun ng og -> Printf.printf "%d -> %d " (Evar.repr ng) (Evar.repr og)) ng_to_og; + let unmapped = ref (Proof.all_goals np) in + GoalMap.iter (fun ng _ -> unmapped := Goal.Set.remove ng !unmapped) ng_to_og; + if Goal.Set.cardinal !unmapped > 0 then begin + Printf.printf "\nUnmapped goals: "; + Goal.Set.iter (fun ng -> Printf.printf "%d " (Evar.repr ng)) !unmapped + end; Printf.printf "\n" [@@@ocaml.warning "+32"] @@ -612,11 +626,11 @@ let make_goal_map_i op np = let nevar_to_oevar = match_goals (Some (to_constr op)) (to_constr np) in let oevar_to_og = ref StringMap.empty in - let (_,_,_,_,osigma) = Proof.proof op in + let Proof.{sigma=osigma} = Proof.data op in List.iter (fun og -> oevar_to_og := StringMap.add (goal_to_evar og osigma) og !oevar_to_og) (Goal.Set.elements rem_gs); - let (_,_,_,_,nsigma) = Proof.proof np in + let Proof.{sigma=nsigma} = Proof.data np in let get_og ng = let nevar = goal_to_evar ng nsigma in let oevar = StringMap.find nevar nevar_to_oevar in diff --git a/printing/proof_diffs.mli b/printing/proof_diffs.mli index ce9ee5ae6f..1ebde3d572 100644 --- a/printing/proof_diffs.mli +++ b/printing/proof_diffs.mli @@ -12,6 +12,7 @@ (** Controls whether to show diffs. Takes values "on", "off", "removed" *) val write_diffs_option : string -> unit + (** Returns true if the diffs option is "on" or "removed" *) val show_diffs : unit -> bool diff --git a/proofs/clenv.ml b/proofs/clenv.ml index b7ccd647b5..1f1bdf4da7 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -601,17 +601,17 @@ let make_evar_clause env sigma ?len t = | None -> -1 | Some n -> assert (0 <= n); n in - (** FIXME: do the renaming online *) + (* FIXME: do the renaming online *) let t = rename_bound_vars_as_displayed sigma Id.Set.empty [] t in let rec clrec (sigma, holes) inst n t = if n = 0 then (sigma, holes, t) else match EConstr.kind sigma t with | Cast (t, _, _) -> clrec (sigma, holes) inst n t | Prod (na, t1, t2) -> - (** Share the evar instances as we are living in the same context *) + (* Share the evar instances as we are living in the same context *) let inst, ctx, args, subst = match inst with | None -> - (** Dummy type *) + (* Dummy type *) let ctx, _, args, subst = push_rel_context_to_named_context env sigma mkProp in Some (ctx, args, subst), ctx, args, subst | Some (ctx, args, subst) -> inst, ctx, args, subst @@ -688,7 +688,7 @@ let solve_evar_clause env sigma hyp_only clause = function let open EConstr in let fold holes h = if h.hole_deps then - (** Some subsequent term uses the hole *) + (* Some subsequent term uses the hole *) let (ev, _) = destEvar sigma h.hole_evar in let is_dep hole = occur_evar sigma ev hole.hole_type in let in_hyp = List.exists is_dep holes in @@ -697,7 +697,7 @@ let solve_evar_clause env sigma hyp_only clause = function let h = { h with hole_deps = dep } in h :: holes else - (** The hole does not occur anywhere *) + (* The hole does not occur anywhere *) h :: holes in let holes = List.fold_left fold [] (List.rev clause.cl_holes) in diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 4720328893..c36b0fa337 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -61,9 +61,9 @@ let clenv_pose_dependent_evars ?(with_evars=false) clenv = clenv_pose_metas_as_evars clenv dep_mvs let clenv_refine ?(with_evars=false) ?(with_classes=true) clenv = - (** ppedrot: a Goal.enter here breaks things, because the tactic below may - solve goals by side effects, while the compatibility layer keeps those - useless goals. That deserves a FIXME. *) + (* ppedrot: a Goal.enter here breaks things, because the tactic below may + solve goals by side effects, while the compatibility layer keeps those + useless goals. That deserves a FIXME. *) Proofview.V82.tactic begin fun gl -> let clenv, evars = clenv_pose_dependent_evars ~with_evars clenv in let evd' = diff --git a/proofs/logic.ml b/proofs/logic.ml index 15ba0a704f..3581e90b79 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -63,7 +63,7 @@ let catchable_exception = function | CErrors.UserError _ | TypeError _ | Proof.OpenProof _ (* abstract will call close_proof inside a tactic *) - | Notation.NumeralNotationError _ + | Notation.PrimTokenNotationError _ | RefinerError _ | Indrec.RecursionSchemeError _ | Nametab.GlobalizationError _ (* reduction errors *) @@ -373,8 +373,8 @@ let rec mk_refgoals sigma goal goalacc conclty trm = check_typability env sigma ty; let sigma = check_conv_leq_goal env sigma trm ty conclty in let res = mk_refgoals sigma goal goalacc ty t in - (** we keep the casts (in particular VMcast and NATIVEcast) except - when they are annotating metas *) + (* we keep the casts (in particular VMcast and NATIVEcast) except + when they are annotating metas *) if isMeta t then begin assert (k != VMcast && k != NATIVEcast); res diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 886a62cb89..e2b7df19de 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -33,7 +33,7 @@ let () = CErrors.register_handler begin function end let get_nth_V82_goal p i = - let goals,_,_,_,sigma = Proof.proof p in + let Proof.{ sigma; goals } = Proof.data p in try { it = List.nth goals (i-1) ; sigma } with Failure _ -> raise NoSuchGoal @@ -120,7 +120,8 @@ let solve ?with_end_tac gi info_lvl tac pr = let by tac = Proof_global.with_current_proof (fun _ -> solve (Goal_select.SelectNth 1) None tac) let instantiate_nth_evar_com n com = - Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.instantiate_evar n com p) + Proof_global.simple_with_current_proof (fun _ p -> + Proof.V82.instantiate_evar Global.(env ())n com p) (**********************************************************************) @@ -166,51 +167,51 @@ let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = let univs = UState.merge ~sideff:side_eff ~extend:true Evd.univ_rigid univs ctx in cb, status, univs -let refine_by_tactic env sigma ty tac = - (** Save the initial side-effects to restore them afterwards. We set the - current set of side-effects to be empty so that we can retrieve the - ones created during the tactic invocation easily. *) +let refine_by_tactic ~name ~poly env sigma ty tac = + (* Save the initial side-effects to restore them afterwards. We set the + current set of side-effects to be empty so that we can retrieve the + ones created during the tactic invocation easily. *) let eff = Evd.eval_side_effects sigma in let sigma = Evd.drop_side_effects sigma in - (** Save the existing goals *) + (* Save the existing goals *) let prev_future_goals = save_future_goals sigma in - (** Start a proof *) - let prf = Proof.start sigma [env, ty] in + (* Start a proof *) + let prf = Proof.start ~name ~poly sigma [env, ty] in let (prf, _) = try Proof.run_tactic env tac prf with Logic_monad.TacticFailure e as src -> - (** Catch the inner error of the monad tactic *) + (* Catch the inner error of the monad tactic *) let (_, info) = CErrors.push src in iraise (e, info) in - (** Plug back the retrieved sigma *) - let (goals,stack,shelf,given_up,sigma) = Proof.proof prf in + (* Plug back the retrieved sigma *) + let Proof.{ goals; stack; shelf; given_up; sigma; entry } = Proof.data prf in assert (stack = []); - let ans = match Proof.initial_goals prf with + let ans = match Proofview.initial_goals entry with | [c, _] -> c | _ -> assert false in let ans = EConstr.to_constr ~abort_on_undefined_evars:false sigma ans in - (** [neff] contains the freshly generated side-effects *) + (* [neff] contains the freshly generated side-effects *) let neff = Evd.eval_side_effects sigma in - (** Reset the old side-effects *) + (* Reset the old side-effects *) let sigma = Evd.drop_side_effects sigma in let sigma = Evd.emit_side_effects eff sigma in - (** Restore former goals *) + (* Restore former goals *) let sigma = restore_future_goals sigma prev_future_goals in - (** Push remaining goals as future_goals which is the only way we - have to inform the caller that there are goals to collect while - not being encapsulated in the monad *) - (** Goals produced by tactic "shelve" *) + (* Push remaining goals as future_goals which is the only way we + have to inform the caller that there are goals to collect while + not being encapsulated in the monad *) + (* Goals produced by tactic "shelve" *) let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToShelve) shelf sigma in - (** Goals produced by tactic "give_up" *) + (* Goals produced by tactic "give_up" *) let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToGiveUp) given_up sigma in - (** Other goals *) + (* Other goals *) let sigma = List.fold_right Evd.declare_future_goal goals sigma in - (** Get rid of the fresh side-effects by internalizing them in the term - itself. Note that this is unsound, because the tactic may have solved - other goals that were already present during its invocation, so that - those goals rely on effects that are not present anymore. Hopefully, - this hack will work in most cases. *) + (* Get rid of the fresh side-effects by internalizing them in the term + itself. Note that this is unsound, because the tactic may have solved + other goals that were already present during its invocation, so that + those goals rely on effects that are not present anymore. Hopefully, + this hack will work in most cases. *) let ans = Safe_typing.inline_private_constants_in_constr env ans neff in ans, sigma diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 155221947a..5699320af5 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -81,8 +81,13 @@ val build_by_tactic : ?side_eff:bool -> env -> UState.t -> ?poly:polymorphic -> EConstr.types -> unit Proofview.tactic -> constr * bool * UState.t -val refine_by_tactic : env -> Evd.evar_map -> EConstr.types -> unit Proofview.tactic -> - constr * Evd.evar_map +val refine_by_tactic + : name:Id.t + -> poly:bool + -> env -> Evd.evar_map + -> EConstr.types + -> unit Proofview.tactic + -> constr * Evd.evar_map (** A variant of the above function that handles open terms as well. Caveat: all effects are purged in the returned term at the end, but other evars solved by side-effects are NOT purged, so that unexpected failures may diff --git a/proofs/proof.ml b/proofs/proof.ml index 6c13c4946a..1aeb24606b 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -105,22 +105,29 @@ let done_cond ?(loose_end=false) k = CondDone (loose_end,k) (* Subpart of the type of proofs. It contains the parts of the proof which are under control of the undo mechanism *) -type t = { - (* Current focused proofview *) - proofview: Proofview.proofview; - (* Entry for the proofview *) - entry : Proofview.entry; - (* History of the focusings, provides information on how - to unfocus the proof and the extra information stored while focusing. - The list is empty when the proof is fully unfocused. *) - focus_stack: (_focus_condition*focus_info*Proofview.focus_context) list; - (* List of goals that have been shelved. *) - shelf : Goal.goal list; - (* List of goals that have been given up *) - given_up : Goal.goal list; - (* The initial universe context (for the statement) *) - initial_euctx : UState.t -} +type t = + { proofview: Proofview.proofview + (** Current focused proofview *) + ; entry : Proofview.entry + (** Entry for the proofview *) + ; focus_stack: (_focus_condition*focus_info*Proofview.focus_context) list + (** History of the focusings, provides information on how to unfocus + the proof and the extra information stored while focusing. The + list is empty when the proof is fully unfocused. *) + ; shelf : Goal.goal list + (** List of goals that have been shelved. *) + ; given_up : Goal.goal list + (** List of goals that have been given up *) + ; initial_euctx : UState.t + (** The initial universe context (for the statement) *) + ; name : Names.Id.t + (** the name of the theorem whose proof is being constructed *) + ; poly : bool + (** Locality, polymorphism, and "kind" [Coercion, Definition, etc...] *) + } + +let initial_goals pf = Proofview.initial_goals pf.entry +let initial_euctx pf = pf.initial_euctx (*** General proof functions ***) @@ -141,7 +148,7 @@ let proof p = (goals,stack,shelf,given_up,sigma) type 'a pre_goals = { - fg_goals : 'a list; + fg_goals : 'a list; (** List of the focussed goals *) bg_goals : ('a list * 'a list) list; (** Zipper representing the unfocussed background goals *) @@ -311,7 +318,7 @@ let end_of_stack = CondEndStack end_of_stack_kind let unfocused = is_last_focus end_of_stack_kind -let start sigma goals = +let start ~name ~poly sigma goals = let entry, proofview = Proofview.init sigma goals in let pr = { proofview; @@ -320,9 +327,13 @@ let start sigma goals = shelf = [] ; given_up = []; initial_euctx = - Evd.evar_universe_context (snd (Proofview.proofview proofview)) } in + Evd.evar_universe_context (snd (Proofview.proofview proofview)) + ; name + ; poly + } in _focus end_of_stack (Obj.repr ()) 1 (List.length goals) pr -let dependent_start goals = + +let dependent_start ~name ~poly goals = let entry, proofview = Proofview.dependent_init goals in let pr = { proofview; @@ -331,7 +342,10 @@ let dependent_start goals = shelf = [] ; given_up = []; initial_euctx = - Evd.evar_universe_context (snd (Proofview.proofview proofview)) } in + Evd.evar_universe_context (snd (Proofview.proofview proofview)) + ; name + ; poly + } in let number_of_goals = List.length (Proofview.initial_goals pr.entry) in _focus end_of_stack (Obj.repr ()) 1 number_of_goals pr @@ -375,9 +389,6 @@ let return ?pid (p : t) = let p = unfocus end_of_stack_kind p () in Proofview.return p.proofview -let initial_goals p = Proofview.initial_goals p.entry -let initial_euctx p = p.initial_euctx - let compact p = let entry, proofview = Proofview.compact p.entry p.proofview in { p with proofview; entry } @@ -468,7 +479,7 @@ module V82 = struct { p with proofview = Proofview.V82.grab p.proofview } (* Main component of vernac command Existential *) - let instantiate_evar n com pr = + let instantiate_evar env n com pr = let tac = Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma -> let (evk, evi) = @@ -487,7 +498,7 @@ module V82 = struct let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in Proofview.Unsafe.tclEVARS sigma end in - let ((), proofview, _, _) = Proofview.apply (Global.env ()) tac pr.proofview in + let ((), proofview, _, _) = Proofview.apply env tac pr.proofview in let shelf = List.filter begin fun g -> Evd.is_undefined (Proofview.return proofview) g @@ -507,3 +518,37 @@ let all_goals p = let set = add given_up set in let { Evd.it = bgoals ; sigma = bsigma } = V82.background_subgoals p in add bgoals set + +type data = + { sigma : Evd.evar_map + (** A representation of the evar_map [EJGA wouldn't it better to just return the proofview?] *) + ; goals : Evar.t list + (** Focused goals *) + ; entry : Proofview.entry + (** Entry for the proofview *) + ; stack : (Evar.t list * Evar.t list) list + (** A representation of the focus stack *) + ; shelf : Evar.t list + (** A representation of the shelf *) + ; given_up : Evar.t list + (** A representation of the given up goals *) + ; initial_euctx : UState.t + (** The initial universe context (for the statement) *) + ; name : Names.Id.t + (** The name of the theorem whose proof is being constructed *) + ; poly : bool + (** Locality, polymorphism, and "kind" [Coercion, Definition, etc...] *) + } + +let data { proofview; focus_stack; entry; shelf; given_up; initial_euctx; name; poly } = + let goals, sigma = Proofview.proofview proofview in + (* spiwack: beware, the bottom of the stack is used by [Proof] + internally, and should not be exposed. *) + let rec map_minus_one f = function + | [] -> assert false + | [_] -> [] + | a::l -> f a :: (map_minus_one f l) + in + let stack = + map_minus_one (fun (_,_,c) -> Proofview.focus_context c) focus_stack in + { sigma; goals; entry; stack; shelf; given_up; initial_euctx; name; poly } diff --git a/proofs/proof.mli b/proofs/proof.mli index aaabea3454..fd5e905a3b 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -50,27 +50,70 @@ val proof : t -> * Goal.goal list * Goal.goal list * Evd.evar_map +[@@ocaml.deprecated "use [Proof.data]"] + +val initial_goals : t -> (EConstr.constr * EConstr.types) list +[@@ocaml.deprecated "use [Proof.data]"] + +val initial_euctx : t -> UState.t +[@@ocaml.deprecated "use [Proof.data]"] + +type data = + { sigma : Evd.evar_map + (** A representation of the evar_map [EJGA wouldn't it better to just return the proofview?] *) + ; goals : Evar.t list + (** Focused goals *) + ; entry : Proofview.entry + (** Entry for the proofview *) + ; stack : (Evar.t list * Evar.t list) list + (** A representation of the focus stack *) + ; shelf : Evar.t list + (** A representation of the shelf *) + ; given_up : Evar.t list + (** A representation of the given up goals *) + ; initial_euctx : UState.t + (** The initial universe context (for the statement) *) + ; name : Names.Id.t + (** The name of the theorem whose proof is being constructed *) + ; poly : bool; + (** polymorphism *) + } + +val data : t -> data (* Generic records structured like the return type of proof *) type 'a pre_goals = { fg_goals : 'a list; + [@ocaml.deprecated "use [Proof.data]"] (** List of the focussed goals *) bg_goals : ('a list * 'a list) list; + [@ocaml.deprecated "use [Proof.data]"] (** Zipper representing the unfocussed background goals *) shelved_goals : 'a list; + [@ocaml.deprecated "use [Proof.data]"] (** List of the goals on the shelf. *) given_up_goals : 'a list; + [@ocaml.deprecated "use [Proof.data]"] (** List of the goals that have been given up *) } +[@@ocaml.deprecated "use [Proof.data]"] -val map_structured_proof : t -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals) - +(* needed in OCaml 4.05.0, not needed in newer ones *) +[@@@ocaml.warning "-3"] +val map_structured_proof : t -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals) [@ocaml.warning "-3"] +[@@ocaml.deprecated "use [Proof.data]"] +[@@@ocaml.warning "+3"] (*** General proof functions ***) -val start : Evd.evar_map -> (Environ.env * EConstr.types) list -> t -val dependent_start : Proofview.telescope -> t -val initial_goals : t -> (EConstr.constr * EConstr.types) list -val initial_euctx : t -> UState.t +val start + : name:Names.Id.t + -> poly:bool + -> Evd.evar_map -> (Environ.env * EConstr.types) list -> t + +val dependent_start + : name:Names.Id.t + -> poly:bool + -> Proofview.telescope -> t (* Returns [true] if the considered proof is completed, that is if no goal remain to be considered (this does not require that all evars have been solved). *) @@ -177,8 +220,9 @@ val no_focused_goal : t -> bool (* the returned boolean signal whether an unsafe tactic has been used. In which case it is [false]. *) -val run_tactic : Environ.env -> - unit Proofview.tactic -> t -> t * (bool*Proofview_monad.Info.tree) +val run_tactic + : Environ.env + -> unit Proofview.tactic -> t -> t * (bool*Proofview_monad.Info.tree) val maximal_unfocus : 'a focus_kind -> t -> t @@ -208,7 +252,8 @@ module V82 : sig val grab_evars : t -> t (* Implements the Existential command *) - val instantiate_evar : int -> Constrexpr.constr_expr -> t -> t + val instantiate_evar : + Environ.env -> int -> Constrexpr.constr_expr -> t -> t end (* returns the set of all goals in the proof *) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 67e19df0e7..8077da8807 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -90,14 +90,13 @@ type proof_terminator = proof_ending -> unit type closed_proof = proof_object * proof_terminator type pstate = { - pid : Id.t; (* the name of the theorem whose proof is being constructed *) terminator : proof_terminator CEphemeron.key; endline_tactic : Genarg.glob_generic_argument option; section_vars : Constr.named_context option; proof : Proof.t; - strength : Decl_kinds.goal_kind; mode : proof_mode CEphemeron.key; universe_decl: UState.universe_decl; + strength : Decl_kinds.goal_kind; } type t = pstate list @@ -142,7 +141,7 @@ end (*** Proof Global manipulation ***) let get_all_proof_names () = - List.map (function { pid = id } -> id) !pstates + List.map Proof.(function pf -> (data pf.proof).name) !pstates let cur_pstate () = match !pstates with @@ -151,7 +150,7 @@ let cur_pstate () = let give_me_the_proof () = (cur_pstate ()).proof let give_me_the_proof_opt () = try Some (give_me_the_proof ()) with | NoCurrentProof -> None -let get_current_proof_name () = (cur_pstate ()).pid +let get_current_proof_name () = (Proof.data (cur_pstate ()).proof).Proof.name let with_current_proof f = match !pstates with @@ -205,8 +204,12 @@ let check_no_pending_proof () = str"Use \"Abort All\" first or complete proof(s).") end +let pf_name_eq id ps = + let Proof.{ name } = Proof.data ps.proof in + Id.equal name id + let discard_gen id = - pstates := List.filter (fun { pid = id' } -> not (Id.equal id id')) !pstates + pstates := List.filter (fun pf -> not (pf_name_eq id pf)) !pstates let discard {CAst.loc;v=id} = let n = List.length !pstates in @@ -223,9 +226,9 @@ let discard_all () = pstates := [] (* [set_proof_mode] sets the proof mode to be used after it's called. It is typically called by the Proof Mode command. *) let set_proof_mode m id = - pstates := - List.map (function { pid = id' } as p -> - if Id.equal id' id then { p with mode = m } else p) !pstates; + pstates := List.map + (fun ps -> if pf_name_eq id ps then { ps with mode = m } else ps) + !pstates; update_proof_mode () let set_proof_mode mn = @@ -244,28 +247,26 @@ let disactivate_current_proof_mode () = end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -let start_proof sigma id ?(pl=UState.default_univ_decl) str goals terminator = +let start_proof sigma name ?(pl=UState.default_univ_decl) kind goals terminator = let initial_state = { - pid = id; terminator = CEphemeron.create terminator; - proof = Proof.start sigma goals; + proof = Proof.start ~name ~poly:(pi2 kind) sigma goals; endline_tactic = None; section_vars = None; - strength = str; mode = find_proof_mode "No"; - universe_decl = pl } in + universe_decl = pl; + strength = kind } in push initial_state pstates -let start_dependent_proof id ?(pl=UState.default_univ_decl) str goals terminator = +let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals terminator = let initial_state = { - pid = id; terminator = CEphemeron.create terminator; - proof = Proof.dependent_start goals; + proof = Proof.dependent_start ~name ~poly:(pi2 kind) goals; endline_tactic = None; section_vars = None; - strength = str; mode = find_proof_mode "No"; - universe_decl = pl } in + universe_decl = pl; + strength = kind } in push initial_state pstates let get_used_variables () = (cur_pstate ()).section_vars @@ -301,10 +302,10 @@ let set_used_variables l = ctx, [] let get_open_goals () = - let gl, gll, shelf , _ , _ = Proof.proof (cur_pstate ()).proof in - List.length gl + + let Proof.{ goals; stack; shelf } = Proof.data (cur_pstate ()).proof in + List.length goals + List.fold_left (+) 0 - (List.map (fun (l1,l2) -> List.length l1 + List.length l2) gll) + + (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + List.length shelf type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * UState.t @@ -323,12 +324,9 @@ let private_poly_univs = let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now (fpl : closed_proof_output Future.computation) = - let { pid; section_vars; strength; proof; terminator; universe_decl } = - cur_pstate () in + let { section_vars; proof; terminator; universe_decl; strength } = cur_pstate () in + let Proof.{ name; poly; entry; initial_euctx } = Proof.data proof in let opaque = match opaque with Opaque -> true | Transparent -> false in - let poly = pi2 strength (* Polymorphic *) in - let initial_goals = Proof.initial_goals proof in - let initial_euctx = Proof.initial_euctx proof in let constrain_variables ctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) ctx in @@ -411,30 +409,31 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now const_entry_opaque = opaque; const_entry_universes = univs; } in - let entries = Future.map2 entry_fn fpl initial_goals in - { id = pid; entries = entries; persistence = strength; + let entries = Future.map2 entry_fn fpl Proofview.(initial_goals entry) in + { id = name; entries = entries; persistence = strength; universes }, fun pr_ending -> CEphemeron.get terminator pr_ending let return_proof ?(allow_partial=false) () = - let { pid; proof; strength = (_,poly,_) } = cur_pstate () in + let { proof } = cur_pstate () in if allow_partial then begin let proofs = Proof.partial_proof proof in - let _,_,_,_, evd = Proof.proof proof in + let Proof.{sigma=evd} = Proof.data proof in let eff = Evd.eval_side_effects evd in - (** ppedrot: FIXME, this is surely wrong. There is no reason to duplicate - side-effects... This may explain why one need to uniquize side-effects - thereafter... *) + (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate + side-effects... This may explain why one need to uniquize side-effects + thereafter... *) let proofs = List.map (fun c -> EConstr.Unsafe.to_constr c, eff) proofs in proofs, Evd.evar_universe_context evd end else - let initial_goals = Proof.initial_goals proof in + let Proof.{name=pid;entry} = Proof.data proof in + let initial_goals = Proofview.initial_goals entry in let evd = Proof.return ~pid proof in let eff = Evd.eval_side_effects evd in let evd = Evd.minimize_universes evd in - (** ppedrot: FIXME, this is surely wrong. There is no reason to duplicate - side-effects... This may explain why one need to uniquize side-effects - thereafter... *) + (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate + side-effects... This may explain why one need to uniquize side-effects + thereafter... *) let proofs = List.map (fun (c, _) -> (EConstr.to_constr evd c, eff)) initial_goals in proofs, Evd.evar_universe_context evd @@ -455,25 +454,23 @@ let set_terminator hook = module V82 = struct let get_current_initial_conclusions () = - let { pid; strength; proof } = cur_pstate () in - let initial = Proof.initial_goals proof in + let { proof; strength } = cur_pstate () in + let Proof.{ name; entry } = Proof.data proof in + let initial = Proofview.initial_goals entry in let goals = List.map (fun (o, c) -> c) initial in - pid, (goals, strength) + name, (goals, strength) end let freeze ~marshallable = - match marshallable with - | `Yes -> - CErrors.anomaly (Pp.str"full marshalling of proof state not supported.") - | `Shallow -> !pstates - | `No -> !pstates + if marshallable then CErrors.anomaly (Pp.str"full marshalling of proof state not supported.") + else !pstates let unfreeze s = pstates := s; update_proof_mode () let proof_of_state = function { proof }::_ -> proof | _ -> raise NoCurrentProof let copy_terminators ~src ~tgt = assert(List.length src = List.length tgt); List.map2 (fun op p -> { p with terminator = op.terminator }) src tgt -let update_global_env () = +let update_global_env pf_info = with_current_proof (fun _ p -> Proof.in_proof p (fun sigma -> let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index d9c32cf9d5..9e904c57aa 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -135,7 +135,7 @@ module V82 : sig Decl_kinds.goal_kind) end -val freeze : marshallable:[`Yes | `No | `Shallow] -> t +val freeze : marshallable:bool -> t val unfreeze : t -> unit val proof_of_state : t -> Proof.t val copy_terminators : src:t -> tgt:t -> t diff --git a/proofs/refine.ml b/proofs/refine.ml index 540a8bb420..d812a8cad7 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -27,7 +27,7 @@ let extract_prefix env info = let typecheck_evar ev env sigma = let info = Evd.find sigma ev in - (** Typecheck the hypotheses. *) + (* Typecheck the hypotheses. *) let type_hyp (sigma, env) decl = let t = NamedDecl.get_type decl in let sigma, _ = Typing.sort_of env sigma t in @@ -40,7 +40,7 @@ let typecheck_evar ev env sigma = let (common, changed) = extract_prefix env info in let env = Environ.reset_with_named_context (EConstr.val_of_named_context common) env in let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in - (** Typecheck the conclusion *) + (* Typecheck the conclusion *) let sigma, _ = Typing.sort_of env sigma (Evd.evar_concl info) in sigma @@ -60,39 +60,39 @@ let generic_refine ~typecheck f gl = let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let state = Proofview.Goal.state gl in - (** Save the [future_goals] state to restore them after the - refinement. *) + (* Save the [future_goals] state to restore them after the + refinement. *) let prev_future_goals = Evd.save_future_goals sigma in - (** Create the refinement term *) + (* Create the refinement term *) 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.save_future_goals sigma in - (** Redo the effects in sigma in the monad's env *) + (* Redo the effects in sigma in the monad's env *) let privates_csts = Evd.eval_side_effects sigma in let sideff = Safe_typing.side_effects_of_private_constants privates_csts in let env = add_side_effects env sideff in - (** Check that the introduced evars are well-typed *) + (* Check that the introduced evars are well-typed *) let fold accu ev = typecheck_evar ev env accu in let sigma = if typecheck then Evd.fold_future_goals fold sigma evs else sigma in - (** Check that the refined term is typesafe *) + (* Check that the refined term is typesafe *) let sigma = if typecheck then Typing.check env sigma c concl else sigma in - (** Check that the goal itself does not appear in the refined term *) + (* Check that the goal itself does not appear in the refined term *) let self = Proofview.Goal.goal gl in let _ = if not (Evarutil.occur_evar_upto sigma self c) then () else Pretype_errors.error_occur_check env sigma self c in - (** Restore the [future goals] state. *) + (* Restore the [future goals] state. *) let sigma = Evd.restore_future_goals sigma prev_future_goals in - (** Select the goals *) + (* Select the goals *) let evs = Evd.map_filter_future_goals (Proofview.Unsafe.advance sigma) evs in let comb,shelf,given_up,evkmain = Evd.dispatch_future_goals evs in - (** Proceed to the refinement *) + (* Proceed to the refinement *) let sigma = match Proofview.Unsafe.advance sigma self with | None -> - (** Nothing to do, the goal has been solved by side-effect *) + (* Nothing to do, the goal has been solved by side-effect *) sigma | Some self -> match evkmain with @@ -104,7 +104,7 @@ let generic_refine ~typecheck f gl = | None -> sigma | Some id -> Evd.rename evk id sigma in - (** Mark goals *) + (* Mark goals *) let sigma = Proofview.Unsafe.mark_as_goals sigma comb in let comb = CList.map (fun x -> Proofview.goal_with_state x state) comb in let trace () = Pp.(hov 2 (str"simple refine"++spc()++ diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index eed68b058b..df90354717 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -127,7 +127,7 @@ module New = struct f { Evd.it = Proofview.Goal.goal gl ; sigma = project gl; } let pf_global id gl = - (** We only check for the existence of an [id] in [hyps] *) + (* We only check for the existence of an [id] in [hyps] *) let hyps = Proofview.Goal.hyps gl in Constrintern.construct_reference hyps id @@ -143,12 +143,12 @@ module New = struct let pf_conv_x gl t1 t2 = pf_apply is_conv gl t1 t2 let pf_ids_of_hyps gl = - (** We only get the identifiers in [hyps] *) + (* We only get the identifiers in [hyps] *) let hyps = Proofview.Goal.hyps gl in ids_of_named_context hyps let pf_ids_set_of_hyps gl = - (** We only get the identifiers in [hyps] *) + (* We only get the identifiers in [hyps] *) let env = Proofview.Goal.env gl in Environ.ids_of_named_context_val (Environ.named_context_val env) @@ -180,7 +180,7 @@ module New = struct List.hd hyps let pf_nf_concl (gl : Proofview.Goal.t) = - (** We normalize the conclusion just after *) + (* We normalize the conclusion just after *) let concl = Proofview.Goal.concl gl in let sigma = project gl in nf_evar sigma concl diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 94e04d1842..51166cf238 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -60,7 +60,7 @@ module Make(T : Task) () = struct type request = Request of T.request type more_data = - | MoreDataUnivLevel of UnivGen.universe_id list + | MoreDataUnivLevel of UnivGen.univ_unique_id list let slave_respond (Request r) = let res = T.perform r in diff --git a/stm/asyncTaskQueue.mli b/stm/asyncTaskQueue.mli index 6e6827c73f..067ea5df0c 100644 --- a/stm/asyncTaskQueue.mli +++ b/stm/asyncTaskQueue.mli @@ -70,6 +70,7 @@ module type Task = sig (** UID of the task kind, for -toploop *) val name : string ref + (** Extra arguments of the task kind, for -toploop *) val extra_env : unit -> string array diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index b8af2bcd56..230a3207a8 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -49,12 +49,12 @@ let is_focused_goal_simple ~doc id = match state_of_id ~doc id with | `Expired | `Error _ | `Valid None -> `Not | `Valid (Some { Vernacstate.proof }) -> - let proof = Proof_global.proof_of_state proof in - let focused, r1, r2, r3, sigma = Proof.proof proof in - let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in - if List.for_all (fun x -> simple_goal sigma x rest) focused - then `Simple focused - else `Not + let proof = Proof_global.proof_of_state proof in + let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in + let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in + if List.for_all (fun x -> simple_goal sigma x rest) focused + then `Simple focused + else `Not type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ] diff --git a/stm/stm.ml b/stm/stm.ml index 3444229735..c84721bcb5 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -78,7 +78,7 @@ let async_proofs_is_master opt = (* Protect against state changes *) let stm_purify f x = - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in try let res = f x in Vernacstate.unfreeze_interp_state st; @@ -343,7 +343,7 @@ module VCS : sig val set_ldir : Names.DirPath.t -> unit val get_ldir : unit -> Names.DirPath.t - val is_interactive : unit -> [`Yes | `No | `Shallow] + val is_interactive : unit -> bool val is_vio_doc : unit -> bool val current_branch : unit -> Branch.t @@ -543,8 +543,8 @@ end = struct (* {{{ *) let is_interactive () = match !doc_type with - | Interactive _ -> `Yes - | _ -> `No + | Interactive _ -> true + | _ -> false let is_vio_doc () = match !doc_type with @@ -632,13 +632,20 @@ end = struct (* {{{ *) " to "^Stateid.to_string block_stop^".")) in aux block_stop + (* [slice] copies a slice of the DAG, keeping only the last known valid state. + When it copies a state, it drops the libobjects and keeps only the structure. *) let slice ~block_start ~block_stop = let l = nodes_in_slice ~block_start ~block_stop in let copy_info v id = Vcs_.set_info v id { (get_info id) with state = Empty; vcs_backup = None,None } in + let make_shallow = function + | Valid st -> Valid (Vernacstate.make_shallow st) + | x -> x + in let copy_info_w_state v id = - Vcs_.set_info v id { (get_info id) with vcs_backup = None,None } in + let info = get_info id in + Vcs_.set_info v id { info with state = make_shallow info.state; vcs_backup = None,None } in let copy_proof_blockes v = let nodes = Vcs_.Dag.all_nodes (Vcs_.dag v) in let props = @@ -750,7 +757,7 @@ end = struct (* {{{ *) end let print ?(now=false) () = - if not !Flags.debug && not now then () else NB.command ~now (print_dag !vcs) + if !Flags.debug then NB.command ~now (print_dag !vcs) let backup () = !vcs let restore v = vcs := v @@ -776,14 +783,14 @@ module State : sig val define : doc:doc -> ?safe_id:Stateid.t -> - ?redefine:bool -> ?cache:Summary.marshallable -> + ?redefine:bool -> ?cache:bool -> ?feedback_processed:bool -> (unit -> unit) -> Stateid.t -> unit val fix_exn_ref : (Exninfo.iexn -> Exninfo.iexn) ref val install_cached : Stateid.t -> unit - val is_cached : ?cache:Summary.marshallable -> Stateid.t -> bool - val is_cached_and_valid : ?cache:Summary.marshallable -> Stateid.t -> bool + val is_cached : ?cache:bool -> Stateid.t -> bool + val is_cached_and_valid : ?cache:bool -> Stateid.t -> bool val exn_on : Stateid.t -> valid:Stateid.t -> Exninfo.iexn -> Exninfo.iexn @@ -832,16 +839,15 @@ end = struct (* {{{ *) Summary.project_from_summary st Util.(pi2 summary_pstate), Summary.project_from_summary st Util.(pi3 summary_pstate) - let freeze marshallable id = - VCS.set_state id (Valid (Vernacstate.freeze_interp_state marshallable)) + let freeze ~marshallable id = + VCS.set_state id (Valid (Vernacstate.freeze_interp_state ~marshallable)) let freeze_invalid id iexn = VCS.set_state id (Error iexn) - let is_cached ?(cache=`No) id only_valid = + let is_cached ?(cache=false) id only_valid = if Stateid.equal id !cur_id then try match VCS.get_info id with - | { state = Empty } when cache = `Yes -> freeze `No id; true - | { state = Empty } when cache = `Shallow -> freeze `Shallow id; true + | { state = Empty } when cache -> freeze ~marshallable:false id; true | _ -> true with VCS.Expired -> false else @@ -866,7 +872,7 @@ end = struct (* {{{ *) | _ -> (* coqc has a 1 slot cache and only for valid states *) - if VCS.is_interactive () = `No && Stateid.equal id !cur_id then () + if not (VCS.is_interactive ()) && Stateid.equal id !cur_id then () else anomaly Pp.(str "installing a non cached state.") let get_cached id = @@ -924,7 +930,7 @@ end = struct (* {{{ *) let e2 = Summary.project_from_summary s2 Global.global_env_summary_tag in e1 == e2 - let define ~doc ?safe_id ?(redefine=false) ?(cache=`No) ?(feedback_processed=true) + let define ~doc ?safe_id ?(redefine=false) ?(cache=false) ?(feedback_processed=true) f id = feedback ~id:id (ProcessingIn !Flags.async_proofs_worker_id); @@ -933,13 +939,12 @@ end = struct (* {{{ *) anomaly Pp.(str"defining state "++str str_id++str" twice."); try stm_prerr_endline (fun () -> "defining "^str_id^" (cache="^ - if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)"); + if cache then "Y)" else "N)"); let good_id = match safe_id with None -> !cur_id | Some id -> id in fix_exn_ref := exn_on id ~valid:good_id; f (); fix_exn_ref := (fun x -> x); - if cache = `Yes then freeze `No id - else if cache = `Shallow then freeze `Shallow id; + if cache then freeze ~marshallable:false id; stm_prerr_endline (fun () -> "setting cur id to "^str_id); cur_id := id; if feedback_processed then @@ -958,14 +963,14 @@ end = struct (* {{{ *) | None, Some good_id -> (exn_on id ~valid:good_id (e, info)) | Some _, None -> (e, info) | Some (_,at), Some id -> (e, Stateid.add info ~valid:id at) in - if cache = `Yes || cache = `Shallow then freeze_invalid id ie; + if cache then freeze_invalid id ie; Hooks.(call unreachable_state ~doc id ie); Exninfo.iraise ie let init_state = ref None let register_root_state () = - init_state := Some (Vernacstate.freeze_interp_state `No) + init_state := Some (Vernacstate.freeze_interp_state ~marshallable:false) let restore_root_state () = cur_id := Stateid.dummy; @@ -1087,7 +1092,7 @@ let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacstate.t (stm_pperr_endline Pp.(fun () -> str "ignoring " ++ Ppvernac.pr_vernac expr); st) else match cmd with - | VernacShow ShowScript -> ShowScript.show_script (); st (** XX we are ignoring control here *) + | VernacShow ShowScript -> ShowScript.show_script (); st (* XX we are ignoring control here *) | _ -> stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st (CAst.make ?loc expr) @@ -1178,7 +1183,7 @@ end = struct (* {{{ *) | _ -> None let undo_vernac_classifier v ~doc = - if VCS.is_interactive () = `No && !cur_opt.async_proofs_cache <> Some Force + if not (VCS.is_interactive ()) && !cur_opt.async_proofs_cache <> Some Force then undo_costly_in_batch_mode v; try match Vernacprop.under_control v with @@ -1508,9 +1513,7 @@ end = struct (* {{{ *) let build_proof_here ~doc ?loc ~drop_pt (id,valid) eop = Future.create (State.exn_on id ~valid) (fun () -> let wall_clock1 = Unix.gettimeofday () in - if VCS.is_interactive () = `No - then Reach.known_state ~doc ~cache:`No eop - else Reach.known_state ~doc ~cache:`Shallow eop; + Reach.known_state ~doc ~cache:(VCS.is_interactive ()) eop; let wall_clock2 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc "proof_build_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); @@ -1532,7 +1535,7 @@ end = struct (* {{{ *) * a bad fixpoint *) let fix_exn = Future.fix_exn_of future_proof in (* STATE: We use the current installed imperative state *) - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in if not drop then begin let checked_proof = Future.chain future_proof (fun p -> let opaque = Proof_global.Opaque in @@ -1545,7 +1548,7 @@ end = struct (* {{{ *) let terminator = (* The one sent by master is an InvalidKey *) Lemmas.(standard_proof_terminator []) in - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_vernac_interp stop ~proof:(pobject, terminator) st { verbose = false; loc; indentation = 0; strlen = 0; @@ -1676,7 +1679,7 @@ end = struct (* {{{ *) with VCS.Expired -> cur in aux stop in try - Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:`No stop; + Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false stop; if drop then let _proof = Proof_global.return_proof ~allow_partial:true () in `OK_ADMITTED @@ -1689,14 +1692,14 @@ end = struct (* {{{ *) Proof_global.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) - Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:`No start; + Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false start; (* STATE SPEC: * - start: First non-expired state! [This looks very fishy] * - end : start + qed * => takes nothing from the itermediate states. *) (* STATE We use the state resulting from reaching start. *) - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp stop ~proof st { verbose = false; loc; indentation = 0; strlen = 0; expr = VernacExpr ([], VernacEndProof (Proved (opaque,None))) }); @@ -1750,7 +1753,7 @@ end = struct (* {{{ *) let uc = Option.get (Opaqueproof.get_constraints (Global.opaque_tables ()) o) in - (** We only manipulate monomorphic terms here. *) + (* We only manipulate monomorphic terms here. *) let map (c, ctx) = assert (Univ.AUContext.is_empty ctx); c in let pr = Future.from_val (map (Option.get (Global.body_of_constant_body c))) in @@ -1934,9 +1937,9 @@ end = struct (* {{{ *) let perform { r_state = id; r_state_fb; r_document = vcs; r_ast; r_goal } = Option.iter VCS.restore vcs; try - Reach.known_state ~doc:dummy_doc (* XXX should be vcs *) ~cache:`No id; + Reach.known_state ~doc:dummy_doc (* XXX should be vcs *) ~cache:false id; stm_purify (fun () -> - let _,_,_,_,sigma0 = Proof.proof (Proof_global.give_me_the_proof ()) in + let Proof.{sigma=sigma0} = Proof.data (Proof_global.give_me_the_proof ()) in let g = Evd.find sigma0 r_goal in let is_ground c = Evarutil.is_ground_term sigma0 c in if not ( @@ -1955,9 +1958,9 @@ end = struct (* {{{ *) * => captures state id in a future closure, which will discard execution state but for the proof + univs. *) - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp r_state_fb st ast); - let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in + let Proof.{sigma} = Proof.data (Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> RespNoProgress | Evd.Evar_defined t -> @@ -1994,12 +1997,12 @@ end = struct (* {{{ *) | VernacFail e -> find ~time ~batch ~fail:true e | e -> e, time, batch, fail in find ~time:false ~batch:false ~fail:false e in - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in Vernacentries.with_fail st fail (fun () -> (if time then System.with_time ~batch else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> Proof_global.with_current_proof (fun _ p -> - let goals, _, _, _, _ = Proof.proof p in + let Proof.{goals} = Proof.data p in let open TacTask in let res = CList.map_i (fun i g -> let f, assign = @@ -2089,9 +2092,9 @@ end = struct (* {{{ *) let perform { r_where; r_doc; r_what; r_for } = VCS.restore r_doc; VCS.print (); - Reach.known_state ~doc:dummy_doc (* XXX should be r_doc *) ~cache:`No r_where; + Reach.known_state ~doc:dummy_doc (* XXX should be r_doc *) ~cache:false r_where; (* STATE *) - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in try (* STATE SPEC: * - start: r_where @@ -2133,14 +2136,14 @@ end (* }}} *) and Reach : sig val known_state : - doc:doc -> ?redefine_qed:bool -> cache:Summary.marshallable -> + doc:doc -> ?redefine_qed:bool -> cache:bool -> Stateid.t -> unit end = struct (* {{{ *) let async_policy () = - if Attributes.is_universe_polymorphism () then false - else if VCS.is_interactive () = `Yes then + if Attributes.is_universe_polymorphism () then false (* FIXME this makes no sense, it is the default value of the attribute *) + else if VCS.is_interactive () then (async_proofs_is_master !cur_opt || !cur_opt.async_proofs_mode = APonLazy) else (VCS.is_vio_doc () || !cur_opt.async_proofs_mode <> APoff) @@ -2322,7 +2325,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = * - end : maybe after recovery command. *) (* STATE: We use an updated state with proof *) - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in Option.iter (fun expr -> ignore(stm_vernac_interp id st { verbose = true; loc = None; expr; indentation = 0; strlen = 0 } )) @@ -2358,11 +2361,11 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = (* ugly functions to process nested lemmas, i.e. hard to reproduce * side effects *) let cherry_pick_non_pstate () = - let st = Summary.freeze_summaries ~marshallable:`No in + let st = Summary.freeze_summaries ~marshallable:false in let st = Summary.remove_from_summary st Util.(pi1 summary_pstate) in let st = Summary.remove_from_summary st Util.(pi2 summary_pstate) in let st = Summary.remove_from_summary st Util.(pi3 summary_pstate) in - st, Lib.freeze ~marshallable:`No in + st, Lib.freeze ~marshallable:false in let inject_non_pstate (s,l) = Summary.unfreeze_summaries ~partial:true s; Lib.unfreeze l; update_global_env () @@ -2393,7 +2396,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | `Cmd { cast = x; cqueue = `TacQueue (solve,abstract,cancel_switch); cblock } -> (fun () -> resilient_tactic id cblock (fun () -> - reach ~cache:`Shallow view.next; + reach ~cache:true view.next; Partac.vernac_interp ~solve ~abstract ~cancel_switch !cur_opt.async_proofs_n_tacworkers view.next id x) ), cache, true @@ -2406,39 +2409,39 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = resilient_tactic id cblock (fun () -> reach view.next; (* State resulting from reach *) - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x) ); if eff then update_global_env () - ), (if eff then `Yes else cache), true + ), eff || cache, true | `Cmd { cast = x; ceff = eff } -> (fun () -> (match !cur_opt.async_proofs_mode with | APon | APonLazy -> resilient_command reach view.next | APoff -> reach view.next); - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); if eff then update_global_env () - ), (if eff then `Yes else cache), true + ), eff || cache, true | `Fork ((x,_,_,_), None) -> (fun () -> resilient_command reach view.next; - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); wall_clock_last_fork := Unix.gettimeofday () - ), `Yes, true + ), true, true | `Fork ((x,_,_,_), Some prev) -> (fun () -> (* nested proof *) - reach ~cache:`Shallow prev; + reach ~cache:true prev; reach view.next; (try - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); with e when CErrors.noncritical e -> let (e, info) = CErrors.push e in let info = Stateid.add info ~valid:prev id in Exninfo.iraise (e, info)); wall_clock_last_fork := Unix.gettimeofday () - ), `Yes, true + ), true, true | `Qed ({ qast = x; keep; brinfo; brname } as qed, eop) -> let rec aux = function | `ASync (block_start, nodes, name, delegate) -> (fun () -> @@ -2468,7 +2471,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = State.install_cached id | { VCS.kind = `Proof _ }, Some _ -> assert false | { VCS.kind = `Proof _ }, None -> - reach ~cache:`Shallow block_start; + reach ~cache:true block_start; let fp, cancel = if delegate then Slaves.build_proof ~doc @@ -2487,19 +2490,19 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = Proof_global.close_future_proof ~opaque ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id ~proof st x); feedback ~id:id Incomplete | { VCS.kind = `Master }, _ -> assert false end; Proof_global.discard_all () - ), (if redefine_qed then `No else `Yes), true + ), not redefine_qed, true | `Sync (name, `Immediate) -> (fun () -> reach eop; - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); Proof_global.discard_all () - ), `Yes, true + ), true, true | `Sync (name, reason) -> (fun () -> log_processing_sync id name reason; reach eop; @@ -2523,25 +2526,25 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = if keep <> VtKeep VtKeepAxiom then reach view.next; let wall_clock2 = Unix.gettimeofday () in - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id ?proof st x); let wall_clock3 = Unix.gettimeofday () in 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 + ), true, true | `MaybeASync (start, nodes, name, delegate) -> (fun () -> - reach ~cache:`Shallow start; + reach ~cache:true start; (* no sections *) if CList.is_empty (Environ.named_context (Global.env ())) then Util.pi1 (aux (`ASync (start, nodes, name, delegate))) () else Util.pi1 (aux (`Sync (name, `NoPU_NoHint_NoES))) () - ), (if redefine_qed then `No else `Yes), true + ), not redefine_qed, true in aux (collect_proof keep (view.next, x) brname brinfo eop) | `Sideff (ReplayCommand x,_) -> (fun () -> reach view.next; - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); update_global_env () ), cache, true @@ -2551,8 +2554,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = ), cache, true in let cache_step = - if !cur_opt.async_proofs_cache = Some Force then `Yes - else cache_step in + !cur_opt.async_proofs_cache = Some Force || cache_step + in State.define ~doc ?safe_id ~cache:cache_step ~redefine:redefine_qed ~feedback_processed step id; stm_prerr_endline (fun () -> "reached: "^ Stateid.to_string id) in @@ -2671,7 +2674,7 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = load_objs require_libs; (* We record the state at this point! *) - State.define ~doc ~cache:`Yes ~redefine:true (fun () -> ()) Stateid.initial; + State.define ~doc ~cache:true ~redefine:true (fun () -> ()) Stateid.initial; Backtrack.record (); Slaves.init (); if async_proofs_is_master !cur_opt then begin @@ -2715,7 +2718,7 @@ let finish ~doc = ); doc let wait ~doc = - let doc = finish ~doc in + let doc = observe ~doc (VCS.get_branch_pos VCS.Branch.master) in Slaves.wait_all_done (); VCS.print (); doc @@ -2729,12 +2732,29 @@ let rec join_admitted_proofs id = join_admitted_proofs view.next | _ -> join_admitted_proofs view.next +(* Error resiliency may have tolerated some broken commands *) +let rec check_no_err_states ~doc visited id = + let open Stateid in + if Set.mem id visited then visited else + match state_of_id ~doc id with + | `Error e -> raise e + | _ -> + let view = VCS.visit id in + match view.step with + | `Qed(_,id) -> + let visited = check_no_err_states ~doc (Set.add id visited) id in + check_no_err_states ~doc visited view.next + | _ -> check_no_err_states ~doc (Set.add id visited) view.next + let join ~doc = let doc = wait ~doc in stm_prerr_endline (fun () -> "Joining the environment"); Global.join_safe_environment (); stm_prerr_endline (fun () -> "Joining Admitted proofs"); - join_admitted_proofs (VCS.get_branch_pos (VCS.current_branch ())); + join_admitted_proofs (VCS.get_branch_pos VCS.Branch.master); + stm_prerr_endline (fun () -> "Checking no error states"); + ignore(check_no_err_states ~doc (Stateid.Set.singleton Stateid.initial) + (VCS.get_branch_pos VCS.Branch.master)); VCS.print (); doc @@ -2785,7 +2805,7 @@ let merge_proof_branch ~valid ?id qast keep brname = VCS.rewrite_merge qed_id ~ours:(Qed (qed ofp)) ~at:master_id brname; VCS.delete_branch brname; VCS.gc (); - let _st : unit = Reach.known_state ~doc:dummy_doc (* XXX should be taken in input *) ~redefine_qed:true ~cache:`No qed_id in + let _st : unit = Reach.known_state ~doc:dummy_doc (* XXX should be taken in input *) ~redefine_qed:true ~cache:false qed_id in VCS.checkout VCS.Branch.master; `Unfocus qed_id | { VCS.kind = `Master } -> @@ -2957,12 +2977,12 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in let id = VCS.new_node ~id:newtip () in let head_id = VCS.get_branch_pos head in - let _st : unit = Reach.known_state ~doc ~cache:`Yes head_id in (* ensure it is ok *) + let _st : unit = Reach.known_state ~doc ~cache:true head_id in (* ensure it is ok *) let step () = VCS.checkout VCS.Branch.master; let mid = VCS.get_branch_pos VCS.Branch.master in let _st' : unit = Reach.known_state ~doc ~cache:(VCS.is_interactive ()) mid in - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); (* Vernac x may or may not start a proof *) if not in_proof && Proof_global.there_are_pending_proofs () then @@ -2987,7 +3007,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) end; VCS.checkout_shallowest_proof_branch (); end in - State.define ~doc ~safe_id:head_id ~cache:`Yes step id; + State.define ~doc ~safe_id:head_id ~cache:true step id; Backtrack.record (); `Ok | VtUnknown, VtLater -> @@ -3116,7 +3136,7 @@ type focus = { let query ~doc ~at ~route s = stm_purify (fun s -> if Stateid.equal at Stateid.dummy then ignore(finish ~doc:dummy_doc) - else Reach.known_state ~doc ~cache:`Yes at; + else Reach.known_state ~doc ~cache:true at; try while true do let { CAst.loc; v=ast } = parse_sentence ~doc at s in diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 3c262de910..3a687a6b41 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -76,7 +76,7 @@ let shrink_entry sign const = | None -> assert false | Some t -> t in - (** The body has been forced by the call to [build_constant_by_tactic] *) + (* The body has been forced by the call to [build_constant_by_tactic] *) let () = assert (Future.is_over const.const_entry_body) in let ((body, uctx), eff) = Future.force const.const_entry_body in let (body, typ, ctx) = decompose (List.length sign) body typ [] in @@ -140,18 +140,18 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = let cd = Entries.DefinitionEntry { const with Entries.const_entry_opaque = opaque } in let decl = (cd, if opaque then IsProof Lemma else IsDefinition Definition) in let cst () = - (** do not compute the implicit arguments, it may be costly *) + (* do not compute the implicit arguments, it may be costly *) let () = Impargs.make_implicit_args false in - (** ppedrot: seems legit to have abstracted subproofs as local*) + (* ppedrot: seems legit to have abstracted subproofs as local*) Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl in let cst = Impargs.with_implicit_protection cst () in let inst = match const.Entries.const_entry_universes with | Entries.Monomorphic_const_entry _ -> EInstance.empty | Entries.Polymorphic_const_entry (_, ctx) -> - (** We mimick what the kernel does, that is ensuring that no additional - constraints appear in the body of polymorphic constants. Ideally this - should be enforced statically. *) + (* We mimick what the kernel does, that is ensuring that no additional + constraints appear in the body of polymorphic constants. Ideally this + should be enforced statically. *) let (_, body_uctx), _ = Future.force const.Entries.const_entry_body in let () = assert (Univ.ContextSet.is_empty body_uctx) in EInstance.make (Univ.UContext.instance ctx) diff --git a/tactics/auto.ml b/tactics/auto.ml index 441fb68acc..f5c3619e64 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -70,19 +70,19 @@ let auto_unif_flags = (* Try unification with the precompiled clause, then use registered Apply *) let connect_hint_clenv poly (c, _, ctx) clenv gl = - (** [clenv] has been generated by a hint-making function, so the only relevant - data in its evarmap is the set of metas. The [evar_reset_evd] function - below just replaces the metas of sigma by those coming from the clenv. *) + (* [clenv] has been generated by a hint-making function, so the only relevant + data in its evarmap is the set of metas. The [evar_reset_evd] function + below just replaces the metas of sigma by those coming from the clenv. *) let sigma = Tacmach.New.project gl in let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in - (** Still, we need to update the universes *) + (* Still, we need to update the universes *) let clenv, c = if poly then - (** Refresh the instance of the hint *) + (* Refresh the instance of the hint *) let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in let emap c = Vars.subst_univs_level_constr subst c in let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in - (** Only metas are mentioning the old universes. *) + (* Only metas are mentioning the old universes. *) let clenv = { templval = Evd.map_fl emap clenv.templval; templtyp = Evd.map_fl emap clenv.templtyp; @@ -211,30 +211,26 @@ let tclLOG (dbg,_,depth,trace) pp tac = match dbg with | Off -> tac | Debug -> - (* For "debug (trivial/auto)", we directly output messages *) + (* For "debug (trivial/auto)", we directly output messages *) let s = String.make (depth+1) '*' in - Proofview.V82.tactic begin fun gl -> - try - let out = Proofview.V82.of_tactic tac gl in - Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); - out - with reraise -> - let reraise = CErrors.push reraise in - Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); - iraise reraise - end + Proofview.(tclIFCATCH ( + tac >>= fun v -> + Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); + tclUNIT v + ) Proofview.tclUNIT + (fun (exn, info) -> + Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); + tclZERO ~info exn)) | Info -> (* For "info (trivial/auto)", we store a log trace *) - Proofview.V82.tactic begin fun gl -> - try - let out = Proofview.V82.of_tactic tac gl in - trace := (depth, Some pp) :: !trace; - out - with reraise -> - let reraise = CErrors.push reraise in - trace := (depth, None) :: !trace; - iraise reraise - end + Proofview.(tclIFCATCH ( + tac >>= fun v -> + trace := (depth, Some pp) :: !trace; + tclUNIT v + ) Proofview.tclUNIT + (fun (exn, info) -> + trace := (depth, None) :: !trace; + tclZERO ~info exn)) (** For info, from the linear trace information, we reconstitute the part of the proof tree we're interested in. The last executed tactic diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 76cbdee0d5..f824552705 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -196,17 +196,12 @@ let subst_hintrewrite (subst,(rbase,list as node)) = if list' == list then node else (rbase,list') -let classify_hintrewrite x = Libobject.Substitute x - - (* Declaration of the Hint Rewrite library object *) let inHintRewrite : string * HintDN.t -> Libobject.obj = - Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with - Libobject.cache_function = cache_hintrewrite; - Libobject.load_function = (fun _ -> cache_hintrewrite); - Libobject.subst_function = subst_hintrewrite; - Libobject.classify_function = classify_hintrewrite } - + let open Libobject in + declare_object @@ superglobal_object_nodischarge "HINT_REWRITE" + ~cache:cache_hintrewrite + ~subst:(Some subst_hintrewrite) open Clenv diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index fd2a163f80..ba7645446d 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1096,8 +1096,8 @@ let resolve_all_evars debug depth unique env p oevd do_split fail = let initial_select_evars filter = fun evd ev evi -> filter ev (Lazy.from_val (snd evi.Evd.evar_source)) && - (** Typeclass evars can contain evars whose conclusion is not - yet determined to be a class or not. *) + (* Typeclass evars can contain evars whose conclusion is not + yet determined to be a class or not. *) Typeclasses.is_class_evar evd evi let resolve_typeclass_evars debug depth unique env evd filter split fail = diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index 46dff34f89..a6922213d0 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -39,20 +39,20 @@ val autoapply : constr -> Hints.hint_db_name -> unit Proofview.tactic module Search : sig val eauto_tac : - ?st:TransparentState.t -> + ?st:TransparentState.t (** The transparent_state used when working with local hypotheses *) - ?unique:bool -> + -> ?unique:bool (** Should we force a unique solution *) - only_classes:bool -> + -> only_classes:bool (** Should non-class goals be shelved and resolved at the end *) - ?strategy:search_strategy -> + -> ?strategy:search_strategy (** Is a traversing-strategy specified? *) - depth:Int.t option -> + -> depth:Int.t option (** Bounded or unbounded search *) - dep:bool -> + -> dep:bool (** Should the tactic be made backtracking on the initial goals, - whatever their internal dependencies are. *) - Hints.hint_db list -> + whatever their internal dependencies are. *) + -> Hints.hint_db list (** The list of hint databases to use *) - unit Proofview.tactic + -> unit Proofview.tactic end diff --git a/tactics/equality.ml b/tactics/equality.ml index bdc95941b2..769e702da1 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1742,7 +1742,7 @@ let subst_one_var dep_proof_ok x = (* Find a non-recursive definition for x *) let res = try - (** [is_eq_x] ensures nf_evar on its side *) + (* [is_eq_x] ensures nf_evar on its side *) let hyps = Proofview.Goal.hyps gl in let test hyp _ = is_eq_x gl x hyp in Context.Named.fold_outside test ~init:() hyps; diff --git a/tactics/hints.ml b/tactics/hints.ml index 77479f9efa..571ad9d160 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -210,9 +210,9 @@ let fresh_key = let lbl = Id.of_string ("_" ^ string_of_int cur) in let kn = Lib.make_kn lbl in let (mp, _) = KerName.repr kn in - (** We embed the full path of the kernel name in the label so that the - identifier should be unique. This ensures that including two modules - together won't confuse the corresponding labels. *) + (* We embed the full path of the kernel name in the label so that + the identifier should be unique. This ensures that including + two modules together won't confuse the corresponding labels. *) let lbl = Id.of_string_soft (Printf.sprintf "%s#%i" (ModPath.to_string mp) cur) in @@ -558,7 +558,7 @@ struct let realize_tac secvars (id,tac) = if Id.Pred.subset tac.secvars secvars then Some tac else - (** Warn about no longer typable hint? *) + (* Warn about no longer typable hint? *) None let head_evar sigma c = @@ -601,7 +601,7 @@ struct let se = find k db in merge_entry secvars db se.sentry_nopat se.sentry_pat - (** Precondition: concl has no existentials *) + (* Precondition: concl has no existentials *) let map_auto sigma ~secvars (k,args) concl db = let se = find k db in let st = if db.use_dn then (Some db.hintdb_state) else None in @@ -644,7 +644,7 @@ struct | None -> let is_present (_, (_, v')) = KerName.equal v.code.uid v'.code.uid in if not (List.exists is_present db.hintdb_nopat) then - (** FIXME *) + (* FIXME *) { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } else db | Some gr -> @@ -738,7 +738,6 @@ module Hintdbmap = String.Map type hint_db = Hint_db.t (** Initially created hint databases, for typeclasses and rewrite *) - let typeclasses_db = "typeclass_instances" let rewrite_db = "rewrite" @@ -1064,12 +1063,12 @@ let cache_autohint (kn, obj) = let subst_autohint (subst, obj) = let subst_key gr = - let (lab'', elab') = subst_global subst gr in - let elab' = EConstr.of_constr elab' in - let gr' = - (try head_constr_bound Evd.empty elab' - with Bound -> lab'') - in if gr' == gr then gr else gr' + let (gr', t) = subst_global subst gr in + match t with + | None -> gr' + | Some t -> + (try head_constr_bound Evd.empty (EConstr.of_constr t.Univ.univ_abstracted_value) + with Bound -> gr') in let subst_hint (k,data as hint) = let k' = Option.Smart.map subst_key k in @@ -1517,8 +1516,8 @@ let pr_hint_term env sigma cl = let pr_applicable_hint () = let env = Global.env () in let pts = Proof_global.give_me_the_proof () in - let glss,_,_,_,sigma = Proof.proof pts in - match glss with + let Proof.{goals;sigma} = Proof.data pts in + match goals with | [] -> CErrors.user_err Pp.(str "No focused goal.") | g::_ -> pr_hint_term env sigma (Goal.V82.concl sigma g) @@ -1586,7 +1585,7 @@ let log_hint h = let store = get_extra_data sigma in match Store.get store hint_trace with | None -> - (** All calls to hint logging should be well-scoped *) + (* All calls to hint logging should be well-scoped *) assert false | Some trace -> let trace = KNmap.add h.uid h trace in diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index a53e3bf20d..a67f5f6d6e 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -59,12 +59,10 @@ let discharge_scheme (_,(kind,l)) = Some (kind, l) let inScheme : string * (inductive * Constant.t) array -> obj = - declare_object {(default_object "SCHEME") with - cache_function = cache_scheme; - load_function = (fun _ -> cache_scheme); - subst_function = subst_scheme; - classify_function = (fun obj -> Substitute obj); - discharge_function = discharge_scheme} + declare_object @@ superglobal_object "SCHEME" + ~cache:cache_scheme + ~subst:(Some subst_scheme) + ~discharge:discharge_scheme (**********************************************************************) (* The table of scheme building functions *) diff --git a/tactics/inv.ml b/tactics/inv.ml index 6a39a10fc4..2ae37ab471 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -365,7 +365,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = let substHypIfVariable tac id = Proofview.Goal.enter begin fun gl -> let sigma = project gl in - (** We only look at the type of hypothesis "id" *) + (* We only look at the type of hypothesis "id" *) let hyp = pf_nf_evar gl (pf_get_hyp_typ id gl) in let (t,t1,t2) = dest_nf_eq (pf_env gl) sigma hyp in match (EConstr.kind sigma t1, EConstr.kind sigma t2) with diff --git a/tactics/leminv.ml b/tactics/leminv.ml index caf4c1eca3..356b43ec14 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -183,7 +183,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = scheme on sort [sort]. Depending on the value of [dep_option] it will build a dependent lemma or a non-dependent one *) -let inversion_scheme env sigma t sort dep_option inv_op = +let inversion_scheme ~name ~poly env sigma t sort dep_option inv_op = let (env,i) = add_prods_sign env sigma t in let ind = try find_rectype env sigma i @@ -201,7 +201,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = user_err ~hdr:"lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) - let pf = Proof.start (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in + let pf = Proof.start ~name ~poly (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in let pf = fst (Proof.run_tactic env ( tclTHEN intro (onLastHypId inv_op)) pf) @@ -217,7 +217,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = invEnv ~init:Context.Named.empty end in let avoid = ref Id.Set.empty in - let _,_,_,_,sigma = Proof.proof pf in + let Proof.{sigma} = Proof.data pf in let sigma = Evd.minimize_universes sigma in let rec fill_holes c = match EConstr.kind sigma c with @@ -236,7 +236,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = p, sigma let add_inversion_lemma ~poly name env sigma t sort dep inv_op = - let invProof, sigma = inversion_scheme env sigma t sort dep inv_op in + let invProof, sigma = inversion_scheme ~name ~poly env sigma t sort dep inv_op in let univs = Evd.const_univ_entry ~poly sigma in diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 224cd68cf9..bfbce8f6eb 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -572,7 +572,7 @@ module New = struct with Failure _ -> CErrors.user_err Pp.(str "Not enough hypotheses in the goal.") let nthHypId m gl = - (** We only use [id] *) + (* We only use [id] *) nthDecl m gl |> NamedDecl.get_id let nthHyp m gl = mkVar (nthHypId m gl) @@ -688,12 +688,12 @@ module New = struct end) end let elimination_sort_of_goal gl = - (** Retyping will expand evars anyway. *) + (* Retyping will expand evars anyway. *) let c = Proofview.Goal.concl gl in pf_apply Retyping.get_sort_family_of gl c let elimination_sort_of_hyp id gl = - (** Retyping will expand evars anyway. *) + (* Retyping will expand evars anyway. *) let c = pf_get_hyp_typ id gl in pf_apply Retyping.get_sort_family_of gl c diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 2947e44f7a..201b7801c3 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -191,6 +191,7 @@ module New : sig val tclTHENS3PARTS : unit tactic -> unit tactic array -> unit tactic -> unit tactic array -> unit tactic val tclTHENSFIRSTn : unit tactic -> unit tactic array -> unit tactic -> unit tactic val tclTHENFIRSTn : unit tactic -> unit tactic array -> unit tactic + (** [tclTHENFIRST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2] to the first resulting subgoal *) val tclTHENFIRST : unit tactic -> unit tactic -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 9bd4a29a69..0756344ba3 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -183,7 +183,7 @@ let convert_gen pb x y = | Some sigma -> Proofview.Unsafe.tclEVARS sigma | None -> Tacticals.New.tclFAIL 0 (str "Not convertible") | exception _ -> - (** FIXME: Sometimes an anomaly is raised from conversion *) + (* FIXME: Sometimes an anomaly is raised from conversion *) Tacticals.New.tclFAIL 0 (str "Not convertible") end @@ -241,7 +241,7 @@ let clear_gen fail = function | ids -> Proofview.Goal.enter begin fun gl -> let ids = List.fold_right Id.Set.add ids Id.Set.empty in - (** clear_hyps_in_evi does not require nf terms *) + (* clear_hyps_in_evi does not require nf terms *) let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -307,7 +307,7 @@ let rename_hyp repl = let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - (** Check that we do not mess variables *) + (* Check that we do not mess variables *) let fold accu decl = Id.Set.add (NamedDecl.get_id decl) accu in let vars = List.fold_left fold Id.Set.empty hyps in let () = @@ -322,7 +322,7 @@ let rename_hyp repl = CErrors.user_err (Id.print elt ++ str " is already used") with Not_found -> () in - (** All is well *) + (* All is well *) let make_subst (src, dst) = (src, mkVar dst) in let subst = List.map make_subst repl in let subst c = Vars.replace_vars subst c in @@ -1235,7 +1235,7 @@ let cut c = let concl = Proofview.Goal.concl gl in let is_sort = try - (** Backward compat: ensure that [c] is well-typed. *) + (* Backward compat: ensure that [c] is well-typed. *) let typ = Typing.unsafe_type_of env sigma c in let typ = whd_all env sigma typ in match EConstr.kind sigma typ with @@ -1245,7 +1245,7 @@ let cut c = in if is_sort then let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_set_of_hyps gl) in - (** Backward compat: normalize [c]. *) + (* Backward compat: normalize [c]. *) let c = if normalize_cut then local_strong whd_betaiota sigma c else c in Refine.refine ~typecheck:false begin fun h -> let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in @@ -1498,8 +1498,8 @@ let simplest_elim c = default_elim false None (c,NoBindings) *) let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = - (** The evarmap of elimclause is assumed to be an extension of hypclause, so - we do not need to merge the universes coming from hypclause. *) + (* The evarmap of elimclause is assumed to be an extension of hypclause, so + we do not need to merge the universes coming from hypclause. *) try clenv_fchain ~with_univs:false ~flags mv elimclause hypclause with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> (* Set the hypothesis name in the message *) @@ -1909,7 +1909,7 @@ let exact_no_check c = let exact_check c = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in - (** We do not need to normalize the goal because we just check convertibility *) + (* We do not need to normalize the goal because we just check convertibility *) let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let sigma, ct = Typing.type_of env sigma c in @@ -2021,7 +2021,7 @@ let clear_body ids = let check = try let check (env, sigma, seen) decl = - (** Do no recheck hypotheses that do not depend *) + (* Do no recheck hypotheses that do not depend *) let sigma = if not seen then sigma else if List.exists (fun id -> occur_var_in_decl env sigma id decl) ids then @@ -2848,7 +2848,7 @@ let generalize_dep ?(with_let=false) c = in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in - (** Check that the generalization is indeed well-typed *) + (* Check that the generalization is indeed well-typed *) let (evd, _) = Typing.type_of env evd cl'' in let args = Context.Named.to_instance mkVar to_quantify_rev in tclTHENLIST @@ -3021,7 +3021,7 @@ let specialize (c,lbind) ipat = let unfold_body x = let open Context.Named.Declaration in Proofview.Goal.enter begin fun gl -> - (** We normalize the given hypothesis immediately. *) + (* We normalize the given hypothesis immediately. *) let env = Proofview.Goal.env gl in let xval = match Environ.lookup_named x env with | LocalAssum _ -> user_err ~hdr:"unfold_body" diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index 03d2a17eee..e273891500 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -281,7 +281,7 @@ struct open TDnet let pat_of_constr c : term_pattern = - (** To each evar we associate a unique identifier. *) + (* To each evar we associate a unique identifier. *) let metas = ref Evar.Map.empty in let rec pat_of_constr c = match Constr.kind c with | Rel _ -> Term DRel @@ -378,7 +378,7 @@ struct let c_id = Opt.reduce (Ident.constr_of id) in let c_id = EConstr.of_constr c_id in let (ctx,wc) = - try Termops.align_prod_letin Evd.empty whole_c c_id (** FIXME *) + try Termops.align_prod_letin Evd.empty whole_c c_id (* FIXME *) with Invalid_argument _ -> [],c_id in let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in try diff --git a/test-suite/Makefile b/test-suite/Makefile index 1db97f43c5..34a1900bbc 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -62,6 +62,7 @@ get_coq_prog_args_in_parens = $(subst $(SINGLE_QUOTE),,$(if $(call get_coq_prog_ # get the command to use with this set of arguments; if there's -compile, use coqc, else use coqtop has_profile_ltac_or_compile_flag = $(filter "-profile-ltac-cutoff" "-profile-ltac" "-compile",$(call get_coq_prog_args,$(1))) get_command_based_on_flags = $(if $(call has_profile_ltac_or_compile_flag,$(1)),$(coqtopcompile),$(coqtopload)) +get_set_impredicativity= $(filter "-impredicative-set",$(call get_coq_prog_args,$(1))) bogomips:= @@ -89,19 +90,17 @@ FAIL = >&2 echo 'FAILED $@' # Testing subsystems ####################################################################### -# Apart so that it can be easily skipped with overriding +# These targets can be skipped by doing `make TARGET= test-suite` COMPLEXITY := $(if $(bogomips),complexity) - BUGS := bugs/opened bugs/closed - INTERACTIVE := interactive - +UNIT_TESTS := unit-tests VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ output-modulo-time $(INTERACTIVE) micromega $(COMPLEXITY) modules stm \ coqdoc ssr # All subsystems -SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile tools unit-tests +SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile tools $(UNIT_TESTS) PREREQUISITELOG = prerequisite/admit.v.log \ prerequisite/make_local.v.log prerequisite/make_notation.v.log \ @@ -118,6 +117,10 @@ PREREQUISITELOG = prerequisite/admit.v.log \ all: run $(MAKE) report +# do nothing +.PHONY: noop +noop: ; + run: $(SUBSYSTEMS) bugs: $(BUGS) @@ -303,6 +306,8 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v echo " $<...correctly prepared" ; \ fi; \ } > "$@" + @echo "CHK $(shell basename $< .v)" + $(HIDE)$(coqchk) -norec TestSuite.$(shell basename $< .v) > $(shell dirname $<)/$(shell basename $< .v).chk.log 2>&1 ssr: $(wildcard ssr/*.v:%.v=%.v.log) $(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v)): %.v.log: %.v $(PREREQUISITELOG) @@ -320,6 +325,16 @@ $(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v)): %.v $(FAIL); \ fi; \ } > "$@" + @echo "CHK $(shell basename $< .v)" + $(HIDE){ \ + opts="$(if $(findstring modules/,$<),-R modules Mods -norec Mods.$(shell basename $< .v),-I $(shell dirname $<) -norec $(shell basename $< .v))"; \ + $(coqchk) -silent $(call get_set_impredicativity,$<) $$opts 2>&1; R=$$?; \ + if [ $$R != 0 ]; then \ + echo $(log_failure); \ + echo " $<...could not be checked (Error!)" ; \ + $(FAIL); \ + fi; \ + } > "$(shell dirname $<)/$(shell basename $< .v).chk.log" stm: $(wildcard stm/*.v:%.v=%.v.log) $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v @@ -337,6 +352,15 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v $(FAIL); \ fi; \ } > "$@" + @echo "CHK $(shell basename $< .v)" + $(HIDE){ \ + $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ + if [ $$R != 0 ]; then \ + echo $(log_failure); \ + echo " $<...could not be checked (Error!)" ; \ + $(FAIL); \ + fi; \ + } > "$(shell dirname $<)/$(shell basename $< .v).chk.log" $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" @@ -352,6 +376,15 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) $(FAIL); \ fi; \ } > "$@" + @echo "CHK $(shell basename $< .v)" + $(HIDE){ \ + $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ + if [ $$R != 0 ]; then \ + echo $(log_failure); \ + echo " $<...could not be checked (Error!)" ; \ + $(FAIL); \ + fi; \ + } > "$(shell dirname $<)/$(shell basename $< .v).chk.log" $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" @@ -538,7 +571,7 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake)) @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ - $(BIN)fake_ide $< "-coqlib $(LIB) -boot -async-proofs on -async-proofs-tactic-error-resilience off -async-proofs-command-error-resilience off" 2>&1; \ + $(BIN)fake_ide $< "-coqlib $(LIB) -boot -async-proofs on -async-proofs-tactic-error-resilience off -async-proofs-command-error-resilience off $(call get_coq_prog_args,"$<")" 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ diff --git a/test-suite/bugs/closed/bug_4509.v b/test-suite/bugs/closed/bug_4509.v new file mode 100644 index 0000000000..ceae7c5fc3 --- /dev/null +++ b/test-suite/bugs/closed/bug_4509.v @@ -0,0 +1,11 @@ +(* Was solved at some time, suspectingly in PR #6328 *) + +Goal exists n, n > 1. +Proof. + unshelve eexists. (*2 goals, as expected*) + Undo. + unshelve (eexists; instantiate (1:=ltac:(idtac))). (*only 1 goal*) + shelve. + Undo. + 2:unshelve instantiate (1:=_). +Abort. diff --git a/test-suite/bugs/closed/bug_6202.v b/test-suite/bugs/closed/bug_6202.v new file mode 100644 index 0000000000..899260f59a --- /dev/null +++ b/test-suite/bugs/closed/bug_6202.v @@ -0,0 +1,11 @@ +(* This was fixed at some time, suspectingly in PR #6328 *) + +Inductive foo := F (a : forall var : Type -> Type, unit -> var unit) (_ : a = a). +Goal foo. + eexists (fun var => fun u : unit => ltac:(clear u)). + shelve. + Unshelve. + all:[ > | ]. + shelve. + Fail Grab Existential Variables. +Abort. diff --git a/test-suite/bugs/closed/bug_8951.v b/test-suite/bugs/closed/bug_8951.v new file mode 100644 index 0000000000..dce19318c5 --- /dev/null +++ b/test-suite/bugs/closed/bug_8951.v @@ -0,0 +1,14 @@ +Module Type T. + Polymorphic Parameter Inline t@{i} : Type@{i}. +End T. + +Module M. + Polymorphic Definition t@{i} := nat. +End M. + +Module Make (X:T). + Include X. + +End Make. + +Module P := Make M. diff --git a/test-suite/bugs/closed/bug_9166.v b/test-suite/bugs/closed/bug_9166.v new file mode 100644 index 0000000000..8a7e9c37b0 --- /dev/null +++ b/test-suite/bugs/closed/bug_9166.v @@ -0,0 +1,9 @@ +Set Warnings "+deprecated". + +Notation bar := option (compat "8.7"). + +Definition foo (x: nat) : nat := + match x with + | 0 => 0 + | S bar => bar + end. diff --git a/test-suite/coqchk/inductive_functor_params.v b/test-suite/coqchk/inductive_functor_params.v new file mode 100644 index 0000000000..f364a62818 --- /dev/null +++ b/test-suite/coqchk/inductive_functor_params.v @@ -0,0 +1,16 @@ + +Module Type T. + Parameter foo : nat -> nat. +End T. + +Module F (A:T). + Inductive ind (n:nat) : nat -> Prop := + | C : (forall x, x < n -> ind (A.foo n) x) -> ind n n. +End F. + +Module A. Definition foo (n:nat) := n. End A. + +Module M := F A. +(* Note: M.ind could be seen as having 1 recursively uniform + parameter, but module substitution does not recognize it, so it is + treated as a non-uniform parameter. *) diff --git a/test-suite/coqchk/inductive_functor_template.v b/test-suite/coqchk/inductive_functor_template.v new file mode 100644 index 0000000000..bc5cd0fb68 --- /dev/null +++ b/test-suite/coqchk/inductive_functor_template.v @@ -0,0 +1,11 @@ + +Module Type E. Parameter T : Type. End E. + +Module F (X:E). + #[universes(template)] Inductive foo := box : X.T -> foo. +End F. + +Module ME. Definition T := nat. End ME. +Module A := F ME. +(* Note: A.foo could live in Set, and coqchk sees that (because of + template polymorphism implementation details) *) diff --git a/test-suite/dune b/test-suite/dune index c5fa0bb14a..eae072553a 100644 --- a/test-suite/dune +++ b/test-suite/dune @@ -70,4 +70,4 @@ (progn ; XXX: we will allow to set the NJOBS variable in a future Dune ; version, either by using an env var or by letting Dune set `-j` - (run make -j 2 BIN= PRINT_LOGS=1)))) + (run make -j 2 BIN= PRINT_LOGS=1 UNIT_TESTS=%{env:COQ_UNIT_TEST=unit-tests})))) diff --git a/test-suite/ide/join-sync.fake b/test-suite/ide/join-sync.fake new file mode 100644 index 0000000000..236028ce46 --- /dev/null +++ b/test-suite/ide/join-sync.fake @@ -0,0 +1,20 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# Error resiliency + async proofs off +# coq-prog-args: ("-async-proofs" "off" "-async-proofs-command-error-resilience" "on") +# + +ADD { Lemma x : True. } +ADD { Proof using. } +ADD here { trivial. } +ADD { fail. } +ADD { Qed. } +ADD { Lemma y : True. } +ADD { Proof using. } +ADD { trivial. } +ADD { Qed. } +WAIT +FAILJOIN +ASSERT TIP here +ABORT diff --git a/test-suite/ide/join.fake b/test-suite/ide/join.fake new file mode 100644 index 0000000000..c4c696ad9a --- /dev/null +++ b/test-suite/ide/join.fake @@ -0,0 +1,20 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# Error resiliency +# + +ADD { Section x. } +ADD { Lemma x : True. } +ADD { Proof using. } +ADD here { trivial. } +ADD { fail. } +ADD { Qed. } +ADD { Lemma y : True. } +ADD { Proof using. } +ADD { trivial. } +ADD { Qed. } +ADD { End x. } +FAILJOIN +ASSERT TIP here +ABORT diff --git a/test-suite/output/Arguments.v b/test-suite/output/Arguments.v index 97df40f882..844f96aaa1 100644 --- a/test-suite/output/Arguments.v +++ b/test-suite/output/Arguments.v @@ -51,7 +51,7 @@ Arguments pi _ _%F _%B. Check (forall w : r, pi w $ $ = tt). Fail Check (forall w : r, w $ $ = tt). Axiom w : r. -Arguments w _%F _%B : extra scopes. +Arguments w x%F y%B : extra scopes. Check (w $ $ = tt). Fail Arguments w _%F _%B. diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index 7446c17d98..f4544a0df3 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -34,17 +34,23 @@ bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b bool_rec: forall P : bool -> Set, P true -> P false -> forall b : bool, P b eq_true_rec: forall P : bool -> Set, P true -> forall b : bool, eq_true b -> P b -eq_true_ind: - forall P : bool -> Prop, P true -> forall b : bool, eq_true b -> P b +bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b eq_true_rect_r: forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true eq_true_rec_r: forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true eq_true_rect: forall P : bool -> Type, P true -> forall b : bool, eq_true b -> P b -bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b +eq_true_ind: + forall P : bool -> Prop, P true -> forall b : bool, eq_true b -> P b eq_true_ind_r: forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true +Byte.to_bits: + Byte.byte -> + bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) +Byte.of_bits: + bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) -> + Byte.byte andb_true_intro: forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true @@ -52,6 +58,10 @@ BoolSpec_ind: forall (P Q : Prop) (P0 : bool -> Prop), (P -> P0 true) -> (Q -> P0 false) -> forall b : bool, BoolSpec P Q b -> P0 b +Byte.to_bits_of_bits: + forall + b : bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))), + Byte.to_bits (Byte.of_bits b) = b bool_choice: forall (S : Set) (R1 R2 : S -> Prop), (forall x : S, {R1 x} + {R2 x}) -> diff --git a/test-suite/output/StringSyntax.out b/test-suite/output/StringSyntax.out new file mode 100644 index 0000000000..bbc936766d --- /dev/null +++ b/test-suite/output/StringSyntax.out @@ -0,0 +1,1089 @@ +Monomorphic byte_rect = +fun (P : byte -> Type) (f : P "000") (f0 : P "001") (f1 : P "002") (f2 : P "003") (f3 : P "004") (f4 : P "005") (f5 : P "006") (f6 : P "007") (f7 : P "008") (f8 : P "009") (f9 : P "010") (f10 : P "011") (f11 : P "012") (f12 : P "013") (f13 : P "014") (f14 : P "015") (f15 : P "016") (f16 : P "017") (f17 : P "018") (f18 : P "019") (f19 : P "020") (f20 : P "021") (f21 : P "022") (f22 : P "023") (f23 : P "024") (f24 : P "025") (f25 : P "026") (f26 : P "027") (f27 : P "028") (f28 : P "029") (f29 : P "030") (f30 : P "031") (f31 : P " ") (f32 : P "!") (f33 : P """") (f34 : P "#") (f35 : P "$") (f36 : P "%") (f37 : P "&") (f38 : P "'") (f39 : P "(") (f40 : P ")") (f41 : P "*") (f42 : P "+") (f43 : P ",") (f44 : P "-") (f45 : P ".") (f46 : P "/") (f47 : P "0") (f48 : P "1") (f49 : P "2") (f50 : P "3") (f51 : P "4") (f52 : P "5") (f53 : P "6") (f54 : P "7") (f55 : P "8") (f56 : P "9") (f57 : P ":") (f58 : P ";") (f59 : P "<") (f60 : P "=") (f61 : P ">") (f62 : P "?") + (f63 : P "@") (f64 : P "A") (f65 : P "B") (f66 : P "C") (f67 : P "D") (f68 : P "E") (f69 : P "F") (f70 : P "G") (f71 : P "H") (f72 : P "I") (f73 : P "J") (f74 : P "K") (f75 : P "L") (f76 : P "M") (f77 : P "N") (f78 : P "O") (f79 : P "P") (f80 : P "Q") (f81 : P "R") (f82 : P "S") (f83 : P "T") (f84 : P "U") (f85 : P "V") (f86 : P "W") (f87 : P "X") (f88 : P "Y") (f89 : P "Z") (f90 : P "[") (f91 : P "\") (f92 : P "]") (f93 : P "^") (f94 : P "_") (f95 : P "`") (f96 : P "a") (f97 : P "b") (f98 : P "c") (f99 : P "d") (f100 : P "e") (f101 : P "f") (f102 : P "g") (f103 : P "h") (f104 : P "i") (f105 : P "j") (f106 : P "k") (f107 : P "l") (f108 : P "m") (f109 : P "n") (f110 : P "o") (f111 : P "p") (f112 : P "q") (f113 : P "r") (f114 : P "s") (f115 : P "t") (f116 : P "u") (f117 : P "v") (f118 : P "w") (f119 : P "x") (f120 : P "y") (f121 : P "z") (f122 : P "{") (f123 : P "|") (f124 : P "}") (f125 : P "~") (f126 : P "127") (f127 : P "128") (f128 : P "129") (f129 : P "130") + (f130 : P "131") (f131 : P "132") (f132 : P "133") (f133 : P "134") (f134 : P "135") (f135 : P "136") (f136 : P "137") (f137 : P "138") (f138 : P "139") (f139 : P "140") (f140 : P "141") (f141 : P "142") (f142 : P "143") (f143 : P "144") (f144 : P "145") (f145 : P "146") (f146 : P "147") (f147 : P "148") (f148 : P "149") (f149 : P "150") (f150 : P "151") (f151 : P "152") (f152 : P "153") (f153 : P "154") (f154 : P "155") (f155 : P "156") (f156 : P "157") (f157 : P "158") (f158 : P "159") (f159 : P "160") (f160 : P "161") (f161 : P "162") (f162 : P "163") (f163 : P "164") (f164 : P "165") (f165 : P "166") (f166 : P "167") (f167 : P "168") (f168 : P "169") (f169 : P "170") (f170 : P "171") (f171 : P "172") (f172 : P "173") (f173 : P "174") (f174 : P "175") (f175 : P "176") (f176 : P "177") (f177 : P "178") (f178 : P "179") (f179 : P "180") (f180 : P "181") (f181 : P "182") (f182 : P "183") (f183 : P "184") (f184 : P "185") (f185 : P "186") (f186 : P "187") + (f187 : P "188") (f188 : P "189") (f189 : P "190") (f190 : P "191") (f191 : P "192") (f192 : P "193") (f193 : P "194") (f194 : P "195") (f195 : P "196") (f196 : P "197") (f197 : P "198") (f198 : P "199") (f199 : P "200") (f200 : P "201") (f201 : P "202") (f202 : P "203") (f203 : P "204") (f204 : P "205") (f205 : P "206") (f206 : P "207") (f207 : P "208") (f208 : P "209") (f209 : P "210") (f210 : P "211") (f211 : P "212") (f212 : P "213") (f213 : P "214") (f214 : P "215") (f215 : P "216") (f216 : P "217") (f217 : P "218") (f218 : P "219") (f219 : P "220") (f220 : P "221") (f221 : P "222") (f222 : P "223") (f223 : P "224") (f224 : P "225") (f225 : P "226") (f226 : P "227") (f227 : P "228") (f228 : P "229") (f229 : P "230") (f230 : P "231") (f231 : P "232") (f232 : P "233") (f233 : P "234") (f234 : P "235") (f235 : P "236") (f236 : P "237") (f237 : P "238") (f238 : P "239") (f239 : P "240") (f240 : P "241") (f241 : P "242") (f242 : P "243") (f243 : P "244") + (f244 : P "245") (f245 : P "246") (f246 : P "247") (f247 : P "248") (f248 : P "249") (f249 : P "250") (f250 : P "251") (f251 : P "252") (f252 : P "253") (f253 : P "254") (f254 : P "255") (b : byte) => +match b as b0 return (P b0) with +| "000" => f +| "001" => f0 +| "002" => f1 +| "003" => f2 +| "004" => f3 +| "005" => f4 +| "006" => f5 +| "007" => f6 +| "008" => f7 +| "009" => f8 +| "010" => f9 +| "011" => f10 +| "012" => f11 +| "013" => f12 +| "014" => f13 +| "015" => f14 +| "016" => f15 +| "017" => f16 +| "018" => f17 +| "019" => f18 +| "020" => f19 +| "021" => f20 +| "022" => f21 +| "023" => f22 +| "024" => f23 +| "025" => f24 +| "026" => f25 +| "027" => f26 +| "028" => f27 +| "029" => f28 +| "030" => f29 +| "031" => f30 +| " " => f31 +| "!" => f32 +| """" => f33 +| "#" => f34 +| "$" => f35 +| "%" => f36 +| "&" => f37 +| "'" => f38 +| "(" => f39 +| ")" => f40 +| "*" => f41 +| "+" => f42 +| "," => f43 +| "-" => f44 +| "." => f45 +| "/" => f46 +| "0" => f47 +| "1" => f48 +| "2" => f49 +| "3" => f50 +| "4" => f51 +| "5" => f52 +| "6" => f53 +| "7" => f54 +| "8" => f55 +| "9" => f56 +| ":" => f57 +| ";" => f58 +| "<" => f59 +| "=" => f60 +| ">" => f61 +| "?" => f62 +| "@" => f63 +| "A" => f64 +| "B" => f65 +| "C" => f66 +| "D" => f67 +| "E" => f68 +| "F" => f69 +| "G" => f70 +| "H" => f71 +| "I" => f72 +| "J" => f73 +| "K" => f74 +| "L" => f75 +| "M" => f76 +| "N" => f77 +| "O" => f78 +| "P" => f79 +| "Q" => f80 +| "R" => f81 +| "S" => f82 +| "T" => f83 +| "U" => f84 +| "V" => f85 +| "W" => f86 +| "X" => f87 +| "Y" => f88 +| "Z" => f89 +| "[" => f90 +| "\" => f91 +| "]" => f92 +| "^" => f93 +| "_" => f94 +| "`" => f95 +| "a" => f96 +| "b" => f97 +| "c" => f98 +| "d" => f99 +| "e" => f100 +| "f" => f101 +| "g" => f102 +| "h" => f103 +| "i" => f104 +| "j" => f105 +| "k" => f106 +| "l" => f107 +| "m" => f108 +| "n" => f109 +| "o" => f110 +| "p" => f111 +| "q" => f112 +| "r" => f113 +| "s" => f114 +| "t" => f115 +| "u" => f116 +| "v" => f117 +| "w" => f118 +| "x" => f119 +| "y" => f120 +| "z" => f121 +| "{" => f122 +| "|" => f123 +| "}" => f124 +| "~" => f125 +| "127" => f126 +| "128" => f127 +| "129" => f128 +| "130" => f129 +| "131" => f130 +| "132" => f131 +| "133" => f132 +| "134" => f133 +| "135" => f134 +| "136" => f135 +| "137" => f136 +| "138" => f137 +| "139" => f138 +| "140" => f139 +| "141" => f140 +| "142" => f141 +| "143" => f142 +| "144" => f143 +| "145" => f144 +| "146" => f145 +| "147" => f146 +| "148" => f147 +| "149" => f148 +| "150" => f149 +| "151" => f150 +| "152" => f151 +| "153" => f152 +| "154" => f153 +| "155" => f154 +| "156" => f155 +| "157" => f156 +| "158" => f157 +| "159" => f158 +| "160" => f159 +| "161" => f160 +| "162" => f161 +| "163" => f162 +| "164" => f163 +| "165" => f164 +| "166" => f165 +| "167" => f166 +| "168" => f167 +| "169" => f168 +| "170" => f169 +| "171" => f170 +| "172" => f171 +| "173" => f172 +| "174" => f173 +| "175" => f174 +| "176" => f175 +| "177" => f176 +| "178" => f177 +| "179" => f178 +| "180" => f179 +| "181" => f180 +| "182" => f181 +| "183" => f182 +| "184" => f183 +| "185" => f184 +| "186" => f185 +| "187" => f186 +| "188" => f187 +| "189" => f188 +| "190" => f189 +| "191" => f190 +| "192" => f191 +| "193" => f192 +| "194" => f193 +| "195" => f194 +| "196" => f195 +| "197" => f196 +| "198" => f197 +| "199" => f198 +| "200" => f199 +| "201" => f200 +| "202" => f201 +| "203" => f202 +| "204" => f203 +| "205" => f204 +| "206" => f205 +| "207" => f206 +| "208" => f207 +| "209" => f208 +| "210" => f209 +| "211" => f210 +| "212" => f211 +| "213" => f212 +| "214" => f213 +| "215" => f214 +| "216" => f215 +| "217" => f216 +| "218" => f217 +| "219" => f218 +| "220" => f219 +| "221" => f220 +| "222" => f221 +| "223" => f222 +| "224" => f223 +| "225" => f224 +| "226" => f225 +| "227" => f226 +| "228" => f227 +| "229" => f228 +| "230" => f229 +| "231" => f230 +| "232" => f231 +| "233" => f232 +| "234" => f233 +| "235" => f234 +| "236" => f235 +| "237" => f236 +| "238" => f237 +| "239" => f238 +| "240" => f239 +| "241" => f240 +| "242" => f241 +| "243" => f242 +| "244" => f243 +| "245" => f244 +| "246" => f245 +| "247" => f246 +| "248" => f247 +| "249" => f248 +| "250" => f249 +| "251" => f250 +| "252" => f251 +| "253" => f252 +| "254" => f253 +| "255" => f254 +end + : forall P : byte -> Type, + P "000" -> + P "001" -> + P "002" -> + P "003" -> + P "004" -> + P "005" -> + P "006" -> + P "007" -> + P "008" -> + P "009" -> + P "010" -> + P "011" -> + P "012" -> + P "013" -> + P "014" -> + P "015" -> + P "016" -> + P "017" -> + P "018" -> + P "019" -> + P "020" -> + P "021" -> + P "022" -> + P "023" -> + P "024" -> + P "025" -> + P "026" -> + P "027" -> + P "028" -> + P "029" -> + P "030" -> + P "031" -> + P " " -> + P "!" -> + P """" -> + P "#" -> + P "$" -> + P "%" -> + P "&" -> + P "'" -> + P "(" -> + P ")" -> + P "*" -> + P "+" -> + P "," -> + P "-" -> + P "." -> + P "/" -> + P "0" -> + P "1" -> + P "2" -> + P "3" -> + P "4" -> + P "5" -> + P "6" -> + P "7" -> + P "8" -> + P "9" -> + P ":" -> + P ";" -> + P "<" -> + P "=" -> + P ">" -> + P "?" -> + P "@" -> + P "A" -> + P "B" -> + P "C" -> + P "D" -> + P "E" -> + P "F" -> + P "G" -> + P "H" -> + P "I" -> + P "J" -> + P "K" -> + P "L" -> + P "M" -> + P "N" -> + P "O" -> + P "P" -> + P "Q" -> + P "R" -> + P "S" -> + P "T" -> + P "U" -> + P "V" -> + P "W" -> + P "X" -> + P "Y" -> + P "Z" -> + P "[" -> + P "\" -> + P "]" -> + P "^" -> + P "_" -> + P "`" -> + P "a" -> + P "b" -> + P "c" -> + P "d" -> + P "e" -> + P "f" -> + P "g" -> + P "h" -> + P "i" -> + P "j" -> + P "k" -> + P "l" -> + P "m" -> + P "n" -> + P "o" -> + P "p" -> + P "q" -> + P "r" -> + P "s" -> + P "t" -> + P "u" -> + P "v" -> + P "w" -> + P "x" -> + P "y" -> + P "z" -> + P "{" -> + P "|" -> + P "}" -> + P "~" -> + P "127" -> + P "128" -> + P "129" -> + P "130" -> + P "131" -> + P "132" -> + P "133" -> + P "134" -> + P "135" -> + P "136" -> + P "137" -> + P "138" -> + P "139" -> + P "140" -> + P "141" -> + P "142" -> + P "143" -> + P "144" -> + P "145" -> + P "146" -> + P "147" -> + P "148" -> + P "149" -> + P "150" -> + P "151" -> + P "152" -> + P "153" -> + P "154" -> + P "155" -> + P "156" -> + P "157" -> + P "158" -> + P "159" -> + P "160" -> + P "161" -> + P "162" -> + P "163" -> + P "164" -> + P "165" -> + P "166" -> + P "167" -> + P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b + +byte_rect is not universe polymorphic +Argument scopes are [function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ byte_scope] +Monomorphic byte_rec = +fun P : byte -> Set => byte_rect P + : forall P : byte -> Set, + P "000" -> + P "001" -> + P "002" -> + P "003" -> + P "004" -> + P "005" -> + P "006" -> + P "007" -> + P "008" -> + P "009" -> + P "010" -> + P "011" -> + P "012" -> + P "013" -> + P "014" -> + P "015" -> + P "016" -> + P "017" -> + P "018" -> + P "019" -> + P "020" -> + P "021" -> + P "022" -> + P "023" -> + P "024" -> + P "025" -> + P "026" -> + P "027" -> + P "028" -> + P "029" -> + P "030" -> + P "031" -> + P " " -> + P "!" -> + P """" -> + P "#" -> + P "$" -> + P "%" -> + P "&" -> + P "'" -> + P "(" -> + P ")" -> + P "*" -> + P "+" -> + P "," -> + P "-" -> + P "." -> + P "/" -> + P "0" -> + P "1" -> + P "2" -> + P "3" -> + P "4" -> + P "5" -> + P "6" -> + P "7" -> + P "8" -> + P "9" -> + P ":" -> + P ";" -> + P "<" -> + P "=" -> + P ">" -> + P "?" -> + P "@" -> + P "A" -> + P "B" -> + P "C" -> + P "D" -> + P "E" -> + P "F" -> + P "G" -> + P "H" -> + P "I" -> + P "J" -> + P "K" -> + P "L" -> + P "M" -> + P "N" -> + P "O" -> + P "P" -> + P "Q" -> + P "R" -> + P "S" -> + P "T" -> + P "U" -> + P "V" -> + P "W" -> + P "X" -> + P "Y" -> + P "Z" -> + P "[" -> + P "\" -> + P "]" -> + P "^" -> + P "_" -> + P "`" -> + P "a" -> + P "b" -> + P "c" -> + P "d" -> + P "e" -> + P "f" -> + P "g" -> + P "h" -> + P "i" -> + P "j" -> + P "k" -> + P "l" -> + P "m" -> + P "n" -> + P "o" -> + P "p" -> + P "q" -> + P "r" -> + P "s" -> + P "t" -> + P "u" -> + P "v" -> + P "w" -> + P "x" -> + P "y" -> + P "z" -> + P "{" -> + P "|" -> + P "}" -> + P "~" -> + P "127" -> + P "128" -> + P "129" -> + P "130" -> + P "131" -> + P "132" -> + P "133" -> + P "134" -> + P "135" -> + P "136" -> + P "137" -> + P "138" -> + P "139" -> + P "140" -> + P "141" -> + P "142" -> + P "143" -> + P "144" -> + P "145" -> + P "146" -> + P "147" -> + P "148" -> + P "149" -> + P "150" -> + P "151" -> + P "152" -> + P "153" -> + P "154" -> + P "155" -> + P "156" -> + P "157" -> + P "158" -> + P "159" -> + P "160" -> + P "161" -> + P "162" -> + P "163" -> + P "164" -> + P "165" -> + P "166" -> + P "167" -> + P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b + +byte_rec is not universe polymorphic +Argument scopes are [function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ byte_scope] +Monomorphic byte_ind = +fun (P : byte -> Prop) (f : P "000") (f0 : P "001") (f1 : P "002") (f2 : P "003") (f3 : P "004") (f4 : P "005") (f5 : P "006") (f6 : P "007") (f7 : P "008") (f8 : P "009") (f9 : P "010") (f10 : P "011") (f11 : P "012") (f12 : P "013") (f13 : P "014") (f14 : P "015") (f15 : P "016") (f16 : P "017") (f17 : P "018") (f18 : P "019") (f19 : P "020") (f20 : P "021") (f21 : P "022") (f22 : P "023") (f23 : P "024") (f24 : P "025") (f25 : P "026") (f26 : P "027") (f27 : P "028") (f28 : P "029") (f29 : P "030") (f30 : P "031") (f31 : P " ") (f32 : P "!") (f33 : P """") (f34 : P "#") (f35 : P "$") (f36 : P "%") (f37 : P "&") (f38 : P "'") (f39 : P "(") (f40 : P ")") (f41 : P "*") (f42 : P "+") (f43 : P ",") (f44 : P "-") (f45 : P ".") (f46 : P "/") (f47 : P "0") (f48 : P "1") (f49 : P "2") (f50 : P "3") (f51 : P "4") (f52 : P "5") (f53 : P "6") (f54 : P "7") (f55 : P "8") (f56 : P "9") (f57 : P ":") (f58 : P ";") (f59 : P "<") (f60 : P "=") (f61 : P ">") (f62 : P "?") + (f63 : P "@") (f64 : P "A") (f65 : P "B") (f66 : P "C") (f67 : P "D") (f68 : P "E") (f69 : P "F") (f70 : P "G") (f71 : P "H") (f72 : P "I") (f73 : P "J") (f74 : P "K") (f75 : P "L") (f76 : P "M") (f77 : P "N") (f78 : P "O") (f79 : P "P") (f80 : P "Q") (f81 : P "R") (f82 : P "S") (f83 : P "T") (f84 : P "U") (f85 : P "V") (f86 : P "W") (f87 : P "X") (f88 : P "Y") (f89 : P "Z") (f90 : P "[") (f91 : P "\") (f92 : P "]") (f93 : P "^") (f94 : P "_") (f95 : P "`") (f96 : P "a") (f97 : P "b") (f98 : P "c") (f99 : P "d") (f100 : P "e") (f101 : P "f") (f102 : P "g") (f103 : P "h") (f104 : P "i") (f105 : P "j") (f106 : P "k") (f107 : P "l") (f108 : P "m") (f109 : P "n") (f110 : P "o") (f111 : P "p") (f112 : P "q") (f113 : P "r") (f114 : P "s") (f115 : P "t") (f116 : P "u") (f117 : P "v") (f118 : P "w") (f119 : P "x") (f120 : P "y") (f121 : P "z") (f122 : P "{") (f123 : P "|") (f124 : P "}") (f125 : P "~") (f126 : P "127") (f127 : P "128") (f128 : P "129") (f129 : P "130") + (f130 : P "131") (f131 : P "132") (f132 : P "133") (f133 : P "134") (f134 : P "135") (f135 : P "136") (f136 : P "137") (f137 : P "138") (f138 : P "139") (f139 : P "140") (f140 : P "141") (f141 : P "142") (f142 : P "143") (f143 : P "144") (f144 : P "145") (f145 : P "146") (f146 : P "147") (f147 : P "148") (f148 : P "149") (f149 : P "150") (f150 : P "151") (f151 : P "152") (f152 : P "153") (f153 : P "154") (f154 : P "155") (f155 : P "156") (f156 : P "157") (f157 : P "158") (f158 : P "159") (f159 : P "160") (f160 : P "161") (f161 : P "162") (f162 : P "163") (f163 : P "164") (f164 : P "165") (f165 : P "166") (f166 : P "167") (f167 : P "168") (f168 : P "169") (f169 : P "170") (f170 : P "171") (f171 : P "172") (f172 : P "173") (f173 : P "174") (f174 : P "175") (f175 : P "176") (f176 : P "177") (f177 : P "178") (f178 : P "179") (f179 : P "180") (f180 : P "181") (f181 : P "182") (f182 : P "183") (f183 : P "184") (f184 : P "185") (f185 : P "186") (f186 : P "187") + (f187 : P "188") (f188 : P "189") (f189 : P "190") (f190 : P "191") (f191 : P "192") (f192 : P "193") (f193 : P "194") (f194 : P "195") (f195 : P "196") (f196 : P "197") (f197 : P "198") (f198 : P "199") (f199 : P "200") (f200 : P "201") (f201 : P "202") (f202 : P "203") (f203 : P "204") (f204 : P "205") (f205 : P "206") (f206 : P "207") (f207 : P "208") (f208 : P "209") (f209 : P "210") (f210 : P "211") (f211 : P "212") (f212 : P "213") (f213 : P "214") (f214 : P "215") (f215 : P "216") (f216 : P "217") (f217 : P "218") (f218 : P "219") (f219 : P "220") (f220 : P "221") (f221 : P "222") (f222 : P "223") (f223 : P "224") (f224 : P "225") (f225 : P "226") (f226 : P "227") (f227 : P "228") (f228 : P "229") (f229 : P "230") (f230 : P "231") (f231 : P "232") (f232 : P "233") (f233 : P "234") (f234 : P "235") (f235 : P "236") (f236 : P "237") (f237 : P "238") (f238 : P "239") (f239 : P "240") (f240 : P "241") (f241 : P "242") (f242 : P "243") (f243 : P "244") + (f244 : P "245") (f245 : P "246") (f246 : P "247") (f247 : P "248") (f248 : P "249") (f249 : P "250") (f250 : P "251") (f251 : P "252") (f252 : P "253") (f253 : P "254") (f254 : P "255") (b : byte) => +match b as b0 return (P b0) with +| "000" => f +| "001" => f0 +| "002" => f1 +| "003" => f2 +| "004" => f3 +| "005" => f4 +| "006" => f5 +| "007" => f6 +| "008" => f7 +| "009" => f8 +| "010" => f9 +| "011" => f10 +| "012" => f11 +| "013" => f12 +| "014" => f13 +| "015" => f14 +| "016" => f15 +| "017" => f16 +| "018" => f17 +| "019" => f18 +| "020" => f19 +| "021" => f20 +| "022" => f21 +| "023" => f22 +| "024" => f23 +| "025" => f24 +| "026" => f25 +| "027" => f26 +| "028" => f27 +| "029" => f28 +| "030" => f29 +| "031" => f30 +| " " => f31 +| "!" => f32 +| """" => f33 +| "#" => f34 +| "$" => f35 +| "%" => f36 +| "&" => f37 +| "'" => f38 +| "(" => f39 +| ")" => f40 +| "*" => f41 +| "+" => f42 +| "," => f43 +| "-" => f44 +| "." => f45 +| "/" => f46 +| "0" => f47 +| "1" => f48 +| "2" => f49 +| "3" => f50 +| "4" => f51 +| "5" => f52 +| "6" => f53 +| "7" => f54 +| "8" => f55 +| "9" => f56 +| ":" => f57 +| ";" => f58 +| "<" => f59 +| "=" => f60 +| ">" => f61 +| "?" => f62 +| "@" => f63 +| "A" => f64 +| "B" => f65 +| "C" => f66 +| "D" => f67 +| "E" => f68 +| "F" => f69 +| "G" => f70 +| "H" => f71 +| "I" => f72 +| "J" => f73 +| "K" => f74 +| "L" => f75 +| "M" => f76 +| "N" => f77 +| "O" => f78 +| "P" => f79 +| "Q" => f80 +| "R" => f81 +| "S" => f82 +| "T" => f83 +| "U" => f84 +| "V" => f85 +| "W" => f86 +| "X" => f87 +| "Y" => f88 +| "Z" => f89 +| "[" => f90 +| "\" => f91 +| "]" => f92 +| "^" => f93 +| "_" => f94 +| "`" => f95 +| "a" => f96 +| "b" => f97 +| "c" => f98 +| "d" => f99 +| "e" => f100 +| "f" => f101 +| "g" => f102 +| "h" => f103 +| "i" => f104 +| "j" => f105 +| "k" => f106 +| "l" => f107 +| "m" => f108 +| "n" => f109 +| "o" => f110 +| "p" => f111 +| "q" => f112 +| "r" => f113 +| "s" => f114 +| "t" => f115 +| "u" => f116 +| "v" => f117 +| "w" => f118 +| "x" => f119 +| "y" => f120 +| "z" => f121 +| "{" => f122 +| "|" => f123 +| "}" => f124 +| "~" => f125 +| "127" => f126 +| "128" => f127 +| "129" => f128 +| "130" => f129 +| "131" => f130 +| "132" => f131 +| "133" => f132 +| "134" => f133 +| "135" => f134 +| "136" => f135 +| "137" => f136 +| "138" => f137 +| "139" => f138 +| "140" => f139 +| "141" => f140 +| "142" => f141 +| "143" => f142 +| "144" => f143 +| "145" => f144 +| "146" => f145 +| "147" => f146 +| "148" => f147 +| "149" => f148 +| "150" => f149 +| "151" => f150 +| "152" => f151 +| "153" => f152 +| "154" => f153 +| "155" => f154 +| "156" => f155 +| "157" => f156 +| "158" => f157 +| "159" => f158 +| "160" => f159 +| "161" => f160 +| "162" => f161 +| "163" => f162 +| "164" => f163 +| "165" => f164 +| "166" => f165 +| "167" => f166 +| "168" => f167 +| "169" => f168 +| "170" => f169 +| "171" => f170 +| "172" => f171 +| "173" => f172 +| "174" => f173 +| "175" => f174 +| "176" => f175 +| "177" => f176 +| "178" => f177 +| "179" => f178 +| "180" => f179 +| "181" => f180 +| "182" => f181 +| "183" => f182 +| "184" => f183 +| "185" => f184 +| "186" => f185 +| "187" => f186 +| "188" => f187 +| "189" => f188 +| "190" => f189 +| "191" => f190 +| "192" => f191 +| "193" => f192 +| "194" => f193 +| "195" => f194 +| "196" => f195 +| "197" => f196 +| "198" => f197 +| "199" => f198 +| "200" => f199 +| "201" => f200 +| "202" => f201 +| "203" => f202 +| "204" => f203 +| "205" => f204 +| "206" => f205 +| "207" => f206 +| "208" => f207 +| "209" => f208 +| "210" => f209 +| "211" => f210 +| "212" => f211 +| "213" => f212 +| "214" => f213 +| "215" => f214 +| "216" => f215 +| "217" => f216 +| "218" => f217 +| "219" => f218 +| "220" => f219 +| "221" => f220 +| "222" => f221 +| "223" => f222 +| "224" => f223 +| "225" => f224 +| "226" => f225 +| "227" => f226 +| "228" => f227 +| "229" => f228 +| "230" => f229 +| "231" => f230 +| "232" => f231 +| "233" => f232 +| "234" => f233 +| "235" => f234 +| "236" => f235 +| "237" => f236 +| "238" => f237 +| "239" => f238 +| "240" => f239 +| "241" => f240 +| "242" => f241 +| "243" => f242 +| "244" => f243 +| "245" => f244 +| "246" => f245 +| "247" => f246 +| "248" => f247 +| "249" => f248 +| "250" => f249 +| "251" => f250 +| "252" => f251 +| "253" => f252 +| "254" => f253 +| "255" => f254 +end + : forall P : byte -> Prop, + P "000" -> + P "001" -> + P "002" -> + P "003" -> + P "004" -> + P "005" -> + P "006" -> + P "007" -> + P "008" -> + P "009" -> + P "010" -> + P "011" -> + P "012" -> + P "013" -> + P "014" -> + P "015" -> + P "016" -> + P "017" -> + P "018" -> + P "019" -> + P "020" -> + P "021" -> + P "022" -> + P "023" -> + P "024" -> + P "025" -> + P "026" -> + P "027" -> + P "028" -> + P "029" -> + P "030" -> + P "031" -> + P " " -> + P "!" -> + P """" -> + P "#" -> + P "$" -> + P "%" -> + P "&" -> + P "'" -> + P "(" -> + P ")" -> + P "*" -> + P "+" -> + P "," -> + P "-" -> + P "." -> + P "/" -> + P "0" -> + P "1" -> + P "2" -> + P "3" -> + P "4" -> + P "5" -> + P "6" -> + P "7" -> + P "8" -> + P "9" -> + P ":" -> + P ";" -> + P "<" -> + P "=" -> + P ">" -> + P "?" -> + P "@" -> + P "A" -> + P "B" -> + P "C" -> + P "D" -> + P "E" -> + P "F" -> + P "G" -> + P "H" -> + P "I" -> + P "J" -> + P "K" -> + P "L" -> + P "M" -> + P "N" -> + P "O" -> + P "P" -> + P "Q" -> + P "R" -> + P "S" -> + P "T" -> + P "U" -> + P "V" -> + P "W" -> + P "X" -> + P "Y" -> + P "Z" -> + P "[" -> + P "\" -> + P "]" -> + P "^" -> + P "_" -> + P "`" -> + P "a" -> + P "b" -> + P "c" -> + P "d" -> + P "e" -> + P "f" -> + P "g" -> + P "h" -> + P "i" -> + P "j" -> + P "k" -> + P "l" -> + P "m" -> + P "n" -> + P "o" -> + P "p" -> + P "q" -> + P "r" -> + P "s" -> + P "t" -> + P "u" -> + P "v" -> + P "w" -> + P "x" -> + P "y" -> + P "z" -> + P "{" -> + P "|" -> + P "}" -> + P "~" -> + P "127" -> + P "128" -> + P "129" -> + P "130" -> + P "131" -> + P "132" -> + P "133" -> + P "134" -> + P "135" -> + P "136" -> + P "137" -> + P "138" -> + P "139" -> + P "140" -> + P "141" -> + P "142" -> + P "143" -> + P "144" -> + P "145" -> + P "146" -> + P "147" -> + P "148" -> + P "149" -> + P "150" -> + P "151" -> + P "152" -> + P "153" -> + P "154" -> + P "155" -> + P "156" -> + P "157" -> + P "158" -> + P "159" -> + P "160" -> + P "161" -> + P "162" -> + P "163" -> + P "164" -> + P "165" -> + P "166" -> + P "167" -> + P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b + +byte_ind is not universe polymorphic +Argument scopes are [function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ byte_scope] +"000" + : byte +"a" + : byte +"127" + : byte +The command has indeed failed with message: +Expects a single character or a three-digits ascii code. +"000" + : ascii +"a" + : ascii +"127" + : ascii +The command has indeed failed with message: +Expects a single character or a three-digits ascii code. +"000" + : string +"a" + : string +"127" + : string +"€" + : string +"" + : string + = "a"%char + : ascii + = "a"%byte + : byte + = "a"%string + : string + = ["a"%byte] + : list byte + = ["000"; "001"; "002"; "003"; "004"; "005"; "006"; "007"; "008"; "009"; "010"; "011"; "012"; "013"; "014"; "015"; "016"; "017"; "018"; "019"; "020"; "021"; "022"; "023"; "024"; "025"; "026"; "027"; "028"; "029"; "030"; "031"; " "; "!"; """"; "#"; "$"; "%"; "&"; "'"; "("; ")"; "*"; "+"; ","; "-"; "."; "/"; "0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; ":"; ";"; "<"; "="; ">"; "?"; "@"; "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"; "["; "\"; "]"; "^"; "_"; "`"; "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"; "{"; "|"; "}"; "~"; "127"; "128"; "129"; "130"; "131"; "132"; "133"; "134"; "135"; "136"; "137"; "138"; "139"; "140"; "141"; "142"; "143"; "144"; "145"; "146"; "147"; "148"; "149"; "150"; "151"; "152"; "153"; "154"; "155"; "156"; "157"; "158"; "159"; "160"; "161"; "162"; "163"; "164"; "165"; "166"; "167"; + "168"; "169"; "170"; "171"; "172"; "173"; "174"; "175"; "176"; "177"; "178"; "179"; "180"; "181"; "182"; "183"; "184"; "185"; "186"; "187"; "188"; "189"; "190"; "191"; "192"; "193"; "194"; "195"; "196"; "197"; "198"; "199"; "200"; "201"; "202"; "203"; "204"; "205"; "206"; "207"; "208"; "209"; "210"; "211"; "212"; "213"; "214"; "215"; "216"; "217"; "218"; "219"; "220"; "221"; "222"; "223"; "224"; "225"; "226"; "227"; "228"; "229"; "230"; "231"; "232"; "233"; "234"; "235"; "236"; "237"; "238"; "239"; "240"; "241"; "242"; "243"; "244"; "245"; "246"; "247"; "248"; "249"; "250"; "251"; "252"; "253"; "254"; "255"] + : list byte + = ["000"; "001"; "002"; "003"; "004"; "005"; "006"; "007"; "008"; "009"; "010"; "011"; "012"; "013"; "014"; "015"; "016"; "017"; "018"; "019"; "020"; "021"; "022"; "023"; "024"; "025"; "026"; "027"; "028"; "029"; "030"; "031"; " "; "!"; """"; "#"; "$"; "%"; "&"; "'"; "("; ")"; "*"; "+"; ","; "-"; "."; "/"; "0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; ":"; ";"; "<"; "="; ">"; "?"; "@"; "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"; "["; "\"; "]"; "^"; "_"; "`"; "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"; "{"; "|"; "}"; "~"; "127"; "128"; "129"; "130"; "131"; "132"; "133"; "134"; "135"; "136"; "137"; "138"; "139"; "140"; "141"; "142"; "143"; "144"; "145"; "146"; "147"; "148"; "149"; "150"; "151"; "152"; "153"; "154"; "155"; "156"; "157"; "158"; "159"; "160"; "161"; "162"; "163"; "164"; "165"; "166"; "167"; + "168"; "169"; "170"; "171"; "172"; "173"; "174"; "175"; "176"; "177"; "178"; "179"; "180"; "181"; "182"; "183"; "184"; "185"; "186"; "187"; "188"; "189"; "190"; "191"; "192"; "193"; "194"; "195"; "196"; "197"; "198"; "199"; "200"; "201"; "202"; "203"; "204"; "205"; "206"; "207"; "208"; "209"; "210"; "211"; "212"; "213"; "214"; "215"; "216"; "217"; "218"; "219"; "220"; "221"; "222"; "223"; "224"; "225"; "226"; "227"; "228"; "229"; "230"; "231"; "232"; "233"; "234"; "235"; "236"; "237"; "238"; "239"; "240"; "241"; "242"; "243"; "244"; "245"; "246"; "247"; "248"; "249"; "250"; "251"; "252"; "253"; "254"; "255"] + : list ascii diff --git a/test-suite/output/StringSyntax.v b/test-suite/output/StringSyntax.v new file mode 100644 index 0000000000..aab6e0bb03 --- /dev/null +++ b/test-suite/output/StringSyntax.v @@ -0,0 +1,52 @@ +Require Import Coq.Lists.List. +Require Import Coq.Strings.String Coq.Strings.Byte Coq.Strings.Ascii. +Import ListNotations. + +Set Printing Depth 100000. +Set Printing Width 1000. + +Close Scope char_scope. +Close Scope string_scope. + +Open Scope byte_scope. +Print byte_rect. +Print byte_rec. +Print byte_ind. +Check "000". +Check "a". +Check "127". +Fail Check "€". +Close Scope byte_scope. + +Open Scope char_scope. +Check "000". +Check "a". +Check "127". +Fail Check "€". +Close Scope char_scope. + +Open Scope string_scope. +Check "000". +Check "a". +Check "127". +Check "€". +Check String "001" EmptyString. +Close Scope string_scope. + +Compute ascii_of_byte "a". +Compute byte_of_ascii "a". +Compute string_of_list_byte ("a"::nil)%byte. +Compute list_byte_of_string "a". + +Local Open Scope byte_scope. +Compute List.fold_right + (fun n ls => match Byte.of_nat n with + | Some b => cons b ls + | None => ls + end) + nil + (List.seq 0 256). +Local Close Scope byte_scope. +Local Open Scope char_scope. +Compute List.map Ascii.ascii_of_nat (List.seq 0 256). +Local Close Scope char_scope. diff --git a/theories/Init/Byte.v b/theories/Init/Byte.v new file mode 100644 index 0000000000..eede9d5028 --- /dev/null +++ b/theories/Init/Byte.v @@ -0,0 +1,830 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * Bytes *) + +Require Import Coq.Init.Datatypes. +Require Import Coq.Init.Logic. +Require Import Coq.Init.Specif. +Require Coq.Init.Nat. + +Declare ML Module "string_notation_plugin". + +(** We define an inductive for use with the [String Notation] command + which contains all ascii characters. We use 256 constructors for + efficiency and ease of conversion. *) + +Declare Scope byte_scope. +Delimit Scope byte_scope with byte. + +Inductive byte := +| x00 +| x01 +| x02 +| x03 +| x04 +| x05 +| x06 +| x07 +| x08 +| x09 +| x0a +| x0b +| x0c +| x0d +| x0e +| x0f +| x10 +| x11 +| x12 +| x13 +| x14 +| x15 +| x16 +| x17 +| x18 +| x19 +| x1a +| x1b +| x1c +| x1d +| x1e +| x1f +| x20 +| x21 +| x22 +| x23 +| x24 +| x25 +| x26 +| x27 +| x28 +| x29 +| x2a +| x2b +| x2c +| x2d +| x2e +| x2f +| x30 +| x31 +| x32 +| x33 +| x34 +| x35 +| x36 +| x37 +| x38 +| x39 +| x3a +| x3b +| x3c +| x3d +| x3e +| x3f +| x40 +| x41 +| x42 +| x43 +| x44 +| x45 +| x46 +| x47 +| x48 +| x49 +| x4a +| x4b +| x4c +| x4d +| x4e +| x4f +| x50 +| x51 +| x52 +| x53 +| x54 +| x55 +| x56 +| x57 +| x58 +| x59 +| x5a +| x5b +| x5c +| x5d +| x5e +| x5f +| x60 +| x61 +| x62 +| x63 +| x64 +| x65 +| x66 +| x67 +| x68 +| x69 +| x6a +| x6b +| x6c +| x6d +| x6e +| x6f +| x70 +| x71 +| x72 +| x73 +| x74 +| x75 +| x76 +| x77 +| x78 +| x79 +| x7a +| x7b +| x7c +| x7d +| x7e +| x7f +| x80 +| x81 +| x82 +| x83 +| x84 +| x85 +| x86 +| x87 +| x88 +| x89 +| x8a +| x8b +| x8c +| x8d +| x8e +| x8f +| x90 +| x91 +| x92 +| x93 +| x94 +| x95 +| x96 +| x97 +| x98 +| x99 +| x9a +| x9b +| x9c +| x9d +| x9e +| x9f +| xa0 +| xa1 +| xa2 +| xa3 +| xa4 +| xa5 +| xa6 +| xa7 +| xa8 +| xa9 +| xaa +| xab +| xac +| xad +| xae +| xaf +| xb0 +| xb1 +| xb2 +| xb3 +| xb4 +| xb5 +| xb6 +| xb7 +| xb8 +| xb9 +| xba +| xbb +| xbc +| xbd +| xbe +| xbf +| xc0 +| xc1 +| xc2 +| xc3 +| xc4 +| xc5 +| xc6 +| xc7 +| xc8 +| xc9 +| xca +| xcb +| xcc +| xcd +| xce +| xcf +| xd0 +| xd1 +| xd2 +| xd3 +| xd4 +| xd5 +| xd6 +| xd7 +| xd8 +| xd9 +| xda +| xdb +| xdc +| xdd +| xde +| xdf +| xe0 +| xe1 +| xe2 +| xe3 +| xe4 +| xe5 +| xe6 +| xe7 +| xe8 +| xe9 +| xea +| xeb +| xec +| xed +| xee +| xef +| xf0 +| xf1 +| xf2 +| xf3 +| xf4 +| xf5 +| xf6 +| xf7 +| xf8 +| xf9 +| xfa +| xfb +| xfc +| xfd +| xfe +| xff +. + +Bind Scope byte_scope with byte. + +Register byte as core.byte.type. + +Local Notation "0" := false. +Local Notation "1" := true. + +(** We pick a definition that matches with [Ascii.ascii] *) +Definition of_bits (b : bool * (bool * (bool * (bool * (bool * (bool * (bool * bool))))))) : byte + := match b with + | (0,(0,(0,(0,(0,(0,(0,0))))))) => x00 + | (1,(0,(0,(0,(0,(0,(0,0))))))) => x01 + | (0,(1,(0,(0,(0,(0,(0,0))))))) => x02 + | (1,(1,(0,(0,(0,(0,(0,0))))))) => x03 + | (0,(0,(1,(0,(0,(0,(0,0))))))) => x04 + | (1,(0,(1,(0,(0,(0,(0,0))))))) => x05 + | (0,(1,(1,(0,(0,(0,(0,0))))))) => x06 + | (1,(1,(1,(0,(0,(0,(0,0))))))) => x07 + | (0,(0,(0,(1,(0,(0,(0,0))))))) => x08 + | (1,(0,(0,(1,(0,(0,(0,0))))))) => x09 + | (0,(1,(0,(1,(0,(0,(0,0))))))) => x0a + | (1,(1,(0,(1,(0,(0,(0,0))))))) => x0b + | (0,(0,(1,(1,(0,(0,(0,0))))))) => x0c + | (1,(0,(1,(1,(0,(0,(0,0))))))) => x0d + | (0,(1,(1,(1,(0,(0,(0,0))))))) => x0e + | (1,(1,(1,(1,(0,(0,(0,0))))))) => x0f + | (0,(0,(0,(0,(1,(0,(0,0))))))) => x10 + | (1,(0,(0,(0,(1,(0,(0,0))))))) => x11 + | (0,(1,(0,(0,(1,(0,(0,0))))))) => x12 + | (1,(1,(0,(0,(1,(0,(0,0))))))) => x13 + | (0,(0,(1,(0,(1,(0,(0,0))))))) => x14 + | (1,(0,(1,(0,(1,(0,(0,0))))))) => x15 + | (0,(1,(1,(0,(1,(0,(0,0))))))) => x16 + | (1,(1,(1,(0,(1,(0,(0,0))))))) => x17 + | (0,(0,(0,(1,(1,(0,(0,0))))))) => x18 + | (1,(0,(0,(1,(1,(0,(0,0))))))) => x19 + | (0,(1,(0,(1,(1,(0,(0,0))))))) => x1a + | (1,(1,(0,(1,(1,(0,(0,0))))))) => x1b + | (0,(0,(1,(1,(1,(0,(0,0))))))) => x1c + | (1,(0,(1,(1,(1,(0,(0,0))))))) => x1d + | (0,(1,(1,(1,(1,(0,(0,0))))))) => x1e + | (1,(1,(1,(1,(1,(0,(0,0))))))) => x1f + | (0,(0,(0,(0,(0,(1,(0,0))))))) => x20 + | (1,(0,(0,(0,(0,(1,(0,0))))))) => x21 + | (0,(1,(0,(0,(0,(1,(0,0))))))) => x22 + | (1,(1,(0,(0,(0,(1,(0,0))))))) => x23 + | (0,(0,(1,(0,(0,(1,(0,0))))))) => x24 + | (1,(0,(1,(0,(0,(1,(0,0))))))) => x25 + | (0,(1,(1,(0,(0,(1,(0,0))))))) => x26 + | (1,(1,(1,(0,(0,(1,(0,0))))))) => x27 + | (0,(0,(0,(1,(0,(1,(0,0))))))) => x28 + | (1,(0,(0,(1,(0,(1,(0,0))))))) => x29 + | (0,(1,(0,(1,(0,(1,(0,0))))))) => x2a + | (1,(1,(0,(1,(0,(1,(0,0))))))) => x2b + | (0,(0,(1,(1,(0,(1,(0,0))))))) => x2c + | (1,(0,(1,(1,(0,(1,(0,0))))))) => x2d + | (0,(1,(1,(1,(0,(1,(0,0))))))) => x2e + | (1,(1,(1,(1,(0,(1,(0,0))))))) => x2f + | (0,(0,(0,(0,(1,(1,(0,0))))))) => x30 + | (1,(0,(0,(0,(1,(1,(0,0))))))) => x31 + | (0,(1,(0,(0,(1,(1,(0,0))))))) => x32 + | (1,(1,(0,(0,(1,(1,(0,0))))))) => x33 + | (0,(0,(1,(0,(1,(1,(0,0))))))) => x34 + | (1,(0,(1,(0,(1,(1,(0,0))))))) => x35 + | (0,(1,(1,(0,(1,(1,(0,0))))))) => x36 + | (1,(1,(1,(0,(1,(1,(0,0))))))) => x37 + | (0,(0,(0,(1,(1,(1,(0,0))))))) => x38 + | (1,(0,(0,(1,(1,(1,(0,0))))))) => x39 + | (0,(1,(0,(1,(1,(1,(0,0))))))) => x3a + | (1,(1,(0,(1,(1,(1,(0,0))))))) => x3b + | (0,(0,(1,(1,(1,(1,(0,0))))))) => x3c + | (1,(0,(1,(1,(1,(1,(0,0))))))) => x3d + | (0,(1,(1,(1,(1,(1,(0,0))))))) => x3e + | (1,(1,(1,(1,(1,(1,(0,0))))))) => x3f + | (0,(0,(0,(0,(0,(0,(1,0))))))) => x40 + | (1,(0,(0,(0,(0,(0,(1,0))))))) => x41 + | (0,(1,(0,(0,(0,(0,(1,0))))))) => x42 + | (1,(1,(0,(0,(0,(0,(1,0))))))) => x43 + | (0,(0,(1,(0,(0,(0,(1,0))))))) => x44 + | (1,(0,(1,(0,(0,(0,(1,0))))))) => x45 + | (0,(1,(1,(0,(0,(0,(1,0))))))) => x46 + | (1,(1,(1,(0,(0,(0,(1,0))))))) => x47 + | (0,(0,(0,(1,(0,(0,(1,0))))))) => x48 + | (1,(0,(0,(1,(0,(0,(1,0))))))) => x49 + | (0,(1,(0,(1,(0,(0,(1,0))))))) => x4a + | (1,(1,(0,(1,(0,(0,(1,0))))))) => x4b + | (0,(0,(1,(1,(0,(0,(1,0))))))) => x4c + | (1,(0,(1,(1,(0,(0,(1,0))))))) => x4d + | (0,(1,(1,(1,(0,(0,(1,0))))))) => x4e + | (1,(1,(1,(1,(0,(0,(1,0))))))) => x4f + | (0,(0,(0,(0,(1,(0,(1,0))))))) => x50 + | (1,(0,(0,(0,(1,(0,(1,0))))))) => x51 + | (0,(1,(0,(0,(1,(0,(1,0))))))) => x52 + | (1,(1,(0,(0,(1,(0,(1,0))))))) => x53 + | (0,(0,(1,(0,(1,(0,(1,0))))))) => x54 + | (1,(0,(1,(0,(1,(0,(1,0))))))) => x55 + | (0,(1,(1,(0,(1,(0,(1,0))))))) => x56 + | (1,(1,(1,(0,(1,(0,(1,0))))))) => x57 + | (0,(0,(0,(1,(1,(0,(1,0))))))) => x58 + | (1,(0,(0,(1,(1,(0,(1,0))))))) => x59 + | (0,(1,(0,(1,(1,(0,(1,0))))))) => x5a + | (1,(1,(0,(1,(1,(0,(1,0))))))) => x5b + | (0,(0,(1,(1,(1,(0,(1,0))))))) => x5c + | (1,(0,(1,(1,(1,(0,(1,0))))))) => x5d + | (0,(1,(1,(1,(1,(0,(1,0))))))) => x5e + | (1,(1,(1,(1,(1,(0,(1,0))))))) => x5f + | (0,(0,(0,(0,(0,(1,(1,0))))))) => x60 + | (1,(0,(0,(0,(0,(1,(1,0))))))) => x61 + | (0,(1,(0,(0,(0,(1,(1,0))))))) => x62 + | (1,(1,(0,(0,(0,(1,(1,0))))))) => x63 + | (0,(0,(1,(0,(0,(1,(1,0))))))) => x64 + | (1,(0,(1,(0,(0,(1,(1,0))))))) => x65 + | (0,(1,(1,(0,(0,(1,(1,0))))))) => x66 + | (1,(1,(1,(0,(0,(1,(1,0))))))) => x67 + | (0,(0,(0,(1,(0,(1,(1,0))))))) => x68 + | (1,(0,(0,(1,(0,(1,(1,0))))))) => x69 + | (0,(1,(0,(1,(0,(1,(1,0))))))) => x6a + | (1,(1,(0,(1,(0,(1,(1,0))))))) => x6b + | (0,(0,(1,(1,(0,(1,(1,0))))))) => x6c + | (1,(0,(1,(1,(0,(1,(1,0))))))) => x6d + | (0,(1,(1,(1,(0,(1,(1,0))))))) => x6e + | (1,(1,(1,(1,(0,(1,(1,0))))))) => x6f + | (0,(0,(0,(0,(1,(1,(1,0))))))) => x70 + | (1,(0,(0,(0,(1,(1,(1,0))))))) => x71 + | (0,(1,(0,(0,(1,(1,(1,0))))))) => x72 + | (1,(1,(0,(0,(1,(1,(1,0))))))) => x73 + | (0,(0,(1,(0,(1,(1,(1,0))))))) => x74 + | (1,(0,(1,(0,(1,(1,(1,0))))))) => x75 + | (0,(1,(1,(0,(1,(1,(1,0))))))) => x76 + | (1,(1,(1,(0,(1,(1,(1,0))))))) => x77 + | (0,(0,(0,(1,(1,(1,(1,0))))))) => x78 + | (1,(0,(0,(1,(1,(1,(1,0))))))) => x79 + | (0,(1,(0,(1,(1,(1,(1,0))))))) => x7a + | (1,(1,(0,(1,(1,(1,(1,0))))))) => x7b + | (0,(0,(1,(1,(1,(1,(1,0))))))) => x7c + | (1,(0,(1,(1,(1,(1,(1,0))))))) => x7d + | (0,(1,(1,(1,(1,(1,(1,0))))))) => x7e + | (1,(1,(1,(1,(1,(1,(1,0))))))) => x7f + | (0,(0,(0,(0,(0,(0,(0,1))))))) => x80 + | (1,(0,(0,(0,(0,(0,(0,1))))))) => x81 + | (0,(1,(0,(0,(0,(0,(0,1))))))) => x82 + | (1,(1,(0,(0,(0,(0,(0,1))))))) => x83 + | (0,(0,(1,(0,(0,(0,(0,1))))))) => x84 + | (1,(0,(1,(0,(0,(0,(0,1))))))) => x85 + | (0,(1,(1,(0,(0,(0,(0,1))))))) => x86 + | (1,(1,(1,(0,(0,(0,(0,1))))))) => x87 + | (0,(0,(0,(1,(0,(0,(0,1))))))) => x88 + | (1,(0,(0,(1,(0,(0,(0,1))))))) => x89 + | (0,(1,(0,(1,(0,(0,(0,1))))))) => x8a + | (1,(1,(0,(1,(0,(0,(0,1))))))) => x8b + | (0,(0,(1,(1,(0,(0,(0,1))))))) => x8c + | (1,(0,(1,(1,(0,(0,(0,1))))))) => x8d + | (0,(1,(1,(1,(0,(0,(0,1))))))) => x8e + | (1,(1,(1,(1,(0,(0,(0,1))))))) => x8f + | (0,(0,(0,(0,(1,(0,(0,1))))))) => x90 + | (1,(0,(0,(0,(1,(0,(0,1))))))) => x91 + | (0,(1,(0,(0,(1,(0,(0,1))))))) => x92 + | (1,(1,(0,(0,(1,(0,(0,1))))))) => x93 + | (0,(0,(1,(0,(1,(0,(0,1))))))) => x94 + | (1,(0,(1,(0,(1,(0,(0,1))))))) => x95 + | (0,(1,(1,(0,(1,(0,(0,1))))))) => x96 + | (1,(1,(1,(0,(1,(0,(0,1))))))) => x97 + | (0,(0,(0,(1,(1,(0,(0,1))))))) => x98 + | (1,(0,(0,(1,(1,(0,(0,1))))))) => x99 + | (0,(1,(0,(1,(1,(0,(0,1))))))) => x9a + | (1,(1,(0,(1,(1,(0,(0,1))))))) => x9b + | (0,(0,(1,(1,(1,(0,(0,1))))))) => x9c + | (1,(0,(1,(1,(1,(0,(0,1))))))) => x9d + | (0,(1,(1,(1,(1,(0,(0,1))))))) => x9e + | (1,(1,(1,(1,(1,(0,(0,1))))))) => x9f + | (0,(0,(0,(0,(0,(1,(0,1))))))) => xa0 + | (1,(0,(0,(0,(0,(1,(0,1))))))) => xa1 + | (0,(1,(0,(0,(0,(1,(0,1))))))) => xa2 + | (1,(1,(0,(0,(0,(1,(0,1))))))) => xa3 + | (0,(0,(1,(0,(0,(1,(0,1))))))) => xa4 + | (1,(0,(1,(0,(0,(1,(0,1))))))) => xa5 + | (0,(1,(1,(0,(0,(1,(0,1))))))) => xa6 + | (1,(1,(1,(0,(0,(1,(0,1))))))) => xa7 + | (0,(0,(0,(1,(0,(1,(0,1))))))) => xa8 + | (1,(0,(0,(1,(0,(1,(0,1))))))) => xa9 + | (0,(1,(0,(1,(0,(1,(0,1))))))) => xaa + | (1,(1,(0,(1,(0,(1,(0,1))))))) => xab + | (0,(0,(1,(1,(0,(1,(0,1))))))) => xac + | (1,(0,(1,(1,(0,(1,(0,1))))))) => xad + | (0,(1,(1,(1,(0,(1,(0,1))))))) => xae + | (1,(1,(1,(1,(0,(1,(0,1))))))) => xaf + | (0,(0,(0,(0,(1,(1,(0,1))))))) => xb0 + | (1,(0,(0,(0,(1,(1,(0,1))))))) => xb1 + | (0,(1,(0,(0,(1,(1,(0,1))))))) => xb2 + | (1,(1,(0,(0,(1,(1,(0,1))))))) => xb3 + | (0,(0,(1,(0,(1,(1,(0,1))))))) => xb4 + | (1,(0,(1,(0,(1,(1,(0,1))))))) => xb5 + | (0,(1,(1,(0,(1,(1,(0,1))))))) => xb6 + | (1,(1,(1,(0,(1,(1,(0,1))))))) => xb7 + | (0,(0,(0,(1,(1,(1,(0,1))))))) => xb8 + | (1,(0,(0,(1,(1,(1,(0,1))))))) => xb9 + | (0,(1,(0,(1,(1,(1,(0,1))))))) => xba + | (1,(1,(0,(1,(1,(1,(0,1))))))) => xbb + | (0,(0,(1,(1,(1,(1,(0,1))))))) => xbc + | (1,(0,(1,(1,(1,(1,(0,1))))))) => xbd + | (0,(1,(1,(1,(1,(1,(0,1))))))) => xbe + | (1,(1,(1,(1,(1,(1,(0,1))))))) => xbf + | (0,(0,(0,(0,(0,(0,(1,1))))))) => xc0 + | (1,(0,(0,(0,(0,(0,(1,1))))))) => xc1 + | (0,(1,(0,(0,(0,(0,(1,1))))))) => xc2 + | (1,(1,(0,(0,(0,(0,(1,1))))))) => xc3 + | (0,(0,(1,(0,(0,(0,(1,1))))))) => xc4 + | (1,(0,(1,(0,(0,(0,(1,1))))))) => xc5 + | (0,(1,(1,(0,(0,(0,(1,1))))))) => xc6 + | (1,(1,(1,(0,(0,(0,(1,1))))))) => xc7 + | (0,(0,(0,(1,(0,(0,(1,1))))))) => xc8 + | (1,(0,(0,(1,(0,(0,(1,1))))))) => xc9 + | (0,(1,(0,(1,(0,(0,(1,1))))))) => xca + | (1,(1,(0,(1,(0,(0,(1,1))))))) => xcb + | (0,(0,(1,(1,(0,(0,(1,1))))))) => xcc + | (1,(0,(1,(1,(0,(0,(1,1))))))) => xcd + | (0,(1,(1,(1,(0,(0,(1,1))))))) => xce + | (1,(1,(1,(1,(0,(0,(1,1))))))) => xcf + | (0,(0,(0,(0,(1,(0,(1,1))))))) => xd0 + | (1,(0,(0,(0,(1,(0,(1,1))))))) => xd1 + | (0,(1,(0,(0,(1,(0,(1,1))))))) => xd2 + | (1,(1,(0,(0,(1,(0,(1,1))))))) => xd3 + | (0,(0,(1,(0,(1,(0,(1,1))))))) => xd4 + | (1,(0,(1,(0,(1,(0,(1,1))))))) => xd5 + | (0,(1,(1,(0,(1,(0,(1,1))))))) => xd6 + | (1,(1,(1,(0,(1,(0,(1,1))))))) => xd7 + | (0,(0,(0,(1,(1,(0,(1,1))))))) => xd8 + | (1,(0,(0,(1,(1,(0,(1,1))))))) => xd9 + | (0,(1,(0,(1,(1,(0,(1,1))))))) => xda + | (1,(1,(0,(1,(1,(0,(1,1))))))) => xdb + | (0,(0,(1,(1,(1,(0,(1,1))))))) => xdc + | (1,(0,(1,(1,(1,(0,(1,1))))))) => xdd + | (0,(1,(1,(1,(1,(0,(1,1))))))) => xde + | (1,(1,(1,(1,(1,(0,(1,1))))))) => xdf + | (0,(0,(0,(0,(0,(1,(1,1))))))) => xe0 + | (1,(0,(0,(0,(0,(1,(1,1))))))) => xe1 + | (0,(1,(0,(0,(0,(1,(1,1))))))) => xe2 + | (1,(1,(0,(0,(0,(1,(1,1))))))) => xe3 + | (0,(0,(1,(0,(0,(1,(1,1))))))) => xe4 + | (1,(0,(1,(0,(0,(1,(1,1))))))) => xe5 + | (0,(1,(1,(0,(0,(1,(1,1))))))) => xe6 + | (1,(1,(1,(0,(0,(1,(1,1))))))) => xe7 + | (0,(0,(0,(1,(0,(1,(1,1))))))) => xe8 + | (1,(0,(0,(1,(0,(1,(1,1))))))) => xe9 + | (0,(1,(0,(1,(0,(1,(1,1))))))) => xea + | (1,(1,(0,(1,(0,(1,(1,1))))))) => xeb + | (0,(0,(1,(1,(0,(1,(1,1))))))) => xec + | (1,(0,(1,(1,(0,(1,(1,1))))))) => xed + | (0,(1,(1,(1,(0,(1,(1,1))))))) => xee + | (1,(1,(1,(1,(0,(1,(1,1))))))) => xef + | (0,(0,(0,(0,(1,(1,(1,1))))))) => xf0 + | (1,(0,(0,(0,(1,(1,(1,1))))))) => xf1 + | (0,(1,(0,(0,(1,(1,(1,1))))))) => xf2 + | (1,(1,(0,(0,(1,(1,(1,1))))))) => xf3 + | (0,(0,(1,(0,(1,(1,(1,1))))))) => xf4 + | (1,(0,(1,(0,(1,(1,(1,1))))))) => xf5 + | (0,(1,(1,(0,(1,(1,(1,1))))))) => xf6 + | (1,(1,(1,(0,(1,(1,(1,1))))))) => xf7 + | (0,(0,(0,(1,(1,(1,(1,1))))))) => xf8 + | (1,(0,(0,(1,(1,(1,(1,1))))))) => xf9 + | (0,(1,(0,(1,(1,(1,(1,1))))))) => xfa + | (1,(1,(0,(1,(1,(1,(1,1))))))) => xfb + | (0,(0,(1,(1,(1,(1,(1,1))))))) => xfc + | (1,(0,(1,(1,(1,(1,(1,1))))))) => xfd + | (0,(1,(1,(1,(1,(1,(1,1))))))) => xfe + | (1,(1,(1,(1,(1,(1,(1,1))))))) => xff + end. + +Definition to_bits (b : byte) : bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) + := match b with + | x00 => (0,(0,(0,(0,(0,(0,(0,0))))))) + | x01 => (1,(0,(0,(0,(0,(0,(0,0))))))) + | x02 => (0,(1,(0,(0,(0,(0,(0,0))))))) + | x03 => (1,(1,(0,(0,(0,(0,(0,0))))))) + | x04 => (0,(0,(1,(0,(0,(0,(0,0))))))) + | x05 => (1,(0,(1,(0,(0,(0,(0,0))))))) + | x06 => (0,(1,(1,(0,(0,(0,(0,0))))))) + | x07 => (1,(1,(1,(0,(0,(0,(0,0))))))) + | x08 => (0,(0,(0,(1,(0,(0,(0,0))))))) + | x09 => (1,(0,(0,(1,(0,(0,(0,0))))))) + | x0a => (0,(1,(0,(1,(0,(0,(0,0))))))) + | x0b => (1,(1,(0,(1,(0,(0,(0,0))))))) + | x0c => (0,(0,(1,(1,(0,(0,(0,0))))))) + | x0d => (1,(0,(1,(1,(0,(0,(0,0))))))) + | x0e => (0,(1,(1,(1,(0,(0,(0,0))))))) + | x0f => (1,(1,(1,(1,(0,(0,(0,0))))))) + | x10 => (0,(0,(0,(0,(1,(0,(0,0))))))) + | x11 => (1,(0,(0,(0,(1,(0,(0,0))))))) + | x12 => (0,(1,(0,(0,(1,(0,(0,0))))))) + | x13 => (1,(1,(0,(0,(1,(0,(0,0))))))) + | x14 => (0,(0,(1,(0,(1,(0,(0,0))))))) + | x15 => (1,(0,(1,(0,(1,(0,(0,0))))))) + | x16 => (0,(1,(1,(0,(1,(0,(0,0))))))) + | x17 => (1,(1,(1,(0,(1,(0,(0,0))))))) + | x18 => (0,(0,(0,(1,(1,(0,(0,0))))))) + | x19 => (1,(0,(0,(1,(1,(0,(0,0))))))) + | x1a => (0,(1,(0,(1,(1,(0,(0,0))))))) + | x1b => (1,(1,(0,(1,(1,(0,(0,0))))))) + | x1c => (0,(0,(1,(1,(1,(0,(0,0))))))) + | x1d => (1,(0,(1,(1,(1,(0,(0,0))))))) + | x1e => (0,(1,(1,(1,(1,(0,(0,0))))))) + | x1f => (1,(1,(1,(1,(1,(0,(0,0))))))) + | x20 => (0,(0,(0,(0,(0,(1,(0,0))))))) + | x21 => (1,(0,(0,(0,(0,(1,(0,0))))))) + | x22 => (0,(1,(0,(0,(0,(1,(0,0))))))) + | x23 => (1,(1,(0,(0,(0,(1,(0,0))))))) + | x24 => (0,(0,(1,(0,(0,(1,(0,0))))))) + | x25 => (1,(0,(1,(0,(0,(1,(0,0))))))) + | x26 => (0,(1,(1,(0,(0,(1,(0,0))))))) + | x27 => (1,(1,(1,(0,(0,(1,(0,0))))))) + | x28 => (0,(0,(0,(1,(0,(1,(0,0))))))) + | x29 => (1,(0,(0,(1,(0,(1,(0,0))))))) + | x2a => (0,(1,(0,(1,(0,(1,(0,0))))))) + | x2b => (1,(1,(0,(1,(0,(1,(0,0))))))) + | x2c => (0,(0,(1,(1,(0,(1,(0,0))))))) + | x2d => (1,(0,(1,(1,(0,(1,(0,0))))))) + | x2e => (0,(1,(1,(1,(0,(1,(0,0))))))) + | x2f => (1,(1,(1,(1,(0,(1,(0,0))))))) + | x30 => (0,(0,(0,(0,(1,(1,(0,0))))))) + | x31 => (1,(0,(0,(0,(1,(1,(0,0))))))) + | x32 => (0,(1,(0,(0,(1,(1,(0,0))))))) + | x33 => (1,(1,(0,(0,(1,(1,(0,0))))))) + | x34 => (0,(0,(1,(0,(1,(1,(0,0))))))) + | x35 => (1,(0,(1,(0,(1,(1,(0,0))))))) + | x36 => (0,(1,(1,(0,(1,(1,(0,0))))))) + | x37 => (1,(1,(1,(0,(1,(1,(0,0))))))) + | x38 => (0,(0,(0,(1,(1,(1,(0,0))))))) + | x39 => (1,(0,(0,(1,(1,(1,(0,0))))))) + | x3a => (0,(1,(0,(1,(1,(1,(0,0))))))) + | x3b => (1,(1,(0,(1,(1,(1,(0,0))))))) + | x3c => (0,(0,(1,(1,(1,(1,(0,0))))))) + | x3d => (1,(0,(1,(1,(1,(1,(0,0))))))) + | x3e => (0,(1,(1,(1,(1,(1,(0,0))))))) + | x3f => (1,(1,(1,(1,(1,(1,(0,0))))))) + | x40 => (0,(0,(0,(0,(0,(0,(1,0))))))) + | x41 => (1,(0,(0,(0,(0,(0,(1,0))))))) + | x42 => (0,(1,(0,(0,(0,(0,(1,0))))))) + | x43 => (1,(1,(0,(0,(0,(0,(1,0))))))) + | x44 => (0,(0,(1,(0,(0,(0,(1,0))))))) + | x45 => (1,(0,(1,(0,(0,(0,(1,0))))))) + | x46 => (0,(1,(1,(0,(0,(0,(1,0))))))) + | x47 => (1,(1,(1,(0,(0,(0,(1,0))))))) + | x48 => (0,(0,(0,(1,(0,(0,(1,0))))))) + | x49 => (1,(0,(0,(1,(0,(0,(1,0))))))) + | x4a => (0,(1,(0,(1,(0,(0,(1,0))))))) + | x4b => (1,(1,(0,(1,(0,(0,(1,0))))))) + | x4c => (0,(0,(1,(1,(0,(0,(1,0))))))) + | x4d => (1,(0,(1,(1,(0,(0,(1,0))))))) + | x4e => (0,(1,(1,(1,(0,(0,(1,0))))))) + | x4f => (1,(1,(1,(1,(0,(0,(1,0))))))) + | x50 => (0,(0,(0,(0,(1,(0,(1,0))))))) + | x51 => (1,(0,(0,(0,(1,(0,(1,0))))))) + | x52 => (0,(1,(0,(0,(1,(0,(1,0))))))) + | x53 => (1,(1,(0,(0,(1,(0,(1,0))))))) + | x54 => (0,(0,(1,(0,(1,(0,(1,0))))))) + | x55 => (1,(0,(1,(0,(1,(0,(1,0))))))) + | x56 => (0,(1,(1,(0,(1,(0,(1,0))))))) + | x57 => (1,(1,(1,(0,(1,(0,(1,0))))))) + | x58 => (0,(0,(0,(1,(1,(0,(1,0))))))) + | x59 => (1,(0,(0,(1,(1,(0,(1,0))))))) + | x5a => (0,(1,(0,(1,(1,(0,(1,0))))))) + | x5b => (1,(1,(0,(1,(1,(0,(1,0))))))) + | x5c => (0,(0,(1,(1,(1,(0,(1,0))))))) + | x5d => (1,(0,(1,(1,(1,(0,(1,0))))))) + | x5e => (0,(1,(1,(1,(1,(0,(1,0))))))) + | x5f => (1,(1,(1,(1,(1,(0,(1,0))))))) + | x60 => (0,(0,(0,(0,(0,(1,(1,0))))))) + | x61 => (1,(0,(0,(0,(0,(1,(1,0))))))) + | x62 => (0,(1,(0,(0,(0,(1,(1,0))))))) + | x63 => (1,(1,(0,(0,(0,(1,(1,0))))))) + | x64 => (0,(0,(1,(0,(0,(1,(1,0))))))) + | x65 => (1,(0,(1,(0,(0,(1,(1,0))))))) + | x66 => (0,(1,(1,(0,(0,(1,(1,0))))))) + | x67 => (1,(1,(1,(0,(0,(1,(1,0))))))) + | x68 => (0,(0,(0,(1,(0,(1,(1,0))))))) + | x69 => (1,(0,(0,(1,(0,(1,(1,0))))))) + | x6a => (0,(1,(0,(1,(0,(1,(1,0))))))) + | x6b => (1,(1,(0,(1,(0,(1,(1,0))))))) + | x6c => (0,(0,(1,(1,(0,(1,(1,0))))))) + | x6d => (1,(0,(1,(1,(0,(1,(1,0))))))) + | x6e => (0,(1,(1,(1,(0,(1,(1,0))))))) + | x6f => (1,(1,(1,(1,(0,(1,(1,0))))))) + | x70 => (0,(0,(0,(0,(1,(1,(1,0))))))) + | x71 => (1,(0,(0,(0,(1,(1,(1,0))))))) + | x72 => (0,(1,(0,(0,(1,(1,(1,0))))))) + | x73 => (1,(1,(0,(0,(1,(1,(1,0))))))) + | x74 => (0,(0,(1,(0,(1,(1,(1,0))))))) + | x75 => (1,(0,(1,(0,(1,(1,(1,0))))))) + | x76 => (0,(1,(1,(0,(1,(1,(1,0))))))) + | x77 => (1,(1,(1,(0,(1,(1,(1,0))))))) + | x78 => (0,(0,(0,(1,(1,(1,(1,0))))))) + | x79 => (1,(0,(0,(1,(1,(1,(1,0))))))) + | x7a => (0,(1,(0,(1,(1,(1,(1,0))))))) + | x7b => (1,(1,(0,(1,(1,(1,(1,0))))))) + | x7c => (0,(0,(1,(1,(1,(1,(1,0))))))) + | x7d => (1,(0,(1,(1,(1,(1,(1,0))))))) + | x7e => (0,(1,(1,(1,(1,(1,(1,0))))))) + | x7f => (1,(1,(1,(1,(1,(1,(1,0))))))) + | x80 => (0,(0,(0,(0,(0,(0,(0,1))))))) + | x81 => (1,(0,(0,(0,(0,(0,(0,1))))))) + | x82 => (0,(1,(0,(0,(0,(0,(0,1))))))) + | x83 => (1,(1,(0,(0,(0,(0,(0,1))))))) + | x84 => (0,(0,(1,(0,(0,(0,(0,1))))))) + | x85 => (1,(0,(1,(0,(0,(0,(0,1))))))) + | x86 => (0,(1,(1,(0,(0,(0,(0,1))))))) + | x87 => (1,(1,(1,(0,(0,(0,(0,1))))))) + | x88 => (0,(0,(0,(1,(0,(0,(0,1))))))) + | x89 => (1,(0,(0,(1,(0,(0,(0,1))))))) + | x8a => (0,(1,(0,(1,(0,(0,(0,1))))))) + | x8b => (1,(1,(0,(1,(0,(0,(0,1))))))) + | x8c => (0,(0,(1,(1,(0,(0,(0,1))))))) + | x8d => (1,(0,(1,(1,(0,(0,(0,1))))))) + | x8e => (0,(1,(1,(1,(0,(0,(0,1))))))) + | x8f => (1,(1,(1,(1,(0,(0,(0,1))))))) + | x90 => (0,(0,(0,(0,(1,(0,(0,1))))))) + | x91 => (1,(0,(0,(0,(1,(0,(0,1))))))) + | x92 => (0,(1,(0,(0,(1,(0,(0,1))))))) + | x93 => (1,(1,(0,(0,(1,(0,(0,1))))))) + | x94 => (0,(0,(1,(0,(1,(0,(0,1))))))) + | x95 => (1,(0,(1,(0,(1,(0,(0,1))))))) + | x96 => (0,(1,(1,(0,(1,(0,(0,1))))))) + | x97 => (1,(1,(1,(0,(1,(0,(0,1))))))) + | x98 => (0,(0,(0,(1,(1,(0,(0,1))))))) + | x99 => (1,(0,(0,(1,(1,(0,(0,1))))))) + | x9a => (0,(1,(0,(1,(1,(0,(0,1))))))) + | x9b => (1,(1,(0,(1,(1,(0,(0,1))))))) + | x9c => (0,(0,(1,(1,(1,(0,(0,1))))))) + | x9d => (1,(0,(1,(1,(1,(0,(0,1))))))) + | x9e => (0,(1,(1,(1,(1,(0,(0,1))))))) + | x9f => (1,(1,(1,(1,(1,(0,(0,1))))))) + | xa0 => (0,(0,(0,(0,(0,(1,(0,1))))))) + | xa1 => (1,(0,(0,(0,(0,(1,(0,1))))))) + | xa2 => (0,(1,(0,(0,(0,(1,(0,1))))))) + | xa3 => (1,(1,(0,(0,(0,(1,(0,1))))))) + | xa4 => (0,(0,(1,(0,(0,(1,(0,1))))))) + | xa5 => (1,(0,(1,(0,(0,(1,(0,1))))))) + | xa6 => (0,(1,(1,(0,(0,(1,(0,1))))))) + | xa7 => (1,(1,(1,(0,(0,(1,(0,1))))))) + | xa8 => (0,(0,(0,(1,(0,(1,(0,1))))))) + | xa9 => (1,(0,(0,(1,(0,(1,(0,1))))))) + | xaa => (0,(1,(0,(1,(0,(1,(0,1))))))) + | xab => (1,(1,(0,(1,(0,(1,(0,1))))))) + | xac => (0,(0,(1,(1,(0,(1,(0,1))))))) + | xad => (1,(0,(1,(1,(0,(1,(0,1))))))) + | xae => (0,(1,(1,(1,(0,(1,(0,1))))))) + | xaf => (1,(1,(1,(1,(0,(1,(0,1))))))) + | xb0 => (0,(0,(0,(0,(1,(1,(0,1))))))) + | xb1 => (1,(0,(0,(0,(1,(1,(0,1))))))) + | xb2 => (0,(1,(0,(0,(1,(1,(0,1))))))) + | xb3 => (1,(1,(0,(0,(1,(1,(0,1))))))) + | xb4 => (0,(0,(1,(0,(1,(1,(0,1))))))) + | xb5 => (1,(0,(1,(0,(1,(1,(0,1))))))) + | xb6 => (0,(1,(1,(0,(1,(1,(0,1))))))) + | xb7 => (1,(1,(1,(0,(1,(1,(0,1))))))) + | xb8 => (0,(0,(0,(1,(1,(1,(0,1))))))) + | xb9 => (1,(0,(0,(1,(1,(1,(0,1))))))) + | xba => (0,(1,(0,(1,(1,(1,(0,1))))))) + | xbb => (1,(1,(0,(1,(1,(1,(0,1))))))) + | xbc => (0,(0,(1,(1,(1,(1,(0,1))))))) + | xbd => (1,(0,(1,(1,(1,(1,(0,1))))))) + | xbe => (0,(1,(1,(1,(1,(1,(0,1))))))) + | xbf => (1,(1,(1,(1,(1,(1,(0,1))))))) + | xc0 => (0,(0,(0,(0,(0,(0,(1,1))))))) + | xc1 => (1,(0,(0,(0,(0,(0,(1,1))))))) + | xc2 => (0,(1,(0,(0,(0,(0,(1,1))))))) + | xc3 => (1,(1,(0,(0,(0,(0,(1,1))))))) + | xc4 => (0,(0,(1,(0,(0,(0,(1,1))))))) + | xc5 => (1,(0,(1,(0,(0,(0,(1,1))))))) + | xc6 => (0,(1,(1,(0,(0,(0,(1,1))))))) + | xc7 => (1,(1,(1,(0,(0,(0,(1,1))))))) + | xc8 => (0,(0,(0,(1,(0,(0,(1,1))))))) + | xc9 => (1,(0,(0,(1,(0,(0,(1,1))))))) + | xca => (0,(1,(0,(1,(0,(0,(1,1))))))) + | xcb => (1,(1,(0,(1,(0,(0,(1,1))))))) + | xcc => (0,(0,(1,(1,(0,(0,(1,1))))))) + | xcd => (1,(0,(1,(1,(0,(0,(1,1))))))) + | xce => (0,(1,(1,(1,(0,(0,(1,1))))))) + | xcf => (1,(1,(1,(1,(0,(0,(1,1))))))) + | xd0 => (0,(0,(0,(0,(1,(0,(1,1))))))) + | xd1 => (1,(0,(0,(0,(1,(0,(1,1))))))) + | xd2 => (0,(1,(0,(0,(1,(0,(1,1))))))) + | xd3 => (1,(1,(0,(0,(1,(0,(1,1))))))) + | xd4 => (0,(0,(1,(0,(1,(0,(1,1))))))) + | xd5 => (1,(0,(1,(0,(1,(0,(1,1))))))) + | xd6 => (0,(1,(1,(0,(1,(0,(1,1))))))) + | xd7 => (1,(1,(1,(0,(1,(0,(1,1))))))) + | xd8 => (0,(0,(0,(1,(1,(0,(1,1))))))) + | xd9 => (1,(0,(0,(1,(1,(0,(1,1))))))) + | xda => (0,(1,(0,(1,(1,(0,(1,1))))))) + | xdb => (1,(1,(0,(1,(1,(0,(1,1))))))) + | xdc => (0,(0,(1,(1,(1,(0,(1,1))))))) + | xdd => (1,(0,(1,(1,(1,(0,(1,1))))))) + | xde => (0,(1,(1,(1,(1,(0,(1,1))))))) + | xdf => (1,(1,(1,(1,(1,(0,(1,1))))))) + | xe0 => (0,(0,(0,(0,(0,(1,(1,1))))))) + | xe1 => (1,(0,(0,(0,(0,(1,(1,1))))))) + | xe2 => (0,(1,(0,(0,(0,(1,(1,1))))))) + | xe3 => (1,(1,(0,(0,(0,(1,(1,1))))))) + | xe4 => (0,(0,(1,(0,(0,(1,(1,1))))))) + | xe5 => (1,(0,(1,(0,(0,(1,(1,1))))))) + | xe6 => (0,(1,(1,(0,(0,(1,(1,1))))))) + | xe7 => (1,(1,(1,(0,(0,(1,(1,1))))))) + | xe8 => (0,(0,(0,(1,(0,(1,(1,1))))))) + | xe9 => (1,(0,(0,(1,(0,(1,(1,1))))))) + | xea => (0,(1,(0,(1,(0,(1,(1,1))))))) + | xeb => (1,(1,(0,(1,(0,(1,(1,1))))))) + | xec => (0,(0,(1,(1,(0,(1,(1,1))))))) + | xed => (1,(0,(1,(1,(0,(1,(1,1))))))) + | xee => (0,(1,(1,(1,(0,(1,(1,1))))))) + | xef => (1,(1,(1,(1,(0,(1,(1,1))))))) + | xf0 => (0,(0,(0,(0,(1,(1,(1,1))))))) + | xf1 => (1,(0,(0,(0,(1,(1,(1,1))))))) + | xf2 => (0,(1,(0,(0,(1,(1,(1,1))))))) + | xf3 => (1,(1,(0,(0,(1,(1,(1,1))))))) + | xf4 => (0,(0,(1,(0,(1,(1,(1,1))))))) + | xf5 => (1,(0,(1,(0,(1,(1,(1,1))))))) + | xf6 => (0,(1,(1,(0,(1,(1,(1,1))))))) + | xf7 => (1,(1,(1,(0,(1,(1,(1,1))))))) + | xf8 => (0,(0,(0,(1,(1,(1,(1,1))))))) + | xf9 => (1,(0,(0,(1,(1,(1,(1,1))))))) + | xfa => (0,(1,(0,(1,(1,(1,(1,1))))))) + | xfb => (1,(1,(0,(1,(1,(1,(1,1))))))) + | xfc => (0,(0,(1,(1,(1,(1,(1,1))))))) + | xfd => (1,(0,(1,(1,(1,(1,(1,1))))))) + | xfe => (0,(1,(1,(1,(1,(1,(1,1))))))) + | xff => (1,(1,(1,(1,(1,(1,(1,1))))))) + end. + +Lemma of_bits_to_bits (b : byte) : of_bits (to_bits b) = b. +Proof. destruct b; exact eq_refl. Qed. + +Lemma to_bits_of_bits (b : _) : to_bits (of_bits b) = b. +Proof. + repeat match goal with + | p : prod _ _ |- _ => destruct p + | b : bool |- _ => destruct b + end; + exact eq_refl. +Qed. + +Definition byte_of_byte (b : byte) : byte := b. + +Module Export ByteSyntaxNotations. + String Notation byte byte_of_byte byte_of_byte : byte_scope. +End ByteSyntaxNotations. diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 6d98bcb34a..5e29f854e8 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -13,6 +13,7 @@ Require Export Logic. Require Export Logic_Type. Require Export Datatypes. Require Export Specif. +Require Coq.Init.Byte. Require Coq.Init.Decimal. Require Coq.Init.Nat. Require Export Peano. @@ -26,6 +27,7 @@ Require Export Coq.Init.Tauto. Declare ML Module "cc_plugin". Declare ML Module "ground_plugin". Declare ML Module "numeral_notation_plugin". +Declare ML Module "string_notation_plugin". (* Parsing / printing of decimal numbers *) Arguments Nat.of_uint d%dec_uint_scope. @@ -38,5 +40,8 @@ Numeral Notation Decimal.int Decimal.int_of_int Decimal.int_of_int (* Parsing / printing of [nat] numbers *) Numeral Notation nat Nat.of_uint Nat.to_uint : nat_scope (abstract after 5000). +(* Printing/Parsing of bytes *) +Export Byte.ByteSyntaxNotations. + (* Default substrings not considered by queries like SearchAbout *) Add Search Blacklist "_subproof" "_subterm" "Private_". diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index b7c1eaa788..6a0c5f066e 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -12,7 +12,7 @@ (** Contributed by Laurent Théry (INRIA); Adapted to Coq V8 by the Coq Development Team *) -Require Import Bool BinPos BinNat PeanoNat Nnat. +Require Import Bool BinPos BinNat PeanoNat Nnat Coq.Strings.Byte. (** * Definition of ascii characters *) @@ -20,10 +20,7 @@ Require Import Bool BinPos BinNat PeanoNat Nnat. Inductive ascii : Set := Ascii (_ _ _ _ _ _ _ _ : bool). -Register Ascii as plugins.syntax.Ascii. - Declare Scope char_scope. -Module Export AsciiSyntax. Declare ML Module "ascii_syntax_plugin". End AsciiSyntax. Delimit Scope char_scope with char. Bind Scope char_scope with ascii. @@ -140,6 +137,12 @@ do 8 (destruct p; [ | | intros; vm_compute; reflexivity ]); intro H; vm_compute in H; destruct p; discriminate. Qed. +Theorem N_ascii_bounded : + forall a : ascii, (N_of_ascii a < 256)%N. +Proof. + destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity. +Qed. + Theorem ascii_nat_embedding : forall a : ascii, ascii_of_nat (nat_of_ascii a) = a. Proof. @@ -158,6 +161,15 @@ Proof. now apply Nat.compare_lt_iff. Qed. +Theorem nat_ascii_bounded : + forall a : ascii, nat_of_ascii a < 256. +Proof. + intro a; unfold nat_of_ascii. + change 256 with (N.to_nat 256). + rewrite <- Nat.compare_lt_iff, <- N2Nat.inj_compare, N.compare_lt_iff. + apply N_ascii_bounded. +Qed. + (** * Concrete syntax *) @@ -175,7 +187,53 @@ Qed. stand-alone utf8 characters so that only the notation "nnn" is available for them (unless your terminal is able to represent them, which is typically not the case in coqide). -*) + *) + +Definition ascii_of_byte (b : byte) : ascii + := let '(b0, (b1, (b2, (b3, (b4, (b5, (b6, b7))))))) := Byte.to_bits b in + Ascii b0 b1 b2 b3 b4 b5 b6 b7. + +Definition byte_of_ascii (a : ascii) : byte + := let (b0, b1, b2, b3, b4, b5, b6, b7) := a in + Byte.of_bits (b0, (b1, (b2, (b3, (b4, (b5, (b6, b7))))))). + +Lemma ascii_of_byte_of_ascii x : ascii_of_byte (byte_of_ascii x) = x. +Proof. + cbv [ascii_of_byte byte_of_ascii]. + destruct x; rewrite to_bits_of_bits; reflexivity. +Qed. + +Lemma byte_of_ascii_of_byte x : byte_of_ascii (ascii_of_byte x) = x. +Proof. + cbv [ascii_of_byte byte_of_ascii]. + repeat match goal with + | [ |- context[match ?x with pair _ _ => _ end] ] + => rewrite (surjective_pairing x) + | [ |- context[(fst ?x, snd ?x)] ] + => rewrite <- (surjective_pairing x) + end. + rewrite of_bits_to_bits; reflexivity. +Qed. + +Lemma ascii_of_byte_via_N x : ascii_of_byte x = ascii_of_N (Byte.to_N x). +Proof. destruct x; reflexivity. Qed. + +Lemma ascii_of_byte_via_nat x : ascii_of_byte x = ascii_of_nat (Byte.to_nat x). +Proof. destruct x; reflexivity. Qed. + +Lemma byte_of_ascii_via_N x : Some (byte_of_ascii x) = Byte.of_N (N_of_ascii x). +Proof. + rewrite <- (ascii_of_byte_of_ascii x); destruct (byte_of_ascii x); reflexivity. +Qed. + +Lemma byte_of_ascii_via_nat x : Some (byte_of_ascii x) = Byte.of_nat (nat_of_ascii x). +Proof. + rewrite <- (ascii_of_byte_of_ascii x); destruct (byte_of_ascii x); reflexivity. +Qed. + +Module Export AsciiSyntax. + String Notation ascii ascii_of_byte byte_of_ascii : char_scope. +End AsciiSyntax. Local Open Scope char_scope. diff --git a/theories/Strings/BinaryString.v b/theories/Strings/BinaryString.v index 6df0a9170a..a2bb1763f5 100644 --- a/theories/Strings/BinaryString.v +++ b/theories/Strings/BinaryString.v @@ -48,7 +48,7 @@ Module Raw. end end. - Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) + Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) {struct p} : to_N (of_pos p rest) base = to_N rest match base with | N0 => N.pos p diff --git a/theories/Strings/Byte.v b/theories/Strings/Byte.v new file mode 100644 index 0000000000..2759ea60cb --- /dev/null +++ b/theories/Strings/Byte.v @@ -0,0 +1,1214 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import Coq.Arith.EqNat. +Require Import Coq.NArith.BinNat. +Require Import Coq.NArith.Nnat. +Require Export Coq.Init.Byte. + +Local Set Implicit Arguments. + +Definition eqb (a b : byte) : bool + := let '(a0, (a1, (a2, (a3, (a4, (a5, (a6, a7))))))) := to_bits a in + let '(b0, (b1, (b2, (b3, (b4, (b5, (b6, b7))))))) := to_bits b in + (Bool.eqb a0 b0 && Bool.eqb a1 b1 && Bool.eqb a2 b2 && Bool.eqb a3 b3 && + Bool.eqb a4 b4 && Bool.eqb a5 b5 && Bool.eqb a6 b6 && Bool.eqb a7 b7)%bool. + +Module Export ByteNotations. + Export ByteSyntaxNotations. + Infix "=?" := eqb (at level 70) : byte_scope. +End ByteNotations. + +Lemma byte_dec_lb x y : x = y -> eqb x y = true. +Proof. intro; subst y; destruct x; reflexivity. Defined. + +Lemma byte_dec_bl x y (H : eqb x y = true) : x = y. +Proof. + rewrite <- (of_bits_to_bits x), <- (of_bits_to_bits y). + cbv [eqb] in H; revert H. + generalize (to_bits x) (to_bits y); clear x y; intros x y H. + repeat match goal with + | [ H : and _ _ |- _ ] => destruct H + | [ H : prod _ _ |- _ ] => destruct H + | [ H : context[andb _ _ = true] |- _ ] => rewrite Bool.andb_true_iff in H + | [ H : context[Bool.eqb _ _ = true] |- _ ] => rewrite Bool.eqb_true_iff in H + | _ => progress subst + | _ => reflexivity + end. +Qed. + +Lemma eqb_false x y : eqb x y = false -> x <> y. +Proof. intros H H'; pose proof (byte_dec_lb H'); congruence. Qed. + +Definition byte_eq_dec (x y : byte) : {x = y} + {x <> y} + := (if eqb x y as beq return eqb x y = beq -> _ + then fun pf => left (byte_dec_bl x y pf) + else fun pf => right (eqb_false pf)) + eq_refl. + +Section nat. + Definition to_nat (x : byte) : nat + := match x with + | x00 => 0 + | x01 => 1 + | x02 => 2 + | x03 => 3 + | x04 => 4 + | x05 => 5 + | x06 => 6 + | x07 => 7 + | x08 => 8 + | x09 => 9 + | x0a => 10 + | x0b => 11 + | x0c => 12 + | x0d => 13 + | x0e => 14 + | x0f => 15 + | x10 => 16 + | x11 => 17 + | x12 => 18 + | x13 => 19 + | x14 => 20 + | x15 => 21 + | x16 => 22 + | x17 => 23 + | x18 => 24 + | x19 => 25 + | x1a => 26 + | x1b => 27 + | x1c => 28 + | x1d => 29 + | x1e => 30 + | x1f => 31 + | x20 => 32 + | x21 => 33 + | x22 => 34 + | x23 => 35 + | x24 => 36 + | x25 => 37 + | x26 => 38 + | x27 => 39 + | x28 => 40 + | x29 => 41 + | x2a => 42 + | x2b => 43 + | x2c => 44 + | x2d => 45 + | x2e => 46 + | x2f => 47 + | x30 => 48 + | x31 => 49 + | x32 => 50 + | x33 => 51 + | x34 => 52 + | x35 => 53 + | x36 => 54 + | x37 => 55 + | x38 => 56 + | x39 => 57 + | x3a => 58 + | x3b => 59 + | x3c => 60 + | x3d => 61 + | x3e => 62 + | x3f => 63 + | x40 => 64 + | x41 => 65 + | x42 => 66 + | x43 => 67 + | x44 => 68 + | x45 => 69 + | x46 => 70 + | x47 => 71 + | x48 => 72 + | x49 => 73 + | x4a => 74 + | x4b => 75 + | x4c => 76 + | x4d => 77 + | x4e => 78 + | x4f => 79 + | x50 => 80 + | x51 => 81 + | x52 => 82 + | x53 => 83 + | x54 => 84 + | x55 => 85 + | x56 => 86 + | x57 => 87 + | x58 => 88 + | x59 => 89 + | x5a => 90 + | x5b => 91 + | x5c => 92 + | x5d => 93 + | x5e => 94 + | x5f => 95 + | x60 => 96 + | x61 => 97 + | x62 => 98 + | x63 => 99 + | x64 => 100 + | x65 => 101 + | x66 => 102 + | x67 => 103 + | x68 => 104 + | x69 => 105 + | x6a => 106 + | x6b => 107 + | x6c => 108 + | x6d => 109 + | x6e => 110 + | x6f => 111 + | x70 => 112 + | x71 => 113 + | x72 => 114 + | x73 => 115 + | x74 => 116 + | x75 => 117 + | x76 => 118 + | x77 => 119 + | x78 => 120 + | x79 => 121 + | x7a => 122 + | x7b => 123 + | x7c => 124 + | x7d => 125 + | x7e => 126 + | x7f => 127 + | x80 => 128 + | x81 => 129 + | x82 => 130 + | x83 => 131 + | x84 => 132 + | x85 => 133 + | x86 => 134 + | x87 => 135 + | x88 => 136 + | x89 => 137 + | x8a => 138 + | x8b => 139 + | x8c => 140 + | x8d => 141 + | x8e => 142 + | x8f => 143 + | x90 => 144 + | x91 => 145 + | x92 => 146 + | x93 => 147 + | x94 => 148 + | x95 => 149 + | x96 => 150 + | x97 => 151 + | x98 => 152 + | x99 => 153 + | x9a => 154 + | x9b => 155 + | x9c => 156 + | x9d => 157 + | x9e => 158 + | x9f => 159 + | xa0 => 160 + | xa1 => 161 + | xa2 => 162 + | xa3 => 163 + | xa4 => 164 + | xa5 => 165 + | xa6 => 166 + | xa7 => 167 + | xa8 => 168 + | xa9 => 169 + | xaa => 170 + | xab => 171 + | xac => 172 + | xad => 173 + | xae => 174 + | xaf => 175 + | xb0 => 176 + | xb1 => 177 + | xb2 => 178 + | xb3 => 179 + | xb4 => 180 + | xb5 => 181 + | xb6 => 182 + | xb7 => 183 + | xb8 => 184 + | xb9 => 185 + | xba => 186 + | xbb => 187 + | xbc => 188 + | xbd => 189 + | xbe => 190 + | xbf => 191 + | xc0 => 192 + | xc1 => 193 + | xc2 => 194 + | xc3 => 195 + | xc4 => 196 + | xc5 => 197 + | xc6 => 198 + | xc7 => 199 + | xc8 => 200 + | xc9 => 201 + | xca => 202 + | xcb => 203 + | xcc => 204 + | xcd => 205 + | xce => 206 + | xcf => 207 + | xd0 => 208 + | xd1 => 209 + | xd2 => 210 + | xd3 => 211 + | xd4 => 212 + | xd5 => 213 + | xd6 => 214 + | xd7 => 215 + | xd8 => 216 + | xd9 => 217 + | xda => 218 + | xdb => 219 + | xdc => 220 + | xdd => 221 + | xde => 222 + | xdf => 223 + | xe0 => 224 + | xe1 => 225 + | xe2 => 226 + | xe3 => 227 + | xe4 => 228 + | xe5 => 229 + | xe6 => 230 + | xe7 => 231 + | xe8 => 232 + | xe9 => 233 + | xea => 234 + | xeb => 235 + | xec => 236 + | xed => 237 + | xee => 238 + | xef => 239 + | xf0 => 240 + | xf1 => 241 + | xf2 => 242 + | xf3 => 243 + | xf4 => 244 + | xf5 => 245 + | xf6 => 246 + | xf7 => 247 + | xf8 => 248 + | xf9 => 249 + | xfa => 250 + | xfb => 251 + | xfc => 252 + | xfd => 253 + | xfe => 254 + | xff => 255 + end. + + Definition of_nat (x : nat) : option byte + := match x with + | 0 => Some x00 + | 1 => Some x01 + | 2 => Some x02 + | 3 => Some x03 + | 4 => Some x04 + | 5 => Some x05 + | 6 => Some x06 + | 7 => Some x07 + | 8 => Some x08 + | 9 => Some x09 + | 10 => Some x0a + | 11 => Some x0b + | 12 => Some x0c + | 13 => Some x0d + | 14 => Some x0e + | 15 => Some x0f + | 16 => Some x10 + | 17 => Some x11 + | 18 => Some x12 + | 19 => Some x13 + | 20 => Some x14 + | 21 => Some x15 + | 22 => Some x16 + | 23 => Some x17 + | 24 => Some x18 + | 25 => Some x19 + | 26 => Some x1a + | 27 => Some x1b + | 28 => Some x1c + | 29 => Some x1d + | 30 => Some x1e + | 31 => Some x1f + | 32 => Some x20 + | 33 => Some x21 + | 34 => Some x22 + | 35 => Some x23 + | 36 => Some x24 + | 37 => Some x25 + | 38 => Some x26 + | 39 => Some x27 + | 40 => Some x28 + | 41 => Some x29 + | 42 => Some x2a + | 43 => Some x2b + | 44 => Some x2c + | 45 => Some x2d + | 46 => Some x2e + | 47 => Some x2f + | 48 => Some x30 + | 49 => Some x31 + | 50 => Some x32 + | 51 => Some x33 + | 52 => Some x34 + | 53 => Some x35 + | 54 => Some x36 + | 55 => Some x37 + | 56 => Some x38 + | 57 => Some x39 + | 58 => Some x3a + | 59 => Some x3b + | 60 => Some x3c + | 61 => Some x3d + | 62 => Some x3e + | 63 => Some x3f + | 64 => Some x40 + | 65 => Some x41 + | 66 => Some x42 + | 67 => Some x43 + | 68 => Some x44 + | 69 => Some x45 + | 70 => Some x46 + | 71 => Some x47 + | 72 => Some x48 + | 73 => Some x49 + | 74 => Some x4a + | 75 => Some x4b + | 76 => Some x4c + | 77 => Some x4d + | 78 => Some x4e + | 79 => Some x4f + | 80 => Some x50 + | 81 => Some x51 + | 82 => Some x52 + | 83 => Some x53 + | 84 => Some x54 + | 85 => Some x55 + | 86 => Some x56 + | 87 => Some x57 + | 88 => Some x58 + | 89 => Some x59 + | 90 => Some x5a + | 91 => Some x5b + | 92 => Some x5c + | 93 => Some x5d + | 94 => Some x5e + | 95 => Some x5f + | 96 => Some x60 + | 97 => Some x61 + | 98 => Some x62 + | 99 => Some x63 + | 100 => Some x64 + | 101 => Some x65 + | 102 => Some x66 + | 103 => Some x67 + | 104 => Some x68 + | 105 => Some x69 + | 106 => Some x6a + | 107 => Some x6b + | 108 => Some x6c + | 109 => Some x6d + | 110 => Some x6e + | 111 => Some x6f + | 112 => Some x70 + | 113 => Some x71 + | 114 => Some x72 + | 115 => Some x73 + | 116 => Some x74 + | 117 => Some x75 + | 118 => Some x76 + | 119 => Some x77 + | 120 => Some x78 + | 121 => Some x79 + | 122 => Some x7a + | 123 => Some x7b + | 124 => Some x7c + | 125 => Some x7d + | 126 => Some x7e + | 127 => Some x7f + | 128 => Some x80 + | 129 => Some x81 + | 130 => Some x82 + | 131 => Some x83 + | 132 => Some x84 + | 133 => Some x85 + | 134 => Some x86 + | 135 => Some x87 + | 136 => Some x88 + | 137 => Some x89 + | 138 => Some x8a + | 139 => Some x8b + | 140 => Some x8c + | 141 => Some x8d + | 142 => Some x8e + | 143 => Some x8f + | 144 => Some x90 + | 145 => Some x91 + | 146 => Some x92 + | 147 => Some x93 + | 148 => Some x94 + | 149 => Some x95 + | 150 => Some x96 + | 151 => Some x97 + | 152 => Some x98 + | 153 => Some x99 + | 154 => Some x9a + | 155 => Some x9b + | 156 => Some x9c + | 157 => Some x9d + | 158 => Some x9e + | 159 => Some x9f + | 160 => Some xa0 + | 161 => Some xa1 + | 162 => Some xa2 + | 163 => Some xa3 + | 164 => Some xa4 + | 165 => Some xa5 + | 166 => Some xa6 + | 167 => Some xa7 + | 168 => Some xa8 + | 169 => Some xa9 + | 170 => Some xaa + | 171 => Some xab + | 172 => Some xac + | 173 => Some xad + | 174 => Some xae + | 175 => Some xaf + | 176 => Some xb0 + | 177 => Some xb1 + | 178 => Some xb2 + | 179 => Some xb3 + | 180 => Some xb4 + | 181 => Some xb5 + | 182 => Some xb6 + | 183 => Some xb7 + | 184 => Some xb8 + | 185 => Some xb9 + | 186 => Some xba + | 187 => Some xbb + | 188 => Some xbc + | 189 => Some xbd + | 190 => Some xbe + | 191 => Some xbf + | 192 => Some xc0 + | 193 => Some xc1 + | 194 => Some xc2 + | 195 => Some xc3 + | 196 => Some xc4 + | 197 => Some xc5 + | 198 => Some xc6 + | 199 => Some xc7 + | 200 => Some xc8 + | 201 => Some xc9 + | 202 => Some xca + | 203 => Some xcb + | 204 => Some xcc + | 205 => Some xcd + | 206 => Some xce + | 207 => Some xcf + | 208 => Some xd0 + | 209 => Some xd1 + | 210 => Some xd2 + | 211 => Some xd3 + | 212 => Some xd4 + | 213 => Some xd5 + | 214 => Some xd6 + | 215 => Some xd7 + | 216 => Some xd8 + | 217 => Some xd9 + | 218 => Some xda + | 219 => Some xdb + | 220 => Some xdc + | 221 => Some xdd + | 222 => Some xde + | 223 => Some xdf + | 224 => Some xe0 + | 225 => Some xe1 + | 226 => Some xe2 + | 227 => Some xe3 + | 228 => Some xe4 + | 229 => Some xe5 + | 230 => Some xe6 + | 231 => Some xe7 + | 232 => Some xe8 + | 233 => Some xe9 + | 234 => Some xea + | 235 => Some xeb + | 236 => Some xec + | 237 => Some xed + | 238 => Some xee + | 239 => Some xef + | 240 => Some xf0 + | 241 => Some xf1 + | 242 => Some xf2 + | 243 => Some xf3 + | 244 => Some xf4 + | 245 => Some xf5 + | 246 => Some xf6 + | 247 => Some xf7 + | 248 => Some xf8 + | 249 => Some xf9 + | 250 => Some xfa + | 251 => Some xfb + | 252 => Some xfc + | 253 => Some xfd + | 254 => Some xfe + | 255 => Some xff + | _ => None + end. + + Lemma of_to_nat x : of_nat (to_nat x) = Some x. + Proof. destruct x; reflexivity. Qed. + + Lemma to_of_nat x y : of_nat x = Some y -> to_nat y = x. + Proof. + do 256 try destruct x as [|x]; cbv [of_nat]; intro. + all: repeat match goal with + | _ => reflexivity + | _ => progress subst + | [ H : Some ?a = Some ?b |- _ ] => assert (a = b) by refine match H with eq_refl => eq_refl end; clear H + | [ H : None = Some _ |- _ ] => solve [ inversion H ] + end. + Qed. + + Lemma to_of_nat_iff x y : of_nat x = Some y <-> to_nat y = x. + Proof. split; intro; subst; (apply of_to_nat || apply to_of_nat); assumption. Qed. + + Lemma to_of_nat_option_map x : option_map to_nat (of_nat x) = if Nat.leb x 255 then Some x else None. + Proof. do 256 try destruct x as [|x]; reflexivity. Qed. + + Lemma to_nat_bounded x : to_nat x <= 255. + Proof. + generalize (to_of_nat_option_map (to_nat x)). + rewrite of_to_nat; cbn [option_map]. + destruct (Nat.leb (to_nat x) 255) eqn:H; [ | congruence ]. + rewrite (PeanoNat.Nat.leb_le (to_nat x) 255) in H. + intro; assumption. + Qed. + + Lemma of_nat_None_iff x : of_nat x = None <-> 255 < x. + Proof. + generalize (to_of_nat_option_map x). + destruct (of_nat x), (Nat.leb x 255) eqn:H; cbn [option_map]; try congruence. + { rewrite PeanoNat.Nat.leb_le in H; split; [ congruence | ]. + rewrite PeanoNat.Nat.lt_nge; intro H'; exfalso; apply H'; assumption. } + { rewrite PeanoNat.Nat.leb_nle in H; split; [ | reflexivity ]. + rewrite PeanoNat.Nat.lt_nge; intro; assumption. } + Qed. +End nat. + +Section N. + Local Open Scope N_scope. + + Definition to_N (x : byte) : N + := match x with + | x00 => 0 + | x01 => 1 + | x02 => 2 + | x03 => 3 + | x04 => 4 + | x05 => 5 + | x06 => 6 + | x07 => 7 + | x08 => 8 + | x09 => 9 + | x0a => 10 + | x0b => 11 + | x0c => 12 + | x0d => 13 + | x0e => 14 + | x0f => 15 + | x10 => 16 + | x11 => 17 + | x12 => 18 + | x13 => 19 + | x14 => 20 + | x15 => 21 + | x16 => 22 + | x17 => 23 + | x18 => 24 + | x19 => 25 + | x1a => 26 + | x1b => 27 + | x1c => 28 + | x1d => 29 + | x1e => 30 + | x1f => 31 + | x20 => 32 + | x21 => 33 + | x22 => 34 + | x23 => 35 + | x24 => 36 + | x25 => 37 + | x26 => 38 + | x27 => 39 + | x28 => 40 + | x29 => 41 + | x2a => 42 + | x2b => 43 + | x2c => 44 + | x2d => 45 + | x2e => 46 + | x2f => 47 + | x30 => 48 + | x31 => 49 + | x32 => 50 + | x33 => 51 + | x34 => 52 + | x35 => 53 + | x36 => 54 + | x37 => 55 + | x38 => 56 + | x39 => 57 + | x3a => 58 + | x3b => 59 + | x3c => 60 + | x3d => 61 + | x3e => 62 + | x3f => 63 + | x40 => 64 + | x41 => 65 + | x42 => 66 + | x43 => 67 + | x44 => 68 + | x45 => 69 + | x46 => 70 + | x47 => 71 + | x48 => 72 + | x49 => 73 + | x4a => 74 + | x4b => 75 + | x4c => 76 + | x4d => 77 + | x4e => 78 + | x4f => 79 + | x50 => 80 + | x51 => 81 + | x52 => 82 + | x53 => 83 + | x54 => 84 + | x55 => 85 + | x56 => 86 + | x57 => 87 + | x58 => 88 + | x59 => 89 + | x5a => 90 + | x5b => 91 + | x5c => 92 + | x5d => 93 + | x5e => 94 + | x5f => 95 + | x60 => 96 + | x61 => 97 + | x62 => 98 + | x63 => 99 + | x64 => 100 + | x65 => 101 + | x66 => 102 + | x67 => 103 + | x68 => 104 + | x69 => 105 + | x6a => 106 + | x6b => 107 + | x6c => 108 + | x6d => 109 + | x6e => 110 + | x6f => 111 + | x70 => 112 + | x71 => 113 + | x72 => 114 + | x73 => 115 + | x74 => 116 + | x75 => 117 + | x76 => 118 + | x77 => 119 + | x78 => 120 + | x79 => 121 + | x7a => 122 + | x7b => 123 + | x7c => 124 + | x7d => 125 + | x7e => 126 + | x7f => 127 + | x80 => 128 + | x81 => 129 + | x82 => 130 + | x83 => 131 + | x84 => 132 + | x85 => 133 + | x86 => 134 + | x87 => 135 + | x88 => 136 + | x89 => 137 + | x8a => 138 + | x8b => 139 + | x8c => 140 + | x8d => 141 + | x8e => 142 + | x8f => 143 + | x90 => 144 + | x91 => 145 + | x92 => 146 + | x93 => 147 + | x94 => 148 + | x95 => 149 + | x96 => 150 + | x97 => 151 + | x98 => 152 + | x99 => 153 + | x9a => 154 + | x9b => 155 + | x9c => 156 + | x9d => 157 + | x9e => 158 + | x9f => 159 + | xa0 => 160 + | xa1 => 161 + | xa2 => 162 + | xa3 => 163 + | xa4 => 164 + | xa5 => 165 + | xa6 => 166 + | xa7 => 167 + | xa8 => 168 + | xa9 => 169 + | xaa => 170 + | xab => 171 + | xac => 172 + | xad => 173 + | xae => 174 + | xaf => 175 + | xb0 => 176 + | xb1 => 177 + | xb2 => 178 + | xb3 => 179 + | xb4 => 180 + | xb5 => 181 + | xb6 => 182 + | xb7 => 183 + | xb8 => 184 + | xb9 => 185 + | xba => 186 + | xbb => 187 + | xbc => 188 + | xbd => 189 + | xbe => 190 + | xbf => 191 + | xc0 => 192 + | xc1 => 193 + | xc2 => 194 + | xc3 => 195 + | xc4 => 196 + | xc5 => 197 + | xc6 => 198 + | xc7 => 199 + | xc8 => 200 + | xc9 => 201 + | xca => 202 + | xcb => 203 + | xcc => 204 + | xcd => 205 + | xce => 206 + | xcf => 207 + | xd0 => 208 + | xd1 => 209 + | xd2 => 210 + | xd3 => 211 + | xd4 => 212 + | xd5 => 213 + | xd6 => 214 + | xd7 => 215 + | xd8 => 216 + | xd9 => 217 + | xda => 218 + | xdb => 219 + | xdc => 220 + | xdd => 221 + | xde => 222 + | xdf => 223 + | xe0 => 224 + | xe1 => 225 + | xe2 => 226 + | xe3 => 227 + | xe4 => 228 + | xe5 => 229 + | xe6 => 230 + | xe7 => 231 + | xe8 => 232 + | xe9 => 233 + | xea => 234 + | xeb => 235 + | xec => 236 + | xed => 237 + | xee => 238 + | xef => 239 + | xf0 => 240 + | xf1 => 241 + | xf2 => 242 + | xf3 => 243 + | xf4 => 244 + | xf5 => 245 + | xf6 => 246 + | xf7 => 247 + | xf8 => 248 + | xf9 => 249 + | xfa => 250 + | xfb => 251 + | xfc => 252 + | xfd => 253 + | xfe => 254 + | xff => 255 + end. + + Definition of_N (x : N) : option byte + := match x with + | 0 => Some x00 + | 1 => Some x01 + | 2 => Some x02 + | 3 => Some x03 + | 4 => Some x04 + | 5 => Some x05 + | 6 => Some x06 + | 7 => Some x07 + | 8 => Some x08 + | 9 => Some x09 + | 10 => Some x0a + | 11 => Some x0b + | 12 => Some x0c + | 13 => Some x0d + | 14 => Some x0e + | 15 => Some x0f + | 16 => Some x10 + | 17 => Some x11 + | 18 => Some x12 + | 19 => Some x13 + | 20 => Some x14 + | 21 => Some x15 + | 22 => Some x16 + | 23 => Some x17 + | 24 => Some x18 + | 25 => Some x19 + | 26 => Some x1a + | 27 => Some x1b + | 28 => Some x1c + | 29 => Some x1d + | 30 => Some x1e + | 31 => Some x1f + | 32 => Some x20 + | 33 => Some x21 + | 34 => Some x22 + | 35 => Some x23 + | 36 => Some x24 + | 37 => Some x25 + | 38 => Some x26 + | 39 => Some x27 + | 40 => Some x28 + | 41 => Some x29 + | 42 => Some x2a + | 43 => Some x2b + | 44 => Some x2c + | 45 => Some x2d + | 46 => Some x2e + | 47 => Some x2f + | 48 => Some x30 + | 49 => Some x31 + | 50 => Some x32 + | 51 => Some x33 + | 52 => Some x34 + | 53 => Some x35 + | 54 => Some x36 + | 55 => Some x37 + | 56 => Some x38 + | 57 => Some x39 + | 58 => Some x3a + | 59 => Some x3b + | 60 => Some x3c + | 61 => Some x3d + | 62 => Some x3e + | 63 => Some x3f + | 64 => Some x40 + | 65 => Some x41 + | 66 => Some x42 + | 67 => Some x43 + | 68 => Some x44 + | 69 => Some x45 + | 70 => Some x46 + | 71 => Some x47 + | 72 => Some x48 + | 73 => Some x49 + | 74 => Some x4a + | 75 => Some x4b + | 76 => Some x4c + | 77 => Some x4d + | 78 => Some x4e + | 79 => Some x4f + | 80 => Some x50 + | 81 => Some x51 + | 82 => Some x52 + | 83 => Some x53 + | 84 => Some x54 + | 85 => Some x55 + | 86 => Some x56 + | 87 => Some x57 + | 88 => Some x58 + | 89 => Some x59 + | 90 => Some x5a + | 91 => Some x5b + | 92 => Some x5c + | 93 => Some x5d + | 94 => Some x5e + | 95 => Some x5f + | 96 => Some x60 + | 97 => Some x61 + | 98 => Some x62 + | 99 => Some x63 + | 100 => Some x64 + | 101 => Some x65 + | 102 => Some x66 + | 103 => Some x67 + | 104 => Some x68 + | 105 => Some x69 + | 106 => Some x6a + | 107 => Some x6b + | 108 => Some x6c + | 109 => Some x6d + | 110 => Some x6e + | 111 => Some x6f + | 112 => Some x70 + | 113 => Some x71 + | 114 => Some x72 + | 115 => Some x73 + | 116 => Some x74 + | 117 => Some x75 + | 118 => Some x76 + | 119 => Some x77 + | 120 => Some x78 + | 121 => Some x79 + | 122 => Some x7a + | 123 => Some x7b + | 124 => Some x7c + | 125 => Some x7d + | 126 => Some x7e + | 127 => Some x7f + | 128 => Some x80 + | 129 => Some x81 + | 130 => Some x82 + | 131 => Some x83 + | 132 => Some x84 + | 133 => Some x85 + | 134 => Some x86 + | 135 => Some x87 + | 136 => Some x88 + | 137 => Some x89 + | 138 => Some x8a + | 139 => Some x8b + | 140 => Some x8c + | 141 => Some x8d + | 142 => Some x8e + | 143 => Some x8f + | 144 => Some x90 + | 145 => Some x91 + | 146 => Some x92 + | 147 => Some x93 + | 148 => Some x94 + | 149 => Some x95 + | 150 => Some x96 + | 151 => Some x97 + | 152 => Some x98 + | 153 => Some x99 + | 154 => Some x9a + | 155 => Some x9b + | 156 => Some x9c + | 157 => Some x9d + | 158 => Some x9e + | 159 => Some x9f + | 160 => Some xa0 + | 161 => Some xa1 + | 162 => Some xa2 + | 163 => Some xa3 + | 164 => Some xa4 + | 165 => Some xa5 + | 166 => Some xa6 + | 167 => Some xa7 + | 168 => Some xa8 + | 169 => Some xa9 + | 170 => Some xaa + | 171 => Some xab + | 172 => Some xac + | 173 => Some xad + | 174 => Some xae + | 175 => Some xaf + | 176 => Some xb0 + | 177 => Some xb1 + | 178 => Some xb2 + | 179 => Some xb3 + | 180 => Some xb4 + | 181 => Some xb5 + | 182 => Some xb6 + | 183 => Some xb7 + | 184 => Some xb8 + | 185 => Some xb9 + | 186 => Some xba + | 187 => Some xbb + | 188 => Some xbc + | 189 => Some xbd + | 190 => Some xbe + | 191 => Some xbf + | 192 => Some xc0 + | 193 => Some xc1 + | 194 => Some xc2 + | 195 => Some xc3 + | 196 => Some xc4 + | 197 => Some xc5 + | 198 => Some xc6 + | 199 => Some xc7 + | 200 => Some xc8 + | 201 => Some xc9 + | 202 => Some xca + | 203 => Some xcb + | 204 => Some xcc + | 205 => Some xcd + | 206 => Some xce + | 207 => Some xcf + | 208 => Some xd0 + | 209 => Some xd1 + | 210 => Some xd2 + | 211 => Some xd3 + | 212 => Some xd4 + | 213 => Some xd5 + | 214 => Some xd6 + | 215 => Some xd7 + | 216 => Some xd8 + | 217 => Some xd9 + | 218 => Some xda + | 219 => Some xdb + | 220 => Some xdc + | 221 => Some xdd + | 222 => Some xde + | 223 => Some xdf + | 224 => Some xe0 + | 225 => Some xe1 + | 226 => Some xe2 + | 227 => Some xe3 + | 228 => Some xe4 + | 229 => Some xe5 + | 230 => Some xe6 + | 231 => Some xe7 + | 232 => Some xe8 + | 233 => Some xe9 + | 234 => Some xea + | 235 => Some xeb + | 236 => Some xec + | 237 => Some xed + | 238 => Some xee + | 239 => Some xef + | 240 => Some xf0 + | 241 => Some xf1 + | 242 => Some xf2 + | 243 => Some xf3 + | 244 => Some xf4 + | 245 => Some xf5 + | 246 => Some xf6 + | 247 => Some xf7 + | 248 => Some xf8 + | 249 => Some xf9 + | 250 => Some xfa + | 251 => Some xfb + | 252 => Some xfc + | 253 => Some xfd + | 254 => Some xfe + | 255 => Some xff + | _ => None + end. + + Lemma of_to_N x : of_N (to_N x) = Some x. + Proof. destruct x; reflexivity. Qed. + + Lemma to_of_N x y : of_N x = Some y -> to_N y = x. + Proof. + cbv [of_N]; + repeat match goal with + | [ |- context[match ?x with _ => _ end] ] => is_var x; destruct x + | _ => intro + | _ => reflexivity + | _ => progress subst + | [ H : Some ?a = Some ?b |- _ ] => assert (a = b) by refine match H with eq_refl => eq_refl end; clear H + | [ H : None = Some _ |- _ ] => solve [ inversion H ] + end. + Qed. + + Lemma to_of_N_iff x y : of_N x = Some y <-> to_N y = x. + Proof. split; intro; subst; (apply of_to_N || apply to_of_N); assumption. Qed. + + Lemma to_of_N_option_map x : option_map to_N (of_N x) = if N.leb x 255 then Some x else None. + Proof. + cbv [of_N]; + repeat match goal with + | [ |- context[match ?x with _ => _ end] ] => is_var x; destruct x + end; + reflexivity. + Qed. + + Lemma to_N_bounded x : to_N x <= 255. + Proof. + generalize (to_of_N_option_map (to_N x)). + rewrite of_to_N; cbn [option_map]. + destruct (N.leb (to_N x) 255) eqn:H; [ | congruence ]. + rewrite (N.leb_le (to_N x) 255) in H. + intro; assumption. + Qed. + + Lemma of_N_None_iff x : of_N x = None <-> 255 < x. + Proof. + generalize (to_of_N_option_map x). + destruct (of_N x), (N.leb x 255) eqn:H; cbn [option_map]; try congruence. + { rewrite N.leb_le in H; split; [ congruence | ]. + rewrite N.lt_nge; intro H'; exfalso; apply H'; assumption. } + { rewrite N.leb_nle in H; split; [ | reflexivity ]. + rewrite N.lt_nge; intro; assumption. } + Qed. + + Lemma to_N_via_nat x : to_N x = N.of_nat (to_nat x). + Proof. destruct x; reflexivity. Qed. + + Lemma to_nat_via_N x : to_nat x = N.to_nat (to_N x). + Proof. destruct x; reflexivity. Qed. + + Lemma of_N_via_nat x : of_N x = of_nat (N.to_nat x). + Proof. + destruct (of_N x) as [b|] eqn:H1. + { rewrite to_of_N_iff in H1; subst. + destruct b; reflexivity. } + { rewrite of_N_None_iff, <- N.compare_lt_iff in H1. + symmetry; rewrite of_nat_None_iff, <- PeanoNat.Nat.compare_lt_iff. + rewrite Nat2N.inj_compare, N2Nat.id; assumption. } + Qed. + + Lemma of_nat_via_N x : of_nat x = of_N (N.of_nat x). + Proof. + destruct (of_nat x) as [b|] eqn:H1. + { rewrite to_of_nat_iff in H1; subst. + destruct b; reflexivity. } + { rewrite of_nat_None_iff, <- PeanoNat.Nat.compare_lt_iff in H1. + symmetry; rewrite of_N_None_iff, <- N.compare_lt_iff. + rewrite N2Nat.inj_compare, Nat2N.id; assumption. } + Qed. +End N. diff --git a/theories/Strings/HexString.v b/theories/Strings/HexString.v index 9ea93c909e..9fa8e0ccf2 100644 --- a/theories/Strings/HexString.v +++ b/theories/Strings/HexString.v @@ -120,7 +120,7 @@ Module Raw. end end. - Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) + Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) {struct p} : to_N (of_pos p rest) base = to_N rest match base with | N0 => N.pos p diff --git a/theories/Strings/OctalString.v b/theories/Strings/OctalString.v index fe8cc9aae9..78e98e451b 100644 --- a/theories/Strings/OctalString.v +++ b/theories/Strings/OctalString.v @@ -78,7 +78,7 @@ Module Raw. end end. - Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) + Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) {struct p} : to_N (of_pos p rest) base = to_N rest match base with | N0 => N.pos p diff --git a/theories/Strings/String.v b/theories/Strings/String.v index a09d518892..08ccfac877 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -15,6 +15,7 @@ Require Import Arith. Require Import Ascii. Require Import Bool. +Require Import Coq.Strings.Byte. (** *** Definition of strings *) @@ -25,7 +26,6 @@ Inductive string : Set := | String : ascii -> string -> string. Declare Scope string_scope. -Module Export StringSyntax. Declare ML Module "string_syntax_plugin". End StringSyntax. Delimit Scope string_scope with string. Bind Scope string_scope with string. Local Open Scope string_scope. @@ -114,12 +114,12 @@ Theorem get_correct : Proof. intros s1; elim s1; simpl. intros s2; case s2; simpl; split; auto. -intros H; generalize (H 0); intros H1; inversion H1. +intros H; generalize (H O); intros H1; inversion H1. intros; discriminate. intros a s1' Rec s2; case s2; simpl; split; auto. -intros H; generalize (H 0); intros H1; inversion H1. +intros H; generalize (H O); intros H1; inversion H1. intros; discriminate. -intros H; generalize (H 0); simpl; intros H1; inversion H1. +intros H; generalize (H O); simpl; intros H1; inversion H1. case (Rec s). intros H0; rewrite H0; auto. intros n; exact (H (S n)). @@ -150,7 +150,7 @@ Proof. intros s1; elim s1; simpl; auto. intros s2 n; rewrite plus_comm; simpl; auto. intros a s1' Rec s2 n; case n; simpl; auto. -generalize (Rec s2 0); simpl; auto. intros. +generalize (Rec s2 O); simpl; auto. intros. rewrite <- Plus.plus_Snm_nSm; auto. Qed. @@ -162,9 +162,9 @@ Qed. Fixpoint substring (n m : nat) (s : string) : string := match n, m, s with - | 0, 0, _ => EmptyString - | 0, S m', EmptyString => s - | 0, S m', String c s' => String c (substring 0 m' s') + | O, O, _ => EmptyString + | O, S m', EmptyString => s + | O, S m', String c s' => String c (substring 0 m' s') | S n', _, EmptyString => s | S n', _, String c s' => substring n' m s' end. @@ -257,16 +257,16 @@ Qed. Fixpoint index (n : nat) (s1 s2 : string) : option nat := match s2, n with - | EmptyString, 0 => + | EmptyString, O => match s1 with - | EmptyString => Some 0 + | EmptyString => Some O | String a s1' => None end | EmptyString, S n' => None - | String b s2', 0 => - if prefix s1 s2 then Some 0 + | String b s2', O => + if prefix s1 s2 then Some O else - match index 0 s1 s2' with + match index O s1 s2' with | Some n => Some (S n) | None => None end @@ -300,8 +300,8 @@ generalize (prefix_correct s1 (String b s2')); intros H0 H; injection H as <-; auto. case H0; simpl; auto. case m; simpl; auto. -case (index 0 s1 s2'); intros; discriminate. -intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto. +case (index O s1 s2'); intros; discriminate. +intros m'; generalize (Rec O m' s1); case (index O s1 s2'); auto. intros x H H0 H1; apply H; injection H1; auto. intros; discriminate. intros n'; case m; simpl; auto. @@ -335,7 +335,7 @@ intros H0 H; injection H as <-; auto. intros p H2 H3; inversion H3. case m; simpl; auto. case (index 0 s1 s2'); intros; discriminate. -intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto. +intros m'; generalize (Rec O m' s1); case (index 0 s1 s2'); auto. intros x H H0 H1 p; try case p; simpl; auto. intros H2 H3; red; intros H4; case H0. intros H5 H6; absurd (false = true); auto with bool. @@ -383,7 +383,7 @@ intros H4 H5; absurd (false = true); auto with bool. case s1; simpl; auto. intros a s n0 H H0 H1 H2; change (substring n0 (length (String a s)) s2' <> String a s); - apply (Rec 0); auto. + apply (Rec O); auto. generalize H0; case (index 0 (String a s) s2'); simpl; auto; intros; discriminate. apply Le.le_O_n. @@ -423,9 +423,53 @@ Qed. Definition findex n s1 s2 := match index n s1 s2 with | Some n => n - | None => 0 + | None => O end. +(** *** Conversion to/from [list ascii] and [list byte] *) + +Fixpoint string_of_list_ascii (s : list ascii) : string + := match s with + | nil => EmptyString + | cons ch s => String ch (string_of_list_ascii s) + end. + +Fixpoint list_ascii_of_string (s : string) : list ascii + := match s with + | EmptyString => nil + | String ch s => cons ch (list_ascii_of_string s) + end. + +Lemma string_of_list_ascii_of_string s : string_of_list_ascii (list_ascii_of_string s) = s. +Proof. + induction s as [|? ? IHs]; [ reflexivity | cbn; apply f_equal, IHs ]. +Defined. + +Lemma list_ascii_of_string_of_list_ascii s : list_ascii_of_string (string_of_list_ascii s) = s. +Proof. + induction s as [|? ? IHs]; [ reflexivity | cbn; apply f_equal, IHs ]. +Defined. + +Definition string_of_list_byte (s : list byte) : string + := string_of_list_ascii (List.map ascii_of_byte s). + +Definition list_byte_of_string (s : string) : list byte + := List.map byte_of_ascii (list_ascii_of_string s). + +Lemma string_of_list_byte_of_string s : string_of_list_byte (list_byte_of_string s) = s. +Proof. + cbv [string_of_list_byte list_byte_of_string]. + erewrite List.map_map, List.map_ext, List.map_id, string_of_list_ascii_of_string; [ reflexivity | intro ]. + apply ascii_of_byte_of_ascii. +Qed. + +Lemma list_byte_of_string_of_list_byte s : list_byte_of_string (string_of_list_byte s) = s. +Proof. + cbv [string_of_list_byte list_byte_of_string]. + erewrite list_ascii_of_string_of_list_ascii, List.map_map, List.map_ext, List.map_id; [ reflexivity | intro ]. + apply byte_of_ascii_of_byte. +Qed. + (** *** Concrete syntax *) (** @@ -438,7 +482,11 @@ Definition findex n s1 s2 := part of a valid utf8 sequence of characters are not representable using the Coq string notation (use explicitly the String constructor with the ascii codes of the characters). -*) + *) + +Module Export StringSyntax. + String Notation string string_of_list_byte list_byte_of_string : string_scope. +End StringSyntax. Example HelloWorld := " ""Hello world!"" ". diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 226a19678f..4e80caa4cc 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -233,7 +233,7 @@ struct let rem = NSet.fold push next rem in aux rem seen | Some false -> - (** The path we took encountered x -> y but not the one in seen *) + (* The path we took encountered x -> y but not the one in seen *) if through then aux (NMap.add n true rem) (NMap.add n true seen) else aux rem seen | Some true -> aux rem seen @@ -357,7 +357,7 @@ let treat_coq_file chan = | None -> acc | Some file_str -> (canonize file_str, ".v") :: acc else acc - | AddLoadPath _ | AddRecLoadPath _ -> acc (** TODO *) + | AddLoadPath _ | AddRecLoadPath _ -> acc (* TODO *) in loop acc in diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index db2031c64b..e3dd32fb63 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -132,7 +132,7 @@ let add_mllib_known, _, search_mllib_known = mkknown () let add_mlpack_known, _, search_mlpack_known = mkknown () let vKnown = (Hashtbl.create 19 : (string list, string * bool) Hashtbl.t) -(** The associated boolean is true if this is a root path. *) +(* The associated boolean is true if this is a root path. *) let coqlibKnown = (Hashtbl.create 19 : (string list, unit) Hashtbl.t) let get_prefix p l = diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 6c4ea9afa1..0a32879764 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -176,7 +176,7 @@ let set_batch_mode opts = let add_compile opts verbose s = let opts = set_batch_mode opts in if not opts.glob_opt then Dumpglob.dump_to_dotglob (); - (** make the file name explicit; needed not to break up Coq loadpath stuff. *) + (* make the file name explicit; needed not to break up Coq loadpath stuff. *) let s = let open Filename in if is_implicit s diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 5cf2157044..e58b9ccac7 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -323,7 +323,8 @@ let loop_flush_all () = let pequal cmp1 cmp2 (a1,a2) (b1,b2) = cmp1 a1 b1 && cmp2 a2 b2 let evleq e1 e2 = CList.equal Evar.equal e1 e2 let cproof p1 p2 = - let (a1,a2,a3,a4,_),(b1,b2,b3,b4,_) = Proof.proof p1, Proof.proof p2 in + let Proof.{goals=a1;stack=a2;shelf=a3;given_up=a4} = Proof.data p1 in + let Proof.{goals=b1;stack=b2;shelf=b3;given_up=b4} = Proof.data p2 in evleq a1 b1 && CList.equal (pequal evleq evleq) a2 b2 && CList.equal Evar.equal a3 b3 && diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index edef741ca6..56622abc92 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -95,9 +95,9 @@ let init_color opts = if has_color then begin let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in match colors with - | None -> Topfmt.default_styles (); true (** Default colors *) - | Some "" -> false (** No color output *) - | Some s -> Topfmt.parse_color_config s; true (** Overwrite all colors *) + | None -> Topfmt.default_styles (); true (* Default colors *) + | Some "" -> false (* No color output *) + | Some s -> Topfmt.parse_color_config s; true (* Overwrite all colors *) end else false @@ -144,7 +144,7 @@ let init_gc () = * In this case, we put in place our preferred configuration. *) Gc.set { (Gc.get ()) with - Gc.minor_heap_size = 33554432; (** 4M *) + Gc.minor_heap_size = 33554432; (* 4M *) Gc.space_overhead = 120} (** Main init routine *) diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 3ca2a4ad6b..b5cc74b594 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -294,7 +294,7 @@ let traverse current t = let type_of_constant cb = cb.Declarations.const_type let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = - (** Only keep the transitive dependencies *) + (* Only keep the transitive dependencies *) let (_, graph, ax2ty) = traverse (label_of gr) t in let fold obj _ accu = match obj with | VarRef id -> diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 6a32960a9d..66e10f94cd 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -119,6 +119,7 @@ val vernac_monomorphic_flag : vernac_flag (** For the stm, do not use! *) val polymorphic_nowarn : bool attribute + (** For internal use, avoid warning if not qualified as eg [universes(polymorphic)]. *) val universe_polymorphism_option_name : string list val is_universe_polymorphism : unit -> bool diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index fa1b8eeb3e..d9787bc73c 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -335,8 +335,8 @@ let build_beq_scheme mode kn = | Finite -> mkFix (((Array.make nb_ind 0),i),(names,types,cores)) | BiFinite -> - (** If the inductive type is not recursive, the fixpoint is not - used, so let's replace it with garbage *) + (* If the inductive type is not recursive, the fixpoint is + not used, so let's replace it with garbage *) let subst = List.init nb_ind (fun _ -> mkProp) in Vars.substl subst cores.(i) in diff --git a/vernac/class.ml b/vernac/class.ml index ab43d5c8ff..8374a5c84f 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -66,7 +66,7 @@ let explain_coercion_error g = function let check_reference_arity ref = let env = Global.env () in let c, _ = Typeops.type_of_global_in_context env ref in - if not (Reductionops.is_arity env (Evd.from_env env) (EConstr.of_constr c)) (** FIXME *) then + if not (Reductionops.is_arity env (Evd.from_env env) (EConstr.of_constr c)) (* FIXME *) then raise (CoercionError (NotAClass ref)) let check_arity = function @@ -260,7 +260,7 @@ let add_new_coercion_core coef stre poly source target isid = raise (CoercionError (NoSource source)) in check_source (Some cls); - if not (uniform_cond Evd.empty (** FIXME - for when possibly called with unresolved evars in the future *) + if not (uniform_cond Evd.empty (* FIXME - for when possibly called with unresolved evars in the future *) ctx lvs) then warn_uniform_inheritance coef; let clt = diff --git a/vernac/classes.ml b/vernac/classes.ml index d0cf1c6bee..370df615fc 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -373,7 +373,7 @@ let context poly l = | [] -> assert false | [_] -> Evd.const_univ_entry ~poly sigma | _::_::_ -> - (** TODO: explain this little belly dance *) + (* TODO: explain this little belly dance *) if Lib.sections_are_opened () then begin diff --git a/vernac/classes.mli b/vernac/classes.mli index bb70334342..eb6c0c92e1 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -27,22 +27,22 @@ val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit val declare_instance_constant : typeclass -> - Hints.hint_info_expr -> (** priority *) - bool -> (** globality *) - Impargs.manual_explicitation list -> (** implicits *) + Hints.hint_info_expr (** priority *) -> + bool (** globality *) -> + Impargs.manual_explicitation list (** implicits *) -> ?hook:(GlobRef.t -> unit) -> - Id.t -> (** name *) + Id.t (** name *) -> UState.universe_decl -> - bool -> (* polymorphic *) - Evd.evar_map -> (* Universes *) - Constr.t -> (** body *) - Constr.types -> (** type *) + bool (** polymorphic *) -> + Evd.evar_map (** Universes *) -> + Constr.t (** body *) -> + Constr.types (** type *) -> unit val new_instance : - ?abstract:bool -> (** Not abstract by default. *) - ?global:bool -> (** Not global by default. *) - ?refine:bool -> (** Allow refinement *) + ?abstract:bool (** Not abstract by default. *) -> + ?global:bool (** Not global by default. *) -> + ?refine:bool (** Allow refinement *) -> program_mode:bool -> Decl_kinds.polymorphic -> local_binder_expr list -> diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index f4569ed3e2..338dfa5ef5 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -78,6 +78,7 @@ val interp_fixpoint : (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Registering fixpoints and cofixpoints in the environment *) + (** [Not used so far] *) val declare_fixpoint : locality -> polymorphic -> diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 8b9cf7d269..4af6415a4d 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -265,7 +265,7 @@ let inductive_levels env evd poly arities inds = else minlev in let minlev = - (** Indices contribute. *) + (* Indices contribute. *) if indices_matter env && List.length ctx > 0 then ( let ilev = sign_level env evd ctx in Univ.sup ilev minlev) @@ -282,15 +282,15 @@ let inductive_levels env evd poly arities inds = let evd, arities = CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> if is_impredicative env du then - (** Any product is allowed here. *) + (* Any product is allowed here. *) evd, arity :: arities - else (** If in a predicative sort, or asked to infer the type, - we take the max of: - - indices (if in indices-matter mode) - - constructors - - Type(1) if there is more than 1 constructor + else (* If in a predicative sort, or asked to infer the type, + we take the max of: + - indices (if in indices-matter mode) + - constructors + - Type(1) if there is more than 1 constructor *) - (** Constructors contribute. *) + (* Constructors contribute. *) let evd = if Sorts.is_set du then if not (Evd.check_leq evd cu Univ.type0_univ) then @@ -301,7 +301,7 @@ let inductive_levels env evd poly arities inds = in let evd = if len >= 2 && Univ.is_type0m_univ cu then - (** "Polymorphic" type constraint and more than one constructor, + (* "Polymorphic" type constraint and more than one constructor, should not land in Prop. Add constraint only if it would land in Prop directly (no informative arguments as well). *) Evd.set_leq_sort env evd Set du @@ -510,7 +510,7 @@ let is_recursive mie = let rec is_recursive_constructor lift typ = match Constr.kind typ with | Prod (_,arg,rest) -> - not (EConstr.Vars.noccurn Evd.empty (** FIXME *) lift (EConstr.of_constr arg)) || + not (EConstr.Vars.noccurn Evd.empty (* FIXME *) lift (EConstr.of_constr arg)) || is_recursive_constructor (lift+1) rest | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest | _ -> false diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index f23085a538..9df8f7c341 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -39,8 +39,8 @@ val do_mutual_inductive : associated schemes *) type one_inductive_impls = - Impargs.manual_implicits (** for inds *)* - Impargs.manual_implicits list (** for constrs *) + Impargs.manual_implicits (* for inds *) * + Impargs.manual_implicits list (* for constrs *) val declare_mutual_inductive_with_eliminations : mutual_inductive_entry -> UnivNames.universe_binders -> one_inductive_impls list -> diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index e62ae99159..edce8e255c 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -211,7 +211,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let univs = Evd.check_univ_decl ~poly sigma decl in (*FIXME poly? *) let ce = definition_entry ~types:ty ~univs (EConstr.to_constr sigma body) in - (** FIXME: include locality *) + (* FIXME: include locality *) let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in if Impargs.is_implicit_args () || not (List.is_empty impls) then diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 898de7b166..41057f8ab2 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -27,7 +27,7 @@ let warn_local_declaration = let get_locality id ~kind = function | Discharge -> - (** If a Let is defined outside a section, then we consider it as a local definition *) + (* If a Let is defined outside a section, then we consider it as a local definition *) warn_local_declaration (id,kind); true | Local -> true diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index befb4d7ccf..e1496e58d7 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -64,8 +64,8 @@ let process_vernac_interp_error exn = match fst exn with wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te) | PretypeError(ctx,sigma,te) -> wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) - | Notation.NumeralNotationError(ctx,sigma,te) -> - wrap_vernac_error exn (Himsg.explain_numeral_notation_error ctx sigma te) + | Notation.PrimTokenNotationError(kind,ctx,sigma,te) -> + wrap_vernac_error exn (Himsg.explain_prim_token_notation_error kind ctx sigma te) | Typeclasses_errors.TypeClassError(env, te) -> wrap_vernac_error exn (Himsg.explain_typeclass_error env te) | Implicit_quantifiers.MismatchedContextInstance(e,c,l,x) -> diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 6c7117b513..a2b5c8d70a 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -125,12 +125,12 @@ let display_eq ~flags env sigma t1 t2 = printed alike. *) let rec pr_explicit_aux env sigma t1 t2 = function | [] -> - (** no specified flags: default. *) + (* no specified flags: default. *) (quote (Printer.pr_leconstr_env env sigma t1), quote (Printer.pr_leconstr_env env sigma t2)) | flags :: rem -> let equal = display_eq ~flags env sigma t1 t2 in if equal then - (** The two terms are the same from the user point of view *) + (* The two terms are the same from the user point of view *) pr_explicit_aux env sigma t1 t2 rem else let open Constrextern in @@ -142,12 +142,12 @@ let rec pr_explicit_aux env sigma t1 t2 = function let explicit_flags = let open Constrextern in - [ []; (** First, try with the current flags *) - [print_implicits]; (** Then with implicit *) - [print_universes]; (** Then with universes *) - [print_universes; print_implicits]; (** With universes AND implicits *) - [print_implicits; print_coercions; print_no_symbol]; (** Then more! *) - [print_universes; print_implicits; print_coercions; print_no_symbol] (** and more! *) ] + [ []; (* First, try with the current flags *) + [print_implicits]; (* Then with implicit *) + [print_universes]; (* Then with universes *) + [print_universes; print_implicits]; (* With universes AND implicits *) + [print_implicits; print_coercions; print_no_symbol]; (* Then more! *) + [print_universes; print_implicits; print_coercions; print_no_symbol] (* and more! *) ] let pr_explicit env sigma t1 t2 = pr_explicit_aux env sigma t1 t2 explicit_flags @@ -328,7 +328,7 @@ let explain_actual_type env sigma j t reason = let env = make_all_name_different env sigma in let j = j_nf_betaiotaevar env sigma j in let t = Reductionops.nf_betaiota env sigma t in - (** Actually print *) + (* Actually print *) let pe = pr_ne_context_of (str "In environment") env sigma in let pc = pr_leconstr_env env sigma (Environ.j_val j) in let (pt, pct) = pr_explicit env sigma t (Environ.j_type j) in @@ -774,7 +774,7 @@ let explain_unsatisfiable_constraints env sigma constr comp = let (_, constraints) = Evd.extract_all_conv_pbs sigma in let tcs = Evd.get_typeclass_evars sigma in let undef = Evd.undefined_map sigma in - (** Only keep evars that are subject to resolution and members of the given + (* Only keep evars that are subject to resolution and members of the given component. *) let is_kept evk _ = match comp with | None -> Evar.Set.mem evk tcs @@ -1112,7 +1112,7 @@ let error_ill_formed_inductive env c v = let error_ill_formed_constructor env id c v nparams nargs = let pv = pr_lconstr_env env (Evd.from_env env) v in - let atomic = Int.equal (nb_prod Evd.empty (EConstr.of_constr c)) (** FIXME *) 0 in + let atomic = Int.equal (nb_prod Evd.empty (EConstr.of_constr c)) (* FIXME *) 0 in str "The type of constructor" ++ brk(1,1) ++ Id.print id ++ brk(1,1) ++ str "is not valid;" ++ brk(1,1) ++ strbrk (if atomic then "it must be " else "its conclusion must be ") ++ @@ -1326,12 +1326,12 @@ let explain_reduction_tactic_error = function spc () ++ str "is not well typed." ++ fnl () ++ explain_type_error env' (Evd.from_env env') e -let explain_numeral_notation_error env sigma = function +let explain_prim_token_notation_error kind env sigma = function | Notation.UnexpectedTerm c -> (strbrk "Unexpected term " ++ pr_constr_env env sigma c ++ - strbrk " while parsing a numeral notation.") + strbrk (" while parsing a "^kind^" notation.")) | Notation.UnexpectedNonOptionTerm c -> (strbrk "Unexpected non-option term " ++ pr_constr_env env sigma c ++ - strbrk " while parsing a numeral notation.") + strbrk (" while parsing a "^kind^" notation.")) diff --git a/vernac/himsg.mli b/vernac/himsg.mli index db05aaa125..bab66b2af4 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -47,4 +47,4 @@ val explain_module_internalization_error : val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error -val explain_numeral_notation_error : env -> Evd.evar_map -> Notation.numeral_notation_error -> Pp.t +val explain_prim_token_notation_error : string -> env -> Evd.evar_map -> Notation.prim_token_notation_error -> Pp.t diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 9bd095aa52..d29f66f81f 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -307,7 +307,7 @@ let warn_cannot_build_congruence = strbrk "Cannot build congruence scheme because eq is not found") let declare_congr_scheme ind = - if Hipattern.is_equality_type Evd.empty (EConstr.of_constr (mkInd ind)) (** FIXME *) then begin + if Hipattern.is_equality_type Evd.empty (EConstr.of_constr (mkInd ind)) (* FIXME *) then begin if try Coqlib.check_required_library Coqlib.logic_module_name; true with e when CErrors.noncritical e -> false diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 1a6eda446c..8f155adb8a 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -483,7 +483,7 @@ let save_proof ?proof = function let pftree = Proof_global.give_me_the_proof () in let id, k, typ = Pfedit.current_proof_statement () in let typ = EConstr.Unsafe.to_constr typ in - let universes = Proof.initial_euctx pftree in + let universes = Proof.((data pftree).initial_euctx) in (* This will warn if the proof is complete *) let pproofs, _univs = Proof_global.return_proof ~allow_partial:true () in diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 82434afbbd..4e79b50b79 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -33,11 +33,9 @@ open Nameops let cache_token (_,s) = CLexer.add_keyword s let inToken : string -> obj = - declare_object {(default_object "TOKEN") with - open_function = (fun i o -> if Int.equal i 1 then cache_token o); - cache_function = cache_token; - subst_function = Libobject.ident_subst_function; - classify_function = (fun o -> Substitute o)} + declare_object @@ global_object_nodischarge "TOKEN" + ~cache:cache_token + ~subst:(Some Libobject.ident_subst_function) let add_token_obj s = Lib.add_anonymous_leaf (inToken s) @@ -1361,7 +1359,7 @@ let inNotation : notation_obj -> obj = (**********************************************************************) let with_lib_stk_protection f x = - let fs = Lib.freeze ~marshallable:`No in + let fs = Lib.freeze ~marshallable:false in try let a = f x in Lib.unfreeze fs; a with reraise -> let reraise = CErrors.push reraise in @@ -1467,7 +1465,7 @@ let add_notation_in_scope local df env c mods scope = notobj_local = local; notobj_scope = scope; notobj_interp = (List.map_filter map i_vars, ac); - (** Order is important here! *) + (* Order is important here! *) notobj_onlyparse = onlyparse; notobj_coercion = coe; notobj_onlyprint = sd.only_printing; @@ -1486,7 +1484,7 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_ let level, i_typs, onlyprint = if not (is_numeral symbs) then begin let sy = recover_notation_syntax (make_notation_key InConstrEntrySomeLevel symbs) in let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy)) in - (** If the only printing flag has been explicitly requested, put it back *) + (* If the only printing flag has been explicitly requested, put it back *) let onlyprint = onlyprint || sy.synext_notgram.notgram_onlyprinting in let _,_,_,typs = sy.synext_level in Some sy.synext_level, typs, onlyprint @@ -1507,7 +1505,7 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_ notobj_local = local; notobj_scope = scope; notobj_interp = (List.map_filter map i_vars, ac); - (** Order is important here! *) + (* Order is important here! *) notobj_onlyparse = onlyparse; notobj_coercion = coe; notobj_onlyprint = onlyprint; diff --git a/vernac/mltop.ml b/vernac/mltop.ml index 3620e177fe..8d6268753e 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -394,7 +394,7 @@ let unfreeze_ml_modules x = let _ = Summary.declare_ml_modules_summary - { Summary.freeze_function = (fun _ -> get_loaded_modules ()); + { Summary.freeze_function = (fun ~marshallable -> get_loaded_modules ()); Summary.unfreeze_function = unfreeze_ml_modules; Summary.init_function = reset_loaded_modules } diff --git a/vernac/obligations.ml b/vernac/obligations.ml index f18227039f..6642d04c98 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -381,7 +381,7 @@ let subst_deps expand obls deps t = (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t) let rec prod_app t n = - match Constr.kind (EConstr.Unsafe.to_constr (Termops.strip_outer_cast Evd.empty (EConstr.of_constr t))) (** FIXME *) with + match Constr.kind (EConstr.Unsafe.to_constr (Termops.strip_outer_cast Evd.empty (EConstr.of_constr t))) (* FIXME *) with | Prod (_,_,b) -> subst1 n b | LetIn (_, b, t, b') -> prod_app (subst1 b b') n | _ -> @@ -503,7 +503,7 @@ let compute_possible_guardness_evidences (n,_) fixbody fixtype = but doing it properly involves delta-reduction, and it finally doesn't seem to worth the effort (except for huge mutual fixpoints ?) *) - let m = Termops.nb_prod Evd.empty (EConstr.of_constr fixtype) (** FIXME *) in + let m = Termops.nb_prod Evd.empty (EConstr.of_constr fixtype) (* FIXME *) in let ctx = fst (decompose_prod_n_assum m fixtype) in List.map_i (fun i _ -> i) 0 ctx @@ -649,7 +649,7 @@ let declare_obligation prg obl body ty uctx = const_entry_inline_code = false; const_entry_feedback = None; } in - (** ppedrot: seems legit to have obligations as local *) + (* ppedrot: seems legit to have obligations as local *) let constant = Declare.declare_constant obl.obl_name ~local:true (DefinitionEntry ce,IsProof Property) in @@ -857,9 +857,9 @@ let obligation_terminator ?univ_hook name num guard auto pf = let sigma = Evd.from_ctx uctx in let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in Inductiveops.control_only_guard (Global.env ()) sigma (EConstr.of_constr body); - (** Declare the obligation ourselves and drop the hook *) + (* Declare the obligation ourselves and drop the hook *) let prg = get_info (ProgMap.find name !from_prg) in - (** Ensure universes are substituted properly in body and type *) + (* Ensure universes are substituted properly in body and type *) let body = EConstr.to_constr sigma (EConstr.of_constr body) in let ty = Option.map (fun x -> EConstr.to_constr sigma (EConstr.of_constr x)) ty in let ctx = Evd.evar_universe_context sigma in @@ -885,14 +885,14 @@ let obligation_terminator ?univ_hook name num guard auto pf = let () = obls.(num) <- obl in let prg_ctx = if pi2 (prg.prg_kind) then (* Polymorphic *) - (** We merge the new universes and constraints of the - polymorphic obligation with the existing ones *) + (* We merge the new universes and constraints of the + polymorphic obligation with the existing ones *) UState.union prg.prg_ctx ctx else - (** The first obligation, if defined, - declares the univs of the constant, - each subsequent obligation declares its own additional - universes and constraints if any *) + (* The first obligation, if defined, + declares the univs of the constant, + each subsequent obligation declares its own additional + universes and constraints if any *) if defined then UState.make (Global.universes ()) else ctx in diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 46854b7f5d..e0dd3380f9 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -363,7 +363,7 @@ open Pputils match factorize l with | (xl,((c', t') as r))::l' when (c : bool) == c' && Pervasives.(=) t t' -> - (** FIXME: we need equality on constr_expr *) + (* FIXME: we need equality on constr_expr *) (idl@xl,r)::l' | l' -> (idl,(c,t))::l' diff --git a/vernac/record.ml b/vernac/record.ml index f6dbcb5291..ffd4f654c6 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -321,7 +321,7 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f ~proj_arg:i (Label.of_id fid) in - (** Already defined by declare_mind silently *) + (* Already defined by declare_mind silently *) let kn = Projection.Repr.constant p in Declare.definition_message fid; kn, mkProj (Projection.make p false,mkRel 1) diff --git a/vernac/search.ml b/vernac/search.ml index 1fac28358a..6610789626 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -172,8 +172,8 @@ let prioritize_search seq fn = (** Filters *) -(** This function tries to see whether the conclusion matches a pattern. *) -(** FIXME: this is quite dummy, we may find a more efficient algorithm. *) +(** This function tries to see whether the conclusion matches a pattern. + FIXME: this is quite dummy, we may find a more efficient algorithm. *) let rec pattern_filter pat ref env sigma typ = let typ = Termops.strip_outer_cast sigma typ in if Constr_matching.is_matching env sigma pat typ then true diff --git a/vernac/search.mli b/vernac/search.mli index 0dc82c1c3f..ecbb02bc68 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -49,16 +49,16 @@ val search_about : int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = - (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) | Name_Pattern of Str.regexp - (** Whether the object type satisfies a pattern *) + (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) | Type_Pattern of Pattern.constr_pattern - (** Whether some subtype of object type satisfies a pattern *) + (** Whether the object type satisfies a pattern *) | SubType_Pattern of Pattern.constr_pattern - (** Whether the object pertains to a module *) + (** Whether some subtype of object type satisfies a pattern *) | In_Module of Names.DirPath.t - (** Bypass the Search blacklist *) + (** Whether the object pertains to a module *) | Include_Blacklist + (** Bypass the Search blacklist *) type 'a coq_object = { coq_object_prefix : string list; diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 4bf76dae51..4065bb9c1f 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -222,20 +222,21 @@ let diff_tag_stack = ref [] (* global, just like std_ft *) (** Not thread-safe. We should put a lock somewhere if we print from different threads. Do we? *) let make_style_stack () = - (** Default tag is to reset everything *) + (* Default tag is to reset everything *) let style_stack = ref [] in let peek () = match !style_stack with - | [] -> default_style (** Anomalous case, but for robustness *) + | [] -> default_style (* Anomalous case, but for robustness *) | st :: _ -> st in let open_tag tag = let (tpfx, ttag) = split_tag tag in if tpfx = end_pfx then "" else let style = get_style ttag in - (** Merge the current settings and the style being pushed. This allows - restoring the previous settings correctly in a pop when both set the same - attribute. Example: current settings have red FG, the pushed style has - green FG. When popping the style, we should set red FG, not default FG. *) + (* Merge the current settings and the style being pushed. This + allows restoring the previous settings correctly in a pop + when both set the same attribute. Example: current settings + have red FG, the pushed style has green FG. When popping the + style, we should set red FG, not default FG. *) let style = Terminal.merge (peek ()) style in let diff = Terminal.diff (peek ()) style in style_stack := style :: !style_stack; @@ -247,7 +248,7 @@ let make_style_stack () = if tpfx = start_pfx then "" else begin if tpfx = end_pfx then diff_tag_stack := (try List.tl !diff_tag_stack with tl -> []); match !style_stack with - | [] -> (** Something went wrong, we fallback *) + | [] -> (* Something went wrong, we fallback *) Terminal.eval default_style | cur :: rem -> style_stack := rem; if cur = (peek ()) then "" else diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index f5d68a2199..e6e3db4beb 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -82,12 +82,12 @@ let show_proof () = let show_top_evars () = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) let pfts = Proof_global.give_me_the_proof () in - let gls,_,shelf,givenup,sigma = Proof.proof pfts in - pr_evars_int sigma ~shelf ~givenup 1 (Evd.undefined_map sigma) + let Proof.{goals;shelf;given_up;sigma} = Proof.data pfts in + pr_evars_int sigma ~shelf ~given_up 1 (Evd.undefined_map sigma) let show_universes () = let pfts = Proof_global.give_me_the_proof () in - let gls,_,_,_,sigma = Proof.proof pfts in + let Proof.{goals;sigma} = Proof.data pfts in let ctx = Evd.universe_context_set (Evd.minimize_universes sigma) in Termops.pr_evar_universe_context (Evd.evar_universe_context sigma) ++ fnl () ++ str "Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx @@ -96,9 +96,9 @@ let show_universes () = let show_intro all = let open EConstr in let pf = Proof_global.give_me_the_proof() in - let gls,_,_,_,sigma = Proof.proof pf in - if not (List.is_empty gls) then begin - let gl = {Evd.it=List.hd gls ; sigma = sigma; } in + let Proof.{goals;sigma} = Proof.data pf in + if not (List.is_empty goals) then begin + let gl = {Evd.it=List.hd goals ; sigma = sigma; } in let l,_= decompose_prod_assum sigma (Termops.strip_outer_cast sigma (pf_concl gl)) in if all then let lid = Tactics.find_intro_names l gl in @@ -681,14 +681,14 @@ let vernac_inductive ~atts cum lo finite indl = | _ -> None in if Option.has_some is_defclass then - (** Definitional class case *) + (* Definitional class case *) let (id, bl, c, l) = Option.get is_defclass in let (coe, (lid, ce)) = l in let coe' = if coe then Some true else None in let f = (((coe', AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce)), None), []) in vernac_record ~template udecl cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]] else if List.for_all is_record indl then - (** Mutual record case *) + (* Mutual record case *) let check_kind ((_, _, _, kind, _), _) = match kind with | Variant -> user_err (str "The Variant keyword does not support syntax { ... }.") @@ -704,14 +704,14 @@ let vernac_inductive ~atts cum lo finite indl = let unpack ((id, bl, c, _, decl), _) = match decl with | RecordDecl (oc, fs) -> (id, bl, c, oc, fs) - | Constructors _ -> assert false (** ruled out above *) + | Constructors _ -> assert false (* ruled out above *) in let ((_, _, _, kind, _), _) = List.hd indl in let kind = match kind with Class _ -> Class false | _ -> kind in let recordl = List.map unpack indl in vernac_record ~template udecl cum kind atts.polymorphic finite recordl else if List.for_all is_constructor indl then - (** Mutual inductive case *) + (* Mutual inductive case *) let check_kind ((_, _, _, kind, _), _) = match kind with | (Record | Structure) -> user_err (str "The Record keyword is for types defined using the syntax { ... }.") @@ -1047,8 +1047,9 @@ let vernac_set_end_tac tac = let vernac_set_used_variables e = let env = Global.env () in + let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in let tys = - List.map snd (Proof.initial_goals (Proof_global.give_me_the_proof ())) in + List.map snd (initial_goals (Proof_global.give_me_the_proof ())) in let tys = List.map EConstr.Unsafe.to_constr tys in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in @@ -1221,11 +1222,9 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red let rec check_extra_args extra_args = match extra_args with | [] -> () - | { notation_scope = None } :: _ -> err_extra_args (names_of extra_args) - | { name = Anonymous; notation_scope = Some _ } :: args -> - check_extra_args args - | _ -> - user_err Pp.(str "Extra notation scopes can be set on anonymous and explicit arguments only.") + | { notation_scope = None } :: _ -> + user_err Pp.(str"Extra arguments should specify a scope.") + | { notation_scope = Some _ } :: args -> check_extra_args args in let args, scopes = @@ -1817,8 +1816,8 @@ let vernac_global_check c = let get_nth_goal n = let pf = Proof_global.give_me_the_proof() in - let gls,_,_,_,sigma = Proof.proof pf in - let gl = {Evd.it=List.nth gls (n-1) ; sigma = sigma; } in + let Proof.{goals;sigma} = Proof.data pf in + let gl = {Evd.it=List.nth goals (n-1) ; sigma = sigma; } in gl exception NoHyp @@ -1992,7 +1991,7 @@ let vernac_search ~atts s gopt r = let vernac_locate = function | LocateAny {v=AN qid} -> print_located_qualid qid | LocateTerm {v=AN qid} -> print_located_term qid - | LocateAny {v=ByNotation (ntn, sc)} (** TODO : handle Ltac notations *) + | LocateAny {v=ByNotation (ntn, sc)} (* TODO : handle Ltac notations *) | LocateTerm {v=ByNotation (ntn, sc)} -> let _, env = Pfedit.get_current_context () in Notation.locate_notation @@ -2437,7 +2436,7 @@ let interp ?verbosely ?proof ~st cmd = Vernacstate.unfreeze_interp_state st; try interp ?verbosely ?proof ~st cmd; - Vernacstate.freeze_interp_state `No + Vernacstate.freeze_interp_state ~marshallable:false with exn -> let exn = CErrors.push exn in Vernacstate.invalidate_cache (); diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 1e6c40c829..417c9ebfbd 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -247,11 +247,11 @@ type vernac_argument_status = { } type extend_name = - (** Name of the vernac entry where the tactic is defined, typically found - after the VERNAC EXTEND statement in the source. *) + (* Name of the vernac entry where the tactic is defined, typically found + after the VERNAC EXTEND statement in the source. *) string * - (** Index of the extension in the VERNAC EXTEND statement. Each parsing branch - is given an offset, starting from zero. *) + (* Index of the extension in the VERNAC EXTEND statement. Each parsing branch + is given an offset, starting from zero. *) int type nonrec vernac_expr = diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 2541f73582..05687afd8b 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -42,8 +42,11 @@ and vernac_sideff_type = Names.Id.t list and opacity_guarantee = | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) + and solving_tac = bool (** a terminator *) + and anon_abstracting_tac = bool (** abstracting anonymously its result *) + and proof_block_name = string (** open type of delimiters *) type vernac_when = diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 8b07be8b16..0d43eb1ee8 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -58,8 +58,11 @@ and vernac_sideff_type = Names.Id.t list and opacity_guarantee = | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) + and solving_tac = bool (** a terminator *) + and anon_abstracting_tac = bool (** abstracting anonymously its result *) + and proof_block_name = string (** open type of delimiters *) type vernac_when = @@ -86,7 +89,7 @@ type (_, _) ty_sig = ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig -type ty_ml = TyML : bool (** deprecated *) * ('r, 's) ty_sig * 'r * 's option -> ty_ml +type ty_ml = TyML : bool (* deprecated *) * ('r, 's) ty_sig * 'r * 's option -> ty_ml (** Wrapper to dynamically extend vernacular commands. *) val vernac_extend : diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index aa8bcdc328..b40bccf27e 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -33,11 +33,18 @@ let do_if_not_cached rf f v = | Some _ -> () -let freeze_interp_state marshallable = +let freeze_interp_state ~marshallable = { system = update_cache s_cache (States.freeze ~marshallable); proof = update_cache s_proof (Proof_global.freeze ~marshallable); - shallow = marshallable = `Shallow } + shallow = marshallable } let unfreeze_interp_state { system; proof } = do_if_not_cached s_cache States.unfreeze system; do_if_not_cached s_proof Proof_global.unfreeze proof + +let make_shallow st = + let lib = States.lib_of_state st.system in + { st with + system = States.replace_lib st.system @@ Lib.drop_objects lib; + shallow = true; + } diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index b4d478d12d..ed20cb935a 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -14,8 +14,10 @@ type t = { shallow : bool (* is the state trimmed down (libstack) *) } -val freeze_interp_state : Summary.marshallable -> t +val freeze_interp_state : marshallable:bool -> t val unfreeze_interp_state : t -> unit +val make_shallow : t -> t + (* WARNING: Do not use, it will go away in future releases *) val invalidate_cache : unit -> unit |