diff options
255 files changed, 6275 insertions, 3057 deletions
diff --git a/Makefile.ide b/Makefile.ide index 640ee7b188..789acee5ec 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -296,10 +296,12 @@ $(COQIDEAPP):$(COQIDEAPP)/Contents/Resources # CoqIde for Windows special targets ########################################################################### +# This is either x86_64-w64-mingw32 or i686-w64-mingw32 +TARGET_ARCH=$(shell $CC -dumpmachine) + %.o: %.rc $(SHOW)'WINDRES $<' - $(HIDE)i686-w64-mingw32-windres -i $< -o $@ - + $(HIDE)$(TARGET_ARCH)-windres -i $< -o $@ # For emacs: # Local Variables: @@ -59,11 +59,11 @@ environment for semi-interactive development of machine-checked proofs. [nixpkgs-badge]: https://repology.org/badge/version-for-repo/nix_unstable/coq.svg [nixpkgs-link]: https://nixos.org/nixos/packages.html#coq -[dockerhub-badge]: https://img.shields.io/docker/automated/coqorg/coq.svg -[dockerhub-link]: https://hub.docker.com/r/coqorg/coq "Automated build on Docker Hub" +[dockerhub-badge]: https://img.shields.io/badge/images%20on-Docker%20Hub-blue.svg +[dockerhub-link]: https://hub.docker.com/r/coqorg/coq#supported-tags "Supported tags on Docker Hub" [coqorg-badge]: https://images.microbadger.com/badges/version/coqorg/coq.svg -[coqorg-link]: https://github.com/coq-community/docker-coq/wiki#docker-coq-images "Docker images of Coq" +[coqorg-link]: https://github.com/coq-community/docker-coq/wiki#docker-coq-images "coqorg/coq:latest" Download the pre-built packages of the [latest release][] for Windows and macOS; read the [help page][opam-using] on how to install Coq with OPAM; diff --git a/checker/checkFlags.ml b/checker/checkFlags.ml index 1f5e76bd83..369623e8c5 100644 --- a/checker/checkFlags.ml +++ b/checker/checkFlags.ml @@ -18,6 +18,7 @@ let set_local_flags flags env = check_universes = flags.check_universes; conv_oracle = flags.conv_oracle; cumulative_sprop = flags.cumulative_sprop; + allow_uip = flags.allow_uip; } in Environ.set_typing_flags flags env diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index c370a77ea0..ef606c9a75 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -101,11 +101,17 @@ let check_kelim k1 k2 = Sorts.family_leq k1 k2 (* 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_nested_types ty1 ty2 = match ty1, ty2 with +| NestedInd ind1, NestedInd ind2 -> eq_ind_chk ind1 ind2 +| NestedInd _, _ -> false +| NestedPrimitive c1, NestedPrimitive c2 -> Names.Constant.equal c1 c2 +| NestedPrimitive _, _ -> false + 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 + | Nested ty1, Nested ty2 -> eq_nested_types ty1 ty2 + | (Norec | Mrec _ | Nested _), _ -> false let eq_reloc_tbl = Array.equal (fun x y -> Int.equal (fst x) (fst y) && Int.equal (snd x) (snd y)) diff --git a/checker/checker.ml b/checker/checker.ml index 086acc482c..e2c90e2b93 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -95,12 +95,10 @@ let add_rec_path ~unix_path ~coq_root = else Feedback.msg_warning (str "Cannot open " ++ str unix_path) -(* By the option -include -I or -R of the command line *) +(* By the option -R/-Q of the command line *) let includes = ref [] let push_include (s, alias) = includes := (s,alias) :: !includes -let set_default_include d = - push_include (d, Check.default_root_prefix) let set_include d p = let p = dirpath_of_string p in push_include (d,p) @@ -127,7 +125,7 @@ let init_load_path () = List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) coqpath; (* then current directory *) add_path ~unix_path:"." ~coq_root:Check.default_root_prefix; - (* additional loadpath, given with -I -include -R options *) + (* additional loadpath, given with -R/-Q options *) List.iter (fun (unix_path, coq_root) -> add_rec_path ~unix_path ~coq_root) (List.rev !includes); @@ -299,6 +297,7 @@ let explain_exn = function | UnsatisfiedConstraints _ -> str"UnsatisfiedConstraints" | DisallowedSProp -> str"DisallowedSProp" | BadRelevance -> str"BadRelevance" + | BadInvert -> str"BadInvert" | UndeclaredUniverse _ -> str"UndeclaredUniverse")) | InductiveError e -> @@ -320,9 +319,6 @@ let explain_exn = function report ()) | e -> CErrors.print e (* for anomalies and other uncaught exceptions *) -let deprecated flag = - Feedback.msg_warning (str "Deprecated flag " ++ quote (str flag)) - let parse_args argv = let rec parse = function | [] -> () @@ -338,16 +334,8 @@ let parse_args argv = Envars.set_user_coqlib s; parse rem - | ("-I"|"-include") :: d :: "-as" :: p :: rem -> deprecated "-I"; set_include d p; parse rem - | ("-I"|"-include") :: d :: "-as" :: [] -> usage () - | ("-I"|"-include") :: d :: rem -> deprecated "-I"; set_default_include d; parse rem - | ("-I"|"-include") :: [] -> usage () - - | "-Q" :: d :: p :: rem -> set_include d p;parse rem - | "-Q" :: ([] | [_]) -> usage () - - | "-R" :: d :: p :: rem -> set_include d p;parse rem - | "-R" :: ([] | [_]) -> usage () + | ("-Q"|"-R") :: d :: p :: rem -> set_include d p;parse rem + | ("-Q"|"-R") :: ([] | [_]) -> usage () | "-debug" :: rem -> set_debug (); parse rem diff --git a/checker/values.ml b/checker/values.ml index cce0ce7203..38cb243f80 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -147,18 +147,20 @@ let rec v_constr = [|v_puniverses v_cst|]; (* Const *) [|v_puniverses v_ind|]; (* Ind *) [|v_puniverses v_cons|]; (* Construct *) - [|v_caseinfo;v_constr;v_constr;Array v_constr|]; (* Case *) + [|v_caseinfo;v_constr;v_case_invert;v_constr;Array v_constr|]; (* Case *) [|v_fix|]; (* Fix *) [|v_cofix|]; (* CoFix *) [|v_proj;v_constr|]; (* Proj *) [|v_uint63|]; (* Int *) - [|Float64|] (* Int *) + [|Float64|]; (* Float *) + [|v_instance;Array v_constr;v_constr;v_constr|] (* Array *) |]) and v_prec = Tuple ("prec_declaration", [|Array (v_binder_annot v_name); Array v_constr; Array v_constr|]) and v_fix = Tuple ("pfixpoint", [|Tuple ("fix2",[|Array Int;Int|]);v_prec|]) and v_cofix = Tuple ("pcofixpoint",[|Int;v_prec|]) +and v_case_invert = Sum ("case_inversion", 1, [|[|v_instance;Array v_constr|]|]) let v_rdecl = v_sum "rel_declaration" 0 [| [|v_binder_annot v_name; v_constr|]; (* LocalAssum *) @@ -234,7 +236,7 @@ let v_template_universes = v_tuple "template_universes" [|List(Opt v_level);v_context_set|] let v_primitive = - v_enum "primitive" 44 (* Number of "Primitive" in Int63.v and PrimFloat.v *) + v_enum "primitive" 50 (* Number of "Primitive" in Int63.v and PrimFloat.v *) let v_cst_def = v_sum "constant_def" 0 @@ -244,7 +246,7 @@ let v_typing_flags = v_tuple "typing_flags" [|v_bool; v_bool; v_bool; v_oracle; v_bool; v_bool; - v_bool; v_bool; v_bool|] + v_bool; v_bool; v_bool; v_bool|] let v_univs = v_sum "universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] @@ -258,8 +260,11 @@ let v_cb = v_tuple "constant_body" v_bool; v_typing_flags|] +let v_nested = v_sum "nested" 0 + [|[|v_ind|] (* NestedInd *);[|v_cst|] (* NestedPrimitive *)|] + let v_recarg = v_sum "recarg" 1 (* Norec *) - [|[|v_ind|] (* Mrec *);[|v_ind|] (* Imbr *)|] + [|[|v_ind|] (* Mrec *);[|v_nested|] (* Nested *)|] let rec v_wfp = Sum ("wf_paths",0, [|[|Int;Int|]; (* Rtree.Param *) @@ -316,7 +321,7 @@ let v_ind_pack = v_tuple "mutual_inductive_body" let v_prim_ind = v_enum "prim_ind" 6 (* Number of "Register ... as kernel.ind_..." in Int63.v and PrimFloat.v *) -let v_prim_type = v_enum "prim_type" 2 +let v_prim_type = v_enum "prim_type" 3 (* Number of constructors of prim_type in "kernel/cPrimitives.ml" *) let v_retro_action = diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 39ca5413cc..2735c5b5eb 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -339,6 +339,10 @@ let understand_state = function | "proof" -> "VtModifyProof", false | "proof_opt_query" -> "VtReadProofOpt", false | "proof_query" -> "VtReadProof", false + | "read_program" -> "VtReadProgram", false + | "program" -> "VtModifyProgram", false + | "declare_program" -> "VtDeclareProgram", false + | "program_interactive" -> "VtOpenProofProgram", false | s -> fatal ("unsupported state specifier: " ^ s) let print_body_state state fmt r = diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 6ceb7f54b2..cc9fd13fdc 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1401,10 +1401,6 @@ function make_coq { logn configure ./configure -with-doc no -prefix "$PREFIXCOQ" fi - # The windows resource compiler binary name is hard coded - sed -i "s/i686-w64-mingw32-windres/$TARGET_ARCH-windres/" Makefile.build - sed -i "s/i686-w64-mingw32-windres/$TARGET_ARCH-windres/" Makefile.ide || true - # 8.4x doesn't support parallel make if [[ $COQ_VERSION == 8.4* ]] ; then log1 make diff --git a/dev/ci/user-overlays/10390-SkySkimmer-uip.sh b/dev/ci/user-overlays/10390-SkySkimmer-uip.sh new file mode 100644 index 0000000000..80107ac9c5 --- /dev/null +++ b/dev/ci/user-overlays/10390-SkySkimmer-uip.sh @@ -0,0 +1,30 @@ +if [ "$CI_PULL_REQUEST" = "10390" ] || [ "$CI_BRANCH" = "uip" ]; then + + unicoq_CI_REF=uip + unicoq_CI_GITURL=https://github.com/SkySkimmer/unicoq + + mtac2_CI_REF=uip + mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 + + elpi_CI_REF=uip + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + + equations_CI_REF=uip + equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations + + paramcoq_CI_REF=uip + paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq + + relation_algebra_CI_REF=uip + relation_algebra_CI_GITURL=https://github.com/SkySkimmer/relation-algebra + + coq_dpdgraph_CI_REF=uip + coq_dpdgraph_CI_GITURL=https://github.com/SkySkimmer/coq-dpdgraph + + coqhammer_CI_REF=uip + coqhammer_CI_GITURL=https://github.com/SkySkimmer/coqhammer + + metacoq_CI_REF=uip + metacoq_CI_GITURL=https://github.com/SkySkimmer/metacoq + +fi diff --git a/dev/ci/user-overlays/11604-persistent-arrays.sh b/dev/ci/user-overlays/11604-persistent-arrays.sh new file mode 100644 index 0000000000..aec5c4fa3d --- /dev/null +++ b/dev/ci/user-overlays/11604-persistent-arrays.sh @@ -0,0 +1,18 @@ +if [ "$CI_PULL_REQUEST" = "11604" ] || [ "$CI_BRANCH" = "persistent-arrays" ]; then + + unicoq_CI_REF=persistent-arrays + unicoq_CI_GITURL=https://github.com/maximedenes/unicoq + + elpi_CI_REF=persistent-arrays + elpi_CI_GITURL=https://github.com/maximedenes/coq-elpi + + #relation_algebra_CI_REF=persistent-arrays + #relation_algebra_CI_GITURL=https://github.com/maximedenes/relation-algebra + + coqhammer_CI_REF=persistent-arrays + coqhammer_CI_GITURL=https://github.com/maximedenes/coqhammer + + metacoq_CI_REF=persistent-arrays + metacoq_CI_GITURL=https://github.com/maximedenes/metacoq + +fi diff --git a/dev/ci/user-overlays/11836-ejgallego-obligations+functional.sh b/dev/ci/user-overlays/11836-ejgallego-obligations+functional.sh new file mode 100644 index 0000000000..72ec55a37c --- /dev/null +++ b/dev/ci/user-overlays/11836-ejgallego-obligations+functional.sh @@ -0,0 +1,18 @@ +if [ "$CI_PULL_REQUEST" = "11836" ] || [ "$CI_BRANCH" = "obligations+functional" ]; then + + mtac2_CI_REF=obligations+functional + mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 + + paramcoq_CI_REF=obligations+functional + paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq + + equations_CI_REF=obligations+functional + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + metacoq_CI_REF=obligations+functional + metacoq_CI_GITURL=https://github.com/ejgallego/metacoq + + rewriter_CI_REF=obligations+functional + rewriter_CI_GITURL=https://github.com/ejgallego/rewriter + +fi diff --git a/dev/ci/user-overlays/12523-term-notation-custom.sh b/dev/ci/user-overlays/12523-term-notation-custom.sh new file mode 100644 index 0000000000..6217312a2a --- /dev/null +++ b/dev/ci/user-overlays/12523-term-notation-custom.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12523" ] || [ "$CI_BRANCH" = "fix-11121" ]; then + + equations_CI_REF=fix-11121 + equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations + +fi diff --git a/dev/doc/SProp.md b/dev/doc/SProp.md index f263dbb867..d517983046 100644 --- a/dev/doc/SProp.md +++ b/dev/doc/SProp.md @@ -39,3 +39,32 @@ Relevance can be inferred from a well-typed term using functions in term, note the difference between its relevance as a term (is `x : (_ : SProp)`) and as a type (is `x : SProp`), there are functions for both kinds. + +## Case inversion + +Inductives in SProp with 1 constructor which has no arguments have a +special reduction rule for matches. To implement it the Case +constructor is extended with a `case_invert` field. + +If you are constructing a match on a normal (non-special reduction) +inductive you must fill the new field with `NoInvert`. Otherwise you +must fill it with `CaseInvert {univs ; args}` where `univs` is the +universe instance of the type you are matching and `args` the +parameters and indices. + +For instance, in + +~~~coq +Inductive seq {A} (a:A) : A -> SProp := + srefl : seq a a. + +Definition seq_to_eq {A x y} (e:seq x y) : x = y :> A + := match e with srefl => eq_refl end. +~~~ + +the `match e with ...` has `CaseInvert {univs = Instance.empty; args = [|A x y|]}`. +(empty instance since we defined a universe monomorphic `seq`). + +In practice, you should use `Inductiveops.make_case_or_project` which +will take care of this for you (and also handles primitive records +correctly etc). diff --git a/dev/top_printers.ml b/dev/top_printers.ml index f14edec639..ea90e83a83 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -50,13 +50,8 @@ let ppqualid qid = pp(pr_qualid qid) let ppclindex cl = pp(Coercionops.pr_cl_index cl) let ppscheme k = pp (Ind_tables.pr_scheme_kind k) -let prrecarg = function - | Declarations.Norec -> str "Norec" - | Declarations.Mrec (mind,i) -> - str "Mrec[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]" - | Declarations.Imbr (mind,i) -> - str "Imbr[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]" -let ppwf_paths x = pp (Rtree.pp_tree prrecarg x) +let prrecarg = Declareops.pp_recarg +let ppwf_paths x = pp (Declareops.pp_wf_paths x) let get_current_context () = try Vernacstate.Declare.get_current_context () @@ -238,7 +233,9 @@ let ppnamedcontextval e = let ppaucontext auctx = let nas = AUContext.names auctx in let prlev l = match Level.var_index l with - | Some n -> Name.print nas.(n) + | Some n -> (match nas.(n) with + | Anonymous -> prlev l + | Name id -> Id.print id) | None -> prlev l in pp (pr_universe_context prlev (AUContext.repr auctx)) @@ -294,7 +291,7 @@ let constr_display csr = "MutConstruct(("^(MutInd.to_string sp)^","^(string_of_int i)^")," ^","^(universes_display u)^(string_of_int j)^")" | Proj (p, c) -> "Proj("^(Constant.to_string (Projection.constant p))^","^term_display c ^")" - | Case (ci,p,c,bl) -> + | Case (ci,p,iv,c,bl) -> "MutCase(<abs>,"^(term_display p)^","^(term_display c)^"," ^(array_display bl)^")" | Fix ((t,i),(lna,tl,bl)) -> @@ -314,6 +311,7 @@ let constr_display csr = "Int("^(Uint63.to_string i)^")" | Float f -> "Float("^(Float64.to_string f)^")" + | Array (u,t,def,ty) -> "Array("^(array_display t)^","^(term_display def)^","^(term_display ty)^")@{" ^universes_display u^"\n" and array_display v = "[|"^ @@ -406,7 +404,7 @@ let print_pure_constr csr = print_int i; print_string ","; print_int j; print_string ","; universes_display u; print_string ")" - | Case (ci,p,c,bl) -> + | Case (ci,p,iv,c,bl) -> open_vbox 0; print_string "<"; box_display p; print_string ">"; print_cut(); print_string "Case"; @@ -448,6 +446,16 @@ let print_pure_constr csr = print_string ("Int("^(Uint63.to_string i)^")") | Float f -> print_string ("Float("^(Float64.to_string f)^")") + | Array (u,t,def,ty) -> + print_string "Array("; + Array.iter (fun x -> box_display x; print_space()) t; + print_string "|"; + box_display def; + print_string ":"; + box_display ty; + print_string ")@{"; + universes_display u; + print_string "}" and box_display c = open_hovbox 1; term_display c; close_box() diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 73cf1b0195..aa650fbdc8 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -17,6 +17,8 @@ let ppripos (ri,pos) = print_string ("getglob "^(Constant.to_string kn)^"\n") | Reloc_proj_name p -> print_string ("proj "^(Projection.Repr.to_string p)^"\n") + | Reloc_caml_prim op -> + print_string ("caml primitive "^CPrimitives.to_string op) ); print_flush () @@ -85,6 +87,7 @@ and ppwhd whd = | Vconstr_block b -> ppvblock b | Vint64 i -> printf "int64(%LiL)" i | Vfloat64 f -> printf "float64(%.17g)" f + | Varray t -> ppvarray t | Vatom_stk(a,s) -> open_hbox();ppatom a;close_box(); print_string"@";ppstack s @@ -100,6 +103,20 @@ and ppvblock b = print_string")"; close_box() +and ppvarray t = + let length = Parray.length_int t in + open_hbox(); + print_string "[|"; + for i = 0 to length - 2 do + ppvalues (Parray.get t (Uint63.of_int i)); + print_string "; " + done; + ppvalues (Parray.get t (Uint63.of_int (length - 1))); + print_string " | "; + ppvalues (Parray.default t); + print_string " |]"; + close_box() + and ppvalues v = open_hovbox 0;ppwhd (whd_val v);close_box(); print_flush() diff --git a/doc/changelog/01-kernel/10390-uip.rst b/doc/changelog/01-kernel/10390-uip.rst new file mode 100644 index 0000000000..dab096d8db --- /dev/null +++ b/doc/changelog/01-kernel/10390-uip.rst @@ -0,0 +1,5 @@ +- **Added:** + Definitional UIP, only when :flag:`Definitional UIP` is enabled. See + documentation of the flag for details. + (`#10390 <https://github.com/coq/coq/pull/10390>`_, + by Gaëtan Gilbert). diff --git a/doc/changelog/01-kernel/11604-persistent-arrays.rst b/doc/changelog/01-kernel/11604-persistent-arrays.rst new file mode 100644 index 0000000000..fbade033d2 --- /dev/null +++ b/doc/changelog/01-kernel/11604-persistent-arrays.rst @@ -0,0 +1,6 @@ +- **Added:** + Built-in support for persistent arrays, which expose a functional + interface but are implemented using an imperative data structure, for + better performance. + (`#11604 <https://github.com/coq/coq/pull/11604>`_, + by Maxime Dénès and Benjamin Grégoire, with help from Gaëtan Gilbert). diff --git a/doc/changelog/01-kernel/12537-master+module-starting-extends-delta-resolver.rst b/doc/changelog/01-kernel/12537-master+module-starting-extends-delta-resolver.rst new file mode 100644 index 0000000000..bec121836c --- /dev/null +++ b/doc/changelog/01-kernel/12537-master+module-starting-extends-delta-resolver.rst @@ -0,0 +1,8 @@ +- **Fixed:** + A loss of definitional equality for declarations obtained through + :cmd:`Include` when entering the scope of a :cmd:`Module` or + :cmd:`Module Type` was causing :cmd:`Search` not to see the included + declarations + (`#12537 <https://github.com/coq/coq/pull/12537>`_, fixes `#12525 + <https://github.com/coq/coq/pull/12525>`_ and `#12647 + <https://github.com/coq/coq/pull/12647>`_, by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12523-term-notation-custom.rst b/doc/changelog/03-notations/12523-term-notation-custom.rst new file mode 100644 index 0000000000..1a611f3fb1 --- /dev/null +++ b/doc/changelog/03-notations/12523-term-notation-custom.rst @@ -0,0 +1,4 @@ +- **Added:** + Simultaneous definition of terms and notations now support custom entries. + Fixes `#11121 <https://github.com/coq/coq/pull/11121>`_. + (`#12523 <https://github.com/coq/coq/pull/11523>`_, by Maxime Dénès). diff --git a/doc/changelog/04-tactics/12572-fix-12571.rst b/doc/changelog/04-tactics/12572-fix-12571.rst new file mode 100644 index 0000000000..98b217e86b --- /dev/null +++ b/doc/changelog/04-tactics/12572-fix-12571.rst @@ -0,0 +1,6 @@ +- **Fixed:** + typeclasses eauto (and discriminated hint bases) now correctly + classify local variables as being unfoldable + (`#12572 <https://github.com/coq/coq/pull/12572>`_, + fixes `#12571 <https://github.com/coq/coq/issues/12571>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/05-tactic-language/12594-fix-ltac2-type-params.rst b/doc/changelog/05-tactic-language/12594-fix-ltac2-type-params.rst new file mode 100644 index 0000000000..555020d319 --- /dev/null +++ b/doc/changelog/05-tactic-language/12594-fix-ltac2-type-params.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Fix the parsing of multi-parameters Ltac2 types + (`#12594 <https://github.com/coq/coq/pull/12594>`_, + fixes `#12595 <https://github.com/coq/coq/issues/12595>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/08-tools/12613-coqchk-noi.rst b/doc/changelog/08-tools/12613-coqchk-noi.rst new file mode 100644 index 0000000000..b83c9c69a2 --- /dev/null +++ b/doc/changelog/08-tools/12613-coqchk-noi.rst @@ -0,0 +1,3 @@ +- **Removed:** The option ``-I`` of coqchk was removed (it was + deprecated in Coq 8.8) (`#12613 + <https://github.com/coq/coq/pull/12613>`_, by Gaëtan Gilbert). diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index b19239ed22..6c62ff3116 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -173,6 +173,79 @@ strict propositions. For instance: Definition eq_true_is_true b (H:true=b) : is_true b := match H in _ = x return is_true x with eq_refl => stt end. +Definitional UIP +---------------- + +.. flag:: Definitional UIP + + This flag, off by default, allows the declaration of non-squashed + inductive types with 1 constructor which takes no argument in + |SProp|. Since this includes equality types, it provides + definitional uniqueness of identity proofs. + + Because squashing is a universe restriction, unsetting + :flag:`Universe Checking` is stronger than setting + :flag:`Definitional UIP`. + +Definitional UIP involves a special reduction rule through which +reduction depends on conversion. Consider the following code: + +.. coqtop:: in + + Set Definitional UIP. + + Inductive seq {A} (a:A) : A -> SProp := + srefl : seq a a. + + Axiom e : seq 0 0. + Definition hidden_arrow := match e return Set with srefl _ => nat -> nat end. + + Check (fun (f : hidden_arrow) (x:nat) => (f : nat -> nat) x). + +By the usual reduction rules :g:`hidden_arrow` is a stuck match, but +by proof irrelevance :g:`e` is convertible to :g:`srefl 0` and then by +congruence :g:`hidden_arrow` is convertible to `nat -> nat`. + +The special reduction reduces any match on a type which uses +definitional UIP when the indices are convertible to those of the +constructor. For `seq`, this means a match on a value of type `seq x +y` reduces if and only if `x` and `y` are convertible. + +Such matches are indicated in the printed representation by inserting +a cast around the discriminee: + +.. coqtop:: out + + Print hidden_arrow. + +Non Termination with UIP +++++++++++++++++++++++++ + +The special reduction rule of UIP combined with an impredicative sort +breaks termination of reduction +:cite:`abel19:failur_normal_impred_type_theor`: + +.. coqtop:: all + + Axiom all_eq : forall (P Q:Prop), P -> Q -> seq P Q. + + Definition transport (P Q:Prop) (x:P) (y:Q) : Q + := match all_eq P Q x y with srefl _ => x end. + + Definition top : Prop := forall P : Prop, P -> P. + + Definition c : top := + fun P p => + transport + (top -> top) + P + (fun x : top => x (top -> top) (fun x => x) x) + p. + + Fail Timeout 1 Eval lazy in c (top -> top) (fun x => x) c. + +The term :g:`c (top -> top) (fun x => x) c` infinitely reduces to itself. + Issues with non-cumulativity ---------------------------- diff --git a/doc/sphinx/biblio.bib b/doc/sphinx/biblio.bib index 3d73f9bd6e..323da93f3e 100644 --- a/doc/sphinx/biblio.bib +++ b/doc/sphinx/biblio.bib @@ -608,3 +608,47 @@ the Calculus of Inductive Constructions}}, publisher = {ACM}, address = {New York, NY, USA}, } + +@techreport{abel19:failur_normal_impred_type_theor, + author = {Andreas Abel AND Thierry Coquand}, + title = {{Failure of Normalization in Impredicative Type + Theory with Proof-Irrelevant Propositional + Equality}}, + year = 2019, + institution = {Chalmers and Gothenburg University}, +} + +@inproceedings{ConchonFilliatre07wml, + author = {Sylvain Conchon and Jean-Christophe Filliâtre}, + title = {A Persistent Union-Find Data Structure}, + booktitle = {ACM SIGPLAN Workshop on ML}, + publisher = {ACM Press}, + pages = {37--45}, + year = 2007, + address = {Freiburg, Germany}, + month = {October}, + topics = {team, lri}, + type_publi = {icolcomlec}, + type_digiteo = {conf_isbn}, + x-pdf = {https://www.lri.fr/~filliatr/ftp/publis/puf-wml07.pdf}, + url = {https://www.lri.fr/~filliatr/ftp/publis/puf-wml07.pdf}, + abstract = { The problem of disjoint sets, also known as union-find, + consists in maintaining a partition of a finite set within a data + structure. This structure provides two operations: a function find + returning the class of an element and a function union merging two + classes. An optimal and imperative solution is known since 1975. + However, the imperative nature of this data structure may be a + drawback when it is used in a backtracking algorithm. This paper + details the implementation of a persistent union-find data structure + as efficient as its imperative counterpart. To achieve this result, + our solution makes heavy use of imperative features and thus it is a + significant example of a data structure whose side effects are + safely hidden behind a persistent interface. To strengthen this + last claim, we also detail a formalization using the Coq proof + assistant which shows both the correctness of our solution and its + observational persistence. }, + x-equipes = {demons PROVAL}, + x-type = {article}, + x-support = {actes_aux}, + x-cle-support = {ML} +} diff --git a/doc/sphinx/language/core/primitive.rst b/doc/sphinx/language/core/primitive.rst index dc8f131209..727177b23a 100644 --- a/doc/sphinx/language/core/primitive.rst +++ b/doc/sphinx/language/core/primitive.rst @@ -40,9 +40,8 @@ These primitive declarations are regular axioms. As such, they must be trusted a Print Assumptions one_minus_one_is_zero. -The reduction machines (:tacn:`vm_compute`, :tacn:`native_compute`) implement -dedicated, efficient, rules to reduce the applications of these primitive -operations. +The reduction machines implement dedicated, efficient rules to reduce the +applications of these primitive operations. The extraction of these primitives can be customized similarly to the extraction of regular axioms (see :ref:`extraction`). Nonetheless, the :g:`ExtrOCamlInt63` @@ -105,3 +104,53 @@ Literal values (of type :g:`Float64.t`) are extracted to literal OCaml values (of type :g:`float`) written in hexadecimal notation and wrapped into the :g:`Float64.of_float` constructor, e.g.: :g:`Float64.of_float (0x1p+0)`. + +.. _primitive-arrays: + +Primitive Arrays +---------------- + +The language of terms features persistent arrays as values. The type of +such a value is *axiomatized*; it is declared through the following sentence +(excerpt from the :g:`PArray` module): + +.. coqdoc:: + + Primitive array := #array_type. + +This type is equipped with a few operators, that must be similarly declared. +For instance, elements in an array can be accessed and updated using the +:g:`PArray.get` and :g:`PArray.set` functions, declared and specified as +follows: + +.. coqdoc:: + + Primitive get := #array_get. + Primitive set := #array_set. + Notation "t .[ i ]" := (get t i). + Notation "t .[ i <- a ]" := (set t i a). + + Axiom get_set_same : forall A t i (a:A), (i < length t) = true -> t.[i<-a].[i] = a. + Axiom get_set_other : forall A t i j (a:A), i <> j -> t.[i<-a].[j] = t.[j]. + +The complete set of such operators can be obtained looking at the :g:`PArray` module. + +These primitive declarations are regular axioms. As such, they must be trusted and are listed by the +:g:`Print Assumptions` command. + +The reduction machines (:tacn:`vm_compute`, :tacn:`native_compute`) implement +dedicated, efficient rules to reduce the applications of these primitive +operations. + +The extraction of these primitives can be customized similarly to the extraction +of regular axioms (see :ref:`extraction`). Nonetheless, the :g:`ExtrOCamlPArray` +module can be used when extracting to OCaml: it maps the Coq primitives to types +and functions of a :g:`Parray` module. Said OCaml module is not produced by +extraction. Instead, it has to be provided by the user (if they want to compile +or execute the extracted code). For instance, an implementation of this module +can be taken from the kernel of Coq (see ``kernel/parray.ml``). + +Primitive arrays expose a functional interface, but they are internally +implemented using a persistent data structure :cite:`ConchonFilliatre07wml`. +Update and access to an element in the most recent copy of an array are +constant time operations. diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 3c92206fd2..fcd5ecc070 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -368,13 +368,14 @@ a :token:`decl_notations` clause after the definition of the (co)inductive type (co)recursive term (or after the definition of each of them in case of mutual definitions). The exact syntax is given by :n:`@decl_notation` for inductive, co-inductive, recursive and corecursive definitions and in :ref:`record-types` -for records. +for records. Note that only syntax modifiers that do not require to add or +change a parsing rule are accepted. .. insertprodn decl_notations decl_notation .. prodn:: decl_notations ::= where @decl_notation {* and @decl_notation } - decl_notation ::= @string := @one_term {? ( only parsing ) } {? : @scope_name } + decl_notation ::= @string := @one_term {? ( {+, @syntax_modifier } ) } {? : @scope_name } Here are examples: diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index 4badb20295..f39c50238a 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -15,6 +15,7 @@ theories/extraction/ExtrOcamlBigIntConv.v theories/extraction/ExtrOcamlChar.v theories/extraction/ExtrOCamlInt63.v theories/extraction/ExtrOCamlFloats.v +theories/extraction/ExtrOCamlPArray.v theories/extraction/ExtrOcamlIntConv.v theories/extraction/ExtrOcamlNatBigInt.v theories/extraction/ExtrOcamlNatInt.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index ab615d5f65..7c1328916b 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -709,4 +709,11 @@ through the <tt>Require Import</tt> command.</p> theories/Compat/Coq812.v theories/Compat/Coq813.v </dd> + + <dt> <b>Array</b>: + Persistent native arrays + </dt> + <dd> + theories/Array/PArray.v + </dd> </dl> diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 42c9359ff0..334c23c963 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -69,7 +69,7 @@ let mkInd i = of_kind (Ind (in_punivs i)) let mkConstructU pc = of_kind (Construct pc) let mkConstruct c = of_kind (Construct (in_punivs c)) let mkConstructUi ((ind,u),i) = of_kind (Construct ((ind,i),u)) -let mkCase (ci, c, r, p) = of_kind (Case (ci, c, r, p)) +let mkCase (ci, c, iv, r, p) = of_kind (Case (ci, c, iv, r, p)) let mkFix f = of_kind (Fix f) let mkCoFix f = of_kind (CoFix f) let mkProj (p, c) = of_kind (Proj (p, c)) @@ -77,6 +77,7 @@ let mkArrow t1 r t2 = of_kind (Prod (make_annot Anonymous r, t1, t2)) let mkArrowR t1 t2 = mkArrow t1 Sorts.Relevant t2 let mkInt i = of_kind (Int i) let mkFloat f = of_kind (Float f) +let mkArray (u,t,def,ty) = of_kind (Array (u,t,def,ty)) let mkRef (gr,u) = let open GlobRef in match gr with | ConstRef c -> mkConstU (c,u) @@ -194,7 +195,7 @@ let destCoFix sigma c = match kind sigma c with | _ -> raise DestKO let destCase sigma c = match kind sigma c with -| Case (ci, t, c, p) -> (ci, t, c, p) +| Case (ci, t, iv, c, p) -> (ci, t, iv, c, p) | _ -> raise DestKO let destProj sigma c = match kind sigma c with @@ -356,7 +357,7 @@ let iter_with_full_binders sigma g f n c = | LetIn (na,b,t,c) -> f n b; f n t; f (g (LocalDef (na, b, t)) n) c | App (c,l) -> f n c; Array.Fun1.iter f n l | Evar (_,l) -> List.iter (fun c -> f n c) l - | Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl + | Case (_,p,iv,c,bl) -> f n p; iter_invert (f n) iv; f n c; Array.Fun1.iter f n bl | Proj (p,c) -> f n c | Fix (_,(lna,tl,bl)) -> Array.iter (f n) tl; @@ -366,6 +367,7 @@ let iter_with_full_binders sigma g f n c = Array.iter (f n) tl; let n' = Array.fold_left2_i (fun i n na t -> g (LocalAssum (na,lift i t)) n) n lna tl in Array.iter (f n') bl + | Array (_u,t,def,ty) -> Array.Fun1.iter f n t; f n def; f n ty let iter_with_binders sigma g f n c = let f l c = f l (of_constr c) in @@ -380,7 +382,7 @@ let compare_gen k eq_inst eq_sort eq_constr nargs c1 c2 = let eq_constr sigma c1 c2 = let kind c = kind sigma c in - let eq_inst _ _ i1 i2 = EInstance.equal sigma i1 i2 in + let eq_inst _ i1 i2 = EInstance.equal sigma i1 i2 in let eq_sorts s1 s2 = ESorts.equal sigma s1 s2 in let rec eq_constr nargs c1 c2 = compare_gen kind eq_inst eq_sorts eq_constr nargs c1 c2 @@ -390,13 +392,13 @@ let eq_constr sigma c1 c2 = let eq_constr_nounivs sigma c1 c2 = let kind c = kind sigma c in let rec eq_constr nargs c1 c2 = - compare_gen kind (fun _ _ _ _ -> true) (fun _ _ -> true) eq_constr nargs c1 c2 + compare_gen kind (fun _ _ _ -> true) (fun _ _ -> true) eq_constr nargs c1 c2 in eq_constr 0 c1 c2 let compare_constr sigma cmp c1 c2 = let kind c = kind sigma c in - let eq_inst _ _ i1 i2 = EInstance.equal sigma i1 i2 in + let eq_inst _ i1 i2 = EInstance.equal sigma i1 i2 in let eq_sorts s1 s2 = ESorts.equal sigma s1 s2 in let cmp nargs c1 c2 = cmp c1 c2 in compare_gen kind eq_inst eq_sorts cmp 0 c1 c2 @@ -442,22 +444,22 @@ let cmp_constructors (mind, ind, cns as spec) nargs u1 u2 cstrs = Array.fold_left2 (fun cstrs u1 u2 -> UnivProblem.(Set.add (UWeak (u1,u2)) cstrs)) cstrs (Univ.Instance.to_array u1) (Univ.Instance.to_array u2) -let eq_universes env sigma cstrs cv_pb ref nargs l l' = +let eq_universes env sigma cstrs cv_pb refargs l l' = if EInstance.is_empty l then (assert (EInstance.is_empty l'); true) else let l = EInstance.kind sigma l and l' = EInstance.kind sigma l' in let open GlobRef in let open UnivProblem in - match ref with - | VarRef _ -> assert false (* variables don't have instances *) - | ConstRef _ -> + match refargs with + | None | Some (ConstRef _, _) -> cstrs := enforce_eq_instances_univs true l l' !cstrs; true - | IndRef ind -> + | Some (VarRef _, _) -> assert false (* variables don't have instances *) + | Some (IndRef ind, nargs) -> let mind = Environ.lookup_mind (fst ind) env in cstrs := cmp_inductives cv_pb (mind,snd ind) nargs l l' !cstrs; true - | ConstructRef ((mi,ind),ctor) -> + | Some (ConstructRef ((mi,ind),ctor), nargs) -> let mind = Environ.lookup_mind mi env in cstrs := cmp_constructors (mind,ind,ctor) nargs l l' !cstrs; true @@ -469,8 +471,8 @@ let test_constr_universes env sigma leq m n = else let cstrs = ref Set.empty in let cv_pb = if leq then Reduction.CUMUL else Reduction.CONV in - let eq_universes ref nargs l l' = eq_universes env sigma cstrs Reduction.CONV ref nargs l l' - and leq_universes ref nargs l l' = eq_universes env sigma cstrs cv_pb ref nargs l l' in + let eq_universes refargs l l' = eq_universes env sigma cstrs Reduction.CONV refargs l l' + and leq_universes refargs l l' = eq_universes env sigma cstrs cv_pb refargs l l' in let eq_sorts s1 s2 = let s1 = ESorts.kind sigma s1 in let s2 = ESorts.kind sigma s2 in @@ -546,18 +548,21 @@ let universes_of_constr sigma c = let rec aux s c = match kind sigma c with | Const (c, u) -> - LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s + LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s | Ind ((mind,_), u) | Construct (((mind,_),_), u) -> - LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s + LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s | Sort u -> - let sort = ESorts.kind sigma u in - if Sorts.is_small sort then s - else - let u = Sorts.univ_of_sort sort in - LSet.fold LSet.add (Universe.levels u) s + let sort = ESorts.kind sigma u in + if Sorts.is_small sort then s + else + let u = Sorts.univ_of_sort sort in + LSet.fold LSet.add (Universe.levels u) s | Evar (k, args) -> - let concl = Evd.evar_concl (Evd.find sigma k) in - fold sigma aux (aux s concl) c + let concl = Evd.evar_concl (Evd.find sigma k) in + fold sigma aux (aux s concl) c + | Array (u,_,_,_) -> + let s = LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s in + fold sigma aux s c | _ -> fold sigma aux s c in aux LSet.empty c @@ -762,7 +767,7 @@ let kind_of_type sigma t = match kind sigma t with | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Proj _ | Case _ | Fix _ | CoFix _ | Ind _) -> AtomicType (t,[||]) - | (Lambda _ | Construct _ | Int _ | Float _) -> failwith "Not a type" + | (Lambda _ | Construct _ | Int _ | Float _ | Array _) -> failwith "Not a type" module Unsafe = struct @@ -777,5 +782,7 @@ let to_named_context = = fun Refl x -> x in gen unsafe_eq +let to_case_invert = unsafe_to_case_invert + let eq = unsafe_eq end diff --git a/engine/eConstr.mli b/engine/eConstr.mli index aea441b90b..d0f675319d 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -128,13 +128,14 @@ val mkIndU : inductive * EInstance.t -> t val mkConstruct : constructor -> t val mkConstructU : constructor * EInstance.t -> t val mkConstructUi : (inductive * EInstance.t) * int -> t -val mkCase : case_info * t * t * t array -> t +val mkCase : case_info * t * (t,EInstance.t) case_invert * t * t array -> t val mkFix : (t, t) pfixpoint -> t val mkCoFix : (t, t) pcofixpoint -> t val mkArrow : t -> Sorts.relevance -> t -> t val mkArrowR : t -> t -> t val mkInt : Uint63.t -> t val mkFloat : Float64.t -> t +val mkArray : EInstance.t * t array * t * t -> t val mkRef : GlobRef.t * EInstance.t -> t @@ -198,7 +199,7 @@ val destConst : Evd.evar_map -> t -> Constant.t * EInstance.t val destEvar : Evd.evar_map -> t -> t pexistential val destInd : Evd.evar_map -> t -> inductive * EInstance.t val destConstruct : Evd.evar_map -> t -> constructor * EInstance.t -val destCase : Evd.evar_map -> t -> case_info * t * t * t array +val destCase : Evd.evar_map -> t -> case_info * t * (t,EInstance.t) case_invert * t * t array val destProj : Evd.evar_map -> t -> Projection.t * t val destFix : Evd.evar_map -> t -> (t, t) pfixpoint val destCoFix : Evd.evar_map -> t -> (t, t) pcofixpoint @@ -341,6 +342,8 @@ val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (t, typ val to_rel_decl : Evd.evar_map -> (t, types) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt +val of_case_invert : (Constr.t,Univ.Instance.t) case_invert -> (t,EInstance.t) case_invert + (** {5 Unsafe operations} *) module Unsafe : @@ -365,6 +368,8 @@ sig val to_instance : EInstance.t -> Univ.Instance.t (** Physical identity. Does not care for normalization. *) + val to_case_invert : (t,EInstance.t) case_invert -> (Constr.t,Univ.Instance.t) case_invert + val eq : (t, Constr.t) eq (** Use for transparent cast between types. *) end diff --git a/engine/evarutil.ml b/engine/evarutil.ml index eea7e38f87..b4b2032dd2 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -127,10 +127,11 @@ let is_ground_env evd env = (* Memoization is safe since evar_map and environ are applicative structures *) let memo f = - let m = ref None in - fun x y -> match !m with - | Some (x', y', r) when x == x' && y == y' -> r - | _ -> let r = f x y in m := Some (x, y, r); r + let module E = Ephemeron.K2 in + let m = E.create () in + fun x y -> match E.get_key1 m, E.get_key2 m with + | Some x', Some y' when x == x' && y == y' -> Option.get (E.get_data m) + | _ -> let r = f x y in E.set_key1 m x; E.set_key2 m y; E.set_data m r; r let is_ground_env = memo is_ground_env @@ -143,7 +144,7 @@ let head_evar sigma c = let c = EConstr.Unsafe.to_constr c in let rec hrec c = match kind c with | Evar (evk,_) -> evk - | Case (_,_,c,_) -> hrec c + | Case (_,_,_,c,_) -> hrec c | App (c,_) -> hrec c | Cast (c,_,_) -> hrec c | Proj (p, c) -> hrec c @@ -408,15 +409,8 @@ let push_rel_context_to_named_context ?hypnaming env sigma typ = let default_source = Loc.tag @@ Evar_kinds.InternalHole -let new_pure_evar_full evd ?typeclass_candidate evi = - let (evd, evk) = Evd.new_evar evd ?typeclass_candidate evi in - let evd = Evd.declare_future_goal evk evd in - (evd, evk) - -let new_pure_evar?(src=default_source) ?(filter = Filter.identity) ?(abstract_arguments = Abstraction.identity) - ?candidates ?naming ?typeclass_candidate ?(principal=false) sign evd typ = - let default_naming = IntroAnonymous in - let naming = Option.default default_naming naming in +let new_pure_evar ?(src=default_source) ?(filter = Filter.identity) ?(abstract_arguments = Abstraction.identity) + ?candidates ?(naming = IntroAnonymous) ?typeclass_candidate ?(principal=false) sign evd typ = let name = match naming with | IntroAnonymous -> None | IntroIdentifier id -> Some id @@ -442,22 +436,6 @@ let new_pure_evar?(src=default_source) ?(filter = Filter.identity) ?(abstract_ar in (evd, newevk) -let new_evar_instance ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_candidate - ?principal sign evd typ instance = - let open EConstr in - assert (not !Flags.debug || - List.distinct (ids_of_named_context (named_context_of_val sign))); - let (evd, newevk) = new_pure_evar sign evd ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_candidate ?principal typ in - evd, mkEvar (newevk, instance) - -let new_evar_from_context ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal sign evd typ = - let instance = List.map (NamedDecl.get_id %> EConstr.mkVar) (named_context_of_val sign) in - let instance = - match filter with - | None -> instance - | Some filter -> Filter.filter_list filter instance in - new_evar_instance sign evd typ ?src ?filter ?candidates ?naming ?principal instance - (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) let new_evar ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_candidate @@ -469,8 +447,9 @@ let new_evar ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_can match filter with | None -> instance | Some filter -> Filter.filter_list filter instance in - new_evar_instance sign evd typ' ?src ?filter ?abstract_arguments ?candidates ?naming - ?typeclass_candidate ?principal instance + let (evd, evk) = new_pure_evar sign evd typ' ?src ?filter ?abstract_arguments ?candidates ?naming + ?typeclass_candidate ?principal in + (evd, EConstr.mkEvar (evk, instance)) let new_type_evar ?src ?filter ?naming ?principal ?hypnaming env evd rigid = let (evd', s) = new_sort_variable rigid evd in diff --git a/engine/evarutil.mli b/engine/evarutil.mli index b3c94e6b3b..41b58d38b0 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -25,14 +25,6 @@ val mk_new_meta : unit -> constr (** {6 Creating a fresh evar given their type and context} *) -val new_evar_from_context : - ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> - ?candidates:constr list -> - ?naming:intro_pattern_naming_expr -> - ?typeclass_candidate:bool -> - ?principal:bool -> - named_context_val -> evar_map -> types -> evar_map * EConstr.t - type naming_mode = | KeepUserNameAndRenameExistingButSectionNames | KeepUserNameAndRenameExistingEvenSectionNames @@ -56,8 +48,6 @@ val new_pure_evar : ?principal:bool -> named_context_val -> evar_map -> types -> evar_map * Evar.t -val new_pure_evar_full : evar_map -> ?typeclass_candidate:bool -> evar_info -> evar_map * Evar.t - (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : @@ -73,21 +63,6 @@ val new_Type : ?rigid:rigid -> evar_map -> evar_map * constr val new_global : evar_map -> GlobRef.t -> evar_map * constr -(** Create a fresh evar in a context different from its definition context: - [new_evar_instance sign evd ty inst] creates a new evar of context - [sign] and type [ty], [inst] is a mapping of the evar context to - the context where the evar should occur. This means that the terms - of [inst] are typed in the occurrence context and their type (seen - as a telescope) is [sign] *) -val new_evar_instance : - ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> - ?abstract_arguments:Abstraction.t -> ?candidates:constr list -> - ?naming:intro_pattern_naming_expr -> - ?typeclass_candidate:bool -> - ?principal:bool -> - named_context_val -> evar_map -> types -> - constr list -> evar_map * constr - val make_pure_subst : evar_info -> 'a list -> (Id.t * 'a) list val safe_evar_value : evar_map -> Constr.existential -> Constr.constr option diff --git a/engine/evd.ml b/engine/evd.ml index f0ee8ae68f..c570f75c6b 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -1398,6 +1398,9 @@ module MiniEConstr = struct let unsafe_to_rel_decl d = d let to_rel_decl sigma d = Context.Rel.Declaration.map_constr (to_constr sigma) d + let unsafe_to_case_invert x = x + let of_case_invert x = x + end (** The following functions return the set of evars immediately diff --git a/engine/evd.mli b/engine/evd.mli index d9b7bd76e7..679173ca72 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -732,6 +732,8 @@ module MiniEConstr : sig (Constr.t, Constr.types) Context.Named.Declaration.pt val unsafe_to_rel_decl : (t, t) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt + val of_case_invert : (constr,Univ.Instance.t) case_invert -> (econstr,EInstance.t) case_invert + val unsafe_to_case_invert : (econstr,EInstance.t) case_invert -> (constr,Univ.Instance.t) case_invert val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (t, t) Context.Rel.Declaration.pt val to_rel_decl : evar_map -> (t, t) Context.Rel.Declaration.pt -> diff --git a/engine/namegen.ml b/engine/namegen.ml index c4472050f8..fb9f6db0ea 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -118,7 +118,7 @@ let head_name sigma c = (* Find the head constant of a constr if any *) Some (Nametab.basename_of_global (global_of_constr c)) | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) -> Some (match lna.(i).binder_name with Name id -> id | _ -> assert false) - | Sort _ | Rel _ | Meta _|Evar _|Case (_, _, _, _) | Int _ | Float _ -> None + | Sort _ | Rel _ | Meta _|Evar _|Case _ | Int _ | Float _ | Array _ -> None in hdrec c @@ -163,9 +163,10 @@ let hdchar env sigma c = let id = match lna.(i).binder_name with Name id -> id | _ -> assert false in lowercase_first_char id | Evar _ (* We could do better... *) - | Meta _ | Case (_, _, _, _) -> "y" + | Meta _ | Case _ -> "y" | Int _ -> "i" | Float _ -> "f" + | Array _ -> "a" in hdrec 0 c diff --git a/engine/termops.ml b/engine/termops.ml index c51e753d46..e5231ef9cd 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -639,13 +639,14 @@ let map_constr_with_binders_left_to_right sigma g f l c = let al' = List.map_left (f l) al in if List.for_all2 (==) al' al then c else mkEvar (e, al') - | Case (ci,p,b,bl) -> + | Case (ci,p,iv,b,bl) -> (* In v8 concrete syntax, predicate is after the term to match! *) let b' = f l b in + let iv' = map_invert (f l) iv in let p' = f l p in let bl' = Array.map_left (f l) bl in - if b' == b && p' == p && bl' == bl then c - else mkCase (ci, p', b', bl') + if b' == b && p' == p && iv' == iv && bl' == bl then c + else mkCase (ci, p', iv', b', bl') | Fix (ln,(lna,tl,bl as fx)) -> let l' = fold_rec_types g fx l in let (tl', bl') = map_left2 (f l) tl (f l') bl in @@ -658,6 +659,12 @@ let map_constr_with_binders_left_to_right sigma g f l c = if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then c else mkCoFix (ln,(lna,tl',bl')) + | Array(u,t,def,ty) -> + let t' = Array.map_left (f l) t in + let def' = f l def in + let ty' = f l ty in + if def' == def && t' == t && ty' == ty then c + else mkArray(u,t',def',ty') let map_under_context_with_full_binders sigma g f l n d = let open EConstr in @@ -709,18 +716,20 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = | Evar (e,al) -> let al' = List.map (f l) al in if List.for_all2 (==) al al' then cstr else mkEvar (e, al') - | Case (ci,p,c,bl) when userview -> + | Case (ci,p,iv,c,bl) when userview -> let p' = map_return_predicate_with_full_binders sigma g f l ci p in + let iv' = map_invert (f l) iv in let c' = f l c in let bl' = map_branches_with_full_binders sigma g f l ci bl in - if p==p' && c==c' && bl'==bl then cstr else - mkCase (ci, p', c', bl') - | Case (ci,p,c,bl) -> + if p==p' && iv'==iv && c==c' && bl'==bl then cstr else + mkCase (ci, p', iv', c', bl') + | Case (ci,p,iv,c,bl) -> let p' = f l p in + let iv' = map_invert (f l) iv in let c' = f l c in let bl' = Array.map (f l) bl in - if p==p' && c==c' && Array.for_all2 (==) bl bl' then cstr else - mkCase (ci, p', c', bl') + if p==p' && iv'==iv && c==c' && Array.for_all2 (==) bl bl' then cstr else + mkCase (ci, p', iv', c', bl') | Fix (ln,(lna,tl,bl as fx)) -> let tl' = Array.map (f l) tl in let l' = fold_rec_types g fx l in @@ -735,6 +744,11 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then cstr else mkCoFix (ln,(lna,tl',bl')) + | Array(u,t,def,ty) -> + let t' = Array.Smart.map (f l) t in + let def' = f l def in + let ty' = f l ty in + if def==def' && t == t' && ty==ty' then cstr else mkArray (u,t', def',ty') let map_constr_with_full_binders sigma g f = map_constr_with_full_binders_gen false sigma g f diff --git a/engine/univProblem.ml b/engine/univProblem.ml index 08ff9efa5b..8d6689933c 100644 --- a/engine/univProblem.ml +++ b/engine/univProblem.ml @@ -150,7 +150,7 @@ let eq_constr_univs_infer_with kind1 kind2 univs fold m n accu = [kind1,kind2], because [kind1] and [kind2] may be different, typically evaluating [m] and [n] in different evar maps. *) let cstrs = ref accu in - let eq_universes _ _ = UGraph.check_eq_instances univs in + let eq_universes _ = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else diff --git a/engine/univSubst.ml b/engine/univSubst.ml index 92211d5f3d..335c2e5e68 100644 --- a/engine/univSubst.ml +++ b/engine/univSubst.ml @@ -146,7 +146,18 @@ let nf_evars_and_universes_opt_subst f subst = if pu' == pu then c else mkConstructU pu' | Sort (Type u) -> let u' = Univ.subst_univs_universe subst u in - if u' == u then c else mkSort (sort_of_univ u') + if u' == u then c else mkSort (sort_of_univ u') + | Case (ci,p,CaseInvert {univs;args},t,br) -> + let univs' = Instance.subst_fn lsubst univs in + if univs' == univs then Constr.map aux c + else Constr.map aux (mkCase (ci,p,CaseInvert {univs=univs';args},t,br)) + | Array (u,elems,def,ty) -> + let u' = Univ.Instance.subst_fn lsubst u in + let elems' = CArray.Smart.map aux elems in + let def' = aux def in + let ty' = aux ty in + if u == u' && elems == elems' && def == def' && ty == ty' then c + else mkArray (u',elems',def',ty') | _ -> Constr.map aux c in aux diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 21f682ac0e..c98e05370e 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -29,10 +29,10 @@ type notation_entry_level = InConstrEntrySomeLevel | InCustomEntryLevel of strin type notation_key = string (* A notation associated to a given parsing rule *) -type notation = notation_entry_level * notation_key +type notation = notation_entry * notation_key (* A notation associated to a given interpretation *) -type specific_notation = notation_with_optional_scope * notation +type specific_notation = notation_with_optional_scope * (notation_entry * notation_key) type 'a or_by_notation_r = | AN of 'a @@ -115,6 +115,7 @@ and constr_expr_r = | CGeneralization of Glob_term.binding_kind * abstraction_kind option * constr_expr | CPrim of prim_token | CDelimiters of string * constr_expr + | CArray of instance_expr option * constr_expr array * constr_expr * constr_expr and constr_expr = constr_expr_r CAst.t and case_expr = constr_expr (* expression that is being matched *) diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 3d99e1d227..ce8e7d3c2c 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -174,10 +174,14 @@ let rec constr_expr_eq e1 e2 = | CDelimiters(s1,e1), CDelimiters(s2,e2) -> String.equal s1 s2 && constr_expr_eq e1 e2 + | CArray(u1,t1,def1,ty1), CArray(u2,t2,def2,ty2) -> + Array.equal constr_expr_eq t1 t2 && + constr_expr_eq def1 def2 && constr_expr_eq ty1 ty2 && + eq_universes u1 u2 | (CRef _ | CFix _ | CCoFix _ | CProdN _ | CLambdaN _ | CLetIn _ | CAppExpl _ | CApp _ | CRecord _ | CCases _ | CLetTuple _ | CIf _ | CHole _ | CPatVar _ | CEvar _ | CSort _ | CCast _ | CNotation _ | CPrim _ - | CGeneralization _ | CDelimiters _ ), _ -> false + | CGeneralization _ | CDelimiters _ | CArray _), _ -> false and args_eq (a1,e1) (a2,e2) = Option.equal (eq_ast explicitation_eq) e1 e2 && @@ -353,6 +357,7 @@ let fold_constr_expr_with_binders g f n acc = CAst.with_val (function (fold_local_binders g f n acc t lb) c lb) l acc | CCoFix (_,_) -> Feedback.msg_warning (strbrk "Capture check in multiple binders not done"); acc + | CArray (_u,t,def,ty) -> f n (f n (Array.fold_left (f n) acc t) def) ty ) let free_vars_of_constr_expr c = @@ -439,6 +444,8 @@ let map_constr_expr_with_binders g f e = CAst.map (function let e'' = List.fold_left (fun e ({ CAst.v = id },_,_,_) -> g id e) e' dl in let d' = f e'' d in (id,bl',t',d')) dl) + | CArray (u, t, def, ty) -> + CArray (u, Array.map (f e) t, f e def, f e ty) ) (* Used in constrintern *) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 63079993c8..95df626d4c 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -359,14 +359,14 @@ let make_notation_gen loc ntn mknot mkprim destprim l bl = (* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *) | "- _", [Some (Numeral p)] when not (NumTok.Signed.is_zero p) -> assert (bl=[]); - mknot (loc,ntn,([mknot (loc,(InConstrEntrySomeLevel,"( _ )"),l,[])]),[]) + mknot (loc,ntn,([mknot (loc,(InConstrEntry,"( _ )"),l,[])]),[]) | _ -> match decompose_notation_key ntn, l with - | (InConstrEntrySomeLevel,[Terminal "-"; Terminal x]), [] -> + | (InConstrEntry,[Terminal "-"; Terminal x]), [] -> begin match NumTok.Unsigned.parse_string x with | Some n -> mkprim (loc, Numeral (NumTok.SMinus,n)) | None -> mknot (loc,ntn,l,bl) end - | (InConstrEntrySomeLevel,[Terminal x]), [] -> + | (InConstrEntry,[Terminal x]), [] -> begin match NumTok.Unsigned.parse_string x with | Some n -> mkprim (loc, Numeral (NumTok.SPlus,n)) | None -> mknot (loc,ntn,l,bl) end @@ -486,7 +486,13 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(no_implicit,nb_to_drop function | NotationRule (_,ntn as specific_ntn) -> begin - match availability_of_entry_coercion custom (fst ntn) with + let notation_entry_level = match (fst ntn) with + | InConstrEntry -> InConstrEntrySomeLevel + | InCustomEntry s -> + let (_,level,_) = Notation.level_of_notation ntn in + InCustomEntryLevel (s, level) + in + match availability_of_entry_coercion custom notation_entry_level with | None -> raise No_match | Some coercion -> match availability_of_notation specific_ntn (tmp_scope,scopes) with @@ -1089,6 +1095,9 @@ let rec extern inctx ?impargs scopes vars r = | GFloat f -> extern_float f (snd scopes) + | GArray(u,t,def,ty) -> + CArray(u,Array.map (extern inctx scopes vars) t, extern inctx scopes vars def, extern_typ scopes vars ty) + in insert_entry_coercion coercion (CAst.make ?loc c) and extern_typ ?impargs (subentry,(_,scopes)) = @@ -1260,7 +1269,13 @@ and extern_notation (custom,scopes as allscopes) vars t rules = (* Try availability of interpretation ... *) match keyrule with | NotationRule (_,ntn as specific_ntn) -> - (match availability_of_entry_coercion custom (fst ntn) with + let notation_entry_level = match (fst ntn) with + | InConstrEntry -> InConstrEntrySomeLevel + | InCustomEntry s -> + let (_,level,_) = Notation.level_of_notation ntn in + InCustomEntryLevel (s, level) + in + (match availability_of_entry_coercion custom notation_entry_level with | None -> raise No_match | Some coercion -> match availability_of_notation specific_ntn scopes with @@ -1457,6 +1472,9 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with | PSort Sorts.InType -> GSort (UAnonymous {rigid=true}) | PInt i -> GInt i | PFloat f -> GFloat f + | PArray(t,def,ty) -> + let glob_of = glob_of_pat avoid env sigma in + GArray (None, Array.map glob_of t, glob_of def, glob_of ty) let extern_constr_pattern env sigma pat = extern true (InConstrEntrySomeLevel,(None,[])) Id.Set.empty (glob_of_pat Id.Set.empty env sigma pat) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index ee041ed088..987aa63392 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -224,35 +224,35 @@ let expand_notation_string ntn n = (* Remark: expansion of squash at definition is done in metasyntax.ml *) let contract_curly_brackets ntn (l,ll,bl,bll) = match ntn with - | InCustomEntryLevel _,_ -> ntn,(l,ll,bl,bll) - | InConstrEntrySomeLevel, ntn -> + | InCustomEntry _,_ -> ntn,(l,ll,bl,bll) + | InConstrEntry, ntn -> let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] - | { CAst.v = CNotation (None,(InConstrEntrySomeLevel,"{ _ }"),([a],[],[],[])) } :: l -> + | { CAst.v = CNotation (None,(InConstrEntry,"{ _ }"),([a],[],[],[])) } :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> a::contract_squash (n+1) l in let l = contract_squash 0 l in (* side effect; don't inline *) - (InConstrEntrySomeLevel,!ntn'),(l,ll,bl,bll) + (InConstrEntry,!ntn'),(l,ll,bl,bll) let contract_curly_brackets_pat ntn (l,ll) = match ntn with - | InCustomEntryLevel _,_ -> ntn,(l,ll) - | InConstrEntrySomeLevel, ntn -> + | InCustomEntry _,_ -> ntn,(l,ll) + | InConstrEntry, ntn -> let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] - | { CAst.v = CPatNotation (None,(InConstrEntrySomeLevel,"{ _ }"),([a],[]),[]) } :: l -> + | { CAst.v = CPatNotation (None,(InConstrEntry,"{ _ }"),([a],[]),[]) } :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> a::contract_squash (n+1) l in let l = contract_squash 0 l in (* side effect; don't inline *) - (InConstrEntrySomeLevel,!ntn'),(l,ll) + (InConstrEntry,!ntn'),(l,ll) type intern_env = { ids: Names.Id.Set.t; @@ -772,7 +772,7 @@ let rec adjust_env env = function | NCast (c,_) -> adjust_env env c | NApp _ -> restart_no_binders env | NVar _ | NRef _ | NHole _ | NCases _ | NLetTuple _ | NIf _ - | NRec _ | NSort _ | NInt _ | NFloat _ + | NRec _ | NSort _ | NInt _ | NFloat _ | NArray _ | NList _ | NBinderList _ -> env (* to be safe, but restart should be ok *) let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = @@ -1688,11 +1688,11 @@ let drop_notations_pattern looked_for genv = (* but not scopes in expl_pl *) let (argscs1,_) = find_remaining_scopes expl_pl pl g in DAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) pl, []) - | CPatNotation (_,(InConstrEntrySomeLevel,"- _"),([a],[]),[]) when is_non_zero_pat a -> + | CPatNotation (_,(InConstrEntry,"- _"),([a],[]),[]) when is_non_zero_pat a -> let p = match a.CAst.v with CPatPrim (Numeral (_, p)) -> p | _ -> assert false in let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Numeral (SMinus,p)) scopes in rcp_of_glob scopes pat - | CPatNotation (_,(InConstrEntrySomeLevel,"( _ )"),([a],[]),[]) -> + | CPatNotation (_,(InConstrEntry,"( _ )"),([a],[]),[]) -> in_pat top scopes a | CPatNotation (_,ntn,fullargs,extrargs) -> let ntn,(terms,termlists) = contract_curly_brackets_pat ntn fullargs in @@ -2006,10 +2006,10 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = DAst.make ?loc @@ GLetIn (na.CAst.v, inc1, int, intern_restart_binders (push_name_env ntnvars (impls_term_list 1 inc1) env na) c2) - | CNotation (_,(InConstrEntrySomeLevel,"- _"), ([a],[],[],[])) when is_non_zero a -> + | CNotation (_,(InConstrEntry,"- _"), ([a],[],[],[])) when is_non_zero a -> let p = match a.CAst.v with CPrim (Numeral (_, p)) -> p | _ -> assert false in intern env (CAst.make ?loc @@ CPrim (Numeral (SMinus,p))) - | CNotation (_,(InConstrEntrySomeLevel,"( _ )"),([a],[],[],[])) -> intern env a + | CNotation (_,(InConstrEntry,"( _ )"),([a],[],[],[])) -> intern env a | CNotation (_,ntn,args) -> let c = intern_notation intern env ntnvars loc ntn args in let x, impl, scopes = find_appl_head_data c in @@ -2204,6 +2204,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CCast (c1, c2) -> DAst.make ?loc @@ GCast (intern env c1, map_cast_type (intern_type (slide_binders env)) c2) + | CArray(u,t,def,ty) -> + DAst.make ?loc @@ GArray(u, Array.map (intern env) t, intern env def, intern env ty) ) and intern_type env = intern (set_type_scope env) diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index 57ec708b07..d57c05788d 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -207,7 +207,7 @@ let cook_notation (from,df) sc = done; let df = Bytes.sub_string ntn 0 !j in let df_sc = match sc with Some sc -> ":" ^ sc ^ ":" ^ df | _ -> "::" ^ df in - let from_df_sc = match from with Constrexpr.InCustomEntryLevel (from,_) -> ":" ^ from ^ df_sc | Constrexpr.InConstrEntrySomeLevel -> ":" ^ df_sc in + let from_df_sc = match from with Constrexpr.InCustomEntry from -> ":" ^ from ^ df_sc | Constrexpr.InConstrEntry -> ":" ^ df_sc in from_df_sc let dump_notation_location posl df (((path,secpath),_),sc) = diff --git a/interp/impargs.ml b/interp/impargs.ml index a1b029c381..db102470b0 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -229,14 +229,14 @@ let add_free_rels_until strict strongly_strict revpat bound env sigma m pos acc let rec is_rigid_head sigma t = match kind sigma t with | Rel _ | Evar _ -> false | Ind _ | Const _ | Var _ | Sort _ -> true - | Case (_,_,f,_) -> is_rigid_head sigma f + | Case (_,_,_,f,_) -> is_rigid_head sigma f | Proj (p,c) -> true | App (f,args) -> (match kind sigma f with | Fix ((fi,i),_) -> is_rigid_head sigma (args.(fi.(i))) | _ -> is_rigid_head sigma f) | Lambda _ | LetIn _ | Construct _ | CoFix _ | Fix _ - | Prod _ | Meta _ | Cast _ | Int _ | Float _ -> assert false + | Prod _ | Meta _ | Cast _ | Int _ | Float _ | Array _ -> assert false let is_rigid env sigma t = let open Context.Rel.Declaration in diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 3d29da025e..4016a3600e 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -92,7 +92,7 @@ let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = let rec aux bdvars l c = match CAst.(c.v) with | CRef (qid,_) when qualid_is_ident qid -> found c.CAst.loc (qualid_basename qid) bdvars l - | CNotation (_,(InConstrEntrySomeLevel,"{ _ : _ | _ }"), ({ CAst.v = CRef (qid,_) } :: _, [], [], [])) when + | CNotation (_,(InConstrEntry,"{ _ : _ | _ }"), ({ CAst.v = CRef (qid,_) } :: _, [], [], [])) when qualid_is_ident qid && not (Id.Set.mem (qualid_basename qid) bdvars) -> Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add (qualid_basename qid) bdvars) l c | _ -> Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c diff --git a/interp/notation.ml b/interp/notation.ml index d4a44d9622..e282d62396 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -56,9 +56,9 @@ let notation_with_optional_scope_eq inscope1 inscope2 = match (inscope1,inscope2 | (LastLonelyNotation | NotationInScope _), _ -> false let notation_eq (from1,ntn1) (from2,ntn2) = - notation_entry_level_eq from1 from2 && String.equal ntn1 ntn2 + notation_entry_eq from1 from2 && String.equal ntn1 ntn2 -let pr_notation (from,ntn) = qstring ntn ++ match from with InConstrEntrySomeLevel -> mt () | InCustomEntryLevel (s,n) -> str " in custom " ++ str s +let pr_notation (from,ntn) = qstring ntn ++ match from with InConstrEntry -> mt () | InCustomEntry s -> str " in custom " ++ str s module NotationOrd = struct @@ -337,6 +337,33 @@ let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) | NApp (_,args) -> Oth, Some (List.length args) | _ -> Oth, None +(** Dealing with precedences *) + +type level = notation_entry * entry_level * entry_relative_level list + (* first argument is InCustomEntry s for custom entries *) + +let entry_relative_level_eq t1 t2 = match t1, t2 with +| LevelLt n1, LevelLt n2 -> Int.equal n1 n2 +| LevelLe n1, LevelLe n2 -> Int.equal n1 n2 +| LevelSome, LevelSome -> true +| (LevelLt _ | LevelLe _ | LevelSome), _ -> false + +let level_eq (s1, l1, t1) (s2, l2, t2) = + notation_entry_eq s1 s2 && Int.equal l1 l2 && List.equal entry_relative_level_eq t1 t2 + +let notation_level_map = Summary.ref ~name:"notation_level_map" NotationMap.empty + +let declare_notation_level ntn level = + try + let _ = NotationMap.find ntn !notation_level_map in + anomaly (str "Notation " ++ pr_notation ntn ++ str " is already assigned a level.") + with Not_found -> + notation_level_map := NotationMap.add ntn level !notation_level_map + +let level_of_notation ntn = + NotationMap.find ntn !notation_level_map + + (**********************************************************************) (* Interpreting numbers (not in summary because functional objects) *) @@ -1228,8 +1255,8 @@ let find_notation ntn sc = NotationMap.find ntn (find_scope sc).notations let notation_of_prim_token = function - | Constrexpr.Numeral (SPlus,n) -> InConstrEntrySomeLevel, NumTok.Unsigned.sprint n - | Constrexpr.Numeral (SMinus,n) -> InConstrEntrySomeLevel, "- "^NumTok.Unsigned.sprint n + | Constrexpr.Numeral (SPlus,n) -> InConstrEntry, NumTok.Unsigned.sprint n + | Constrexpr.Numeral (SMinus,n) -> InConstrEntry, "- "^NumTok.Unsigned.sprint n | String _ -> raise Not_found let find_prim_token check_allowed ?loc p sc = @@ -1256,7 +1283,7 @@ let find_prim_token check_allowed ?loc p sc = let interp_prim_token_gen ?loc g p local_scopes = let scopes = make_current_scopes local_scopes in - let p_as_ntn = try notation_of_prim_token p with Not_found -> InConstrEntrySomeLevel,"" in + let p_as_ntn = try notation_of_prim_token p with Not_found -> InConstrEntry,"" in try let (pat,loc), sc = find_interpretation p_as_ntn (find_prim_token ?loc g p) scopes in pat, (loc,sc) @@ -1336,7 +1363,8 @@ module EntryCoercionOrd = module EntryCoercionMap = Map.Make(EntryCoercionOrd) -let entry_coercion_map = ref EntryCoercionMap.empty +let entry_coercion_map : (((entry_level option * entry_level option) * entry_coercion) list EntryCoercionMap.t) ref = + ref EntryCoercionMap.empty let level_ord lev lev' = match lev, lev' with @@ -1349,13 +1377,18 @@ let rec search nfrom nto = function | ((pfrom,pto),coe)::l -> if level_ord pfrom nfrom && level_ord nto pto then coe else search nfrom nto l -let decompose_custom_entry = function +let make_notation_entry_level entry level = + match entry with + | InConstrEntry -> InConstrEntrySomeLevel + | InCustomEntry s -> InCustomEntryLevel (s,level) + +let decompose_notation_entry_level = function | InConstrEntrySomeLevel -> InConstrEntry, None | InCustomEntryLevel (s,n) -> InCustomEntry s, Some n let availability_of_entry_coercion entry entry' = - let entry, lev = decompose_custom_entry entry in - let entry', lev' = decompose_custom_entry entry' in + let entry, lev = decompose_notation_entry_level entry in + let entry', lev' = decompose_notation_entry_level entry' in if notation_entry_eq entry entry' && level_ord lev' lev then Some [] else try Some (search lev lev' (EntryCoercionMap.find (entry,entry') !entry_coercion_map)) @@ -1377,28 +1410,27 @@ let rec insert_coercion_path path = function else if shorter_path path path' then path::allpaths else path'::insert_coercion_path path paths -let declare_entry_coercion (scope,(entry,_) as specific_ntn) entry' = - let entry, lev = decompose_custom_entry entry in - let entry', lev' = decompose_custom_entry entry' in +let declare_entry_coercion (scope,(entry,key)) lev entry' = + let entry', lev' = decompose_notation_entry_level entry' in (* Transitive closure *) let toaddleft = EntryCoercionMap.fold (fun (entry'',entry''') paths l -> List.fold_right (fun ((lev'',lev'''),path) l -> if notation_entry_eq entry entry''' && level_ord lev lev''' && not (notation_entry_eq entry' entry'') - then ((entry'',entry'),((lev'',lev'),path@[specific_ntn]))::l else l) paths l) + then ((entry'',entry'),((lev'',lev'),path@[(scope,(entry,key))]))::l else l) paths l) !entry_coercion_map [] in let toaddright = EntryCoercionMap.fold (fun (entry'',entry''') paths l -> List.fold_right (fun ((lev'',lev'''),path) l -> if entry' = entry'' && level_ord lev' lev'' && entry <> entry''' - then ((entry,entry'''),((lev,lev'''),path@[specific_ntn]))::l else l) paths l) + then ((entry,entry'''),((lev,lev'''),path@[(scope,(entry,key))]))::l else l) paths l) !entry_coercion_map [] in entry_coercion_map := List.fold_right (fun (pair,path) -> let olds = try EntryCoercionMap.find pair !entry_coercion_map with Not_found -> [] in EntryCoercionMap.add pair (insert_coercion_path path olds)) - (((entry,entry'),((lev,lev'),[specific_ntn]))::toaddright@toaddleft) + (((entry,entry'),((lev,lev'),[(scope,(entry,key))]))::toaddright@toaddleft) !entry_coercion_map let entry_has_global_map = ref String.Map.empty diff --git a/interp/notation.mli b/interp/notation.mli index e7e917463b..c39bfa6e28 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -298,8 +298,8 @@ type symbol = val symbol_eq : symbol -> symbol -> bool (** Make/decompose a notation of the form "_ U _" *) -val make_notation_key : notation_entry_level -> symbol list -> notation -val decompose_notation_key : notation -> notation_entry_level * symbol list +val make_notation_key : notation_entry -> symbol list -> notation +val decompose_notation_key : notation -> notation_entry * symbol list (** Decompose a notation of the form "a 'U' b" *) val decompose_raw_notation : string -> symbol list @@ -313,8 +313,10 @@ val locate_notation : (glob_constr -> Pp.t) -> notation_key -> val pr_visibility: (glob_constr -> Pp.t) -> scope_name option -> Pp.t +val make_notation_entry_level : notation_entry -> entry_level -> notation_entry_level + type entry_coercion = (notation_with_optional_scope * notation) list -val declare_entry_coercion : specific_notation -> notation_entry_level -> unit +val declare_entry_coercion : specific_notation -> entry_level option -> notation_entry_level -> unit val availability_of_entry_coercion : notation_entry_level -> notation_entry_level -> entry_coercion option val declare_custom_entry_has_global : string -> int -> unit @@ -323,6 +325,20 @@ val declare_custom_entry_has_ident : string -> int -> unit val entry_has_global : notation_entry_level -> bool val entry_has_ident : notation_entry_level -> bool +(** Dealing with precedences *) + +type level = notation_entry * entry_level * entry_relative_level list + (* first argument is InCustomEntry s for custom entries *) + +val level_eq : level -> level -> bool +val entry_relative_level_eq : entry_relative_level -> entry_relative_level -> bool + +(** {6 Declare and test the level of a (possibly uninterpreted) notation } *) + +val declare_notation_level : notation -> level -> unit +val level_of_notation : notation -> level + (** raise [Not_found] if not declared *) + (** Rem: printing rules for primitive token are canonical *) val with_notation_protection : ('a -> 'b) -> 'a -> 'b diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 54065e8b35..6422e184b5 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -92,9 +92,12 @@ let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with Uint63.equal i1 i2 | NFloat f1, NFloat f2 -> Float64.equal f1 f2 +| NArray(t1,def1,ty1), NArray(t2,def2,ty2) -> + Array.equal (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) def1 def2 + && eq_notation_constr vars ty1 ty2 | (NRef _ | NVar _ | NApp _ | NHole _ | NList _ | NLambda _ | NProd _ | NBinderList _ | NLetIn _ | NCases _ | NLetTuple _ | NIf _ - | NRec _ | NSort _ | NCast _ | NInt _ | NFloat _), _ -> false + | NRec _ | NSort _ | NCast _ | NInt _ | NFloat _ | NArray _), _ -> false (**********************************************************************) (* Re-interpret a notation as a glob_constr, taking care of binders *) @@ -249,6 +252,7 @@ let glob_constr_of_notation_constr_with_binders ?loc g f ?(h=default_binder_stat | NRef x -> GRef (x,None) | NInt i -> GInt i | NFloat f -> GFloat f + | NArray (t,def,ty) -> GArray(None, Array.map (f e) t, f e def, f e ty) let glob_constr_of_notation_constr ?loc x = let rec aux () x = @@ -472,6 +476,7 @@ let notation_constr_and_vars_of_glob_constr recvars a = if arg != None then has_ltac := true; NHole (w, naming, arg) | GRef (r,_) -> NRef r + | GArray (_u,t,def,ty) -> NArray (Array.map aux t, aux def, aux ty) | GEvar _ | GPatVar _ -> user_err Pp.(str "Existential variables not allowed in notations.") ) x @@ -675,6 +680,14 @@ let rec subst_notation_constr subst bound raw = let k' = smartmap_cast_type (subst_notation_constr subst bound) k in if r1' == r1 && k' == k then raw else NCast(r1',k') + | NArray (t,def,ty) -> + let def' = subst_notation_constr subst bound def + and t' = Array.Smart.map (subst_notation_constr subst bound) t + and ty' = subst_notation_constr subst bound ty + in + if def' == def && t' == t && ty' == ty then raw else + NArray(t',def',ty') + let subst_interpretation subst (metas,pat) = let bound = List.fold_left (fun accu (id, _) -> Id.Set.add id accu) Id.Set.empty metas in (metas,subst_notation_constr subst bound pat) @@ -1254,9 +1267,16 @@ let rec match_ inner u alp metas sigma a1 a2 = match_names metas (alp,sigma) (Name id') na in match_in u alp metas sigma (mkGApp a1 [DAst.make @@ GVar id']) b2 + | GArray(_u,t,def,ty), NArray(nt,ndef,nty) -> + if Int.equal (Array.length t) (Array.length nt) then + let sigma = match_in u alp metas sigma def ndef in + let sigma = match_in u alp metas sigma ty nty in + Array.fold_left2 (match_in u alp metas) sigma t nt + else raise No_match + | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ | GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ - | GCast _ | GInt _ | GFloat _), _ -> raise No_match + | GCast _ | GInt _ | GFloat _ | GArray _), _ -> raise No_match and match_in u = match_ true u diff --git a/interp/notation_term.ml b/interp/notation_term.ml index 4e9b8bbb17..82238b71b7 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -45,6 +45,7 @@ type notation_constr = | NCast of notation_constr * notation_constr cast_type | NInt of Uint63.t | NFloat of Float64.t + | NArray of notation_constr array * notation_constr * notation_constr (** Note concerning NList: first constr is iterator, second is terminator; first id is where each argument of the list has to be substituted diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index 306643f758..814cdfe1d8 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -75,6 +75,8 @@ void init_arity () { arity[CHECKNEXTUPFLOAT]=arity[CHECKNEXTDOWNFLOAT]=1; /* instruction with two operands */ arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= + arity[ISARRAY_CAML_CALL1]=arity[ISINT_CAML_CALL2]= + arity[ISARRAY_INT_CAML_CALL2]=arity[ISARRAY_INT_CAML_CALL3]= arity[PROJ]=2; /* instruction with four operands */ arity[MAKESWITCHBLOCK]=4; diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 7588c1ce07..9921208e04 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -22,6 +22,7 @@ #include <caml/memory.h> #include <caml/signals.h> #include <caml/version.h> +#include <caml/callback.h> #include "coq_instruct.h" #include "coq_fix_code.h" @@ -111,7 +112,8 @@ if (sp - num_args < coq_stack_threshold) { \ /* GC interface */ #define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; } #define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; } - +#define Setup_for_caml_call { *--sp = coq_env; coq_sp = sp; } +#define Restore_after_caml_call { sp = coq_sp; coq_env = *sp++; } /* Register optimization. Some compilers underestimate the use of the local variables representing @@ -1771,6 +1773,71 @@ value coq_interprete Next; } + + Instruct(ISINT_CAML_CALL2) { + value arg; + print_instr("ISINT_CAML_CALL2"); + if (Is_uint63(accu)) { + pc++; + print_int(*pc); + arg = sp[0]; + Setup_for_caml_call; + accu = caml_callback2(Field(coq_global_data, *pc), accu, arg); + Restore_after_caml_call; + sp += 1; + pc++; + } else pc += *pc; + Next; + } + + Instruct(ISARRAY_CAML_CALL1) { + print_instr("ISARRAY_CAML_CALL1"); + if (Is_coq_array(accu)) { + pc++; + Setup_for_caml_call; + print_int(*pc); + accu = caml_callback(Field(coq_global_data, *pc),accu); + Restore_after_caml_call; + pc++; + } + else pc += *pc; + Next; + } + + Instruct(ISARRAY_INT_CAML_CALL2) { + value arg; + print_instr("ISARRAY_INT_CAML_CALL2"); + if (Is_coq_array(accu) && Is_uint63(sp[0])) { + pc++; + arg = sp[0]; + Setup_for_caml_call; + print_int(*pc); + accu = caml_callback2(Field(coq_global_data, *pc), accu, arg); + Restore_after_caml_call; + sp += 1; + pc++; + } else pc += *pc; + Next; + } + + Instruct(ISARRAY_INT_CAML_CALL3) { + value arg1; + value arg2; + print_instr("ISARRAY_INT_CAML_CALL3"); + if (Is_coq_array(accu) && Is_uint63(sp[0])) { + pc++; + arg1 = sp[0]; + arg2 = sp[1]; + Setup_for_caml_call; + print_int(*pc); + accu = caml_callback3(Field(coq_global_data, *pc),accu, arg1, arg2); + Restore_after_caml_call; + sp += 2; + pc++; + } else pc += *pc; + Next; + } + /* Debugging and machine control */ Instruct(STOP){ diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h index b027673ac7..86ae6295fd 100644 --- a/kernel/byterun/coq_values.h +++ b/kernel/byterun/coq_values.h @@ -33,6 +33,9 @@ #define IS_EVALUATED_COFIX(v) (Is_accu(v) && Is_block(Field(v,1)) && (Tag_val(Field(v,1)) == ATOM_COFIXEVALUATED_TAG)) #define Is_double(v) (Tag_val(v) == Double_tag) +/* coq array */ +#define Is_coq_array(v) (Is_block(v) && (Wosize_val(v) == 1)) + /* coq values for primitive operations */ #define coq_tag_C1 2 #define coq_tag_C0 1 diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index de02882370..a23ef8fdca 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -343,16 +343,20 @@ and fterm = | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) + | FCaseInvert of case_info * constr * finvert * fconstr * constr array * fconstr subs | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FInt of Uint63.t | FFloat of Float64.t + | FArray of Univ.Instance.t * fconstr Parray.t * fconstr | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED +and finvert = Univ.Instance.t * fconstr array + let fterm_of v = v.term let set_norm v = v.mark <- Mark.set_norm v.mark let is_val v = match Mark.red_state v.mark with Norm -> true | Cstr | Whnf | Red -> false @@ -375,16 +379,30 @@ type infos_cache = { i_env : env; i_sigma : existential -> constr option; i_share : bool; + i_univs : UGraph.t; } type clos_infos = { i_flags : reds; + i_relevances : Sorts.relevance Range.t; i_cache : infos_cache } type clos_tab = (fconstr, Empty.t) constant_def KeyTable.t let info_flags info = info.i_flags let info_env info = info.i_cache.i_env +let info_univs info = info.i_cache.i_univs + +let push_relevance infos r = + { infos with i_relevances = Range.cons r.Context.binder_relevance infos.i_relevances } + +let push_relevances infos nas = + { infos with i_relevances = Array.fold_left (fun l x -> Range.cons x.Context.binder_relevance l) + infos.i_relevances nas } + +let set_info_relevances info r = { info with i_relevances = r } + +let info_relevances info = info.i_relevances (**********************************************************************) (* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) @@ -438,8 +456,8 @@ let rec lft_fconstr n ft = {mark=mark Cstr r; term=FCoFix(cfx,subs_shft(n,e))} | FLIFT(k,m) -> lft_fconstr (n+k) m | FLOCKED -> assert false - | FFlex (RelKey _) | FAtom _ | FApp _ | FProj _ | FCaseT _ | FProd _ - | FLetIn _ | FEvar _ | FCLOS _ -> {mark=ft.mark; term=FLIFT(n,ft)} + | FFlex (RelKey _) | FAtom _ | FApp _ | FProj _ | FCaseT _ | FCaseInvert _ | FProd _ + | FLetIn _ | FEvar _ | FCLOS _ | FArray _ -> {mark=ft.mark; term=FLIFT(n,ft)} let lift_fconstr k f = if Int.equal k 0 then f else lft_fconstr k f let lift_fconstr_vect k v = @@ -501,11 +519,13 @@ let mk_clos e t = | Construct kn -> {mark = mark Cstr Unknown; term = FConstruct kn } | Int i -> {mark = mark Cstr Unknown; term = FInt i} | Float f -> {mark = mark Cstr Unknown; term = FFloat f} - | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _) -> + | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _|Array _) -> {mark = mark Red Unknown; term = FCLOS(t,e)} let inject c = mk_clos (subs_id 0) c +(************************************************************************) + (** Hand-unrolling of the map function to bypass the call to the generic array allocation *) let mk_clos_vect env v = match v with @@ -541,7 +561,7 @@ let ref_value_cache ({ i_cache = cache; _ }) tab ref = in Def (inject body) with - | NotEvaluableConst (IsPrimitive op) (* Const *) -> Primitive op + | NotEvaluableConst (IsPrimitive (_u,op)) (* Const *) -> Primitive op | Not_found (* List.assoc *) | NotEvaluableConst _ (* Const *) -> Undef None @@ -558,14 +578,10 @@ let rec to_constr lfts v = | FFlex (ConstKey op) -> mkConstU op | FInd op -> mkIndU op | FConstruct op -> mkConstructU op - | FCaseT (ci,p,c,ve,env) -> - if is_subs_id env && is_lift_id lfts then - mkCase (ci, p, to_constr lfts c, ve) - else - let subs = comp_subs lfts env in - mkCase (ci, subst_constr subs p, - to_constr lfts c, - Array.map (fun b -> subst_constr subs b) ve) + | FCaseT (ci,p,c,ve,env) -> to_constr_case lfts ci p NoInvert c ve env + | FCaseInvert (ci,p,(univs,args),c,ve,env) -> + let iv = CaseInvert {univs;args=Array.map (to_constr lfts) args} in + to_constr_case lfts ci p iv c ve env | FFix ((op,(lna,tys,bds)) as fx, e) -> if is_subs_id e && is_lift_id lfts then mkFix fx @@ -613,7 +629,7 @@ let rec to_constr lfts v = subst_constr subs f) | FEvar ((ev,args),env) -> let subs = comp_subs lfts env in - mkEvar(ev,List.map (fun a -> subst_constr subs a) args) + mkEvar(ev, List.map (fun a -> subst_constr subs a) args) | FLIFT (k,a) -> to_constr (el_shft k lfts) a | FInt i -> @@ -621,6 +637,11 @@ let rec to_constr lfts v = | FFloat f -> Constr.mkFloat f + | FArray (u,t,ty) -> + let ty = to_constr lfts ty in + let init i = to_constr lfts (Parray.get t (Uint63.of_int i)) in + mkArray(u,Array.init (Parray.length_int t) init, to_constr lfts (Parray.default t),ty) + | FCLOS (t,env) -> if is_subs_id env && is_lift_id lfts then t else @@ -628,6 +649,15 @@ let rec to_constr lfts v = subst_constr subs t | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*) +and to_constr_case lfts ci p iv c ve env = + if is_subs_id env && is_lift_id lfts then + mkCase (ci, p, iv, to_constr lfts c, ve) + else + let subs = comp_subs lfts env in + mkCase (ci, subst_constr subs p, iv, + to_constr lfts c, + Array.map (fun b -> subst_constr subs b) ve) + and subst_constr subst c = match [@ocaml.warning "-4"] Constr.kind c with | Rel i -> begin match expand_rel i subst with @@ -909,54 +939,6 @@ let unfold_projection info p = Some (Zproj (Projection.repr p)) else None -(*********************************************************************) -(* A machine that inspects the head of a term until it finds an - atom or a subterm that may produce a redex (abstraction, - constructor, cofix, letin, constant), or a neutral term (product, - inductive) *) -let rec knh info m stk = - match m.term with - | FLIFT(k,a) -> knh info a (zshift k stk) - | FCLOS(t,e) -> knht info e t (zupdate info m stk) - | FLOCKED -> assert false - | FApp(a,b) -> knh info a (append_stack b (zupdate info m stk)) - | FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate info m stk) - | FFix(((ri,n),_),_) -> - (match get_nth_arg m ri.(n) stk with - (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') - | (None, stk') -> (m,stk')) - | FProj (p,c) -> - (match unfold_projection info p with - | None -> (m, stk) - | Some s -> knh info c (s :: zupdate info m stk)) - -(* cases where knh stops *) - | (FFlex _|FLetIn _|FConstruct _|FEvar _| - FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _|FInt _|FFloat _) -> - (m, stk) - -(* The same for pure terms *) -and knht info e t stk = - match kind t with - | App(a,b) -> - knht info e a (append_stack (mk_clos_vect e b) stk) - | Case(ci,p,t,br) -> - knht info e t (ZcaseT(ci, p, br, e)::stk) - | Fix fx -> knh info { mark = mark Cstr Unknown; term = FFix (fx, e) } stk - | Cast(a,_,_) -> knht info e a stk - | Rel n -> knh info (clos_rel e n) stk - | Proj (p, c) -> knh info { mark = mark Red Unknown; term = FProj (p, mk_clos e c) } stk - | (Ind _|Const _|Construct _|Var _|Meta _ | Sort _ | Int _|Float _) -> (mk_clos e t, stk) - | CoFix cfx -> { mark = mark Cstr Unknown; term = FCoFix (cfx,e) }, stk - | Lambda _ -> { mark = mark Cstr Unknown; term = mk_lambda e t }, stk - | Prod (n, t, c) -> - { mark = mark Whnf KnownR; term = FProd (n, mk_clos e t, c, e) }, stk - | LetIn (n,b,t,c) -> - { mark = mark Red Unknown; term = FLetIn (n, mk_clos e b, mk_clos e t, c, e) }, stk - | Evar ev -> { mark = mark Red Unknown; term = FEvar (ev, e) }, stk - -let inject c = mk_clos (subs_id 0) c - (************************************************************************) (* Reduction of Native operators *) @@ -967,6 +949,7 @@ module FNativeEntries = type elem = fconstr type args = fconstr array type evd = unit + type uinstance = Univ.Instance.t let get = Array.get @@ -980,6 +963,11 @@ module FNativeEntries = | FFloat f -> f | _ -> raise Primred.NativeDestKO + let get_parray () e = + match [@ocaml.warning "-4"] e.term with + | FArray (_u,t,_ty) -> t + | _ -> raise Not_found + let dummy = {mark = mark Norm KnownR; term = FRel 0} let current_retro = ref Retroknowledge.empty @@ -1108,6 +1096,17 @@ module FNativeEntries = frefl := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs crefl) } | None -> defined_refl := false + let defined_array = ref false + + let farray = ref dummy + + let init_array retro = + match retro.Retroknowledge.retro_array with + | Some c -> + defined_array := true; + farray := { mark = mark Norm KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } + | None -> defined_array := false + let init env = current_retro := env.retroknowledge; init_int !current_retro; @@ -1118,7 +1117,8 @@ module FNativeEntries = init_cmp !current_retro; init_f_cmp !current_retro; init_f_class !current_retro; - init_refl !current_retro + init_refl !current_retro; + init_array !current_retro let check_env env = if not (!current_retro == env.retroknowledge) then init env @@ -1155,6 +1155,10 @@ module FNativeEntries = check_env env; assert (!defined_f_class) + let check_array env = + check_env env; + assert (!defined_array) + let mkInt env i = check_int env; { mark = mark Cstr KnownR; term = FInt i } @@ -1244,12 +1248,76 @@ module FNativeEntries = let mkNaN env = check_f_class env; !fNaN + + let mkArray env u t ty = + check_array env; + { mark = mark Whnf KnownR; term = FArray (u,t,ty)} + end module FredNative = RedNative(FNativeEntries) +(*********************************************************************) +(* A machine that inspects the head of a term until it finds an + atom or a subterm that may produce a redex (abstraction, + constructor, cofix, letin, constant), or a neutral term (product, + inductive) *) +let rec knh info m stk = + match m.term with + | FLIFT(k,a) -> knh info a (zshift k stk) + | FCLOS(t,e) -> knht info e t (zupdate info m stk) + | FLOCKED -> assert false + | FApp(a,b) -> knh info a (append_stack b (zupdate info m stk)) + | FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate info m stk) + | FFix(((ri,n),_),_) -> + (match get_nth_arg m ri.(n) stk with + (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') + | (None, stk') -> (m,stk')) + | FProj (p,c) -> + (match unfold_projection info p with + | None -> (m, stk) + | Some s -> knh info c (s :: zupdate info m stk)) + +(* cases where knh stops *) + | (FFlex _|FLetIn _|FConstruct _|FEvar _|FCaseInvert _| + FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _|FInt _|FFloat _|FArray _) -> + (m, stk) + +(* The same for pure terms *) +and knht info e t stk = + match kind t with + | App(a,b) -> + knht info e a (append_stack (mk_clos_vect e b) stk) + | Case(ci,p,NoInvert,t,br) -> + knht info e t (ZcaseT(ci, p, br, e)::stk) + | Case(ci,p,CaseInvert{univs;args},t,br) -> + let term = FCaseInvert (ci, p, (univs,Array.map (mk_clos e) args), mk_clos e t, br, e) in + { mark = mark Red Unknown; term }, stk + | Fix fx -> knh info { mark = mark Cstr Unknown; term = FFix (fx, e) } stk + | Cast(a,_,_) -> knht info e a stk + | Rel n -> knh info (clos_rel e n) stk + | Proj (p, c) -> knh info { mark = mark Red Unknown; term = FProj (p, mk_clos e c) } stk + | (Ind _|Const _|Construct _|Var _|Meta _ | Sort _ | Int _|Float _) -> (mk_clos e t, stk) + | CoFix cfx -> { mark = mark Cstr Unknown; term = FCoFix (cfx,e) }, stk + | Lambda _ -> { mark = mark Cstr Unknown; term = mk_lambda e t }, stk + | Prod (n, t, c) -> + { mark = mark Whnf KnownR; term = FProd (n, mk_clos e t, c, e) }, stk + | LetIn (n,b,t,c) -> + { mark = mark Red Unknown; term = FLetIn (n, mk_clos e b, mk_clos e t, c, e) }, stk + | Evar ev -> { mark = mark Red Unknown; term = FEvar (ev, e) }, stk + | Array(u,t,def,ty) -> + let len = Array.length t in + let ty = mk_clos e ty in + let t = Parray.init (Uint63.of_int len) (fun i -> mk_clos e t.(i)) (mk_clos e def) in + let term = FArray (u,t,ty) in + knh info { mark = mark Cstr Unknown; term } stk + (************************************************************************) +let conv : (clos_infos -> clos_tab -> fconstr -> fconstr -> bool) ref + = ref (fun _ _ _ _ -> (assert false : bool)) +let set_conv f = conv := f + (* Computes a weak head normal form from the result of knh. *) let rec knr info tab m stk = match m.term with @@ -1257,7 +1325,7 @@ let rec knr info tab m stk = (match get_args n tys f e stk with Inl e', s -> knit info tab e' f s | Inr lam, s -> (lam,s)) - | FFlex(ConstKey (kn,_ as c)) when red_set info.i_flags (fCONST kn) -> + | FFlex(ConstKey (kn,_u as c)) when red_set info.i_flags (fCONST kn) -> (match ref_value_cache info tab (ConstKey c) with | Def v -> kni info tab v stk | Primitive op when check_native_args op stk -> @@ -1306,15 +1374,16 @@ let rec knr info tab m stk = (match info.i_cache.i_sigma ev with Some c -> knit info tab env c stk | None -> (m,stk)) - | FInt _ | FFloat _ -> + | FInt _ | FFloat _ | FArray _ -> (match [@ocaml.warning "-4"] strip_update_shift_app m stk with - | (_, _, Zprimitive(op,c,rargs,nargs)::s) -> + | (_, _, Zprimitive(op,(_,u as c),rargs,nargs)::s) -> let (rargs, nargs) = skip_native_args (m::rargs) nargs in begin match nargs with | [] -> let args = Array.of_list (List.rev rargs) in - begin match FredNative.red_prim (info_env info) () op args with - | Some m -> kni info tab m s + begin match FredNative.red_prim (info_env info) () op u args with + | Some m -> + kni info tab m s | None -> let f = {mark = mark Whnf KnownR; term = FFlex (ConstKey c)} in let m = {mark = mark Whnf KnownR; term = FApp(f,args)} in @@ -1325,8 +1394,13 @@ let rec knr info tab m stk = kni info tab a (Zprimitive(op,c,rargs,nargs)::s) end | (_, _, s) -> (m, s)) + | FCaseInvert (ci,_p,iv,_c,v,env) when red_set info.i_flags fMATCH -> + begin match case_inversion info tab ci iv v with + | Some c -> knit info tab env c stk + | None -> (m, stk) + end | FLOCKED | FRel _ | FAtom _ | FFlex (RelKey _ | ConstKey _ | VarKey _) | FInd _ | FApp _ | FProj _ - | FFix _ | FCoFix _ | FCaseT _ | FLambda _ | FProd _ | FLetIn _ | FLIFT _ + | FFix _ | FCoFix _ | FCaseT _ | FCaseInvert _ | FLambda _ | FProd _ | FLetIn _ | FLIFT _ | FCLOS _ -> (m, stk) @@ -1338,6 +1412,28 @@ and knit info tab e t stk = let (ht,s) = knht info e t stk in knr info tab ht s +and case_inversion info tab ci (univs,args) v = + let open Declarations in + if Array.is_empty args then Some v.(0) + else + let env = info_env info in + let ind = ci.ci_ind in + let params, indices = Array.chop ci.ci_npar args in + let psubst = subs_cons (params, subs_id 0) in + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + (* indtyping enforces 1 ctor with no letins in the context *) + let _, expect = mip.mind_nf_lc.(0) in + let _ind, expect_args = destApp expect in + let check_index i index = + let expected = expect_args.(ci.ci_npar + i) in + let expected = Vars.subst_instance_constr univs expected in + let expected = mk_clos psubst expected in + !conv {info with i_flags=all} tab expected index + in + if Array.for_all_i check_index 0 indices + then Some v.(0) else None + let kh info tab v stk = fapp_stack(kni info tab v stk) (************************************************************************) @@ -1348,7 +1444,7 @@ let rec zip_term zfun m stk = | Zapp args :: s -> zip_term zfun (mkApp(m, Array.map zfun args)) s | ZcaseT(ci,p,br,e)::s -> - let t = mkCase(ci, zfun (mk_clos e p), m, + let t = mkCase(ci, zfun (mk_clos e p), NoInvert, m, Array.map (fun b -> zfun (mk_clos e b)) br) in zip_term zfun t s | Zproj p::s -> @@ -1388,31 +1484,35 @@ and norm_head info tab m = | FLambda(_n,tys,f,e) -> let (e',info,rvtys) = List.fold_left (fun (e,info,ctxt) (na,ty) -> + let info = push_relevance info na in (subs_lift e, info, (na,kl info tab (mk_clos e ty))::ctxt)) (e,info,[]) tys in let bd = kl info tab (mk_clos e' f) in List.fold_left (fun b (na,ty) -> mkLambda(na,ty,b)) bd rvtys | FLetIn(na,a,b,f,e) -> let c = mk_clos (subs_lift e) f in - mkLetIn(na, kl info tab a, kl info tab b, kl info tab c) + mkLetIn(na, kl info tab a, kl info tab b, kl (push_relevance info na) tab c) | FProd(na,dom,rng,e) -> - mkProd(na, kl info tab dom, kl info tab (mk_clos (subs_lift e) rng)) + mkProd(na, kl info tab dom, kl (push_relevance info na) tab (mk_clos (subs_lift e) rng)) | FCoFix((n,(na,tys,bds)),e) -> let ftys = Array.Fun1.map mk_clos e tys in let fbds = Array.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in - mkCoFix(n,(na, CArray.map (kl info tab) ftys, CArray.map (kl info tab) fbds)) + let infobd = push_relevances info na in + mkCoFix(n,(na, CArray.map (kl info tab) ftys, CArray.map (kl infobd tab) fbds)) | FFix((n,(na,tys,bds)),e) -> let ftys = Array.Fun1.map mk_clos e tys in let fbds = Array.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in - mkFix(n,(na, CArray.map (kl info tab) ftys, CArray.map (kl info tab) fbds)) + let infobd = push_relevances info na in + mkFix(n,(na, CArray.map (kl info tab) ftys, CArray.map (kl infobd tab) fbds)) | FEvar((i,args),env) -> mkEvar(i, List.map (fun a -> kl info tab (mk_clos env a)) args) | FProj (p,c) -> mkProj (p, kl info tab c) | FLOCKED | FRel _ | FAtom _ | FFlex _ | FInd _ | FConstruct _ - | FApp _ | FCaseT _ | FLIFT _ | FCLOS _ | FInt _ | FFloat _ -> term_of_fconstr m + | FApp _ | FCaseT _ | FCaseInvert _ | FLIFT _ | FCLOS _ | FInt _ + | FFloat _ | FArray _ -> term_of_fconstr m (* Initialization and then normalization *) @@ -1434,14 +1534,16 @@ let whd_stack infos tab m stk = match Mark.red_state m.mark with let () = if infos.i_cache.i_share then ignore (fapp_stack k) in (* to unlock Zupdates! *) k -let create_clos_infos ?(evars=fun _ -> None) flgs env = +let create_clos_infos ?univs ?(evars=fun _ -> None) flgs env = + let univs = Option.default (universes env) univs in let share = (Environ.typing_flags env).Declarations.share_reduction in let cache = { i_env = env; i_sigma = evars; i_share = share; + i_univs = univs; } in - { i_flags = flgs; i_cache = cache } + { i_flags = flgs; i_relevances = Range.empty; i_cache = cache } let create_tab () = KeyTable.create 17 diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 79092813bc..ada0fc9780 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -95,10 +95,11 @@ module KeyTable : Hashtbl.S with type key = table_key (** [fconstr] is the type of frozen constr *) type fconstr - (** [fconstr] can be accessed by using the function [fterm_of] and by matching on type [fterm] *) +type finvert + type fterm = | FRel of int | FAtom of constr (** Metas and Sorts *) @@ -110,12 +111,14 @@ type fterm = | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) + | FCaseInvert of case_info * constr * finvert * fconstr * constr array * fconstr subs | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FInt of Uint63.t | FFloat of Float64.t + | FArray of Univ.Instance.t * fconstr Parray.t * fconstr | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED @@ -173,15 +176,22 @@ val set_relevance : Sorts.relevance -> fconstr -> unit type clos_infos type clos_tab val create_clos_infos : - ?evars:(existential->constr option) -> reds -> env -> clos_infos + ?univs:UGraph.t -> ?evars:(existential->constr option) -> reds -> env -> clos_infos val oracle_of_infos : clos_infos -> Conv_oracle.oracle val create_tab : unit -> clos_tab val info_env : clos_infos -> env val info_flags: clos_infos -> reds +val info_univs : clos_infos -> UGraph.t val unfold_projection : clos_infos -> Projection.t -> stack_member option +val push_relevance : clos_infos -> 'b Context.binder_annot -> clos_infos +val push_relevances : clos_infos -> 'b Context.binder_annot array -> clos_infos +val set_info_relevances : clos_infos -> Sorts.relevance Range.t -> clos_infos + +val info_relevances : clos_infos -> Sorts.relevance Range.t + val infos_with_reds : clos_infos -> reds -> clos_infos (** Reduction function *) @@ -214,6 +224,9 @@ val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> (** [unfold_reference] unfolds references in a [fconstr] *) val unfold_reference : clos_infos -> clos_tab -> table_key -> (fconstr, Util.Empty.t) constant_def +(** Hook for Reduction *) +val set_conv : (clos_infos -> clos_tab -> fconstr -> fconstr -> bool) -> unit + (*********************************************************************** i This is for lazy debug *) diff --git a/kernel/cPrimitives.ml b/kernel/cPrimitives.ml index c4036e9677..314cb54d1d 100644 --- a/kernel/cPrimitives.ml +++ b/kernel/cPrimitives.ml @@ -8,6 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Univ + type t = | Int63head0 | Int63tail0 @@ -51,6 +53,13 @@ type t = | Float64ldshiftexp | Float64next_up | Float64next_down + | Arraymake + | Arrayget + | Arraydefault + | Arrayset + | Arraycopy + | Arrayreroot + | Arraylength let parse = function | "int63_head0" -> Int63head0 @@ -95,6 +104,13 @@ let parse = function | "float64_ldshiftexp" -> Float64ldshiftexp | "float64_next_up" -> Float64next_up | "float64_next_down" -> Float64next_down + | "array_make" -> Arraymake + | "array_get" -> Arrayget + | "array_default" -> Arraydefault + | "array_set" -> Arrayset + | "array_length" -> Arraylength + | "array_copy" -> Arraycopy + | "array_reroot" -> Arrayreroot | _ -> raise Not_found let equal (p1 : t) (p2 : t) = @@ -143,6 +159,13 @@ let hash = function | Float64eq -> 40 | Float64lt -> 41 | Float64le -> 42 + | Arraymake -> 43 + | Arrayget -> 44 + | Arraydefault -> 45 + | Arrayset -> 46 + | Arraycopy -> 47 + | Arrayreroot -> 48 + | Arraylength -> 49 (* Should match names in nativevalues.ml *) let to_string = function @@ -188,28 +211,66 @@ let to_string = function | Float64ldshiftexp -> "ldshiftexp" | Float64next_up -> "next_up" | Float64next_down -> "next_down" + | Arraymake -> "arraymake" + | Arrayget -> "arrayget" + | Arraydefault -> "arraydefault" + | Arrayset -> "arrayset" + | Arraycopy -> "arraycopy" + | Arrayreroot -> "arrayreroot" + | Arraylength -> "arraylength" + +type const = + | Arraymaxlength -type prim_type = - | PT_int63 - | PT_float64 +let const_to_string = function + | Arraymaxlength -> "arraymaxlength" + +let const_of_string = function + | "array_max_length" -> Arraymaxlength + | _ -> raise Not_found -type 'a prim_ind = +let const_univs = function + | Arraymaxlength -> AUContext.empty + +type 'a prim_type = + | PT_int63 : unit prim_type + | PT_float64 : unit prim_type + | PT_array : (Instance.t * ind_or_type) prim_type + +and 'a prim_ind = | PIT_bool : unit prim_ind - | PIT_carry : prim_type prim_ind - | PIT_pair : (prim_type * prim_type) prim_ind + | PIT_carry : ind_or_type prim_ind + | PIT_pair : (ind_or_type * ind_or_type) prim_ind | PIT_cmp : unit prim_ind | PIT_f_cmp : unit prim_ind | PIT_f_class : unit prim_ind -type prim_ind_ex = PIE : 'a prim_ind -> prim_ind_ex - -type ind_or_type = +and ind_or_type = | PITT_ind : 'a prim_ind * 'a -> ind_or_type - | PITT_type : prim_type -> ind_or_type + | PITT_type : 'a prim_type * 'a -> ind_or_type + | PITT_param : int -> ind_or_type (* DeBruijn index referring to prenex type quantifiers *) + +let one_univ = + AUContext.make Names.[|Name (Id.of_string "u")|] Constraint.empty + +let typ_univs (type a) (t : a prim_type) = match t with + | PT_int63 -> AUContext.empty + | PT_float64 -> AUContext.empty + | PT_array -> one_univ + +type prim_type_ex = PTE : 'a prim_type -> prim_type_ex + +type prim_ind_ex = PIE : 'a prim_ind -> prim_ind_ex let types = - let int_ty = PITT_type PT_int63 in - let float_ty = PITT_type PT_float64 in + let int_ty = PITT_type (PT_int63, ()) in + let float_ty = PITT_type (PT_float64, ()) in + let array_ty = + PITT_type + (PT_array, + (Instance.of_array [|Level.var 0|], + PITT_param 1)) + in function | Int63head0 | Int63tail0 -> [int_ty; int_ty] | Int63add | Int63sub | Int63mul @@ -217,25 +278,144 @@ let types = | Int63lsr | Int63lsl | Int63land | Int63lor | Int63lxor -> [int_ty; int_ty; int_ty] | Int63addc | Int63subc | Int63addCarryC | Int63subCarryC -> - [int_ty; int_ty; PITT_ind (PIT_carry, PT_int63)] + [int_ty; int_ty; PITT_ind (PIT_carry, int_ty)] | Int63mulc | Int63diveucl -> - [int_ty; int_ty; PITT_ind (PIT_pair, (PT_int63, PT_int63))] + [int_ty; int_ty; PITT_ind (PIT_pair, (int_ty, int_ty))] | Int63eq | Int63lt | Int63le -> [int_ty; int_ty; PITT_ind (PIT_bool, ())] | Int63compare -> [int_ty; int_ty; PITT_ind (PIT_cmp, ())] | Int63div21 -> - [int_ty; int_ty; int_ty; PITT_ind (PIT_pair, (PT_int63, PT_int63))] + [int_ty; int_ty; int_ty; PITT_ind (PIT_pair, (int_ty, int_ty))] | Int63addMulDiv -> [int_ty; int_ty; int_ty; int_ty] | Float64opp | Float64abs | Float64sqrt | Float64next_up | Float64next_down -> [float_ty; float_ty] | Float64ofInt63 -> [int_ty; float_ty] | Float64normfr_mantissa -> [float_ty; int_ty] - | Float64frshiftexp -> [float_ty; PITT_ind (PIT_pair, (PT_float64, PT_int63))] + | Float64frshiftexp -> [float_ty; PITT_ind (PIT_pair, (float_ty, int_ty))] | Float64eq | Float64lt | Float64le -> [float_ty; float_ty; PITT_ind (PIT_bool, ())] | Float64compare -> [float_ty; float_ty; PITT_ind (PIT_f_cmp, ())] | Float64classify -> [float_ty; PITT_ind (PIT_f_class, ())] | Float64add | Float64sub | Float64mul | Float64div -> [float_ty; float_ty; float_ty] | Float64ldshiftexp -> [float_ty; int_ty; float_ty] + | Arraymake -> [int_ty; PITT_param 1; array_ty] + | Arrayget -> [array_ty; int_ty; PITT_param 1] + | Arraydefault -> [array_ty; PITT_param 1] + | Arrayset -> [array_ty; int_ty; PITT_param 1; array_ty] + | Arraycopy -> [array_ty; array_ty] + | Arrayreroot -> [array_ty; array_ty] + | Arraylength -> [array_ty; int_ty] + +let one_param = + (* currently if there's a parameter it's always this *) + let a_annot = Context.nameR (Names.Id.of_string "A") in + let ty = Constr.mkType (Universe.make (Level.var 0)) in + Context.Rel.Declaration.[LocalAssum (a_annot, ty)] + +let params = function + | Int63head0 + | Int63tail0 + | Int63add + | Int63sub + | Int63mul + | Int63div + | Int63mod + | Int63lsr + | Int63lsl + | Int63land + | Int63lor + | Int63lxor + | Int63addc + | Int63subc + | Int63addCarryC + | Int63subCarryC + | Int63mulc + | Int63diveucl + | Int63div21 + | Int63addMulDiv + | Int63eq + | Int63lt + | Int63le + | Int63compare + | Float64opp + | Float64abs + | Float64eq + | Float64lt + | Float64le + | Float64compare + | Float64classify + | Float64add + | Float64sub + | Float64mul + | Float64div + | Float64sqrt + | Float64ofInt63 + | Float64normfr_mantissa + | Float64frshiftexp + | Float64ldshiftexp + | Float64next_up + | Float64next_down -> [] + + | Arraymake + | Arrayget + | Arraydefault + | Arrayset + | Arraycopy + | Arrayreroot + | Arraylength -> one_param + +let nparams x = List.length (params x) + +let univs = function + | Int63head0 + | Int63tail0 + | Int63add + | Int63sub + | Int63mul + | Int63div + | Int63mod + | Int63lsr + | Int63lsl + | Int63land + | Int63lor + | Int63lxor + | Int63addc + | Int63subc + | Int63addCarryC + | Int63subCarryC + | Int63mulc + | Int63diveucl + | Int63div21 + | Int63addMulDiv + | Int63eq + | Int63lt + | Int63le + | Int63compare + | Float64opp + | Float64abs + | Float64eq + | Float64lt + | Float64le + | Float64compare + | Float64classify + | Float64add + | Float64sub + | Float64mul + | Float64div + | Float64sqrt + | Float64ofInt63 + | Float64normfr_mantissa + | Float64frshiftexp + | Float64ldshiftexp + | Float64next_up + | Float64next_down -> AUContext.empty + + | Arraymake + | Arrayget + | Arraydefault + | Arrayset + | Arraycopy + | Arrayreroot + | Arraylength -> one_univ type arg_kind = | Kparam (* not needed for the evaluation of the primitive when it reduces *) @@ -247,17 +427,21 @@ type args_red = arg_kind list (* Invariant only argument of type int63, float or an inductive can have kind Kwhnf *) -let arity t = List.length (types t) - 1 +let arity t = let sign = types t in nparams t + List.length sign - 1 let kind t = - let rec aux n = if n <= 0 then [] else Kwhnf :: aux (n - 1) in - aux (arity t) + let rec params n = if n <= 0 then [] else Kparam :: params (n - 1) in + let args = function PITT_type _ | PITT_ind _ -> Kwhnf | PITT_param _ -> Karg in + params (nparams t) @ List.map args (CList.drop_last (types t)) + +let types t = params t, types t (** Special Entries for Register **) type op_or_type = | OT_op of t - | OT_type of prim_type + | OT_type : 'a prim_type -> op_or_type + | OT_const of const let prim_ind_to_string (type a) (p : a prim_ind) = match p with | PIT_bool -> "bool" @@ -267,24 +451,40 @@ let prim_ind_to_string (type a) (p : a prim_ind) = match p with | PIT_f_cmp -> "f_cmp" | PIT_f_class -> "f_class" -let prim_type_to_string = function +let prim_type_to_string (type a) (ty : a prim_type) = match ty with | PT_int63 -> "int63_type" | PT_float64 -> "float64_type" + | PT_array -> "array_type" let op_or_type_to_string = function | OT_op op -> to_string op | OT_type t -> prim_type_to_string t + | OT_const c -> const_to_string c let prim_type_of_string = function - | "int63_type" -> PT_int63 - | "float64_type" -> PT_float64 + | "int63_type" -> PTE PT_int63 + | "float64_type" -> PTE PT_float64 + | "array_type" -> PTE PT_array | _ -> raise Not_found let op_or_type_of_string s = - try OT_type (prim_type_of_string s) - with Not_found -> OT_op (parse s) + match prim_type_of_string s with + | PTE ty -> OT_type ty + | exception Not_found -> + begin try OT_op (parse s) + with Not_found -> OT_const (const_of_string s) + end let parse_op_or_type ?loc s = try op_or_type_of_string s with Not_found -> CErrors.user_err ?loc Pp.(str ("Built-in #"^s^" does not exist.")) + +let op_or_type_univs = function + | OT_op t -> univs t + | OT_type t -> typ_univs t + | OT_const c -> const_univs c + +let body_of_prim_const = function + | Arraymaxlength -> + Constr.mkInt (Parray.max_length) diff --git a/kernel/cPrimitives.mli b/kernel/cPrimitives.mli index a5db51111f..5e5fad9f04 100644 --- a/kernel/cPrimitives.mli +++ b/kernel/cPrimitives.mli @@ -51,6 +51,13 @@ type t = | Float64ldshiftexp | Float64next_up | Float64next_down + | Arraymake + | Arrayget + | Arraydefault + | Arrayset + | Arraycopy + | Arrayreroot + | Arraylength (** Can raise [Not_found]. Beware that this is not exactly the reverse of [to_string] below. *) @@ -58,8 +65,11 @@ val parse : string -> t val equal : t -> t -> bool +type const = + | Arraymaxlength + type arg_kind = - | Kparam (* not needed for the elavuation of the primitive*) + | Kparam (* not needed for the evaluation of the primitive*) | Kwhnf (* need to be reduced in whnf before reducing the primitive *) | Karg (* no need to be reduced in whnf *) @@ -70,32 +80,49 @@ val hash : t -> int val to_string : t -> string val arity : t -> int +(** Including parameters *) + +val nparams : t -> int val kind : t -> args_red +(** Includes parameters *) (** Special Entries for Register **) -type prim_type = - | PT_int63 - | PT_float64 - -(** Can raise [Not_found] *) -val prim_type_of_string : string -> prim_type -val prim_type_to_string : prim_type -> string +type 'a prim_type = + | PT_int63 : unit prim_type + | PT_float64 : unit prim_type + | PT_array : (Univ.Instance.t * ind_or_type) prim_type -type 'a prim_ind = +and 'a prim_ind = | PIT_bool : unit prim_ind - | PIT_carry : prim_type prim_ind - | PIT_pair : (prim_type * prim_type) prim_ind + | PIT_carry : ind_or_type prim_ind + | PIT_pair : (ind_or_type * ind_or_type) prim_ind | PIT_cmp : unit prim_ind | PIT_f_cmp : unit prim_ind | PIT_f_class : unit prim_ind +and ind_or_type = + | PITT_ind : 'a prim_ind * 'a -> ind_or_type + | PITT_type : 'a prim_type * 'a -> ind_or_type + | PITT_param : int -> ind_or_type (* DeBruijn index referring to prenex type quantifiers *) + +val typ_univs : 'a prim_type -> Univ.AUContext.t + +type prim_type_ex = PTE : 'a prim_type -> prim_type_ex + type prim_ind_ex = PIE : 'a prim_ind -> prim_ind_ex +(** Can raise [Not_found] *) +val prim_type_of_string : string -> prim_type_ex +val prim_type_to_string : 'a prim_type -> string + type op_or_type = | OT_op of t - | OT_type of prim_type + | OT_type : 'a prim_type -> op_or_type + | OT_const of const + +val op_or_type_univs : op_or_type -> Univ.AUContext.t val prim_ind_to_string : 'a prim_ind -> string @@ -105,8 +132,12 @@ val op_or_type_to_string : op_or_type -> string val parse_op_or_type : ?loc:Loc.t -> string -> op_or_type -type ind_or_type = - | PITT_ind : 'a prim_ind * 'a -> ind_or_type - | PITT_type : prim_type -> ind_or_type +val univs : t -> Univ.AUContext.t + +val types : t -> Constr.rel_context * ind_or_type list +(** Parameters * Reduction relevant arguments and output type + + XXX we could reify universes in ind_or_type (currently polymorphic types + like array are assumed to use universe 0). *) -val types : t -> ind_or_type list +val body_of_prim_const : const -> Constr.t diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 25ec250367..74405a0105 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -61,6 +61,7 @@ type instruction = | Kensurestackcapacity of int | Kbranch of Label.t (* jump to label *) | Kprim of CPrimitives.t * pconstant option + | Kcamlprim of CPrimitives.t * Label.t | Kareint of int and bytecodes = instruction list @@ -147,6 +148,10 @@ let rec pp_instr i = | Kprim (op, id) -> str (CPrimitives.to_string op) ++ str " " ++ (match id with Some (id,_u) -> Constant.print id | None -> str "") + | Kcamlprim (op, lbl) -> + str "camlcall " ++ str (CPrimitives.to_string op) ++ spc () ++ + pp_lbl lbl + | Kareint n -> str "areint " ++ int n and pp_bytecodes c = diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index f1d441ca76..b703058fb7 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -60,7 +60,7 @@ type instruction = | Kbranch of Label.t (** jump to label, is it needed ? *) | Kprim of CPrimitives.t * pconstant option - + | Kcamlprim of CPrimitives.t * Label.t | Kareint of int and bytecodes = instruction list diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 59ae8c0745..7bff377238 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -516,6 +516,18 @@ let rec get_alias env kn = | BCalias kn' -> get_alias env kn' | _ -> kn) +(* Some primitives are not implemented natively by the VM, but calling OCaml + code instead *) +let is_caml_prim = let open CPrimitives in function + | Arraymake + | Arrayget + | Arraydefault + | Arrayset + | Arraycopy + | Arrayreroot + | Arraylength -> true + | _ -> false + (* sz is the size of the local stack *) let rec compile_lam env cenv lam sz cont = set_max_stack_size sz; @@ -775,6 +787,27 @@ let rec compile_lam env cenv lam sz cont = let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in comp_args (compile_lam env) cenv args sz cont + | Lprim (Some (kn,u), op, args) when is_caml_prim op -> + let arity = CPrimitives.arity op in + let nparams = CPrimitives.nparams op in + let nargs = arity - nparams in + assert (arity = Array.length args && arity <= 4); + let (jump, cont) = make_branch cont in + let lbl_default = Label.create () in + let default = + let cont = [Kgetglobal kn; Kapply (arity + Univ.Instance.length u); jump] in + let cont = + if Univ.Instance.is_empty u then cont + else comp_args compile_universe cenv (Univ.Instance.to_array u) (sz + arity) (Kpush::cont) + in + Klabel lbl_default :: + Kpush :: + if Int.equal nparams 0 then cont + else comp_args (compile_lam env) cenv (Array.sub args 0 nparams) (sz + nargs) (Kpush::cont) + in + fun_code := [Ksequence(default, !fun_code)]; + comp_args (compile_lam env) cenv (Array.sub args nparams nargs) sz (Kcamlprim (op, lbl_default) :: cont) + | Lprim (kn, op, args) -> comp_args (compile_lam env) cenv args sz (Kprim(op, kn)::cont) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index d855dbf2bb..6b4daabf0c 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -30,6 +30,7 @@ type reloc_info = | Reloc_const of structured_constant | Reloc_getglobal of Names.Constant.t | Reloc_proj_name of Projection.Repr.t + | Reloc_caml_prim of CPrimitives.t let eq_reloc_info r1 r2 = match r1, r2 with | Reloc_annot sw1, Reloc_annot sw2 -> eq_annot_switch sw1 sw2 @@ -40,6 +41,8 @@ let eq_reloc_info r1 r2 = match r1, r2 with | Reloc_getglobal _, _ -> false | Reloc_proj_name p1, Reloc_proj_name p2 -> Projection.Repr.equal p1 p2 | Reloc_proj_name _, _ -> false +| Reloc_caml_prim p1, Reloc_caml_prim p2 -> CPrimitives.equal p1 p2 +| Reloc_caml_prim _, _ -> false let hash_reloc_info r = let open Hashset.Combine in @@ -48,6 +51,7 @@ let hash_reloc_info r = | Reloc_const c -> combinesmall 2 (hash_structured_constant c) | Reloc_getglobal c -> combinesmall 3 (Constant.hash c) | Reloc_proj_name p -> combinesmall 4 (Projection.Repr.hash p) + | Reloc_caml_prim p -> combinesmall 5 (CPrimitives.hash p) module RelocTable = Hashtbl.Make(struct type t = reloc_info @@ -199,6 +203,10 @@ let slot_for_proj_name env p = enter env (Reloc_proj_name p); out_int env 0 +let slot_for_caml_prim env op = + enter env (Reloc_caml_prim op); + out_int env 0 + (* Emission of one instruction *) let nocheck_prim_op = function @@ -252,6 +260,11 @@ let check_prim_op = function | Float64ldshiftexp -> opCHECKLDSHIFTEXP | Float64next_up -> opCHECKNEXTUPFLOAT | Float64next_down -> opCHECKNEXTDOWNFLOAT + | Arraymake -> opISINT_CAML_CALL2 + | Arrayget -> opISARRAY_INT_CAML_CALL2 + | Arrayset -> opISARRAY_INT_CAML_CALL3 + | Arraydefault | Arraycopy | Arrayreroot | Arraylength -> + opISARRAY_CAML_CALL1 let emit_instr env = function | Klabel lbl -> define_label env lbl @@ -349,6 +362,11 @@ let emit_instr env = function out env (check_prim_op op); slot_for_getglobal env q + | Kcamlprim (op,lbl) -> + out env (check_prim_op op); + out_label env lbl; + slot_for_caml_prim env op + | Kareint 1 -> out env opISINT | Kareint 2 -> out env opAREINT2; @@ -415,6 +433,7 @@ let subst_reloc s ri = | Reloc_const sc -> Reloc_const (subst_strcst s sc) | Reloc_getglobal kn -> Reloc_getglobal (subst_constant s kn) | Reloc_proj_name p -> Reloc_proj_name (subst_proj_repr s p) + | Reloc_caml_prim _ -> ri let subst_patches subst p = let infos = CArray.map (fun (r, pos) -> (subst_reloc subst r, pos)) p.reloc_infos in diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index 209d741ba8..c4262f3380 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -16,6 +16,7 @@ type reloc_info = | Reloc_const of structured_constant | Reloc_getglobal of Constant.t | Reloc_proj_name of Projection.Repr.t + | Reloc_caml_prim of CPrimitives.t type patches type emitcodes diff --git a/kernel/clambda.ml b/kernel/clambda.ml index 65de52c0f6..6690a379ce 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -542,6 +542,14 @@ let makeblock tag nparams arity args = Lval(val_of_block Obj.last_non_constant_constructor_tag args) else Lmakeblock(tag, args) +let makearray args def = + try + let p = Array.map get_value args in + Lval (val_of_parray @@ Parray.unsafe_of_array p (get_value def)) + with Not_found -> + let ar = Lmakeblock(0, args) in (* build the ocaml array *) + let kind = Lmakeblock(0, [|ar; def|]) in (* Parray.Array *) + Lmakeblock(0,[|kind|]) (* the reference *) (* Compiling constants *) @@ -568,8 +576,13 @@ let expand_prim kn op arity = let lambda_of_prim kn op args = let arity = CPrimitives.arity op in - if Array.length args >= arity then prim kn op args - else mkLapp (expand_prim kn op arity) args + match Int.compare (Array.length args) arity with + | 0 -> prim kn op args + | x when x > 0 -> + let prim_args = Array.sub args 0 arity in + let extra_args = Array.sub args arity (Array.length args - arity) in + mkLapp(prim kn op prim_args) extra_args + | _ -> mkLapp (expand_prim kn op arity) args (*i Global environment *) @@ -710,7 +723,7 @@ let rec lambda_of_constr env c = | Construct _ -> lambda_of_app env c empty_args - | Case(ci,t,a,branches) -> + | Case(ci,t,_iv,a,branches) -> (* XXX handle iv *) let ind = ci.ci_ind in let mib = lookup_mind (fst ind) env.global_env in let oib = mib.mind_packets.(snd ind) in @@ -768,6 +781,9 @@ let rec lambda_of_constr env c = | Int i -> Luint i | Float f -> Lfloat f + | Array(_u, t,def,_ty) -> + let def = lambda_of_constr env def in + makearray (lambda_of_args env 0 t) def and lambda_of_app env f args = match Constr.kind f with diff --git a/kernel/constr.ml b/kernel/constr.ml index 703e3616a0..1837a39764 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -83,6 +83,10 @@ type pconstant = Constant.t puniverses type pinductive = inductive puniverses type pconstructor = constructor puniverses +type ('constr, 'univs) case_invert = + | NoInvert + | CaseInvert of { univs : 'univs; args : 'constr array } + (* [Var] is used for named variables and [Rel] for variables as de Bruijn indices. *) type ('constr, 'types, 'sort, 'univs) kind_of_term = @@ -99,12 +103,13 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Const of (Constant.t * 'univs) | Ind of (inductive * 'univs) | Construct of (constructor * 'univs) - | Case of case_info * 'constr * 'constr * 'constr array + | Case of case_info * 'constr * ('constr, 'univs) case_invert * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr | Int of Uint63.t | Float of Float64.t + | Array of 'univs * 'constr array * 'constr * 'types (* constr is the fixpoint of the previous type. Requires option -rectypes of the Caml compiler to be set *) type t = (t, t, Sorts.t, Instance.t) kind_of_term @@ -189,7 +194,7 @@ let mkConstructU c = Construct c let mkConstructUi ((ind,u),i) = Construct ((ind,i),u) (* Constructs the term <p>Case c of c1 | c2 .. | cn end *) -let mkCase (ci, p, c, ac) = Case (ci, p, c, ac) +let mkCase (ci, p, iv, c, ac) = Case (ci, p, iv, c, ac) (* If recindxs = [|i1,...in|] funnames = [|f1,...fn|] @@ -242,6 +247,9 @@ let mkRef (gr,u) = let open GlobRef in match gr with (* Constructs a primitive integer *) let mkInt i = Int i +(* Constructs an array *) +let mkArray (u,t,def,ty) = Array (u,t,def,ty) + (* Constructs a primitive float number *) let mkFloat f = Float f @@ -417,7 +425,7 @@ let destConstruct c = match kind c with (* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) let destCase c = match kind c with - | Case (ci,p,c,v) -> (ci,p,c,v) + | Case (ci,p,iv,c,v) -> (ci,p,iv,c,v) | _ -> raise DestKO let destProj c = match kind c with @@ -461,6 +469,11 @@ let decompose_appvect c = starting from [acc] and proceeding from left to right according to the usual representation of the constructions; it is not recursive *) +let fold_invert f acc = function + | NoInvert -> acc + | CaseInvert {univs=_;args} -> + Array.fold_left f acc args + let fold f acc c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _) -> acc @@ -471,16 +484,23 @@ let fold f acc c = match kind c with | App (c,l) -> Array.fold_left f (f acc c) l | Proj (_p,c) -> f acc c | Evar (_,l) -> List.fold_left f acc l - | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl + | Case (_,p,iv,c,bl) -> Array.fold_left f (f (fold_invert f (f acc p) iv) c) bl | Fix (_,(_lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl | CoFix (_,(_lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl + | Array(_u,t,def,ty) -> + f (f (Array.fold_left f acc t) def) ty (* [iter f c] iters [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) +let iter_invert f = function + | NoInvert -> () + | CaseInvert {univs=_; args;} -> + Array.iter f args + let iter f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _) -> () @@ -491,9 +511,10 @@ let iter f c = match kind c with | App (c,l) -> f c; Array.iter f l | Proj (_p,c) -> f c | Evar (_,l) -> List.iter f l - | Case (_,p,c,bl) -> f p; f c; Array.iter f bl + | Case (_,p,iv,c,bl) -> f p; iter_invert f iv; f c; Array.iter f bl | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl + | Array(_u,t,def,ty) -> Array.iter f t; f def; f ty (* [iter_with_binders g f n c] iters [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift @@ -510,7 +531,7 @@ let iter_with_binders g f n c = match kind c with | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c | App (c,l) -> f n c; Array.Fun1.iter f n l | Evar (_,l) -> List.iter (fun c -> f n c) l - | Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl + | Case (_,p,iv,c,bl) -> f n p; iter_invert (f n) iv; f n c; Array.Fun1.iter f n bl | Proj (_p,c) -> f n c | Fix (_,(_,tl,bl)) -> Array.Fun1.iter f n tl; @@ -518,6 +539,8 @@ let iter_with_binders g f n c = match kind c with | CoFix (_,(_,tl,bl)) -> Array.Fun1.iter f n tl; Array.Fun1.iter f (iterate g (Array.length tl) n) bl + | Array(_u,t,def,ty) -> + Array.iter (f n) t; f n def; f n ty (* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate subterms of [c] starting from [acc] and proceeding from left to @@ -537,7 +560,7 @@ let fold_constr_with_binders g f n acc c = | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_p,c) -> f n acc c | Evar (_,l) -> List.fold_left (f n) acc l - | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl + | Case (_,p,iv,c,bl) -> Array.fold_left (f n) (f n (fold_invert (f n) (f n acc p) iv) c) bl | Fix (_,(_,tl,bl)) -> let n' = iterate g (Array.length tl) n in let fd = Array.map2 (fun t b -> (t,b)) tl bl in @@ -546,6 +569,8 @@ let fold_constr_with_binders g f n acc c = let n' = iterate g (Array.length tl) n in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + | Array(_u,t,def,ty) -> + f n (f n (Array.fold_left (f n) acc t) def) ty (* [map f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is @@ -623,6 +648,13 @@ let map_branches_with_full_binders g f l ci bl = let map_return_predicate_with_full_binders g f l ci p = map_under_context_with_full_binders g f l (List.length ci.ci_pp_info.ind_tags) p +let map_invert f = function + | NoInvert -> NoInvert + | CaseInvert {univs;args;} as orig -> + let args' = Array.Smart.map f args in + if args == args' then orig + else CaseInvert {univs;args=args';} + let map_gen userview f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _) -> c @@ -660,18 +692,20 @@ let map_gen userview f c = match kind c with let l' = List.Smart.map f l in if l'==l then c else mkEvar (e, l') - | Case (ci,p,b,bl) when userview -> + | Case (ci,p,iv,b,bl) when userview -> let b' = f b in + let iv' = map_invert f iv in let p' = map_return_predicate f ci p in let bl' = map_branches f ci bl in - if b'==b && p'==p && bl'==bl then c - else mkCase (ci, p', b', bl') - | Case (ci,p,b,bl) -> + if b'==b && iv'==iv && p'==p && bl'==bl then c + else mkCase (ci, p', iv', b', bl') + | Case (ci,p,iv,b,bl) -> let b' = f b in + let iv' = map_invert f iv in let p' = f p in let bl' = Array.Smart.map f bl in - if b'==b && p'==p && bl'==bl then c - else mkCase (ci, p', b', bl') + if b'==b && iv'==iv && p'==p && bl'==bl then c + else mkCase (ci, p', iv', b', bl') | Fix (ln,(lna,tl,bl)) -> let tl' = Array.Smart.map f tl in let bl' = Array.Smart.map f bl in @@ -682,12 +716,25 @@ let map_gen userview f c = match kind c with let bl' = Array.Smart.map f bl in if tl'==tl && bl'==bl then c else mkCoFix (ln,(lna,tl',bl')) + | Array(u,t,def,ty) -> + let t' = Array.Smart.map f t in + let def' = f def in + let ty' = f ty in + if def'==def && t==t' && ty==ty' then c + else mkArray(u,t',def',ty') let map_user_view = map_gen true let map = map_gen false (* Like {!map} but with an accumulator. *) +let fold_map_invert f acc = function + | NoInvert -> acc, NoInvert + | CaseInvert {univs;args;} as orig -> + let acc, args' = Array.fold_left_map f acc args in + if args==args' then acc, orig + else acc, CaseInvert {univs;args=args';} + let fold_map f accu c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _) -> accu, c @@ -726,12 +773,13 @@ let fold_map f accu c = match kind c with let accu, l' = List.fold_left_map f accu l in if l'==l then accu, c else accu, mkEvar (e, l') - | Case (ci,p,b,bl) -> + | Case (ci,p,iv,b,bl) -> let accu, b' = f accu b in + let accu, iv' = fold_map_invert f accu iv in let accu, p' = f accu p in let accu, bl' = Array.Smart.fold_left_map f accu bl in - if b'==b && p'==p && bl'==bl then accu, c - else accu, mkCase (ci, p', b', bl') + if b'==b && iv'==iv && p'==p && bl'==bl then accu, c + else accu, mkCase (ci, p', iv', b', bl') | Fix (ln,(lna,tl,bl)) -> let accu, tl' = Array.Smart.fold_left_map f accu tl in let accu, bl' = Array.Smart.fold_left_map f accu bl in @@ -742,6 +790,12 @@ let fold_map f accu c = match kind c with let accu, bl' = Array.Smart.fold_left_map f accu bl in if tl'==tl && bl'==bl then accu, c else accu, mkCoFix (ln,(lna,tl',bl')) + | Array(u,t,def,ty) -> + let accu, t' = Array.Smart.fold_left_map f accu t in + let accu, def' = f accu def in + let accu, ty' = f accu ty in + if def'==def && t==t' && ty==ty' then accu, c + else accu, mkArray(u,t',def',ty') (* [map_with_binders g f n c] maps [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift @@ -786,12 +840,13 @@ let map_with_binders g f l c0 = match kind c0 with let al' = List.Smart.map (fun c -> f l c) al in if al' == al then c0 else mkEvar (e, al') - | Case (ci, p, c, bl) -> + | Case (ci, p, iv, c, bl) -> let p' = f l p in + let iv' = map_invert (f l) iv in let c' = f l c in let bl' = Array.Fun1.Smart.map f l bl in - if p' == p && c' == c && bl' == bl then c0 - else mkCase (ci, p', c', bl') + if p' == p && iv' == iv && c' == c && bl' == bl then c0 + else mkCase (ci, p', iv', c', bl') | Fix (ln, (lna, tl, bl)) -> let tl' = Array.Fun1.Smart.map f l tl in let l' = iterate g (Array.length tl) l in @@ -803,6 +858,12 @@ let map_with_binders g f l c0 = match kind c0 with let l' = iterate g (Array.length tl) l in let bl' = Array.Fun1.Smart.map f l' bl in mkCoFix (ln,(lna,tl',bl')) + | Array(u,t,def,ty) -> + let t' = Array.Fun1.Smart.map f l t in + let def' = f l def in + let ty' = f l ty in + if def'==def && t==t' && ty==ty' then c0 + else mkArray(u,t',def',ty') (*********************) (* Lifting *) @@ -836,7 +897,7 @@ let fold_with_full_binders g f n acc c = | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_,c) -> f n acc c | Evar (_,l) -> List.fold_left (f n) acc l - | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl + | Case (_,p,iv,c,bl) -> Array.fold_left (f n) (f n (fold_invert (f n) (f n acc p) iv) c) bl | Fix (_,(lna,tl,bl)) -> let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in @@ -845,9 +906,10 @@ let fold_with_full_binders g f n acc c = let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + | Array(_u,t,def,ty) -> f n (f n (Array.fold_left (f n) acc t) def) ty -type 'univs instance_compare_fn = GlobRef.t -> int -> +type 'univs instance_compare_fn = (GlobRef.t * int) option -> 'univs -> 'univs -> bool type 'constr constr_compare_fn = int -> 'constr -> 'constr -> bool @@ -863,6 +925,14 @@ type 'constr constr_compare_fn = int -> 'constr -> 'constr -> bool optimisation that physically equal arrays are equals (hence the calls to {!Array.equal_norefl}). *) +let eq_invert eq leq_universes iv1 iv2 = + match iv1, iv2 with + | NoInvert, NoInvert -> true + | NoInvert, CaseInvert _ | CaseInvert _, NoInvert -> false + | CaseInvert {univs;args}, CaseInvert iv2 -> + leq_universes univs iv2.univs + && Array.equal eq args iv2.args + let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t1 t2 = match kind_nocast_gen kind1 t1, kind_nocast_gen kind2 t2 with | Cast _, _ | _, Cast _ -> assert false (* kind_nocast *) @@ -884,20 +954,24 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && List.equal (eq 0) l1 l2 | Const (c1,u1), Const (c2,u2) -> (* The args length currently isn't used but may as well pass it. *) - Constant.equal c1 c2 && leq_universes (GlobRef.ConstRef c1) nargs u1 u2 - | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && leq_universes (GlobRef.IndRef c1) nargs u1 u2 + Constant.equal c1 c2 && leq_universes (Some (GlobRef.ConstRef c1, nargs)) u1 u2 + | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && leq_universes (Some (GlobRef.IndRef c1, nargs)) u1 u2 | Construct (c1,u1), Construct (c2,u2) -> - eq_constructor c1 c2 && leq_universes (GlobRef.ConstructRef c1) nargs u1 u2 - | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> - eq 0 p1 p2 && eq 0 c1 c2 && Array.equal (eq 0) bl1 bl2 + eq_constructor c1 c2 && leq_universes (Some (GlobRef.ConstructRef c1, nargs)) u1 u2 + | Case (_,p1,iv1,c1,bl1), Case (_,p2,iv2,c2,bl2) -> + eq 0 p1 p2 && eq_invert (eq 0) (leq_universes None) iv1 iv2 && eq 0 c1 c2 && Array.equal (eq 0) bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 && Array.equal_norefl (eq 0) tl1 tl2 && Array.equal_norefl (eq 0) bl1 bl2 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> Int.equal ln1 ln2 && Array.equal_norefl (eq 0) tl1 tl2 && Array.equal_norefl (eq 0) bl1 bl2 + | Array(u1,t1,def1,ty1), Array(u2,t2,def2,ty2) -> + leq_universes None u1 u2 && + Array.equal_norefl (eq 0) t1 t2 && + eq 0 def1 def2 && eq 0 ty1 ty2 | (Rel _ | Meta _ | Var _ | Sort _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ | Fix _ - | CoFix _ | Int _ | Float _), _ -> false + | CoFix _ | Int _ | Float _| Array _), _ -> false (* [compare_head_gen_leq u s eq leq c1 c2] compare [c1] and [c2] using [eq] to compare the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, @@ -923,7 +997,7 @@ let compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq t1 t2 = let compare_head_gen eq_universes eq_sorts eq t1 t2 = compare_head_gen_leq eq_universes eq_sorts eq eq t1 t2 -let compare_head = compare_head_gen (fun _ _ -> Univ.Instance.equal) Sorts.equal +let compare_head = compare_head_gen (fun _ -> Univ.Instance.equal) Sorts.equal (*******************************) (* alpha conversion functions *) @@ -932,14 +1006,14 @@ let compare_head = compare_head_gen (fun _ _ -> Univ.Instance.equal) Sorts.equal (* alpha conversion : ignore print names and casts *) let rec eq_constr nargs m n = - (m == n) || compare_head_gen (fun _ _ -> Instance.equal) Sorts.equal eq_constr nargs m n + (m == n) || compare_head_gen (fun _ -> Instance.equal) Sorts.equal eq_constr nargs m n let equal n m = eq_constr 0 m n (* to avoid tracing a recursive fun *) let eq_constr_univs univs m n = if m == n then true else - let eq_universes _ _ = UGraph.check_eq_instances univs in + let eq_universes _ = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = s1 == s2 || UGraph.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in let rec eq_constr' nargs m n = m == n || compare_head_gen eq_universes eq_sorts eq_constr' nargs m n @@ -948,7 +1022,7 @@ let eq_constr_univs univs m n = let leq_constr_univs univs m n = if m == n then true else - let eq_universes _ _ = UGraph.check_eq_instances univs in + let eq_universes _ = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = s1 == s2 || UGraph.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in let leq_sorts s1 s2 = s1 == s2 || @@ -965,7 +1039,7 @@ let eq_constr_univs_infer univs m n = if m == n then true, Constraint.empty else let cstrs = ref Constraint.empty in - let eq_universes _ _ = UGraph.check_eq_instances univs in + let eq_universes _ = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else @@ -985,7 +1059,7 @@ let leq_constr_univs_infer univs m n = if m == n then true, Constraint.empty else let cstrs = ref Constraint.empty in - let eq_universes _ _ l l' = UGraph.check_eq_instances univs l l' in + let eq_universes _ l l' = UGraph.check_eq_instances univs l l' in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else @@ -1015,7 +1089,16 @@ let leq_constr_univs_infer univs m n = res, !cstrs let rec eq_constr_nounivs m n = - (m == n) || compare_head_gen (fun _ _ _ _ -> true) (fun _ _ -> true) (fun _ -> eq_constr_nounivs) 0 m n + (m == n) || compare_head_gen (fun _ _ _ -> true) (fun _ _ -> true) (fun _ -> eq_constr_nounivs) 0 m n + +let compare_invert f iv1 iv2 = + match iv1, iv2 with + | NoInvert, NoInvert -> 0 + | NoInvert, CaseInvert _ -> -1 + | CaseInvert _, NoInvert -> 1 + | CaseInvert iv1, CaseInvert iv2 -> + (* univs ignored deliberately *) + Array.compare f iv1.args iv2.args let constr_ord_int f t1 t2 = let (=?) f g i1 i2 j1 j2= @@ -1060,8 +1143,12 @@ let constr_ord_int f t1 t2 = | Ind _, _ -> -1 | _, Ind _ -> 1 | Construct (ct1,_u1), Construct (ct2,_u2) -> constructor_ord ct1 ct2 | Construct _, _ -> -1 | _, Construct _ -> 1 - | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> - ((f =? f) ==? (Array.compare f)) p1 p2 c1 c2 bl1 bl2 + | Case (_,p1,iv1,c1,bl1), Case (_,p2,iv2,c2,bl2) -> + let c = f p1 p2 in + if Int.equal c 0 then let c = compare_invert f iv1 iv2 in + if Int.equal c 0 then let c = f c1 c2 in + if Int.equal c 0 then Array.compare f bl1 bl2 + else c else c else c | Case _, _ -> -1 | _, Case _ -> 1 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> ((fix_cmp =? (Array.compare f)) ==? (Array.compare f)) @@ -1076,6 +1163,9 @@ let constr_ord_int f t1 t2 = | Int i1, Int i2 -> Uint63.compare i1 i2 | Int _, _ -> -1 | _, Int _ -> 1 | Float f1, Float f2 -> Float64.total_compare f1 f2 + | Array(_u1,t1,def1,ty1), Array(_u2,t2,def2,ty2) -> + (((Array.compare f) =? f) ==? f) t1 t2 def1 def2 ty1 ty2 + | Array _, _ -> -1 | _, Array _ -> 1 let rec compare m n= constr_ord_int compare m n @@ -1129,6 +1219,14 @@ let array_eqeq t1 t2 = (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) in aux 0) +let invert_eqeq iv1 iv2 = + match iv1, iv2 with + | NoInvert, NoInvert -> true + | NoInvert, CaseInvert _ | CaseInvert _, NoInvert -> false + | CaseInvert iv1, CaseInvert iv2 -> + iv1.univs == iv2.univs + && iv1.args == iv2.args + let hasheq t1 t2 = match t1, t2 with | Rel n1, Rel n2 -> n1 == n2 @@ -1146,8 +1244,8 @@ let hasheq t1 t2 = | Const (c1,u1), Const (c2,u2) -> c1 == c2 && u1 == u2 | Ind (ind1,u1), Ind (ind2,u2) -> ind1 == ind2 && u1 == u2 | Construct (cstr1,u1), Construct (cstr2,u2) -> cstr1 == cstr2 && u1 == u2 - | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) -> - ci1 == ci2 && p1 == p2 && c1 == c2 && array_eqeq bl1 bl2 + | Case (ci1,p1,iv1,c1,bl1), Case (ci2,p2,iv2,c2,bl2) -> + ci1 == ci2 && p1 == p2 && invert_eqeq iv1 iv2 && c1 == c2 && array_eqeq bl1 bl2 | Fix ((ln1, i1),(lna1,tl1,bl1)), Fix ((ln2, i2),(lna2,tl2,bl2)) -> Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 @@ -1161,9 +1259,11 @@ let hasheq t1 t2 = && array_eqeq bl1 bl2 | Int i1, Int i2 -> i1 == i2 | Float f1, Float f2 -> Float64.equal f1 f2 + | Array(u1,t1,def1,ty1), Array(u2,t2,def2,ty2) -> + u1 == u2 && def1 == def2 && ty1 == ty2 && array_eqeq t1 t2 | (Rel _ | Meta _ | Var _ | Sort _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ - | Fix _ | CoFix _ | Int _ | Float _), _ -> false + | Fix _ | CoFix _ | Int _ | Float _ | Array _), _ -> false (** Note that the following Make has the side effect of creating once and for all the table we'll use for hash-consing all constr *) @@ -1236,12 +1336,13 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let u', hu = sh_instance u in (Construct (sh_construct c, u'), combinesmall 11 (combine (constructor_syntactic_hash c) hu)) - | Case (ci,p,c,bl) -> + | Case (ci,p,iv,c,bl) -> let p, hp = sh_rec p + and iv, hiv = sh_invert iv and c, hc = sh_rec c in let bl,hbl = hash_term_array bl in - let hbl = combine (combine hc hp) hbl in - (Case (sh_ci ci, p, c, bl), combinesmall 12 hbl) + let hbl = combine4 hc hp hiv hbl in + (Case (sh_ci ci, p, iv, c, bl), combinesmall 12 hbl) | Fix (ln,(lna,tl,bl)) -> let bl,hbl = hash_term_array bl in let tl,htl = hash_term_array tl in @@ -1270,6 +1371,20 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let (h,l) = Uint63.to_int2 i in (t, combinesmall 18 (combine h l)) | Float f -> (t, combinesmall 19 (Float64.hash f)) + | Array (u,t,def,ty) -> + let u, hu = sh_instance u in + let t, ht = hash_term_array t in + let def, hdef = sh_rec def in + let ty, hty = sh_rec ty in + let h = combine4 hu ht hdef hty in + (Array(u,t,def,ty), combinesmall 20 h) + + and sh_invert = function + | NoInvert -> NoInvert, 0 + | CaseInvert {univs;args;} -> + let univs, hu = sh_instance univs in + let args, ha = hash_term_array args in + CaseInvert {univs;args;}, combinesmall 1 (combine hu ha) and sh_rec t = let (y, h) = hash_term t in @@ -1332,8 +1447,8 @@ let rec hash t = combinesmall 10 (combine (ind_hash ind) (Instance.hash u)) | Construct (c,u) -> combinesmall 11 (combine (constructor_hash c) (Instance.hash u)) - | Case (_ , p, c, bl) -> - combinesmall 12 (combine3 (hash c) (hash p) (hash_term_array bl)) + | Case (_ , p, iv, c, bl) -> + combinesmall 12 (combine4 (hash c) (hash p) (hash_invert iv) (hash_term_array bl)) | Fix (_ln ,(_, tl, bl)) -> combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl)) | CoFix(_ln, (_, tl, bl)) -> @@ -1344,6 +1459,13 @@ let rec hash t = combinesmall 17 (combine (Projection.hash p) (hash c)) | Int i -> combinesmall 18 (Uint63.hash i) | Float f -> combinesmall 19 (Float64.hash f) + | Array(u,t,def,ty) -> + combinesmall 20 (combine4 (Instance.hash u) (hash_term_array t) (hash def) (hash ty)) + +and hash_invert = function + | NoInvert -> 0 + | CaseInvert {univs;args;} -> + combinesmall 1 (combine (Instance.hash univs) (hash_term_array args)) and hash_term_array t = Array.fold_left (fun acc t -> combine acc (hash t)) 0 t @@ -1476,9 +1598,9 @@ let rec debug_print c = | Construct (((sp,i),j),u) -> str"Constr(" ++ pr_puniverses (MutInd.print sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")" | Proj (p,c) -> str"Proj(" ++ Constant.debug_print (Projection.constant p) ++ str"," ++ bool (Projection.unfolded p) ++ debug_print c ++ str")" - | Case (_ci,p,c,bl) -> v 0 + | Case (_ci,p,iv,c,bl) -> v 0 (hv 0 (str"<"++debug_print p++str">"++ cut() ++ str"Case " ++ - debug_print c ++ str"of") ++ cut() ++ + debug_print c ++ debug_invert iv ++ str"of") ++ cut() ++ prlist_with_sep (fun _ -> brk(1,2)) debug_print (Array.to_list bl) ++ cut() ++ str"end") | Fix f -> debug_print_fix debug_print f @@ -1492,3 +1614,12 @@ let rec debug_print c = str"}") | Int i -> str"Int("++str (Uint63.to_string i) ++ str")" | Float i -> str"Float("++str (Float64.to_string i) ++ str")" + | Array(u,t,def,ty) -> str"Array(" ++ prlist_with_sep pr_comma debug_print (Array.to_list t) ++ str" | " + ++ debug_print def ++ str " : " ++ debug_print ty + ++ str")@{" ++ Univ.Instance.pr Univ.Level.pr u ++ str"}" + +and debug_invert = let open Pp in function + | NoInvert -> mt() + | CaseInvert {univs;args;} -> + spc() ++ str"Invert {univs=" ++ Instance.pr Level.pr univs ++ + str "; args=" ++ prlist_with_sep spc debug_print (Array.to_list args) ++ str "} " diff --git a/kernel/constr.mli b/kernel/constr.mli index 00051d7551..62f2555a7e 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -49,6 +49,14 @@ type case_info = ci_pp_info : case_printing (* not interpreted by the kernel *) } +type ('constr, 'univs) case_invert = + | NoInvert + (** Normal reduction: match when the scrutinee is a constructor. *) + + | CaseInvert of { univs : 'univs; args : 'constr array; } + (** Reduce when the indices match those of the unique constructor. + (SProp to non SProp only) *) + (** {6 The type of constructions } *) type t @@ -76,6 +84,9 @@ val mkVar : Id.t -> constr (** Constructs a machine integer *) val mkInt : Uint63.t -> constr +(** Constructs an array *) +val mkArray : Univ.Instance.t * constr array * constr * types -> constr + (** Constructs a machine float number *) val mkFloat : Float64.t -> constr @@ -148,7 +159,7 @@ val mkRef : GlobRef.t Univ.puniverses -> constr [ac]{^ ith} element is ith constructor case presented as {e lambda construct_args (without params). case_term } *) -val mkCase : case_info * constr * constr * constr array -> constr +val mkCase : case_info * constr * (constr,Univ.Instance.t) case_invert * constr * constr array -> constr (** If [recindxs = [|i1,...in|]] [funnames = [|f1,.....fn|]] @@ -232,12 +243,13 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Ind of (inductive * 'univs) (** A name of an inductive type defined by [Variant], [Inductive] or [Record] Vernacular-commands. *) | Construct of (constructor * 'univs) (** A constructor of an inductive type defined by [Variant], [Inductive] or [Record] Vernacular-commands. *) - | Case of case_info * 'constr * 'constr * 'constr array + | Case of case_info * 'constr * ('constr,'univs) case_invert * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr | Int of Uint63.t | Float of Float64.t + | Array of 'univs * 'constr array * 'constr * 'types (** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative @@ -339,7 +351,7 @@ Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args return P in t1], or [if c then t1 else t2]) @return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] where [info] is pretty-printing information *) -val destCase : constr -> case_info * constr * constr * constr array +val destCase : constr -> case_info * constr * (constr,Univ.Instance.t) case_invert * constr * constr array (** Destructs a projection *) val destProj : constr -> Projection.t * constr @@ -497,12 +509,16 @@ val fold_with_full_binders : (rel_declaration -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b +val fold_invert : ('a -> 'b -> 'a) -> 'a -> ('b, 'c) case_invert -> 'a + (** [map f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) val map : (constr -> constr) -> constr -> constr +val map_invert : ('a -> 'a) -> ('a, 'b) case_invert -> ('a, 'b) case_invert + (** [map_user_view f c] maps [f] on the immediate subterms of [c]; it differs from [map f c] in that the typing context and body of the return predicate and of the branches of a [match] are considered as @@ -514,6 +530,9 @@ val map_user_view : (constr -> constr) -> constr -> constr val fold_map : ('a -> constr -> 'a * constr) -> 'a -> constr -> 'a * constr +val fold_map_invert : ('a -> 'b -> 'a * 'b) -> + 'a -> ('b, 'c) case_invert -> 'a * ('b, 'c) case_invert + (** [map_with_binders g f n c] maps [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at @@ -529,6 +548,8 @@ val map_with_binders : val iter : (constr -> unit) -> constr -> unit +val iter_invert : ('a -> unit) -> ('a, 'b) case_invert -> unit + (** [iter_with_binders g f n c] iters [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at @@ -558,7 +579,7 @@ val compare_head : constr constr_compare_fn -> constr constr_compare_fn (** Convert a global reference applied to 2 instances. The int says how many arguments are given (as we can only use cumulativity for fully applied inductives/constructors) .*) -type 'univs instance_compare_fn = GlobRef.t -> int -> +type 'univs instance_compare_fn = (GlobRef.t * int) option -> 'univs -> 'univs -> bool (** [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to @@ -605,6 +626,9 @@ val compare_head_gen_leq : Univ.Instance.t instance_compare_fn -> constr constr_compare_fn -> constr constr_compare_fn +val eq_invert : ('a -> 'a -> bool) -> ('b -> 'b -> bool) + -> ('a, 'b) case_invert -> ('a, 'b) case_invert -> bool + (** {6 Hashconsing} *) val hash : constr -> int diff --git a/kernel/cooking.ml b/kernel/cooking.ml index a17aff9b09..fdcf44c943 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -75,23 +75,30 @@ let share_univs cache r u l = let (u', args) = share cache r l in mkApp (instantiate_my_gr r (Instance.append u' u), args) -let update_case_info cache ci modlist = - try - let (_u,l) = share cache (IndRef ci.ci_ind) modlist in - { ci with ci_npar = ci.ci_npar + Array.length l } - with Not_found -> - ci +let update_case cache ci iv modlist = + match share cache (IndRef ci.ci_ind) modlist with + | exception Not_found -> ci, iv + | u, l -> + let iv = match iv with + | NoInvert -> NoInvert + | CaseInvert {univs; args;} -> + let univs = Instance.append u univs in + let args = Array.append l args in + CaseInvert {univs; args;} + in + { ci with ci_npar = ci.ci_npar + Array.length l }, iv let is_empty_modlist (cm, mm) = Cmap.is_empty cm && Mindmap.is_empty mm let expmod_constr cache modlist c = let share_univs = share_univs cache in - let update_case_info = update_case_info cache in + let update_case = update_case cache in let rec substrec c = match kind c with - | Case (ci,p,t,br) -> - Constr.map substrec (mkCase (update_case_info ci modlist,p,t,br)) + | Case (ci,p,iv,t,br) -> + let ci,iv = update_case ci iv modlist in + Constr.map substrec (mkCase (ci,p,iv,t,br)) | Ind (ind,u) -> (try diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index f41585e93a..185fb9f5a4 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -63,6 +63,15 @@ let set_global v = global_data.glob_len <- global_data.glob_len + 1; n +(* Initialization of OCaml primitives *) +let parray_make = set_global Vmvalues.parray_make +let parray_get = set_global Vmvalues.parray_get +let parray_get_default = set_global Vmvalues.parray_get_default +let parray_set = set_global Vmvalues.parray_set +let parray_copy = set_global Vmvalues.parray_copy +let parray_reroot = set_global Vmvalues.parray_reroot +let parray_length = set_global Vmvalues.parray_length + (* table pour les structured_constant et les annotations des switchs *) module SConstTable = Hashtbl.Make (struct @@ -119,6 +128,17 @@ let slot_for_annot key = AnnotTable.add annot_tbl key n; n +let slot_for_caml_prim = + let open CPrimitives in function + | Arraymake -> parray_make + | Arrayget -> parray_get + | Arraydefault -> parray_get_default + | Arrayset -> parray_set + | Arraycopy -> parray_copy + | Arrayreroot -> parray_reroot + | Arraylength -> parray_length + | _ -> assert false + let slot_for_proj_name key = try ProjNameTable.find proj_name_tbl key with Not_found -> @@ -182,6 +202,7 @@ and eval_to_patch env (buff,pl,fv) = | Reloc_const sc -> slot_for_str_cst sc | Reloc_getglobal kn -> slot_for_getglobal env kn | Reloc_proj_name p -> slot_for_proj_name p + | Reloc_caml_prim op -> slot_for_caml_prim op in let tc = patch buff pl slots in let vm_env = diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 2f6a870c8a..7609c1a64d 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -55,7 +55,7 @@ type ('a, 'opaque) constant_def = | Undef of inline (** a global assumption *) | Def of 'a (** or a transparent global definition *) | OpaqueDef of 'opaque (** or an opaque global definition *) - | Primitive of CPrimitives.t (** or a primitive operation *) + | Primitive of CPrimitives.t (** or a primitive operation *) type universes = | Monomorphic of Univ.ContextSet.t @@ -94,6 +94,10 @@ type typing_flags = { cumulative_sprop : bool; (** SProp <= Type *) + + allow_uip: bool; + (** Allow definitional UIP (breaks termination) *) + } (* some contraints are in constant_constraints, some other may be in @@ -112,11 +116,14 @@ type 'opaque constant_body = { } (** {6 Representation of mutual inductive types in the kernel } *) +type nested_type = +| NestedInd of inductive +| NestedPrimitive of Constant.t type recarg = - | Norec - | Mrec of inductive - | Imbr of inductive +| Norec +| Mrec of inductive +| Nested of nested_type type wf_paths = recarg Rtree.t diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 0ab99cab35..326bf0d6ad 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -27,6 +27,7 @@ let safe_flags oracle = { enable_native_compiler = true; indices_matter = true; cumulative_sprop = false; + allow_uip = false; } (** {6 Arities } *) @@ -155,21 +156,47 @@ let hcons_const_body cb = } (** {6 Inductive types } *) +let eq_nested_type t1 t2 = match t1, t2 with +| NestedInd ind1, NestedInd ind2 -> Names.eq_ind ind1 ind2 +| NestedInd _, _ -> false +| NestedPrimitive c1, NestedPrimitive c2 -> Names.Constant.equal c1 c2 +| NestedPrimitive _, _ -> false let eq_recarg r1 r2 = match r1, r2 with | Norec, Norec -> true +| Norec, _ -> false | Mrec i1, Mrec i2 -> Names.eq_ind i1 i2 -| Imbr i1, Imbr i2 -> Names.eq_ind i1 i2 -| _ -> false +| Mrec _, _ -> false +| Nested ty1, Nested ty2 -> eq_nested_type ty1 ty2 +| Nested _, _ -> false + +let pp_recarg = let open Pp in function + | Declarations.Norec -> str "Norec" + | Declarations.Mrec (mind,i) -> + str "Mrec[" ++ Names.MutInd.print mind ++ pr_comma () ++ int i ++ str "]" + | Declarations.(Nested (NestedInd (mind,i))) -> + str "Nested[" ++ Names.MutInd.print mind ++ pr_comma () ++ int i ++ str "]" + | Declarations.(Nested (NestedPrimitive c)) -> + str "Nested[" ++ Names.Constant.print c ++ str "]" + +let pp_wf_paths x = Rtree.pp_tree pp_recarg x + +let subst_nested_type sub ty = match ty with +| NestedInd (kn,i) -> + let kn' = subst_mind sub kn in + if kn==kn' then ty else NestedInd (kn',i) +| NestedPrimitive c -> + let c',_ = subst_con sub c in + if c==c' then ty else NestedPrimitive c' let subst_recarg sub r = match r with | Norec -> r | Mrec (kn,i) -> let kn' = subst_mind sub kn in if kn==kn' then r else Mrec (kn',i) - | Imbr (kn,i) -> - let kn' = subst_mind sub kn in - if kn==kn' then r else Imbr (kn',i) + | Nested ty -> + let ty' = subst_nested_type sub ty in + if ty==ty' then r else Nested ty' let mk_norec = Rtree.mk_node Norec [||] diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 01e4429e7e..4ab8d45e60 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -46,6 +46,9 @@ val is_opaque : 'a constant_body -> bool val eq_recarg : recarg -> recarg -> bool +val pp_recarg : recarg -> Pp.t +val pp_wf_paths : wf_paths -> Pp.t + val subst_recarg : substitution -> recarg -> recarg val mk_norec : wf_paths diff --git a/kernel/entries.ml b/kernel/entries.ml index e0b678621a..ae64112e33 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -91,8 +91,7 @@ type parameter_entry = Id.Set.t option * types in_universes_entry * inline type primitive_entry = { - prim_entry_type : types option; - prim_entry_univs : Univ.ContextSet.t; (* always monomorphic *) + prim_entry_type : types in_universes_entry option; prim_entry_content : CPrimitives.op_or_type; } diff --git a/kernel/environ.ml b/kernel/environ.ml index 182ed55d0e..e75ccbb252 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -449,6 +449,7 @@ let same_flags { enable_VM; enable_native_compiler; cumulative_sprop; + allow_uip; } alt = check_guarded == alt.check_guarded && check_positive == alt.check_positive && @@ -458,7 +459,8 @@ let same_flags { share_reduction == alt.share_reduction && enable_VM == alt.enable_VM && enable_native_compiler == alt.enable_native_compiler && - cumulative_sprop == alt.cumulative_sprop + cumulative_sprop == alt.cumulative_sprop && + allow_uip == alt.allow_uip [@warning "+9"] let set_cumulative_sprop b = map_universes (UGraph.set_cumulative_sprop b) @@ -501,7 +503,7 @@ let constant_type env (kn,u) = type const_evaluation_result = | NoBody | Opaque - | IsPrimitive of CPrimitives.t + | IsPrimitive of Univ.Instance.t * CPrimitives.t exception NotEvaluableConst of const_evaluation_result @@ -533,7 +535,7 @@ let constant_value_in env (kn,u) = subst_instance_constr u b | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) - | Primitive p -> raise (NotEvaluableConst (IsPrimitive p)) + | Primitive p -> raise (NotEvaluableConst (IsPrimitive (u,p))) let constant_opt_value_in env cst = try Some (constant_value_in env cst) diff --git a/kernel/environ.mli b/kernel/environ.mli index f489b13a3b..5cb56a2a29 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -225,7 +225,7 @@ val type_in_type_constant : Constant.t -> env -> bool type const_evaluation_result = | NoBody | Opaque - | IsPrimitive of CPrimitives.t + | IsPrimitive of Univ.Instance.t * CPrimitives.t exception NotEvaluableConst of const_evaluation_result val constant_type : env -> Constant.t puniverses -> types constrained diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml index 0a9f137c45..67a672c349 100644 --- a/kernel/genOpcodeFiles.ml +++ b/kernel/genOpcodeFiles.ml @@ -157,6 +157,10 @@ let opcodes = "CHECKLDSHIFTEXP"; "CHECKNEXTUPFLOAT"; "CHECKNEXTDOWNFLOAT"; + "ISINT_CAML_CALL2"; + "ISARRAY_CAML_CALL1"; + "ISARRAY_INT_CAML_CALL2"; + "ISARRAY_INT_CAML_CALL3"; "STOP" |] diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index e9687991c0..179353d3f0 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -134,11 +134,18 @@ let check_constructors env_ar_par isrecord params lc (arity,indices,univ_info) = (* Empty type: all OK *) | 0 -> univ_info - (* SProp primitive records are OK, if we squash and become fakerecord also OK *) - | 1 when isrecord -> univ_info - - (* Unit and identity types must squash if SProp *) - | 1 -> check_univ_leq env_ar_par Univ.Universe.type0m univ_info + | 1 -> + (* SProp primitive records are OK, if we squash and become fakerecord also OK *) + if isrecord then univ_info + (* 1 constructor with no arguments also OK in SProp (to make + things easier on ourselves when reducing we forbid letins) *) + else if (Environ.typing_flags env_ar_par).allow_uip + && fst (splayed_lc.(0)) = [] + && List.for_all Context.Rel.Declaration.is_local_assum params + then univ_info + (* 1 constructor with arguments must squash if SProp + (we could allow arguments in SProp but the reduction rule is a pain) *) + else check_univ_leq env_ar_par Univ.Universe.type0m univ_info (* More than 1 constructor: must squash if Prop/SProp *) | _ -> check_univ_leq env_ar_par Univ.Universe.type0 univ_info diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 9da6c7842e..a27ff41a1c 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -165,7 +165,7 @@ let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lrecparams) = let decl = LocalAssum (anon, hnf_prod_applist env ty lrecparams) in push_rel decl env in let ra_env' = - (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: + (Nested (NestedInd mi),(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in (* New index of the inductive types *) let newidx = n + auxntyp in @@ -241,6 +241,9 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( discharged to the [check_positive_nested] function. *) if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec) else check_positive_nested ienv nmr (ind_kn, largs) + | Const (c,_) when is_primitive_positive_container env c -> + if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec) + else check_positive_nested_primitive ienv nmr (c, largs) | _err -> (** If an inductive of the mutually inductive block appears in any other way, then the positivy check gives @@ -298,7 +301,16 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr in - (nmr',(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0)) + (nmr',(Rtree.mk_rec [|mk_paths (Nested (NestedInd mi)) irecargs|]).(0)) + + and check_positive_nested_primitive (env,n,ntypes,ra_env) nmr (c, largs) = + (* We model the primitive type c X1 ... Xn as if it had one constructor + C : X1 -> ... -> Xn -> c X1 ... Xn + The subterm relation is defined for each primitive in `inductive.ml`. *) + let ra_env = List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in + let ienv = (env,n,ntypes,ra_env) in + let nmr',recargs = List.fold_left_map (check_pos ienv) nmr largs in + (nmr', (Rtree.mk_rec [| mk_paths (Nested (NestedPrimitive c)) [| recargs |] |]).(0)) (** [check_constructors ienv check_head nmr c] checks the positivity condition in the type [c] of a constructor (i.e. that recursive diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 8423813639..d751d9875a 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -464,11 +464,16 @@ let eq_wf_paths = Rtree.equal Declareops.eq_recarg let inter_recarg r1 r2 = match r1, r2 with | Norec, Norec -> Some r1 +| Norec, _ -> None | Mrec i1, Mrec i2 -| Imbr i1, Imbr i2 -| Mrec i1, Imbr i2 -> if Names.eq_ind i1 i2 then Some r1 else None -| Imbr i1, Mrec i2 -> if Names.eq_ind i1 i2 then Some r2 else None -| _ -> None +| Nested (NestedInd i1), Nested (NestedInd i2) +| Mrec i1, (Nested (NestedInd i2)) -> if Names.eq_ind i1 i2 then Some r1 else None +| Mrec _, _ -> None +| Nested (NestedInd i1), Mrec i2 -> if Names.eq_ind i1 i2 then Some r2 else None +| Nested (NestedInd _), _ -> None +| Nested (NestedPrimitive c1), Nested (NestedPrimitive c2) -> + if Names.Constant.equal c1 c2 then Some r1 else None +| Nested (NestedPrimitive _), _ -> None let inter_wf_paths = Rtree.inter Declareops.eq_recarg inter_recarg Norec @@ -551,8 +556,8 @@ let lookup_subterms env ind = let match_inductive ind ra = match ra with - | (Mrec i | Imbr i) -> eq_ind ind i - | Norec -> false + | Mrec i | Nested (NestedInd i) -> eq_ind ind i + | Norec | Nested (NestedPrimitive _) -> false (* In {match c as z in ci y_s return P with |C_i x_s => t end} [branches_specif renv c_spec ci] returns an array of x_s specs knowing @@ -603,7 +608,7 @@ let ienv_push_inductive (env, ra_env) ((mind,u),lpar) = push_rel decl env in let env = Array.fold_right push_ind mib.mind_packets env in - let rc = Array.mapi (fun j t -> (Imbr (mind,j),t)) (Rtree.mk_rec_calls ntypes) in + let rc = Array.mapi (fun j t -> (Nested (NestedInd (mind,j)),t)) (Rtree.mk_rec_calls ntypes) in let lra_ind = Array.rev_to_list rc in let ra_env = List.map (fun (r,t) -> (r,Rtree.lift ntypes t)) ra_env in (env, lra_ind @ ra_env) @@ -637,6 +642,11 @@ let abstract_mind_lc ntyps npars lc = in Array.map (substl make_abs) lc +let is_primitive_positive_container env c = + match env.retroknowledge.Retroknowledge.retro_array with + | Some c' when Constant.equal c c' -> true + | _ -> false + (* [get_recargs_approx env tree ind args] builds an approximation of the recargs tree for ind, knowing args. The argument tree is used to know when candidate nested types should be traversed, pruning the tree otherwise. This code is very @@ -657,8 +667,14 @@ let get_recargs_approx env tree ind args = (* When the inferred tree allows it, we consider that we have a potential nested inductive type *) begin match dest_recarg tree with - | Imbr kn' | Mrec kn' when eq_ind (fst ind_kn) kn' -> - build_recargs_nested ienv tree (ind_kn, largs) + | Nested (NestedInd kn') | Mrec kn' when eq_ind (fst ind_kn) kn' -> + build_recargs_nested ienv tree (ind_kn, largs) + | _ -> mk_norec + end + | Const (c,_) when is_primitive_positive_container env c -> + begin match dest_recarg tree with + | Nested (NestedPrimitive c') when Constant.equal c c' -> + build_recargs_nested_primitive ienv tree (c, largs) | _ -> mk_norec end | _err -> @@ -696,11 +712,21 @@ let get_recargs_approx env tree ind args = build_recargs_constructors ienv' trees.(j).(k) c') auxlcvect in - mk_paths (Imbr (mind,j)) paths + mk_paths (Nested (NestedInd (mind,j))) paths in let irecargs = Array.mapi mk_irecargs mib.mind_packets in (Rtree.mk_rec irecargs).(i) + and build_recargs_nested_primitive (env, ra_env) tree (c, largs) = + if eq_wf_paths tree mk_norec then tree + else + let ntypes = 1 in (* Primitive types are modelled by non-mutual inductive types *) + let ra_env = List.map (fun (r,t) -> (r,Rtree.lift ntypes t)) ra_env in + let ienv = (env, ra_env) in + let paths = List.map2 (build_recargs ienv) (dest_subterms tree).(0) largs in + let recargs = [| mk_paths (Nested (NestedPrimitive c)) [| paths |] |] in + (Rtree.mk_rec recargs).(0) + and build_recargs_constructors ienv trees c = let rec recargs_constr_rec (env,_ra_env as ienv) trees lrec c = let x,largs = decompose_app (whd_all env c) in @@ -756,7 +782,7 @@ let rec subterm_specif renv stack t = let f,l = decompose_app (whd_all renv.env t) in match kind f with | Rel k -> subterm_var k renv - | Case (ci,p,c,lbr) -> + | Case (ci,p,_iv,c,lbr) -> (* iv ignored: it's just a cache *) let stack' = push_stack_closures renv l stack in let cases_spec = branches_specif renv (lazy_subterm_specif renv [] c) ci @@ -829,8 +855,17 @@ let rec subterm_specif renv stack t = | Dead_code -> Dead_code | Not_subterm -> Not_subterm) - | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ | Ind _ - | Construct _ | CoFix _ | Int _ | Float _ -> Not_subterm + | Const c -> + begin try + let _ = Environ.constant_value_in renv.env c in Not_subterm + with + | NotEvaluableConst (IsPrimitive (_u,op)) when List.length l >= CPrimitives.arity op -> + primitive_specif renv op l + | NotEvaluableConst _ -> Not_subterm + end + + | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Ind _ + | Construct _ | CoFix _ | Int _ | Float _ | Array _ -> Not_subterm (* Other terms are not subterms *) @@ -846,6 +881,24 @@ and extract_stack = function | [] -> Lazy.from_val Not_subterm , [] | h::t -> stack_element_specif h, t +and primitive_specif renv op args = + let open CPrimitives in + match op with + | Arrayget | Arraydefault -> + (* t.[i] and default t can be seend as strict subterms of t, with a + potentially nested rectree. *) + let arg = List.nth args 1 in (* the result is a strict subterm of the second argument *) + let subt = subterm_specif renv [] arg in + begin match subt with + | Subterm (_s, wf) -> + let wf_args = (dest_subterms wf).(0) in + spec_of_tree (List.nth wf_args 0) (* first and only parameter of `array` *) + | Dead_code -> Dead_code + | Not_subterm -> Not_subterm + end + | _ -> Not_subterm + + (* Check term c can be applied to one of the mutual fixpoints. *) let check_is_subterm x tree = match Lazy.force x with @@ -954,7 +1007,7 @@ let check_one_fix renv recpos trees def = check_rec_call renv stack (Term.applist(lift p c,l)) end - | Case (ci,p,c_0,lrest) -> + | Case (ci,p,iv,c_0,lrest) -> (* iv ignored: it's just a cache *) begin try List.iter (check_rec_call renv []) (c_0::p::l); (* compute the recarg info for the arguments of each branch *) @@ -976,7 +1029,7 @@ let check_one_fix renv recpos trees def = (* the call to whd_betaiotazeta will reduce the apparent iota redex away *) check_rec_call renv [] - (Term.applist (mkCase (ci,p,c_0,lrest), l)) + (Term.applist (mkCase (ci,p,iv,c_0,lrest), l)) | _ -> Exninfo.iraise exn end @@ -1086,6 +1139,12 @@ let check_one_fix renv recpos trees def = | Sort _ | Int _ | Float _ -> assert (List.is_empty l) + | Array (_u, t,def,ty) -> + assert (List.is_empty l); + Array.iter (check_rec_call renv []) t; + check_rec_call renv [] def; + check_rec_call renv [] ty + (* l is not checked because it is considered as the meta's context *) | (Evar _ | Meta _) -> () @@ -1254,7 +1313,7 @@ let check_one_cofix env nbfix def deftype = else raise (CoFixGuardError (env,UnguardedRecursiveCall c)) - | Case (_,p,tm,vrest) -> + | Case (_,p,_,tm,vrest) -> (* iv ignored: just a cache *) begin let tree = match restrict_spec env (Subterm (Strict, tree)) p with | Dead_code -> assert false @@ -1278,7 +1337,7 @@ let check_one_cofix env nbfix def deftype = | Evar _ -> List.iter (check_rec_call env alreadygrd n tree vlra) args | Rel _ | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ - | Ind _ | Fix _ | Proj _ | Int _ | Float _ -> + | Ind _ | Fix _ | Proj _ | Int _ | Float _ | Array _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in let ((mind, _),_) = codomain_is_coind env deftype in diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 9f865f8f01..78658dc4de 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -105,6 +105,13 @@ val check_case_info : env -> pinductive -> Sorts.relevance -> case_info -> unit (** {6 Guard conditions for fix and cofix-points. } *) +(** [is_primitive_positive_container env c] tells if the constant [c] is + registered as a primitive type that can be seen as a container where the + occurrences of its parameters are positive, in which case the positivity and + guard conditions are extended to allow inductive types to nest their subterms + in these containers. *) +val is_primitive_positive_container : env -> Constant.t -> bool + (** When [chk] is false, the guard condition is not actually checked. *) val check_fix : env -> fixpoint -> unit diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml index 662ad550b8..8191a5b0f3 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -138,6 +138,18 @@ let rec infer_fterm cv_pb infos variances hd stk = let le = Esubst.subs_liftn n e in let variances = infer_vect infos variances (Array.map (mk_clos le) cl) in infer_stack infos variances stk + | FArray (u,elemsdef,ty) -> + let variances = infer_generic_instance_eq variances u in + let variances = infer_fterm CONV infos variances ty [] in + let elems, def = Parray.to_array elemsdef in + let variances = infer_fterm CONV infos variances def [] in + let variances = infer_vect infos variances elems in + infer_stack infos variances stk + + | FCaseInvert (_,p,_,_,br,e) -> + let infer c variances = infer_fterm CONV infos variances (mk_clos e c) [] in + let variances = infer p variances in + Array.fold_right infer br variances (* Removed by whnf *) | FLOCKED | FCaseT _ | FLetIn _ | FApp _ | FLIFT _ | FCLOS _ -> assert false diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index cc9da3a2ce..41388d9f17 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -1,8 +1,8 @@ Names TransparentState Uint63 +Parray Float64 -CPrimitives Univ UGraph Esubst @@ -12,6 +12,7 @@ Context Constr Vars Term +CPrimitives Mod_subst Vmvalues Cbytecodes diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 317141e324..2aeb1ea202 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -364,20 +364,21 @@ let rec map_kn f f' c = | Construct (((kn,i),j),u) -> let kn' = f kn in if kn'==kn then c else mkConstructU (((kn',i),j),u) - | Case (ci,p,ct,l) -> + | Case (ci,p,iv,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in let kn' = f kn in if kn'==kn then ci.ci_ind else kn',i in let p' = func p in + let iv' = map_invert func iv in let ct' = func ct in let l' = Array.Smart.map func l in - if (ci.ci_ind==ci_ind && p'==p + if (ci.ci_ind==ci_ind && p'==p && iv'==iv && l'==l && ct'==ct)then c else mkCase ({ci with ci_ind = ci_ind}, - p',ct', l') + p',iv',ct', l') | Cast (ct,k,t) -> let ct' = func ct in let t'= func t in diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index f30ddce4d7..ae070e6f8e 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -259,6 +259,7 @@ type primitive = | Mk_proj | Is_int | Is_float + | Is_parray | Cast_accu | Upd_cofix | Force_cofix @@ -285,7 +286,8 @@ type primitive = | MLmagic | MLarrayget | Mk_empty_instance - | Coq_primitive of CPrimitives.t * (prefix * pconstant) option + | MLparray_of_array + | Coq_primitive of CPrimitives.t * bool (* check for accu *) let eq_primitive p1 p2 = match p1, p2 with @@ -346,15 +348,15 @@ let primitive_hash = function | MLsub -> 31 | MLmul -> 32 | MLmagic -> 33 - | Coq_primitive (prim, None) -> combinesmall 34 (CPrimitives.hash prim) - | Coq_primitive (prim, Some (prefix,(kn,_))) -> - combinesmall 35 (combine3 (String.hash prefix) (Constant.hash kn) (CPrimitives.hash prim)) - | Mk_proj -> 36 - | MLarrayget -> 37 - | Mk_empty_instance -> 38 - | Mk_float -> 39 - | Is_float -> 40 + | Coq_primitive (prim, b) -> combinesmall 34 (combine (CPrimitives.hash prim) (Hashtbl.hash b)) + | Mk_proj -> 35 + | MLarrayget -> 36 + | Mk_empty_instance -> 37 + | Mk_float -> 38 + | Is_float -> 39 + | Is_parray -> 41 | MLnot -> 41 + | MLparray_of_array -> 42 type mllambda = | MLlocal of lname @@ -971,11 +973,14 @@ type prim_aux = let add_check cond targs args = let aux cond t a = - match a with - | PAml(MLint _) -> cond - | PAml ml -> + match t, a with + | CPrimitives.(PITT_type (PT_int63, _)), PAml(MLapp(MLprimitive Mk_uint, _)) -> cond + | CPrimitives.(PITT_type (PT_array, _)), PAml(MLapp(MLprimitive MLparray_of_array, _)) -> cond + | CPrimitives.(PITT_type (PT_array, _)), PAml(MLapp (MLglobal (Ginternal "get_value"),_)) -> cond + | CPrimitives.(PITT_type (prim_ty, _)), PAml ml -> (* FIXME: use explicit equality function *) - if List.mem (t, ml) cond then cond else (t, ml)::cond + let c = (CPrimitives.PTE prim_ty, ml) in + if List.mem c cond then cond else c::cond | _ -> cond in Array.fold_left2 aux cond targs args @@ -985,13 +990,15 @@ let extract_prim ml_of l = let cond = ref [] in let type_args p = let rec aux = function [] | [_] -> [] | h :: t -> h :: aux t in - Array.of_list (aux (CPrimitives.types p)) in + let params, sign = CPrimitives.types p in + List.length params, Array.of_list (aux sign) in let rec aux l = match l with | Lprim(prefix,kn,p,args) -> - let targs = type_args p in + let nparams, targs = type_args p in let args = Array.map aux args in - cond := add_check !cond targs args; + let checked_args = Array.init (Array.length args - nparams) (fun i -> args.(i+nparams)) in + cond := add_check !cond targs checked_args; PAprim(prefix,kn,p,args) | Lrel _ | Lvar _ | Luint _ | Lval _ | Lconst _ -> PAml (ml_of l) | _ -> @@ -1006,31 +1013,48 @@ let cast_to_int v = | MLint _ -> v | _ -> MLapp(MLprimitive Val_to_int, [|v|]) -let compile_prim decl cond paux = +let ml_of_instance instance u = + let ml_of_level l = + match Univ.Level.var_index l with + | Some i -> + let univ = MLapp(MLprimitive MLmagic, [|MLlocal (Option.get instance)|]) in + mkMLapp (MLprimitive MLarrayget) [|univ; MLint i|] + | None -> let i = push_symbol (SymbLevel l) in get_level_code i + in + let u = Univ.Instance.to_array u in + if Array.is_empty u then [||] + else let u = Array.map ml_of_level u in + [|MLapp (MLprimitive MLmagic, [|MLarray u|])|] + +let compile_prim env decl cond paux = let rec opt_prim_aux paux = match paux with | PAprim(_prefix, _kn, op, args) -> - let args = Array.map opt_prim_aux args in - app_prim (Coq_primitive(op,None)) args + let n = CPrimitives.nparams op in + let args = Array.map opt_prim_aux (Array.sub args n (Array.length args - n)) in + app_prim (Coq_primitive(op, false)) args | PAml ml -> ml and naive_prim_aux paux = match paux with - | PAprim(prefix, kn, op, args) -> - app_prim (Coq_primitive(op, Some (prefix,kn))) (Array.map naive_prim_aux args) + | PAprim(prefix, (kn,u), op, args) -> + let uarg = ml_of_instance env.env_univ u in + let prim_const = mkMLapp (MLglobal (Gconstant(prefix,kn))) uarg in + let prim = mkMLapp (MLprimitive(Coq_primitive(op, true))) [|prim_const|] in + mkMLapp prim (Array.map naive_prim_aux args) | PAml ml -> ml in let compile_cond cond paux = match cond with | [] -> opt_prim_aux paux - | [CPrimitives.(PITT_type PT_int63), c1] -> + | [CPrimitives.(PTE PT_int63), c1] -> MLif(app_prim Is_int [|c1|], opt_prim_aux paux, naive_prim_aux paux) | _ -> - let ci, cf = + let ci, co = let is_int = - function CPrimitives.(PITT_type PT_int63), _ -> true | _ -> false in + function CPrimitives.(PTE PT_int63), _ -> true | _ -> false in List.partition is_int cond in let condi = let cond = @@ -1038,21 +1062,25 @@ let compile_prim decl cond paux = (fun ml (_, c) -> app_prim MLland [| ml; cast_to_int c|]) (MLint 0) ci in app_prim MLmagic [|cond|] in - let condf = match cf with + let condo = match co with | [] -> MLint 0 - | [_, c1] -> app_prim Is_float [|c1|] - | (_, c1) :: condf -> + | (CPrimitives.PTE ty, c1) :: condo -> + let check = match ty with + | CPrimitives.PT_float64 -> Is_float + | CPrimitives.PT_array -> Is_parray + | CPrimitives.PT_int63 -> assert false + in List.fold_left - (fun ml (_, c) -> app_prim MLand [| ml; app_prim Is_float [|c|]|]) - (app_prim Is_float [|c1|]) condf in - match ci, cf with + (fun ml (_, c) -> app_prim MLand [| ml; app_prim check [|c|]|]) + (app_prim check [|c1|]) condo in + match ci, co with | [], [] -> opt_prim_aux paux | _ :: _, [] -> MLif(condi, naive_prim_aux paux, opt_prim_aux paux) | [], _ :: _ -> - MLif(condf, opt_prim_aux paux, naive_prim_aux paux) + MLif(condo, opt_prim_aux paux, naive_prim_aux paux) | _ :: _, _ :: _ -> - let cond = app_prim MLand [|condf; app_prim MLnot [|condi|]|] in + let cond = app_prim MLand [|condo; app_prim MLnot [|condi|]|] in MLif(cond, opt_prim_aux paux, naive_prim_aux paux) in let add_decl decl body = @@ -1065,19 +1093,6 @@ let compile_prim decl cond paux = else add_decl decl (compile_cond cond paux) -let ml_of_instance instance u = - let ml_of_level l = - match Univ.Level.var_index l with - | Some i -> - let univ = MLapp(MLprimitive MLmagic, [|MLlocal (Option.get instance)|]) in - mkMLapp (MLprimitive MLarrayget) [|univ; MLint i|] - | None -> let i = push_symbol (SymbLevel l) in get_level_code i - in - let u = Univ.Instance.to_array u in - if Array.is_empty u then [||] - else let u = Array.map ml_of_level u in - [|MLapp (MLprimitive MLmagic, [|MLarray u|])|] - let rec ml_of_lam env l t = match t with | Lrel(id ,i) -> get_rel env id i @@ -1118,7 +1133,7 @@ let ml_of_instance instance u = | Lproj (prefix, ind, i) -> MLglobal(Gproj (prefix, ind, i)) | Lprim _ -> let decl,cond,paux = extract_prim (ml_of_lam env l) t in - compile_prim decl cond paux + compile_prim env decl cond paux | Lcase (annot,p,a,bs) -> (* let predicate_uid fv_pred = compilation of p let rec case_uid fv a_uid = @@ -1333,6 +1348,9 @@ let ml_of_instance instance u = MLconstruct(prefix,cn,tag,args) | Luint i -> MLapp(MLprimitive Mk_uint, [|MLuint i|]) | Lfloat f -> MLapp(MLprimitive Mk_float, [|MLfloat f|]) + | Lparray (t,def) -> + let def = ml_of_lam env l def in + MLapp(MLprimitive MLparray_of_array, [| MLarray (Array.map (ml_of_lam env l) t); def |]) | Lval v -> let i = push_symbol (SymbValue v) in get_value_code i | Lsort s -> @@ -1777,6 +1795,7 @@ let pp_mllam fmt l = | Mk_proj -> Format.fprintf fmt "mk_proj_accu" | Is_int -> Format.fprintf fmt "is_int" | Is_float -> Format.fprintf fmt "is_float" + | Is_parray -> Format.fprintf fmt "is_parray" | Cast_accu -> Format.fprintf fmt "cast_accu" | Upd_cofix -> Format.fprintf fmt "upd_cofix" | Force_cofix -> Format.fprintf fmt "force_cofix" @@ -1803,11 +1822,10 @@ let pp_mllam fmt l = | MLmagic -> Format.fprintf fmt "Obj.magic" | MLarrayget -> Format.fprintf fmt "Array.get" | Mk_empty_instance -> Format.fprintf fmt "Univ.Instance.empty" - | Coq_primitive (op,None) -> + | MLparray_of_array -> Format.fprintf fmt "parray_of_array" + | Coq_primitive (op, false) -> Format.fprintf fmt "no_check_%s" (CPrimitives.to_string op) - | Coq_primitive (op, Some (prefix,(c,_))) -> - Format.fprintf fmt "%s %a" (CPrimitives.to_string op) - pp_mllam (MLglobal (Gconstant (prefix,c))) + | Coq_primitive (op, true) -> Format.fprintf fmt "%s" (CPrimitives.to_string op) in Format.fprintf fmt "@[%a@]" pp_mllam l @@ -2088,7 +2106,7 @@ let compile_deps env sigma prefix ~interactive init t = | Proj (p,c) -> let init = compile_mind_deps env prefix ~interactive init (Projection.mind p) in aux env lvl init c - | Case (ci, _p, _c, _ac) -> + | Case (ci, _p, _iv, _c, _ac) -> let mind = fst ci.ci_ind in let init = compile_mind_deps env prefix ~interactive init mind in fold_constr_with_binders succ (aux env) lvl init t diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index 31a716a786..01e9550ec5 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -38,6 +38,10 @@ let rec conv_val env pb lvl v1 v2 cu = | Vfloat64 f1, Vfloat64 f2 -> if Float64.(equal (of_float f1) (of_float f2)) then cu else raise NotConvertible + | Varray t1, Varray t2 -> + let len = Parray.length_int t1 in + if not (Int.equal len (Parray.length_int t2)) then raise NotConvertible; + Parray.fold_left2 (fun cu v1 v2 -> conv_val env CONV lvl v1 v2 cu) cu t1 t2 | Vblock b1, Vblock b2 -> let n1 = block_size b1 in let n2 = block_size b2 in @@ -51,7 +55,7 @@ let rec conv_val env pb lvl v1 v2 cu = aux lvl max b1 b2 (i+1) cu in aux lvl (n1-1) b1 b2 0 cu - | (Vaccu _ | Vconst _ | Vint64 _ | Vfloat64 _ | Vblock _), _ -> raise NotConvertible + | (Vaccu _ | Vconst _ | Vint64 _ | Vfloat64 _ | Varray _ | Vblock _), _ -> raise NotConvertible and conv_accu env pb lvl k1 k2 cu = let n1 = accu_nargs k1 in diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 02ee501f5f..b00b96018f 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -40,6 +40,7 @@ type lambda = | Lfix of (int array * (string * inductive) array * int) * fix_decl | Lcofix of int * fix_decl | Lint of int (* a constant constructor *) + | Lparray of lambda array * lambda | Lmakeblock of prefix * inductive * int * lambda array (* prefix, inductive name, constructor tag, arguments *) (* A fully applied non-constant constructor *) @@ -187,6 +188,10 @@ let map_lam_with_binders g f n lam = | Levar (evk, args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Levar (evk, args') + | Lparray (p,def) -> + let p' = Array.Smart.map (f n) p in + let def' = f n def in + if def' == def && p == p' then lam else Lparray (p', def') (*s Lift and substitution *) @@ -377,6 +382,12 @@ let makeblock env ind tag nparams arity args = let prefix = get_mind_prefix env (fst ind) in Lmakeblock(prefix, ind, tag, args) +let makearray args def = + try + let p = Array.map get_value args in + Lval (Nativevalues.parray_of_array p (get_value def)) + with Not_found -> Lparray (args, def) + (* Translation of constants *) let rec get_alias env (kn, u as p) = @@ -400,8 +411,13 @@ let expand_prim env kn op arity = let lambda_of_prim env kn op args = let arity = CPrimitives.arity op in - if Array.length args >= arity then prim env kn op args - else mkLapp (expand_prim env kn op arity) args + match Int.compare (Array.length args) arity with + | 0 -> prim env kn op args + | x when x > 0 -> + let prim_args = Array.sub args 0 arity in + let extra_args = Array.sub args arity (Array.length args - arity) in + mkLapp(prim env kn op prim_args) extra_args + | _ -> mkLapp (expand_prim env kn op arity) args (*i Global environment *) @@ -521,7 +537,7 @@ let rec lambda_of_constr cache env sigma c = let prefix = get_mind_prefix env (fst ind) in mkLapp (Lproj (prefix, ind, Projection.arg p)) [|lambda_of_constr cache env sigma c|] - | Case(ci,t,a,branches) -> + | Case(ci,t,_iv,a,branches) -> (* XXX handle iv *) let (mind,i as ind) = ci.ci_ind in let mib = lookup_mind mind env in let oib = mib.mind_packets.(i) in @@ -589,6 +605,10 @@ let rec lambda_of_constr cache env sigma c = | Float f -> Lfloat f + | Array (_u, t, def, _ty) -> + let def = lambda_of_constr cache env sigma def in + makearray (lambda_of_args cache env sigma 0 t) def + and lambda_of_app cache env sigma f args = match kind f with | Const (_kn,_u as c) -> diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index e339286329..619d362f35 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -34,6 +34,7 @@ type lambda = | Lfix of (int array * (string * inductive) array * int) * fix_decl | Lcofix of int * fix_decl | Lint of int (* a constant constructor *) + | Lparray of lambda array * lambda | Lmakeblock of prefix * inductive * int * lambda array (* prefix, inductive name, constructor tag, arguments *) (* A fully applied non-constant constructor *) diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index a5fcfae1fc..9e17f97a56 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -244,6 +244,7 @@ type kind_of_value = | Vconst of int | Vint64 of int64 | Vfloat64 of float + | Varray of t Parray.t | Vblock of block let kind_of_value (v:t) = @@ -253,7 +254,8 @@ let kind_of_value (v:t) = else let tag = Obj.tag o in if Int.equal tag accumulate_tag then - Vaccu (Obj.magic v) + if Int.equal (Obj.size o) 1 then Varray (Obj.magic v) + else Vaccu (Obj.magic v) else if Int.equal tag Obj.custom_tag then Vint64 (Obj.magic v) else if Int.equal tag Obj.double_tag then Vfloat64 (Obj.magic v) else if (tag < Obj.lazy_tag) then Vblock (Obj.magic v) @@ -686,6 +688,84 @@ let next_down accu x = if is_float x then no_check_next_down x else accu x +let is_parray t = + let t = Obj.magic t in + Obj.is_block t && Obj.size t = 1 + +let to_parray t = Obj.magic t +let of_parray t = Obj.magic t + +let no_check_arraymake n def = + of_parray (Parray.make (to_uint n) def) + +let arraymake accu vA n def = + if is_int n then + no_check_arraymake n def + else accu vA n def + +let no_check_arrayget t n = + Parray.get (to_parray t) (to_uint n) +[@@ocaml.inline always] + +let arrayget accu vA t n = + if is_parray t && is_int n then + no_check_arrayget t n + else accu vA t n + +let no_check_arraydefault t = + Parray.default (to_parray t) +[@@ocaml.inline always] + +let arraydefault accu vA t = + if is_parray t then + no_check_arraydefault t + else accu vA t + +let no_check_arrayset t n v = + of_parray (Parray.set (to_parray t) (to_uint n) v) +[@@ocaml.inline always] + +let arrayset accu vA t n v = + if is_parray t && is_int n then + no_check_arrayset t n v + else accu vA t n v + +let no_check_arraycopy t = + of_parray (Parray.copy (to_parray t)) +[@@ocaml.inline always] + +let arraycopy accu vA t = + if is_parray t then + no_check_arraycopy t + else accu vA t + +let no_check_arrayreroot t = + of_parray (Parray.reroot (to_parray t)) +[@@ocaml.inline always] + +let arrayreroot accu vA t = + if is_parray t then + no_check_arrayreroot t + else accu vA t + +let no_check_arraylength t = + mk_uint (Parray.length (to_parray t)) +[@@ocaml.inline always] + +let arraylength accu vA t = + if is_parray t then + no_check_arraylength t + else accu vA t + +let parray_of_array t def = + (Obj.magic (Parray.unsafe_of_array t def) : t) + +let arrayinit n (f:t->t) def = + of_parray (Parray.init (to_uint n) (Obj.magic f) def) + +let arraymap f t = + of_parray (Parray.map f (to_parray t)) + let hobcnv = Array.init 256 (fun i -> Printf.sprintf "%02x" i) let bohcnv = Array.init 256 (fun i -> i - (if 0x30 <= i then 0x30 else 0) - diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index 78a9b2ea13..08c5bd7126 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -134,6 +134,7 @@ type kind_of_value = | Vconst of int | Vint64 of int64 | Vfloat64 of float + | Varray of t Parray.t | Vblock of block val kind_of_value : t -> kind_of_value @@ -332,3 +333,39 @@ val no_check_next_up : t -> t val no_check_next_down : t -> t [@@ocaml.inline always] + +(** Support for arrays *) + +val parray_of_array : t array -> t -> t +val is_parray : t -> bool + +val arraymake : t -> t -> t -> t -> t (* accu A n def *) +val arrayget : t -> t -> t -> t -> t (* accu A t n *) +val arraydefault : t -> t -> t (* accu A t *) +val arrayset : t -> t -> t -> t -> t -> t (* accu A t n v *) +val arraycopy : t -> t -> t -> t (* accu A t *) +val arrayreroot : t -> t -> t -> t (* accu A t *) +val arraylength : t -> t -> t -> t (* accu A t *) +val arrayinit : t -> t -> t -> t (* accu A n f def *) +val arraymap : t -> t -> t (* accu A B f t *) + +val no_check_arraymake : t -> t -> t +[@@ocaml.inline always] + +val no_check_arrayget : t -> t -> t -> t +[@@ocaml.inline always] + +val no_check_arraydefault : t -> t +[@@ocaml.inline always] + +val no_check_arrayset : t -> t -> t -> t +[@@ocaml.inline always] + +val no_check_arraycopy : t -> t +[@@ocaml.inline always] + +val no_check_arrayreroot : t -> t +[@@ocaml.inline always] + +val no_check_arraylength : t -> t +[@@ocaml.inline always] diff --git a/kernel/parray.ml b/kernel/parray.ml new file mode 100644 index 0000000000..ea314c1883 --- /dev/null +++ b/kernel/parray.ml @@ -0,0 +1,124 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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) *) +(************************************************************************) + +let max_array_length32 = 4194303 + +let max_length = Uint63.of_int max_array_length32 + +let length_to_int i = snd (Uint63.to_int2 i) + +let trunc_size n = + if Uint63.le Uint63.zero n && Uint63.lt n (Uint63.of_int max_array_length32) then + length_to_int n + else max_array_length32 + +type 'a t = ('a kind) ref +and 'a kind = + | Array of 'a array * 'a + | Updated of int * 'a * 'a t + +let unsafe_of_array t def = ref (Array (t,def)) +let of_array t def = unsafe_of_array (Array.copy t) def + +let rec length_int p = + match !p with + | Array (t,_) -> Array.length t + | Updated (_, _, p) -> length_int p + +let length p = Uint63.of_int @@ length_int p + +let rec get p n = + match !p with + | Array (t,def) -> + let l = Array.length t in + if Uint63.le Uint63.zero n && Uint63.lt n (Uint63.of_int l) then + Array.unsafe_get t (length_to_int n) + else def + | Updated (k,e,p) -> + if Uint63.equal n (Uint63.of_int k) then e + else get p n + +let set p n e = + let kind = !p in + match kind with + | Array (t,_) -> + let l = Uint63.of_int @@ Array.length t in + if Uint63.le Uint63.zero n && Uint63.lt n l then + let res = ref kind in + let n = length_to_int n in + p := Updated (n, Array.unsafe_get t n, res); + Array.unsafe_set t n e; + res + else p + | Updated _ -> + if Uint63.le Uint63.zero n && Uint63.lt n (length p) then + ref (Updated((length_to_int n), e, p)) + else p + +let rec default p = + match !p with + | Array (_,def) -> def + | Updated (_,_,p) -> default p + +let make n def = + ref (Array (Array.make (trunc_size n) def, def)) + +let init n f def = + let n = trunc_size n in + let t = Array.init n f in + ref (Array (t, def)) + +let rec to_array p = + match !p with + | Array (t,def) -> Array.copy t, def + | Updated (n,e,p) -> + let (t,_) as r = to_array p in + Array.unsafe_set t n e; r + +let copy p = + let (t,def) = to_array p in + ref (Array (t,def)) + +let rec rerootk t k = + match !t with + | Array _ -> k () + | Updated (i, v, t') -> + let k' () = + begin match !t' with + | Array (a,_def) as n -> + let v' = a.(i) in + Array.unsafe_set a i v; + t := n; + t' := Updated (i, v', t) + | Updated _ -> assert false + end; k() in + rerootk t' k' + +let reroot t = rerootk t (fun () -> t) + +let map f p = + let p = reroot p in + match !p with + | Array (t,def) -> ref (Array (Array.map f t, f def)) + | Updated _ -> assert false + +let fold_left f x p = + let p = reroot p in + match !p with + | Array (t,def) -> f (Array.fold_left f x t) def + | Updated _ -> assert false + +let fold_left2 f a p1 p2 = + let p1 = reroot p1 in + let p2 = reroot p2 in + match !p1, !p2 with + | Array (t1, def1), Array (t2, def2) -> + f (CArray.fold_left2 f a t1 t2) def1 def2 + | _ -> assert false diff --git a/kernel/parray.mli b/kernel/parray.mli new file mode 100644 index 0000000000..0276278bd0 --- /dev/null +++ b/kernel/parray.mli @@ -0,0 +1,36 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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) *) +(************************************************************************) + +val max_length : Uint63.t + +type 'a t +val length : 'a t -> Uint63.t +val length_int : 'a t -> int +val get : 'a t -> Uint63.t -> 'a +val set : 'a t -> Uint63.t -> 'a -> 'a t +val default : 'a t -> 'a +val make : Uint63.t -> 'a -> 'a t +val init : Uint63.t -> (int -> 'a) -> 'a -> 'a t +val copy : 'a t -> 'a t +val reroot : 'a t -> 'a t + +val map : ('a -> 'b) -> 'a t -> 'b t + +val to_array : 'a t -> 'a array * 'a (* default *) + +val of_array : 'a array -> 'a (* default *) -> 'a t + +val unsafe_of_array : 'a array -> 'a -> 'a t +(* [unsafe_of_array] injects a mutable array into a persistent one, but does + not perform a copy. This means that if the persistent array is mutated, the + original one will be too. *) + +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a +val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a diff --git a/kernel/primred.ml b/kernel/primred.ml index c475828cb3..10a8da8813 100644 --- a/kernel/primred.ml +++ b/kernel/primred.ml @@ -21,6 +21,13 @@ let add_retroknowledge env action = | None -> { retro with retro_float64 = Some c } | Some c' -> assert (Constant.equal c c'); retro in set_retroknowledge env retro + | Register_type(PT_array,c) -> + let retro = env.retroknowledge in + let retro = + match retro.retro_array with + | None -> { retro with retro_array = Some c } + | Some c' -> assert (Constant.equal c c'); retro in + set_retroknowledge env retro | Register_ind(pit,ind) -> let retro = env.retroknowledge in let retro = @@ -120,10 +127,12 @@ module type RedNativeEntries = type elem type args type evd (* will be unit in kernel, evar_map outside *) + type uinstance val get : args -> int -> elem val get_int : evd -> elem -> Uint63.t val get_float : evd -> elem -> Float64.t + val get_parray : evd -> elem -> elem Parray.t val mkInt : env -> Uint63.t -> elem val mkFloat : env -> Float64.t -> elem val mkBool : env -> bool -> elem @@ -146,6 +155,7 @@ module type RedNativeEntries = val mkPInf : env -> elem val mkNInf : env -> elem val mkNaN : env -> elem + val mkArray : env -> uinstance -> elem Parray.t -> elem -> elem end module type RedNative = @@ -153,17 +163,20 @@ module type RedNative = type elem type args type evd - val red_prim : env -> evd -> CPrimitives.t -> args -> elem option + type uinstance + val red_prim : env -> evd -> CPrimitives.t -> uinstance -> args -> elem option end module RedNative (E:RedNativeEntries) : RedNative with type elem = E.elem with type args = E.args - with type evd = E.evd = + with type evd = E.evd + with type uinstance = E.uinstance = struct type elem = E.elem type args = E.args type evd = E.evd + type uinstance = E.uinstance let get_int evd args i = E.get_int evd (E.get args i) @@ -180,7 +193,9 @@ struct let get_float2 evd args = get_float evd args 0, get_float evd args 1 - let red_prim_aux env evd op args = + let get_parray evd args i = E.get_parray evd (E.get args i) + + let red_prim_aux env evd op u args = let open CPrimitives in match op with | Int63head0 -> @@ -315,11 +330,43 @@ struct let f = get_float1 evd args in E.mkFloat env (Float64.next_up f) | Float64next_down -> let f = get_float1 evd args in E.mkFloat env (Float64.next_down f) + | Arraymake -> + let ty = E.get args 0 in + let i = get_int evd args 1 in + let d = E.get args 2 in + E.mkArray env u (Parray.make i d) ty + | Arrayget -> + let t = get_parray evd args 1 in + let i = get_int evd args 2 in + Parray.get t i + | Arraydefault -> + let t = get_parray evd args 1 in + Parray.default t + | Arrayset -> + let ty = E.get args 0 in + let t = get_parray evd args 1 in + let i = get_int evd args 2 in + let a = E.get args 3 in + let t' = Parray.set t i a in + E.mkArray env u t' ty + | Arraycopy -> + let ty = E.get args 0 in + let t = get_parray evd args 1 in + let t' = Parray.copy t in + E.mkArray env u t' ty + | Arrayreroot -> + let ar = E.get args 1 in + let t = E.get_parray evd ar in + let _ = Parray.reroot t in + ar + | Arraylength -> + let t = get_parray evd args 1 in + E.mkInt env (Parray.length t) - let red_prim env evd p args = + let red_prim env evd p u args = try let r = - red_prim_aux env evd p args + red_prim_aux env evd p u args in Some r with NativeDestKO -> None diff --git a/kernel/primred.mli b/kernel/primred.mli index bbe564d8e7..1bfaffaa44 100644 --- a/kernel/primred.mli +++ b/kernel/primred.mli @@ -24,10 +24,12 @@ module type RedNativeEntries = type elem type args type evd (* will be unit in kernel, evar_map outside *) + type uinstance val get : args -> int -> elem val get_int : evd -> elem -> Uint63.t val get_float : evd -> elem -> Float64.t + val get_parray : evd -> elem -> elem Parray.t val mkInt : env -> Uint63.t -> elem val mkFloat : env -> Float64.t -> elem val mkBool : env -> bool -> elem @@ -50,6 +52,7 @@ module type RedNativeEntries = val mkPInf : env -> elem val mkNInf : env -> elem val mkNaN : env -> elem + val mkArray : env -> uinstance -> elem Parray.t -> elem -> elem end module type RedNative = @@ -57,7 +60,8 @@ module type RedNative = type elem type args type evd - val red_prim : env -> evd -> CPrimitives.t -> args -> elem option + type uinstance + val red_prim : env -> evd -> CPrimitives.t -> uinstance -> args -> elem option end module RedNative : @@ -65,3 +69,4 @@ module RedNative : RedNative with type elem = E.elem with type args = E.args with type evd = E.evd + with type uinstance = E.uinstance diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 4ff90dd70d..0754e9d4cc 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -138,10 +138,10 @@ let nf_betaiota env t = let whd_betaiotazeta env x = match kind x with | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| - Prod _|Lambda _|Fix _|CoFix _|Int _|Float _) -> x + Prod _|Lambda _|Fix _|CoFix _|Int _|Float _|Array _) -> x | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Evar _ | Meta _ | Const _ | Int _ | Float _ -> x + | Ind _ | Construct _ | Evar _ | Meta _ | Const _ | Int _ | Float _ | Array _ -> x | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Case _ | Fix _ | CoFix _ | Proj _ -> whd_val (create_clos_infos betaiotazeta env) (create_tab ()) (inject x) @@ -152,10 +152,10 @@ let whd_betaiotazeta env x = let whd_all env t = match kind t with | (Sort _|Meta _|Evar _|Ind _|Construct _| - Prod _|Lambda _|Fix _|CoFix _|Int _|Float _) -> t + Prod _|Lambda _|Fix _|CoFix _|Int _|Float _|Array _) -> t | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Evar _ | Meta _ | Int _ | Float _ -> t + | Ind _ | Construct _ | Evar _ | Meta _ | Int _ | Float _ | Array _ -> t | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Const _ |Case _ | Fix _ | CoFix _ | Proj _ -> whd_val (create_clos_infos all env) (create_tab ()) (inject t) @@ -166,10 +166,10 @@ let whd_all env t = let whd_allnolet env t = match kind t with | (Sort _|Meta _|Evar _|Ind _|Construct _| - Prod _|Lambda _|Fix _|CoFix _|LetIn _|Int _|Float _) -> t + Prod _|Lambda _|Fix _|CoFix _|LetIn _|Int _|Float _|Array _) -> t | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Evar _ | Meta _ | LetIn _ | Int _ | Float _ -> t + | Ind _ | Construct _ | Evar _ | Meta _ | LetIn _ | Int _ | Float _ | Array _ -> t | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | App _ | Const _ | Case _ | Fix _ | CoFix _ | Proj _ -> whd_val (create_clos_infos allnolet env) (create_tab ()) (inject t) @@ -209,12 +209,16 @@ type conv_pb = let is_cumul = function CUMUL -> true | CONV -> false -type 'a universe_compare = - { (* Might raise NotConvertible *) - compare_sorts : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a -> 'a; - compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; - compare_cumul_instances : conv_pb -> Univ.Variance.t array -> - Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a } +type 'a universe_compare = { + (* used in reduction *) + compare_graph : 'a -> UGraph.t; + + (* Might raise NotConvertible *) + compare_sorts : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a -> 'a; + compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; + compare_cumul_instances : conv_pb -> Univ.Variance.t array -> + Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; +} type 'a universe_state = 'a * 'a universe_compare @@ -302,7 +306,6 @@ let unfold_ref_with_args infos tab fl v = type conv_tab = { cnv_inf : clos_infos; - relevances : Sorts.relevance Range.t; lft_tab : clos_tab; rgt_tab : clos_tab; } @@ -313,13 +316,13 @@ type conv_tab = { passed to each respective side of the conversion function below. *) let push_relevance infos r = - { infos with relevances = Range.cons r.Context.binder_relevance infos.relevances } + { infos with cnv_inf = CClosure.push_relevance infos.cnv_inf r } let push_relevances infos nas = - { infos with relevances = Array.fold_left (fun l x -> Range.cons x.Context.binder_relevance l) infos.relevances nas } + { infos with cnv_inf = CClosure.push_relevances infos.cnv_inf nas } let rec skip_pattern infos relevances n c1 c2 = - if Int.equal n 0 then {infos with relevances}, c1, c2 + if Int.equal n 0 then {infos with cnv_inf = CClosure.set_info_relevances infos.cnv_inf relevances}, c1, c2 else match kind c1, kind c2 with | Lambda (x, _, c1), Lambda (_, _, c2) -> skip_pattern infos (Range.cons x.Context.binder_relevance relevances) (pred n) c1 c2 @@ -327,11 +330,11 @@ let rec skip_pattern infos relevances n c1 c2 = let skip_pattern infos n c1 c2 = if Int.equal n 0 then infos, c1, c2 - else skip_pattern infos infos.relevances n c1 c2 + else skip_pattern infos (info_relevances infos.cnv_inf) n c1 c2 let is_irrelevant infos lft c = let env = info_env infos.cnv_inf in - try Relevanceops.relevance_of_fterm env infos.relevances lft c == Sorts.Irrelevant with _ -> false + try Relevanceops.relevance_of_fterm env (info_relevances infos.cnv_inf) lft c == Sorts.Irrelevant with _ -> false (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = @@ -633,13 +636,31 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = if Float64.equal f1 f2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible + | FCaseInvert (ci1,p1,_,_,br1,e1), FCaseInvert (ci2,p2,_,_,br2,e2) -> + (if not (eq_ind ci1.ci_ind ci2.ci_ind) then raise NotConvertible); + let el1 = el_stack lft1 v1 and el2 = el_stack lft2 v2 in + let ccnv = ccnv CONV l2r infos el1 el2 in + let cuniv = ccnv (mk_clos e1 p1) (mk_clos e2 p2) cuniv in + Array.fold_right2 (fun b1 b2 cuniv -> ccnv (mk_clos e1 b1) (mk_clos e2 b2) cuniv) + br1 br2 cuniv + + | FArray (u1,t1,ty1), FArray (u2,t2,ty2) -> + let len = Parray.length_int t1 in + if not (Int.equal len (Parray.length_int t2)) then raise NotConvertible; + let cuniv = convert_instances ~flex:false u1 u2 cuniv in + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in + let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in + let cuniv = Parray.fold_left2 (fun u v1 v2 -> ccnv CONV l2r infos el1 el2 v1 v2 u) cuniv t1 t2 in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) | ( (FLetIn _, _) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) | (_, FLetIn _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false - | (FRel _ | FAtom _ | FInd _ | FFix _ | FCoFix _ - | FProd _ | FEvar _ | FInt _ | FFloat _), _ -> raise NotConvertible + | (FRel _ | FAtom _ | FInd _ | FFix _ | FCoFix _ | FCaseInvert _ + | FProd _ | FEvar _ | FInt _ | FFloat _ | FArray _), _ -> raise NotConvertible and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = let f (l1, t1) (l2, t2) cuniv = ccnv CONV l2r infos l1 l2 t1 t2 cuniv in @@ -711,10 +732,10 @@ and convert_list l2r infos lft1 lft2 v1 v2 cuniv = match v1, v2 with let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let reds = CClosure.RedFlags.red_add_transparent betaiotazeta trans in - let infos = create_clos_infos ~evars reds env in + let graph = (snd univs).compare_graph (fst univs) in + let infos = create_clos_infos ~univs:graph ~evars reds env in let infos = { cnv_inf = infos; - relevances = Range.empty; lft_tab = create_tab (); rgt_tab = create_tab (); } in @@ -759,10 +780,25 @@ let check_inductive_instances cv_pb variance u1 u2 univs = else raise NotConvertible let checked_universes = - { compare_sorts = checked_sort_cmp_universes; + { compare_graph = (fun x -> x); + compare_sorts = checked_sort_cmp_universes; compare_instances = check_convert_instances; compare_cumul_instances = check_inductive_instances; } +let () = + let conv infos tab a b = + try + let univs = info_univs infos in + let infos = { cnv_inf = infos; lft_tab = tab; rgt_tab = tab; } in + let univs', _ = ccnv CONV false infos el_id el_id a b + (univs, checked_universes) + in + assert (univs==univs'); + true + with NotConvertible -> false + in + CClosure.set_conv conv + let infer_eq (univs, cstrs as cuniv) u u' = if UGraph.check_eq univs u u' then cuniv else @@ -807,7 +843,8 @@ let infer_inductive_instances cv_pb variance u1 u2 (univs,csts') = (univs, Univ.Constraint.union csts csts') let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = - { compare_sorts = infer_cmp_universes; + { compare_graph = (fun (x,_) -> x); + compare_sorts = infer_cmp_universes; compare_instances = infer_convert_instances; compare_cumul_instances = infer_inductive_instances; } diff --git a/kernel/reduction.mli b/kernel/reduction.mli index ff5934c66c..4ae3838691 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -36,12 +36,15 @@ type 'a extended_conversion_function = type conv_pb = CONV | CUMUL -type 'a universe_compare = - { (* Might raise NotConvertible *) - compare_sorts : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a -> 'a; - compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; - compare_cumul_instances : conv_pb -> Univ.Variance.t array -> - Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a } +type 'a universe_compare = { + compare_graph : 'a -> UGraph.t; (* used for case inversion in reduction *) + + (* Might raise NotConvertible *) + compare_sorts : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a -> 'a; + compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; + compare_cumul_instances : conv_pb -> Univ.Variance.t array -> + Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; +} type 'a universe_state = 'a * 'a universe_compare diff --git a/kernel/relevanceops.ml b/kernel/relevanceops.ml index 3f3e722245..f12b8cba37 100644 --- a/kernel/relevanceops.ml +++ b/kernel/relevanceops.ml @@ -54,14 +54,14 @@ let rec relevance_of_fterm env extra lft f = | FRel n -> Range.get extra (Esubst.reloc_rel n lft - 1) | FAtom c -> relevance_of_term_extra env extra lft (Esubst.subs_id 0) c | FFlex key -> relevance_of_flex env key - | FInt _ | FFloat _ -> Sorts.Relevant + | FInt _ | FFloat _ | FArray _ -> Sorts.Relevant | FInd _ | FProd _ -> Sorts.Relevant (* types are always relevant *) | FConstruct (c,_) -> relevance_of_constructor env c | FApp (f, _) -> relevance_of_fterm env extra lft f | FProj (p, _) -> relevance_of_projection env p | FFix (((_,i),(lna,_,_)), _) -> (lna.(i)).binder_relevance | FCoFix ((i,(lna,_,_)), _) -> (lna.(i)).binder_relevance - | FCaseT (ci, _, _, _, _) -> ci.ci_relevance + | FCaseT (ci, _, _, _, _) | FCaseInvert (ci, _, _, _, _, _) -> ci.ci_relevance | FLambda (len, tys, bdy, e) -> let extra = List.fold_left (fun accu (x, _) -> Range.cons (binder_relevance x) accu) extra tys in let lft = Esubst.el_liftn len lft in @@ -97,11 +97,12 @@ and relevance_of_term_extra env extra lft subs c = | App (c, _) -> relevance_of_term_extra env extra lft subs c | Const (c,_) -> relevance_of_constant env c | Construct (c,_) -> relevance_of_constructor env c - | Case (ci, _, _, _) -> ci.ci_relevance + | Case (ci, _, _, _, _) -> ci.ci_relevance | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance | Proj (p, _) -> relevance_of_projection env p | Int _ | Float _ -> Sorts.Relevant + | Array _ -> Sorts.Relevant | Meta _ | Evar _ -> Sorts.Relevant (* let's assume metas and evars are relevant for now *) diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index 4e642ca11d..f7c4b62d1f 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -19,6 +19,7 @@ open Names type retroknowledge = { retro_int63 : Constant.t option; retro_float64 : Constant.t option; + retro_array : Constant.t option; retro_bool : (constructor * constructor) option; (* true, false *) retro_carry : (constructor * constructor) option; (* C0, C1 *) retro_pair : constructor option; @@ -40,6 +41,7 @@ type retroknowledge = { let empty = { retro_int63 = None; retro_float64 = None; + retro_array = None; retro_bool = None; retro_carry = None; retro_pair = None; @@ -51,4 +53,4 @@ let empty = { type action = | Register_ind : 'a CPrimitives.prim_ind * inductive -> action - | Register_type : CPrimitives.prim_type * Constant.t -> action + | Register_type : 'a CPrimitives.prim_type * Constant.t -> action diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index bf8ec8badb..fd412cdd0a 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -13,6 +13,7 @@ open Names type retroknowledge = { retro_int63 : Constant.t option; retro_float64 : Constant.t option; + retro_array : Constant.t option; retro_bool : (constructor * constructor) option; (* true, false *) retro_carry : (constructor * constructor) option; (* C0, C1 *) retro_pair : constructor option; @@ -35,4 +36,4 @@ val empty : retroknowledge type action = | Register_ind : 'a CPrimitives.prim_ind * inductive -> action - | Register_type : CPrimitives.prim_type * Constant.t -> action + | Register_type : 'a CPrimitives.prim_type * Constant.t -> action diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 93337fca5d..8b85072d6d 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -1023,6 +1023,8 @@ let start_module l senv = mp, { empty_environment with env = senv.env; + modresolver = senv.modresolver; + paramresolver = senv.paramresolver; modpath = mp; modvariant = STRUCT ([],senv); required = senv.required } @@ -1034,6 +1036,8 @@ let start_modtype l senv = mp, { empty_environment with env = senv.env; + modresolver = senv.modresolver; + paramresolver = senv.paramresolver; modpath = mp; modvariant = SIG ([], senv); required = senv.required } diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index c8c2301171..04e7a81697 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -21,13 +21,14 @@ open Constr open Declarations open Environ open Entries +open Univ module NamedDecl = Context.Named.Declaration (* Insertion of constants and parameters in environment. *) type 'a effect_handler = - env -> Constr.t -> 'a -> (Constr.t * Univ.ContextSet.t * int) + env -> Constr.t -> 'a -> (Constr.t * ContextSet.t * int) let skip_trusted_seff sl b e = let rec aux sl b e acc = @@ -62,55 +63,91 @@ let feedback_completion_typecheck = type typing_context = | MonoTyCtx of Environ.env * unsafe_type_judgment * Id.Set.t * Stateid.t option -| PolyTyCtx of Environ.env * unsafe_type_judgment * Univ.universe_level_subst * Univ.AUContext.t * Id.Set.t * Stateid.t option +| PolyTyCtx of Environ.env * unsafe_type_judgment * universe_level_subst * AUContext.t * Id.Set.t * Stateid.t option -let infer_declaration env (dcl : constant_entry) = - match dcl with - | ParameterEntry (ctx,(t,uctx),nl) -> - let env = match uctx with - | Monomorphic_entry uctx -> push_context_set ~strict:true uctx env - | Polymorphic_entry (_, uctx) -> push_context ~strict:false uctx env +let check_primitive_type env op_t u t = + let inft = Typeops.type_of_prim_or_type env u op_t in + try Reduction.default_conv ~l2r:false Reduction.CONV env inft t + with Reduction.NotConvertible -> + Type_errors.error_incorrect_primitive env (make_judge op_t inft) t + +let merge_unames = + Array.map2 (fun base user -> match user with Anonymous -> base | Name _ -> user) + +let infer_primitive env { prim_entry_type = utyp; prim_entry_content = p; } = + let open CPrimitives in + let auctx = CPrimitives.op_or_type_univs p in + let univs, typ = + match utyp with + | None -> + let u = UContext.instance (AUContext.repr auctx) in + let typ = Typeops.type_of_prim_or_type env u p in + let univs = if AUContext.is_empty auctx then Monomorphic ContextSet.empty + else Polymorphic auctx in - let j = Typeops.infer env t in - let usubst, univs = Declareops.abstract_universes uctx in - let r = Typeops.assumption_of_judgment env j in - let t = Vars.subst_univs_level_constr usubst j.uj_val in - { - Cooking.cook_body = Undef nl; - cook_type = t; - cook_universes = univs; - cook_relevance = r; - cook_inline = false; - cook_context = ctx; - } + univs, typ - (** Primitives cannot be universe polymorphic *) - | PrimitiveEntry ({ prim_entry_type = otyp; - prim_entry_univs = uctxt; - prim_entry_content = op_t; - }) -> - let env = push_context_set ~strict:true uctxt env in - let ty = match otyp with - | Some typ -> + | Some (typ,Monomorphic_entry uctx) -> + assert (AUContext.is_empty auctx); + let env = push_context_set ~strict:true uctx env in + let u = Instance.empty in + let typ = let typ = Typeops.infer_type env typ in - Typeops.check_primitive_type env op_t typ.utj_val; + check_primitive_type env p u typ.utj_val; typ.utj_val - | None -> - match op_t with - | CPrimitives.OT_op op -> Typeops.type_of_prim env op - | CPrimitives.OT_type _ -> mkSet in - let cd = - match op_t with - | CPrimitives.OT_op op -> Declarations.Primitive op - | CPrimitives.OT_type _ -> Undef None in - { Cooking.cook_body = cd; - cook_type = ty; - cook_universes = Monomorphic uctxt; - cook_inline = false; - cook_context = None; - cook_relevance = Sorts.Relevant; - } + Monomorphic uctx, typ + + | Some (typ,Polymorphic_entry (unames,uctx)) -> + assert (not (AUContext.is_empty auctx)); + (* push_context will check that the universes aren't repeated in the instance + so comparing the sizes works *) + assert (AUContext.size auctx = UContext.size uctx); + (* No polymorphic primitive uses constraints currently *) + assert (Constraint.is_empty (UContext.constraints uctx)); + let env = push_context ~strict:false uctx env in + (* Now we know that uctx matches the auctx *) + let typ = (Typeops.infer_type env typ).utj_val in + let () = check_primitive_type env p (UContext.instance uctx) typ in + let unames = merge_unames (AUContext.names auctx) unames in + let u, auctx = abstract_universes unames uctx in + let typ = Vars.subst_univs_level_constr (make_instance_subst u) typ in + Polymorphic auctx, typ + in + let body = match p with + | OT_op op -> Declarations.Primitive op + | OT_type _ -> Undef None + | OT_const c -> Def (Mod_subst.from_val (CPrimitives.body_of_prim_const c)) + in + { Cooking.cook_body = body; + cook_type = typ; + cook_universes = univs; + cook_inline = false; + cook_context = None; + cook_relevance = Sorts.Relevant; + } + +let infer_declaration env (dcl : constant_entry) = + match dcl with + | ParameterEntry (ctx,(t,uctx),nl) -> + let env = match uctx with + | Monomorphic_entry uctx -> push_context_set ~strict:true uctx env + | Polymorphic_entry (_, uctx) -> push_context ~strict:false uctx env + in + let j = Typeops.infer env t in + let usubst, univs = Declareops.abstract_universes uctx in + let r = Typeops.assumption_of_judgment env j in + let t = Vars.subst_univs_level_constr usubst j.uj_val in + { + Cooking.cook_body = Undef nl; + cook_type = t; + cook_universes = univs; + cook_relevance = r; + cook_inline = false; + cook_context = ctx; + } + + | PrimitiveEntry entry -> infer_primitive env entry | DefinitionEntry c -> let { const_entry_type = typ; _ } = c in @@ -118,13 +155,13 @@ let infer_declaration env (dcl : constant_entry) = let env, usubst, univs = match c.const_entry_universes with | Monomorphic_entry ctx -> let env = push_context_set ~strict:true ctx env in - env, Univ.empty_level_subst, Monomorphic ctx + env, empty_level_subst, Monomorphic ctx | Polymorphic_entry (nas, uctx) -> (** [ctx] must contain local universes, such that it has no impact on the rest of the graph (up to transitivity). *) let env = push_context ~strict:false uctx env in - let sbst, auctx = Univ.abstract_universes nas uctx in - let sbst = Univ.make_instance_subst sbst in + let sbst, auctx = abstract_universes nas uctx in + let sbst = make_instance_subst sbst in env, sbst, Polymorphic auctx in let j = Typeops.infer env body in @@ -171,8 +208,8 @@ let infer_opaque env = function let { opaque_entry_feedback = feedback_id; _ } = c in let env = push_context ~strict:false uctx env in let tj = Typeops.infer_type env typ in - let sbst, auctx = Univ.abstract_universes nas uctx in - let usubst = Univ.make_instance_subst sbst in + let sbst, auctx = abstract_universes nas uctx in + let usubst = make_instance_subst sbst in let context = PolyTyCtx (env, tj, usubst, auctx, c.opaque_entry_secctx, feedback_id) in let def = OpaqueDef () in let typ = Vars.subst_univs_level_constr usubst tj.utj_val in @@ -260,7 +297,7 @@ let check_delayed (type a) (handle : a effect_handler) tyenv (body : a proof_out | MonoTyCtx (env, tyj, declared, feedback_id) -> let ((body, uctx), side_eff) = body in let (body, uctx', valid_signatures) = handle env body side_eff in - let uctx = Univ.ContextSet.union uctx uctx' in + let uctx = ContextSet.union uctx uctx' in let env = push_context_set uctx env in let body,env,ectx = skip_trusted_seff valid_signatures body env in let j = Typeops.infer env body in @@ -273,17 +310,17 @@ let check_delayed (type a) (handle : a effect_handler) tyenv (body : a proof_out | PolyTyCtx (env, tj, usubst, auctx, declared, feedback_id) -> let ((body, ctx), side_eff) = body in let body, ctx', _ = handle env body side_eff in - let ctx = Univ.ContextSet.union ctx ctx' in + let ctx = ContextSet.union ctx ctx' in (** [ctx] must contain local universes, such that it has no impact on the rest of the graph (up to transitivity). *) let env = push_subgraph ctx env in - let private_univs = on_snd (Univ.subst_univs_level_constraints usubst) ctx in + let private_univs = on_snd (subst_univs_level_constraints usubst) ctx in let j = Typeops.infer env body in let _ = Typeops.judge_of_cast env j DEFAULTcast tj in let () = check_section_variables env declared tj.utj_val body in let def = Vars.subst_univs_level_constr usubst j.uj_val in let () = feedback_completion_typecheck feedback_id in - def, Opaqueproof.PrivatePolymorphic (Univ.AUContext.size auctx, private_univs) + def, Opaqueproof.PrivatePolymorphic (AUContext.size auctx, private_univs) (*s Global and local constant declaration. *) @@ -325,13 +362,13 @@ let translate_local_def env _id centry = const_entry_secctx = centry.secdef_secctx; const_entry_feedback = centry.secdef_feedback; const_entry_type = centry.secdef_type; - const_entry_universes = Monomorphic_entry Univ.ContextSet.empty; + const_entry_universes = Monomorphic_entry ContextSet.empty; const_entry_inline_code = false; } in let decl = infer_declaration env (DefinitionEntry centry) in let typ = decl.cook_type in let () = match decl.cook_universes with - | Monomorphic ctx -> assert (Univ.ContextSet.is_empty ctx) + | Monomorphic ctx -> assert (ContextSet.is_empty ctx) | Polymorphic _ -> assert false in let c = match decl.cook_body with diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 42fc6b2e45..ae5c4b6880 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -68,6 +68,7 @@ type ('constr, 'types) ptype_error = | UndeclaredUniverse of Level.t | DisallowedSProp | BadRelevance + | BadInvert type type_error = (constr, types) ptype_error @@ -159,6 +160,9 @@ let error_disallowed_sprop env = let error_bad_relevance env = raise (TypeError (env, BadRelevance)) +let error_bad_invert env = + raise (TypeError (env, BadInvert)) + let map_pguard_error f = function | NotEnoughAbstractionInFixBody -> NotEnoughAbstractionInFixBody | RecursionNotOnInductiveType c -> RecursionNotOnInductiveType (f c) @@ -202,3 +206,4 @@ let map_ptype_error f = function | UndeclaredUniverse l -> UndeclaredUniverse l | DisallowedSProp -> DisallowedSProp | BadRelevance -> BadRelevance +| BadInvert -> BadInvert diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index a58d9aa50d..b1f7eb8a34 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -69,6 +69,7 @@ type ('constr, 'types) ptype_error = | UndeclaredUniverse of Level.t | DisallowedSProp | BadRelevance + | BadInvert type type_error = (constr, types) ptype_error @@ -143,5 +144,7 @@ val error_disallowed_sprop : env -> 'a val error_bad_relevance : env -> 'a +val error_bad_invert : env -> 'a + 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 diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 19d76bfee6..f86c12e1f1 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -213,9 +213,20 @@ let type_of_apply env func funt argsv argstv = apply_rec 0 (inject funt) (* Type of primitive constructs *) -let type_of_prim_type _env = function - | CPrimitives.PT_int63 -> Constr.mkSet - | CPrimitives.PT_float64 -> Constr.mkSet +let type_of_prim_type _env u (type a) (prim : a CPrimitives.prim_type) = match prim with + | CPrimitives.PT_int63 -> + assert (Univ.Instance.is_empty u); + Constr.mkSet + | CPrimitives.PT_float64 -> + assert (Univ.Instance.is_empty u); + Constr.mkSet + | CPrimitives.PT_array -> + begin match Univ.Instance.to_array u with + | [|u|] -> + let ty = Constr.mkType (Univ.Universe.make u) in + Constr.mkProd(Context.anonR, ty , ty) + | _ -> anomaly Pp.(str"universe instance for array type should have length 1") + end let type_of_int env = match env.retroknowledge.Retroknowledge.retro_int63 with @@ -228,71 +239,11 @@ let type_of_float env = | None -> raise (Invalid_argument "Typeops.type_of_float: float64 not_defined") -let type_of_prim env t = - let int_ty () = type_of_int env in - let float_ty () = type_of_float env in - let bool_ty () = - match env.retroknowledge.Retroknowledge.retro_bool with - | Some ((ind,_),_) -> Constr.mkInd ind - | None -> CErrors.user_err Pp.(str"The type bool must be registered before this primitive.") - in - let compare_ty () = - match env.retroknowledge.Retroknowledge.retro_cmp with - | Some ((ind,_),_,_) -> Constr.mkInd ind - | None -> CErrors.user_err Pp.(str"The type compare must be registered before this primitive.") - in - let f_compare_ty () = - match env.retroknowledge.Retroknowledge.retro_f_cmp with - | Some ((ind,_),_,_,_) -> Constr.mkInd ind - | None -> CErrors.user_err Pp.(str"The type float_comparison must be registered before this primitive.") - in - let f_class_ty () = - match env.retroknowledge.Retroknowledge.retro_f_class with - | Some ((ind,_),_,_,_,_,_,_,_,_) -> Constr.mkInd ind - | None -> CErrors.user_err Pp.(str"The type float_class must be registered before this primitive.") - in - let pair_ty fst_ty snd_ty = - match env.retroknowledge.Retroknowledge.retro_pair with - | Some (ind,_) -> Constr.mkApp(Constr.mkInd ind, [|fst_ty;snd_ty|]) - | None -> CErrors.user_err Pp.(str"The type pair must be registered before this primitive.") - in - let carry_ty int_ty = - match env.retroknowledge.Retroknowledge.retro_carry with - | Some ((ind,_),_) -> Constr.mkApp(Constr.mkInd ind, [|int_ty|]) - | None -> CErrors.user_err Pp.(str"The type carry must be registered before this primitive.") - in - let open CPrimitives in - let tr_prim_type = function - | PT_int63 -> int_ty () - | PT_float64 -> float_ty () in - let tr_ind (type t) (i : t prim_ind) (a : t) = match i, a with - | PIT_bool, () -> bool_ty () - | PIT_carry, t -> carry_ty (tr_prim_type t) - | PIT_pair, (t1, t2) -> pair_ty (tr_prim_type t1) (tr_prim_type t2) - | PIT_cmp, () -> compare_ty () - | PIT_f_cmp, () -> f_compare_ty () - | PIT_f_class, () -> f_class_ty () in - let tr_type = function - | PITT_ind (i, a) -> tr_ind i a - | PITT_type t -> tr_prim_type t in - let rec nary_op = function - | [] -> assert false - | [ret_ty] -> tr_type ret_ty - | arg_ty :: r -> - let arg_ty = tr_type arg_ty in - Constr.mkProd(Context.nameR (Id.of_string "x"), arg_ty, nary_op r) in - nary_op (types t) - -let type_of_prim_or_type env = let open CPrimitives in - function - | OT_type t -> type_of_prim_type env t - | OT_op op -> type_of_prim env op - -let judge_of_int env i = - make_judge (Constr.mkInt i) (type_of_int env) - -let judge_of_float env f = - make_judge (Constr.mkFloat f) (type_of_float env) +let type_of_array env u = + assert (Univ.Instance.length u = 1); + match env.retroknowledge.Retroknowledge.retro_array with + | Some c -> mkConstU (c,u) + | None -> CErrors.user_err Pp.(str"The type array must be registered before this construction can be typechecked.") (* Type of product *) @@ -354,6 +305,18 @@ let check_cast env c ct k expected_type = with NotConvertible -> error_actual_type env (make_judge c ct) expected_type +let judge_of_int env i = + make_judge (Constr.mkInt i) (type_of_int env) + +let judge_of_float env f = + make_judge (Constr.mkFloat f) (type_of_float env) + +let judge_of_array env u tj defj = + let def = defj.uj_val in + let ty = defj.uj_type in + Array.iter (fun j -> check_cast env j.uj_val j.uj_type DEFAULTcast ty) tj; + make_judge (mkArray(u, Array.map j_val tj, def, ty)) (mkApp (type_of_array env u, [|ty|])) + (* Inductive types. *) (* The type is parametric over the uniform parameters whose conclusion @@ -407,7 +370,20 @@ let check_branch_types env (ind,u) c ct lft explft = | Invalid_argument _ -> error_number_branches env (make_judge c ct) (Array.length explft) -let type_of_case env ci p pt c ct _lf lft = +let should_invert_case env ci = + ci.ci_relevance == Sorts.Relevant && + let mib,mip = lookup_mind_specif env ci.ci_ind in + mip.mind_relevance == Sorts.Irrelevant && + (* NB: it's possible to have 2 ctors or arguments to 1 ctor by unsetting univ checks + but we don't do special reduction in such cases + + XXX Someday consider more carefully what happens with letin params and arguments + (currently they're squashed, see indtyping) + *) + Array.length mip.mind_nf_lc = 1 && + List.length (fst mip.mind_nf_lc.(0)) = List.length mib.mind_params_ctxt + +let type_of_case env ci p pt iv c ct _lf lft = let (pind, _ as indspec) = try find_rectype env ct with Not_found -> error_case_not_inductive env (make_judge c ct) in @@ -418,6 +394,14 @@ let type_of_case env ci p pt c ct _lf lft = else (warn_bad_relevance_ci (); {ci with ci_relevance=rp}) in let () = check_case_info env pind rp ci in + let () = + let is_inversion = match iv with + | NoInvert -> false + | CaseInvert _ -> true (* contents already checked *) + in + if not (is_inversion = should_invert_case env ci) + then error_bad_invert env + in let (bty,rslty) = type_case_branches env indspec (make_judge p pt) c in let () = check_branch_types env pind c ct lft bty in @@ -564,13 +548,22 @@ let rec execute env cstr = | Construct c -> cstr, type_of_constructor env c - | Case (ci,p,c,lf) -> + | Case (ci,p,iv,c,lf) -> let c', ct = execute env c in + let iv' = match iv with + | NoInvert -> NoInvert + | CaseInvert {univs;args} -> + let ct' = mkApp (mkIndU (ci.ci_ind,univs), args) in + let (ct', _) : constr * Sorts.t = execute_is_type env ct' in + let () = conv_leq false env ct ct' in + let _, args' = decompose_appvect ct' in + if args == args' then iv else CaseInvert {univs;args=args'} + in let p', pt = execute env p in let lf', lft = execute_array env lf in - let ci', t = type_of_case env ci p' pt c' ct lf' lft in - let cstr = if ci == ci' && c == c' && p == p' && lf == lf' then cstr - else mkCase(ci',p',c',lf') + let ci', t = type_of_case env ci p' pt iv' c' ct lf' lft in + let cstr = if ci == ci' && c == c' && p == p' && iv == iv' && lf == lf' then cstr + else mkCase(ci',p',iv',c',lf') in cstr, t @@ -591,6 +584,23 @@ let rec execute env cstr = (* Primitive types *) | Int _ -> cstr, type_of_int env | Float _ -> cstr, type_of_float env + | Array(u,t,def,ty) -> + (* ty : Type@{u} and all of t,def : ty *) + let ulev = match Univ.Instance.to_array u with + | [|u|] -> u + | _ -> assert false + in + let ty',tyty = execute env ty in + check_cast env ty' tyty DEFAULTcast (mkType (Universe.make ulev)); + let def', def_ty = execute env def in + check_cast env def' def_ty DEFAULTcast ty'; + let ta = type_of_array env u in + let t' = Array.Smart.map (fun x -> + let x', xt = execute env x in + check_cast env x' xt DEFAULTcast ty'; + x') t in + let cstr = if def'==def && t'==t && ty'==ty then cstr else mkArray(u, t',def',ty') in + cstr, mkApp(ta, [|ty'|]) (* Partial proofs: unsupported by the kernel *) | Meta _ -> @@ -710,14 +720,84 @@ let judge_of_inductive env indu = let judge_of_constructor env cu = make_judge (mkConstructU cu) (type_of_constructor env cu) -let judge_of_case env ci pj cj lfj = +let judge_of_case env ci pj iv cj lfj = let lf, lft = dest_judgev lfj in - let ci, t = type_of_case env ci pj.uj_val pj.uj_type cj.uj_val cj.uj_type lf lft in - make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, lft)) t + let ci, t = type_of_case env ci pj.uj_val pj.uj_type iv cj.uj_val cj.uj_type lf lft in + make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, iv, cj.uj_val, lft)) t (* Building type of primitive operators and type *) -let check_primitive_type env op_t t = - let inft = type_of_prim_or_type env op_t in - try default_conv ~l2r:false CUMUL env inft t - with NotConvertible -> error_incorrect_primitive env (make_judge op_t inft) t +let type_of_prim_const env _u c = + let int_ty () = type_of_int env in + match c with + | CPrimitives.Arraymaxlength -> + int_ty () + +let type_of_prim env u t = + let int_ty () = type_of_int env in + let float_ty () = type_of_float env in + let array_ty u a = mkApp(type_of_array env u, [|a|]) in + let bool_ty () = + match env.retroknowledge.Retroknowledge.retro_bool with + | Some ((ind,_),_) -> Constr.mkInd ind + | None -> CErrors.user_err Pp.(str"The type bool must be registered before this primitive.") + in + let compare_ty () = + match env.retroknowledge.Retroknowledge.retro_cmp with + | Some ((ind,_),_,_) -> Constr.mkInd ind + | None -> CErrors.user_err Pp.(str"The type compare must be registered before this primitive.") + in + let f_compare_ty () = + match env.retroknowledge.Retroknowledge.retro_f_cmp with + | Some ((ind,_),_,_,_) -> Constr.mkInd ind + | None -> CErrors.user_err Pp.(str"The type float_comparison must be registered before this primitive.") + in + let f_class_ty () = + match env.retroknowledge.Retroknowledge.retro_f_class with + | Some ((ind,_),_,_,_,_,_,_,_,_) -> Constr.mkInd ind + | None -> CErrors.user_err Pp.(str"The type float_class must be registered before this primitive.") + in + let pair_ty fst_ty snd_ty = + match env.retroknowledge.Retroknowledge.retro_pair with + | Some (ind,_) -> Constr.mkApp(Constr.mkInd ind, [|fst_ty;snd_ty|]) + | None -> CErrors.user_err Pp.(str"The type pair must be registered before this primitive.") + in + let carry_ty int_ty = + match env.retroknowledge.Retroknowledge.retro_carry with + | Some ((ind,_),_) -> Constr.mkApp(Constr.mkInd ind, [|int_ty|]) + | None -> CErrors.user_err Pp.(str"The type carry must be registered before this primitive.") + in + let open CPrimitives in + let tr_prim_type (tr_type : ind_or_type -> constr) (type a) (ty : a prim_type) (t : a) = match ty with + | PT_int63 -> int_ty t + | PT_float64 -> float_ty t + | PT_array -> array_ty (fst t) (tr_type (snd t)) + in + let tr_ind (tr_type : ind_or_type -> constr) (type t) (i : t prim_ind) (a : t) = match i, a with + | PIT_bool, () -> bool_ty () + | PIT_carry, t -> carry_ty (tr_type t) + | PIT_pair, (t1, t2) -> pair_ty (tr_type t1) (tr_type t2) + | PIT_cmp, () -> compare_ty () + | PIT_f_cmp, () -> f_compare_ty () + | PIT_f_class, () -> f_class_ty () + in + let rec tr_type n = function + | PITT_ind (i, a) -> tr_ind (tr_type n) i a + | PITT_type (ty,t) -> tr_prim_type (tr_type n) ty t + | PITT_param i -> Constr.mkRel (n+i) + in + let rec nary_op n = function + | [] -> assert false + | [ret_ty] -> tr_type n ret_ty + | arg_ty :: r -> + Constr.mkProd(Context.nameR (Id.of_string "x"), tr_type n arg_ty, nary_op (n+1) r) + in + let params, sign = types t in + assert (AUContext.size (univs t) = Instance.length u); + Vars.subst_instance_constr u (Term.it_mkProd_or_LetIn (nary_op 0 sign) params) + +let type_of_prim_or_type env u = let open CPrimitives in + function + | OT_type t -> type_of_prim_type env u t + | OT_op op -> type_of_prim env u op + | OT_const c -> type_of_prim_const env u c diff --git a/kernel/typeops.mli b/kernel/typeops.mli index e61d5c399e..87a5666fcc 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -94,8 +94,9 @@ val judge_of_constructor : env -> constructor puniverses -> unsafe_judgment (** {6 Type of Cases. } *) val judge_of_case : env -> case_info - -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array - -> unsafe_judgment + -> unsafe_judgment -> (constr,Instance.t) case_invert -> unsafe_judgment + -> unsafe_judgment array + -> unsafe_judgment (** {6 Type of global references. } *) @@ -113,8 +114,6 @@ val type_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t val check_hyps_inclusion : env -> ?evars:((existential->constr option) * UGraph.t) -> GlobRef.t -> Constr.named_context -> unit -val check_primitive_type : env -> CPrimitives.op_or_type -> types -> unit - (** Types for primitives *) val type_of_int : env -> types @@ -123,8 +122,16 @@ val judge_of_int : env -> Uint63.t -> unsafe_judgment val type_of_float : env -> types val judge_of_float : env -> Float64.t -> unsafe_judgment -val type_of_prim_type : env -> CPrimitives.prim_type -> types -val type_of_prim : env -> CPrimitives.t -> types +val type_of_array : env -> Univ.Instance.t -> types +val judge_of_array : env -> Univ.Instance.t -> unsafe_judgment array -> unsafe_judgment -> unsafe_judgment + +val type_of_prim_type : env -> Univ.Instance.t -> 'a CPrimitives.prim_type -> types +val type_of_prim : env -> Univ.Instance.t -> CPrimitives.t -> types +val type_of_prim_or_type : env -> Univ.Instance.t -> CPrimitives.op_or_type -> types val warn_bad_relevance_name : string (** Allow the checker to make this warning into an error. *) + +val should_invert_case : env -> case_info -> bool +(** We have case inversion exactly when going from irrelevant nonempty + (ie 1 constructor) inductive to relevant type. *) diff --git a/kernel/univ.ml b/kernel/univ.ml index 0aca4b41ad..6d8aa02dff 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -985,6 +985,8 @@ module AUContext = struct type t = Names.Name.t array constrained + let make names csts : t = names, csts + let repr (inst, cst) = (Array.init (Array.length inst) (fun i -> Level.var i), cst) diff --git a/kernel/univ.mli b/kernel/univ.mli index 7651e34b12..7286fc84cb 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -353,6 +353,10 @@ module AUContext : sig type t + val make : Names.Name.t array -> Constraint.t -> t + (** Build an abstract context. Constraints may be between universe + variables. *) + val repr : t -> UContext.t (** [repr ctx] is [(Var(0), ... Var(n-1) |= cstr] where [n] is the length of the context and [cstr] the abstracted Constraint.t. *) diff --git a/kernel/vars.ml b/kernel/vars.ml index a4465c293b..f7e28b0cfe 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -252,6 +252,22 @@ let subst_univs_level_constr subst c = let u' = Univ.subst_univs_level_universe subst u in if u' == u then t else (changed := true; mkSort (Sorts.sort_of_univ u')) + + | Case (ci,p,CaseInvert {univs;args},c,br) -> + if Univ.Instance.is_empty univs then Constr.map aux t + else + let univs' = f univs in + if univs' == univs then Constr.map aux t + else (changed:=true; Constr.map aux (mkCase (ci,p,CaseInvert {univs=univs';args},c,br))) + + | Array (u,elems,def,ty) -> + let u' = f u in + let elems' = CArray.Smart.map aux elems in + let def' = aux def in + let ty' = aux ty in + if u == u' && elems == elems' && def == def' && ty == ty' then t + else (changed := true; mkArray (u',elems',def',ty')) + | _ -> Constr.map aux t in let c' = aux c in @@ -288,6 +304,20 @@ let subst_instance_constr subst c = let u' = Univ.subst_instance_universe subst u in if u' == u then t else (mkSort (Sorts.sort_of_univ u')) + + | Case (ci,p,CaseInvert {univs;args},c,br) -> + let univs' = f univs in + if univs' == univs then Constr.map aux t + else Constr.map aux (mkCase (ci,p,CaseInvert {univs=univs';args},c,br)) + + | Array (u,elems,def,ty) -> + let u' = f u in + let elems' = CArray.Smart.map aux elems in + let def' = aux def in + let ty' = aux ty in + if u == u' && elems == elems' && def == def' && ty == ty' then t + else mkArray (u',elems',def',ty') + | _ -> Constr.map aux t in aux c @@ -309,11 +339,14 @@ let universes_of_constr c = let rec aux s c = match kind c with | Const (_c, u) -> - LSet.fold LSet.add (Instance.levels u) s + LSet.fold LSet.add (Instance.levels u) s | Ind ((_mind,_), u) | Construct (((_mind,_),_), u) -> - LSet.fold LSet.add (Instance.levels u) s + LSet.fold LSet.add (Instance.levels u) s | Sort u when not (Sorts.is_small u) -> let u = Sorts.univ_of_sort u in LSet.fold LSet.add (Universe.levels u) s + | Array (u,_,_,_) -> + let s = LSet.fold LSet.add (Instance.levels u) s in + Constr.fold aux s c | _ -> Constr.fold aux s c in aux LSet.empty c diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 3563407f7e..f78f0d4d1e 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -76,6 +76,11 @@ and conv_whd env pb k whd1 whd2 cu = | Vfloat64 f1, Vfloat64 f2 -> if Float64.(equal (of_float f1) (of_float f2)) then cu else raise NotConvertible + | Varray t1, Varray t2 -> + if t1 == t2 then cu else + let n = Parray.length_int t1 in + if not (Int.equal n (Parray.length_int t2)) then raise NotConvertible; + Parray.fold_left2 (fun cu v1 v2 -> conv_val env CONV k v1 v2 cu) cu t1 t2 | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> conv_atom env pb k a1 stk1 a2 stk2 cu | Vfun _, _ | _, Vfun _ -> @@ -83,7 +88,7 @@ and conv_whd env pb k whd1 whd2 cu = conv_val env CONV (k+1) (apply_whd k whd1) (apply_whd k whd2) cu | Vprod _, _ | Vfix _, _ | Vcofix _, _ | Vconstr_const _, _ | Vint64 _, _ - | Vfloat64 _, _ | Vconstr_block _, _ | Vatom_stk _, _ -> raise NotConvertible + | Vfloat64 _, _ | Varray _, _ | Vconstr_block _, _ | Vatom_stk _, _ -> raise NotConvertible and conv_atom env pb k a1 stk1 a2 stk2 cu = diff --git a/kernel/vm.ml b/kernel/vm.ml index f2d033f89b..d8c66bebd2 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -169,7 +169,7 @@ let rec apply_stack a stk v = let apply_whd k whd = let v = val_of_rel k in match whd with - | Vprod _ | Vconstr_const _ | Vconstr_block _ | Vint64 _ | Vfloat64 _ -> + | Vprod _ | Vconstr_const _ | Vconstr_block _ | Vint64 _ | Vfloat64 _ | Varray _ -> assert false | Vfun f -> reduce_fun k f | Vfix(f, None) -> diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index f4ce953d4a..ec429d5f9e 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -292,6 +292,7 @@ type whd = | Vconstr_block of vblock | Vint64 of int64 | Vfloat64 of float + | Varray of values Parray.t | Vatom_stk of atom * stack | Vuniv_level of Univ.Level.t @@ -324,6 +325,7 @@ let uni_lvl_val (v : values) : Univ.Level.t = | Vconstr_block _b -> str "Vconstr_block" | Vint64 _ -> str "Vint64" | Vfloat64 _ -> str "Vfloat64" + | Varray _ -> str "Varray" | Vatom_stk (_a,_stk) -> str "Vatom_stk" | Vuniv_level _ -> assert false in @@ -403,7 +405,9 @@ let whd_val : values -> whd = else let tag = Obj.tag o in if tag = accu_tag then - if is_accumulate (fun_code o) then whd_accu o [] + if Int.equal (Obj.size o) 1 then + Varray(Obj.obj o) + else if is_accumulate (fun_code o) then whd_accu o [] else Vprod(Obj.obj o) else if tag = Obj.closure_tag || tag = Obj.infix_tag then @@ -456,7 +460,9 @@ let val_of_atom a = val_of_obj (obj_of_atom a) let val_of_int i = (Obj.magic i : values) -let val_of_uint i = (Obj.magic i : values) +let val_of_uint i = (Obj.magic i : structured_values) + +let val_of_parray p = (Obj.magic p : structured_values) let atom_of_proj kn v = let r = Obj.new_block proj_tag 2 in @@ -689,6 +695,7 @@ and pr_whd w = | Vconstr_block _b -> str "Vconstr_block" | Vint64 i -> i |> Format.sprintf "Vint64(%LiL)" |> str | Vfloat64 f -> str "Vfloat64(" ++ str (Float64.(to_string (of_float f))) ++ str ")" + | Varray _ -> str "Varray" | Vatom_stk (a,stk) -> str "Vatom_stk(" ++ pr_atom a ++ str ", " ++ pr_stack stk ++ str ")" | Vuniv_level _ -> assert false) and pr_stack stk = @@ -701,3 +708,13 @@ and pr_zipper z = | Zfix (_f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")" | Zswitch _s -> str "Zswitch(...)" | Zproj c -> str "Zproj(" ++ Projection.Repr.print c ++ str ")") + +(** Primitives implemented in OCaml *) + +let parray_make = Obj.magic Parray.make +let parray_get = Obj.magic Parray.get +let parray_get_default = Obj.magic Parray.default +let parray_set = Obj.magic Parray.set +let parray_copy = Obj.magic Parray.copy +let parray_reroot = Obj.magic Parray.reroot +let parray_length = Obj.magic Parray.length diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli index cd85440fed..f4070a02a3 100644 --- a/kernel/vmvalues.mli +++ b/kernel/vmvalues.mli @@ -129,6 +129,7 @@ type whd = | Vconstr_block of vblock | Vint64 of int64 | Vfloat64 of float + | Varray of values Parray.t | Vatom_stk of atom * stack | Vuniv_level of Univ.Level.t @@ -150,6 +151,7 @@ val val_of_atom : atom -> values val val_of_int : int -> structured_values val val_of_block : tag -> structured_values array -> structured_values val val_of_uint : Uint63.t -> structured_values +val val_of_parray : structured_values Parray.t -> structured_values external val_of_annot_switch : annot_switch -> values = "%identity" external val_of_proj_name : Projection.Repr.t -> values = "%identity" @@ -199,3 +201,12 @@ val bfield : vblock -> int -> values val check_switch : vswitch -> vswitch -> bool val branch_arg : int -> tag * int -> values + +(** Primitives implemented in OCaml, seen as values (to be used as globals) *) +val parray_make : values +val parray_get : values +val parray_get_default : values +val parray_set : values +val parray_copy : values +val parray_reroot : values +val parray_length : values diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index c19dd00b38..61317f3ef2 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -65,6 +65,18 @@ let test_name_colon = let aliasvar = function { CAst.v = CPatAlias (_, na) } -> Some na | _ -> None +let test_array_opening = + let open Pcoq.Lookahead in + to_entry "test_array_opening" begin + lk_kw "[" >> lk_kw "|" >> check_no_space + end + +let test_array_closing = + let open Pcoq.Lookahead in + to_entry "test_array_closing" begin + lk_kw "|" >> lk_kw "]" >> check_no_space + end + } GRAMMAR EXTEND Gram @@ -165,16 +177,24 @@ GRAMMAR EXTEND Gram collapse -(3) into the numeral -3. *) (match c.CAst.v with | CPrim (Numeral (NumTok.SPlus,n)) -> - CAst.make ~loc @@ CNotation(None,(InConstrEntrySomeLevel,"( _ )"),([c],[],[],[])) + CAst.make ~loc @@ CNotation(None,(InConstrEntry,"( _ )"),([c],[],[],[])) | _ -> c) } | "{|"; c = record_declaration; bar_cbrace -> { c } | "{"; c = binder_constr ; "}" -> - { CAst.make ~loc @@ CNotation(None,(InConstrEntrySomeLevel,"{ _ }"),([c],[],[],[])) } + { CAst.make ~loc @@ CNotation(None,(InConstrEntry,"{ _ }"),([c],[],[],[])) } | "`{"; c = operconstr LEVEL "200"; "}" -> { CAst.make ~loc @@ CGeneralization (MaxImplicit, None, c) } + | test_array_opening; "["; "|"; ls = array_elems; "|"; def = lconstr; ty = type_cstr; test_array_closing; "|"; "]"; u = univ_instance -> + { let t = Array.make (List.length ls) def in + List.iteri (fun i e -> t.(i) <- e) ls; + CAst.make ~loc @@ CArray(u, t, def, ty) + } | "`("; c = operconstr LEVEL "200"; ")" -> { CAst.make ~loc @@ CGeneralization (Explicit, None, c) } ] ] ; + array_elems: + [ [ fs = LIST0 lconstr SEP ";" -> { fs } ]] + ; record_declaration: [ [ fs = fields_def -> { CAst.make ~loc @@ CRecord fs } ] ] ; @@ -346,7 +366,7 @@ GRAMMAR EXTEND Gram collapse -(3) into the numeral -3. *) match p.CAst.v with | CPatPrim (Numeral (NumTok.SPlus,n)) -> - CAst.make ~loc @@ CPatNotation(None,(InConstrEntrySomeLevel,"( _ )"),([p],[]),[]) + CAst.make ~loc @@ CPatNotation(None,(InConstrEntry,"( _ )"),([p],[]),[]) | _ -> p } | "("; p = pattern LEVEL "200"; "|" ; pl = LIST1 pattern LEVEL "200" SEP "|"; ")" -> { CAst.make ~loc @@ CPatOr (p::pl) } diff --git a/parsing/notation_gram.ml b/parsing/notation_gram.ml index 7940931dfc..045f497070 100644 --- a/parsing/notation_gram.ml +++ b/parsing/notation_gram.ml @@ -9,13 +9,6 @@ (************************************************************************) open Names -open Extend -open Constrexpr - -(** Dealing with precedences *) - -type level = notation_entry * entry_level * entry_relative_level list * constr_entry_key list - (* first argument is InCustomEntry s for custom entries *) type grammar_constr_prod_item = | GramConstrTerminal of string Tok.p @@ -28,10 +21,11 @@ type grammar_constr_prod_item = (** Grammar rules for a notation *) type one_notation_grammar = { - notgram_level : level; + notgram_level : Notation.level; notgram_assoc : Gramlib.Gramext.g_assoc option; notgram_notation : Constrexpr.notation; notgram_prods : grammar_constr_prod_item list list; + notgram_typs : Extend.constr_entry_key list; } type notation_grammar = one_notation_grammar list diff --git a/parsing/notgram_ops.ml b/parsing/notgram_ops.ml index 1d18e7dcfa..74ced431c9 100644 --- a/parsing/notgram_ops.ml +++ b/parsing/notgram_ops.ml @@ -12,63 +12,33 @@ open Pp open CErrors open Util open Notation -open Constrexpr -(* Register the level of notation for parsing and printing +(* Register the grammar of notation for parsing and printing (also register the parsing rule if not onlyprinting) *) -let notation_level_map = Summary.ref ~name:"notation_level_map" NotationMap.empty +let notation_grammar_map = Summary.ref ~name:"notation_grammar_map" NotationMap.empty -let declare_notation_level ntn parsing_rule level = +let declare_notation_grammar ntn rule = try - let _ = NotationMap.find ntn !notation_level_map in - anomaly (str "Notation " ++ pr_notation ntn ++ str " is already assigned a level.") + let _ = NotationMap.find ntn !notation_grammar_map in + anomaly (str "Notation " ++ pr_notation ntn ++ str " is already assigned a grammar.") with Not_found -> - notation_level_map := NotationMap.add ntn (parsing_rule,level) !notation_level_map + notation_grammar_map := NotationMap.add ntn rule !notation_grammar_map -let level_of_notation ntn = - NotationMap.find ntn !notation_level_map +let grammar_of_notation ntn = + NotationMap.find ntn !notation_grammar_map -let get_defined_notations () = - NotationSet.elements @@ NotationMap.domain !notation_level_map - -(**********************************************************************) -(* Equality *) - -open Extend - -let entry_relative_level_eq t1 t2 = match t1, t2 with -| LevelLt n1, LevelLt n2 -> Int.equal n1 n2 -| LevelLe n1, LevelLe n2 -> Int.equal n1 n2 -| LevelSome, LevelSome -> true -| (LevelLt _ | LevelLe _ | LevelSome), _ -> false - -let production_position_eq pp1 pp2 = match (pp1,pp2) with -| BorderProd (side1,assoc1), BorderProd (side2,assoc2) -> side1 = side2 && assoc1 = assoc2 -| InternalProd, InternalProd -> true -| (BorderProd _ | InternalProd), _ -> false +let notation_subentries_map = Summary.ref ~name:"notation_subentries_map" NotationMap.empty -let production_level_eq l1 l2 = match (l1,l2) with -| NextLevel, NextLevel -> true -| NumLevel n1, NumLevel n2 -> Int.equal n1 n2 -| DefaultLevel, DefaultLevel -> true -| (NextLevel | NumLevel _ | DefaultLevel), _ -> false - -let constr_entry_key_eq eq v1 v2 = match v1, v2 with -| ETIdent, ETIdent -> true -| ETGlobal, ETGlobal -> true -| ETBigint, ETBigint -> true -| ETBinder b1, ETBinder b2 -> b1 == b2 -| ETConstr (s1,bko1,lev1), ETConstr (s2,bko2,lev2) -> - notation_entry_eq s1 s2 && eq lev1 lev2 && Option.equal (=) bko1 bko2 -| ETPattern (b1,n1), ETPattern (b2,n2) -> b1 = b2 && Option.equal Int.equal n1 n2 -| (ETIdent | ETGlobal | ETBigint | ETBinder _ | ETConstr _ | ETPattern _), _ -> false +let declare_notation_subentries ntn entries = + try + let _ = NotationMap.find ntn !notation_grammar_map in + anomaly (str "Notation " ++ pr_notation ntn ++ str " is already assigned a grammar.") + with Not_found -> + notation_subentries_map := NotationMap.add ntn entries !notation_subentries_map -let level_eq_gen strict (s1, l1, t1, u1) (s2, l2, t2, u2) = - let prod_eq (l1,pp1) (l2,pp2) = - not strict || - (production_level_eq l1 l2 && production_position_eq pp1 pp2) in - notation_entry_eq s1 s2 && Int.equal l1 l2 && List.equal entry_relative_level_eq t1 t2 - && List.equal (constr_entry_key_eq prod_eq) u1 u2 +let subentries_of_notation ntn = + NotationMap.find ntn !notation_subentries_map -let level_eq = level_eq_gen false +let get_defined_notations () = + NotationSet.elements @@ NotationMap.domain !notation_grammar_map diff --git a/parsing/notgram_ops.mli b/parsing/notgram_ops.mli index dd1375a1f1..15b8717705 100644 --- a/parsing/notgram_ops.mli +++ b/parsing/notgram_ops.mli @@ -12,14 +12,14 @@ open Constrexpr open Notation_gram -val level_eq : level -> level -> bool -val entry_relative_level_eq : entry_relative_level -> entry_relative_level -> bool +(** {6 Declare the parsing rules and entries of a (possibly uninterpreted) notation } *) -(** {6 Declare and test the level of a (possibly uninterpreted) notation } *) - -val declare_notation_level : notation -> notation_grammar option -> level -> unit -val level_of_notation : notation -> notation_grammar option * level +val declare_notation_grammar : notation -> notation_grammar -> unit +val grammar_of_notation : notation -> notation_grammar (** raise [Not_found] if not declared *) +val declare_notation_subentries : notation -> Extend.constr_entry_key list -> unit +val subentries_of_notation : notation -> Extend.constr_entry_key list + (** Returns notations with defined parsing/printing rules *) val get_defined_notations : unit -> notation list diff --git a/parsing/ppextend.ml b/parsing/ppextend.ml index b888614ecb..fe6e8360c1 100644 --- a/parsing/ppextend.ml +++ b/parsing/ppextend.ml @@ -13,7 +13,6 @@ open Pp open CErrors open Notation open Constrexpr -open Notgram_ops (*s Pretty-print. *) diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 52c6c5d0f9..23f8fe04a3 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -112,7 +112,7 @@ module Bool = struct else if head === negb && Array.length args = 1 then Negb (aux args.(0)) else Var (Env.add env c) - | Case (info, r, arg, pats) -> + | Case (info, r, _iv, arg, pats) -> let is_bool = let i = info.ci_ind in Names.eq_ind i (Lazy.force ind) diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 0dbc0513b4..4a41f4c890 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -63,6 +63,11 @@ let pp_boxed_tuple f = function | [x] -> f x | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l)) +let pp_array f = function + | [] -> mt () + | [x] -> f x + | l -> pp_par true (prlist_with_sep (fun () -> str ";" ++ spc ()) f l) + (** By default, in module Format, you can do horizontal placing of blocks even if they include newlines, as long as the number of chars in the blocks is less that a line length. To avoid this awkward situation, diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index e77d37fb81..0bd9efd255 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -30,6 +30,7 @@ val pp_apply2 : Pp.t -> bool -> Pp.t list -> Pp.t val pp_tuple_light : (bool -> 'a -> Pp.t) -> 'a list -> Pp.t val pp_tuple : ('a -> Pp.t) -> 'a list -> Pp.t +val pp_array : ('a -> Pp.t) -> 'a list -> Pp.t val pp_boxed_tuple : ('a -> Pp.t) -> 'a list -> Pp.t val pr_binding : Id.t list -> Pp.t diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 0f96b9bbe8..2dca1d5e49 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -291,7 +291,7 @@ let rec extract_type env sg db j c args = let reason = if lvl == TypeScheme then Ktype else Kprop in Tarr (Tdummy reason, mld))) | Sort _ -> Tdummy Ktype (* The two logical cases. *) - | _ when sort_of env sg (applistc c args) == InProp -> Tdummy Kprop + | _ when info_of_family (sort_of env sg (applistc c args)) == Logic -> Tdummy Kprop | Rel n -> (match EConstr.lookup_rel n env with | LocalDef (_,t,_) -> @@ -351,7 +351,7 @@ let rec extract_type env sg db j c args = | (Info, TypeScheme) -> extract_type_app env sg db (r, type_sign env sg ty) args | (Info, Default) -> Tunknown)) - | Cast _ | LetIn _ | Construct _ | Int _ | Float _ -> assert false + | Cast _ | LetIn _ | Construct _ | Int _ | Float _ | Array _ -> assert false (*s Auxiliary function dealing with type application. Precondition: [r] is a type scheme represented by the signature [s], @@ -672,8 +672,9 @@ let rec extract_term env sg mle mlt c args = (* we unify it with an fresh copy of the stored type of [Rel n]. *) let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n) in extract_app env sg mle mlt extract_rel args - | Case ({ci_ind=ip},_,c0,br) -> - extract_app env sg mle mlt (extract_case env sg mle (ip,c0,br)) args + | Case ({ci_ind=ip},_,iv,c0,br) -> + (* If invert_case then this is a match that will get erased later, but right now we don't care. *) + extract_app env sg mle mlt (extract_case env sg mle (ip,c0,br)) args | Fix ((_,i),recd) -> extract_app env sg mle mlt (extract_fix env sg mle i recd) args | CoFix (i,recd) -> @@ -692,6 +693,12 @@ let rec extract_term env sg mle mlt c args = extract_app env sg mle mlt extract_var args | Int i -> assert (args = []); MLuint i | Float f -> assert (args = []); MLfloat f + | Array (_u,t,def,_ty) -> + assert (args = []); + let a = new_meta () in + let ml_arr = Array.map (fun c -> extract_term env sg mle a c []) t in + let def = extract_term env sg mle a def [] in + MLparray(ml_arr, def) | Ind _ | Prod _ | Sort _ -> assert false (*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *) @@ -852,8 +859,8 @@ and extract_case env sg mle ((kn,i) as ip,c,br) mlt = end else (* [c] has an inductive type, and is not a type scheme type. *) let t = type_of env sg c in - (* The only non-informative case: [c] is of sort [Prop] *) - if (sort_of env sg t) == InProp then + (* The only non-informative case: [c] is of sort [Prop]/[SProp] *) + if info_of_family (sort_of env sg t) == Logic then begin add_recursors env kn; (* May have passed unseen if logical ... *) (* Logical singleton case: *) @@ -1016,7 +1023,7 @@ let extract_fixpoint env sg vkn (fi,ti,ci) = (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *) let sub = List.rev_map EConstr.mkConst kns in for i = 0 to n-1 do - if sort_of env sg ti.(i) != InProp then + if info_of_family (sort_of env sg ti.(i)) != Logic then try let e,t = extract_std_constant env sg vkn.(i) (EConstr.Vars.substl sub ci.(i)) ti.(i) in @@ -1073,7 +1080,7 @@ let fake_match_projection env p = else let p = mkLambda (x, lift 1 indty, liftn 1 2 ty) in let branch = lift 1 (it_mkLambda_or_LetIn (mkRel (List.length ctx - (j-1))) ctx) in - let body = mkCase (ci, p, mkRel 1, [|branch|]) in + let body = mkCase (ci, p, NoInvert, mkRel 1, [|branch|]) in it_mkLambda_or_LetIn (mkLambda (x,indty,body)) mib.mind_params_ctxt | LocalDef (_,c,t) :: rem -> let c = liftn 1 j c in diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 97fe8a5776..c25285c987 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -218,6 +218,8 @@ let rec pp_expr par env args = pp_par par (str "Prelude.error \"EXTRACTION OF UINT NOT IMPLEMENTED\"") | MLfloat _ -> pp_par par (str "Prelude.error \"EXTRACTION OF FLOAT NOT IMPLEMENTED\"") + | MLparray _ -> + pp_par par (str "Prelude.error \"EXTRACTION OF ARRAY NOT IMPLEMENTED\"") and pp_cons_pat par r ppl = pp_par par diff --git a/plugins/extraction/json.ml b/plugins/extraction/json.ml index 81b3e1bcdc..974d254d9c 100644 --- a/plugins/extraction/json.ml +++ b/plugins/extraction/json.ml @@ -165,6 +165,11 @@ let rec json_expr env = function ("what", json_str "expr:float"); ("float", json_str (Float64.to_string f)) ] + | MLparray(t,def) -> json_dict [ + ("what", json_str "expr:array"); + ("elems", json_listarr (Array.map (json_expr env) t)); + ("default", json_expr env def) + ] and json_one_pat env (ids,p,t) = let ids', env' = push_vars (List.rev_map id_of_mlid ids) env in json_dict [ diff --git a/plugins/extraction/miniml.ml b/plugins/extraction/miniml.ml index 451272d554..a5a6564873 100644 --- a/plugins/extraction/miniml.ml +++ b/plugins/extraction/miniml.ml @@ -128,6 +128,7 @@ and ml_ast = | MLmagic of ml_ast | MLuint of Uint63.t | MLfloat of Float64.t + | MLparray of ml_ast array * ml_ast and ml_pattern = | Pcons of GlobRef.t * ml_pattern list diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index 451272d554..a5a6564873 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -128,6 +128,7 @@ and ml_ast = | MLmagic of ml_ast | MLuint of Uint63.t | MLfloat of Float64.t + | MLparray of ml_ast array * ml_ast and ml_pattern = | Pcons of GlobRef.t * ml_pattern list diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 465ad50e9b..b1ce10985a 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -431,6 +431,7 @@ let ast_iter_rel f = | MLapp (a,l) -> iter n a; List.iter (iter n) l | MLcons (_,_,l) | MLtuple l -> List.iter (iter n) l | MLmagic a -> iter n a + | MLparray (t,def) -> Array.iter (iter n) t; iter n def | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ | MLfloat _ -> () in iter 0 @@ -450,6 +451,7 @@ let ast_map f = function | MLcons (typ,c,l) -> MLcons (typ,c, List.map f l) | MLtuple l -> MLtuple (List.map f l) | MLmagic a -> MLmagic (f a) + | MLparray (t,def) -> MLparray (Array.map f t, f def) | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ | MLfloat _ as a -> a @@ -469,6 +471,7 @@ let ast_map_lift f n = function | MLcons (typ,c,l) -> MLcons (typ,c, List.map (f n) l) | MLtuple l -> MLtuple (List.map (f n) l) | MLmagic a -> MLmagic (f n a) + | MLparray (t,def) -> MLparray (Array.map (f n) t, f n def) | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ | MLfloat _ as a -> a @@ -484,6 +487,7 @@ let ast_iter f = function | MLapp (a,l) -> f a; List.iter f l | MLcons (_,_,l) | MLtuple l -> List.iter f l | MLmagic a -> f a + | MLparray (t,def) -> Array.iter f t; f def | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ | MLfloat _ -> () @@ -521,6 +525,7 @@ let nb_occur_match = | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l | MLcons (_,_,l) | MLtuple l -> List.fold_left (fun r a -> r+(nb k a)) 0 l | MLmagic a -> nb k a + | MLparray (t,def) -> Array.fold_left (fun r a -> r+(nb k a)) 0 t + nb k def | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ | MLfloat _ -> 0 in nb 1 @@ -573,6 +578,11 @@ let dump_unused_vars a = let b' = ren env b in if b' == b then a else MLmagic b' + | MLparray(t,def) -> + let t' = Array.Smart.map (ren env) t in + let def' = ren env def in + if def' == def && t' == t then a else MLparray(t',def') + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ | MLfloat _ -> a and ren_branch env ((ids,p,b) as tr) = @@ -1406,6 +1416,7 @@ let rec ml_size = function | MLfix(_,_,f) -> ml_size_array f | MLletin (_,_,t) -> ml_size t | MLmagic t -> ml_size t + | MLparray(t,def) -> ml_size_array t + ml_size def | MLglob _ | MLrel _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ | MLfloat _ -> 0 diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index d051602844..3a481039bf 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -107,7 +107,7 @@ let ast_iter_references do_term do_cons do_type a = Array.iter (fun (_,p,_) -> patt_iter_references do_cons p) v | MLrel _ | MLlam _ | MLapp _ | MLletin _ | MLtuple _ | MLfix _ | MLexn _ - | MLdummy _ | MLaxiom | MLmagic _ | MLuint _ | MLfloat _ -> () + | MLdummy _ | MLaxiom | MLmagic _ | MLuint _ | MLfloat _ | MLparray _ -> () in iter a let ind_iter_references do_term do_cons do_type kn ind = diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index a2ce47b11f..088405da5d 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -311,6 +311,11 @@ let rec pp_expr par env args = | MLfloat f -> assert (args=[]); str "(" ++ str (Float64.compile f) ++ str ")" + | MLparray(t,def) -> + assert (args=[]); + let tuple = pp_array (pp_expr true env []) (Array.to_list t) in + let def = pp_expr true env [] def in + str "(ExtrNative.of_array [|" ++ tuple ++ str "|]" ++ spc () ++ def ++ str")" and pp_record_proj par env typ t pv args = diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index 1fb605fc9a..ee50476b10 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -133,6 +133,8 @@ let rec pp_expr env args = paren (str "Prelude.error \"EXTRACTION OF UINT NOT IMPLEMENTED\"") | MLfloat _ -> paren (str "Prelude.error \"EXTRACTION OF FLOAT NOT IMPLEMENTED\"") + | MLparray _ -> + paren (str "Prelude.error \"EXTRACTION OF PARRAY NOT IMPLEMENTED\"") and pp_cons_args env = function | MLcons (_,r,args) when is_coinductive r -> diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 9c3debe48f..c62bc73e41 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -67,10 +67,10 @@ let unif env evd t1 t2= | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast evd nt2) bige | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> Queue.add (a,c) bige;Queue.add (pop b,pop d) bige - | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> - Queue.add (pa,pb) bige; - Queue.add (ca,cb) bige; - let l=Array.length va in + | Case (_,pa,_,ca,va),Case (_,pb,_,cb,vb)-> + Queue.add (pa,pb) bige; + Queue.add (ca,cb) bige; + let l=Array.length va in if not (Int.equal l (Array.length vb)) then raise (UFAIL (nt1,nt2)) else diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 9b578d4697..743afe4177 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -585,10 +585,10 @@ let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos let sigma = project g in (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) match EConstr.kind sigma dyn_infos.info with - | Case (ci, ct, t, cb) -> + | Case (ci, ct, iv, t, cb) -> let do_finalize_t dyn_info' g = let t = dyn_info'.info in - let dyn_infos = {dyn_info' with info = mkCase (ci, ct, t, cb)} in + let dyn_infos = {dyn_info' with info = mkCase (ci, ct, iv, t, cb)} in let g_nb_prod = nb_prod (project g) (pf_concl g) in let g, type_of_term = tac_type_of g t in let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in @@ -645,6 +645,7 @@ let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos match EConstr.kind sigma f with | Int _ -> user_err Pp.(str "integer cannot be applied") | Float _ -> user_err Pp.(str "float cannot be applied") + | Array _ -> user_err Pp.(str "array cannot be applied") | App _ -> assert false (* we have collected all the app in decompose_app *) | Proj _ -> assert false (*FIXME*) @@ -696,6 +697,7 @@ let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos ; build_proof do_finalize new_infos ] g | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + | Array _ -> CErrors.user_err Pp.(str "Arrays not handled yet") and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) Indfun_common.observe_tac @@ -862,7 +864,8 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num Declare.Proof.by (Proofview.V82.tactic prove_replacement) lemma in let (_ : _ list) = - Declare.Proof.save ~proof:lemma ~opaque:Vernacexpr.Transparent ~idopt:None + Declare.Proof.save_regular ~proof:lemma ~opaque:Vernacexpr.Transparent + ~idopt:None in evd diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 167cf37026..45b1713441 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -70,7 +70,7 @@ let build_newrecursive lnameargsardef = CErrors.user_err ~hdr:"Function" (Pp.str "Body of Function must be given") in - States.with_state_protection (List.map f) lnameargsardef + Vernacstate.System.protect (List.map f) lnameargsardef in (recdef, rec_impls) @@ -103,6 +103,8 @@ let is_rec names = names nal) b | GApp (f, args) -> List.exists (lookup names) (f :: args) + | GArray (_u, t, def, ty) -> + Array.exists (lookup names) t || lookup names def || lookup names ty | GCases (_, _, el, brl) -> List.exists (fun (e, _) -> lookup names e) el || List.exists (lookup_br names) brl @@ -987,7 +989,7 @@ and intros_with_rewrite_aux : Tacmach.tactic = ( UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type" )) -> Proofview.V82.of_tactic tauto g - | Case (_, _, v, _) -> + | Case (_, _, _, v, _) -> tclTHENLIST [Proofview.V82.of_tactic (simplest_case v); intros_with_rewrite] g @@ -1026,7 +1028,7 @@ let rec reflexivity_with_destruct_cases g = match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with - | Case (_, _, v, _) -> + | Case (_, _, _, v, _) -> tclTHENLIST [ Proofview.V82.of_tactic (simplest_case v) ; Proofview.V82.of_tactic intros @@ -1524,9 +1526,9 @@ let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) let lemma = fst @@ Declare.Proof.by (Proofview.V82.tactic (proving_tac i)) lemma in - let (_ : GlobRef.t list) = - Declare.Proof.save ~proof:lemma ~opaque:Vernacexpr.Transparent - ~idopt:None + let (_ : _ list) = + Declare.Proof.save_regular ~proof:lemma + ~opaque:Vernacexpr.Transparent ~idopt:None in let finfo = match find_Function_infos (fst f_as_constant) with @@ -1597,8 +1599,8 @@ let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) lemma) in let (_ : _ list) = - Declare.Proof.save ~proof:lemma ~opaque:Vernacexpr.Transparent - ~idopt:None + Declare.Proof.save_regular ~proof:lemma + ~opaque:Vernacexpr.Transparent ~idopt:None in let finfo = match find_Function_infos (fst f_as_constant) with @@ -2047,7 +2049,8 @@ let rec add_args id new_args = | CGeneralization _ -> CErrors.anomaly ~label:"add_args " (Pp.str "CGeneralization.") | CDelimiters _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "CDelimiters.")) + CErrors.anomaly ~label:"add_args " (Pp.str "CDelimiters.") + | CArray _ -> CErrors.anomaly ~label:"add_args " (Pp.str "CArray.")) let rec get_args b t : Constrexpr.local_binder_expr list diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 11e4fa0ac7..6ed61043f9 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -568,6 +568,7 @@ let rec build_entry_lc env sigma funnames avoid rt : | GProd _ -> user_err Pp.(str "Cannot apply a type") | GInt _ -> user_err Pp.(str "Cannot apply an integer") | GFloat _ -> user_err Pp.(str "Cannot apply a float") + | GArray _ -> user_err Pp.(str "Cannot apply an array") (* end of the application treatement *) ) | GLambda (n, _, t, b) -> (* we first compute the list of constructor @@ -672,6 +673,7 @@ let rec build_entry_lc env sigma funnames avoid rt : build_entry_lc env sigma funnames avoid match_expr | GRec _ -> user_err Pp.(str "Not handled GRec") | GCast (b, _) -> build_entry_lc env sigma funnames avoid b + | GArray _ -> user_err Pp.(str "Not handled GArray") and build_entry_lc_from_case env sigma funname make_discr (el : tomatch_tuples) (brl : Glob_term.cases_clauses) avoid : glob_constr build_entry_return = @@ -1196,7 +1198,7 @@ let rec compute_cst_params relnames params gt = discrimination ones *) | GSort _ -> params | GHole _ -> params - | GIf _ | GRec _ | GCast _ -> + | GIf _ | GRec _ | GCast _ | GArray _ -> CErrors.user_err ~hdr:"compute_cst_params" (str "Not handled case")) gt diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 5026120849..8e1331ace9 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -109,7 +109,13 @@ let change_vars = | GCast (b, c) -> GCast ( change_vars mapping b - , Glob_ops.map_cast_type (change_vars mapping) c )) + , Glob_ops.map_cast_type (change_vars mapping) c ) + | GArray (u, t, def, ty) -> + GArray + ( u + , Array.map (change_vars mapping) t + , change_vars mapping def + , change_vars mapping ty )) rt and change_vars_br mapping ({CAst.loc; v = idl, patl, res} as br) = let new_mapping = List.fold_right Id.Map.remove idl mapping in @@ -282,6 +288,12 @@ let rec alpha_rt excluded rt = GCast (alpha_rt excluded b, Glob_ops.map_cast_type (alpha_rt excluded) c) | GApp (f, args) -> GApp (alpha_rt excluded f, List.map (alpha_rt excluded) args) + | GArray (u, t, def, ty) -> + GArray + ( u + , Array.map (alpha_rt excluded) t + , alpha_rt excluded def + , alpha_rt excluded ty ) in new_rt @@ -331,7 +343,9 @@ let is_free_in id = | GHole _ -> false | GCast (b, (CastConv t | CastVM t | CastNative t)) -> is_free_in b || is_free_in t | GCast (b, CastCoerce) -> is_free_in b - | GInt _ | GFloat _ -> false) + | GInt _ | GFloat _ -> false + | GArray (_u, t, def, ty) -> + Array.exists is_free_in t || is_free_in def || is_free_in ty) x and is_free_in_br {CAst.v = ids, _, rt} = (not (Id.List.mem id ids)) && is_free_in rt @@ -404,6 +418,12 @@ let replace_var_by_term x_id term = | (GSort _ | GHole _) as rt -> rt | GInt _ as rt -> rt | GFloat _ as rt -> rt + | GArray (u, t, def, ty) -> + GArray + ( u + , Array.map replace_var_by_pattern t + , replace_var_by_pattern def + , replace_var_by_pattern ty ) | GCast (b, c) -> GCast ( replace_var_by_pattern b @@ -510,7 +530,10 @@ let expand_as = ( sty , Option.map (expand_as map) po , List.map (fun (rt, t) -> (expand_as map rt, t)) el - , List.map (expand_as_br map) brl )) + , List.map (expand_as_br map) brl ) + | GArray (u, t, def, ty) -> + GArray + (u, Array.map (expand_as map) t, expand_as map def, expand_as map ty)) and expand_as_br map {CAst.loc; v = idl, cpl, rt} = CAst.make ?loc (idl, cpl, expand_as (List.fold_left add_as map cpl) rt) in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 884792cc15..253c95fa67 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -59,7 +59,8 @@ let declare_fun name kind ?univs value = let defined lemma = let (_ : _ list) = - Declare.Proof.save ~proof:lemma ~opaque:Vernacexpr.Transparent ~idopt:None + Declare.Proof.save_regular ~proof:lemma ~opaque:Vernacexpr.Transparent + ~idopt:None in () @@ -305,14 +306,16 @@ let check_not_nested env sigma forbidden e = | Lambda (_, t, b) -> check_not_nested t; check_not_nested b | LetIn (_, v, t, b) -> check_not_nested t; check_not_nested b; check_not_nested v - | App (f, l) -> - check_not_nested f; - Array.iter check_not_nested l + | App (f, l) -> check_not_nested f + | Array (_u, t, def, ty) -> + Array.iter check_not_nested t; + check_not_nested def; + check_not_nested ty | Proj (p, c) -> check_not_nested c | Const _ -> () | Ind _ -> () | Construct _ -> () - | Case (_, t, e, a) -> + | Case (_, t, _, e, a) -> check_not_nested t; check_not_nested e; Array.iter check_not_nested a @@ -374,7 +377,13 @@ type journey_info = ; lambdA : (Name.t * types * constr, constr) journey_info_tac ; casE : ((constr infos -> tactic) -> constr infos -> tactic) - -> (case_info * constr * constr * constr array, constr) journey_info_tac + -> ( case_info + * constr + * (constr, EInstance.t) case_invert + * constr + * constr array + , constr ) + journey_info_tac ; otherS : (unit, constr) journey_info_tac ; apP : (constr * constr list, constr) journey_info_tac ; app_reC : (constr * constr list, constr) journey_info_tac @@ -441,6 +450,7 @@ let rec travel_aux jinfo continuation_tac (expr_info : constr infos) g = match EConstr.kind sigma expr_info.info with | CoFix _ | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") + | Array _ -> user_err Pp.(str "Function cannot treat arrays") | Proj _ -> user_err Pp.(str "Function cannot treat projections") | LetIn (na, b, t, e) -> let new_continuation_tac = @@ -474,9 +484,9 @@ let rec travel_aux jinfo continuation_tac (expr_info : constr infos) g = ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id ) ) - | Case (ci, t, a, l) -> + | Case (ci, t, iv, a, l) -> let continuation_tac_a = - jinfo.casE (travel jinfo) (ci, t, a, l) expr_info continuation_tac + jinfo.casE (travel jinfo) (ci, t, iv, a, l) expr_info continuation_tac in travel jinfo continuation_tac_a {expr_info with info = a; is_main_branch = false; is_final = false} @@ -767,7 +777,8 @@ let mkDestructEq not_on_hyp expr g = in (g, tac, to_revert) -let terminate_case next_step (ci, a, t, l) expr_info continuation_tac infos g = +let terminate_case next_step (ci, a, iv, t, l) expr_info continuation_tac infos + g = let sigma = project g in let env = pf_env g in let f_is_present = @@ -779,7 +790,7 @@ let terminate_case next_step (ci, a, t, l) expr_info continuation_tac infos g = let a' = infos.info in let new_info = { infos with - info = mkCase (ci, t, a', l) + info = mkCase (ci, t, iv, a', l) ; is_main_branch = expr_info.is_main_branch ; is_final = expr_info.is_final } in @@ -916,10 +927,10 @@ let prove_terminate = travel terminate_info (* Equation proof *) -let equation_case next_step (ci, a, t, l) expr_info continuation_tac infos = +let equation_case next_step case expr_info continuation_tac infos = observe_tac (fun _ _ -> str "equation case") - (terminate_case next_step (ci, a, t, l) expr_info continuation_tac infos) + (terminate_case next_step case expr_info continuation_tac infos) let rec prove_le g = let sigma = project g in @@ -1493,7 +1504,7 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name in let lemma = build_proof env (Evd.from_env env) start_tac end_tac in let (_ : _ list) = - Declare.Proof.save ~proof:lemma ~opaque:opacity ~idopt:None + Declare.Proof.save_regular ~proof:lemma ~opaque:opacity ~idopt:None in () in @@ -1652,7 +1663,11 @@ let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref in let _ = Flags.silently - (fun () -> Declare.Proof.save ~proof:lemma ~opaque:opacity ~idopt:None) + (fun () -> + let (_ : _ list) = + Declare.Proof.save_regular ~proof:lemma ~opaque:opacity ~idopt:None + in + ()) () in () diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 40c64a1c26..66c72a30a2 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -776,7 +776,7 @@ let rec find_a_destructable_match sigma t = let cl = [cl, (None, None), None], None in let dest = TacAtom (CAst.make @@ TacInductionDestruct(false, false, cl)) in match EConstr.kind sigma t with - | Case (_,_,x,_) when closed0 sigma x -> + | Case (_,_,_,x,_) when closed0 sigma x -> if isVar sigma x then (* TODO check there is no rel n. *) raise (Found (Tacinterp.eval_tactic dest)) diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index 81ee6ed5bb..fa176482bf 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -80,14 +80,14 @@ GRAMMAR EXTEND Gram open Declare.Obls -let obligation obl tac = with_tac (fun t -> obligation obl t) tac -let next_obligation obl tac = with_tac (fun t -> next_obligation obl t) tac +let obligation ~pm obl tac = with_tac (fun t -> obligation ~pm obl t) tac +let next_obligation ~pm obl tac = with_tac (fun t -> next_obligation ~pm obl t) tac let classify_obbl _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[])) } -VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } STATE open_proof +VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } STATE declare_program | [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> { obligation (num, Some name, Some t) tac } | [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> @@ -101,14 +101,14 @@ VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } STATE open_pro | [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } END -VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF +VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF STATE program | [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> { try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) } | [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> { try_solve_obligation num None (Some (Tacinterp.interp t)) } END -VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF +VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF STATE program | [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> { try_solve_obligations (Some name) (Some (Tacinterp.interp t)) } | [ "Solve" "Obligations" "with" tactic(t) ] -> @@ -117,14 +117,14 @@ VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF { try_solve_obligations None None } END -VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF +VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF STATE program | [ "Solve" "All" "Obligations" "with" tactic(t) ] -> { solve_all_obligations (Some (Tacinterp.interp t)) } | [ "Solve" "All" "Obligations" ] -> { solve_all_obligations None } END -VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF +VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF STATE program | [ "Admit" "Obligations" "of" ident(name) ] -> { admit_obligations (Some name) } | [ "Admit" "Obligations" ] -> { admit_obligations None } END @@ -148,14 +148,14 @@ VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY Feedback.msg_notice (str"Program obligation tactic is " ++ print_default_tactic ()) } END -VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY +VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY STATE read_program | [ "Obligations" "of" ident(name) ] -> { show_obligations (Some name) } | [ "Obligations" ] -> { show_obligations None } END -VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY -| [ "Preterm" "of" ident(name) ] -> { Feedback.msg_notice (show_term (Some name)) } -| [ "Preterm" ] -> { Feedback.msg_notice (show_term None) } +VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY STATE read_program +| [ "Preterm" "of" ident(name) ] -> { fun ~pm -> Feedback.msg_notice (show_term ~pm (Some name)) } +| [ "Preterm" ] -> { fun ~pm -> Feedback.msg_notice (show_term ~pm None) } END { diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 40dea90c00..fb149071c9 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -923,8 +923,8 @@ let reset_env env = let env' = Global.env_of_context (Environ.named_context_val env) in Environ.push_rel_context (Environ.rel_context env) env' -let fold_match env sigma c = - let (ci, p, c, brs) = destCase sigma c in +let fold_match ?(force=false) env sigma c = + let (ci, p, iv, c, brs) = destCase sigma c in let cty = Retyping.get_type_of env sigma c in let dep, pred, exists, sk = let env', ctx, body = @@ -1184,7 +1184,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | Fail | Identity -> b' in state, res - | Case (ci, p, c, brs) -> + | Case (ci, p, iv, c, brs) -> let cty = Retyping.get_type_of env (goalevars evars) c in let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in let cstr' = Some eqty in @@ -1194,7 +1194,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let state, res = match c' with | Success r -> - let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in + let case = mkCase (ci, lift 1 p, map_invert (lift 1) iv, mkRel 1, Array.map (lift 1) brs) in let res = make_leibniz_proof env case ty r in state, Success (coerce env unfresh (prop,cstr) res) | Fail | Identity -> @@ -1216,7 +1216,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = in match found with | Some r -> - let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in + let ctxc = mkCase (ci, lift 1 p, map_invert (lift 1) iv, lift 1 c, Array.of_list (List.rev (brs' c'))) in state, Success (make_leibniz_proof env ctxc ty r) | None -> state, c' else diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index e6c59f446d..f8c25d5dd0 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -489,7 +489,7 @@ let register_ltac local ?deprecation tacl = in (* STATE XXX: Review what is going on here. Why does this needs protection? Why is not the STM level protection enough? Fishy *) - let defs = States.with_state_protection defs () in + let defs = Vernacstate.System.protect defs () in let iter (def, tac) = match def with | NewTac id -> Tacenv.register_ltac false local id tac ?deprecation; diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 878f7a834e..95faede7d0 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -77,7 +77,7 @@ let protect_red map env sigma c0 = let evars ev = Evarutil.safe_evar_value sigma ev in let c = EConstr.Unsafe.to_constr c0 in let tab = create_tab () in - let infos = create_clos_infos ~evars all env in + let infos = create_clos_infos ~univs:(Evd.universes sigma) ~evars all env in let map = lookup_map map sigma c0 in let rec eval n c = match Constr.kind c with | Prod (na, t, u) -> Constr.mkProd (na, eval n t, eval (n + 1) u) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 5f463f8de4..65204b7868 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -1351,9 +1351,8 @@ let unsafe_intro env decl b = let inst = List.map (get_id %> EConstr.mkVar) (Environ.named_context env) in let ninst = EConstr.mkRel 1 :: inst in let nb = EConstr.Vars.subst1 (EConstr.mkVar (get_id decl)) b in - let sigma, ev = - Evarutil.new_evar_instance nctx sigma nb ~principal:true ninst in - sigma, EConstr.mkNamedLambda_or_LetIn decl ev + let sigma, ev = Evarutil.new_pure_evar ~principal:true nctx sigma nb in + sigma, EConstr.mkNamedLambda_or_LetIn decl (EConstr.mkEvar (ev, ninst)) end let set_decl_id id = let open Context in function diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 5d6e7c51d0..5dedae6388 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -308,10 +308,11 @@ let iter_constr_LR f c = match kind c with | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b | LetIn (_, v, t, b) -> f v; f t; f b | App (cf, a) -> f cf; Array.iter f a - | Case (_, p, v, b) -> f v; f p; Array.iter f b + | Case (_, p, iv, v, b) -> f v; iter_invert f iv; f p; Array.iter f b | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done | Proj(_,a) -> f a + | Array(_u,t,def,ty) -> Array.iter f t; f def; f ty | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _) -> () @@ -859,7 +860,7 @@ let glob_cpattern gs p = | k, (v, Some t), _ as orig -> if k = 'x' then glob_ssrterm gs ('(', (v, Some t), None) else match t.CAst.v with - | CNotation(_,(InConstrEntrySomeLevel,"( _ in _ )"), ([t1; t2], [], [], [])) -> + | CNotation(_,(InConstrEntry,"( _ in _ )"), ([t1; t2], [], [], [])) -> (try match glob t1, glob t2 with | (r1, None), (r2, None) -> encode k "In" [r1;r2] | (r1, Some _), (r2, Some _) when isCVar t1 -> @@ -867,11 +868,11 @@ let glob_cpattern gs p = | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] | _ -> CErrors.anomaly (str"where are we?.") with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) - | CNotation(_,(InConstrEntrySomeLevel,"( _ in _ in _ )"), ([t1; t2; t3], [], [], [])) -> + | CNotation(_,(InConstrEntry,"( _ in _ in _ )"), ([t1; t2; t3], [], [], [])) -> check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] - | CNotation(_,(InConstrEntrySomeLevel,"( _ as _ )"), ([t1; t2], [], [], [])) -> + | CNotation(_,(InConstrEntry,"( _ as _ )"), ([t1; t2], [], [], [])) -> encode k "As" [fst (glob t1); fst (glob t2)] - | CNotation(_,(InConstrEntrySomeLevel,"( _ as _ in _ )"), ([t1; t2; t3], [], [], [])) -> + | CNotation(_,(InConstrEntry,"( _ as _ in _ )"), ([t1; t2; t3], [], [], [])) -> check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] | _ -> glob_ssrterm gs orig ;; diff --git a/plugins/ssrsearch/g_search.mlg b/plugins/ssrsearch/g_search.mlg index f5cbf2005b..5e002e09cc 100644 --- a/plugins/ssrsearch/g_search.mlg +++ b/plugins/ssrsearch/g_search.mlg @@ -59,7 +59,7 @@ let interp_search_notation ?loc tag okey = (Bytes.set s' i' '_'; loop (j + 1) (i' + 2)) else (String.blit s i s' i' m; loop (j + 1) (i' + m + 1)) in loop 0 1 in - let trim_ntn (pntn, m) = (InConstrEntrySomeLevel,Bytes.sub_string pntn 1 (max 0 m)) in + let trim_ntn (pntn, m) = (InConstrEntry,Bytes.sub_string pntn 1 (max 0 m)) in let pr_ntn ntn = str "(" ++ Notation.pr_notation ntn ++ str ")" in let pr_and_list pr = function | [x] -> pr x diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 25353b7c12..a459229256 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1131,14 +1131,14 @@ let rec ungeneralize sigma n ng body = | LetIn (na,b,t,c) -> (* We traverse an alias *) mkLetIn (na,b,t,ungeneralize sigma (n+1) ng c) - | Case (ci,p,c,brs) -> + | Case (ci,p,iv,c,brs) -> (* We traverse a split *) let p = let sign,p = decompose_lam_assum sigma p in let sign2,p = decompose_prod_n_assum sigma ng p in let p = prod_applist sigma p [mkRel (n+List.length sign+ng)] in it_mkLambda_or_LetIn (it_mkProd_or_LetIn p sign2) sign in - mkCase (ci,p,c,Array.map2 (fun q c -> + mkCase (ci,p,iv,c,Array.map2 (fun q c -> let sign,b = decompose_lam_n_decls sigma q c in it_mkLambda_or_LetIn (ungeneralize sigma (n+q) ng b) sign) ci.ci_cstr_ndecls brs) @@ -1161,7 +1161,7 @@ let rec is_dependent_generalization sigma ng body = | LetIn (na,b,t,c) -> (* We traverse an alias *) is_dependent_generalization sigma ng c - | Case (ci,p,c,brs) -> + | Case (ci,p,iv,c,brs) -> (* We traverse a split *) Array.exists2 (fun q c -> let _,b = decompose_lam_n_decls sigma q c in @@ -1448,7 +1448,7 @@ let compile ~program_mode sigma pb = let rci = Typing.check_allowed_sort !!(pb.env) sigma mind current pred in let ci = make_case_info !!(pb.env) (fst mind) rci pb.casestyle in let pred = nf_betaiota !!(pb.env) sigma pred in - let case = make_case_or_project !!(pb.env) sigma indf ci pred current brvals in + let case = make_case_or_project !!(pb.env) sigma indt ci pred current brvals in let sigma, _ = Typing.type_of !!(pb.env) sigma pred in sigma, { uj_val = applist (case, inst); uj_type = prod_applist sigma typ inst } diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index b39ec37cd1..2c7b689c04 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -52,7 +52,8 @@ type cbv_value = | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array | CONSTR of constructor Univ.puniverses * cbv_value array - | PRIMITIVE of CPrimitives.t * constr * cbv_value array + | PRIMITIVE of CPrimitives.t * pconstant * cbv_value array + | ARRAY of Univ.Instance.t * cbv_value Parray.t * cbv_value (* type of terms with a hole. This hole can appear only under App or Case. * TOP means the term is considered without context @@ -75,7 +76,8 @@ type cbv_value = and cbv_stack = | TOP | APP of cbv_value array * cbv_stack - | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + | CASE of constr * constr array * (constr,Univ.Instance.t) case_invert + * case_info * cbv_value subs * cbv_stack | PROJ of Projection.t * cbv_stack (* les vars pourraient etre des constr, @@ -97,6 +99,8 @@ let rec shift_value n = function CONSTR (c, Array.map (shift_value n) args) | PRIMITIVE(op,c,args) -> PRIMITIVE(op,c,Array.map (shift_value n) args) + | ARRAY (u,t,ty) -> + ARRAY(u, Parray.map (shift_value n) t, shift_value n ty) let shift_value n v = if Int.equal n 0 then v else shift_value n v @@ -134,7 +138,7 @@ let rec stack_concat stk1 stk2 = match stk1 with TOP -> stk2 | APP(v,stk1') -> APP(v,stack_concat stk1' stk2) - | CASE(c,b,i,s,stk1') -> CASE(c,b,i,s,stack_concat stk1' stk2) + | CASE(c,b,iv,i,s,stk1') -> CASE(c,b,iv,i,s,stack_concat stk1' stk2) | PROJ (p,stk1') -> PROJ (p,stack_concat stk1' stk2) (* merge stacks when there is no shifts in between *) @@ -169,7 +173,7 @@ let strip_appl head stack = | COFIXP (cofix,env,app) -> (COFIXP(cofix,env,[||]), stack_app app stack) | CONSTR (c,app) -> (CONSTR(c,[||]), stack_app app stack) | PRIMITIVE(op,c,app) -> (PRIMITIVE(op,c,[||]), stack_app app stack) - | VAL _ | STACK _ | CBN _ | LAM _ -> (head, stack) + | VAL _ | STACK _ | CBN _ | LAM _ | ARRAY _ -> (head, stack) (* Tests if fixpoint reduction is possible. *) @@ -208,6 +212,7 @@ module VNativeEntries = type elem = cbv_value type args = cbv_value array type evd = unit + type uinstance = Univ.Instance.t let get = Array.get @@ -227,6 +232,11 @@ module VNativeEntries = | _ -> raise Primred.NativeDestKO) | _ -> raise Primred.NativeDestKO + let get_parray () e = + match e with + | ARRAY(_u,t,_ty) -> t + | _ -> raise Primred.NativeDestKO + let mkInt env i = VAL(0, mkInt i) let mkFloat env f = VAL(0, mkFloat f) @@ -326,6 +336,9 @@ module VNativeEntries = let (_pNormal,_nNormal,_pSubn,_nSubn,_pZero,_nZero,_pInf,_nInf,nan) = get_f_class_constructors env in CONSTR(Univ.in_punivs nan, [||]) + + let mkArray env u t ty = + ARRAY (u,t,ty) end module VredNative = RedNative(VNativeEntries) @@ -339,9 +352,9 @@ let rec reify_stack t = function | TOP -> t | APP (args,st) -> reify_stack (mkApp(t,Array.map reify_value args)) st - | CASE (ty,br,ci,env,st) -> + | CASE (ty,br,iv,ci,env,st) -> reify_stack - (mkCase (ci, ty, t,br)) + (mkCase (ci, ty, iv, t, br)) st | PROJ (p, st) -> reify_stack (mkProj (p, t)) st @@ -367,7 +380,10 @@ and reify_value = function (* reduction under binders *) | CONSTR (c,args) -> mkApp(mkConstructU c, Array.map reify_value args) | PRIMITIVE(op,c,args) -> - mkApp(c, Array.map reify_value args) + mkApp(mkConstU c, Array.map reify_value args) + | ARRAY (u,t,ty) -> + let t, def = Parray.to_array t in + mkArray(u, Array.map reify_value t, reify_value def, reify_value ty) and apply_env env t = match kind t with @@ -400,7 +416,7 @@ let rec norm_head info env t stack = they could be computed when getting out of the stack *) let nargs = Array.map (cbv_stack_term info TOP env) args in norm_head info env head (stack_app nargs stack) - | Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack)) + | Case (ci,p,iv,c,v) -> norm_head info env c (CASE(p,v,iv,ci,env,stack)) | Cast (ct,_,_) -> norm_head info env ct stack | Proj (p, c) -> @@ -457,6 +473,15 @@ let rec norm_head info env t stack = | CoFix cofix -> (COFIXP(cofix,env,[||]), stack) | Construct c -> (CONSTR(c, [||]), stack) + | Array(u,t,def,ty) -> + let ty = cbv_stack_term info TOP env ty in + let len = Array.length t in + let t = + Parray.init (Uint63.of_int len) + (fun i -> cbv_stack_term info TOP env t.(i)) + (cbv_stack_term info TOP env def) in + (ARRAY (u,t,ty), stack) + (* neutral cases *) | (Sort _ | Meta _ | Ind _ | Int _ | Float _) -> (VAL(0, t), stack) | Prod _ -> (CBN(t,env), stack) @@ -467,7 +492,12 @@ and norm_head_ref k info env stack normt t = | Declarations.Def body -> if get_debug_cbv () then Feedback.msg_debug Pp.(str "Unfolding " ++ debug_pr_key normt); strip_appl (shift_value k body) stack - | Declarations.Primitive op -> (PRIMITIVE(op,t,[||]),stack) + | Declarations.Primitive op -> + let c = match normt with + | ConstKey c -> c + | RelKey _ | VarKey _ -> assert false + in + (PRIMITIVE(op,c,[||]),stack) | Declarations.OpaqueDef _ | Declarations.Undef _ -> if get_debug_cbv () then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); (VAL(0,make_constr_ref k normt t),stack) @@ -514,14 +544,14 @@ and cbv_stack_value info env = function cbv_stack_term info stk envf redfix (* constructor in a Case -> IOTA *) - | (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,ci,env,stk))) + | (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,iv,ci,env,stk))) when red_set info.reds fMATCH -> let cargs = Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in cbv_stack_term info (stack_app cargs stk) env br.(n-1) (* constructor of arity 0 in a Case -> IOTA *) - | (CONSTR(((_,n),u),[||]), CASE(_,br,_,env,stk)) + | (CONSTR(((_,n),u),[||]), CASE(_,br,_,_,env,stk)) when red_set info.reds fMATCH -> cbv_stack_term info stk env br.(n-1) @@ -537,7 +567,7 @@ and cbv_stack_value info env = function | (CONSTR(c,[||]), APP(appl,TOP)) -> CONSTR(c,appl) (* primitive apply to arguments *) - | (PRIMITIVE(op,c,[||]), APP(appl,stk)) -> + | (PRIMITIVE(op,(_,u as c),[||]), APP(appl,stk)) -> let nargs = CPrimitives.arity op in let len = Array.length appl in if nargs <= len then @@ -548,7 +578,7 @@ and cbv_stack_value info env = function if nargs < len then stack_app (Array.sub appl nargs (len - nargs)) stk else stk in - match VredNative.red_prim info.env () op args with + match VredNative.red_prim info.env () op u args with | Some (CONSTR (c, args)) -> (* args must be moved to the stack to allow future reductions *) cbv_stack_value info env (CONSTR(c, [||]), stack_app args stk) @@ -584,7 +614,7 @@ and cbv_value_cache info ref = let v = cbv_stack_term info TOP (subs_id 0) body in Declarations.Def v with - | Environ.NotEvaluableConst (Environ.IsPrimitive op) -> Declarations.Primitive op + | Environ.NotEvaluableConst (Environ.IsPrimitive (_u,op)) -> Declarations.Primitive op | Not_found | Environ.NotEvaluableConst _ -> Declarations.Undef None in KeyTable.add info.tab ref v; v @@ -597,9 +627,9 @@ let rec apply_stack info t = function | TOP -> t | APP (args,st) -> apply_stack info (mkApp(t,Array.map (cbv_norm_value info) args)) st - | CASE (ty,br,ci,env,st) -> + | CASE (ty,br,iv,ci,env,st) -> apply_stack info - (mkCase (ci, cbv_norm_term info env ty, t, + (mkCase (ci, cbv_norm_term info env ty, iv, t, Array.map (cbv_norm_term info env) br)) st | PROJ (p, st) -> @@ -642,7 +672,12 @@ and cbv_norm_value info = function (* reduction under binders *) | CONSTR (c,args) -> mkApp(mkConstructU c, Array.map (cbv_norm_value info) args) | PRIMITIVE(op,c,args) -> - mkApp(c,Array.map (cbv_norm_value info) args) + mkApp(mkConstU c,Array.map (cbv_norm_value info) args) + | ARRAY (u,t,ty) -> + let ty = cbv_norm_value info ty in + let t, def = Parray.to_array t in + let def = cbv_norm_value info def in + mkArray(u, Array.map (cbv_norm_value info) t, def, ty) (* with profiling *) let cbv_norm infos constr = diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index fdd4370613..409f4c0f70 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -36,12 +36,14 @@ type cbv_value = | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array | CONSTR of constructor Univ.puniverses * cbv_value array - | PRIMITIVE of CPrimitives.t * Constr.t * cbv_value array + | PRIMITIVE of CPrimitives.t * pconstant * cbv_value array + | ARRAY of Univ.Instance.t * cbv_value Parray.t * cbv_value and cbv_stack = | TOP | APP of cbv_value array * cbv_stack - | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + | CASE of constr * constr array * (constr,Univ.Instance.t) case_invert + * case_info * cbv_value subs * cbv_stack | PROJ of Projection.t * cbv_stack val shift_value : int -> cbv_value -> cbv_value diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 25aa8915ba..419eeaa92a 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -351,7 +351,7 @@ let matches_core env sigma allow_bound_rels sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 - | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> + | PIf (a1,b1,b1'), Case (ci,_,_,a2,[|b2;b2'|]) -> let ctx_b2,b2 = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(0) b2 in let ctx_b2',b2' = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(1) b2' in let n = Context.Rel.length ctx_b2 in @@ -367,7 +367,7 @@ let matches_core env sigma allow_bound_rels else raise PatternMatchingFailure - | PCase (ci1,p1,a1,br1), Case (ci2,p2,a2,br2) -> + | PCase (ci1,p1,a1,br1), Case (ci2,p2,_,a2,br2) -> let n2 = Array.length br2 in let () = match ci1.cip_ind with | None -> () @@ -406,10 +406,16 @@ let matches_core env sigma allow_bound_rels | PEvar (c1,args1), Evar (c2,args2) when Evar.equal c1 c2 -> List.fold_left2 (sorec ctx env) subst args1 args2 | PInt i1, Int i2 when Uint63.equal i1 i2 -> subst + | PFloat f1, Float f2 when Float64.equal f1 f2 -> subst + + | PArray(pt,pdef,pty), Array(_u,t,def,ty) + when Array.length pt = Array.length t -> + sorec ctx env (sorec ctx env (Array.fold_left2 (sorec ctx env) subst pt t) pdef def) pty ty + | (PRef _ | PVar _ | PRel _ | PApp _ | PProj _ | PLambda _ | PProd _ | PLetIn _ | PSort _ | PIf _ | PCase _ - | PFix _ | PCoFix _| PEvar _ | PInt _ | PFloat _), _ -> raise PatternMatchingFailure + | PFix _ | PCoFix _| PEvar _ | PInt _ | PFloat _ | PArray _), _ -> raise PatternMatchingFailure in sorec [] env ((Id.Map.empty,Id.Set.empty), Id.Map.empty) pat c @@ -498,9 +504,9 @@ let sub_match ?(closed=true) env sigma pat c = | [app';c] -> mk_ctx (mkApp (app',[|c|])) | _ -> assert false in try_aux [(env, app); (env, Array.last lc)] mk_ctx next - | Case (ci,hd,c1,lc) -> + | Case (ci,hd,iv,c1,lc) -> let next_mk_ctx = function - | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc)) + | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,iv,c1,Array.of_list lc)) | _ -> assert false in let sub = (env, c1) :: (env, hd) :: subargs env lc in @@ -527,6 +533,13 @@ let sub_match ?(closed=true) env sigma pat c = aux env term mk_ctx next with Retyping.RetypeError _ -> next () end + | Array(u, t, def, ty) -> + let next_mk_ctx = function + | def :: ty :: l -> mk_ctx (mkArray(u, Array.of_list l, def, ty)) + | _ -> assert false + in + let sub = (env,def) :: (env,ty) :: subargs env t in + try_aux sub next_mk_ctx next | Construct _|Ind _|Evar _|Const _|Rel _|Meta _|Var _|Sort _|Int _|Float _ -> next () in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 13946208bc..7fcb0795bd 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -429,7 +429,7 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with | [] -> [Id.Set.empty,[],rhs] | na::nal -> match EConstr.kind sigma c with - | Case (ci,p,c,cl) when + | Case (ci,p,iv,c,cl) when eq_constr sigma c (mkRel (List.index Name.equal na (fst (snd e)))) && not (Int.equal (Array.length cl) 0) && (* don't contract if p dependent *) @@ -498,40 +498,46 @@ let it_destRLambda_or_LetIn_names l c = | _ -> DAst.make @@ GApp (c,[a])) in aux l [] c -let detype_case computable detype detype_eqns testdep avoid data p c bl = - let (indsp,st,constagsl,k) = data in +let detype_case computable detype detype_eqns testdep avoid ci p iv c bl = let synth_type = synthetize_type () in let tomatch = detype c in + let tomatch = match iv with + | NoInvert -> tomatch + | CaseInvert {univs;args} -> + let t = mkApp (mkIndU (ci.ci_ind,univs), args) in + DAst.make @@ GCast (tomatch, CastConv (detype t)) + in let alias, aliastyp, pred= if (not !Flags.raw_print) && synth_type && computable && not (Int.equal (Array.length bl) 0) then Anonymous, None, None else let p = detype p in - let nl,typ = it_destRLambda_or_LetIn_names k p in + let nl,typ = it_destRLambda_or_LetIn_names ci.ci_pp_info.ind_tags p in let n,typ = match DAst.get typ with | GLambda (x,_,t,c) -> x, c | _ -> Anonymous, typ in let aliastyp = if List.for_all (Name.equal Anonymous) nl then None - else Some (CAst.make (indsp,nl)) in + else Some (CAst.make (ci.ci_ind,nl)) in n, aliastyp, Some typ in - let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in - let tag = + let constructs = Array.init (Array.length bl) (fun i -> (ci.ci_ind,i+1)) in + let tag = let st = ci.ci_pp_info.style in try if !Flags.raw_print then RegularStyle else if st == LetPatternStyle then st - else if PrintingLet.active indsp then + else if PrintingLet.active ci.ci_ind then LetStyle - else if PrintingIf.active indsp then + else if PrintingIf.active ci.ci_ind then IfStyle else st with Not_found -> st in + let constagsl = ci.ci_pp_info.cstr_tags in match tag, aliastyp with | LetStyle, None -> let bl' = Array.map detype bl in @@ -793,18 +799,22 @@ and detype_r d flags avoid env sigma t = GRef (GlobRef.IndRef ind_sp, detype_instance sigma u) | Construct (cstr_sp,u) -> GRef (GlobRef.ConstructRef cstr_sp, detype_instance sigma u) - | Case (ci,p,c,bl) -> + | Case (ci,p,iv,c,bl) -> let comp = computable sigma p (List.length (ci.ci_pp_info.ind_tags)) in detype_case comp (detype d flags avoid env sigma) (detype_eqns d flags avoid env sigma ci comp) (is_nondep_branch sigma) avoid - (ci.ci_ind,ci.ci_pp_info.style, - ci.ci_pp_info.cstr_tags,ci.ci_pp_info.ind_tags) - p c bl + ci p iv c bl | Fix (nvn,recdef) -> detype_fix (detype d) flags avoid env sigma nvn recdef | CoFix (n,recdef) -> detype_cofix (detype d) flags avoid env sigma n recdef | Int i -> GInt i | Float f -> GFloat f + | Array(u,t,def,ty) -> + let t = Array.map (detype d flags avoid env sigma) t in + let def = detype d flags avoid env sigma def in + let ty = detype d flags avoid env sigma ty in + let u = detype_instance sigma u in + GArray(u, t, def, ty) and detype_eqns d flags avoid env sigma ci computable constructs consnargsl bl = try @@ -1092,6 +1102,14 @@ let rec subst_glob_constr env subst = DAst.map (function let k' = smartmap_cast_type (subst_glob_constr env subst) k in if r1' == r1 && k' == k then raw else GCast (r1',k') + | GArray (u,t,def,ty) as raw -> + let def' = subst_glob_constr env subst def + and t' = Array.Smart.map (subst_glob_constr env subst) t + and ty' = subst_glob_constr env subst ty + in + if def' == def && t' == t && ty' == ty then raw else + GArray(u,t',def',ty') + ) (* Utilities to transform kernel cases to simple pattern-matching problem *) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 366203faeb..400acc25b6 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -130,7 +130,7 @@ let flex_kind_of_term flags env evd c sk = | Evar ev -> if is_frozen flags ev then Rigid else Flexible ev - | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ | Int _ | Float _ -> Rigid + | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ | Int _ | Float _ | Array _ -> Rigid | Meta _ -> Rigid | Fix _ -> Rigid (* happens when the fixpoint is partially applied *) | Cast _ | App _ | Case _ -> assert false @@ -208,11 +208,11 @@ let occur_rigidly flags env evd (evk,_) t = if rigid_normal_occ b' || rigid_normal_occ t' then Rigid true else Reducible | Rel _ | Var _ -> Reducible - | Case (_,_,c,_) -> + | Case (_,_,_,c,_) -> (match aux c with | Rigid b -> Rigid b | _ -> Reducible) - | Meta _ | Fix _ | CoFix _ | Int _ | Float _ -> Reducible + | Meta _ | Fix _ | CoFix _ | Int _ | Float _ | Array _ -> Reducible in match aux t with | Rigid b -> b @@ -382,7 +382,7 @@ let ise_stack2 no_app env evd f sk1 sk2 = else None, x in match sk1, sk2 with | [], [] -> None, Success i - | Stack.Case (_,t1,c1)::q1, Stack.Case (_,t2,c2)::q2 -> + | Stack.Case (_,t1,_,c1)::q1, Stack.Case (_,t2,_,c2)::q2 -> (match f env i CONV t1 t2 with | Success i' -> (match ise_array2 i' (fun ii -> f env ii CONV) c1 c2 with @@ -417,7 +417,7 @@ let exact_ise_stack2 env evd f sk1 sk2 = let rec ise_stack2 i sk1 sk2 = match sk1, sk2 with | [], [] -> Success i - | Stack.Case (_,t1,c1)::q1, Stack.Case (_,t2,c2)::q2 -> + | Stack.Case (_,t1,_,c1)::q1, Stack.Case (_,t2,_,c2)::q2 -> ise_and i [ (fun i -> ise_stack2 i q1 q2); (fun i -> ise_array2 i (fun ii -> f env ii CONV) c1 c2); @@ -898,7 +898,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty only if necessary) or the second argument is potentially usable as a canonical projection or canonical value *) let rec is_unnamed (hd, args) = match EConstr.kind i hd with - | (Var _|Construct _|Ind _|Const _|Prod _|Sort _|Int _ |Float _) -> + | (Var _|Construct _|Ind _|Const _|Prod _|Sort _|Int _ |Float _|Array _) -> Stack.not_purely_applicative args | (CoFix _|Meta _|Rel _)-> true | Evar _ -> Stack.not_purely_applicative args @@ -1019,7 +1019,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty | Ind _, Ind _ | Construct _, Construct _ | Int _, Int _ - | Float _, Float _ -> + | Float _, Float _ + | Array _, Array _ -> rigids env evd sk1 term1 sk2 term2 | Evar (sp1,al1), Evar (sp2,al2) -> (* Frozen evars *) @@ -1064,9 +1065,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty |Some (sk1',sk2'), Success i' -> evar_conv_x flags env i' CONV (Stack.zip i' (term1,sk1')) (Stack.zip i' (term2,sk2')) end - | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Float _ | Evar _ | Lambda _), _ -> + | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Float _ | Array _ | Evar _ | Lambda _), _ -> UnifFailure (evd,NotSameHead) - | _, (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Evar _ | Lambda _) -> + | _, (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Array _ | Evar _ | Lambda _) -> UnifFailure (evd,NotSameHead) | Case _, _ -> UnifFailure (evd,NotSameHead) | Proj _, _ -> UnifFailure (evd,NotSameHead) @@ -1410,11 +1411,10 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = refresh_universes ~status:Evd.univ_flexible (Some true) env_evar_unf evd evty else evd, evty in - let (evd, ev) = new_evar_instance sign evd evty ~filter instance in - let evk = fst (destEvar evd ev) in + let (evd, evk) = new_pure_evar sign evd evty ~filter in evsref := (evk,evty,inst,prefer_abstraction)::!evsref; fixed := Evar.Set.add evk !fixed; - evd, ev + evd, mkEvar (evk, instance) in let evd, rhs' = apply_on_subterm env_rhs evd fixed set_var test c rhs in if debug_ho_unification () then diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 71edcaa231..f33030d6a4 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -180,26 +180,71 @@ let define_evar_as_sort env evd (ev,args) = constraint on its domain and codomain. If the input constraint is an evar instantiate it with the product of 2 new evars. *) +let rec presplit env sigma c = + let c = Reductionops.whd_all env sigma c in + match EConstr.kind sigma c with + | App (h,args) when isEvar sigma h -> + let sigma, lam = define_evar_as_lambda env sigma (destEvar sigma h) in + (* XXX could be just whd_all -> no recursion? *) + presplit env sigma (mkApp (lam, args)) + | _ -> sigma, c + let split_tycon ?loc env evd tycon = - let rec real_split evd c = - let t = Reductionops.whd_all env evd c in - match EConstr.kind evd t with - | Prod (na,dom,rng) -> evd, (na, dom, rng) - | Evar ev (* ev is undefined because of whd_all *) -> - let (evd',prod) = define_evar_as_product env evd ev in - let (na,dom,rng) = destProd evd prod in - let anon = {na with binder_name = Anonymous} in - evd',(anon, dom, rng) - | App (c,args) when isEvar evd c -> - let (evd',lam) = define_evar_as_lambda env evd (destEvar evd c) in - real_split evd' (mkApp (lam,args)) - | _ -> error_not_product ?loc env evd c - in - match tycon with - | None -> evd,(make_annot Anonymous Relevant,None,None) - | Some c -> - let evd', (n, dom, rng) = real_split evd c in - evd', (n, mk_tycon dom, mk_tycon rng) + match tycon with + | None -> evd,(make_annot Anonymous Relevant,None,None) + | Some c -> + let evd, c = presplit env evd c in + let evd, na, dom, rng = match EConstr.kind evd c with + | Prod (na,dom,rng) -> evd, na, dom, rng + | Evar ev -> + let (evd,prod) = define_evar_as_product env evd ev in + let (na,dom,rng) = destProd evd prod in + let anon = {na with binder_name = Anonymous} in + evd, anon, dom, rng + | _ -> + (* XXX no error to allow later coercion? Not sure if possible with funclass *) + error_not_product ?loc env evd c + in + evd, (na, mk_tycon dom, mk_tycon rng) + + +let define_pure_evar_as_array env sigma evk = + let evi = Evd.find_undefined sigma evk in + let evenv = evar_env env evi in + let evksrc = evar_source evk sigma in + let src = subterm_source evk ~where:Domain evksrc in + let sigma, (ty,u) = new_type_evar evenv sigma univ_flexible ~src ~filter:(evar_filter evi) in + let concl = Reductionops.whd_all evenv sigma evi.evar_concl in + let s = destSort sigma concl in + (* array@{u} ty : Type@{u} <= Type@{s} *) + let sigma = Evd.set_leq_sort env sigma u (ESorts.kind sigma s) in + let u = Option.get (Univ.Universe.level (Sorts.univ_of_sort u)) in + let ar = Typeops.type_of_array env (Univ.Instance.of_array [|u|]) in + let sigma = Evd.define evk (mkApp (EConstr.of_constr ar, [| ty |])) sigma in + sigma + +let is_array_const env sigma c = + match EConstr.kind sigma c with + | Const (cst,_) -> + (match env.Environ.retroknowledge.Retroknowledge.retro_array with + | None -> false + | Some cst' -> Constant.equal cst cst') + | _ -> false + +let split_as_array env sigma0 = function + | None -> sigma0, None + | Some c -> + let sigma, c = presplit env sigma0 c in + match EConstr.kind sigma c with + | App (h,[|ty|]) when is_array_const env sigma h -> sigma, Some ty + | Evar ev -> + let sigma = define_pure_evar_as_array env sigma (fst ev) in + let ty = match EConstr.kind sigma c with + | App (_,[|ty|]) -> ty + | _ -> assert false + in + sigma, Some ty + | _ -> sigma0, None let valcon_of_tycon x = x let lift_tycon n = Option.map (lift n) diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli index a4169c2298..e5c3f8baa1 100644 --- a/pretyping/evardefine.mli +++ b/pretyping/evardefine.mli @@ -35,6 +35,11 @@ val split_tycon : ?loc:Loc.t -> env -> evar_map -> type_constraint -> evar_map * (Name.t Context.binder_annot * type_constraint * type_constraint) +val split_as_array : env -> evar_map -> type_constraint -> + evar_map * type_constraint +(** If the constraint can be made to look like [array A] return [A], + otherwise return [None] (this makes later coercion possible). *) + val valcon_of_tycon : type_constraint -> val_constraint val lift_tycon : int -> type_constraint -> type_constraint diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 348d7c0b2f..79839099f7 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -698,10 +698,9 @@ let make_projectable_subst aliases sigma evi args = *) let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env = - let (evd, evar_in_env) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in + let (evd, evk) = new_pure_evar sign evd ty_t_in_sign ~filter ~src in let t_in_env = whd_evar evd t_in_env in - let (evk, _) = destEvar evd evar_in_env in - let evd = define_fun env evd None (destEvar evd evar_in_env) t_in_env in + let evd = define_fun env evd None (evk, inst_in_env) t_in_env in let ctxt = named_context_of_val sign in let inst_in_sign = inst_of_vars (Filter.filter_list filter ctxt) in let evar_in_sign = mkEvar (evk, inst_in_sign) in @@ -770,9 +769,9 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = define_evar_from_virtual_equation define_fun env evd src ty_in_env ty_t_in_sign sign2 filter2 inst2_in_env in let (evd, ev2_in_sign) = - new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in - let ev2_in_env = (fst (destEvar evd ev2_in_sign), inst2_in_env) in - (evd, ev2_in_sign, ev2_in_env) + new_pure_evar sign2 evd ev2ty_in_sign ~filter:filter2 ~src in + let ev2_in_env = (ev2_in_sign, inst2_in_env) in + (evd, mkEvar (ev2_in_sign, inst2_in_sign), ev2_in_env) let restrict_upon_filter evd evk p args = let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index 05abb86f46..81a62a7048 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -110,7 +110,8 @@ let new_evar env sigma ?src ?naming typ = let instance = rel_list (nb_rel env.renamed_env) inst_vars in let (subst, _, sign) = Lazy.force env.extra in let typ' = csubst_subst subst typ in - new_evar_instance sign sigma typ' ?src ?naming instance + let (sigma, evk) = new_pure_evar sign sigma typ' ?src ?naming in + (sigma, mkEvar (evk, instance)) let new_type_evar env sigma ~src = let sigma, s = Evd.new_sort_variable Evd.univ_flexible_alg sigma in diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 342175a512..5bd26be823 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -168,9 +168,12 @@ let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with f c1 c2 && cast_type_eq f t1 t2 | GInt i1, GInt i2 -> Uint63.equal i1 i2 | GFloat f1, GFloat f2 -> Float64.equal f1 f2 + | GArray (u1, t1, def1, ty1), GArray (u2, t2, def2, ty2) -> + Array.equal f t1 t2 && f def1 def2 && f ty1 ty2 && + Option.equal (List.equal glob_level_eq) u1 u2 | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ | GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GCast _ | - GInt _ | GFloat _), _ -> false + GInt _ | GFloat _ | GArray _), _ -> false let rec glob_constr_eq c = mk_glob_constr_eq glob_constr_eq c @@ -231,6 +234,11 @@ let map_glob_constr_left_to_right f = DAst.map (function let comp1 = f c in let comp2 = map_cast_type f k in GCast (comp1,comp2) + | GArray (u,t,def,ty) -> + let comp1 = Array.map_left f t in + let comp2 = f def in + let comp3 = f ty in + GArray (u,comp1,comp2,comp3) | (GVar _ | GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _ | GFloat _) as x -> x ) @@ -263,6 +271,7 @@ let fold_glob_constr f acc = DAst.with_val (function let acc = match k with | CastConv t | CastVM t | CastNative t -> f acc t | CastCoerce -> acc in f acc c + | GArray (_u,t,def,ty) -> f (f (Array.fold_left f acc t) def) ty | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _ | GFloat _) -> acc ) let fold_return_type_with_binders f g v acc (na,tyopt) = @@ -305,6 +314,7 @@ let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function let acc = match k with | CastConv t | CastVM t | CastNative t -> f v acc t | CastCoerce -> acc in f v acc c + | GArray (_u, t, def, ty) -> f v (f v (Array.fold_left (f v) acc t) def) ty | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _ | GFloat _) -> acc)) let iter_glob_constr f = fold_glob_constr (fun () -> f) () diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index bccc30ad62..526eac6f1e 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -92,6 +92,7 @@ type 'a glob_constr_r = | GCast of 'a glob_constr_g * 'a glob_constr_g cast_type | GInt of Uint63.t | GFloat of Float64.t + | GArray of glob_level list option * 'a glob_constr_g array * 'a glob_constr_g * 'a glob_constr_g and 'a glob_constr_g = ('a glob_constr_r, 'a) DAst.t and 'a glob_decl_g = Name.t * binding_kind * 'a glob_constr_g option * 'a glob_constr_g diff --git a/pretyping/heads.ml b/pretyping/heads.ml index 908b8b00d6..d1ac0862ed 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -78,8 +78,8 @@ and kind_of_head env t = | App (c,al) -> aux k (Array.to_list al @ l) c b | Proj (p,c) -> RigidHead RigidOther - | Case (_,_,c,_) -> aux k [] c true - | Int _ | Float _ -> ConstructorHead + | Case (_,_,_,c,_) -> aux k [] c true + | Int _ | Float _ | Array _ -> ConstructorHead | Fix ((i,j),_) -> let n = i.(j) in try aux k [] (List.nth l n) true diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 6132365b27..5be8f9f83c 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -119,8 +119,10 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = in let obj = match projs with - | None -> mkCase (ci, lift ndepar p, mkRel 1, - Termops.rel_vect ndepar k) + | None -> + let iv = make_case_invert env (find_rectype env sigma (EConstr.of_constr (lift 1 depind))) ci in + let iv = EConstr.Unsafe.to_case_invert iv in + mkCase (ci, lift ndepar p, iv, mkRel 1, Termops.rel_vect ndepar k) | Some ps -> let term = mkApp (mkRel 2, @@ -205,7 +207,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = | ra::rest -> (match dest_recarg ra with | Mrec (_,j) when is_rec -> (depPvect.(j),rest) - | Imbr _ -> (None,rest) + | Nested _ -> (None,rest) | _ -> (None, rest)) in (match optionpos with @@ -278,7 +280,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let optionpos = match dest_recarg recarg with | Norec -> None - | Imbr _ -> None + | Nested _ -> None | Mrec (_,i) -> fvect.(i) in (match optionpos with @@ -407,7 +409,8 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = arsign' in let obj = - Inductiveops.make_case_or_project env !evdref indf ci (EConstr.of_constr pred) + let indty = find_rectype env sigma (EConstr.of_constr depind) in + Inductiveops.make_case_or_project env !evdref indty ci (EConstr.of_constr pred) (EConstr.mkRel 1) (Array.map EConstr.of_constr branches) in let obj = EConstr.to_constr !evdref obj in diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index e77c5082dd..23145b1629 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -66,6 +66,8 @@ let relevance_of_inductive_family env ((ind,_),_ : inductive_family) = type inductive_type = IndType of inductive_family * EConstr.constr list +let ind_of_ind_type = function IndType (((ind,_),_),_) -> ind + let make_ind_type (indf, realargs) = IndType (indf,realargs) let dest_ind_type (IndType (indf,realargs)) = (indf,realargs) @@ -332,16 +334,26 @@ let get_constructors env (ind,params) = let get_projections = Environ.get_projections -let make_case_or_project env sigma indf ci pred c branches = +let make_case_invert env (IndType (((ind,u),params),indices)) ci = + if Typeops.should_invert_case env ci + then + let univs = EConstr.EInstance.make u in + let params = Array.map_of_list EConstr.of_constr params in + let args = Array.append params (Array.of_list indices) in + CaseInvert {univs;args} + else NoInvert + +let make_case_or_project env sigma indt ci pred c branches = let open EConstr in - let projs = get_projections env (fst (fst indf)) in + let IndType (((ind,_),_),_) = indt in + let projs = get_projections env ind in match projs with - | None -> (mkCase (ci, pred, c, branches)) + | None -> + mkCase (ci, pred, make_case_invert env indt ci, c, branches) | Some ps -> assert(Array.length branches == 1); let na, ty, t = destLambda sigma pred in let () = - let (ind, _), _ = dest_ind_family indf in let mib, _ = Inductive.lookup_mind_specif env ind in if (* dependent *) not (Vars.noccurn sigma 1 t) && not (has_dependent_elim mib) then diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 2bec86599e..1e2bba9f73 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -48,6 +48,7 @@ val map_inductive_type : (EConstr.constr -> EConstr.constr) -> inductive_type -> val liftn_inductive_type : int -> int -> inductive_type -> inductive_type val lift_inductive_type : int -> inductive_type -> inductive_type val substnl_ind_type : EConstr.constr list -> int -> inductive_type -> inductive_type +val ind_of_ind_type : inductive_type -> inductive val relevance_of_inductive_type : env -> inductive_type -> Sorts.relevance @@ -204,9 +205,12 @@ val make_case_info : env -> inductive -> Sorts.relevance -> case_style -> case_i Fail with an error if the elimination is dependent while the inductive type does not allow dependent elimination. *) val make_case_or_project : - env -> evar_map -> inductive_family -> case_info -> + env -> evar_map -> inductive_type -> case_info -> (* pred *) EConstr.constr -> (* term *) EConstr.constr -> (* branches *) EConstr.constr array -> EConstr.constr +val make_case_invert : env -> inductive_type -> case_info + -> (EConstr.constr,EConstr.EInstance.t) case_invert + (*i Compatibility val make_default_case_info : env -> case_style -> inductive -> case_info i*) diff --git a/pretyping/keys.ml b/pretyping/keys.ml index 1e4f2f2340..7a7099c195 100644 --- a/pretyping/keys.ml +++ b/pretyping/keys.ml @@ -27,6 +27,7 @@ type key = | KRel | KInt | KFloat + | KArray module KeyOrdered = struct type t = key @@ -44,6 +45,7 @@ module KeyOrdered = struct | KRel -> 7 | KInt -> 8 | KFloat -> 9 + | KArray -> 10 let compare gr1 gr2 = match gr1, gr2 with @@ -138,6 +140,7 @@ let constr_key kind c = | LetIn _ -> KLet | Int _ -> KInt | Float _ -> KFloat + | Array _ -> KArray in Some (aux c) with Not_found -> None @@ -155,6 +158,7 @@ let pr_key pr_global = function | KRel -> str"Rel" | KInt -> str"Int" | KFloat -> str"Float" + | KArray -> str"Array" let pr_keyset pr_global v = prlist_with_sep spc (pr_key pr_global) (Keyset.elements v) diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index d672ddc906..30e1dc0611 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -214,6 +214,7 @@ let rec nf_val env sigma v typ = | Vconst n -> construct_of_constr_const env sigma n typ | Vint64 i -> i |> Uint63.of_int64 |> mkInt | Vfloat64 f -> f |> Float64.of_float |> mkFloat + | Varray t -> nf_array env sigma t typ | Vblock b -> let capp,ctyp = construct_of_constr_block env sigma (block_tag b) typ in let args = nf_bargs env sigma b ctyp in @@ -317,6 +318,11 @@ and nf_atom_type env sigma atom = | Avar id -> mkVar id, Typeops.type_of_variable env id | Acase(ans,accu,p,bs) -> + let () = if Typeops.should_invert_case env ans.asw_ci then + (* TODO implement case inversion readback (properly reducing + it is a problem for the kernel) *) + CErrors.user_err Pp.(str "Native compute readback of case inversion not implemented.") + in let a,ta = nf_accu_type env sigma accu in let ((mind,_),u as ind),allargs = find_rectype_a env ta in let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in @@ -338,8 +344,7 @@ and nf_atom_type env sigma atom = in let branchs = Array.mapi mkbranch bsw in let tcase = build_case_type p realargs a in - let ci = ans.asw_ci in - mkCase(ci, p, a, branchs), tcase + mkCase(ans.asw_ci, p, NoInvert, a, branchs), tcase | Afix(tt,ft,rp,s) -> let tt = Array.map (fun t -> nf_type_sort env sigma t) tt in let tt = Array.map fst tt and rt = Array.map snd tt in @@ -438,6 +443,14 @@ and nf_evar env sigma evk args = evar node *) mkEvar (evk, List.rev args), ty +and nf_array env sigma t typ = + let ty, allargs = app_type env typ in + let typ_elem = allargs.(0) in + let t, vdef = Parray.to_array t in + let t = Array.map (fun v -> nf_val env sigma v typ_elem) t in + let u = snd (destConst ty) in + mkArray(u, t, nf_val env sigma vdef typ_elem, typ_elem) + let evars_of_evar_map sigma = { Nativelambda.evars_val = Evd.existential_opt_value0 sigma; Nativelambda.evars_metas = Evd.meta_type0 sigma } diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index 1dfb8b2cd1..f6d61f4892 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -41,6 +41,7 @@ type constr_pattern = | PCoFix of int * (Name.t array * constr_pattern array * constr_pattern array) | PInt of Uint63.t | PFloat of Float64.t + | PArray of constr_pattern array * constr_pattern * constr_pattern (** Nota : in a [PCase], the array of branches might be shorter than expected, denoting the use of a final "_ => _" branch *) diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 6d30e0338e..8c3d624f0f 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -64,10 +64,13 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with Uint63.equal i1 i2 | PFloat f1, PFloat f2 -> Float64.equal f1 f2 +| PArray (t1, def1, ty1), PArray (t2, def2, ty2) -> + Array.equal constr_pattern_eq t1 t2 && constr_pattern_eq def1 def2 + && constr_pattern_eq ty1 ty2 | (PRef _ | PVar _ | PEvar _ | PRel _ | PApp _ | PSoApp _ | PLambda _ | PProd _ | PLetIn _ | PSort _ | PMeta _ | PIf _ | PCase _ | PFix _ | PCoFix _ | PProj _ | PInt _ - | PFloat _), _ -> false + | PFloat _ | PArray _), _ -> false (** FIXME: fixpoint and cofixpoint should be relativized to pattern *) and pattern_eq (i1, j1, p1) (i2, j2, p2) = @@ -93,6 +96,8 @@ let rec occur_meta_pattern = function (occur_meta_pattern p) || (occur_meta_pattern c) || (List.exists (fun (_,_,p) -> occur_meta_pattern p) br) + | PArray (t,def,ty) -> + Array.exists occur_meta_pattern t || occur_meta_pattern def || occur_meta_pattern ty | PMeta _ | PSoApp _ -> true | PEvar _ | PVar _ | PRef _ | PRel _ | PSort _ | PFix _ | PCoFix _ | PInt _ | PFloat _ -> false @@ -121,6 +126,8 @@ let rec occurn_pattern n = function Array.exists (occurn_pattern n) tl || Array.exists (occurn_pattern (n+Array.length tl)) bl | PCoFix (_,(_,tl,bl)) -> Array.exists (occurn_pattern n) tl || Array.exists (occurn_pattern (n+Array.length tl)) bl + | PArray (t,def,ty) -> + Array.exists (occurn_pattern n) t || occurn_pattern n def || occurn_pattern n ty let noccurn_pattern n c = not (occurn_pattern n c) @@ -139,7 +146,8 @@ let rec head_pattern_bound t = -> raise BoundPattern (* Perhaps they were arguments, but we don't beta-reduce *) | PLambda _ -> raise BoundPattern - | PCoFix _ | PInt _ | PFloat _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type.") + | PCoFix _ | PInt _ | PFloat _ | PArray _ -> + anomaly ~label:"head_pattern_bound" (Pp.str "not a type.") let head_of_constr_reference sigma c = match EConstr.kind sigma c with | Const (sp,_) -> GlobRef.ConstRef sp @@ -193,8 +201,8 @@ let pattern_of_constr env sigma t = else PEvar (evk,List.map (pattern_of_constr env) ctxt) | Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar ido) -> assert false | _ -> - PMeta None) - | Case (ci,p,a,br) -> + PMeta None) + | Case (ci,p,_,a,br) -> let cip = { cip_style = ci.ci_pp_info.style; cip_ind = Some ci.ci_ind; @@ -217,7 +225,10 @@ let pattern_of_constr env sigma t = PCoFix (ln,(Array.map binder_name lna,Array.map (pattern_of_constr env) tl, Array.map (pattern_of_constr env') bl)) | Int i -> PInt i - | Float f -> PFloat f in + | Float f -> PFloat f + | Array (_u, t, def, ty) -> + PArray (Array.map (pattern_of_constr env) t, pattern_of_constr env def, pattern_of_constr env ty) + in pattern_of_constr env t (* To process patterns, we need a translation without typing at all. *) @@ -238,6 +249,7 @@ let map_pattern_with_binders g f l = function | PCoFix (ln,(lna,tl,bl)) -> let l' = Array.fold_left (fun l na -> g na l) l lna in PCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) + | PArray (t,def,ty) -> PArray (Array.map (f l) t, f l def, f l ty) (* Non recursive *) | (PVar _ | PEvar _ | PRel _ | PRef _ | PSort _ | PMeta _ | PInt _ | PFloat _ as x) -> x @@ -359,6 +371,12 @@ let rec subst_pattern env sigma subst pat = let bl' = Array.Smart.map (subst_pattern env sigma subst) bl in if bl' == bl && tl' == tl then pat else PCoFix (ln,(lna,tl',bl')) + | PArray (t,def,ty) -> + let t' = Array.Smart.map (subst_pattern env sigma subst) t in + let def' = subst_pattern env sigma subst def in + let ty' = subst_pattern env sigma subst ty in + if def' == def && t' == t && ty' == ty then pat + else PArray (t',def',ty') let mkPLetIn na b t c = PLetIn(na,b,t,c) let mkPProd na t u = PProd(na,t,u) @@ -502,7 +520,7 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function | GInt i -> PInt i | GFloat f -> PFloat f - | GPatVar _ | GIf _ | GLetTuple _ | GCases _ | GEvar _ -> + | GPatVar _ | GIf _ | GLetTuple _ | GCases _ | GEvar _ | GArray _ -> err ?loc (Pp.str "Non supported pattern.")) and pat_of_glob_in_context metas vars decls c = diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 1b6c17fcf9..b9825b6a92 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -508,6 +508,7 @@ type pretyper = { pretype_cast : pretyper -> glob_constr * glob_constr cast_type -> unsafe_judgment pretype_fun; pretype_int : pretyper -> Uint63.t -> unsafe_judgment pretype_fun; pretype_float : pretyper -> Float64.t -> unsafe_judgment pretype_fun; + pretype_array : pretyper -> glob_level list option * glob_constr array * glob_constr * glob_constr -> unsafe_judgment pretype_fun; pretype_type : pretyper -> glob_constr -> unsafe_type_judgment pretype_fun; } @@ -549,6 +550,8 @@ let eval_pretyper self ~program_mode ~poly resolve_tc tycon env sigma t = self.pretype_int self n ?loc ~program_mode ~poly resolve_tc tycon env sigma | GFloat f -> self.pretype_float self f ?loc ~program_mode ~poly resolve_tc tycon env sigma + | GArray (u,t,def,ty) -> + self.pretype_array self (u,t,def,ty) ?loc ~program_mode ~poly resolve_tc tycon env sigma let eval_type_pretyper self ~program_mode ~poly resolve_tc tycon env sigma t = self.pretype_type self t ~program_mode ~poly resolve_tc tycon env sigma @@ -991,7 +994,7 @@ struct let pretype tycon env sigma c = eval_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in let pretype_type tycon env sigma c = eval_type_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in let sigma, cj = pretype empty_tycon env sigma c in - let (IndType (indf,realargs)) = + let (IndType (indf,realargs)) as indty = try find_rectype !!env sigma cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in @@ -1028,11 +1031,11 @@ struct let fsign = Context.Rel.map (whd_betaiota !!env sigma) fsign in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let fsign,env_f = push_rel_context ~hypnaming sigma fsign env in - let obj ind rci p v f = + let obj indt rci p v f = if not record then let f = it_mkLambda_or_LetIn f fsign in - let ci = make_case_info !!env (fst ind) rci LetStyle in - mkCase (ci, p, cj.uj_val,[|f|]) + let ci = make_case_info !!env (ind_of_ind_type indt) rci LetStyle in + mkCase (ci, p, make_case_invert !!env indt ci, cj.uj_val,[|f|]) else it_mkLambda_or_LetIn f fsign in (* Make dependencies from arity signature impossible *) @@ -1060,7 +1063,7 @@ struct let v = let ind,_ = dest_ind_family indf in let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val p in - obj ind rci p cj.uj_val fj.uj_val + obj indty rci p cj.uj_val fj.uj_val in sigma, { uj_val = v; uj_type = (substl (realargs@[cj.uj_val]) ccl) } @@ -1079,7 +1082,7 @@ struct let v = let ind,_ = dest_ind_family indf in let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val p in - obj ind rci p cj.uj_val fj.uj_val + obj indty rci p cj.uj_val fj.uj_val in sigma, { uj_val = v; uj_type = ccl }) let pretype_cases self (sty, po, tml, eqns) = @@ -1092,7 +1095,7 @@ struct let open Context.Rel.Declaration in let pretype tycon env sigma c = eval_pretyper self ~program_mode ~poly resolve_tc tycon env sigma c in let sigma, cj = pretype empty_tycon env sigma c in - let (IndType (indf,realargs)) = + let (IndType (indf,realargs)) as indty = try find_rectype !!env sigma cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in @@ -1148,7 +1151,7 @@ struct let pred = nf_evar sigma pred in let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val pred in let ci = make_case_info !!env (fst ind) rci IfStyle in - mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + mkCase (ci, pred, make_case_invert !!env indty ci, cj.uj_val, [|b1;b2|]) in let cj = { uj_val = v; uj_type = p } in discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma cj tycon @@ -1196,24 +1199,6 @@ struct sigma, { uj_val = v; uj_type = tval } in discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma cj tycon - let pretype_int self i = - fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> - let resj = - try Typing.judge_of_int !!env i - with Invalid_argument _ -> - user_err ?loc ~hdr:"pretype" (str "Type of int63 should be registered first.") - in - discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon - - let pretype_float self f = - fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> - let resj = - try Typing.judge_of_float !!env f - with Invalid_argument _ -> - user_err ?loc ~hdr:"pretype" (str "Type of float should be registered first.") - in - discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon - (* [pretype_type valcon env sigma c] coerces [c] into a type *) let pretype_type self c ?loc ~program_mode ~poly resolve_tc valcon (env : GlobEnv.t) sigma = match DAst.get c with | GHole (knd, naming, None) -> @@ -1255,6 +1240,52 @@ let pretype_type self c ?loc ~program_mode ~poly resolve_tc valcon (env : GlobEn ?loc:(loc_of_glob_constr c) !!env sigma tj.utj_val v end + let pretype_int self i = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + let resj = + try Typing.judge_of_int !!env i + with Invalid_argument _ -> + user_err ?loc ~hdr:"pretype" (str "Type of int63 should be registered first.") + in + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon + + let pretype_float self f = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + let resj = + try Typing.judge_of_float !!env f + with Invalid_argument _ -> + user_err ?loc ~hdr:"pretype" (str "Type of float should be registered first.") + in + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon + + let pretype_array self (u,t,def,ty) = + fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> + let sigma, tycon' = split_as_array !!env sigma tycon in + let sigma, jty = eval_type_pretyper self ~program_mode ~poly resolve_tc tycon' env sigma ty in + (* XXX not sure if we need to be this complex, I wrote this while + being confused by broken universe substitutions *) + let sigma, u = match Univ.Universe.level (Sorts.univ_of_sort jty.utj_type) with + | Some u -> + let sigma = Evd.make_nonalgebraic_variable sigma u in + sigma, u + | None -> + let sigma, u = Evd.new_univ_level_variable UState.univ_flexible sigma in + let sigma = Evd.set_leq_sort !!env sigma jty.utj_type + (Sorts.sort_of_univ (Univ.Universe.make u)) + in + sigma, u + in + let sigma, jdef = eval_pretyper self ~program_mode ~poly resolve_tc (mk_tycon jty.utj_val) env sigma def in + let pretype_elem = eval_pretyper self ~program_mode ~poly resolve_tc (mk_tycon jty.utj_val) env in + let sigma, jt = Array.fold_left_map pretype_elem sigma t in + let u = Univ.Instance.of_array [| u |] in + let ta = EConstr.of_constr @@ Typeops.type_of_array !!env u in + let j = { + uj_val = EConstr.mkArray(EInstance.make u, Array.map (fun j -> j.uj_val) jt, jdef.uj_val, jty.utj_val); + uj_type = EConstr.mkApp(ta,[|jdef.uj_type|]) + } in + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma j tycon + end (* [pretype tycon env sigma lvar lmeta cstr] attempts to type [cstr] *) @@ -1281,6 +1312,7 @@ let default_pretyper = pretype_cast = pretype_cast; pretype_int = pretype_int; pretype_float = pretype_float; + pretype_array = pretype_array; pretype_type = pretype_type; } diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 8be7b1477b..c03374c59f 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -163,6 +163,7 @@ type pretyper = { pretype_cast : pretyper -> glob_constr * glob_constr cast_type -> unsafe_judgment pretype_fun; pretype_int : pretyper -> Uint63.t -> unsafe_judgment pretype_fun; pretype_float : pretyper -> Float64.t -> unsafe_judgment pretype_fun; + pretype_array : pretyper -> glob_level list option * glob_constr array * glob_constr * glob_constr -> unsafe_judgment pretype_fun; pretype_type : pretyper -> glob_constr -> unsafe_type_judgment pretype_fun; } (** Type of pretyping algorithms in open-recursion style. A typical way to diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index a8e934d3c6..c26da8ccc7 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -185,7 +185,7 @@ let rec cs_pattern_of_constr env t = | Rel n -> Default_cs, Some n, [] | Prod (_,a,b) when Vars.noccurn 1 b -> Prod_cs, None, [a; Vars.lift (-1) b] | Proj (p, c) -> - let { Environ.uj_type = ty } = Typeops.infer env c in + let ty = Retyping.get_type_of_constr env c in let _, params = Inductive.find_rectype env ty in Const_cs (GlobRef.ConstRef (Projection.constant p)), None, params @ [c] | Sort s -> Sort_cs (Sorts.family s), None, [] diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 8ab040b3b1..594b8ab54c 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -179,7 +179,7 @@ sig type 'a member = | App of 'a app_node - | Case of case_info * 'a * 'a array + | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array | Proj of Projection.t | Fix of ('a, 'a) pfixpoint * 'a t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red @@ -231,7 +231,7 @@ struct type 'a member = | App of 'a app_node - | Case of case_info * 'a * 'a array + | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array | Proj of Projection.t | Fix of ('a, 'a) pfixpoint * 'a t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red @@ -244,7 +244,7 @@ struct let pr_c x = hov 1 (pr_c x) in match member with | App app -> str "ZApp" ++ pr_app_node pr_c app - | Case (_,_,br) -> + | Case (_,_,_,br) -> str "ZCase(" ++ prvect_with_sep (pr_bar) pr_c br ++ str ")" @@ -285,7 +285,7 @@ struct ([],[]) -> Int.equal bal 0 | (App (i,_,j)::s1, _) -> compare_rec (bal + j + 1 - i) s1 stk2 | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 - | (Case(c1,_,_)::s1, Case(c2,_,_)::s2) -> + | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Proj (p)::s1, Proj(p2)::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 @@ -305,7 +305,7 @@ struct let t1,l1 = decomp_node_last n1 q1 in let t2,l2 = decomp_node_last n2 q2 in aux (f o t1 t2) l1 l2 - | Case (_,t1,a1) :: q1, Case (_,t2,a2) :: q2 -> + | Case (_,t1,_,a1) :: q1, Case (_,t2,_,a2) :: q2 -> aux (Array.fold_left2 f (f o t1 t2) a1 a2) q1 q2 | Proj (p1) :: q1, Proj (p2) :: q2 -> aux o q1 q2 @@ -321,7 +321,8 @@ struct | App (i,a,j) -> let le = j - i + 1 in App (0,Array.map f (Array.sub a i le), le-1) - | Case (info,ty,br) -> Case (info, f ty, Array.map f br) + | Case (info,ty,iv,br) -> + Case (info, f ty, map_invert f iv, Array.map f br) | Fix ((r,(na,ty,bo)),arg) -> Fix ((r,(na,Array.map f ty, Array.map f bo)),map f arg) | Primitive (p,c,args,kargs) -> @@ -403,7 +404,7 @@ struct then a else Array.sub a i (j - i + 1) in zip (mkApp (f, a'), s) - | f, (Case (ci,rt,br)::s) -> zip (mkCase (ci,rt,f,br), s) + | f, (Case (ci,rt,iv,br)::s) -> zip (mkCase (ci,rt,iv,f,br), s) | f, (Fix (fix,st)::s) -> zip (mkFix fix, st @ (append_app [|f|] s)) | f, (Proj (p)::s) -> zip (mkProj (p,f),s) @@ -421,8 +422,8 @@ struct let get_next_primitive_args kargs stk = let rec nargs = function | [] -> 0 - | CPrimitives.Kwhnf :: _ -> 0 - | _ :: s -> 1 + nargs s + | (CPrimitives.Kwhnf | CPrimitives.Karg) :: _ -> 0 + | CPrimitives.Kparam :: s -> 1 + nargs s in let n = nargs kargs in (List.skipn (n+1) kargs, strip_n_app n stk) @@ -435,15 +436,11 @@ type state = constr * constr Stack.t type reduction_function = env -> evar_map -> constr -> constr type e_reduction_function = env -> evar_map -> constr -> evar_map * constr -type contextual_stack_reduction_function = +type stack_reduction_function = env -> evar_map -> constr -> constr * constr list -type stack_reduction_function = contextual_stack_reduction_function -type local_stack_reduction_function = - evar_map -> constr -> constr * constr list type state_reduction_function = env -> evar_map -> state -> state -type local_state_reduction_function = evar_map -> state -> state let pr_state env sigma (tm,sk) = let open Pp in @@ -536,12 +533,13 @@ let reduce_and_refold_cofix recfun env sigma cofix sk = let reduce_mind_case sigma mia = match EConstr.kind sigma mia.mconstr with | Construct ((ind_sp,i),u) -> -(* let ncargs = (fst mia.mci).(i-1) in*) +(* let ncargs = (fst mia.mci).(i-1) in*) let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1),real_cargs) | CoFix cofix -> let cofix_def = contract_cofix sigma cofix in - mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) + (* XXX Is NoInvert OK here? *) + mkCase (mia.mci, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false (* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce @@ -570,14 +568,6 @@ let reduce_and_refold_fix recfun env sigma fix sk = (fun _ (t,sk') -> recfun (t,sk')) [] sigma raw_answer sk -let fix_recarg ((recindices,bodynum),_) stack = - assert (0 <= bodynum && bodynum < Array.length recindices); - let recargnum = Array.get recindices bodynum in - try - Some (recargnum, Stack.nth stack recargnum) - with Not_found -> - None - open Primred module CNativeEntries = @@ -586,6 +576,7 @@ struct type elem = EConstr.t type args = EConstr.t array type evd = evar_map + type uinstance = EConstr.EInstance.t let get = Array.get @@ -599,6 +590,11 @@ struct | Float f -> f | _ -> raise Primred.NativeDestKO + let get_parray evd e = + match EConstr.kind evd e with + | Array(_u,t,def,_ty) -> Parray.of_array t def + | _ -> raise Not_found + let mkInt env i = mkInt i @@ -609,12 +605,12 @@ struct let (ct,cf) = get_bool_constructors env in mkConstruct (if b then ct else cf) - let mkCarry env b e = - let int_ty = mkConst @@ get_int_type env in - let (c0,c1) = get_carry_constructors env in - mkApp (mkConstruct (if b then c1 else c0),[|int_ty;e|]) + let mkCarry env b e = + let int_ty = mkConst @@ get_int_type env in + let (c0,c1) = get_carry_constructors env in + mkApp (mkConstruct (if b then c1 else c0),[|int_ty;e|]) - let mkIntPair env e1 e2 = + let mkIntPair env e1 e2 = let int_ty = mkConst @@ get_int_type env in let c = get_pair_constructor env in mkApp(mkConstruct c, [|int_ty;int_ty;e1;e2|]) @@ -697,6 +693,11 @@ struct let (_pNormal,_nNormal,_pSubn,_nSubn,_pZero,_nZero,_pInf,_nInf,nan) = get_f_class_constructors env in mkConstruct nan + + let mkArray env u t ty = + let (t,def) = Parray.to_array t in + mkArray(u,t,def,ty) + end module CredNative = RedNative(CNativeEntries) @@ -765,7 +766,7 @@ let rec whd_state_gen flags env sigma = let body = EConstr.of_constr body in whrec (body, stack) end - | exception NotEvaluableConst (IsPrimitive p) when Stack.check_native_args p stack -> + | exception NotEvaluableConst (IsPrimitive (u,p)) when Stack.check_native_args p stack -> let kargs = CPrimitives.kind p in let (kargs,o) = Stack.get_next_primitive_args kargs stack in (* Should not fail thanks to [check_native_args] *) @@ -805,8 +806,8 @@ let rec whd_state_gen flags env sigma = | _ -> fold ()) | _ -> fold ()) - | Case (ci,p,d,lf) -> - whrec (d, Stack.Case (ci,p,lf) :: stack) + | Case (ci,p,iv,d,lf) -> + whrec (d, Stack.Case (ci,p,iv,lf) :: stack) | Fix ((ri,n),_ as f) -> (match Stack.strip_n_app ri.(n) stack with @@ -819,7 +820,7 @@ let rec whd_state_gen flags env sigma = let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, lf)::s') when use_match -> + |args, (Stack.Case(ci, _, _, lf)::s') when use_match -> whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') |args, (Stack.Proj (p)::s') when use_match -> whrec (Stack.nth args (Projection.npars p + Projection.arg p), s') @@ -839,9 +840,9 @@ let rec whd_state_gen flags env sigma = |_ -> fold () else fold () - | Int _ | Float _ -> + | Int _ | Float _ | Array _ -> begin match Stack.strip_app stack with - | (_, Stack.Primitive(p,kn,rargs,kargs)::s) -> + | (_, Stack.Primitive(p,(_, u as kn),rargs,kargs)::s) -> let more_to_reduce = List.exists (fun k -> CPrimitives.Kwhnf = k) kargs in if more_to_reduce then let (kargs,o) = Stack.get_next_primitive_args kargs s in @@ -856,10 +857,11 @@ let rec whd_state_gen flags env sigma = with List.IndexOutOfRange -> (args,[]) (* FIXME probably useless *) in let args = Array.of_list (Option.get (Stack.list_of_app_stack (rargs @ Stack.append_app [|x|] args))) in - begin match CredNative.red_prim env sigma p args with - | Some t -> whrec (t,s) - | None -> ((mkApp (mkConstU kn, args), s)) - end + let s = extra_args @ s in + begin match CredNative.red_prim env sigma p u args with + | Some t -> whrec (t,s) + | None -> ((mkApp (mkConstU kn, args), s)) + end | _ -> fold () end @@ -901,8 +903,8 @@ let local_whd_state_gen flags _env sigma = | Proj (p,c) when CClosure.RedFlags.red_projection flags p -> (whrec (c, Stack.Proj (p) :: stack)) - | Case (ci,p,d,lf) -> - whrec (d, Stack.Case (ci,p,lf) :: stack) + | Case (ci,p,iv,d,lf) -> + whrec (d, Stack.Case (ci,p,iv,lf) :: stack) | Fix ((ri,n),_ as f) -> (match Stack.strip_n_app ri.(n) stack with @@ -920,7 +922,7 @@ let local_whd_state_gen flags _env sigma = let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, lf)::s') when use_match -> + |args, (Stack.Case(ci, _, _, lf)::s') when use_match -> whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') |args, (Stack.Proj (p) :: s') when use_match -> whrec (Stack.nth args (Projection.npars p + Projection.arg p), s') @@ -940,7 +942,7 @@ let local_whd_state_gen flags _env sigma = else s | Rel _ | Var _ | Sort _ | Prod _ | LetIn _ | Const _ | Ind _ | Proj _ - | Int _ | Float _ -> s + | Int _ | Float _ | Array _ -> s in whrec @@ -1035,7 +1037,7 @@ let clos_norm_flags flgs env sigma t = try let evars ev = safe_evar_value sigma ev in EConstr.of_constr (CClosure.norm_val - (CClosure.create_clos_infos ~evars flgs env) + (CClosure.create_clos_infos ~univs:(Evd.universes sigma) ~evars flgs env) (CClosure.create_tab ()) (CClosure.inject (EConstr.Unsafe.to_constr t))) with e when is_anomaly e -> user_err Pp.(str "Tried to normalize ill-typed term") @@ -1044,7 +1046,7 @@ let clos_whd_flags flgs env sigma t = try let evars ev = safe_evar_value sigma ev in EConstr.of_constr (CClosure.whd_val - (CClosure.create_clos_infos ~evars flgs env) + (CClosure.create_clos_infos ~univs:(Evd.universes sigma) ~evars flgs env) (CClosure.create_tab ()) (CClosure.inject (EConstr.Unsafe.to_constr t))) with e when is_anomaly e -> user_err Pp.(str "Tried to normalize ill-typed term") @@ -1148,7 +1150,8 @@ let sigma_check_inductive_instances cv_pb variance u1 u2 sigma = let sigma_univ_state = let open Reduction in - { compare_sorts = sigma_compare_sorts; + { compare_graph = Evd.universes; + compare_sorts = sigma_compare_sorts; compare_instances = sigma_compare_instances; compare_cumul_instances = sigma_check_inductive_instances; } diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index a0cbd8ccf7..218936edfb 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -23,6 +23,7 @@ val debug_RAKAM : unit -> bool module CredNative : Primred.RedNative with type elem = EConstr.t and type args = EConstr.t array and type evd = Evd.evar_map + and type uinstance = EInstance.t (** Machinery to customize the behavior of the reduction *) module ReductionBehaviour : sig @@ -58,7 +59,7 @@ module Stack : sig type 'a member = | App of 'a app_node - | Case of case_info * 'a * 'a array + | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array | Proj of Projection.t | Fix of ('a, 'a) pfixpoint * 'a t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red @@ -111,15 +112,11 @@ type reduction_function = env -> evar_map -> constr -> constr type e_reduction_function = env -> evar_map -> constr -> evar_map * constr -type contextual_stack_reduction_function = +type stack_reduction_function = env -> evar_map -> constr -> constr * constr list -type stack_reduction_function = contextual_stack_reduction_function -type local_stack_reduction_function = - evar_map -> constr -> constr * constr list type state_reduction_function = env -> evar_map -> state -> state -type local_state_reduction_function = evar_map -> state -> state val pr_state : env -> evar_map -> state -> Pp.t @@ -129,11 +126,6 @@ val strong_with_flags : (CClosure.RedFlags.reds -> reduction_function) -> (CClosure.RedFlags.reds -> reduction_function) val strong : reduction_function -> reduction_function -(*i -val stack_reduction_of_reduction : - 'a reduction_function -> 'a state_reduction_function -i*) -val stacklam : (state -> 'a) -> constr list -> evar_map -> constr -> constr Stack.t -> 'a val whd_state_gen : CClosure.RedFlags.reds -> Environ.env -> Evd.evar_map -> state -> state @@ -166,13 +158,13 @@ val whd_allnolet : reduction_function val whd_betalet : reduction_function (** Removes cast and put into applicative form *) -val whd_nored_stack : contextual_stack_reduction_function -val whd_beta_stack : contextual_stack_reduction_function -val whd_betaiota_stack : contextual_stack_reduction_function -val whd_betaiotazeta_stack : contextual_stack_reduction_function -val whd_all_stack : contextual_stack_reduction_function -val whd_allnolet_stack : contextual_stack_reduction_function -val whd_betalet_stack : contextual_stack_reduction_function +val whd_nored_stack : stack_reduction_function +val whd_beta_stack : stack_reduction_function +val whd_betaiota_stack : stack_reduction_function +val whd_betaiotazeta_stack : stack_reduction_function +val whd_all_stack : stack_reduction_function +val whd_allnolet_stack : stack_reduction_function +val whd_betalet_stack : stack_reduction_function val whd_nored_state : state_reduction_function val whd_beta_state : state_reduction_function @@ -241,7 +233,6 @@ val is_arity : env -> evar_map -> constr -> bool val is_sort : env -> evar_map -> types -> bool val contract_fix : evar_map -> fixpoint -> constr -val fix_recarg : ('a, 'a) pfixpoint -> 'b Stack.t -> (int * 'b) option (** {6 Querying the kernel conversion oracle: opaque/transparent constants } *) val is_transparent : Environ.env -> Constant.t tableKey -> bool diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 5ec5005b3e..4bd22e76cb 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -121,7 +121,7 @@ let retype ?(polyprop=true) sigma = | Evar ev -> existential_type sigma ev | Ind (ind, u) -> EConstr.of_constr (rename_type_of_inductive env (ind, EInstance.kind sigma u)) | Construct (cstr, u) -> EConstr.of_constr (rename_type_of_constructor env (cstr, EInstance.kind sigma u)) - | Case (_,p,c,lf) -> + | Case (_,p,_iv,c,lf) -> let Inductiveops.IndType(indf,realargs) = let t = type_of env c in try Inductiveops.find_rectype env sigma t @@ -157,6 +157,9 @@ let retype ?(polyprop=true) sigma = | Sort _ | Prod _ -> mkSort (sort_of env cstr) | Int _ -> EConstr.of_constr (Typeops.type_of_int env) | Float _ -> EConstr.of_constr (Typeops.type_of_float env) + | Array(u, _, _, ty) -> + let arr = EConstr.of_constr @@ Typeops.type_of_array env (EInstance.kind sigma u) in + mkApp(arr, [|ty|]) and sort_of env t = match EConstr.kind sigma t with @@ -257,6 +260,9 @@ let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = (* Makes an unsafe judgment from a constr *) let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c } +let get_type_of_constr ?polyprop ?lax env ?(uctx=UState.from_env env) c = + EConstr.Unsafe.to_constr (get_type_of ?polyprop ?lax env (Evd.from_ctx uctx) (EConstr.of_constr c)) + (* Returns sorts of a context *) let sorts_of_context env evc ctxt = let rec aux = function @@ -297,12 +303,11 @@ let relevance_of_term env sigma c = | Const (c,_) -> Relevanceops.relevance_of_constant env c | Ind _ -> Sorts.Relevant | Construct (c,_) -> Relevanceops.relevance_of_constructor env c - | Case (ci, _, _, _) -> ci.ci_relevance + | Case (ci, _, _, _, _) -> ci.ci_relevance | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance | Proj (p, _) -> Relevanceops.relevance_of_projection env p - | Int _ | Float _ -> Sorts.Relevant - + | Int _ | Float _ | Array _ -> Sorts.Relevant | Meta _ | Evar _ -> Sorts.Relevant in diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index 16bc251c2a..2e19ffdfcd 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -30,6 +30,10 @@ exception RetypeError of retype_error val get_type_of : ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> types +(** No-evar version of [get_type_of] *) +val get_type_of_constr : ?polyprop:bool -> ?lax:bool + -> env -> ?uctx:UState.t -> Constr.t -> Constr.types + val get_sort_of : ?polyprop:bool -> env -> evar_map -> types -> Sorts.t diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 5b9bc91b84..e4b5dc1edf 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -277,8 +277,8 @@ let compute_consteval_direct env sigma ref = | Fix fix when not onlyproj -> (try check_fix_reversibility sigma labs l fix with Elimconst -> NotAnElimination) - | Case (_,_,d,_) when isRel sigma d && not onlyproj -> EliminationCases n - | Case (_,_,d,_) -> srec env n labs true d + | Case (_,_,_,d,_) when isRel sigma d && not onlyproj -> EliminationCases n + | Case (_,_,_,d,_) -> srec env n labs true d | Proj (p, d) when isRel sigma d -> EliminationProj n | _ -> NotAnElimination in @@ -358,30 +358,6 @@ let reference_eval env sigma = function let x = Name default_dependent_ident -let make_elim_fun (names,(nbfix,lv,n)) u largs = - let lu = List.firstn n largs in - let p = List.length lv in - let lyi = List.map fst lv in - let la = - List.map_i (fun q aq -> - (* k from the comment is q+1 *) - try mkRel (p+1-(List.index Int.equal (n-q) lyi)) - with Not_found -> aq) - 0 (List.map (Vars.lift p) lu) - in - fun i -> - match names.(i) with - | None -> None - | Some (minargs,ref) -> - let body = applist (mkEvalRef ref u, la) in - let g = - List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> - let subst = List.map (Vars.lift (-q)) (List.firstn (n-ij) la) in - let tij' = Vars.substl (List.rev subst) tij in - let x = make_annot x Sorts.Relevant in (* TODO relevance *) - mkLambda (x,tij',c)) 1 body (List.rev lv) - in Some (minargs,g) - (* [f] is convertible to [Fix(recindices,bodynum),bodyvect)]: do so that the reduction uses this extra information *) @@ -467,16 +443,6 @@ let substl_checking_arity env subst sigma c = type fix_reduction_result = NotReducible | Reduced of (constr * constr list) -let reduce_fix whdfun sigma fix stack = - match fix_recarg fix (Stack.append_app_list stack Stack.empty) with - | None -> NotReducible - | Some (recargnum,recarg) -> - let (recarg'hd,_ as recarg') = whdfun sigma recarg in - let stack' = List.assign stack recargnum (applist recarg') in - (match EConstr.kind sigma recarg'hd with - | Construct _ -> Reduced (contract_fix sigma fix, stack') - | _ -> NotReducible) - let contract_fix_use_function env sigma f ((recindices,bodynum),(_names,_types,bodies as typedbodies)) = let nbodies = Array.length recindices in @@ -484,22 +450,6 @@ let contract_fix_use_function env sigma f let lbodies = List.init nbodies make_Fi in substl_checking_arity env (List.rev lbodies) sigma (nf_beta env sigma bodies.(bodynum)) -let reduce_fix_use_function env sigma f whfun fix stack = - match fix_recarg fix (Stack.append_app_list stack Stack.empty) with - | None -> NotReducible - | Some (recargnum,recarg) -> - let (recarg'hd,_ as recarg') = - if EConstr.isRel sigma recarg then - (* The recarg cannot be a local def, no worry about the right env *) - (recarg, []) - else - whfun recarg in - let stack' = List.assign stack recargnum (applist recarg') in - (match EConstr.kind sigma recarg'hd with - | Construct _ -> - Reduced (contract_fix_use_function env sigma f fix,stack') - | _ -> NotReducible) - let contract_cofix_use_function env sigma f (bodynum,(_names,_,bodies as typedbodies)) = let nbodies = Array.length bodies in @@ -538,7 +488,8 @@ let reduce_mind_case_use_function func env sigma mia = fun _ -> None in let cofix_def = contract_cofix_use_function env sigma build_cofix_name cofix in - mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) + (* Is NoInvert OK here? *) + mkCase (mia.mci, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false @@ -573,34 +524,23 @@ let match_eval_ref_value env sigma constr stack = env |> lookup_rel n |> RelDecl.get_value |> Option.map (lift n) | _ -> None -let special_red_case env sigma whfun (ci, p, c, lf) = - let rec redrec s = - let (constr, cargs) = whfun s in - match match_eval_ref env sigma constr cargs with - | Some (ref, u) -> - (match reference_opt_value env sigma ref u with - | None -> raise Redelimination - | Some gvalue -> - if reducible_mind_case sigma gvalue then - reduce_mind_case_use_function constr env sigma - {mP=p; mconstr=gvalue; mcargs=cargs; - mci=ci; mlf=lf} - else - redrec (applist(gvalue, cargs))) - | None -> - if reducible_mind_case sigma constr then - reduce_mind_case sigma - {mP=p; mconstr=constr; mcargs=cargs; - mci=ci; mlf=lf} - else - raise Redelimination - in - redrec c +let push_app sigma (hd, stk as p) = match EConstr.kind sigma hd with +| App (hd, args) -> + (hd, Array.fold_right (fun x accu -> x :: accu) args stk) +| _ -> p let recargs = function | EvalVar _ | EvalRel _ | EvalEvar _ -> None | EvalConst c -> ReductionBehaviour.get (GlobRef.ConstRef c) +let fix_recarg ((recindices,bodynum),_) stack = + assert (0 <= bodynum && bodynum < Array.length recindices); + let recargnum = Array.get recindices bodynum in + try + Some (recargnum, List.nth stack recargnum) + with Failure _ -> + None + let reduce_projection env sigma p ~npars (recarg'hd,stack') stack = (match EConstr.kind sigma recarg'hd with | Construct _ -> @@ -608,24 +548,9 @@ let reduce_projection env sigma p ~npars (recarg'hd,stack') stack = Reduced (List.nth stack' proj_narg, stack) | _ -> NotReducible) -let reduce_proj env sigma whfun whfun' c = - let rec redrec s = - match EConstr.kind sigma s with - | Proj (proj, c) -> - let c' = try redrec c with Redelimination -> c in - let constr, cargs = whfun c' in - (match EConstr.kind sigma constr with - | Construct _ -> - let proj_narg = Projection.npars proj + Projection.arg proj in - List.nth cargs proj_narg - | _ -> raise Redelimination) - | Case (n,p,c,brs) -> - let c' = redrec c in - let p = (n,p,c',brs) in - (try special_red_case env sigma whfun' p - with Redelimination -> mkCase p) - | _ -> raise Redelimination - in redrec c +let rec beta_applist sigma accu c stk = match EConstr.kind sigma c, stk with +| Lambda (_, _, c), arg :: stk -> beta_applist sigma (arg :: accu) c stk +| _ -> substl accu c, stk let whd_nothing_for_iota env sigma s = let rec whrec (x, stack as s) = @@ -649,17 +574,17 @@ let whd_nothing_for_iota env sigma s = (match constant_opt_value_in env (const, u) with | Some body -> whrec (EConstr.of_constr body, stack) | None -> s) - | LetIn (_,b,_,c) -> stacklam whrec [b] sigma c stack + | LetIn (_,b,_,c) -> whrec (beta_applist sigma [b] c stack) | Cast (c,_,_) -> whrec (c, stack) - | App (f,cl) -> whrec (f, Stack.append_app cl stack) + | App (f,cl) -> whrec (f, Array.fold_right (fun c accu -> c :: accu) cl stack) | Lambda (na,t,c) -> - (match Stack.decomp stack with - | Some (a,m) -> stacklam whrec [a] sigma c m + (match stack with + | a :: stack -> whrec (beta_applist sigma [a] c stack) | _ -> s) | x -> s in - EConstr.decompose_app sigma (Stack.zip sigma (whrec (s,Stack.empty))) + whrec s (* [red_elim_const] contracts iota/fix/cofix redexes hidden behind constants by keeping the name of the constants in the recursive calls; @@ -702,21 +627,17 @@ let rec red_elim_const env sigma ref u largs = try match reference_eval env sigma ref with | EliminationCases n when nargs >= n -> let c = reference_value env sigma ref u in - let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in - let whfun = whd_simpl_stack env sigma in - (special_red_case env sigma whfun (EConstr.destCase sigma c'), lrest), nocase + let c', lrest = whd_nothing_for_iota env sigma (c, largs) in + (special_red_case env sigma (EConstr.destCase sigma c'), lrest), nocase | EliminationProj n when nargs >= n -> let c = reference_value env sigma ref u in - let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in - let whfun = whd_construct_stack env sigma in - let whfun' = whd_simpl_stack env sigma in - (reduce_proj env sigma whfun whfun' c', lrest), nocase + let c', lrest = whd_nothing_for_iota env sigma (c, largs) in + (reduce_proj env sigma c', lrest), nocase | EliminationFix (min,minfxargs,infos) when nargs >= min -> let c = reference_value env sigma ref u in - let d, lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in - let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) u largs in - let whfun = whd_construct_stack env sigma in - (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with + let d, lrest = whd_nothing_for_iota env sigma (c, largs) in + let f = ([|Some (minfxargs,ref)|],infos), u, largs in + (match reduce_fix_use_function env sigma f (destFix sigma d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase) | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> @@ -728,10 +649,9 @@ let rec red_elim_const env sigma ref u largs = let c', lrest = whd_betalet_stack env sigma (applist(c,args)) in descend (destEvalRefU sigma c') lrest in let (_, midargs as s) = descend (ref,u) largs in - let d, lrest = whd_nothing_for_iota env sigma (applist s) in - let f = make_elim_fun refinfos u midargs in - let whfun = whd_construct_stack env sigma in - (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with + let d, lrest = whd_nothing_for_iota env sigma s in + let f = refinfos, u, midargs in + (match reduce_fix_use_function env sigma f (destFix sigma d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase) | NotAnElimination when unfold_nonelim -> @@ -754,32 +674,30 @@ and reduce_params env sigma stack l = | _ -> raise Redelimination) stack l - (* reduce to whd normal form or to an applied constant that does not hide a reducible iota/fix/cofix redex (the "simpl" tactic) *) and whd_simpl_stack env sigma = let open ReductionBehaviour in let rec redrec s = - let (x, stack) = decompose_app_vect sigma s in - let stack = Array.to_list stack in - let s' = (x, stack) in + let s' = push_app sigma s in + let (x, stack) = s' in match EConstr.kind sigma x with | Lambda (na,t,c) -> (match stack with | [] -> s' - | a :: rest -> redrec (beta_applist sigma (x, stack))) - | LetIn (n,b,t,c) -> redrec (applist (Vars.substl [b] c, stack)) - | App (f,cl) -> redrec (applist(f, (Array.to_list cl)@stack)) - | Cast (c,_,_) -> redrec (applist(c, stack)) - | Case (ci,p,c,lf) -> + | a :: rest -> redrec (beta_applist sigma [a] c rest)) + | LetIn (n,b,t,c) -> redrec (Vars.substl [b] c, stack) + | App (f,cl) -> assert false (* see push_app above *) + | Cast (c,_,_) -> redrec (c, stack) + | Case (ci,p,iv,c,lf) -> (try - redrec (applist(special_red_case env sigma redrec (ci,p,c,lf), stack)) + redrec (special_red_case env sigma (ci,p,iv,c,lf), stack) with Redelimination -> s') | Fix fix -> - (try match reduce_fix (whd_construct_stack env) sigma fix stack with - | Reduced s' -> redrec (applist s') + (try match reduce_fix env sigma fix stack with + | Reduced s' -> redrec s' | NotReducible -> s' with Redelimination -> s') @@ -799,11 +717,11 @@ and whd_simpl_stack env sigma = (match reduce_projection env sigma p ~npars (whd_construct_stack env sigma c) stack with - | Reduced s' -> redrec (applist s') + | Reduced s' -> redrec s' | NotReducible -> s') | _ -> match reduce_projection env sigma p ~npars (whd_construct_stack env sigma c) stack with - | Reduced s' -> redrec (applist s') + | Reduced s' -> redrec s' | NotReducible -> s') else s' with Redelimination -> s') @@ -813,7 +731,7 @@ and whd_simpl_stack env sigma = | Some (ref, u) -> (try let sapp, nocase = red_elim_const env sigma ref u stack in - let hd, _ as s'' = redrec (applist(sapp)) in + let hd, _ as s'' = redrec sapp in let rec is_case x = match EConstr.kind sigma x with | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x | App (hd, _) -> is_case hd @@ -826,10 +744,102 @@ and whd_simpl_stack env sigma = in redrec +and reduce_fix env sigma fix stack = + match fix_recarg fix stack with + | None -> NotReducible + | Some (recargnum,recarg) -> + let (recarg'hd,_ as recarg') = whd_construct_stack env sigma recarg in + let stack' = List.assign stack recargnum (applist recarg') in + (match EConstr.kind sigma recarg'hd with + | Construct _ -> Reduced (contract_fix sigma fix, stack') + | _ -> NotReducible) + +and reduce_fix_use_function env sigma f fix stack = + match fix_recarg fix stack with + | None -> NotReducible + | Some (recargnum,recarg) -> + let (recarg'hd,_ as recarg') = + if EConstr.isRel sigma recarg then + (* The recarg cannot be a local def, no worry about the right env *) + (recarg, []) + else + whd_construct_stack env sigma recarg in + let stack' = List.assign stack recargnum (applist recarg') in + (match EConstr.kind sigma recarg'hd with + | Construct _ -> + let (names, (nbfix, lv, n)), u, largs = f in + let lu = List.firstn n largs in + let p = List.length lv in + let lyi = List.map fst lv in + let la = + List.map_i (fun q aq -> + (* k from the comment is q+1 *) + try mkRel (p+1-(List.index Int.equal (n-q) lyi)) + with Not_found -> Vars.lift p aq) + 0 lu + in + let f i = match names.(i) with + | None -> None + | Some (minargs,ref) -> + let body = applist (mkEvalRef ref u, la) in + let g = + List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> + let subst = List.map (Vars.lift (-q)) (List.firstn (n-ij) la) in + let tij' = Vars.substl (List.rev subst) tij in + let x = make_annot x Sorts.Relevant in (* TODO relevance *) + mkLambda (x,tij',c)) 1 body (List.rev lv) + in Some (minargs,g) + in + Reduced (contract_fix_use_function env sigma f fix,stack') + | _ -> NotReducible) + +and reduce_proj env sigma c = + let rec redrec s = + match EConstr.kind sigma s with + | Proj (proj, c) -> + let c' = try redrec c with Redelimination -> c in + let constr, cargs = whd_construct_stack env sigma c' in + (match EConstr.kind sigma constr with + | Construct _ -> + let proj_narg = Projection.npars proj + Projection.arg proj in + List.nth cargs proj_narg + | _ -> raise Redelimination) + | Case (n,p,iv,c,brs) -> + let c' = redrec c in + let p = (n,p,iv,c',brs) in + (try special_red_case env sigma p + with Redelimination -> mkCase p) + | _ -> raise Redelimination + in redrec c + +and special_red_case env sigma (ci, p, iv, c, lf) = + let rec redrec s = + let (constr, cargs) = whd_simpl_stack env sigma s in + match match_eval_ref env sigma constr cargs with + | Some (ref, u) -> + (match reference_opt_value env sigma ref u with + | None -> raise Redelimination + | Some gvalue -> + if reducible_mind_case sigma gvalue then + reduce_mind_case_use_function constr env sigma + {mP=p; mconstr=gvalue; mcargs=cargs; + mci=ci; mlf=lf} + else + redrec (gvalue, cargs)) + | None -> + if reducible_mind_case sigma constr then + reduce_mind_case sigma + {mP=p; mconstr=constr; mcargs=cargs; + mci=ci; mlf=lf} + else + raise Redelimination + in + redrec (push_app sigma (c, [])) + (* reduce until finding an applied constructor or fail *) and whd_construct_stack env sigma s = - let (constr, cargs as s') = whd_simpl_stack env sigma s in + let (constr, cargs as s') = whd_simpl_stack env sigma (s, []) in if reducible_mind_case sigma constr then s' else match match_eval_ref env sigma constr cargs with | Some (ref, u) -> @@ -854,20 +864,20 @@ let try_red_product env sigma c = | App (f,l) -> (match EConstr.kind sigma f with | Fix fix -> - let stack = Stack.append_app l Stack.empty in - (match fix_recarg fix stack with + (match fix_recarg fix (Array.to_list l) with | None -> raise Redelimination | Some (recargnum,recarg) -> let recarg' = redrec env recarg in - let stack' = Stack.assign stack recargnum recarg' in - simpfun (Stack.zip sigma (f,stack'))) + let l = Array.copy l in + let () = Array.set l recargnum recarg' in + simpfun (mkApp (f, l))) | _ -> simpfun (mkApp (redrec env f, l))) | Cast (c,_,_) -> redrec env c | Prod (x,a,b) -> let open Context.Rel.Declaration in mkProd (x, a, redrec (push_rel (LocalAssum (x, a)) env) b) | LetIn (x,a,b,t) -> redrec env (Vars.subst1 a t) - | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) + | Case (ci,p,iv,d,lf) -> simpfun (mkCase (ci,p,iv,redrec env d,lf)) | Proj (p, c) -> let c' = match EConstr.kind sigma c with @@ -972,19 +982,19 @@ let whd_simpl_orelse_delta_but_fix env sigma c = if List.length stack <= npars then (* Do not show the eta-expanded form *) s' - else redrec (applist (c, stack)) - | _ -> redrec (applist(c, stack))) + else redrec (c, stack) + | _ -> redrec (c, stack)) | None -> s' in let simpfun = clos_norm_flags betaiota env sigma in simpfun (applist (redrec c)) -let hnf_constr = whd_simpl_orelse_delta_but_fix +let hnf_constr env sigma c = whd_simpl_orelse_delta_but_fix env sigma (c, []) (* The "simpl" reduction tactic *) let whd_simpl env sigma c = - applist (whd_simpl_stack env sigma c) + applist (whd_simpl_stack env sigma (c, [])) let simpl env sigma c = strong whd_simpl env sigma c @@ -1264,13 +1274,12 @@ let one_step_reduce env sigma c = | App (f,cl) -> redrec (f, (Array.to_list cl)@stack) | LetIn (_,f,_,cl) -> (Vars.subst1 f cl,stack) | Cast (c,_,_) -> redrec (c,stack) - | Case (ci,p,c,lf) -> + | Case (ci,p,iv,c,lf) -> (try - (special_red_case env sigma (whd_simpl_stack env sigma) - (ci,p,c,lf), stack) + (special_red_case env sigma (ci,p,iv,c,lf), stack) with Redelimination -> raise NotStepReducible) | Fix fix -> - (try match reduce_fix (whd_construct_stack env) sigma fix stack with + (try match reduce_fix env sigma fix stack with | Reduced s' -> s' | NotReducible -> raise NotStepReducible with Redelimination -> raise NotStepReducible) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index f0882d4594..756ccd3438 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -178,7 +178,7 @@ let type_case_branches env sigma (ind,largs) pj c = let ty = whd_betaiota env sigma (lambda_applist_assum sigma (n+1) p (realargs@[c])) in sigma, (lc, ty, Sorts.relevance_of_sort ps) -let judge_of_case env sigma ci pj cj lfj = +let judge_of_case env sigma ci pj iv cj lfj = let ((ind, u), spec) = try find_mrectype env sigma cj.uj_type with Not_found -> error_case_not_inductive env sigma cj in @@ -186,7 +186,10 @@ let judge_of_case env sigma ci pj cj lfj = let sigma, (bty,rslty,rci) = type_case_branches env sigma indspec pj cj.uj_val in let () = check_case_info env (fst indspec) rci ci in let sigma = check_branch_types env sigma (fst indspec) cj (lfj,bty) in - sigma, { uj_val = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj); + let () = if (match iv with | NoInvert -> false | CaseInvert _ -> true) != should_invert_case env ci + then Type_errors.error_bad_invert env + in + sigma, { uj_val = mkCase (ci, pj.uj_val, iv, cj.uj_val, Array.map j_val lfj); uj_type = rslty } let check_type_fixpoint ?loc env sigma lna lar vdefj = @@ -329,6 +332,23 @@ let judge_of_int env v = let judge_of_float env v = Environ.on_judgment EConstr.of_constr (judge_of_float env v) +let judge_of_array env sigma u tj defj tyj = + let ulev = match Univ.Instance.to_array u with + | [|u|] -> u + | _ -> assert false + in + let sigma = Evd.set_leq_sort env sigma tyj.utj_type + (Sorts.sort_of_univ (Univ.Universe.make ulev)) + in + let check_one sigma j = Evarconv.unify_leq_delay env sigma j.uj_type tyj.utj_val in + let sigma = check_one sigma defj in + let sigma = Array.fold_left check_one sigma tj in + let arr = EConstr.of_constr @@ type_of_array env u in + let j = make_judge (mkArray(EInstance.make u, Array.map j_val tj, defj.uj_val, tyj.utj_val)) + (mkApp (arr, [|tyj.utj_val|])) + in + sigma, j + (* cstr must be in n.f. w.r.t. evars and execute returns a judgement where both the term and type are in n.f. *) let rec execute env sigma cstr = @@ -361,11 +381,20 @@ let rec execute env sigma cstr = let sigma, ty = type_of_constructor env sigma ctor in sigma, make_judge cstr ty - | Case (ci,p,c,lf) -> + | Case (ci,p,iv,c,lf) -> let sigma, cj = execute env sigma c in let sigma, pj = execute env sigma p in let sigma, lfj = execute_array env sigma lf in - judge_of_case env sigma ci pj cj lfj + let sigma = match iv with + | NoInvert -> sigma + | CaseInvert {univs;args} -> + let t = mkApp (mkIndU (ci.ci_ind,univs), args) in + let sigma, tj = execute env sigma t in + let sigma, tj = type_judgment env sigma tj in + let sigma = Evarconv.unify_leq_delay env sigma cj.uj_type tj.utj_val in + sigma + in + judge_of_case env sigma ci pj iv cj lfj | Fix ((vn,i as vni),recdef) -> let sigma, (_,tys,_ as recdef') = execute_recdef env sigma recdef in @@ -443,6 +472,13 @@ let rec execute env sigma cstr = | Float f -> sigma, judge_of_float env f + | Array(u,t,def,ty) -> + let sigma, tyj = execute env sigma ty in + let sigma, tyj = type_judgment env sigma tyj in + let sigma, defj = execute env sigma def in + let sigma, tj = execute_array env sigma t in + judge_of_array env sigma (EInstance.kind sigma u) tj defj tyj + and execute_recdef env sigma (names,lar,vdef) = let sigma, larj = execute_array env sigma lar in let sigma, lara = Array.fold_left_map (assumption_of_judgment env) sigma larj in diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 95b07e227e..a26c981cb9 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -564,10 +564,10 @@ let is_rigid_head sigma flags t = match EConstr.kind sigma t with | Const (cst,u) -> not (TransparentState.is_transparent_constant flags.modulo_delta cst) | Ind (i,u) -> true - | Construct _ | Int _ | Float _ -> true + | Construct _ | Int _ | Float _ | Array _ -> true | Fix _ | CoFix _ -> true | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast (_, _, _) | Prod _ - | Lambda _ | LetIn _ | App (_, _) | Case (_, _, _, _) + | Lambda _ | LetIn _ | App (_, _) | Case (_, _, _, _, _) | Proj (_, _) -> false (* Why aren't Prod, Sort rigid heads ? *) let force_eqs c = @@ -657,9 +657,9 @@ let rec is_neutral env sigma ts t = not (TransparentState.is_transparent_variable ts id) | Rel n -> true | Evar _ | Meta _ -> true - | Case (_, p, c, cl) -> is_neutral env sigma ts c + | Case (_, p, _, c, _) -> is_neutral env sigma ts c | Proj (p, c) -> is_neutral env sigma ts c - | Lambda _ | LetIn _ | Construct _ | CoFix _ | Int _ | Float _ -> false + | Lambda _ | LetIn _ | Construct _ | CoFix _ | Int _ | Float _ | Array _ -> false | Sort _ | Cast (_, _, _) | Prod (_, _, _) | Ind _ -> false (* Really? *) | Fix _ -> false (* This is an approximation *) | App _ -> assert false @@ -847,7 +847,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN f2 l2 | _ -> raise ex) - | Case (ci1,p1,c1,cl1), Case (ci2,p2,c2,cl2) -> + | Case (ci1,p1,_,c1,cl1), Case (ci2,p2,_,c2,cl2) -> (try if not (eq_ind ci1.ci_ind ci2.ci_ind) then error_cannot_unify curenv sigma (cM,cN); let opt' = {opt with at_top = true; with_types = false} in @@ -1782,7 +1782,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = matchrec c1 with ex when precatchable_exception ex -> matchrec c2) - | Case(_,_,c,lf) -> (* does not search in the predicate *) + | Case(_,_,_,c,lf) -> (* does not search in the predicate *) (try matchrec c with ex when precatchable_exception ex -> @@ -1819,6 +1819,15 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = with ex when precatchable_exception ex -> matchrec c) + | Array(_u,t,def,ty) -> + (try + matchrec def + with ex when precatchable_exception ex -> + try + matchrec ty + with ex when precatchable_exception ex -> + iter_fail matchrec t) + | Cast (_, _, _) (* Is this expected? *) | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _ -> user_err Pp.(str "Match_subterm"))) @@ -1867,7 +1876,7 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = let c2 = args.(n-1) in bind (matchrec c1) (matchrec c2) - | Case(_,_,c,lf) -> (* does not search in the predicate *) + | Case(_,_,_,c,lf) -> (* does not search in the predicate *) bind (matchrec c) (bind_iter matchrec lf) | Proj (p,c) -> matchrec c @@ -1887,6 +1896,9 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = | Lambda (_,t,c) -> bind (matchrec t) (matchrec c) + | Array(_u,t,def,ty) -> + bind (bind (bind_iter matchrec t) (matchrec def)) (matchrec ty) + | Cast (_, _, _) -> fail "Match_subterm" (* Is this expected? *) | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Const _ | Ind _ diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 37c34d55cf..b3f577b684 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -170,6 +170,7 @@ and nf_whd env sigma whd typ = mkApp(capp,args) | Vint64 i -> i |> Uint63.of_int64 |> mkInt | Vfloat64 f -> f |> Float64.of_float |> mkFloat + | Varray t -> nf_array env sigma t typ | Vatom_stk(Aid idkey, stk) -> constr_type_of_idkey env sigma idkey stk | Vatom_stk(Aind ((mi,i) as ind), stk) -> @@ -261,6 +262,12 @@ and nf_stk ?from:(from=0) env sigma c t stk = nf_stk env sigma (mkApp(fa,[|c|])) (subst1 c codom) stk | Zswitch sw :: stk -> assert (from = 0) ; + let ci = sw.sw_annot.Vmvalues.ci in + let () = if Typeops.should_invert_case env ci then + (* TODO implement case inversion readback (properly reducing + it is a problem for the kernel) *) + CErrors.user_err Pp.(str "VM compute readback of case inversion not implemented.") + in let ((mind,_ as ind), u), allargs = find_rectype_a env t in let (mib,mip) = Inductive.lookup_mind_specif env ind in let nparams = mib.mind_nparams in @@ -280,8 +287,7 @@ and nf_stk ?from:(from=0) env sigma c t stk = in let branchs = Array.mapi mkbranch bsw in let tcase = build_case_type p realargs c in - let ci = sw.sw_annot.Vmvalues.ci in - nf_stk env sigma (mkCase(ci, p, c, branchs)) tcase stk + nf_stk env sigma (mkCase(ci, p, NoInvert, c, branchs)) tcase stk | Zproj p :: stk -> assert (from = 0) ; let p' = Projection.make p true in @@ -394,6 +400,14 @@ and nf_cofix env sigma cf = let cfb = Util.Array.map2 (fun v t -> nf_val env sigma v t) vb cft in mkCoFix (init,(names,cft,cfb)) +and nf_array env sigma t typ = + let ty, allargs = decompose_appvect (whd_all env typ) in + let typ_elem = allargs.(0) in + let t, vdef = Parray.to_array t in + let t = Array.map (fun v -> nf_val env sigma v typ_elem) t in + let u = snd (destConst ty) in + mkArray(u, t, nf_val env sigma vdef typ_elem, typ_elem) + 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."); diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index b285c0abcc..af105f4d63 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -655,6 +655,14 @@ let tag_var = tag Tag.variable return (pr_prim_token p, prec_of_prim_token p) | CDelimiters (sc,a) -> return (pr_delimiters sc (pr mt (LevelLe ldelim) a), ldelim) + | CArray(u, t,def,ty) -> + let pp = ref (str " |"++ spc () ++ pr mt ltop def + ++ pr_opt_type_spc (pr mt) ty ++ str " |]" ++ pr_universe_instance u) in + for i = Array.length t - 1 downto 1 do + pp := str ";" ++ pr mt ltop t.(i) ++ !pp + done; + pp := pr mt ltop t.(0) ++ !pp; + hov 0 (str "[|" ++ !pp), 0 in let loc = constr_loc a in pr_with_comments ?loc diff --git a/printing/printer.ml b/printing/printer.ml index 96213b3b8b..f8413f3588 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -855,10 +855,11 @@ let pr_goal_emacs ~proof gid sid = It is used primarily by the Print Assumptions command. *) type axiom = - | Constant of Constant.t (* An axiom or a constant. *) - | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *) - | Guarded of GlobRef.t (* a constant whose (co)fixpoints have been assumed to be guarded *) - | TypeInType of GlobRef.t (* a constant which relies on type in type *) + | Constant of Constant.t + | Positive of MutInd.t + | Guarded of GlobRef.t + | TypeInType of GlobRef.t + | UIP of MutInd.t type context_object = | Variable of Id.t (* A section variable or a Let definition *) @@ -874,14 +875,21 @@ struct let compare_axiom x y = match x,y with | Constant k1 , Constant k2 -> - Constant.CanOrd.compare k1 k2 - | Positive m1 , Positive m2 -> - MutInd.CanOrd.compare m1 m2 - | Guarded k1 , Guarded k2 -> - GlobRef.Ordered.compare k1 k2 - | _ , Constant _ -> 1 - | _ , Positive _ -> 1 - | _ -> -1 + Constant.CanOrd.compare k1 k2 + | Positive m1 , Positive m2 + | UIP m1, UIP m2 -> + MutInd.CanOrd.compare m1 m2 + | Guarded k1 , Guarded k2 + | TypeInType k1, TypeInType k2 -> + GlobRef.Ordered.compare k1 k2 + | Constant _, _ -> -1 + | _, Constant _ -> 1 + | Positive _, _ -> -1 + | _, Positive _ -> 1 + | Guarded _, _ -> -1 + | _, Guarded _ -> 1 + | TypeInType _, _ -> -1 + | _, TypeInType _ -> 1 let compare x y = match x , y with @@ -942,7 +950,9 @@ let pr_assumptionset env sigma s = | Guarded gr -> hov 2 (safe_pr_global env gr ++ spc () ++ strbrk"is assumed to be guarded.") | TypeInType gr -> - hov 2 (safe_pr_global env gr ++ spc () ++ strbrk"relies on an unsafe hierarchy.") + hov 2 (safe_pr_global env gr ++ spc () ++ strbrk"relies on an unsafe hierarchy.") + | UIP mind -> + hov 2 (safe_pr_inductive env mind ++ spc () ++ strbrk"relies on definitional UIP.") in let fold t typ accu = let (v, a, o, tr) = accu in @@ -1021,4 +1031,5 @@ let pr_typing_flags flags = str "check_guarded: " ++ bool flags.check_guarded ++ fnl () ++ str "check_positive: " ++ bool flags.check_positive ++ fnl () ++ str "check_universes: " ++ bool flags.check_universes ++ fnl () - ++ str "cumulative sprop: " ++ bool flags.cumulative_sprop + ++ str "cumulative sprop: " ++ bool flags.cumulative_sprop ++ fnl () + ++ str "definitional uip: " ++ bool flags.allow_uip diff --git a/printing/printer.mli b/printing/printer.mli index 8805819890..a25cbebe91 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -246,6 +246,7 @@ type axiom = | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *) | Guarded of GlobRef.t (* a constant whose (co)fixpoints have been assumed to be guarded *) | TypeInType of GlobRef.t (* a constant which relies on type in type *) + | UIP of MutInd.t (* An inductive using the special reduction rule. *) type context_object = | Variable of Id.t (* A section variable or a Let definition *) diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 7fb3a21813..9bd7ccda5d 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -263,7 +263,7 @@ let meta_reducible_instance env evd b = let rec irec u = let u = whd_betaiota env Evd.empty u (* FIXME *) in match EConstr.kind evd u with - | Case (ci,p,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> + | Case (ci,p,iv,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> let m = destMeta evd (strip_outer_cast evd c) in (match try @@ -272,8 +272,8 @@ let meta_reducible_instance env evd b = if isConstruct evd g || not is_coerce then Some g else None with Not_found -> None with - | Some g -> irec (mkCase (ci,p,g,bl)) - | None -> mkCase (ci,irec p,c,Array.map irec bl)) + | Some g -> irec (mkCase (ci,p,iv,g,bl)) + | None -> mkCase (ci,irec p,iv,c,Array.map irec bl)) | App (f,l) when EConstr.isMeta evd (strip_outer_cast evd f) -> let m = destMeta evd (strip_outer_cast evd f) in (match @@ -621,8 +621,8 @@ let clenv_cast_meta clenv = else mkCast (mkMeta mv, DEFAULTcast, b) with Not_found -> u) | App(f,args) -> mkApp (crec_hd f, Array.map crec args) - | Case(ci,p,c,br) -> - mkCase (ci, crec_hd p, crec_hd c, Array.map crec br) + | Case(ci,p,iv,c,br) -> + mkCase (ci, crec_hd p, map_invert crec_hd iv, crec_hd c, Array.map crec br) | Proj (p, c) -> mkProj (p, crec_hd c) | _ -> u in @@ -781,7 +781,8 @@ let make_evar_clause env sigma ?len t = Some (ctx, args, subst), ctx, args, subst | Some (ctx, args, subst) -> inst, ctx, args, subst in - let (sigma, ev) = new_evar_instance ~typeclass_candidate:false ctx sigma (csubst_subst subst t1) args in + let (sigma, ev) = new_pure_evar ~typeclass_candidate:false ctx sigma (csubst_subst subst t1) in + let ev = mkEvar (ev, args) in let dep = not (noccurn sigma 1 t2) in let hole = { hole_evar = ev; diff --git a/proofs/goal.ml b/proofs/goal.ml index 53d3047bc7..beeaa60433 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -58,15 +58,9 @@ module V82 = struct goals are restored to their initial value after the evar is created. *) let prev_future_goals = Evd.save_future_goals evars in - let evi = { Evd.evar_hyps = hyps; - Evd.evar_concl = concl; - Evd.evar_filter = Evd.Filter.identity; - Evd.evar_abstract_arguments = Evd.Abstraction.identity; - Evd.evar_body = Evd.Evar_empty; - Evd.evar_source = (Loc.tag Evar_kinds.GoalEvar); - Evd.evar_candidates = None } + let (evars, evk) = + Evarutil.new_pure_evar ~src:(Loc.tag Evar_kinds.GoalEvar) ~typeclass_candidate:false hyps evars concl in - let (evars, evk) = Evarutil.new_pure_evar_full evars ~typeclass_candidate:false evi in let evars = Evd.restore_future_goals evars prev_future_goals in let ctxt = Environ.named_context_of_val hyps in let inst = List.map (NamedDecl.get_id %> EConstr.mkVar) ctxt in diff --git a/proofs/logic.ml b/proofs/logic.ml index 07ea2ea572..f159395177 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -265,14 +265,15 @@ let collect_meta_variables c = let rec collrec deep acc c = match kind c with | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc | Cast(c,_,_) -> collrec deep acc c - | Case(ci,p,c,br) -> - (* Hack assuming only two situations: the legacy one that branches, - if with Metas, are Meta, and the new one with eta-let-expanded - branches *) - let br = Array.map2 (fun n b -> try snd (Term.decompose_lam_n_decls n b) with UserError _ -> b) ci.ci_cstr_ndecls br in - Array.fold_left (collrec deep) - (Constr.fold (collrec deep) (Constr.fold (collrec deep) acc p) c) - br + | Case(ci,p,iv,c,br) -> + (* Hack assuming only two situations: the legacy one that branches, + if with Metas, are Meta, and the new one with eta-let-expanded + branches *) + let br = Array.map2 (fun n b -> try snd (Term.decompose_lam_n_decls n b) with UserError _ -> b) ci.ci_cstr_ndecls br in + let acc = Constr.fold (collrec deep) acc p in + let acc = Constr.fold_invert (collrec deep) acc iv in + let acc = Constr.fold (collrec deep) acc c in + Array.fold_left (collrec deep) acc br | App _ -> Constr.fold (collrec deep) acc c | Proj (_, c) -> collrec deep acc c | _ -> Constr.fold (collrec true) acc c @@ -368,14 +369,15 @@ let rec mk_refgoals ~check env sigma goalacc conclty trm = let ty = EConstr.Unsafe.to_constr ty in (acc',ty,sigma,c) - | Case (ci,p,c,lf) -> + | Case (ci,p,iv,c,lf) -> + (* XXX Is ignoring iv OK? *) let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals ~check env sigma goalacc p c in let sigma = check_conv_leq_goal ~check env sigma trm conclty' conclty in let (acc'',sigma,rbranches) = treat_case ~check env sigma ci lbrty lf acc' in let lf' = Array.rev_of_list rbranches in let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm - else mkCase (ci,p',c',lf') + else mkCase (ci,p',iv,c',lf') in (acc'',conclty',sigma, ans) @@ -416,13 +418,14 @@ and mk_hdgoals ~check env sigma goalacc trm = let ans = if applicand == f && args == l then trm else mkApp (applicand, args) in (acc'',conclty',sigma, ans) - | Case (ci,p,c,lf) -> + | Case (ci,p,iv,c,lf) -> + (* XXX is ignoring iv OK? *) let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals ~check env sigma goalacc p c in let (acc'',sigma,rbranches) = treat_case ~check env sigma ci lbrty lf acc' in let lf' = Array.rev_of_list rbranches in let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm - else mkCase (ci,p',c',lf') + else mkCase (ci,p',iv,c',lf') in (acc'',conclty',sigma, ans) diff --git a/stm/stm.ml b/stm/stm.ml index 652d064b83..3b7921f638 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -199,16 +199,11 @@ let mkTransTac cast cblock cqueue = let mkTransCmd cast cids ceff cqueue = Cmd { ctac = false; cast; cblock = None; cqueue; cids; ceff } -(* Parts of the system state that are morally part of the proof state *) -let summary_pstate = Evarutil.meta_counter_summary_tag, - Evd.evar_counter_summary_tag, - Declare.Obls.State.prg_tag - type cached_state = | EmptyState - | ParsingState of Vernacstate.Parser.state + | ParsingState of Vernacstate.Parser.t | FullState of Vernacstate.t - | ErrorState of Vernacstate.Parser.state option * Exninfo.iexn + | ErrorState of Vernacstate.Parser.t option * Exninfo.iexn type branch = Vcs_.Branch.t * branch_type Vcs_.branch_info type backup = { mine : branch; others : branch list } @@ -334,7 +329,7 @@ module VCS : sig type vcs = (branch_type, transaction, vcs state_info, box) Vcs_.t - val init : stm_doc_type -> id -> Vernacstate.Parser.state -> doc + val init : stm_doc_type -> id -> Vernacstate.Parser.t -> doc (* val get_type : unit -> stm_doc_type *) val set_ldir : Names.DirPath.t -> unit val get_ldir : unit -> Names.DirPath.t @@ -364,8 +359,8 @@ module VCS : sig val goals : id -> int -> unit val set_state : id -> cached_state -> unit val get_state : id -> cached_state - val set_parsing_state : id -> Vernacstate.Parser.state -> unit - val get_parsing_state : id -> Vernacstate.Parser.state option + val set_parsing_state : id -> Vernacstate.Parser.t -> unit + val get_parsing_state : id -> Vernacstate.Parser.t option val get_proof_mode : id -> Pvernac.proof_mode option (* cuts from start -> stop, raising Expired if some nodes are not there *) @@ -678,7 +673,7 @@ end = struct (* {{{ *) { info with state = EmptyState; vcs_backup = None,None } in let make_shallow = function - | FullState st -> FullState (Vernacstate.make_shallow st) + | FullState st -> FullState (Vernacstate.Stm.make_shallow st) | x -> x in let copy_info_w_state v id = @@ -870,22 +865,13 @@ end = struct (* {{{ *) let invalidate_cur_state () = cur_id := Stateid.dummy - type proof_part = - Vernacstate.LemmaStack.t option * - int * (* Evarutil.meta_counter_summary_tag *) - int * (* Evd.evar_counter_summary_tag *) - Declare.Obls.State.t + type proof_part = Vernacstate.Stm.pstate type partial_state = [ `Full of Vernacstate.t | `ProofOnly of Stateid.t * proof_part ] - let proof_part_of_frozen { Vernacstate.lemmas; system } = - let st = States.summary_of_state system in - lemmas, - Summary.project_from_summary st Util.(pi1 summary_pstate), - Summary.project_from_summary st Util.(pi2 summary_pstate), - Summary.project_from_summary st Util.(pi3 summary_pstate) + let proof_part_of_frozen st = Vernacstate.Stm.pstate st let cache_state ~marshallable id = VCS.set_state id (FullState (Vernacstate.freeze_interp_state ~marshallable)) @@ -952,21 +938,10 @@ end = struct (* {{{ *) else s with VCS.Expired -> s in VCS.set_state id (FullState s) - | `ProofOnly(ontop,(pstate,c1,c2,c3)) -> + | `ProofOnly(ontop,pstate) -> if is_cached_and_valid ontop then let s = get_cached ontop in - let s = { s with lemmas = - PG_compat.copy_terminators ~src:s.lemmas ~tgt:pstate } in - let s = { s with system = - States.replace_summary s.system - begin - let st = States.summary_of_state s.system in - let st = Summary.modify_summary st Util.(pi1 summary_pstate) c1 in - let st = Summary.modify_summary st Util.(pi2 summary_pstate) c2 in - let st = Summary.modify_summary st Util.(pi3 summary_pstate) c3 in - st - end - } in + let s = Vernacstate.Stm.set_pstate s pstate in VCS.set_state id (FullState s) with VCS.Expired -> () @@ -978,12 +953,7 @@ end = struct (* {{{ *) execution_error ?loc id (iprint (e, info)); (e, Stateid.add info ~valid id) - let same_env { Vernacstate.system = s1 } { Vernacstate.system = s2 } = - let s1 = States.summary_of_state s1 in - let e1 = Summary.project_from_summary s1 Global.global_env_summary_tag in - let s2 = States.summary_of_state s2 in - let e2 = Summary.project_from_summary s2 Global.global_env_summary_tag in - e1 == e2 + let same_env = Vernacstate.Stm.same_env (* [define] puts the system in state [id] calling [f ()] *) (* [safe_id] is the last known valid state before execution *) @@ -2373,21 +2343,16 @@ 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: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 () in - let inject_non_pstate (s,l) = Summary.unfreeze_summaries ~partial:true s; Lib.unfreeze l; update_global_env () in + let rec pure_cherry_pick_non_pstate safe_id id = State.purify (fun id -> stm_prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id); reach ~safe_id id; - cherry_pick_non_pstate ()) + let st = Vernacstate.freeze_interp_state ~marshallable:false in + Vernacstate.Stm.non_pstate st) id (* traverses the dag backward from nodes being already calculated *) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index a957f7354f..f89fb9f52d 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -127,7 +127,7 @@ let classify_vernac e = | VernacAssumption (_,_,l) -> let ids = List.flatten (List.map (fun (_,(l,_)) -> List.map (fun (id, _) -> id.v) l) l) in VtSideff (ids, VtLater) - | VernacPrimitive (id,_,_) -> + | VernacPrimitive ((id,_),_,_) -> VtSideff ([id.CAst.v], VtLater) | VernacDefinition (_,({v=id},_),DefineBody _) -> VtSideff (idents_of_name id, VtLater) | VernacInductive (_,l) -> diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 6e6af42010..bb062bfc11 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -77,7 +77,7 @@ let constr_val_discr_st sigma ts t = | Const (c,u) -> if TransparentState.is_transparent_constant ts c then Everything else Label(GRLabel (ConstRef c),l) | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) - | Var id when not (TransparentState.is_transparent_variable ts id) -> Label(GRLabel (VarRef id),l) + | Var id -> if TransparentState.is_transparent_variable ts id then Everything else Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) | Lambda (n, d, c) -> if List.is_empty l then @@ -85,7 +85,8 @@ let constr_val_discr_st sigma ts t = else Everything | Sort _ -> Label(SortLabel, []) | Evar _ -> Everything - | _ -> Nothing + | Rel _ | Meta _ | Cast _ | LetIn _ | App _ | Case _ | Fix _ | CoFix _ + | Proj _ | Int _ | Float _ | Array _ -> Nothing let constr_pat_discr_st ts t = let open GlobRef in diff --git a/tactics/cbn.ml b/tactics/cbn.ml index 21e38df6db..dfbcc9fbce 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -106,7 +106,7 @@ sig type 'a member = | App of 'a app_node - | Case of case_info * 'a * 'a array * Cst_stack.t + | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array * Cst_stack.t | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t @@ -158,7 +158,7 @@ struct type 'a member = | App of 'a app_node - | Case of case_info * 'a * 'a array * Cst_stack.t + | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array * Cst_stack.t | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t @@ -172,7 +172,7 @@ struct let pr_c x = hov 1 (pr_c x) in match member with | App app -> str "ZApp" ++ pr_app_node pr_c app - | Case (_,_,br,cst) -> + | Case (_,_,_,br,cst) -> str "ZCase(" ++ prvect_with_sep (pr_bar) pr_c br ++ str ")" @@ -236,7 +236,7 @@ struct let t1,s1' = decomp_node_last a1 s1 in let t2,s2' = decomp_node_last a2 s2 in (f t1 t2) && (equal_rec s1' s2') - | Case (_,t1,a1,_) :: s1, Case (_,t2,a2,_) :: s2 -> + | Case (_,t1,_,a1,_) :: s1, Case (_,t2,_,a2,_) :: s2 -> f t1 t2 && CArray.equal (fun x y -> f x y) a1 a2 && equal_rec s1 s2 | (Proj (p,_)::s1, Proj(p2,_)::s2) -> Projection.Repr.equal (Projection.repr p) (Projection.repr p2) @@ -284,7 +284,7 @@ struct let will_expose_iota args = List.exists - (function (Fix (_,_,l) | Case (_,_,_,l) | + (function (Fix (_,_,l) | Case (_,_,_,_,l) | Proj (_,l) | Cst (_,_,_,_,l)) when Cst_stack.is_empty l -> true | _ -> false) args @@ -346,9 +346,9 @@ struct then a else Array.sub a i (j - i + 1) in zip (mkApp (f, a'), s) - | f, (Case (ci,rt,br,cst_l)::s) when refold -> - zip (best_state sigma (mkCase (ci,rt,f,br), s) cst_l) - | f, (Case (ci,rt,br,_)::s) -> zip (mkCase (ci,rt,f,br), s) + | f, (Case (ci,rt,iv,br,cst_l)::s) when refold -> + zip (best_state sigma (mkCase (ci,rt,iv,f,br), s) cst_l) + | f, (Case (ci,rt,iv,br,_)::s) -> zip (mkCase (ci,rt,iv,f,br), s) | f, (Fix (fix,st,cst_l)::s) when refold -> zip (best_state sigma (mkFix fix, st @ (append_app [|f|] s)) cst_l) | f, (Fix (fix,st,_)::s) -> zip @@ -620,7 +620,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = end end end - | exception NotEvaluableConst (IsPrimitive p) when Stack.check_native_args p stack -> + | exception NotEvaluableConst (IsPrimitive (u,p)) when Stack.check_native_args p stack -> let kargs = CPrimitives.kind p in let (kargs,o) = Stack.get_next_primitive_args kargs stack in (* Should not fail thanks to [check_native_args] *) @@ -699,8 +699,8 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | _ -> fold ()) | _ -> fold ()) - | Case (ci,p,d,lf) -> - whrec Cst_stack.empty (d, Stack.Case (ci,p,lf,cst_l) :: stack) + | Case (ci,p,iv,d,lf) -> + whrec Cst_stack.empty (d, Stack.Case (ci,p,iv,lf,cst_l) :: stack) | Fix ((ri,n),_ as f) -> (match Stack.strip_n_app ri.(n) stack with @@ -713,7 +713,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, lf,_)::s') when use_match -> + |args, (Stack.Case(ci, _, _, lf,_)::s') when use_match -> whrec Cst_stack.empty (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') |args, (Stack.Proj (p,_)::s') when use_match -> whrec Cst_stack.empty (Stack.nth args (Projection.npars p + Projection.arg p), s') @@ -759,9 +759,9 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = |_ -> fold () else fold () - | Int _ | Float _ -> + | Int _ | Float _ | Array _ -> begin match Stack.strip_app stack with - | (_, Stack.Primitive(p,kn,rargs,kargs,cst_l')::s) -> + | (_, Stack.Primitive(p,(_,u as kn),rargs,kargs,cst_l')::s) -> let more_to_reduce = List.exists (fun k -> CPrimitives.Kwhnf = k) kargs in if more_to_reduce then let (kargs,o) = Stack.get_next_primitive_args kargs s in @@ -775,8 +775,9 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = try List.chop n args with List.IndexOutOfRange -> (args,[]) (* FIXME probably useless *) in + let s = extra_args @ s in let args = Array.of_list (Option.get (Stack.list_of_app_stack (rargs @ Stack.append_app [|x|] args))) in - begin match CredNative.red_prim env sigma p args with + begin match CredNative.red_prim env sigma p u args with | Some t -> whrec cst_l' (t,s) | None -> ((mkApp (mkConstU kn, args), s), cst_l) end diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 6da2248cc3..955a7957bf 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -221,6 +221,7 @@ let build_sym_scheme env ind = [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; rel_vect 1 nrealargs; rel_vect (2*nrealargs+2) nrealargs])), + NoInvert, mkRel 1 (* varH *), [|cstr (nrealargs+1)|])))) in c, UState.of_context_set ctx @@ -295,6 +296,7 @@ let build_sym_involutive_scheme env ind = rel_vect 1 nrealargs; [|mkRel 1|]])|]]); mkRel 1|])), + NoInvert, mkRel 1 (* varH *), [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))) in (c, UState.of_context_set ctx) @@ -434,9 +436,11 @@ let build_l2r_rew_scheme dep env ind kind = [|mkRel 2|]])|]]) in let main_body = mkCase (ci, - my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG, - applied_sym_C 3, - [|mkVar varHC|]) in + my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG, + NoInvert, + applied_sym_C 3, + [|mkVar varHC|]) + in let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign @@ -444,12 +448,13 @@ let build_l2r_rew_scheme dep env ind kind = (my_it_mkProd_or_LetIn (if dep then realsign_ind_P else realsign_P) s) (mkNamedLambda (make_annot varHC indr) applied_PC (mkNamedLambda (make_annot varH indr) (lift 2 applied_ind) - (if dep then (* we need a coercion *) + (if dep then (* we need a coercion *) mkCase (cieq, mkLambda (make_annot (Name varH) indr,lift 3 applied_ind, mkLambda (make_annot Anonymous indr, mkApp (eq,[|lift 4 applied_ind;applied_sym_sym;mkRel 1|]), applied_PR)), + NoInvert, mkApp (sym_involutive, Array.append (Context.Rel.to_extended_vect mkRel 3 mip.mind_arity_ctxt) [|mkVar varH|]), [|main_body|]) @@ -540,6 +545,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = (my_it_mkProd_or_LetIn (if dep then realsign_ind_P 2 applied_ind_P else realsign_P 2) s) (mkNamedProd (make_annot varHC indr) applied_PC applied_PG)), + NoInvert, (mkVar varH), [|mkNamedLambda (make_annot varP indr) (my_it_mkProd_or_LetIn @@ -616,6 +622,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+3) realsign_ind) (mkArrow applied_PG indr (lift (2*nrealargs+5) applied_PC)), + NoInvert, mkRel 3 (* varH *), [|mkLambda (make_annot (Name varHC) indr, @@ -830,6 +837,7 @@ let build_congr env (eq,refl,ctx) ind = [|mkVar varB; mkApp (mkVar varf, [|lift (2*mip.mind_nrealdecls+4) b|]); mkApp (mkVar varf, [|mkRel (mip.mind_nrealargs - i + 2)|])|]))), + NoInvert, mkVar varH, [|mkApp (refl, [|mkVar varB; diff --git a/tactics/equality.ml b/tactics/equality.ml index 3aa7626aaa..a2325b69cc 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -877,7 +877,7 @@ let injectable env sigma ~keep_proofs t1 t2 = *) let descend_then env sigma head dirn = - let IndType (indf,_) = + let IndType (indf,_) as indt = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> user_err Pp.(str "Cannot project on an inductive type derived from a dependency.") @@ -904,7 +904,7 @@ let descend_then env sigma head dirn = (List.interval 1 (Array.length mip.mind_consnames)) in let rci = Sorts.Relevant in (* TODO relevance *) let ci = make_case_info env ind rci RegularStyle in - Inductiveops.make_case_or_project env sigma indf ci p head (Array.of_list brl))) + Inductiveops.make_case_or_project env sigma indt ci p head (Array.of_list brl))) (* Now we need to construct the discriminator, given a discriminable position. This boils down to: @@ -924,7 +924,7 @@ let descend_then env sigma head dirn = branch giving [special], and all the rest giving [default]. *) let build_selector env sigma dirn c ind special default = - let IndType(indf,_) = + let IndType(indf,_) as indt = try find_rectype env sigma ind with Not_found -> (* one can find Rel(k) in case of dependent constructors @@ -950,7 +950,7 @@ let build_selector env sigma dirn c ind special default = List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in let rci = Sorts.Relevant in (* TODO relevance *) let ci = make_case_info env ind rci RegularStyle in - let ans = Inductiveops.make_case_or_project env sigma indf ci p c (Array.of_list brl) in + let ans = Inductiveops.make_case_or_project env sigma indt ci p c (Array.of_list brl) in ans let build_coq_False () = pf_constr_of_global (lib_ref "core.False.type") diff --git a/tactics/hints.ml b/tactics/hints.ml index 7a5615dd8e..386224824f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -562,7 +562,7 @@ struct let head_evar sigma c = let rec hrec c = match EConstr.kind sigma c with | Evar (evk,_) -> evk - | Case (_,_,c,_) -> hrec c + | Case (_,_,_,c,_) -> hrec c | App (c,_) -> hrec c | Cast (c,_,_) -> hrec c | Proj (p, c) -> hrec c diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index d5358faf59..ec770e2473 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -417,7 +417,7 @@ let compute_constructor_signatures ~rec_flag ((_,k as ity),u) = | RelDecl.LocalAssum _ :: c, recarg::rest -> let rest = analrec c rest in begin match Declareops.dest_recarg recarg with - | Norec | Imbr _ -> true :: rest + | Norec | Nested _ -> true :: rest | Mrec (_,j) -> if rec_flag && Int.equal j k then true :: true :: rest else true :: rest diff --git a/tactics/tactics.ml b/tactics/tactics.ml index af23747d43..f553a290f9 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -120,8 +120,8 @@ let unsafe_intro env decl b = let inst = List.map (NamedDecl.get_id %> mkVar) (named_context env) in let ninst = mkRel 1 :: inst in let nb = subst1 (mkVar (NamedDecl.get_id decl)) b in - let (sigma, ev) = new_evar_instance nctx sigma nb ~principal:true ninst in - (sigma, mkLambda_or_LetIn (NamedDecl.to_rel_decl decl) ev) + let (sigma, ev) = new_pure_evar nctx sigma nb ~principal:true in + (sigma, mkLambda_or_LetIn (NamedDecl.to_rel_decl decl) (mkEvar (ev, ninst))) end let introduction id = @@ -340,7 +340,8 @@ let rename_hyp repl = let nctx = val_of_named_context nhyps in let instance = List.map (NamedDecl.get_id %> mkVar) hyps in Refine.refine ~typecheck:false begin fun sigma -> - Evarutil.new_evar_instance nctx sigma nconcl ~principal:true instance + let sigma, ev = Evarutil.new_pure_evar nctx sigma nconcl ~principal:true in + sigma, mkEvar (ev, instance) end end @@ -436,7 +437,12 @@ let clear_hyps2 env sigma ids sign t cl = with Evarutil.ClearDependencyError (id,err,inglobal) -> error_replacing_dependency env sigma id err inglobal -let internal_cut_gen ?(check=true) dir replace id t = +let new_evar_from_context ?principal sign evd typ = + let instance = List.map (NamedDecl.get_id %> EConstr.mkVar) (named_context_of_val sign) in + let (evd, evk) = Evarutil.new_pure_evar sign evd typ in + (evd, mkEvar (evk, instance)) + +let internal_cut ?(check=true) replace id t = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -457,23 +463,13 @@ let internal_cut_gen ?(check=true) dir replace id t = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Refine.refine ~typecheck:false begin fun sigma -> - let (sigma,ev,ev') = - if dir then - let (sigma, ev) = Evarutil.new_evar_from_context sign sigma nf_t in - let (sigma, ev') = Evarutil.new_evar_from_context sign' sigma ~principal:true concl in - (sigma,ev,ev') - else - let (sigma, ev') = Evarutil.new_evar_from_context sign' sigma ~principal:true concl in - let (sigma, ev) = Evarutil.new_evar_from_context sign sigma nf_t in - (sigma,ev,ev') in + let (sigma, ev) = new_evar_from_context sign sigma nf_t in + let (sigma, ev') = new_evar_from_context sign' sigma ~principal:true concl in let term = mkLetIn (make_annot (Name id) r, ev, t, EConstr.Vars.subst_var id ev') in (sigma, term) end) end -let internal_cut ?(check=true) = internal_cut_gen ~check true -let internal_cut_rev ?(check=true) = internal_cut_gen ~check false - let assert_before_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter begin fun gl -> @@ -500,7 +496,7 @@ let assert_after_then_gen ?err b naming t tac = Proofview.Goal.enter begin fun gl -> let id = find_name b (LocalAssum (make_annot Anonymous Sorts.Relevant,t)) naming gl in Tacticals.New.tclTHENFIRST - (replace_error_option err (internal_cut_rev b id t)) + (replace_error_option err (internal_cut b id t <*> Proofview.cycle 1)) (tac id) end diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index 553eb903fa..3bcd235b41 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -46,6 +46,7 @@ struct | DCoFix of int * 't array * 't array | DInt of Uint63.t | DFloat of Float64.t + | DArray of 't array * 't * 't (* special constructors only inside the left-hand side of DCtx or DApp. Used to encode lists of foralls/letins/apps as contexts *) @@ -69,6 +70,7 @@ struct Some t' -> str ":=" ++ f t' | None -> str "") ++ spc() ++ str "::" ++ spc() ++ f tl | DNil -> str "[]" + | DArray _ -> str "ARRAY" (* * Functional iterators for the t datatype @@ -86,6 +88,7 @@ struct | DCoFix(i,ta,ca) -> DCoFix (i,Array.map f ta,Array.map f ca) | DCons ((t,topt),u) -> DCons ((f t,Option.map f topt), f u) + | DArray (t,def,ty) -> DArray(Array.map f t, f def, f ty) let compare_ci ci1 ci2 = let c = ind_ord ci1.ci_ind ci2.ci_ind in @@ -157,6 +160,17 @@ struct | DFloat _, _ -> -1 | _, DFloat _ -> 1 + | DArray(t1,def1,ty1), DArray(t2,def2,ty2) -> + let c = Array.compare cmp t1 t2 in + if c = 0 then + let c = cmp def1 def2 in + if c = 0 then + cmp ty1 ty2 + else c + else c + + | DArray _, _ -> -1 | _, DArray _ -> 1 + | DCons ((t1, ot1), u1), DCons ((t2, ot2), u2) -> let c = cmp t1 t2 in if Int.equal c 0 then @@ -178,6 +192,7 @@ struct Array.fold_left f (Array.fold_left f acc ta) ca | DCoFix(i,ta,ca) -> Array.fold_left f (Array.fold_left f acc ta) ca + | DArray(t,def,ty) -> f (f (Array.fold_left f acc t) def) ty | DCons ((t,topt),u) -> f (Option.fold_left f (f acc t) topt) u let choose f = function @@ -189,6 +204,7 @@ struct | DFix (ia,i,ta,ca) -> f ta.(0) | DCoFix (i,ta,ca) -> f ta.(0) | DCons ((t,topt),u) -> f u + | DArray(t,def,ty) -> f t.(0) let dummy_cmp () () = 0 @@ -208,10 +224,12 @@ struct Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2 | DCoFix(i,ta1,ca1), DCoFix(_,ta2,ca2) -> Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2 + | DArray(t1,def1,ty1), DArray(t2,def2,ty2) -> + f (f (Array.fold_left2 f acc t1 t2) def1 def2) ty1 ty2 | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> f (Option.fold_left2 f (f acc t1 t2) topt1 topt2) u1 u2 | (DRel | DNil | DSort | DRef _ | DCtx _ | DApp _ | DLambda _ | DCase _ - | DFix _ | DCoFix _ | DCons _ | DInt _ | DFloat _), _ -> assert false + | DFix _ | DCoFix _ | DCons _ | DInt _ | DFloat _| DArray _), _ -> assert false let map2 (f:'a -> 'b -> 'c) (c1:'a t) (c2:'b t) : 'c t = let head w = map (fun _ -> ()) w in @@ -230,14 +248,16 @@ struct DFix (ia,i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2) | DCoFix (i,ta1,ca1), DCoFix (_,ta2,ca2) -> DCoFix (i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2) + | DArray(t1,def1,ty1), DArray(t2,def2,ty2) -> + DArray(Array.map2 f t1 t2, f def1 def2, f ty1 ty2) | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> DCons ((f t1 t2,Option.lift2 f topt1 topt2), f u1 u2) | (DRel | DNil | DSort | DRef _ | DCtx _ | DApp _ | DLambda _ | DCase _ - | DFix _ | DCoFix _ | DCons _ | DInt _ | DFloat _), _ -> assert false + | DFix _ | DCoFix _ | DCons _ | DInt _ | DFloat _ | DArray _), _ -> assert false let terminal = function | (DRel | DSort | DNil | DRef _ | DInt _ | DFloat _) -> true - | DLambda _ | DApp _ | DCase _ | DFix _ | DCoFix _ | DCtx _ | DCons _ -> + | DLambda _ | DApp _ | DCase _ | DFix _ | DCoFix _ | DCtx _ | DCons _ | DArray _ -> false let compare t1 t2 = compare dummy_cmp t1 t2 @@ -315,7 +335,7 @@ struct meta in Meta meta - | Case (ci,c1,c2,ca) -> + | Case (ci,c1,_iv,c2,ca) -> Term(DCase(ci,pat_of_constr c1,pat_of_constr c2,Array.map pat_of_constr ca)) | Fix ((ia,i),(_,ta,ca)) -> Term(DFix(ia,i,Array.map pat_of_constr ta, Array.map pat_of_constr ca)) @@ -332,6 +352,8 @@ struct Term (DApp (Term (DRef (ConstRef (Projection.constant p))), pat_of_constr c)) | Int i -> Term (DInt i) | Float f -> Term (DFloat f) + | Array (_u,t,def,ty) -> + Term (DArray (Array.map pat_of_constr t, pat_of_constr def, pat_of_constr ty)) and ctx_of_constr ctx c = match Constr.kind c with | Prod (_,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c diff --git a/test-suite/Makefile b/test-suite/Makefile index 59cc3e5a38..0935617fbf 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -112,7 +112,7 @@ INTERACTIVE := interactive UNIT_TESTS := unit-tests VSUBSYSTEMS := prerequisite success failure $(BUGS) output output-coqtop \ output-modulo-time $(INTERACTIVE) micromega $(COMPLEXITY) modules stm \ - coqdoc ssr primitive/uint63 primitive/float ltac2 + coqdoc ssr $(wildcard primitive/*) ltac2 # All subsystems SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk output-coqchk coqwc coq-makefile tools $(UNIT_TESTS) diff --git a/test-suite/bugs/closed/bug_11121.v b/test-suite/bugs/closed/bug_11121.v new file mode 100644 index 0000000000..6112a443ab --- /dev/null +++ b/test-suite/bugs/closed/bug_11121.v @@ -0,0 +1,21 @@ +Declare Custom Entry example. + +Module M1. +Fixpoint stupid (x : nat) : nat := 1. +Reserved Notation " x '==' 1 " (in custom example at level 0, x constr). +Notation " x '==' 1" := (stupid x) (in custom example). +End M1. + +Module M2. +Fixpoint stupid (x : nat) : nat := 1. +Notation " x '==' 1" := (stupid x) (in custom example at level 0). +Fail Notation " x '==' 1" := (stupid x) (in custom example at level 1). +End M2. + +Module M3. +Reserved Notation " x '==' 1 " (in custom example at level 55, x constr). + +Fixpoint stupid (x : nat) : nat := 1 +where " x '==' 1" := (stupid x) (in custom example). + +End M3. diff --git a/test-suite/bugs/closed/bug_12528.v b/test-suite/bugs/closed/bug_12528.v new file mode 100644 index 0000000000..4ab05ac9b8 --- /dev/null +++ b/test-suite/bugs/closed/bug_12528.v @@ -0,0 +1,6 @@ +Set Primitive Projections. +Set Universe Polymorphism. +Record ptd := Ptd { t : Type ; p : t }. +Definition type := Ptd Type (unit:Type). +Definition type' := Ptd Type (p type). +Canonical type'. diff --git a/test-suite/bugs/closed/bug_12551.v b/test-suite/bugs/closed/bug_12551.v new file mode 100644 index 0000000000..77ecb367ec --- /dev/null +++ b/test-suite/bugs/closed/bug_12551.v @@ -0,0 +1,8 @@ + +Section S. + Context [A:Type] (a:A). + Definition id := a. +End S. + +Check id : forall A, A -> A. +Check id 0 : nat. diff --git a/test-suite/bugs/closed/bug_12571.v b/test-suite/bugs/closed/bug_12571.v new file mode 100644 index 0000000000..c348626921 --- /dev/null +++ b/test-suite/bugs/closed/bug_12571.v @@ -0,0 +1,20 @@ +Axiom IsTrunc : Type -> Type. + +Existing Class IsTrunc. + +Declare Instance trunc_forall : + forall (A : Type) (P : A -> Type), + IsTrunc (forall a : A, P a). + +Axiom Graph : Set. +Axiom in_N : forall (n : Graph), Type. + +Definition N : Type := @sigT Graph in_N. + +Goal forall (P : N -> Type) + (Q := fun m : Graph => forall mrec : in_N m, P (existT _ m mrec)) + (A : Graph), IsTrunc (Q A). +Proof. +intros. +solve [typeclasses eauto]. +Qed. diff --git a/test-suite/bugs/closed/bug_12651.v b/test-suite/bugs/closed/bug_12651.v new file mode 100644 index 0000000000..cdeeb84912 --- /dev/null +++ b/test-suite/bugs/closed/bug_12651.v @@ -0,0 +1,6 @@ + +Set Warnings "+implicits-in-term". +Definition thing1 : forall {A}, A -> A := fun A a => a. +Check thing1 : _ -> _. +Fail Definition thing2 : forall {A}, A -> A := fun [A] a => a. +Fail Definition thing2 : forall A, A -> A := fun {A} a => a. diff --git a/test-suite/failure/uip_loop.v b/test-suite/failure/uip_loop.v new file mode 100644 index 0000000000..5b4a88e7cc --- /dev/null +++ b/test-suite/failure/uip_loop.v @@ -0,0 +1,24 @@ +Set Definitional UIP. + +Inductive seq {A} (a:A) : A -> SProp := + srefl : seq a a. +Arguments srefl {_ _}. + +(* Axiom implied by propext (so consistent) *) +Axiom all_eq : forall (P Q:Prop), P -> Q -> seq P Q. + +Definition transport (P Q:Prop) (x:P) (y:Q) : Q + := match all_eq P Q x y with srefl => x end. + +Definition top : Prop := forall P : Prop, P -> P. + +Definition c : top := + fun P p => + transport + (top -> top) + P + (fun x : top => x (top -> top) (fun x => x) x) + p. + +Fail Timeout 1 Eval lazy in c (top -> top) (fun x => x) c. +(* loops *) diff --git a/test-suite/ltac2/constr.v b/test-suite/ltac2/constr.v index 018596ed95..8c06bff056 100644 --- a/test-suite/ltac2/constr.v +++ b/test-suite/ltac2/constr.v @@ -10,3 +10,9 @@ Axiom something : SProp. Ltac2 Eval match (kind '(forall x : something, bool)) with | Prod a c => a | _ => throw Match_failure end. + +From Coq Require Import Int63 PArray. +Open Scope array_scope. +Ltac2 Eval match (kind '([|true|true|])) with + | Array _ _ _ ty => ty + | _ => throw Match_failure end. diff --git a/test-suite/ltac2/syntax.v b/test-suite/ltac2/syntax.v new file mode 100644 index 0000000000..872b2142d0 --- /dev/null +++ b/test-suite/ltac2/syntax.v @@ -0,0 +1,12 @@ +Require Import Ltac2.Ltac2. + +Ltac2 Type ('a, 'b, 'c) t. +Ltac2 Type ('a) u. +Ltac2 Type 'a v. + +Ltac2 foo + (f : ('a, 'b, 'c) t -> ('a -> 'a, 'b -> 'c, 'c * 'c) t) + (x : ('a, 'b, 'c) t) := + f x. + +Ltac2 bar (x : 'a u) (y : ('b) v) := x. diff --git a/test-suite/output/PrintAssumptions.out b/test-suite/output/PrintAssumptions.out index ca4858d7a7..ba316ceb64 100644 --- a/test-suite/output/PrintAssumptions.out +++ b/test-suite/output/PrintAssumptions.out @@ -7,6 +7,8 @@ bli : Type Axioms: bli : Type Axioms: +@seq relies on definitional UIP. +Axioms: extensionality : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g Axioms: diff --git a/test-suite/output/PrintAssumptions.v b/test-suite/output/PrintAssumptions.v index 4c980fddba..71e642519c 100644 --- a/test-suite/output/PrintAssumptions.v +++ b/test-suite/output/PrintAssumptions.v @@ -45,6 +45,32 @@ Module Poly. End Poly. +Module UIP. + Set Definitional UIP. + + Inductive seq {A} (a:A) : A -> SProp := + srefl : seq a a. + Arguments srefl {_ _}. + + Definition eq_to_seq {A x y} (e:x = y :> A) : seq x y + := match e with eq_refl => srefl end. + Definition seq_to_eq {A x y} (e:seq x y) : x = y :> A + := match e with srefl => eq_refl end. + + Definition norm {A x y} (e:x = y :> A) : x = y + := seq_to_eq (eq_to_seq e). + + Definition norm_id {A x y} (e:x = y :> A) : norm e = e + := match e with eq_refl => eq_refl end. + + Theorem UIP {A x y} (e e':x = y :> A) : e = e'. + Proof. + rewrite <-(norm_id e), <-(norm_id e'). + reflexivity. + Defined. + + Print Assumptions UIP. +End UIP. (* The original test-case of the bug-report *) diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index 317e9c3757..09feca71e7 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -455,3 +455,6 @@ PreOrder_Reflexive: reflexive_eq_dom_reflexive: forall {A B : Type} {R' : Relation_Definitions.relation B}, Reflexive R' -> Reflexive (eq ==> R')%signature +B.b: B.a +A.b: A.a +F.L: F.P 0 diff --git a/test-suite/output/Search.v b/test-suite/output/Search.v index 4ec7a760b9..a5ac2cb511 100644 --- a/test-suite/output/Search.v +++ b/test-suite/output/Search.v @@ -66,3 +66,26 @@ Reset Initial. Require Import Morphisms. Search is:Instance [ Reflexive | Symmetric ]. + +Module Bug12525. + (* This was revealing a kernel bug with delta-resolution *) + Module A. Axiom a:Prop. Axiom b:a. End A. + Module B. Include A. End B. + Module M. + Search B.a. + End M. +End Bug12525. + +From Coq Require Lia. + +Module Bug12647. + (* Similar to #12525 *) + Module Type Foo. + Axiom P : nat -> Prop. + Axiom L : P 0. + End Foo. + + Module Bar (F : Foo). + Search F.P. + End Bar. +End Bug12647. diff --git a/test-suite/primitive/arrays/copy.v b/test-suite/primitive/arrays/copy.v new file mode 100644 index 0000000000..bc8e733334 --- /dev/null +++ b/test-suite/primitive/arrays/copy.v @@ -0,0 +1,22 @@ +From Coq Require Import Int63 PArray. + +Open Scope array_scope. + +Definition t : array nat := [| 1; 5; 2 | 4 |]. +Definition t' : array nat := PArray.copy t. + +Definition foo1 := (eq_refl : t'.[1] = 5). +Definition foo2 := (eq_refl 5 <: t'.[1] = 5). +Definition foo3 := (eq_refl 5 <<: t'.[1] = 5). +Definition x1 := Eval compute in t'.[1]. +Definition foo4 := (eq_refl : x1 = 5). +Definition x2 := Eval cbn in t'.[1]. +Definition foo5 := (eq_refl : x2 = 5). + +Definition foo6 := (eq_refl : t.[1] = 5). +Definition foo7 := (eq_refl 5 <: t.[1] = 5). +Definition foo8 := (eq_refl 5 <<: t.[1] = 5). +Definition x3 := Eval compute in t.[1]. +Definition foo9 := (eq_refl : x3 = 5). +Definition x4 := Eval cbn in t.[1]. +Definition foo10 := (eq_refl : x4 = 5). diff --git a/test-suite/primitive/arrays/default.v b/test-suite/primitive/arrays/default.v new file mode 100644 index 0000000000..3b89787faf --- /dev/null +++ b/test-suite/primitive/arrays/default.v @@ -0,0 +1,10 @@ +From Coq Require Import Int63 PArray. + +Definition t : array nat := [| 1; 3; 2 | 4 |]. +Definition foo1 := (eq_refl : default t = 4). +Definition foo2 := (eq_refl 4 <: default t = 4). +Definition foo3 := (eq_refl 4 <<: default t = 4). +Definition x1 := Eval compute in default t. +Definition foo4 := (eq_refl : x1 = 4). +Definition x2 := Eval cbn in default t. +Definition foo5 := (eq_refl : x2 = 4). diff --git a/test-suite/primitive/arrays/get.v b/test-suite/primitive/arrays/get.v new file mode 100644 index 0000000000..9a6f09a83b --- /dev/null +++ b/test-suite/primitive/arrays/get.v @@ -0,0 +1,86 @@ +From Coq Require Import Int63 PArray. + +Open Scope array_scope. + +(* Test reduction of primitives on array with kernel conversion, vm_compute, +native_compute, cbv, cbn *) + +(* Immediate values *) +Definition t : array nat := [| 1; 3; 2 | 4 |]. +Definition foo1 := (eq_refl : t.[0] = 1). +Definition foo2 := (eq_refl 1 <: t.[0] = 1). +Definition foo3 := (eq_refl 1 <<: t.[0] = 1). +Definition x1 := Eval compute in t.[0]. +Definition foo4 := (eq_refl : x1 = 1). +Definition x2 := Eval cbn in t.[0]. +Definition foo5 := (eq_refl : x2 = 1). + +Definition foo6 := (eq_refl : t.[2] = 2). +Definition foo7 := (eq_refl 2 <: t.[2] = 2). +Definition foo8 := (eq_refl 2 <<: t.[2] = 2). +Definition x3 := Eval compute in t.[2]. +Definition foo9 := (eq_refl : x3 = 2). +Definition x4 := Eval cbn in t.[2]. +Definition foo10 := (eq_refl : x4 = 2). + +Definition foo11 := (eq_refl : t.[99] = 4). +Definition foo12 := (eq_refl 4 <: t.[99] = 4). +Definition foo13 := (eq_refl 4 <<: t.[99] = 4). +Definition x5 := Eval compute in t.[4]. +Definition foo14 := (eq_refl : x5 = 4). +Definition x6 := Eval cbn in t.[4]. +Definition foo15 := (eq_refl : x6 = 4). + +(* Computations inside the array *) +Definition t2 : array nat := [| 1 + 3 | 5 |]. +Definition foo16 := (eq_refl : t2.[0] = 4). +Definition foo17 := (eq_refl 4 <: t2.[0] = 4). +Definition foo18 := (eq_refl 4 <<: t2.[0] = 4). +Definition x7 := Eval compute in t2.[0]. +Definition foo19 := (eq_refl : x7 = 4). +Definition x8 := Eval cbn in t2.[0]. +Definition foo20 := (eq_refl : x8 = 4). + +(* Functions inside the array *) +Definition t3 : array (nat -> nat) := [| fun x => x | fun x => O |]. +Definition foo21 := (eq_refl : t3.[0] 2 = 2). +Definition foo22 := (eq_refl 2 <: t3.[0] 2 = 2). +Definition foo23 := (eq_refl 2 <<: t3.[0] 2 = 2). +Definition x9 := Eval compute in t3.[0] 2. +Definition foo24 := (eq_refl : x9 = 2). +Definition x10 := Eval cbn in t3.[0] 2. +Definition foo25 := (eq_refl : x10 = 2). + +Ltac check_const_eq name constr := + let v := (eval cbv delta [name] in name) in + tryif constr_eq v constr + then idtac + else fail 0 "Not syntactically equal:" name ":=" v "<>" constr. + +Notation check_const_eq name constr := (ltac:(check_const_eq name constr; exact constr)) (only parsing). + +(* Stuck primitive *) +Definition lazy_stuck_get := Eval lazy in (fun A (t : array A) => t.[0]). +Definition vm_stuck_get := Eval vm_compute in (fun A (t : array A) => t.[0]). +Definition native_stuck_get := Eval native_compute in (fun A (t : array A) => t.[0]). +Definition compute_stuck_get := Eval compute in (fun A (t : array A) => t.[0]). +Definition cbn_stuck_get := Eval cbn in (fun A (t : array A) => t.[0]). + +Check check_const_eq lazy_stuck_get (fun A (t : array A) => t.[0]). +Check check_const_eq vm_stuck_get (fun A (t : array A) => t.[0]). +Check check_const_eq native_stuck_get (fun A (t : array A) => t.[0]). +Check check_const_eq compute_stuck_get (fun A (t : array A) => t.[0]). +Check check_const_eq cbn_stuck_get (fun A (t : array A) => t.[0]). + +(* Under-application *) +Definition lazy_get := Eval lazy in @PArray.get. +Definition vm_get := Eval vm_compute in @PArray.get. +Definition native_get := Eval native_compute in @PArray.get. +Definition compute_get := Eval compute in @PArray.get. +Definition cbn_get := Eval cbn in @PArray.get. + +Check check_const_eq lazy_get (@PArray.get). +Check check_const_eq vm_get (fun A (t : array A) i => t.[i]). +Check check_const_eq native_get (fun A (t : array A) i => t.[i]). +Check check_const_eq compute_get (@PArray.get). +Check check_const_eq cbn_get (@PArray.get). diff --git a/test-suite/primitive/arrays/length.v b/test-suite/primitive/arrays/length.v new file mode 100644 index 0000000000..67f686f2fb --- /dev/null +++ b/test-suite/primitive/arrays/length.v @@ -0,0 +1,12 @@ +From Coq Require Import Int63 PArray. + +Open Scope int63_scope. + +Definition t : array nat := [| 1; 3; 2 | 4 |]%nat. +Definition foo1 := (eq_refl : PArray.length t = 3). +Definition foo2 := (eq_refl 3 <: PArray.length t = 3). +Definition foo3 := (eq_refl 3 <<: PArray.length t = 3). +Definition x1 := Eval compute in PArray.length t. +Definition foo4 := (eq_refl : x1 = 3). +Definition x2 := Eval cbn in PArray.length t. +Definition foo5 := (eq_refl : x2 = 3). diff --git a/test-suite/primitive/arrays/literal.v b/test-suite/primitive/arrays/literal.v new file mode 100644 index 0000000000..13e57adbbe --- /dev/null +++ b/test-suite/primitive/arrays/literal.v @@ -0,0 +1,6 @@ +From Coq Require Import Int63 PArray. + +Open Scope array_scope. + +Definition t1 : array nat := [| 3; 3; 3; 3 | 3 |]. +Definition t2 := [|Type|Type|]. diff --git a/test-suite/primitive/arrays/make.v b/test-suite/primitive/arrays/make.v new file mode 100644 index 0000000000..a3a39470ed --- /dev/null +++ b/test-suite/primitive/arrays/make.v @@ -0,0 +1,18 @@ +From Coq Require Import Int63 PArray. + +Open Scope array_scope. + +(* Immediate values *) +Definition t1 : array nat := [| 3; 3; 3; 3 | 3 |]. +Definition t2 := PArray.make 4 3. +Definition foo1 := (eq_refl : t1 = t2). +Definition foo2 := (eq_refl t1 <: t1 = t2). +Definition foo3 := (eq_refl t1 <<: t1 = t2). +Definition x1 := Eval compute in t2. +Definition foo4 := (eq_refl : x1 = t1). +Definition x2 := Eval cbn in t2. +Definition foo5 := (eq_refl : x2 = t1). + +Definition partial1 := Eval lazy in @PArray.make. +Definition partial2 := Eval vm_compute in @PArray.make. +Definition partial3 := Eval native_compute in @PArray.make. diff --git a/test-suite/primitive/arrays/max_length.v b/test-suite/primitive/arrays/max_length.v new file mode 100644 index 0000000000..54a6af7a19 --- /dev/null +++ b/test-suite/primitive/arrays/max_length.v @@ -0,0 +1,13 @@ +From Coq Require Import Int63 PArray. + +Open Scope int63_scope. + +Definition max_length := 4194303. + +Definition foo1 := (eq_refl max_length : PArray.max_length = max_length). +Definition foo2 := (eq_refl max_length <: PArray.max_length = max_length). +Definition foo3 := (eq_refl max_length <<: PArray.max_length = max_length). +Definition max_length2 := Eval compute in PArray.max_length. +Definition foo4 := (eq_refl : max_length = max_length2). +Definition max_length3 := Eval cbn in PArray.max_length. +Definition foo5 := (eq_refl : max_length = max_length3). diff --git a/test-suite/primitive/arrays/nested.v b/test-suite/primitive/arrays/nested.v new file mode 100644 index 0000000000..841cee4463 --- /dev/null +++ b/test-suite/primitive/arrays/nested.v @@ -0,0 +1,47 @@ +From Coq Require Import Int63 PArray. + +Open Scope array_scope. + +Module OneLevel. + +Inductive foo : Set := + C : array foo -> foo. + +Fixpoint f1 (x : foo) {struct x} : False := + match x with + | C t => f1 (t.[0]) + end. + +Fixpoint f2 (x : foo) {struct x} : False := + f2 match x with + | C t => t.[0] + end. + +Fixpoint f3 (x : foo) {struct x} : False := + match x with + | C t => f3 (PArray.default t) + end. + +End OneLevel. + +Module TwoLevels. + +Inductive foo : Set := + C : array (array foo) -> foo. + +Fixpoint f1 (x : foo) {struct x} : False := + match x with + | C t => f1 (t.[0].[0]) + end. + +Fixpoint f2 (x : foo) {struct x} : False := + f2 match x with + | C t => t.[0].[0] + end. + +Fixpoint f3 (x : foo) {struct x} : False := + match x with + | C t => f3 (PArray.default (PArray.default t)) + end. + +End TwoLevels. diff --git a/test-suite/primitive/arrays/reroot.v b/test-suite/primitive/arrays/reroot.v new file mode 100644 index 0000000000..172a118cc7 --- /dev/null +++ b/test-suite/primitive/arrays/reroot.v @@ -0,0 +1,22 @@ +From Coq Require Import Int63 PArray. + +Open Scope array_scope. + +Definition t : array nat := [| 1; 5; 2 | 4 |]. +Definition t' : array nat := PArray.reroot t. + +Definition foo1 := (eq_refl : t'.[1] = 5). +Definition foo2 := (eq_refl 5 <: t'.[1] = 5). +Definition foo3 := (eq_refl 5 <<: t'.[1] = 5). +Definition x1 := Eval compute in t'.[1]. +Definition foo4 := (eq_refl : x1 = 5). +Definition x2 := Eval cbn in t'.[1]. +Definition foo5 := (eq_refl : x2 = 5). + +Definition foo6 := (eq_refl : t.[1] = 5). +Definition foo7 := (eq_refl 5 <: t.[1] = 5). +Definition foo8 := (eq_refl 5 <<: t.[1] = 5). +Definition x3 := Eval compute in t.[1]. +Definition foo9 := (eq_refl : x3 = 5). +Definition x4 := Eval cbn in t.[1]. +Definition foo10 := (eq_refl : x4 = 5). diff --git a/test-suite/primitive/arrays/set.v b/test-suite/primitive/arrays/set.v new file mode 100644 index 0000000000..f265c37ea8 --- /dev/null +++ b/test-suite/primitive/arrays/set.v @@ -0,0 +1,22 @@ +From Coq Require Import Int63 PArray. + +Open Scope array_scope. + +Definition t : array nat := [| 1; 3; 2 | 4 |]. +Definition t' : array nat := t.[1 <- 5]. + +Definition foo1 := (eq_refl : t'.[1] = 5). +Definition foo2 := (eq_refl 5 <: t'.[1] = 5). +Definition foo3 := (eq_refl 5 <<: t'.[1] = 5). +Definition x1 := Eval compute in t'.[1]. +Definition foo4 := (eq_refl : x1 = 5). +Definition x2 := Eval cbn in t'.[1]. +Definition foo5 := (eq_refl : x2 = 5). + +Definition foo6 := (eq_refl : t.[1] = 3). +Definition foo7 := (eq_refl 3 <: t.[1] = 3). +Definition foo8 := (eq_refl 3 <<: t.[1] = 3). +Definition x3 := Eval compute in t.[1]. +Definition foo9 := (eq_refl : x3 = 3). +Definition x4 := Eval cbn in t.[1]. +Definition foo10 := (eq_refl : x4 = 3). diff --git a/test-suite/success/bug_10890.v b/test-suite/success/bug_10890.v new file mode 100644 index 0000000000..37b6c816cc --- /dev/null +++ b/test-suite/success/bug_10890.v @@ -0,0 +1,8 @@ +Require Import Derive. + +Derive foo SuchThat (foo = foo :> nat) As bar. +Proof. + Unshelve. + 2:abstract exact 0. + exact eq_refl. +Defined. (* or Qed: anomaly kernel doesn't support existential variables *) diff --git a/test-suite/success/sprop.v b/test-suite/success/sprop.v index 268c1880d2..d3e2749088 100644 --- a/test-suite/success/sprop.v +++ b/test-suite/success/sprop.v @@ -112,6 +112,7 @@ Inductive Istrue : bool -> SProp := istrue : Istrue true. Definition Istrue_sym (b:bool) := if b then sUnit else sEmpty. Definition Istrue_to_sym b (i:Istrue b) : Istrue_sym b := match i with istrue => stt end. +(* We don't need primitive elimination to relevant types for this *) Definition Istrue_rec (P:forall b, Istrue b -> Set) (H:P true istrue) b (i:Istrue b) : P b i. Proof. destruct b. diff --git a/test-suite/success/sprop_uip.v b/test-suite/success/sprop_uip.v new file mode 100644 index 0000000000..508cc2be7d --- /dev/null +++ b/test-suite/success/sprop_uip.v @@ -0,0 +1,101 @@ + +Set Allow StrictProp. +Set Definitional UIP. + +Set Warnings "+bad-relevance". + +(** Case inversion, conversion and universe polymorphism. *) +Set Universe Polymorphism. +Inductive IsTy@{i j} : Type@{j} -> SProp := + isty : IsTy Type@{i}. + +Definition IsTy_rec_red@{i j+} (P:forall T : Type@{j}, IsTy@{i j} T -> Set) + v (e:IsTy@{i j} Type@{i}) + : IsTy_rec P v _ e = v + := eq_refl. + + +(** Identity! Currently we have UIP. *) +Inductive seq {A} (a:A) : A -> SProp := + srefl : seq a a. + +Definition transport {A} (P:A -> Type) {x y} (e:seq x y) (v:P x) : P y := + match e with + srefl _ => v + end. + +Definition transport_refl {A} (P:A -> Type) {x} (e:seq x x) v + : transport P e v = v + := @eq_refl (P x) v. + +Definition id_unit (x : unit) := x. +Definition transport_refl_id {A} (P : A -> Type) {x : A} (u : P x) + : P (transport (fun _ => A) (srefl _ : seq (id_unit tt) tt) x) + := u. + +(** We don't ALWAYS reduce (this uses a constant transport so that the + equation is well-typed) *) +Fail Definition transport_block A B (x y:A) (e:seq x y) v + : transport (fun _ => B) e v = v + := @eq_refl B v. + +Inductive sBox (A:SProp) : Prop + := sbox : A -> sBox A. + +Definition transport_refl_box (A:SProp) P (x y:A) (e:seq (sbox A x) (sbox A y)) v + : transport P e v = v + := eq_refl. + +(** TODO? add tests for binders which aren't lambda. *) +Definition transport_box := + Eval lazy in (fun (A:SProp) P (x y:A) (e:seq (sbox A x) (sbox A y)) v => + transport P e v). + +Lemma transport_box_ok : transport_box = fun A P x y e v => v. +Proof. + unfold transport_box. + match goal with |- ?x = ?x => reflexivity end. +Qed. + +(** Play with UIP *) +Lemma of_seq {A:Type} {x y:A} (p:seq x y) : x = y. +Proof. + destruct p. reflexivity. +Defined. + +Lemma to_seq {A:Type} {x y:A} (p: x = y) : seq x y. +Proof. + destruct p. reflexivity. +Defined. + +Lemma eq_srec (A:Type) (x y:A) (P:x=y->Type) : (forall e : seq x y, P (of_seq e)) -> forall e, P e. +Proof. + intros H e. destruct e. + apply (H (srefl _)). +Defined. + +Lemma K : forall {A x} (p:x=x:>A), p = eq_refl. +Proof. + intros A x. apply eq_srec. intros;reflexivity. +Defined. + +Definition K_refl : forall {A x}, @K A x eq_refl = eq_refl + := fun A x => eq_refl. + +Section funext. + + Variable sfunext : forall {A B} (f g : A -> B), (forall x, seq (f x) (g x)) -> seq f g. + + Lemma funext {A B} (f g : A -> B) (H:forall x, (f x) = (g x)) : f = g. + Proof. + apply of_seq,sfunext;intros x;apply to_seq,H. + Defined. + + Definition funext_refl A B (f : A -> B) : funext f f (fun x => eq_refl) = eq_refl + := eq_refl. +End funext. + +(* check that extraction doesn't fall apart on matches with special reduction *) +Require Extraction. + +Extraction seq_rect. diff --git a/theories/Array/PArray.v b/theories/Array/PArray.v new file mode 100644 index 0000000000..282f56267c --- /dev/null +++ b/theories/Array/PArray.v @@ -0,0 +1,122 @@ +Require Import Int63. + +Set Universe Polymorphism. + +Primitive array := #array_type. + +Primitive make : forall A, int -> A -> array A := #array_make. +Arguments make {_} _ _. + +Primitive get : forall A, array A -> int -> A := #array_get. +Arguments get {_} _ _. + +Primitive default : forall A, array A -> A:= #array_default. +Arguments default {_} _. + +Primitive set : forall A, array A -> int -> A -> array A := #array_set. +Arguments set {_} _ _ _. + +Primitive length : forall A, array A -> int := #array_length. +Arguments length {_} _. + +Primitive copy : forall A, array A -> array A := #array_copy. +Arguments copy {_} _. + +(* [reroot t] produces an array that is extensionaly equal to [t], but whose + history has been squashed. Useful when performing multiple accesses in an old + copy of an array that has been updated. *) +Primitive reroot : forall A, array A -> array A := #array_reroot. +Arguments reroot {_} _. + +Module Export PArrayNotations. + +Declare Scope array_scope. +Delimit Scope array_scope with array. +Notation "t .[ i ]" := (get t i) + (at level 2, left associativity, format "t .[ i ]"). +Notation "t .[ i <- a ]" := (set t i a) + (at level 2, left associativity, format "t .[ i <- a ]"). + +End PArrayNotations. + +Local Open Scope int63_scope. +Local Open Scope array_scope. + +Primitive max_length := #array_max_length. + +(** Axioms *) +Axiom get_out_of_bounds : forall A (t:array A) i, (i < length t) = false -> t.[i] = default t. + +Axiom get_set_same : forall A t i (a:A), (i < length t) = true -> t.[i<-a].[i] = a. +Axiom get_set_other : forall A t i j (a:A), i <> j -> t.[i<-a].[j] = t.[j]. +Axiom default_set : forall A t i (a:A), default t.[i<-a] = default t. + + +Axiom get_make : forall A (a:A) size i, (make size a).[i] = a. + +Axiom leb_length : forall A (t:array A), length t <= max_length = true. + +Axiom length_make : forall A size (a:A), + length (make size a) = if size <= max_length then size else max_length. +Axiom length_set : forall A t i (a:A), + length t.[i<-a] = length t. + +Axiom get_copy : forall A (t:array A) i, (copy t).[i] = t.[i]. +Axiom length_copy : forall A (t:array A), length (copy t) = length t. + +Axiom get_reroot : forall A (t:array A) i, (reroot t).[i] = t.[i]. +Axiom length_reroot : forall A (t:array A), length (reroot t) = length t. + +Axiom array_ext : forall A (t1 t2:array A), + length t1 = length t2 -> + (forall i, i < length t1 = true -> t1.[i] = t2.[i]) -> + default t1 = default t2 -> + t1 = t2. + +(* Lemmas *) + +Lemma default_copy A (t:array A) : default (copy t) = default t. +Proof. + assert (irr_lt : length t < length t = false). + destruct (Int63.ltbP (length t) (length t)); try reflexivity. + exfalso; eapply BinInt.Z.lt_irrefl; eassumption. + assert (get_copy := get_copy A t (length t)). + rewrite !get_out_of_bounds in get_copy; try assumption. + rewrite length_copy; assumption. +Qed. + +Lemma default_make A (a : A) size : default (make size a) = a. +Proof. + assert (irr_lt : length (make size a) < length (make size a) = false). + destruct (Int63.ltbP (length (make size a)) (length (make size a))); try reflexivity. + exfalso; eapply BinInt.Z.lt_irrefl; eassumption. + assert (get_make := get_make A a size (length (make size a))). + rewrite !get_out_of_bounds in get_make; assumption. +Qed. + +Lemma default_reroot A (t:array A) : default (reroot t) = default t. +Proof. + assert (irr_lt : length t < length t = false). + destruct (Int63.ltbP (length t) (length t)); try reflexivity. + exfalso; eapply BinInt.Z.lt_irrefl; eassumption. + assert (get_reroot := get_reroot A t (length t)). + rewrite !get_out_of_bounds in get_reroot; try assumption. + rewrite length_reroot; assumption. +Qed. + +Lemma get_set_same_default A (t : array A) (i : int) : + t.[i <- default t].[i] = default t. +Proof. + case_eq (i < length t); intros. + rewrite get_set_same; trivial. + rewrite get_out_of_bounds, default_set; trivial. + rewrite length_set; trivial. +Qed. + +Lemma get_not_default_lt A (t:array A) x : + t.[x] <> default t -> (x < length t) = true. +Proof. + intros Hd. + case_eq (x < length t); intros Heq; [trivial | ]. + elim Hd; rewrite get_out_of_bounds; trivial. +Qed. diff --git a/theories/Logic/StrictProp.v b/theories/Logic/StrictProp.v index af97b60ee6..b12867ad4e 100644 --- a/theories/Logic/StrictProp.v +++ b/theories/Logic/StrictProp.v @@ -23,9 +23,6 @@ Arguments squash {_} _. Inductive sEmpty : SProp :=. Inductive sUnit : SProp := stt. -Definition sUnit_rect (P:sUnit -> Type) (v:P stt) (u:sUnit) : P u := v. -Definition sUnit_rec (P:sUnit -> Set) (v:P stt) (u:sUnit) : P u := v. -Definition sUnit_ind (P:sUnit -> Prop) (v:P stt) (u:sUnit) : P u := v. Set Primitive Projections. Record Ssig {A:Type} (P:A->SProp) := Sexists { Spr1 : A; Spr2 : P Spr1 }. diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index 047c9d0804..ef09188c33 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -97,6 +97,12 @@ Qed. (** * Properties of Exp *) (******************************************************************) +Lemma exp_neq_0 : forall x:R, exp x <> 0. +Proof. + intro x. + exact (not_eq_sym (Rlt_not_eq 0 (exp x) (exp_pos x))). +Qed. + Theorem exp_increasing : forall x y:R, x < y -> exp x < exp y. Proof. intros x y H. @@ -198,6 +204,8 @@ Definition ln (x:R) : R := | right a => 0 end. +Definition Rlog x y := (ln y)/(ln x). + Lemma exp_ln : forall x:R, 0 < x -> exp (ln x) = x. Proof. intros; unfold ln; decide (Rlt_dec 0 x) with H. @@ -268,6 +276,16 @@ Proof. elim (Rlt_irrefl _ H2). Qed. +Lemma ln_neq_0 : forall x:R, x <> 1 -> 0 < x -> ln x <> 0. +Proof. + intros x Hneq_x_1 Hlt_0_x. + rewrite <- ln_1. + intro H. + assert (x = 1) as H0. + + exact (ln_inv x 1 Hlt_0_x (ltac:(lra) : 0 < 1) H). + + contradiction. +Qed. + Theorem ln_mult : forall x y:R, 0 < x -> 0 < y -> ln (x * y) = ln x + ln y. Proof. intros x y H H0; apply exp_inv. @@ -279,6 +297,25 @@ Proof. apply Rmult_lt_0_compat; assumption. Qed. +Lemma ln_pow : forall (x : R), 0 < x -> forall (n : nat), ln (x^n) = (INR n)*(ln x). +Proof. + intros x Hx. + induction n as [|m Hm]. + + simpl. + rewrite ln_1. + exact (eq_sym (Rmult_0_l (ln x))). + + unfold pow. + fold pow. + rewrite (ln_mult x (x^m) Hx (pow_lt x m Hx)). + rewrite Hm. + rewrite <- (Rmult_1_l (ln x)) at 1. + rewrite <- (Rmult_plus_distr_r 1 (INR m) (ln x)). + rewrite (Rplus_comm 1 (INR m)). + destruct m as [|m]; simpl. + - lra. + - reflexivity. +Qed. + Theorem ln_Rinv : forall x:R, 0 < x -> ln (/ x) = - ln x. Proof. intros x H; apply exp_inv; repeat rewrite exp_ln || rewrite exp_Ropp. @@ -379,8 +416,6 @@ Qed. Definition Rpower (x y:R) := exp (y * ln x). -Local Infix "^R" := Rpower (at level 30, right associativity) : R_scope. - (******************************************************************) (** * Properties of Rpower *) (******************************************************************) @@ -395,13 +430,13 @@ Local Infix "^R" := Rpower (at level 30, right associativity) : R_scope. default value of [Rpower] on the negative side, as it is the case for [Rpower_O]). *) -Theorem Rpower_plus : forall x y z:R, z ^R (x + y) = z ^R x * z ^R y. +Theorem Rpower_plus : forall x y z:R, Rpower z (x + y) = Rpower z x * Rpower z y. Proof. intros x y z; unfold Rpower. rewrite Rmult_plus_distr_r; rewrite exp_plus; auto. Qed. -Theorem Rpower_mult : forall x y z:R, (x ^R y) ^R z = x ^R (y * z). +Theorem Rpower_mult : forall x y z:R, Rpower (Rpower x y) z = Rpower x (y * z). Proof. intros x y z; unfold Rpower. rewrite ln_exp. @@ -410,19 +445,19 @@ Proof. ring. Qed. -Theorem Rpower_O : forall x:R, 0 < x -> x ^R 0 = 1. +Theorem Rpower_O : forall x:R, 0 < x -> Rpower x 0 = 1. Proof. intros x _; unfold Rpower. rewrite Rmult_0_l; apply exp_0. Qed. -Theorem Rpower_1 : forall x:R, 0 < x -> x ^R 1 = x. +Theorem Rpower_1 : forall x:R, 0 < x -> Rpower x 1 = x. Proof. intros x H; unfold Rpower. rewrite Rmult_1_l; apply exp_ln; apply H. Qed. -Theorem Rpower_pow : forall (n:nat) (x:R), 0 < x -> x ^R INR n = x ^ n. +Theorem Rpower_pow : forall (n:nat) (x:R), 0 < x -> Rpower x (INR n) = x ^ n. Proof. intros n; elim n; simpl; auto; fold INR. intros x H; apply Rpower_O; auto. @@ -432,8 +467,15 @@ Proof. try apply Rmult_comm || assumption. Qed. +Lemma Rpower_nonzero : forall (x : R) (n : nat), 0 < x -> Rpower x (INR n) <> 0. +Proof. + intros x n H. + rewrite (Rpower_pow n x H). + exact (pow_nonzero x n (not_eq_sym (Rlt_not_eq 0 x H))). +Qed. + Theorem Rpower_lt : - forall x y z:R, 1 < x -> y < z -> x ^R y < x ^R z. + forall x y z:R, 1 < x -> y < z -> Rpower x y < Rpower x z. Proof. intros x y z H H1. unfold Rpower. @@ -445,7 +487,19 @@ Proof. apply H1. Qed. -Theorem Rpower_sqrt : forall x:R, 0 < x -> x ^R (/ 2) = sqrt x. +Lemma Rpower_Rlog : forall x y:R, x <> 1 -> 0 < x -> 0 < y -> Rpower x (Rlog x y) = y. +Proof. + intros x y H_neq_x_1 H_lt_0_x H_lt_0_y. + unfold Rpower. + unfold Rlog. + unfold Rdiv. + rewrite (Rmult_assoc (ln y) (/ln x) (ln x)). + rewrite (Rinv_l (ln x) (ln_neq_0 x H_neq_x_1 H_lt_0_x)). + rewrite (Rmult_1_r (ln y)). + exact (exp_ln y H_lt_0_y). +Qed. + +Theorem Rpower_sqrt : forall x:R, 0 < x -> Rpower x (/ 2) = sqrt x. Proof. intros x H. apply ln_inv. @@ -454,7 +508,7 @@ Proof. apply Rmult_eq_reg_l with (INR 2). apply exp_inv. fold Rpower. - cut ((x ^R (/ INR 2)) ^R INR 2 = sqrt x ^R INR 2). + cut (Rpower (Rpower x (/ INR 2)) (INR 2) = Rpower (sqrt x) (INR 2)). unfold Rpower; auto. rewrite Rpower_mult. rewrite Rinv_l. @@ -468,7 +522,7 @@ Proof. apply not_O_INR; discriminate. Qed. -Theorem Rpower_Ropp : forall x y:R, x ^R (- y) = / x ^R y. +Theorem Rpower_Ropp : forall x y:R, Rpower x (- y) = / (Rpower x y). Proof. unfold Rpower. intros x y; rewrite Ropp_mult_distr_l_reverse. @@ -490,7 +544,7 @@ Proof. Qed. Theorem Rle_Rpower : - forall e n m:R, 1 <= e -> n <= m -> e ^R n <= e ^R m. + forall e n m:R, 1 <= e -> n <= m -> Rpower e n <= Rpower e m. Proof. intros e n m [H | H]; intros H1. case H1. @@ -499,6 +553,27 @@ Proof. now rewrite <- H; unfold Rpower; rewrite ln_1, !Rmult_0_r; apply Rle_refl. Qed. +Lemma ln_Rpower : forall x y:R, ln (Rpower x y) = y * ln x. +Proof. + intros x y. + unfold Rpower. + rewrite (ln_exp (y * ln x)). + reflexivity. +Qed. + +Lemma Rlog_pow : forall (x : R) (n : nat), x <> 1 -> 0 < x -> Rlog x (x^n) = INR n. +Proof. + intros x n H_neq_x_1 H_lt_0_x. + rewrite <- (Rpower_pow n x H_lt_0_x). + unfold Rpower. + unfold Rlog. + rewrite (ln_exp (INR n * ln x)). + unfold Rdiv. + rewrite (Rmult_assoc (INR n) (ln x) (/ln x)). + rewrite (Rinv_r (ln x) (ln_neq_0 x H_neq_x_1 H_lt_0_x)). + exact (Rmult_1_r (INR n)). +Qed. + Theorem ln_lt_2 : / 2 < ln 2. Proof. apply Rmult_lt_reg_l with (r := 2). @@ -506,7 +581,7 @@ Proof. rewrite Rinv_r. apply exp_lt_inv. apply Rle_lt_trans with (1 := exp_le_3). - change (3 < 2 ^R (1 + 1)). + change (3 < Rpower 2 (1 + 1)). repeat rewrite Rpower_plus; repeat rewrite Rpower_1. now apply (IZR_lt 3 4). prove_sup0. @@ -651,7 +726,7 @@ Qed. Theorem Dpower : forall y z:R, 0 < y -> - D_in (fun x:R => x ^R z) (fun x:R => z * x ^R (z - 1)) ( + D_in (fun x:R => Rpower x z) (fun x:R => z * Rpower x (z - 1)) ( fun x:R => 0 < x) y. Proof. intros y z H; @@ -682,7 +757,7 @@ Qed. Theorem derivable_pt_lim_power : forall x y:R, - 0 < x -> derivable_pt_lim (fun x => x ^R y) x (y * x ^R (y - 1)). + 0 < x -> derivable_pt_lim (fun x => Rpower x y) x (y * Rpower x (y - 1)). Proof. intros x y H. unfold Rminus; rewrite Rpower_plus. @@ -711,13 +786,13 @@ intros x y z x0 y0; unfold Rpower. rewrite <- exp_plus, ln_mult, Rmult_plus_distr_l; auto. Qed. -Lemma Rlt_Rpower_l a b c: 0 < c -> 0 < a < b -> a ^R c < b ^R c. +Lemma Rlt_Rpower_l a b c: 0 < c -> 0 < a < b -> Rpower a c < Rpower b c. Proof. intros c0 [a0 ab]; apply exp_increasing. now apply Rmult_lt_compat_l; auto; apply ln_increasing; lra. Qed. -Lemma Rle_Rpower_l a b c: 0 <= c -> 0 < a <= b -> a ^R c <= b ^R c. +Lemma Rle_Rpower_l a b c: 0 <= c -> 0 < a <= b -> Rpower a c <= Rpower b c. Proof. intros [c0 | c0]; [ | intros; rewrite <- c0, !Rpower_O; [apply Rle_refl | |] ]. diff --git a/theories/extraction/ExtrOCamlPArray.v b/theories/extraction/ExtrOCamlPArray.v new file mode 100644 index 0000000000..67646bdb53 --- /dev/null +++ b/theories/extraction/ExtrOCamlPArray.v @@ -0,0 +1,26 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <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) *) +(************************************************************************) + +(** Extraction to OCaml of persistent arrays. *) + +From Coq Require PArray Extraction. + +(** Primitive types and operators. *) +Extract Constant PArray.array "'a" => "'a Parray.t". +Extraction Inline PArray.array. +(* Otherwise, the name conflicts with the primitive OCaml type [array] *) + +Extract Constant PArray.make => "Parray.make". +Extract Constant PArray.get => "Parray.get". +Extract Constant PArray.default => "Parray.default". +Extract Constant PArray.set => "Parray.set". +Extract Constant PArray.length => "Parray.length". +Extract Constant PArray.copy => "Parray.copy". +Extract Constant PArray.reroot => "Parray.reroot". diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 9097195721..0086516785 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -467,7 +467,7 @@ vok: $(VOFILES:%.vo=%.vok) .PHONY: vok validate: $(VOFILES) - $(TIMER) $(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $^ + $(TIMER) $(COQCHK) $(COQCHKFLAGS) $(COQLIBS_NOML) $^ .PHONY: validate only: $(TGTS) diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 20ffdfe81d..2177da0c75 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -35,9 +35,7 @@ let usage () = eprintf " -sort : output the given file name ordered by dependencies\n"; eprintf " -noglob | -no-glob : \n"; eprintf " -f file : read -I, -Q, -R and filenames from _CoqProject-formatted FILE."; - eprintf " -I dir -as logname : add (non recursively) dir to coq load path under logical name logname\n"; eprintf " -I dir : add (non recursively) dir to ocaml path\n"; - eprintf " -R dir -as logname : add and import dir recursively to coq load path under logical name logname\n"; (* deprecate? *) eprintf " -R dir logname : add and import dir recursively to coq load path under logical name logname\n"; eprintf " -Q dir logname : add (recursively) and open (non recursively) dir to coq load path under logical name logname\n"; eprintf " -vos : also output dependencies about .vos files\n"; diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index c6bb38e005..03c53d6991 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -11,7 +11,7 @@ let outputstate opts = Option.iter (fun ostate_file -> let fname = CUnix.make_suffix ostate_file ".coq" in - Library.extern_state fname) opts.Coqcargs.outputstate + Vernacstate.System.dump fname) opts.Coqcargs.outputstate let coqc_init _copts ~opts = Flags.quiet := true; diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 80123757ec..bbcfcc4826 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -52,7 +52,7 @@ let print_memory_stat () = let inputstate opts = Option.iter (fun istate_file -> let fname = Loadpath.locate_file (CUnix.make_suffix istate_file ".coq") in - Library.intern_state fname) opts.inputstate + Vernacstate.System.load fname) opts.inputstate (******************************************************************************) (* Fatal Errors *) diff --git a/user-contrib/Ltac2/Constr.v b/user-contrib/Ltac2/Constr.v index 94d468e640..4cc9d99c64 100644 --- a/user-contrib/Ltac2/Constr.v +++ b/user-contrib/Ltac2/Constr.v @@ -22,6 +22,11 @@ Module Unsafe. Ltac2 Type case. +Ltac2 Type case_invert := [ +| NoInvert +| CaseInvert (instance,constr array) +]. + Ltac2 Type kind := [ | Rel (int) | Var (ident) @@ -36,12 +41,13 @@ Ltac2 Type kind := [ | Constant (constant, instance) | Ind (inductive, instance) | Constructor (constructor, instance) -| Case (case, constr, constr, constr array) +| Case (case, constr, case_invert, constr, constr array) | Fix (int array, int, binder array, constr array) | CoFix (int, binder array, constr array) | Proj (projection, constr) | Uint63 (uint63) | Float (float) +| Array (instance, constr array, constr, constr) ]. Ltac2 @ external kind : constr -> kind := "ltac2" "constr_kind". diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 3af39ec59a..bec9632e84 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -262,12 +262,16 @@ GRAMMAR EXTEND Gram | "1" LEFTA [ t = SELF; qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, [t]) } ] | "0" - [ "("; t = tac2type LEVEL "5"; ")" -> { t } + [ "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = OPT Prim.qualid -> + { match p, qid with + | [t], None -> t + | _, None -> CErrors.user_err ~loc (Pp.str "Syntax error") + | ts, Some qid -> CAst.make ~loc @@ CTypRef (RelId qid, p) + } | id = typ_param -> { CAst.make ~loc @@ CTypVar (Name id) } | "_" -> { CAst.make ~loc @@ CTypVar Anonymous } | qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, []) } - | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> - { CAst.make ~loc @@ CTypRef (RelId qid, p) } ] + ] ]; locident: [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 0299da6a25..cdbcc24484 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -107,6 +107,19 @@ let to_rec_declaration (nas, cs) = Array.map snd nas, Value.to_array Value.to_constr cs) +let of_case_invert = let open Constr in function + | NoInvert -> ValInt 0 + | CaseInvert {univs;args} -> + v_blk 0 [|of_instance univs; of_array of_constr args|] + +let to_case_invert = let open Constr in function + | ValInt 0 -> NoInvert + | ValBlk (0, [|univs;args|]) -> + let univs = to_instance univs in + let args = to_array to_constr args in + CaseInvert {univs;args} + | _ -> CErrors.anomaly Pp.(str "unexpected value shape") + let of_result f = function | Inl c -> v_blk 0 [|f c|] | Inr e -> v_blk 1 [|Value.of_exn e|] @@ -421,10 +434,11 @@ let () = define1 "constr_kind" constr begin fun c -> Value.of_ext Value.val_constructor cstr; of_instance u; |] - | Case (ci, c, t, bl) -> + | Case (ci, c, iv, t, bl) -> v_blk 13 [| Value.of_ext Value.val_case ci; Value.of_constr c; + of_case_invert iv; Value.of_constr t; Value.of_array Value.of_constr bl; |] @@ -452,6 +466,8 @@ let () = define1 "constr_kind" constr begin fun c -> v_blk 17 [|Value.of_uint63 n|] | Float f -> v_blk 18 [|Value.of_float f|] + | Array(u,t,def,ty) -> + v_blk 19 [|of_instance u; Value.of_array Value.of_constr t; Value.of_constr def; Value.of_constr ty|] end end @@ -507,12 +523,13 @@ let () = define1 "constr_make" valexpr begin fun knd -> let cstr = Value.to_ext Value.val_constructor cstr in let u = to_instance u in EConstr.mkConstructU (cstr, u) - | (13, [|ci; c; t; bl|]) -> + | (13, [|ci; c; iv; t; bl|]) -> let ci = Value.to_ext Value.val_case ci in let c = Value.to_constr c in + let iv = to_case_invert iv in let t = Value.to_constr t in let bl = Value.to_array Value.to_constr bl in - EConstr.mkCase (ci, c, t, bl) + EConstr.mkCase (ci, c, iv, t, bl) | (14, [|recs; i; nas; cs|]) -> let recs = Value.to_array Value.to_int recs in let i = Value.to_int i in @@ -532,6 +549,12 @@ let () = define1 "constr_make" valexpr begin fun knd -> | (18, [|f|]) -> let f = Value.to_float f in EConstr.mkFloat f + | (19, [|u;t;def;ty|]) -> + let t = Value.to_array Value.to_constr t in + let def = Value.to_constr def in + let ty = Value.to_constr ty in + let u = to_instance u in + EConstr.mkArray(u,t,def,ty) | _ -> assert false in return (Value.of_constr c) diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 2bb4bac9a4..848cd501c6 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -179,7 +179,7 @@ let rec traverse current ctx accu t = | Construct (((mind, _), _) as cst, _) -> traverse_inductive accu mind (ConstructRef cst) | Meta _ | Evar _ -> assert false -| Case (_,oty,c,[||]) -> +| Case (_,oty,_,c,[||]) -> (* non dependent match on an inductive with no constructors *) begin match Constr.(kind oty, kind c) with | Lambda(_,_,oty), Const (kn, _) @@ -306,6 +306,13 @@ let traverse current t = considering terms out of any valid environment, so use with caution. *) let type_of_constant cb = cb.Declarations.const_type +let uses_uip mib = + Array.exists (fun mip -> + mip.mind_relevance == Sorts.Irrelevant + && Array.length mip.mind_nf_lc = 1 + && List.length (fst mip.mind_nf_lc.(0)) = List.length mib.mind_params_ctxt) + mib.mind_packets + let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = (* Only keep the transitive dependencies *) let (_, graph, ax2ty) = traverse (label_of gr) t in @@ -363,5 +370,11 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in ContextObjectMap.add (Axiom (TypeInType obj, l)) Constr.mkProp accu in + let accu = + if not (uses_uip mind) then accu + else + let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (UIP m, l)) Constr.mkProp accu + in accu in GlobRef.Map_env.fold fold graph ContextObjectMap.empty diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index bb640a83f6..f47cdd8bf0 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -155,7 +155,7 @@ let build_beq_scheme_deps kn = | None -> accu) | Rel _ | Var _ | Sort _ | Prod _ | Lambda _ | LetIn _ | Proj _ | Construct _ | Case _ | CoFix _ | Fix _ | Meta _ | Evar _ | Int _ - | Float _ -> accu + | Float _ | Array _ -> accu in let u = Univ.Instance.empty in let constrs n = get_constructors env (make_ind_family (((kn, i), u), @@ -293,6 +293,7 @@ let build_beq_scheme mode kn = | Evar _ -> raise (EqUnknown "existential variable") | Int _ -> raise (EqUnknown "int") | Float _ -> raise (EqUnknown "float") + | Array _ -> raise (EqUnknown "array") in aux t in @@ -350,13 +351,13 @@ let build_beq_scheme mode kn = done; ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) - (mkCase (ci,do_predicate rel_list nb_cstr_args, + (mkCase (ci,do_predicate rel_list nb_cstr_args,NoInvert, mkVar (Id.of_string "Y") ,ar2)) (constrsi.(i).cs_args)) done; mkNamedLambda (make_annot (Id.of_string "X") Sorts.Relevant) (mkFullInd ind (nb_ind-1+1)) ( mkNamedLambda (make_annot (Id.of_string "Y") Sorts.Relevant) (mkFullInd ind (nb_ind-1+2)) ( - mkCase (ci, do_predicate rel_list 0,mkVar (Id.of_string "X"),ar))) + mkCase (ci, do_predicate rel_list 0,NoInvert,mkVar (Id.of_string "X"),ar))) in (* build_beq_scheme *) let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and types = Array.make nb_ind mkSet and diff --git a/vernac/classes.ml b/vernac/classes.ml index ba08aa2b94..f454c389dc 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -334,7 +334,7 @@ let do_declare_instance sigma ~global ~poly k u ctx ctx' pri udecl impargs subst Impargs.maybe_declare_manual_implicits false cst impargs; instance_hook pri global cst -let declare_instance_program env sigma ~global ~poly name pri impargs udecl term termtype = +let declare_instance_program pm env sigma ~global ~poly name pri impargs udecl term termtype = let hook { Declare.Hook.S.scope; dref; _ } = let cst = match dref with GlobRef.ConstRef kn -> kn | _ -> assert false in let pri = intern_info pri in @@ -349,9 +349,9 @@ let declare_instance_program env sigma ~global ~poly name pri impargs udecl term Decls.IsDefinition Decls.Instance in let cinfo = Declare.CInfo.make ~name ~typ ~impargs () in let info = Declare.Info.make ~udecl ~scope ~poly ~kind ~hook () in - let _ : Declare.Obls.progress = - Declare.Obls.add_definition ~cinfo ~info ~term ~uctx obls - in () + let pm, _ = + Declare.Obls.add_definition ~pm ~cinfo ~info ~term ~uctx obls + in pm let declare_instance_open sigma ?hook ~tac ~global ~poly id pri impargs udecl ids term termtype = (* spiwack: it is hard to reorder the actions to do @@ -493,7 +493,7 @@ let do_instance env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imp Pretyping.check_evars_are_solved ~program_mode:false env sigma; declare_instance_constant pri global imps ?hook id decl poly sigma term termtype -let do_instance_program env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imps subst id opt_props = +let do_instance_program ~pm env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imps subst id opt_props = let term, termtype, sigma = match opt_props with | Some props -> @@ -506,9 +506,10 @@ let do_instance_program env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri term, termtype, sigma in let termtype, sigma = do_instance_resolve_TC termtype sigma env in if not (Evd.has_undefined sigma) && not (Option.is_empty opt_props) then - declare_instance_constant pri global imps ?hook id decl poly sigma term termtype + let () = declare_instance_constant pri global imps ?hook id decl poly sigma term termtype in + pm else - declare_instance_program env sigma ~global ~poly id pri imps decl term termtype + declare_instance_program pm env sigma ~global ~poly id pri imps decl term termtype let interp_instance_context ~program_mode env ctx ~generalize pl tclass = let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in @@ -564,15 +565,16 @@ let new_instance_interactive ?(global=false) id, do_instance_interactive env env' sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id opt_props -let new_instance_program ?(global=false) +let new_instance_program ?(global=false) ~pm ~poly instid ctx cl opt_props ?(generalize=true) ?hook pri = let env = Global.env() in let id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl = new_instance_common ~program_mode:true ~generalize env instid ctx cl in - do_instance_program env env' sigma ?hook ~global ~poly - cty k u ctx ctx' pri decl imps subst id opt_props; - id + let pm = + do_instance_program ~pm env env' sigma ?hook ~global ~poly + cty k u ctx ctx' pri decl imps subst id opt_props in + pm, id let new_instance ?(global=false) ~poly instid ctx cl props diff --git a/vernac/classes.mli b/vernac/classes.mli index 07695b5bef..e1816fb138 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -52,6 +52,7 @@ val new_instance val new_instance_program : ?global:bool (** Not global by default. *) + -> pm:Declare.OblState.t -> poly:bool -> name_decl -> local_binder_expr list @@ -60,7 +61,7 @@ val new_instance_program -> ?generalize:bool -> ?hook:(GlobRef.t -> unit) -> Vernacexpr.hint_info_expr - -> Id.t + -> Declare.OblState.t * Id.t val declare_new_instance : ?global:bool (** Not global by default. *) diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index d8475126ca..401ba0fba4 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -268,11 +268,14 @@ let context ~poly l = in let b = Option.map (EConstr.to_constr sigma) b in let t = EConstr.to_constr sigma t in - let test x = match x.CAst.v with - | Some (Name id',_) -> Id.equal name id' - | _ -> false + let impl = let open Glob_term in + let search x = match x.CAst.v with + | Some (Name id',max) when Id.equal name id' -> + Some (if max then MaxImplicit else NonMaxImplicit) + | _ -> None + in + try CList.find_map search impls with Not_found -> Explicit in - let impl = Glob_term.(if List.exists test impls then MaxImplicit else Explicit) in (* ??? *) name,b,t,impl) ctx in diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index f9b2d8b1d1..37b7106856 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -29,14 +29,17 @@ let warn_implicits_in_term = let check_imps ~impsty ~impsbody = let rec aux impsty impsbody = - match impsty, impsbody with - | a1 :: impsty, a2 :: impsbody -> - (match a1.CAst.v, a2.CAst.v with - | None , None -> aux impsty impsbody - | Some _ , Some _ -> aux impsty impsbody - | _, _ -> warn_implicits_in_term ?loc:a2.CAst.loc ()) - | _ :: _, [] | [], _ :: _ -> (* Information only on one side *) () - | [], [] -> () in + match impsty, impsbody with + | a1 :: impsty, a2 :: impsbody -> + let () = match a1.CAst.v, a2.CAst.v with + | None , None | Some _, None -> () + | Some (_,b1) , Some (_,b2) -> + if not ((b1:bool) = b2) then warn_implicits_in_term ?loc:a2.CAst.loc () + | None, Some _ -> warn_implicits_in_term ?loc:a2.CAst.loc () + in + aux impsty impsbody + | _ :: _, [] | [], _ :: _ -> (* Information only on one side *) () + | [], [] -> () in aux impsty impsbody let protect_pattern_in_binder bl c ctypopt = @@ -66,9 +69,9 @@ let protect_pattern_in_binder bl c ctypopt = | LetIn (x,b,t,c) -> let evd,c = aux (push_rel (LocalDef (x,b,t)) env) evd c in evd, mkLetIn (x,t,b,c) - | Case (ci,p,a,bl) -> + | Case (ci,p,iv,a,bl) -> let evd,bl = Array.fold_left_map (aux env) evd bl in - evd, mkCase (ci,p,a,bl) + evd, mkCase (ci,p,iv,a,bl) | Cast (c,_,_) -> f env evd c (* we remove the cast we had set *) (* This last case may happen when reaching the proof of an impossible case, as when pattern-matching on a vector of length 1 *) @@ -122,14 +125,14 @@ let do_definition ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = Declare.declare_definition ~info ~cinfo ~opaque:false ~body evd in () -let do_definition_program ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = +let do_definition_program ?hook ~pm ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = let program_mode = true in let (body, types), evd, udecl, impargs = interp_definition ~program_mode udecl bl ~poly red_option c ctypopt in let term, typ, uctx, obls = Declare.Obls.prepare_obligation ~name ~body ~types evd in - let _ : Declare.Obls.progress = + let pm, _ = let cinfo = Declare.CInfo.make ~name ~typ ~impargs () in let info = Declare.Info.make ~udecl ~scope ~poly ~kind ?hook () in - Declare.Obls.add_definition ~cinfo ~info ~term ~uctx obls - in () + Declare.Obls.add_definition ~pm ~cinfo ~info ~term ~uctx obls + in pm diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index e3417d0062..d95e64a85f 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -29,6 +29,7 @@ val do_definition val do_definition_program : ?hook:Declare.Hook.t + -> pm:Declare.OblState.t -> name:Id.t -> scope:Locality.locality -> poly:bool @@ -38,4 +39,4 @@ val do_definition_program -> red_expr option -> constr_expr -> constr_expr option - -> unit + -> Declare.OblState.t diff --git a/vernac/comPrimitive.ml b/vernac/comPrimitive.ml index bcfbc049fa..110dcdc98a 100644 --- a/vernac/comPrimitive.ml +++ b/vernac/comPrimitive.ml @@ -8,30 +8,45 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -let do_primitive id prim typopt = +open Names + +let declare id entry = + let _ : Constant.t = + Declare.declare_constant ~name:id ~kind:Decls.IsPrimitive (Declare.PrimitiveEntry entry) + in + Flags.if_verbose Feedback.msg_info Pp.(Id.print id ++ str " is declared") + +let do_primitive id udecl prim typopt = if Global.sections_are_opened () then CErrors.user_err Pp.(str "Declaring a primitive is not allowed in sections."); if Dumpglob.dump () then Dumpglob.dump_definition id false "ax"; - let env = Global.env () in - let evd = Evd.from_env env in - let evd, typopt = Option.fold_left_map - Constrintern.(interp_type_evars_impls ~impls:empty_internalization_env env) - evd typopt - in - let evd = Evd.minimize_universes evd in - let uvars, impls, typopt = match typopt with - | None -> Univ.LSet.empty, [], None - | Some (ty,impls) -> - EConstr.universes_of_constr evd ty, impls, Some (EConstr.to_constr evd ty) - in - let evd = Evd.restrict_universe_context evd uvars in - let uctx = UState.check_mono_univ_decl (Evd.evar_universe_context evd) UState.default_univ_decl in - let entry = Entries.{ - prim_entry_type = typopt; - prim_entry_univs = uctx; + let loc = id.CAst.loc in + let id = id.CAst.v in + match typopt with + | None -> + if Option.has_some udecl then + CErrors.user_err ?loc + Pp.(strbrk "Cannot use a universe declaration without a type when declaring primitives."); + declare id {Entries.prim_entry_type = None; prim_entry_content = prim} + | Some typ -> + let env = Global.env () in + let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env udecl in + let auctx = CPrimitives.op_or_type_univs prim in + let evd, u = Evd.with_context_set UState.univ_flexible evd (UnivGen.fresh_instance auctx) in + let expected_typ = EConstr.of_constr @@ Typeops.type_of_prim_or_type env u prim in + let evd, (typ,impls) = + Constrintern.(interp_type_evars_impls ~impls:empty_internalization_env) + env evd typ + in + let evd = Evarconv.unify_delay env evd typ expected_typ in + let evd = Evd.minimize_universes evd in + let uvars = EConstr.universes_of_constr evd typ in + let evd = Evd.restrict_universe_context evd uvars in + let typ = EConstr.to_constr evd typ in + let univs = Evd.check_univ_decl ~poly:(not (Univ.AUContext.is_empty auctx)) evd udecl in + let entry = { + Entries.prim_entry_type = Some (typ,univs); prim_entry_content = prim; } - in - let _kn : Names.Constant.t = - Declare.declare_constant ~name:id.CAst.v ~kind:Decls.IsPrimitive (Declare.PrimitiveEntry entry) in - Flags.if_verbose Feedback.msg_info Pp.(Names.Id.print id.CAst.v ++ str " is declared") + in + declare id entry diff --git a/vernac/comPrimitive.mli b/vernac/comPrimitive.mli index 588eb7fdea..4d468f97b1 100644 --- a/vernac/comPrimitive.mli +++ b/vernac/comPrimitive.mli @@ -8,4 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val do_primitive : Names.lident -> CPrimitives.op_or_type -> Constrexpr.constr_expr option -> unit +val do_primitive + : Names.lident + -> Constrexpr.universe_decl_expr option + -> CPrimitives.op_or_type + -> Constrexpr.constr_expr option + -> unit diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 37615fa09c..55901fd604 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -109,7 +109,7 @@ let telescope env sigma l = let nf_evar_context sigma ctx = List.map (map_constr (fun c -> Evarutil.nf_evar sigma c)) ctx -let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = +let build_wellfounded pm (recname,pl,bl,arityc,body) poly r measure notation = let open EConstr in let open Vars in let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in @@ -262,9 +262,9 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let uctx = Evd.evar_universe_context sigma in let cinfo = Declare.CInfo.make ~name:recname ~typ:evars_typ () in let info = Declare.Info.make ~udecl ~poly ~hook () in - let _ : Declare.Obls.progress = - Declare.Obls.add_definition ~cinfo ~info ~term:evars_def ~uctx evars in - () + let pm, _ = + Declare.Obls.add_definition ~pm ~cinfo ~info ~term:evars_def ~uctx evars in + pm let out_def = function | Some def -> def @@ -275,7 +275,7 @@ let collect_evars_of_term evd c ty = Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) evars (Evd.from_ctx (Evd.evar_universe_context evd)) -let do_program_recursive ~scope ~poly fixkind fixl = +let do_program_recursive ~pm ~scope ~poly fixkind fixl = let cofix = fixkind = Declare.Obls.IsCoFixpoint in let (env, rec_sign, udecl, evd), fix, info = interp_recursive ~cofix ~program_mode:true fixl @@ -323,15 +323,15 @@ let do_program_recursive ~scope ~poly fixkind fixl = in let ntns = List.map_append (fun { Vernacexpr.notations } -> notations ) fixl in let info = Declare.Info.make ~poly ~scope ~kind ~udecl () in - Declare.Obls.add_mutual_definitions defs ~info ~uctx ~ntns fixkind + Declare.Obls.add_mutual_definitions ~pm defs ~info ~uctx ~ntns fixkind -let do_fixpoint ~scope ~poly l = +let do_fixpoint ~pm ~scope ~poly l = let g = List.map (fun { Vernacexpr.rec_order } -> rec_order) l in match g, l with | [Some { CAst.v = CWfRec (n,r) }], [ Vernacexpr.{fname={CAst.v=id}; univs; binders; rtype; body_def; notations} ] -> let recarg = mkIdentC n.CAst.v in - build_wellfounded (id, univs, binders, rtype, out_def body_def) poly r recarg notations + build_wellfounded pm (id, univs, binders, rtype, out_def body_def) poly r recarg notations | [Some { CAst.v = CMeasureRec (n, m, r) }], [Vernacexpr.{fname={CAst.v=id}; univs; binders; rtype; body_def; notations }] -> @@ -344,7 +344,7 @@ let do_fixpoint ~scope ~poly l = user_err Pp.(str"Measure takes only two arguments in Program Fixpoint.") | _, _ -> r in - build_wellfounded (id, univs, binders, rtype, out_def body_def) poly + build_wellfounded pm (id, univs, binders, rtype, out_def body_def) poly (Option.default (CAst.make @@ CRef (lt_ref,None)) r) m notations | _, _ when List.for_all (fun ro -> match ro with None | Some { CAst.v = CStructRec _} -> true | _ -> false) g -> @@ -352,12 +352,11 @@ let do_fixpoint ~scope ~poly l = Vernacexpr.(ComFixpoint.adjust_rec_order ~structonly:true fix.binders fix.rec_order)) l in let fixkind = Declare.Obls.IsFixpoint annots in let l = List.map2 (fun fix rec_order -> { fix with Vernacexpr.rec_order }) l annots in - do_program_recursive ~scope ~poly fixkind l - + do_program_recursive ~pm ~scope ~poly fixkind l | _, _ -> - user_err ~hdr:"do_fixpoint" - (str "Well-founded fixpoints not allowed in mutually recursive blocks") + CErrors.user_err ~hdr:"do_fixpoint" + (str "Well-founded fixpoints not allowed in mutually recursive blocks") -let do_cofixpoint ~scope ~poly fixl = +let do_cofixpoint ~pm ~scope ~poly fixl = let fixl = List.map (fun fix -> { fix with Vernacexpr.rec_order = None }) fixl in - do_program_recursive ~scope ~poly Declare.Obls.IsCoFixpoint fixl + do_program_recursive ~pm ~scope ~poly Declare.Obls.IsCoFixpoint fixl diff --git a/vernac/comProgramFixpoint.mli b/vernac/comProgramFixpoint.mli index e39f62c348..7935cf27fb 100644 --- a/vernac/comProgramFixpoint.mli +++ b/vernac/comProgramFixpoint.mli @@ -11,11 +11,16 @@ open Vernacexpr (** Special Fixpoint handling when command is activated. *) - val do_fixpoint : - (* When [false], assume guarded. *) - scope:Locality.locality -> poly:bool -> fixpoint_expr list -> unit + pm:Declare.OblState.t + -> scope:Locality.locality + -> poly:bool + -> fixpoint_expr list + -> Declare.OblState.t val do_cofixpoint : - (* When [false], assume guarded. *) - scope:Locality.locality -> poly:bool -> cofixpoint_expr list -> unit + pm:Declare.OblState.t + -> scope:Locality.locality + -> poly:bool + -> cofixpoint_expr list + -> Declare.OblState.t diff --git a/vernac/declare.ml b/vernac/declare.ml index 85359d5b62..df75e121d8 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -33,11 +33,14 @@ module Hook = struct } end - type t = (S.t -> unit) CEphemeron.key + type 'a g = (S.t -> 'a -> 'a) CEphemeron.key + type t = unit g - let make hook = CEphemeron.create hook + let make_g hook = CEphemeron.create hook + let make (hook : S.t -> unit) : t = CEphemeron.create (fun x () -> hook x) - let call ?hook x = Option.iter (fun hook -> CEphemeron.get hook x) hook + let call_g ?hook x s = Option.cata (fun hook -> CEphemeron.get hook x s) s hook + let call ?hook x = Option.iter (fun hook -> CEphemeron.get hook x ()) hook end @@ -653,9 +656,10 @@ let declare_definition_core ~info ~cinfo ~opaque ~obls ~body sigma = let { CInfo.name; impargs; typ; _ } = cinfo in let entry, uctx = prepare_definition ~info ~opaque ~body ~typ sigma in let { Info.scope; kind; hook; _ } = info in - declare_entry_core ~name ~scope ~kind ~impargs ~obls ?hook ~uctx entry + declare_entry_core ~name ~scope ~kind ~impargs ~obls ?hook ~uctx entry, uctx -let declare_definition = declare_definition_core ~obls:[] +let declare_definition ~info ~cinfo ~opaque ~body sigma = + declare_definition_core ~obls:[] ~info ~cinfo ~opaque ~body sigma |> fst let prepare_obligation ~name ~types ~body sigma = let env = Global.env () in @@ -683,14 +687,6 @@ let prepare_parameter ~poly ~udecl ~types sigma = type progress = Remain of int | Dependent | Defined of GlobRef.t -type obligation_resolver = - Id.t option - -> Int.Set.t - -> unit Proofview.tactic option - -> progress - -type obligation_qed_info = {name : Id.t; num : int; auto : obligation_resolver} - module Obls_ = struct open Constr @@ -716,10 +712,11 @@ type fixpoint_kind = IsFixpoint of lident option list | IsCoFixpoint module ProgramDecl = struct - type t = + type 'a t = { prg_cinfo : constr CInfo.t ; prg_info : Info.t ; prg_opaque : bool + ; prg_hook : 'a Hook.g option ; prg_body : constr ; prg_uctx : UState.t ; prg_obligations : obligations @@ -731,7 +728,7 @@ module ProgramDecl = struct open Obligation - let make ~info ~cinfo ~opaque ~ntns ~reduce ~deps ~uctx ~body ~fixpoint_kind obls = + let make ~info ~cinfo ~opaque ~ntns ~reduce ~deps ~uctx ~body ~fixpoint_kind ?obl_hook obls = let obls', body = match body with | None -> @@ -761,6 +758,7 @@ module ProgramDecl = struct let prg_uctx = UState.make_flexible_nonalgebraic uctx in { prg_cinfo = { cinfo with CInfo.typ = reduce cinfo.CInfo.typ } ; prg_info = info + ; prg_hook = obl_hook ; prg_opaque = opaque ; prg_body = body ; prg_uctx @@ -923,11 +921,11 @@ let err_not_transp () = module ProgMap = Id.Map -module StateFunctional = struct +module State = struct - type t = ProgramDecl.t CEphemeron.key ProgMap.t + type t = t ProgramDecl.t CEphemeron.key ProgMap.t - let _empty = ProgMap.empty + let empty = ProgMap.empty let pending pm = ProgMap.filter @@ -965,30 +963,12 @@ module StateFunctional = struct let find m t = ProgMap.find_opt t m |> Option.map CEphemeron.get end -module State = struct - - type t = StateFunctional.t - - open StateFunctional - - let prg_ref, prg_tag = - Summary.ref_tag ProgMap.empty ~name:"program-tcc-table" - - let first_pending () = first_pending !prg_ref - let get_unique_open_prog id = get_unique_open_prog !prg_ref id - let add id prg = prg_ref := add !prg_ref id prg - let fold ~f ~init = fold !prg_ref ~f ~init - let all () = all !prg_ref - let find id = find !prg_ref id - -end - (* In all cases, the use of the map is read-only so we don't expose the ref *) let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] -let check_solved_obligations ~what_for : unit = - if not (ProgMap.is_empty !State.prg_ref) then - let keys = map_keys !State.prg_ref in +let check_solved_obligations ~pm ~what_for : unit = + if not (ProgMap.is_empty pm) then + let keys = map_keys pm in let have_string = if Int.equal (List.length keys) 1 then " has " else " have " in CErrors.user_err ~hdr:"Program" Pp.( @@ -1084,7 +1064,7 @@ let subst_prog subst prg = ( Vars.replace_vars subst' prg.prg_body , Vars.replace_vars subst' (* Termops.refresh_universes *) prg.prg_cinfo.CInfo.typ ) -let declare_definition prg = +let declare_definition ~pm prg = let varsubst = obligation_substitution true prg in let sigma = Evd.from_ctx prg.prg_uctx in let body, types = subst_prog varsubst prg in @@ -1093,10 +1073,13 @@ let declare_definition prg = let name, info, opaque = prg.prg_cinfo.CInfo.name, prg.prg_info, prg.prg_opaque in let obls = List.map (fun (id, (_, c)) -> (id, c)) varsubst in (* XXX: This is doing normalization twice *) - let kn = declare_definition_core ~cinfo ~info ~obls ~body ~opaque sigma in - let pm = progmap_remove !State.prg_ref prg in - State.prg_ref := pm; - kn + let kn, uctx = declare_definition_core ~cinfo ~info ~obls ~body ~opaque sigma in + (* XXX: We call the obligation hook here, by consistency with the + previous imperative behaviour, however I'm not sure this is right *) + let pm = Hook.call_g ?hook:prg.prg_hook + { Hook.S.uctx; obls; scope = prg.prg_info.Info.scope; dref = kn} pm in + let pm = progmap_remove pm prg in + pm, kn let rec lam_index n t acc = match Constr.kind t with @@ -1117,7 +1100,7 @@ let compute_possible_guardness_evidences n fixbody fixtype = let ctx = fst (Term.decompose_prod_n_assum m fixtype) in List.map_i (fun i _ -> i) 0 ctx -let declare_mutual_definition l = +let declare_mutual_definition ~pm l = let len = List.length l in let first = List.hd l in let defobl x = @@ -1181,34 +1164,33 @@ let declare_mutual_definition l = in (* Only for the first constant *) let dref = List.hd kns in - Hook.( - call ?hook:first.prg_info.Info.hook {S.uctx = first.prg_uctx; obls; scope; dref}); - let pm = List.fold_left progmap_remove !State.prg_ref l in - State.prg_ref := pm; - dref - -let update_obls prg obls rem = + let s_hook = {Hook.S.uctx = first.prg_uctx; obls; scope; dref} in + Hook.call ?hook:first.prg_info.Info.hook s_hook; + (* XXX: We call the obligation hook here, by consistency with the + previous imperative behaviour, however I'm not sure this is right *) + let pm = Hook.call_g ?hook:first.prg_hook s_hook pm in + let pm = List.fold_left progmap_remove pm l in + pm, dref + +let update_obls ~pm prg obls rem = let prg_obligations = {obls; remaining = rem} in let prg' = {prg with prg_obligations} in - let pm = progmap_replace prg' !State.prg_ref in - State.prg_ref := pm; + let pm = progmap_replace prg' pm in obligations_message rem; - if rem > 0 then Remain rem + if rem > 0 then pm, Remain rem else match prg'.prg_deps with | [] -> - let kn = declare_definition prg' in - let pm = progmap_remove !State.prg_ref prg' in - State.prg_ref := pm; - Defined kn + let pm, kn = declare_definition ~pm prg' in + pm, Defined kn | l -> let progs = List.map (fun x -> CEphemeron.get (ProgMap.find x pm)) prg'.prg_deps in if List.for_all (fun x -> obligations_solved x) progs then - let kn = declare_mutual_definition progs in - Defined kn - else Dependent + let pm, kn = declare_mutual_definition ~pm progs in + pm, Defined kn + else pm, Dependent let dependencies obls n = let res = ref Int.Set.empty in @@ -1219,23 +1201,32 @@ let dependencies obls n = obls; !res -let update_program_decl_on_defined prg obls num obl ~uctx rem ~auto = +let update_program_decl_on_defined ~pm prg obls num obl ~uctx rem ~auto = let obls = Array.copy obls in let () = obls.(num) <- obl in let prg = {prg with prg_uctx = uctx} in - let _progress = update_obls prg obls (pred rem) in - let () = + let pm, _progress = update_obls ~pm prg obls (pred rem) in + let pm = if pred rem > 0 then let deps = dependencies obls num in if not (Int.Set.is_empty deps) then - let _progress = auto (Some prg.prg_cinfo.CInfo.name) deps None in - () - else () - else () + let pm, _progress = auto ~pm (Some prg.prg_cinfo.CInfo.name) deps None in + pm + else pm + else pm in - () + pm + +type obligation_resolver = + pm:State.t + -> Id.t option + -> Int.Set.t + -> unit Proofview.tactic option + -> State.t * progress + +type obligation_qed_info = {name : Id.t; num : int; auto : obligation_resolver} -let obligation_terminator ~entry ~uctx ~oinfo:{name; num; auto} = +let obligation_terminator ~pm ~entry ~uctx ~oinfo:{name; num; auto} = let env = Global.env () in let ty = entry.proof_entry_type in let body, uctx = inline_private_constants ~uctx env entry in @@ -1243,7 +1234,7 @@ let obligation_terminator ~entry ~uctx ~oinfo:{name; num; auto} = Inductiveops.control_only_guard (Global.env ()) sigma (EConstr.of_constr body); (* Declare the obligation ourselves and drop the hook *) - let prg = Option.get (State.find name) in + let prg = Option.get (State.find pm name) in let {obls; remaining = rem} = prg.prg_obligations in let obl = obls.(num) in let status = @@ -1274,16 +1265,17 @@ let obligation_terminator ~entry ~uctx ~oinfo:{name; num; auto} = UState.from_env (Global.env ()) else uctx in - update_program_decl_on_defined prg obls num obl ~uctx:prg_ctx rem ~auto; - cst + let pm = + update_program_decl_on_defined ~pm prg obls num obl ~uctx:prg_ctx rem ~auto in + pm, cst (* Similar to the terminator but for the admitted path; this assumes the admitted constant was already declared. FIXME: There is duplication of this code with obligation_terminator and Obligations.admit_obligations *) -let obligation_admitted_terminator {name; num; auto} ctx' dref = - let prg = Option.get (State.find name) in +let obligation_admitted_terminator ~pm {name; num; auto} ctx' dref = + let prg = Option.get (State.find pm name) in let {obls; remaining = rem} = prg.prg_obligations in let obl = obls.(num) in let cst = match dref with GlobRef.ConstRef cst -> cst | _ -> assert false in @@ -1308,7 +1300,7 @@ let obligation_admitted_terminator {name; num; auto} ctx' dref = in let obl = {obl with obl_body = Some (DefinedObl (cst, inst))} in let () = if transparent then add_hint true prg cst in - update_program_decl_on_defined prg obls num obl ~uctx:ctx' rem ~auto + update_program_decl_on_defined ~pm prg obls num obl ~uctx:ctx' rem ~auto end @@ -1322,10 +1314,10 @@ module Proof_ending = struct type t = | Regular - | End_obligation of obligation_qed_info + | End_obligation of Obls_.obligation_qed_info | End_derive of { f : Id.t; name : Id.t } | End_equations of - { hook : Constant.t list -> Evd.evar_map -> unit + { hook : pm:Obls_.State.t -> Constant.t list -> Evd.evar_map -> Obls_.State.t ; i : Id.t ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list ; sigma : Evd.evar_map @@ -1951,15 +1943,15 @@ let compute_proof_using_for_admitted proof typ pproofs = Some (Environ.really_needed env (Id.Set.union ids_typ ids_def)) | _ -> None -let finish_admitted ~pinfo ~uctx pe = +let finish_admitted ~pm ~pinfo ~uctx pe = let cst = MutualEntry.declare_variable ~pinfo ~uctx pe in (* If the constant was an obligation we need to update the program map *) match CEphemeron.get pinfo.Proof_info.proof_ending with | Proof_ending.End_obligation oinfo -> - Obls_.obligation_admitted_terminator oinfo uctx (List.hd cst) - | _ -> () + Obls_.obligation_admitted_terminator ~pm oinfo uctx (List.hd cst) + | _ -> pm -let save_admitted ~proof = +let save_admitted ~pm ~proof = let udecl = get_universe_decl proof in let Proof.{ poly; entry } = Proof.data (get proof) in let typ = match Proofview.initial_goals entry with @@ -1972,7 +1964,7 @@ let save_admitted ~proof = let sec_vars = compute_proof_using_for_admitted proof typ pproofs in let uctx = get_initial_euctx proof in let univs = UState.check_univ_decl ~poly uctx udecl in - finish_admitted ~pinfo:proof.pinfo ~uctx (sec_vars, (typ, univs), None) + finish_admitted ~pm ~pinfo:proof.pinfo ~uctx (sec_vars, (typ, univs), None) (************************************************************************) (* Saving a lemma-like constant *) @@ -2013,7 +2005,7 @@ let finish_derived ~f ~name ~entries = let ct = declare_constant ~name ~kind:Decls.(IsProof Proposition) lemma_def in [GlobRef.ConstRef ct] -let finish_proved_equations ~kind ~hook i proof_obj types sigma0 = +let finish_proved_equations ~pm ~kind ~hook i proof_obj types sigma0 = let obls = ref 1 in let sigma, recobls = @@ -2030,8 +2022,8 @@ let finish_proved_equations ~kind ~hook i proof_obj types sigma0 = sigma, cst) sigma0 types proof_obj.entries in - hook recobls sigma; - List.map (fun cst -> GlobRef.ConstRef cst) recobls + let pm = hook ~pm recobls sigma in + pm, List.map (fun cst -> GlobRef.ConstRef cst) recobls let check_single_entry { entries; uctx } label = match entries with @@ -2039,20 +2031,20 @@ let check_single_entry { entries; uctx } label = | _ -> CErrors.anomaly ~label Pp.(str "close_proof returned more than one proof term") -let finalize_proof proof_obj proof_info = +let finalize_proof ~pm proof_obj proof_info = let open Proof_ending in match CEphemeron.default proof_info.Proof_info.proof_ending Regular with | Regular -> let entry, uctx = check_single_entry proof_obj "Proof.save" in - MutualEntry.declare_mutdef ~entry ~uctx ~pinfo:proof_info + pm, MutualEntry.declare_mutdef ~entry ~uctx ~pinfo:proof_info | End_obligation oinfo -> let entry, uctx = check_single_entry proof_obj "Obligation.save" in - Obls_.obligation_terminator ~entry ~uctx ~oinfo + Obls_.obligation_terminator ~pm ~entry ~uctx ~oinfo | End_derive { f ; name } -> - finish_derived ~f ~name ~entries:proof_obj.entries + pm, finish_derived ~f ~name ~entries:proof_obj.entries | End_equations { hook; i; types; sigma } -> let kind = proof_info.Proof_info.info.Info.kind in - finish_proved_equations ~kind ~hook i proof_obj types sigma + finish_proved_equations ~pm ~kind ~hook i proof_obj types sigma let err_save_forbidden_in_place_of_qed () = CErrors.user_err (Pp.str "Cannot use Save with more than one constant or in this proof mode") @@ -2070,16 +2062,24 @@ let process_idopt_for_save ~idopt info = err_save_forbidden_in_place_of_qed () in { info with Proof_info.cinfo } -let save ~proof ~opaque ~idopt = +let save ~pm ~proof ~opaque ~idopt = (* Env and sigma are just used for error printing in save_remaining_recthms *) let proof_obj = close_proof ~opaque ~keep_body_ucst_separate:false proof in let proof_info = process_idopt_for_save ~idopt proof.pinfo in - finalize_proof proof_obj proof_info + finalize_proof ~pm proof_obj proof_info + +let save_regular ~proof ~opaque ~idopt = + let open Proof_ending in + match CEphemeron.default proof.pinfo.Proof_info.proof_ending Regular with + | Regular -> + let (_, grs) : Obls_.State.t * _ = save ~pm:Obls_.State.empty ~proof ~opaque ~idopt in + grs + | _ -> CErrors.anomaly Pp.(str "save_regular: unexpected proof ending") (***********************************************************************) (* Special case to close a lemma without forcing a proof *) (***********************************************************************) -let save_lemma_admitted_delayed ~proof ~pinfo = +let save_lemma_admitted_delayed ~pm ~proof ~pinfo = let { entries; uctx } = proof in if List.length entries <> 1 then CErrors.user_err Pp.(str "Admitted does not support multiple statements"); @@ -2092,18 +2092,18 @@ let save_lemma_admitted_delayed ~proof ~pinfo = | Some typ -> typ in let ctx = UState.univ_entry ~poly uctx in let sec_vars = if get_keep_admitted_vars () then proof_entry_secctx else None in - finish_admitted ~uctx ~pinfo (sec_vars, (typ, ctx), None) + finish_admitted ~pm ~uctx ~pinfo (sec_vars, (typ, ctx), None) -let save_lemma_proved_delayed ~proof ~pinfo ~idopt = +let save_lemma_proved_delayed ~pm ~proof ~pinfo ~idopt = (* vio2vo calls this but with invalid info, we have to workaround that to add the name to the info structure *) if CList.is_empty pinfo.Proof_info.cinfo then let name = get_po_name proof in let info = Proof_info.add_first_thm ~pinfo ~name ~typ:EConstr.mkSet ~impargs:[] in - finalize_proof proof info + finalize_proof ~pm proof info else let info = process_idopt_for_save ~idopt pinfo in - finalize_proof proof info + finalize_proof ~pm proof info end (* Proof module *) @@ -2217,8 +2217,8 @@ let solve_by_tac ?loc name evi t ~poly ~uctx = warn_solve_errored ?loc err; None -let get_unique_prog prg = - match State.get_unique_open_prog prg with +let get_unique_prog ~pm prg = + match State.get_unique_open_prog pm prg with | Ok prg -> prg | Error [] -> Error.no_obligations None @@ -2241,7 +2241,7 @@ let rec solve_obligation prg num tac = let kind = kind_of_obligation (snd obl.obl_status) in let evd = Evd.from_ctx (Internal.get_uctx prg) in let evd = Evd.update_sigma_env evd (Global.env ()) in - let auto n oblset tac = auto_solve_obligations n ~oblset tac in + let auto ~pm n oblset tac = auto_solve_obligations ~pm n ~oblset tac in let proof_ending = let name = Internal.get_name prg in Proof_ending.End_obligation {name; num; auto} @@ -2254,9 +2254,9 @@ let rec solve_obligation prg num tac = let lemma = Option.cata (fun tac -> Proof.set_endline_tactic tac lemma) lemma tac in lemma -and obligation (user_num, name, typ) tac = +and obligation (user_num, name, typ) ~pm tac = let num = pred user_num in - let prg = get_unique_prog name in + let prg = get_unique_prog ~pm name in let { obls; remaining } = Internal.get_obligations prg in if num >= 0 && num < Array.length obls then let obl = obls.(num) in @@ -2297,7 +2297,7 @@ and solve_obligation_by_tac prg obls i tac = else Some prg else None -and solve_prg_obligations prg ?oblset tac = +and solve_prg_obligations ~pm prg ?oblset tac = let { obls; remaining } = Internal.get_obligations prg in let rem = ref remaining in let obls' = Array.copy obls in @@ -2307,49 +2307,48 @@ and solve_prg_obligations prg ?oblset tac = | Some s -> set := s; (fun i -> Int.Set.mem i !set) in - let (), prg = + let prg = Array.fold_left_i - (fun i ((), prg) x -> + (fun i prg x -> if p i then ( match solve_obligation_by_tac prg obls' i tac with - | None -> (), prg + | None -> prg | Some prg -> let deps = dependencies obls i in set := Int.Set.union !set deps; decr rem; - (), prg) - else (), prg) - ((), prg) obls' + prg) + else prg) + prg obls' in - update_obls prg obls' !rem + update_obls ~pm prg obls' !rem -and solve_obligations n tac = - let prg = get_unique_prog n in - solve_prg_obligations prg tac +and solve_obligations ~pm n tac = + let prg = get_unique_prog ~pm n in + solve_prg_obligations ~pm prg tac -and solve_all_obligations tac = - State.fold ~init:() ~f:(fun k v () -> - let _ = solve_prg_obligations v tac in ()) +and solve_all_obligations ~pm tac = + State.fold pm ~init:pm ~f:(fun k v pm -> + solve_prg_obligations ~pm v tac |> fst) -and try_solve_obligation n prg tac = - let prg = get_unique_prog prg in +and try_solve_obligation ~pm n prg tac = + let prg = get_unique_prog ~pm prg in let {obls; remaining} = Internal.get_obligations prg in let obls' = Array.copy obls in match solve_obligation_by_tac prg obls' n tac with | Some prg' -> - let _r = update_obls prg' obls' (pred remaining) in - () - | None -> () + let pm, _ = update_obls ~pm prg' obls' (pred remaining) in + pm + | None -> pm -and try_solve_obligations n tac = - let _ = solve_obligations n tac in - () +and try_solve_obligations ~pm n tac = + solve_obligations ~pm n tac |> fst -and auto_solve_obligations n ?oblset tac : progress = +and auto_solve_obligations ~pm n ?oblset tac : State.t * progress = Flags.if_verbose Feedback.msg_info (str "Solving obligations automatically..."); - let prg = get_unique_prog n in - solve_prg_obligations prg ?oblset tac + let prg = get_unique_prog ~pm n in + solve_prg_obligations ~pm prg ?oblset tac let show_single_obligation i n obls x = let x = subst_deps_obl obls x in @@ -2379,20 +2378,20 @@ let show_obligations_of_prg ?(msg = true) prg = | Some _ -> ()) obls -let show_obligations ?(msg = true) n = +let show_obligations ~pm ?(msg = true) n = let progs = match n with | None -> - State.all () + State.all pm | Some n -> - (match State.find n with + (match State.find pm n with | Some prg -> [prg] | None -> Error.no_obligations (Some n)) in List.iter (fun x -> show_obligations_of_prg ~msg x) progs -let show_term n = - let prg = get_unique_prog n in +let show_term ~pm n = + let prg = get_unique_prog ~pm n in ProgramDecl.show prg let msg_generating_obl name obls = @@ -2404,46 +2403,46 @@ let msg_generating_obl name obls = info ++ str ", generating " ++ int len ++ str (String.plural len " obligation")) -let add_definition ~cinfo ~info ?term ~uctx +let add_definition ~pm ~cinfo ~info ?obl_hook ?term ~uctx ?tactic ?(reduce = reduce) ?(opaque = false) obls = let prg = - ProgramDecl.make ~info ~cinfo ~body:term ~opaque ~uctx ~reduce ~ntns:[] ~deps:[] ~fixpoint_kind:None obls + ProgramDecl.make ~info ~cinfo ~body:term ~opaque ~uctx ~reduce ~ntns:[] ~deps:[] ~fixpoint_kind:None ?obl_hook obls in let name = CInfo.get_name cinfo in let {obls;_} = Internal.get_obligations prg in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose (msg_generating_obl name) obls; - let cst = Obls_.declare_definition prg in - Defined cst) + let pm, cst = Obls_.declare_definition ~pm prg in + pm, Defined cst) else let () = Flags.if_verbose (msg_generating_obl name) obls in - let () = State.add name prg in - let res = auto_solve_obligations (Some name) tactic in + let pm = State.add pm name prg in + let pm, res = auto_solve_obligations ~pm (Some name) tactic in match res with | Remain rem -> - Flags.if_verbose (show_obligations ~msg:false) (Some name); - res - | _ -> res + Flags.if_verbose (show_obligations ~pm ~msg:false) (Some name); + pm, res + | _ -> pm, res -let add_mutual_definitions l ~info ~uctx +let add_mutual_definitions l ~pm ~info ?obl_hook ~uctx ?tactic ?(reduce = reduce) ?(opaque = false) ~ntns fixkind = let deps = List.map (fun (ci,_,_) -> CInfo.get_name ci) l in let pm = List.fold_left - (fun () (cinfo, b, obls) -> + (fun pm (cinfo, b, obls) -> let prg = ProgramDecl.make ~info ~cinfo ~opaque ~body:(Some b) ~uctx ~deps - ~fixpoint_kind:(Some fixkind) ~ntns obls ~reduce + ~fixpoint_kind:(Some fixkind) ~ntns ~reduce ?obl_hook obls in - State.add (CInfo.get_name cinfo) prg) - () l + State.add pm (CInfo.get_name cinfo) prg) + pm l in let pm, _defined = List.fold_left (fun (pm, finished) x -> if finished then (pm, finished) else - let res = auto_solve_obligations (Some x) tactic in + let pm, res = auto_solve_obligations ~pm (Some x) tactic in match res with | Defined _ -> (* If one definition is turned into a constant, @@ -2454,7 +2453,7 @@ let add_mutual_definitions l ~info ~uctx in pm -let admit_prog prg = +let admit_prog ~pm prg = let {obls; remaining} = Internal.get_obligations prg in let obls = Array.copy obls in Array.iteri @@ -2471,29 +2470,29 @@ let admit_prog prg = obls.(i) <- Obligation.set_body ~body:(DefinedObl (kn, Univ.Instance.empty)) x | Some _ -> ()) obls; - Obls_.update_obls prg obls 0 + Obls_.update_obls ~pm prg obls 0 (* get_any_prog *) -let rec admit_all_obligations () = - let prg = State.first_pending () in +let rec admit_all_obligations ~pm = + let prg = State.first_pending pm in match prg with - | None -> () + | None -> pm | Some prg -> - let _prog = admit_prog prg in - admit_all_obligations () + let pm, _prog = admit_prog ~pm prg in + admit_all_obligations ~pm -let admit_obligations n = +let admit_obligations ~pm n = match n with - | None -> admit_all_obligations () + | None -> admit_all_obligations ~pm | Some _ -> - let prg = get_unique_prog n in - let _ = admit_prog prg in - () + let prg = get_unique_prog ~pm n in + let pm, _ = admit_prog ~pm prg in + pm -let next_obligation n tac = +let next_obligation ~pm n tac = let prg = match n with - | None -> State.first_pending () |> Option.get - | Some _ -> get_unique_prog n + | None -> State.first_pending pm |> Option.get + | Some _ -> get_unique_prog ~pm n in let {obls; remaining} = Internal.get_obligations prg in let is_open _ x = Option.is_empty x.obl_body && List.is_empty (deps_remaining obls x.obl_deps) in @@ -2509,7 +2508,6 @@ let check_program_libraries () = Coqlib.check_required_library ["Coq";"Program";"Tactics"] (* aliases *) -module State = Obls_.State let prepare_obligation = prepare_obligation let check_solved_obligations = Obls_.check_solved_obligations type fixpoint_kind = Obls_.fixpoint_kind = @@ -2518,3 +2516,5 @@ type nonrec progress = progress = | Remain of int | Dependent | Defined of GlobRef.t end + +module OblState = Obls_.State diff --git a/vernac/declare.mli b/vernac/declare.mli index 4891e66803..adb5bd026f 100644 --- a/vernac/declare.mli +++ b/vernac/declare.mli @@ -40,7 +40,9 @@ open Names care, as imperative effects may become not supported in the future. *) module Hook : sig - type t + type 'a g + + type t = unit g (** Hooks allow users of the API to perform arbitrary actions at proof/definition saving time. For example, to register a constant @@ -61,6 +63,7 @@ module Hook : sig } end + val make_g : (S.t -> 'a -> 'a) -> 'a g val make : (S.t -> unit) -> t val call : ?hook:t -> S.t -> unit end @@ -147,6 +150,13 @@ val declare_mutually_recursive (** {2 Declaration of interactive constants } *) +(** [save] / [save_admitted] can update obligations state, so we need + to expose the state here *) +module OblState : sig + type t + val empty : t +end + (** [Declare.Proof.t] Construction of constants using interactive proofs. *) module Proof : sig @@ -172,7 +182,7 @@ module Proof : sig val start_equations : name:Id.t -> info:Info.t - -> hook:(Constant.t list -> Evd.evar_map -> unit) + -> hook:(pm:OblState.t -> Constant.t list -> Evd.evar_map -> OblState.t) -> types:(Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list -> Evd.evar_map -> Proofview.telescope @@ -198,13 +208,21 @@ module Proof : sig (** Qed a proof *) val save + : pm:OblState.t + -> proof:t + -> opaque:Vernacexpr.opacity_flag + -> idopt:Names.lident option + -> OblState.t * GlobRef.t list + + (** For proofs known to have [Regular] ending, no need to touch program state. *) + val save_regular : proof:t -> opaque:Vernacexpr.opacity_flag -> idopt:Names.lident option -> GlobRef.t list (** Admit a proof *) - val save_admitted : proof:t -> unit + val save_admitted : pm:OblState.t -> proof:t -> OblState.t (** [by tac] applies tactic [tac] to the 1st subgoal of the current focused proof. @@ -287,15 +305,17 @@ module Proof : sig (** Special cases for delayed proofs, in this case we must provide the proof information so the proof won't be forced. *) val save_lemma_admitted_delayed : - proof:proof_object + pm:OblState.t + -> proof:proof_object -> pinfo:Proof_info.t - -> unit + -> OblState.t val save_lemma_proved_delayed - : proof:proof_object + : pm:OblState.t + -> proof:proof_object -> pinfo:Proof_info.t -> idopt:Names.lident option - -> GlobRef.t list + -> OblState.t * GlobRef.t list (** Used by the STM only to store info, should go away *) val get_po_name : proof_object -> Id.t @@ -446,16 +466,9 @@ module Obls : sig type fixpoint_kind = IsFixpoint of lident option list | IsCoFixpoint -module State : sig - (* Internal *) - type t - val prg_tag : t Summary.Dyn.tag -end - (** Check obligations are properly solved before closing the [what_for] section / module *) -val check_solved_obligations : what_for:Pp.t -> unit - +val check_solved_obligations : pm:OblState.t -> what_for:Pp.t -> unit val default_tactic : unit Proofview.tactic ref (** Resolution status of a program *) @@ -478,15 +491,17 @@ val prepare_obligation will return whether all the obligations were solved; if so, it will also register [c] with the kernel. *) val add_definition : - cinfo:Constr.types CInfo.t + pm:OblState.t + -> cinfo:Constr.types CInfo.t -> info:Info.t + -> ?obl_hook: OblState.t Hook.g -> ?term:Constr.t -> uctx:UState.t -> ?tactic:unit Proofview.tactic -> ?reduce:(Constr.t -> Constr.t) -> ?opaque:bool -> RetrieveObl.obligation_info - -> progress + -> OblState.t * progress (* XXX: unify with MutualEntry *) @@ -494,41 +509,44 @@ val add_definition : except it takes a list now. *) val add_mutual_definitions : (Constr.t CInfo.t * Constr.t * RetrieveObl.obligation_info) list + -> pm:OblState.t -> info:Info.t + -> ?obl_hook: OblState.t Hook.g -> uctx:UState.t -> ?tactic:unit Proofview.tactic -> ?reduce:(Constr.t -> Constr.t) -> ?opaque:bool -> ntns:Vernacexpr.decl_notation list -> fixpoint_kind - -> unit + -> OblState.t (** Implementation of the [Obligation] command *) val obligation : int * Names.Id.t option * Constrexpr.constr_expr option + -> pm:OblState.t -> Genarg.glob_generic_argument option -> Proof.t (** Implementation of the [Next Obligation] command *) val next_obligation : - Names.Id.t option -> Genarg.glob_generic_argument option -> Proof.t + pm:OblState.t -> Names.Id.t option -> Genarg.glob_generic_argument option -> Proof.t (** Implementation of the [Solve Obligation] command *) val solve_obligations : - Names.Id.t option -> unit Proofview.tactic option -> progress + pm:OblState.t -> Names.Id.t option -> unit Proofview.tactic option -> OblState.t * progress -val solve_all_obligations : unit Proofview.tactic option -> unit +val solve_all_obligations : pm:OblState.t -> unit Proofview.tactic option -> OblState.t (** Number of remaining obligations to be solved for this program *) val try_solve_obligation : - int -> Names.Id.t option -> unit Proofview.tactic option -> unit + pm:OblState.t -> int -> Names.Id.t option -> unit Proofview.tactic option -> OblState.t val try_solve_obligations : - Names.Id.t option -> unit Proofview.tactic option -> unit + pm:OblState.t -> Names.Id.t option -> unit Proofview.tactic option -> OblState.t -val show_obligations : ?msg:bool -> Names.Id.t option -> unit -val show_term : Names.Id.t option -> Pp.t -val admit_obligations : Names.Id.t option -> unit +val show_obligations : pm:OblState.t -> ?msg:bool -> Names.Id.t option -> unit +val show_term : pm:OblState.t -> Names.Id.t option -> Pp.t +val admit_obligations : pm:OblState.t -> Names.Id.t option -> OblState.t val check_program_libraries : unit -> unit diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index fdc8b1ba4c..cbd83e88b6 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -542,7 +542,7 @@ let make_act : type r. r target -> _ -> r gen_eval = function CAst.make ~loc @@ CPatNotation (None, notation, env, []) let extend_constr state forpat ng = - let custom,n,_,_ = ng.notgram_level in + let custom,n,_ = ng.notgram_level in let assoc = ng.notgram_assoc in let (entry, level) = interp_constr_entry_key custom forpat n in let fold (accu, state) pt = diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 45bf61d79e..e0550fd744 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -51,6 +51,7 @@ let record_field = Entry.create "vernac:record_field" let of_type_with_opt_coercion = Entry.create "vernac:of_type_with_opt_coercion" let section_subset_expr = Entry.create "vernac:section_subset_expr" let scope_delimiter = Entry.create "vernac:scope_delimiter" +let syntax_modifiers = Entry.create "vernac:syntax_modifiers" let only_parsing = Entry.create "vernac:only_parsing" let make_bullet s = @@ -233,7 +234,7 @@ GRAMMAR EXTEND Gram { VernacRegister(g, RegisterCoqlib quid) } | IDENT "Register"; IDENT "Inline"; g = global -> { VernacRegister(g, RegisterInline) } - | IDENT "Primitive"; id = identref; typopt = OPT [ ":"; typ = lconstr -> { typ } ]; ":="; r = register_token -> + | IDENT "Primitive"; id = ident_decl; typopt = OPT [ ":"; typ = lconstr -> { typ } ]; ":="; r = register_token -> { VernacPrimitive(id, r, typopt) } | IDENT "Universe"; l = LIST1 identref -> { VernacUniverse l } | IDENT "Universes"; l = LIST1 identref -> { VernacUniverse l } @@ -321,10 +322,13 @@ GRAMMAR EXTEND Gram | -> { None } ] ] ; decl_notation: - [ [ ntn = ne_lstring; ":="; c = constr; b = only_parsing; + [ [ ntn = ne_lstring; ":="; c = constr; + modl = syntax_modifiers; scopt = OPT [ ":"; sc = IDENT -> { sc } ] -> { { decl_ntn_string = ntn; decl_ntn_interp = c; - decl_ntn_only_parsing = b; decl_ntn_scope = scopt } } ] ] + decl_ntn_scope = scopt; + decl_ntn_modifiers = modl; + } } ] ] ; decl_sep: [ [ IDENT "and" -> { () } ] ] @@ -1118,7 +1122,7 @@ GRAMMAR EXTEND Gram (* Grammar extensions *) GRAMMAR EXTEND Gram - GLOBAL: syntax only_parsing; + GLOBAL: syntax only_parsing syntax_modifiers; syntax: [ [ IDENT "Open"; IDENT "Scope"; sc = IDENT -> @@ -1136,7 +1140,7 @@ GRAMMAR EXTEND Gram refl = LIST1 class_rawexpr -> { VernacBindScope (sc,refl) } | IDENT "Infix"; op = ne_lstring; ":="; p = constr; - modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ]; + modl = syntax_modifiers; sc = OPT [ ":"; sc = IDENT -> { sc } ] -> { VernacInfix ((op,modl),p,sc) } | IDENT "Notation"; id = identref; @@ -1145,20 +1149,20 @@ GRAMMAR EXTEND Gram (id,(idl,c),{ onlyparsing = b }) } | IDENT "Notation"; s = lstring; ":="; c = constr; - modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ]; + modl = syntax_modifiers; sc = OPT [ ":"; sc = IDENT -> { sc } ] -> { VernacNotation (c,(s,modl),sc) } | IDENT "Format"; IDENT "Notation"; n = STRING; s = STRING; fmt = STRING -> { VernacNotationAddFormat (n,s,fmt) } | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring; - l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ] -> + l = syntax_modifiers -> { let s = CAst.map (fun s -> "x '"^s^"' y") s in VernacSyntaxExtension (true,(s,l)) } | IDENT "Reserved"; IDENT "Notation"; s = ne_lstring; - l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ] + l = syntax_modifiers -> { VernacSyntaxExtension (false, (s,l)) } (* "Print" "Grammar" and "Declare" "Scope" should be here but are in "command" entry in order @@ -1196,6 +1200,11 @@ GRAMMAR EXTEND Gram | x = IDENT; typ = syntax_extension_type -> { SetEntryType (x,typ) } ] ] ; + syntax_modifiers: + [ [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } + | -> { [] } + ] ] + ; syntax_extension_type: [ [ IDENT "ident" -> { ETIdent } | IDENT "global" -> { ETGlobal } | IDENT "bigint" -> { ETBigint } diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 0c4f76f682..f9ecf10d1b 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -736,6 +736,9 @@ let explain_disallowed_sprop () = let explain_bad_relevance env = strbrk "Bad relevance (maybe a bugged tactic)." +let explain_bad_invert env = + strbrk "Bad case inversion (maybe a bugged tactic)." + let explain_type_error env sigma err = let env = make_all_name_different env sigma in match err with @@ -779,6 +782,7 @@ let explain_type_error env sigma err = explain_undeclared_universe env sigma l | DisallowedSProp -> explain_disallowed_sprop () | BadRelevance -> explain_bad_relevance env + | BadInvert -> explain_bad_invert env let pr_position (cl,pos) = let clpos = match cl with diff --git a/vernac/library.ml b/vernac/library.ml index c30331b221..e580927bfd 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -514,12 +514,3 @@ let get_used_load_paths () = String.Set.empty !libraries_loaded_list) let _ = Nativelib.get_load_paths := get_used_load_paths - -(* These commands may not be very safe due to ML-side plugin loading - etc... use at your own risk *) -let extern_state s = - System.extern_state Coq_config.state_magic_number s (States.freeze ~marshallable:true) - -let intern_state s = - States.unfreeze (System.with_magic_number_check (System.intern_state Coq_config.state_magic_number) s); - overwrite_library_filenames s diff --git a/vernac/library.mli b/vernac/library.mli index 633d266821..d0e9f84691 100644 --- a/vernac/library.mli +++ b/vernac/library.mli @@ -76,7 +76,3 @@ val native_name_from_filename : string -> string (** {6 Opaque accessors} *) val indirect_accessor : Opaqueproof.indirect_accessor - -(** Low-level state overwriting, not very safe *) -val intern_state : string -> unit -val extern_state : string -> unit diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 8435612abd..e9b86f323b 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -249,9 +249,9 @@ let quote_notation_token x = if (n > 0 && norm) || (n > 2 && x.[0] == '\'') then "'"^x^"'" else x -let is_numeral symbs = - match List.filter (function Break _ -> false | _ -> true) symbs with - | ([Terminal "-"; Terminal x] | [Terminal x]) -> +let is_numeral_in_constr entry symbs = + match entry, List.filter (function Break _ -> false | _ -> true) symbs with + | InConstrEntry, ([Terminal "-"; Terminal x] | [Terminal x]) -> NumTok.Unsigned.parse_string x <> None | _ -> false @@ -749,25 +749,25 @@ let pr_arg_level from (lev,typ) = | LevelSome -> mt () in Ppvernac.pr_set_entry_type (fun _ -> (*TO CHECK*) mt()) typ ++ pplev lev -let pr_level ntn (from,fromlevel,args,typs) = +let pr_level ntn (from,fromlevel,args) typs = (match from with InConstrEntry -> mt () | InCustomEntry s -> str "in " ++ str s ++ spc()) ++ str "at level " ++ int fromlevel ++ spc () ++ str "with arguments" ++ spc() ++ prlist_with_sep pr_comma (pr_arg_level fromlevel) (List.combine args typs) -let error_incompatible_level ntn oldprec prec = +let error_incompatible_level ntn oldprec oldtyps prec typs = user_err (str "Notation " ++ pr_notation ntn ++ str " is already defined" ++ spc() ++ - pr_level ntn oldprec ++ + pr_level ntn oldprec oldtyps ++ spc() ++ str "while it is now required to be" ++ spc() ++ - pr_level ntn prec ++ str ".") + pr_level ntn prec typs ++ str ".") -let error_parsing_incompatible_level ntn ntn' oldprec prec = +let error_parsing_incompatible_level ntn ntn' oldprec oldtyps prec typs = user_err (str "Notation " ++ pr_notation ntn ++ str " relies on a parsing rule for " ++ pr_notation ntn' ++ spc() ++ str " which is already defined" ++ spc() ++ - pr_level ntn oldprec ++ + pr_level ntn oldprec oldtyps ++ spc() ++ str "while it is now required to be" ++ spc() ++ - pr_level ntn prec ++ str ".") + pr_level ntn prec typs ++ str ".") let warn_incompatible_format = CWarnings.create ~name:"notation-incompatible-format" ~category:"parsing" @@ -780,9 +780,10 @@ let warn_incompatible_format = strbrk " was already defined with a different format" ++ scope ++ str ".") type syntax_parsing_extension = { - synext_level : Notation_gram.level; + synext_level : Notation.level; synext_notation : notation; synext_notgram : notation_grammar option; + synext_nottyps : Extend.constr_entry_key list; } type syntax_printing_extension = { @@ -827,8 +828,16 @@ let check_and_extend_constr_grammar ntn rule = let ntn_for_grammar = rule.notgram_notation in if notation_eq ntn ntn_for_grammar then raise Not_found; let prec = rule.notgram_level in - let oldparsing,oldprec = Notgram_ops.level_of_notation ntn_for_grammar in - if not (Notgram_ops.level_eq prec oldprec) && oldparsing <> None then error_parsing_incompatible_level ntn ntn_for_grammar oldprec prec; + let typs = rule.notgram_typs in + let oldprec = Notation.level_of_notation ntn_for_grammar in + let oldparsing = + try + Some (Notgram_ops.grammar_of_notation ntn_for_grammar) + with Not_found -> None + in + let oldtyps = Notgram_ops.subentries_of_notation ntn_for_grammar in + if not (Notation.level_eq prec oldprec) && oldparsing <> None then + error_parsing_incompatible_level ntn ntn_for_grammar oldprec oldtyps prec typs; if oldparsing = None then raise Not_found with Not_found -> Egramcoq.extend_constr_grammar rule @@ -839,12 +848,21 @@ let cache_one_syntax_extension (pa_se,pp_se) = (* Check and ensure that the level and the precomputed parsing rule is declared *) let oldparsing = try - let oldparsing,oldprec = Notgram_ops.level_of_notation ntn in - if not (Notgram_ops.level_eq prec oldprec) && (oldparsing <> None || pa_se.synext_notgram = None) then error_incompatible_level ntn oldprec prec; + let oldprec = Notation.level_of_notation ntn in + let oldparsing = + try + Some (Notgram_ops.grammar_of_notation ntn) + with Not_found -> None + in + let oldtyps = Notgram_ops.subentries_of_notation ntn in + if not (Notation.level_eq prec oldprec) && (oldparsing <> None || pa_se.synext_notgram = None) then + error_incompatible_level ntn oldprec oldtyps prec pa_se.synext_nottyps; oldparsing with Not_found -> (* Declare the level and the precomputed parsing rule *) - let _ = Notgram_ops.declare_notation_level ntn pa_se.synext_notgram prec in + let () = Notation.declare_notation_level ntn prec in + let () = Notgram_ops.declare_notation_subentries ntn pa_se.synext_nottyps in + let () = Option.iter (Notgram_ops.declare_notation_grammar ntn) pa_se.synext_notgram in None in (* Declare the parsing rule *) begin match oldparsing, pa_se.synext_notgram with @@ -1009,20 +1027,14 @@ let check_binder_type recvars etyps = strbrk " is only for use in recursive notations for binders.") | _ -> ()) etyps -let not_a_syntax_modifier = function -| SetOnlyParsing -> true -| SetOnlyPrinting -> true -| _ -> false - -let no_syntax_modifiers mods = List.for_all not_a_syntax_modifier mods - -let is_only_parsing mods = - let test = function SetOnlyParsing -> true | _ -> false in - List.exists test mods - -let is_only_printing mods = - let test = function SetOnlyPrinting -> true | _ -> false in - List.exists test mods +let interp_non_syntax_modifiers mods = + let set modif (only_parsing,only_printing,entry) = match modif with + | SetOnlyParsing -> Some (true,only_printing,entry) + | SetOnlyPrinting -> Some (only_parsing,true,entry) + | SetCustomEntry(entry,None) -> Some (only_parsing,only_printing,InCustomEntry entry) + | _ -> None + in + List.fold_left (fun st modif -> Option.bind st @@ set modif) (Some (false,false,InConstrEntry)) mods (* Compute precedences from modifiers (or find default ones) *) @@ -1141,33 +1153,29 @@ let warn_non_reversible_notation = str " not occur in the right-hand side." ++ spc() ++ strbrk "The notation will not be used for printing as it is not reversible.") -let make_custom_entry custom level = - match custom with - | InConstrEntry -> InConstrEntrySomeLevel - | InCustomEntry s -> InCustomEntryLevel (s,level) - type entry_coercion_kind = | IsEntryCoercion of notation_entry_level | IsEntryGlobal of string * int | IsEntryIdent of string * int -let is_coercion = function - | Some (custom,n,_,[e]) -> +let is_coercion level typs = + match level, typs with + | Some (custom,n,_), [e] -> (match e, custom with | ETConstr _, _ -> - let customkey = make_custom_entry custom n in + let customkey = make_notation_entry_level custom n in let subentry = subentry_of_constr_prod_entry e in if notation_entry_level_eq subentry customkey then None else Some (IsEntryCoercion subentry) | ETGlobal, InCustomEntry s -> Some (IsEntryGlobal (s,n)) | ETIdent, InCustomEntry s -> Some (IsEntryIdent (s,n)) | _ -> None) - | Some _ -> assert false - | None -> None + | Some _, _ -> assert false + | None, _ -> None -let printability level onlyparse reversibility = function +let printability level typs onlyparse reversibility = function | NVar _ when reversibility = APrioriReversible -> - let coe = is_coercion level in + let coe = is_coercion level typs in if not onlyparse && coe = None then warn_notation_bound_to_variable (); true, coe @@ -1229,7 +1237,7 @@ let find_precedence custom lev etyps symbols onlyprint = [],Option.get lev let check_curly_brackets_notation_exists () = - try let _ = Notgram_ops.level_of_notation (InConstrEntrySomeLevel,"{ _ }") in () + try let _ = Notation.level_of_notation (InConstrEntry,"{ _ }") in () with Not_found -> user_err Pp.(str "Notations involving patterns of the form \"{ _ }\" are treated \n\ specially and require that the notation \"{ _ }\" is already reserved.") @@ -1284,10 +1292,12 @@ module SynData = struct (* Notation data for parsing *) level : level; + subentries : constr_entry_key list; pa_syntax_data : subentry_types * symbol list; pp_syntax_data : subentry_types * symbol list; not_data : notation * (* notation *) - level * (* level, precedence, types *) + level * (* level, precedence *) + constr_entry_key list * bool; (* needs_squash *) } @@ -1328,12 +1338,11 @@ let compute_syntax_data ~local deprecation df modifiers = (* Notations for interp and grammar *) let msgs,n = find_precedence mods.custom mods.level mods.etyps symbols onlyprint in - let custom = make_custom_entry mods.custom n in - let ntn_for_interp = make_notation_key custom symbols in + let ntn_for_interp = make_notation_key mods.custom symbols in let symbols_for_grammar = - if custom = InConstrEntrySomeLevel then remove_curly_brackets symbols else symbols in + if mods.custom = InConstrEntry then remove_curly_brackets symbols else symbols in let need_squash = not (List.equal Notation.symbol_eq symbols symbols_for_grammar) in - let ntn_for_grammar = if need_squash then make_notation_key custom symbols_for_grammar else ntn_for_interp in + let ntn_for_grammar = if need_squash then make_notation_key mods.custom symbols_for_grammar else ntn_for_interp in if mods.custom = InConstrEntry && not onlyprint then check_rule_productivity symbols_for_grammar; (* To globalize... *) let etyps = join_auxiliary_recursive_types recvars mods.etyps in @@ -1348,7 +1357,7 @@ let compute_syntax_data ~local deprecation df modifiers = check_locality_compatibility local mods.custom sy_typs; let pa_sy_data = (sy_typs_for_grammar,symbols_for_grammar) in let pp_sy_data = (sy_typs,symbols) in - let sy_fulldata = (ntn_for_grammar,(mods.custom,n,prec_for_grammar,List.map snd sy_typs_for_grammar),need_squash) in + let sy_fulldata = (ntn_for_grammar,(mods.custom,n,prec_for_grammar),List.map snd sy_typs_for_grammar,need_squash) in let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in let i_data = ntn_for_interp, df' in @@ -1367,7 +1376,8 @@ let compute_syntax_data ~local deprecation df modifiers = mainvars; intern_typs = i_typs; - level = (mods.custom,n,prec,List.map snd sy_typs); + level = (mods.custom,n,prec); + subentries = List.map snd sy_typs; pa_syntax_data = pa_sy_data; pp_syntax_data = pp_sy_data; not_data = sy_fulldata; @@ -1433,7 +1443,13 @@ let open_notation i (_, nobj) = Notation.declare_uninterpretation (NotationRule specific_ntn) pat; (* Declare a possible coercion *) (match nobj.notobj_coercion with - | Some (IsEntryCoercion entry) -> Notation.declare_entry_coercion specific_ntn entry + | Some (IsEntryCoercion entry) -> + let (_,level,_) = Notation.level_of_notation ntn in + let level = match fst ntn with + | InConstrEntry -> None + | InCustomEntry _ -> Some level + in + Notation.declare_entry_coercion specific_ntn level entry | Some (IsEntryGlobal (entry,n)) -> Notation.declare_custom_entry_has_global entry n | Some (IsEntryIdent (entry,n)) -> Notation.declare_custom_entry_has_ident entry n | None -> ()) @@ -1488,10 +1504,14 @@ exception NoSyntaxRule let recover_notation_syntax ntn = let pa = try - let pa_rule,prec = Notgram_ops.level_of_notation ntn in + let prec = Notation.level_of_notation ntn in + let pa_typs = Notgram_ops.subentries_of_notation ntn in + let pa_rule = try Some (Notgram_ops.grammar_of_notation ntn) with Not_found -> None in { synext_level = prec; synext_notation = ntn; - synext_notgram = pa_rule } + synext_notgram = pa_rule; + synext_nottyps = pa_typs; + } with Not_found -> raise NoSyntaxRule in let pp = @@ -1506,7 +1526,7 @@ let recover_notation_syntax ntn = pa,pp let recover_squash_syntax sy = - let sq,_ = recover_notation_syntax (InConstrEntrySomeLevel,"{ _ }") in + let sq,_ = recover_notation_syntax (InConstrEntry,"{ _ }") in match sq.synext_notgram with | Some gram -> sy :: gram | None -> raise NoSyntaxRule @@ -1514,7 +1534,7 @@ let recover_squash_syntax sy = (**********************************************************************) (* Main entry point for building parsing and printing rules *) -let make_pa_rule level (typs,symbols) ntn need_squash = +let make_pa_rule level entries (typs,symbols) ntn need_squash = let assoc = recompute_assoc typs in let prod = make_production typs symbols in let sy = { @@ -1522,6 +1542,7 @@ let make_pa_rule level (typs,symbols) ntn need_squash = notgram_assoc = assoc; notgram_notation = ntn; notgram_prods = prod; + notgram_typs = entries; } in (* By construction, the rule for "{ _ }" is declared, but we need to redeclare it because the file where it is declared needs not be open @@ -1541,14 +1562,15 @@ let make_pp_rule level (typs,symbols) fmt = hunks_of_format (level, List.split typs) (symbols, parse_format fmt) let make_parsing_rules (sd : SynData.syn_data) = let open SynData in - let ntn_for_grammar, prec_for_grammar, need_squash = sd.not_data in + let ntn_for_grammar, prec_for_grammar, typs_for_grammar, need_squash = sd.not_data in let pa_rule = if sd.only_printing then None - else Some (make_pa_rule prec_for_grammar sd.pa_syntax_data ntn_for_grammar need_squash) + else Some (make_pa_rule prec_for_grammar typs_for_grammar sd.pa_syntax_data ntn_for_grammar need_squash) in { synext_level = sd.level; synext_notation = fst sd.info; synext_notgram = pa_rule; + synext_nottyps = typs_for_grammar; } let warn_irrelevant_format = @@ -1556,7 +1578,7 @@ let warn_irrelevant_format = (fun () -> str "The format modifier is irrelevant for only parsing rules.") let make_printing_rules reserved (sd : SynData.syn_data) = let open SynData in - let custom,level,_,_ = sd.level in + let custom,level,_ = sd.level in let pp_rule = make_pp_rule level sd.pp_syntax_data sd.format in if sd.only_parsing then (if sd.format <> None then warn_irrelevant_format (); None) else Some { @@ -1587,7 +1609,8 @@ let add_notation_in_scope ~local deprecation df env c mods scope = let (acvars, ac, reversibility) = interp_notation_constr env nenv c in let interp = make_interpretation_vars sd.recvars acvars (fst sd.pa_syntax_data) in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in - let onlyparse,coe = printability (Some sd.level) sd.only_parsing reversibility ac in + let onlyparse,coe = printability (Some sd.level) sd.subentries sd.only_parsing reversibility ac in + let notation, location = sd.info in let notation = { notobj_local = local; notobj_scope = scope; @@ -1597,7 +1620,7 @@ let add_notation_in_scope ~local deprecation df env c mods scope = notobj_coercion = coe; notobj_onlyprint = sd.only_printing; notobj_deprecation = sd.deprecation; - notobj_notation = sd.info; + notobj_notation = (notation, location); notobj_specific_pp_rules = sy_pp_rules; } in let gen_sy_pp_rules = @@ -1610,20 +1633,21 @@ let add_notation_in_scope ~local deprecation df env c mods scope = Lib.add_anonymous_leaf (inNotation notation); sd.info -let add_notation_interpretation_core ~local df env ?(impls=empty_internalization_env) c scope onlyparse onlyprint deprecation = +let add_notation_interpretation_core ~local df env ?(impls=empty_internalization_env) entry c scope onlyparse onlyprint deprecation = let (recvars,mainvars,symbs) = analyze_notation_tokens ~onlyprint df in (* Recover types of variables and pa/pp rules; redeclare them if needed *) - let level, i_typs, onlyprint, pp_sy = if not (is_numeral symbs) then begin - let (pa_sy,pp_sy as sy) = recover_notation_syntax (make_notation_key InConstrEntrySomeLevel symbs) in + let notation_key = make_notation_key entry symbs in + let level, i_typs, onlyprint, pp_sy = if not (is_numeral_in_constr entry symbs) then begin + let (pa_sy,pp_sy as sy) = recover_notation_syntax notation_key in let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy)) in (* If the only printing flag has been explicitly requested, put it back *) let onlyprint = onlyprint || pa_sy.synext_notgram = None in - let _,_,_,typs = pa_sy.synext_level in + let typs = pa_sy.synext_nottyps in Some pa_sy.synext_level, typs, onlyprint, pp_sy end else None, [], false, None in (* Declare interpretation *) let path = (Lib.library_dp(), Lib.current_dirpath true) in - let df' = (make_notation_key InConstrEntrySomeLevel symbs, (path,df)) in + let df' = notation_key, (path,df) in let i_vars = make_internalization_vars recvars mainvars (List.map internalization_type_of_entry_type i_typs) in let nenv = { ninterp_var_type = to_map i_vars; @@ -1632,7 +1656,7 @@ let add_notation_interpretation_core ~local df env ?(impls=empty_internalization let (acvars, ac, reversibility) = interp_notation_constr env ~impls nenv c in let interp = make_interpretation_vars recvars acvars (List.combine mainvars i_typs) in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in - let onlyparse,coe = printability level onlyparse reversibility ac in + let onlyparse,coe = printability level i_typs onlyparse reversibility ac in let notation = { notobj_local = local; notobj_scope = scope; @@ -1663,36 +1687,44 @@ let add_notation_interpretation env decl_ntn = let { decl_ntn_string = { CAst.loc ; v = df }; decl_ntn_interp = c; - decl_ntn_only_parsing = onlyparse; - decl_ntn_scope = sc } = decl_ntn in - let df' = add_notation_interpretation_core ~local:false df env c sc onlyparse false None in - Dumpglob.dump_notation (loc,df') sc true + decl_ntn_modifiers = modifiers; + decl_ntn_scope = sc; + } = decl_ntn in + match interp_non_syntax_modifiers modifiers with + | None -> CErrors.user_err (str"Only modifiers not affecting parsing are supported here") + | Some (only_parsing,only_printing,entry) -> + let df' = add_notation_interpretation_core ~local:false df env entry c sc only_parsing false None in + Dumpglob.dump_notation (loc,df') sc true let set_notation_for_interpretation env impls decl_ntn = let { decl_ntn_string = { CAst.v = df }; decl_ntn_interp = c; - decl_ntn_only_parsing = onlyparse; - decl_ntn_scope = sc } = decl_ntn in - (try ignore - (Flags.silently (fun () -> add_notation_interpretation_core ~local:false df env ~impls c sc onlyparse false None) ()); - with NoSyntaxRule -> - user_err Pp.(str "Parsing rule for this notation has to be previously declared.")); - Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc + decl_ntn_modifiers = modifiers; + decl_ntn_scope = sc; + } = decl_ntn in + match interp_non_syntax_modifiers modifiers with + | None -> CErrors.user_err (str"Only modifiers not affecting parsing are supported here") + | Some (only_parsing,only_printing,entry) -> + (try ignore + (Flags.silently (fun () -> add_notation_interpretation_core ~local:false df env ~impls entry c sc only_parsing false None) ()); + with NoSyntaxRule -> + user_err Pp.(str "Parsing rule for this notation has to be previously declared.")); + Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc (* Main entry point *) let add_notation ~local deprecation env c ({CAst.loc;v=df},modifiers) sc = let df' = - if no_syntax_modifiers modifiers then + match interp_non_syntax_modifiers modifiers with + | Some (only_parsing,only_printing,entry) -> (* No syntax data: try to rely on a previously declared rule *) - let onlyparse = is_only_parsing modifiers in - let onlyprint = is_only_printing modifiers in - try add_notation_interpretation_core ~local df env c sc onlyparse onlyprint deprecation + begin try add_notation_interpretation_core ~local df env entry c sc only_parsing only_printing deprecation with NoSyntaxRule -> (* Try to determine a default syntax rule *) add_notation_in_scope ~local deprecation df env c modifiers sc - else + end + | None -> (* Declare both syntax and interpretation *) add_notation_in_scope ~local deprecation df env c modifiers sc in @@ -1701,7 +1733,7 @@ let add_notation ~local deprecation env c ({CAst.loc;v=df},modifiers) sc = let add_notation_extra_printing_rule df k v = let notk = let _,_, symbs = analyze_notation_tokens ~onlyprint:true df in - make_notation_key InConstrEntrySomeLevel symbs in + make_notation_key InConstrEntry symbs in add_notation_extra_printing_rule notk k v (* Infix notations *) @@ -1809,7 +1841,7 @@ let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing let in_pat id = (id,ETConstr (Constrexpr.InConstrEntry,None,(NextLevel,0))) in let interp = make_interpretation_vars ~default_if_binding:AsIdentOrPattern [] acvars (List.map in_pat vars) in let vars = List.map (fun x -> (x, Id.Map.find x interp)) vars in - let onlyparsing = onlyparsing || fst (printability None false reversibility pat) in + let onlyparsing = onlyparsing || fst (printability None [] false reversibility pat) in Syntax_def.declare_syntactic_definition ~local deprecation ident ~onlyparsing (vars,pat) (**********************************************************************) diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 2c52c605b5..e0974ac027 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -22,93 +22,93 @@ open Vernacexpr open Declaremods open Pputils - open Ppconstr +open Ppconstr - let do_not_tag _ x = x - let tag_keyword = do_not_tag () - let tag_vernac = do_not_tag +let do_not_tag _ x = x +let tag_keyword = do_not_tag () +let tag_vernac = do_not_tag - let keyword s = tag_keyword (str s) +let keyword s = tag_keyword (str s) - let pr_constr = pr_constr_expr - let pr_lconstr = pr_lconstr_expr - let pr_spc_lconstr = - let env = Global.env () in - let sigma = Evd.from_env env in - pr_sep_com spc @@ pr_lconstr_expr env sigma +let pr_constr = pr_constr_expr +let pr_lconstr = pr_lconstr_expr +let pr_spc_lconstr = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_sep_com spc @@ pr_lconstr_expr env sigma - let pr_uconstraint (l, d, r) = - pr_glob_sort_name l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ - pr_glob_sort_name r +let pr_uconstraint (l, d, r) = + pr_glob_sort_name l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ + pr_glob_sort_name r - let pr_univ_name_list = function - | None -> mt () - | Some l -> - str "@{" ++ prlist_with_sep spc pr_lname l ++ str"}" +let pr_univ_name_list = function + | None -> mt () + | Some l -> + str "@{" ++ prlist_with_sep spc pr_lname l ++ str"}" - let pr_univdecl_instance l extensible = - prlist_with_sep spc pr_lident l ++ - (if extensible then str"+" else mt ()) +let pr_univdecl_instance l extensible = + prlist_with_sep spc pr_lident l ++ + (if extensible then str"+" else mt ()) - let pr_univdecl_constraints l extensible = - if List.is_empty l && extensible then mt () - else str"|" ++ spc () ++ prlist_with_sep (fun () -> str",") pr_uconstraint l ++ - (if extensible then str"+" else mt()) +let pr_univdecl_constraints l extensible = + if List.is_empty l && extensible then mt () + else str"|" ++ spc () ++ prlist_with_sep (fun () -> str",") pr_uconstraint l ++ + (if extensible then str"+" else mt()) - let pr_universe_decl l = - let open UState in - match l with - | None -> mt () - | Some l -> - str"@{" ++ pr_univdecl_instance l.univdecl_instance l.univdecl_extensible_instance ++ - pr_univdecl_constraints l.univdecl_constraints l.univdecl_extensible_constraints ++ str "}" +let pr_universe_decl l = + let open UState in + match l with + | None -> mt () + | Some l -> + str"@{" ++ pr_univdecl_instance l.univdecl_instance l.univdecl_extensible_instance ++ + pr_univdecl_constraints l.univdecl_constraints l.univdecl_extensible_constraints ++ str "}" - let pr_ident_decl (lid, l) = - pr_lident lid ++ pr_universe_decl l +let pr_ident_decl (lid, l) = + pr_lident lid ++ pr_universe_decl l - let string_of_fqid fqid = - String.concat "." (List.map Id.to_string fqid) +let string_of_fqid fqid = + String.concat "." (List.map Id.to_string fqid) - let pr_fqid fqid = str (string_of_fqid fqid) +let pr_fqid fqid = str (string_of_fqid fqid) - let pr_lfqid {CAst.loc;v=fqid} = - match loc with - | None -> pr_fqid fqid - | Some loc -> let (b,_) = Loc.unloc loc in - pr_located pr_fqid @@ Loc.tag ~loc:(Loc.make_loc (b,b + String.length (string_of_fqid fqid))) fqid +let pr_lfqid {CAst.loc;v=fqid} = + match loc with + | None -> pr_fqid fqid + | Some loc -> let (b,_) = Loc.unloc loc in + pr_located pr_fqid @@ Loc.tag ~loc:(Loc.make_loc (b,b + String.length (string_of_fqid fqid))) fqid - let pr_lname_decl (n, u) = - pr_lname n ++ pr_universe_decl u +let pr_lname_decl (n, u) = + pr_lname n ++ pr_universe_decl u - let pr_smart_global = Pputils.pr_or_by_notation pr_qualid +let pr_smart_global = Pputils.pr_or_by_notation pr_qualid - let pr_ltac_ref = Libnames.pr_qualid +let pr_ltac_ref = Libnames.pr_qualid - let pr_module = Libnames.pr_qualid +let pr_module = Libnames.pr_qualid - let pr_one_import_filter_name (q,etc) = - Libnames.pr_qualid q ++ if etc then str "(..)" else mt() +let pr_one_import_filter_name (q,etc) = + Libnames.pr_qualid q ++ if etc then str "(..)" else mt() - let pr_import_module (m,f) = - Libnames.pr_qualid m ++ match f with - | ImportAll -> mt() - | ImportNames ns -> surround (prlist_with_sep pr_comma pr_one_import_filter_name ns) +let pr_import_module (m,f) = + Libnames.pr_qualid m ++ match f with + | ImportAll -> mt() + | ImportNames ns -> surround (prlist_with_sep pr_comma pr_one_import_filter_name ns) - let sep_end = function - | VernacBullet _ - | VernacSubproof _ - | VernacEndSubproof -> str"" - | _ -> str"." +let sep_end = function + | VernacBullet _ + | VernacSubproof _ + | VernacEndSubproof -> str"" + | _ -> str"." - let pr_gen t = - let env = Global.env () in - let sigma = Evd.from_env env in - Pputils.pr_raw_generic env sigma t +let pr_gen t = + let env = Global.env () in + let sigma = Evd.from_env env in + Pputils.pr_raw_generic env sigma t - let sep = fun _ -> spc() - let sep_v2 = fun _ -> str"," ++ spc() +let sep = fun _ -> spc() +let sep_v2 = fun _ -> str"," ++ spc() - let string_of_theorem_kind = let open Decls in function +let string_of_theorem_kind = let open Decls in function | Theorem -> "Theorem" | Lemma -> "Lemma" | Fact -> "Fact" @@ -117,7 +117,7 @@ open Pputils | Proposition -> "Proposition" | Corollary -> "Corollary" - let string_of_definition_object_kind = let open Decls in function +let string_of_definition_object_kind = let open Decls in function | Definition -> "Definition" | Example -> "Example" | Coercion -> "Coercion" @@ -128,313 +128,313 @@ open Pputils | (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) -> CErrors.anomaly (Pp.str "Internal definition kind.") - let string_of_assumption_kind = let open Decls in function +let string_of_assumption_kind = let open Decls in function | Definitional -> "Parameter" | Logical -> "Axiom" | Conjectural -> "Conjecture" | Context -> "Context" - let string_of_logical_kind = let open Decls in function +let string_of_logical_kind = let open Decls in function | IsAssumption k -> string_of_assumption_kind k | IsDefinition k -> string_of_definition_object_kind k | IsProof k -> string_of_theorem_kind k | IsPrimitive -> "Primitive" - let pr_notation_entry = function - | InConstrEntry -> keyword "constr" - | InCustomEntry s -> keyword "custom" ++ spc () ++ str s +let pr_notation_entry = function + | InConstrEntry -> keyword "constr" + | InCustomEntry s -> keyword "custom" ++ spc () ++ str s - let pr_at_level = function - | NumLevel n -> spc () ++ keyword "at" ++ spc () ++ keyword "level" ++ spc () ++ int n - | NextLevel -> spc () ++ keyword "at" ++ spc () ++ keyword "next" ++ spc () ++ keyword "level" - | DefaultLevel -> mt () +let pr_at_level = function + | NumLevel n -> spc () ++ keyword "at" ++ spc () ++ keyword "level" ++ spc () ++ int n + | NextLevel -> spc () ++ keyword "at" ++ spc () ++ keyword "next" ++ spc () ++ keyword "level" + | DefaultLevel -> mt () - let level_of_pattern_level = function None -> DefaultLevel | Some n -> NumLevel n +let level_of_pattern_level = function None -> DefaultLevel | Some n -> NumLevel n - let pr_constr_as_binder_kind = let open Notation_term in function +let pr_constr_as_binder_kind = let open Notation_term in function | AsIdent -> spc () ++ keyword "as ident" | AsIdentOrPattern -> spc () ++ keyword "as pattern" | AsStrictPattern -> spc () ++ keyword "as strict pattern" - let pr_strict b = if b then str "strict " else mt () - - let pr_set_entry_type pr = function - | ETIdent -> str"ident" - | ETGlobal -> str"global" - | ETPattern (b,n) -> pr_strict b ++ str"pattern" ++ pr_at_level (level_of_pattern_level n) - | ETConstr (s,bko,lev) -> pr_notation_entry s ++ pr lev ++ pr_opt pr_constr_as_binder_kind bko - | ETBigint -> str "bigint" - | ETBinder true -> str "binder" - | ETBinder false -> str "closed binder" - - let pr_set_simple_entry_type = - pr_set_entry_type pr_at_level - - let pr_comment pr_c = function - | CommentConstr c -> pr_c c - | CommentString s -> qs s - | CommentInt n -> int n - - let pr_in_out_modules = function - | SearchInside l -> spc() ++ keyword "inside" ++ spc() ++ prlist_with_sep sep pr_module l - | SearchOutside [] -> mt() - | SearchOutside l -> spc() ++ keyword "outside" ++ spc() ++ prlist_with_sep sep pr_module l - - let pr_search_where = function - | Anywhere, false -> mt () - | Anywhere, true -> str "head:" - | InHyp, true -> str "headhyp:" - | InHyp, false -> str "hyp:" - | InConcl, true -> str "headconcl:" - | InConcl, false -> str "concl:" - - let pr_search_item = function - | SearchSubPattern (where,p) -> - let env = Global.env () in - let sigma = Evd.from_env env in - pr_search_where where ++ pr_constr_pattern_expr env sigma p - | SearchString (where,s,sc) -> pr_search_where where ++ qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc - | SearchKind kind -> str "is:" ++ str (string_of_logical_kind kind) - - let rec pr_search_request = function - | SearchLiteral a -> pr_search_item a - | SearchDisjConj l -> str "[" ++ prlist_with_sep spc (prlist_with_sep pr_bar pr_search_default) l ++ str "]" - - and pr_search_default (b, s) = - (if b then mt() else str "-") ++ pr_search_request s - - let pr_search a gopt b pr_p = - pr_opt (fun g -> Goal_select.pr_goal_selector g ++ str ":"++ spc()) gopt - ++ - match a with - | SearchHead c -> keyword "SearchHead" ++ spc() ++ pr_p c ++ pr_in_out_modules b - | SearchPattern c -> keyword "SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b - | SearchRewrite c -> keyword "SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b - | Search sl -> - keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search_default sl ++ pr_in_out_modules b - - let pr_option_ref_value = function - | Goptions.QualidRefValue id -> pr_qualid id - | Goptions.StringRefValue s -> qs s - - let pr_printoption table b = - prlist_with_sep spc str table ++ - pr_opt (prlist_with_sep sep pr_option_ref_value) b - - let pr_set_option a b = - pr_printoption a None ++ (match b with - | OptionUnset | OptionSetTrue -> mt() - | OptionSetInt n -> spc() ++ int n - | OptionSetString s -> spc() ++ quote (str s)) - - let pr_opt_hintbases l = match l with - | [] -> mt() - | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z - - let pr_reference_or_constr pr_c = function - | HintsReference r -> pr_qualid r - | HintsConstr c -> pr_c c - - let pr_hint_mode = let open Hints in function +let pr_strict b = if b then str "strict " else mt () + +let pr_set_entry_type pr = function + | ETIdent -> str"ident" + | ETGlobal -> str"global" + | ETPattern (b,n) -> pr_strict b ++ str"pattern" ++ pr_at_level (level_of_pattern_level n) + | ETConstr (s,bko,lev) -> pr_notation_entry s ++ pr lev ++ pr_opt pr_constr_as_binder_kind bko + | ETBigint -> str "bigint" + | ETBinder true -> str "binder" + | ETBinder false -> str "closed binder" + +let pr_set_simple_entry_type = + pr_set_entry_type pr_at_level + +let pr_comment pr_c = function + | CommentConstr c -> pr_c c + | CommentString s -> qs s + | CommentInt n -> int n + +let pr_in_out_modules = function + | SearchInside l -> spc() ++ keyword "inside" ++ spc() ++ prlist_with_sep sep pr_module l + | SearchOutside [] -> mt() + | SearchOutside l -> spc() ++ keyword "outside" ++ spc() ++ prlist_with_sep sep pr_module l + +let pr_search_where = function + | Anywhere, false -> mt () + | Anywhere, true -> str "head:" + | InHyp, true -> str "headhyp:" + | InHyp, false -> str "hyp:" + | InConcl, true -> str "headconcl:" + | InConcl, false -> str "concl:" + +let pr_search_item = function + | SearchSubPattern (where,p) -> + let env = Global.env () in + let sigma = Evd.from_env env in + pr_search_where where ++ pr_constr_pattern_expr env sigma p + | SearchString (where,s,sc) -> pr_search_where where ++ qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc + | SearchKind kind -> str "is:" ++ str (string_of_logical_kind kind) + +let rec pr_search_request = function + | SearchLiteral a -> pr_search_item a + | SearchDisjConj l -> str "[" ++ prlist_with_sep spc (prlist_with_sep pr_bar pr_search_default) l ++ str "]" + +and pr_search_default (b, s) = + (if b then mt() else str "-") ++ pr_search_request s + +let pr_search a gopt b pr_p = + pr_opt (fun g -> Goal_select.pr_goal_selector g ++ str ":"++ spc()) gopt + ++ + match a with + | SearchHead c -> keyword "SearchHead" ++ spc() ++ pr_p c ++ pr_in_out_modules b + | SearchPattern c -> keyword "SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b + | SearchRewrite c -> keyword "SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b + | Search sl -> + keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search_default sl ++ pr_in_out_modules b + +let pr_option_ref_value = function + | Goptions.QualidRefValue id -> pr_qualid id + | Goptions.StringRefValue s -> qs s + +let pr_printoption table b = + prlist_with_sep spc str table ++ + pr_opt (prlist_with_sep sep pr_option_ref_value) b + +let pr_set_option a b = + pr_printoption a None ++ (match b with + | OptionUnset | OptionSetTrue -> mt() + | OptionSetInt n -> spc() ++ int n + | OptionSetString s -> spc() ++ quote (str s)) + +let pr_opt_hintbases l = match l with + | [] -> mt() + | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z + +let pr_reference_or_constr pr_c = function + | HintsReference r -> pr_qualid r + | HintsConstr c -> pr_c c + +let pr_hint_mode = let open Hints in function | ModeInput -> str"+" | ModeNoHeadEvar -> str"!" | ModeOutput -> str"-" - let pr_hint_info pr_pat { Typeclasses.hint_priority = pri; hint_pattern = pat } = - pr_opt (fun x -> str"|" ++ int x) pri ++ - pr_opt (fun y -> (if Option.is_empty pri then str"| " else mt()) ++ pr_pat y) pat - - let pr_hints db h pr_c pr_pat = - let opth = pr_opt_hintbases db in - let pph = - let open Hints in - match h with - | HintsResolve l -> - keyword "Resolve " ++ prlist_with_sep sep - (fun (info, _, c) -> pr_reference_or_constr pr_c c ++ pr_hint_info pr_pat info) - l - | HintsResolveIFF (l2r, l, n) -> - keyword "Resolve " ++ str (if l2r then "->" else "<-") - ++ prlist_with_sep sep pr_qualid l - | HintsImmediate l -> - keyword "Immediate" ++ spc() ++ - prlist_with_sep sep (fun c -> pr_reference_or_constr pr_c c) l - | HintsUnfold l -> - keyword "Unfold" ++ spc () ++ prlist_with_sep sep pr_qualid l - | HintsTransparency (l, b) -> - keyword (if b then "Transparent" else "Opaque") - ++ spc () - ++ (match l with - | HintsVariables -> keyword "Variables" - | HintsConstants -> keyword "Constants" - | HintsReferences l -> prlist_with_sep sep pr_qualid l) - | HintsMode (m, l) -> - keyword "Mode" - ++ spc () - ++ pr_qualid m ++ spc() ++ - prlist_with_sep spc pr_hint_mode l - | HintsConstructors c -> - keyword "Constructors" - ++ spc() ++ prlist_with_sep spc pr_qualid c - | HintsExtern (n,c,tac) -> - let pat = match c with None -> mt () | Some pat -> pr_pat pat in - let env = Global.env () in - let sigma = Evd.from_env env in - keyword "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++ - spc() ++ Pputils.pr_raw_generic env sigma tac - in - hov 2 (keyword "Hint "++ pph ++ opth) - - let pr_with_declaration pr_c = function - | CWith_Definition (id,udecl,c) -> - let p = pr_c c in - keyword "Definition" ++ spc() ++ pr_lfqid id ++ pr_universe_decl udecl ++ str" := " ++ p - | CWith_Module (id,qid) -> - keyword "Module" ++ spc() ++ pr_lfqid id ++ str" := " ++ - pr_qualid qid - - let rec pr_module_ast leading_space pr_c = function - | { loc ; v = CMident qid } -> - if leading_space then - spc () ++ pr_located pr_qualid (loc, qid) - else - pr_located pr_qualid (loc,qid) - | { v = CMwith (mty,decl) } -> - let m = pr_module_ast leading_space pr_c mty in - let p = pr_with_declaration pr_c decl in - m ++ spc() ++ keyword "with" ++ spc() ++ p - | { v = CMapply (me1, ( { v = CMident _ } as me2 ) ) } -> - pr_module_ast leading_space pr_c me1 ++ spc() ++ pr_module_ast false pr_c me2 - | { v = CMapply (me1,me2) } -> - pr_module_ast leading_space pr_c me1 ++ spc() ++ - hov 1 (str"(" ++ pr_module_ast false pr_c me2 ++ str")") - - let pr_inline = function - | DefaultInline -> mt () - | NoInline -> str "[no inline]" - | InlineAt i -> str "[inline at level " ++ int i ++ str "]" - - let pr_assumption_inline = function - | DefaultInline -> str "Inline" - | NoInline -> mt () - | InlineAt i -> str "Inline(" ++ int i ++ str ")" - - let pr_module_ast_inl leading_space pr_c (mast,inl) = - pr_module_ast leading_space pr_c mast ++ pr_inline inl - - let pr_of_module_type prc = function - | Enforce mty -> str ":" ++ pr_module_ast_inl true prc mty - | Check mtys -> - prlist_strict (fun m -> str "<:" ++ pr_module_ast_inl true prc m) mtys - - let pr_require_token = function - | Some true -> - keyword "Export" ++ spc () - | Some false -> - keyword "Import" ++ spc () - | None -> mt() - - let pr_module_vardecls pr_c (export,idl,(mty,inl)) = - let m = pr_module_ast true pr_c mty in - spc() ++ - hov 1 (str"(" ++ pr_require_token export ++ - prlist_with_sep spc pr_lident idl ++ str":" ++ m ++ str")") - - let pr_module_binders l pr_c = - prlist_strict (pr_module_vardecls pr_c) l - - let pr_type_option pr_c = function - | { v = CHole (k, Namegen.IntroAnonymous, _) } -> mt() - | _ as c -> brk(0,2) ++ str" :" ++ pr_c c - - let pr_binders_arg = - let env = Global.env () in - let sigma = Evd.from_env env in - pr_non_empty_arg @@ pr_binders env sigma - - let pr_and_type_binders_arg bl = - pr_binders_arg bl - - let pr_onescheme (idop,schem) = - match schem with - | InductionScheme (dep,ind,s) -> - (match idop with - | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() - | None -> spc () - ) ++ - hov 0 ((if dep then keyword "Induction for" else keyword "Minimality for") - ++ spc() ++ pr_smart_global ind) ++ spc() ++ - hov 0 (keyword "Sort" ++ spc() ++ Sorts.pr_sort_family s) - | CaseScheme (dep,ind,s) -> - (match idop with - | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() - | None -> spc () - ) ++ - hov 0 ((if dep then keyword "Elimination for" else keyword "Case for") - ++ spc() ++ pr_smart_global ind) ++ spc() ++ - hov 0 (keyword "Sort" ++ spc() ++ Sorts.pr_sort_family s) - | EqualityScheme ind -> - (match idop with - | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() - | None -> spc() - ) ++ - hov 0 (keyword "Equality for") - ++ spc() ++ pr_smart_global ind - - let begin_of_inductive = function - | [] -> 0 - | (_,({loc},_))::_ -> Option.cata (fun loc -> fst (Loc.unloc loc)) 0 loc - - let pr_class_rawexpr = function - | FunClass -> keyword "Funclass" - | SortClass -> keyword "Sortclass" - | RefClass qid -> pr_smart_global qid - - let pr_assumption_token many discharge kind = - match discharge, kind with - | (NoDischarge,Decls.Logical) -> - keyword (if many then "Axioms" else "Axiom") - | (NoDischarge,Decls.Definitional) -> - keyword (if many then "Parameters" else "Parameter") - | (NoDischarge,Decls.Conjectural) -> str"Conjecture" - | (DoDischarge,Decls.Logical) -> - keyword (if many then "Hypotheses" else "Hypothesis") - | (DoDischarge,Decls.Definitional) -> - keyword (if many then "Variables" else "Variable") - | (DoDischarge,Decls.Conjectural) -> - anomaly (Pp.str "Don't know how to beautify a local conjecture.") - | (_,Decls.Context) -> - anomaly (Pp.str "Context is used only internally.") - - let pr_params pr_c (xl,(c,t)) = - hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++ - (if c then str":>" else str":" ++ - spc() ++ pr_c t)) - - let rec factorize = function - | [] -> [] - | (c,(idl,t))::l -> - match factorize l with - | (xl,((c', t') as r))::l' - when (c : bool) == c' && (=) t t' -> - (* FIXME: we need equality on constr_expr *) - (idl@xl,r)::l' - | l' -> (idl,(c,t))::l' - - let pr_ne_params_list pr_c l = +let pr_hint_info pr_pat { Typeclasses.hint_priority = pri; hint_pattern = pat } = + pr_opt (fun x -> str"|" ++ int x) pri ++ + pr_opt (fun y -> (if Option.is_empty pri then str"| " else mt()) ++ pr_pat y) pat + +let pr_hints db h pr_c pr_pat = + let opth = pr_opt_hintbases db in + let pph = + let open Hints in + match h with + | HintsResolve l -> + keyword "Resolve " ++ prlist_with_sep sep + (fun (info, _, c) -> pr_reference_or_constr pr_c c ++ pr_hint_info pr_pat info) + l + | HintsResolveIFF (l2r, l, n) -> + keyword "Resolve " ++ str (if l2r then "->" else "<-") + ++ prlist_with_sep sep pr_qualid l + | HintsImmediate l -> + keyword "Immediate" ++ spc() ++ + prlist_with_sep sep (fun c -> pr_reference_or_constr pr_c c) l + | HintsUnfold l -> + keyword "Unfold" ++ spc () ++ prlist_with_sep sep pr_qualid l + | HintsTransparency (l, b) -> + keyword (if b then "Transparent" else "Opaque") + ++ spc () + ++ (match l with + | HintsVariables -> keyword "Variables" + | HintsConstants -> keyword "Constants" + | HintsReferences l -> prlist_with_sep sep pr_qualid l) + | HintsMode (m, l) -> + keyword "Mode" + ++ spc () + ++ pr_qualid m ++ spc() ++ + prlist_with_sep spc pr_hint_mode l + | HintsConstructors c -> + keyword "Constructors" + ++ spc() ++ prlist_with_sep spc pr_qualid c + | HintsExtern (n,c,tac) -> + let pat = match c with None -> mt () | Some pat -> pr_pat pat in + let env = Global.env () in + let sigma = Evd.from_env env in + keyword "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++ + spc() ++ Pputils.pr_raw_generic env sigma tac + in + hov 2 (keyword "Hint "++ pph ++ opth) + +let pr_with_declaration pr_c = function + | CWith_Definition (id,udecl,c) -> + let p = pr_c c in + keyword "Definition" ++ spc() ++ pr_lfqid id ++ pr_universe_decl udecl ++ str" := " ++ p + | CWith_Module (id,qid) -> + keyword "Module" ++ spc() ++ pr_lfqid id ++ str" := " ++ + pr_qualid qid + +let rec pr_module_ast leading_space pr_c = function + | { loc ; v = CMident qid } -> + if leading_space then + spc () ++ pr_located pr_qualid (loc, qid) + else + pr_located pr_qualid (loc,qid) + | { v = CMwith (mty,decl) } -> + let m = pr_module_ast leading_space pr_c mty in + let p = pr_with_declaration pr_c decl in + m ++ spc() ++ keyword "with" ++ spc() ++ p + | { v = CMapply (me1, ( { v = CMident _ } as me2 ) ) } -> + pr_module_ast leading_space pr_c me1 ++ spc() ++ pr_module_ast false pr_c me2 + | { v = CMapply (me1,me2) } -> + pr_module_ast leading_space pr_c me1 ++ spc() ++ + hov 1 (str"(" ++ pr_module_ast false pr_c me2 ++ str")") + +let pr_inline = function + | DefaultInline -> mt () + | NoInline -> str "[no inline]" + | InlineAt i -> str "[inline at level " ++ int i ++ str "]" + +let pr_assumption_inline = function + | DefaultInline -> str "Inline" + | NoInline -> mt () + | InlineAt i -> str "Inline(" ++ int i ++ str ")" + +let pr_module_ast_inl leading_space pr_c (mast,inl) = + pr_module_ast leading_space pr_c mast ++ pr_inline inl + +let pr_of_module_type prc = function + | Enforce mty -> str ":" ++ pr_module_ast_inl true prc mty + | Check mtys -> + prlist_strict (fun m -> str "<:" ++ pr_module_ast_inl true prc m) mtys + +let pr_require_token = function + | Some true -> + keyword "Export" ++ spc () + | Some false -> + keyword "Import" ++ spc () + | None -> mt() + +let pr_module_vardecls pr_c (export,idl,(mty,inl)) = + let m = pr_module_ast true pr_c mty in + spc() ++ + hov 1 (str"(" ++ pr_require_token export ++ + prlist_with_sep spc pr_lident idl ++ str":" ++ m ++ str")") + +let pr_module_binders l pr_c = + prlist_strict (pr_module_vardecls pr_c) l + +let pr_type_option pr_c = function + | { v = CHole (k, Namegen.IntroAnonymous, _) } -> mt() + | _ as c -> brk(0,2) ++ str" :" ++ pr_c c + +let pr_binders_arg = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_non_empty_arg @@ pr_binders env sigma + +let pr_and_type_binders_arg bl = + pr_binders_arg bl + +let pr_onescheme (idop,schem) = + match schem with + | InductionScheme (dep,ind,s) -> + (match idop with + | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() + | None -> spc () + ) ++ + hov 0 ((if dep then keyword "Induction for" else keyword "Minimality for") + ++ spc() ++ pr_smart_global ind) ++ spc() ++ + hov 0 (keyword "Sort" ++ spc() ++ Sorts.pr_sort_family s) + | CaseScheme (dep,ind,s) -> + (match idop with + | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() + | None -> spc () + ) ++ + hov 0 ((if dep then keyword "Elimination for" else keyword "Case for") + ++ spc() ++ pr_smart_global ind) ++ spc() ++ + hov 0 (keyword "Sort" ++ spc() ++ Sorts.pr_sort_family s) + | EqualityScheme ind -> + (match idop with + | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() + | None -> spc() + ) ++ + hov 0 (keyword "Equality for") + ++ spc() ++ pr_smart_global ind + +let begin_of_inductive = function + | [] -> 0 + | (_,({loc},_))::_ -> Option.cata (fun loc -> fst (Loc.unloc loc)) 0 loc + +let pr_class_rawexpr = function + | FunClass -> keyword "Funclass" + | SortClass -> keyword "Sortclass" + | RefClass qid -> pr_smart_global qid + +let pr_assumption_token many discharge kind = + match discharge, kind with + | (NoDischarge,Decls.Logical) -> + keyword (if many then "Axioms" else "Axiom") + | (NoDischarge,Decls.Definitional) -> + keyword (if many then "Parameters" else "Parameter") + | (NoDischarge,Decls.Conjectural) -> str"Conjecture" + | (DoDischarge,Decls.Logical) -> + keyword (if many then "Hypotheses" else "Hypothesis") + | (DoDischarge,Decls.Definitional) -> + keyword (if many then "Variables" else "Variable") + | (DoDischarge,Decls.Conjectural) -> + anomaly (Pp.str "Don't know how to beautify a local conjecture.") + | (_,Decls.Context) -> + anomaly (Pp.str "Context is used only internally.") + +let pr_params pr_c (xl,(c,t)) = + hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++ + (if c then str":>" else str":" ++ + spc() ++ pr_c t)) + +let rec factorize = function + | [] -> [] + | (c,(idl,t))::l -> match factorize l with - | [p] -> pr_params pr_c p - | l -> - prlist_with_sep spc - (fun p -> hov 1 (str "(" ++ pr_params pr_c p ++ str ")")) l + | (xl,((c', t') as r))::l' + when (c : bool) == c' && (=) t t' -> + (* FIXME: we need equality on constr_expr *) + (idl@xl,r)::l' + | l' -> (idl,(c,t))::l' + +let pr_ne_params_list pr_c l = + match factorize l with + | [p] -> pr_params pr_c p + | l -> + prlist_with_sep spc + (fun p -> hov 1 (str "(" ++ pr_params pr_c p ++ str ")")) l (* prlist_with_sep pr_semicolon (pr_params pr_c) *) - let pr_thm_token k = keyword (string_of_theorem_kind k) +let pr_thm_token k = keyword (string_of_theorem_kind k) - let pr_syntax_modifier = let open Gramlib.Gramext in function +let pr_syntax_modifier = let open Gramlib.Gramext in function | SetItemLevel (l,bko,n) -> prlist_with_sep sep_v2 str l ++ spc () ++ pr_at_level n ++ pr_opt pr_constr_as_binder_kind bko @@ -449,861 +449,861 @@ open Pputils | SetFormat("text",s) -> keyword "format " ++ pr_ast qs s | SetFormat(k,s) -> keyword "format " ++ qs k ++ spc() ++ pr_ast qs s - let pr_syntax_modifiers = function - | [] -> mt() - | l -> spc() ++ - hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") - - let pr_only_parsing_clause onlyparsing = - pr_syntax_modifiers (if onlyparsing then [SetOnlyParsing] else []) - - let pr_decl_notation prc decl_ntn = - let open Vernacexpr in - let - { decl_ntn_string = {CAst.loc;v=ntn}; - decl_ntn_interp = c; - decl_ntn_only_parsing = onlyparsing; - decl_ntn_scope = scopt } = decl_ntn in - fnl () ++ keyword "where " ++ qs ntn ++ str " := " - ++ Flags.without_option Flags.beautify prc c - ++ pr_only_parsing_clause onlyparsing - ++ pr_opt (fun sc -> str ": " ++ str sc) scopt - - let pr_rec_definition { fname; univs; rec_order; binders; rtype; body_def; notations } = - let env = Global.env () in - let sigma = Evd.from_env env in - let pr_pure_lconstr c = Flags.without_option Flags.beautify pr_lconstr c in - let annot = pr_guard_annot (pr_lconstr_expr env sigma) binders rec_order in - pr_ident_decl (fname,univs) ++ pr_binders_arg binders ++ annot - ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr env sigma c) rtype - ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_pure_lconstr env sigma def) body_def - ++ prlist (pr_decl_notation @@ pr_constr env sigma) notations - - let pr_statement head (idpl,(bl,c)) = - let env = Global.env () in - let sigma = Evd.from_env env in - hov 2 - (head ++ spc() ++ pr_ident_decl idpl ++ spc() ++ - (match bl with [] -> mt() | _ -> pr_binders env sigma bl ++ spc()) ++ - str":" ++ pr_spc_lconstr c) +let pr_syntax_modifiers = function + | [] -> mt() + | l -> spc() ++ + hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") + +let pr_only_parsing_clause onlyparsing = + pr_syntax_modifiers (if onlyparsing then [SetOnlyParsing] else []) + +let pr_decl_notation prc decl_ntn = + let open Vernacexpr in + let + { decl_ntn_string = {CAst.loc;v=ntn}; + decl_ntn_interp = c; + decl_ntn_modifiers = modifiers; + decl_ntn_scope = scopt } = decl_ntn in + fnl () ++ keyword "where " ++ qs ntn ++ str " := " + ++ Flags.without_option Flags.beautify prc c + ++ pr_syntax_modifiers modifiers + ++ pr_opt (fun sc -> str ": " ++ str sc) scopt + +let pr_rec_definition { fname; univs; rec_order; binders; rtype; body_def; notations } = + let env = Global.env () in + let sigma = Evd.from_env env in + let pr_pure_lconstr c = Flags.without_option Flags.beautify pr_lconstr c in + let annot = pr_guard_annot (pr_lconstr_expr env sigma) binders rec_order in + pr_ident_decl (fname,univs) ++ pr_binders_arg binders ++ annot + ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr env sigma c) rtype + ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_pure_lconstr env sigma def) body_def + ++ prlist (pr_decl_notation @@ pr_constr env sigma) notations + +let pr_statement head (idpl,(bl,c)) = + let env = Global.env () in + let sigma = Evd.from_env env in + hov 2 + (head ++ spc() ++ pr_ident_decl idpl ++ spc() ++ + (match bl with [] -> mt() | _ -> pr_binders env sigma bl ++ spc()) ++ + str":" ++ pr_spc_lconstr c) (**************************************) (* Pretty printer for vernac commands *) (**************************************) - let pr_constrarg c = - let env = Global.env () in - let sigma = Evd.from_env env in - spc () ++ pr_constr env sigma c - let pr_lconstrarg c = - let env = Global.env () in - let sigma = Evd.from_env env in - spc () ++ pr_lconstr env sigma c - let pr_intarg n = spc () ++ int n - - let pr_oc = function - | None -> str" :" - | Some true -> str" :>" - | Some false -> str" :>>" - - let pr_record_field (x, { rf_subclass = oc ; rf_priority = pri ; rf_notation = ntn }) = - let env = Global.env () in - let sigma = Evd.from_env env in - let prx = match x with - | AssumExpr (id,t) -> - hov 1 (pr_lname id ++ +let pr_constrarg c = + let env = Global.env () in + let sigma = Evd.from_env env in + spc () ++ pr_constr env sigma c +let pr_lconstrarg c = + let env = Global.env () in + let sigma = Evd.from_env env in + spc () ++ pr_lconstr env sigma c +let pr_intarg n = spc () ++ int n + +let pr_oc = function + | None -> str" :" + | Some true -> str" :>" + | Some false -> str" :>>" + +let pr_record_field (x, { rf_subclass = oc ; rf_priority = pri ; rf_notation = ntn }) = + let env = Global.env () in + let sigma = Evd.from_env env in + let prx = match x with + | AssumExpr (id,t) -> + hov 1 (pr_lname id ++ + pr_oc oc ++ spc() ++ + pr_lconstr_expr env sigma t) + | DefExpr(id,b,opt) -> (match opt with + | Some t -> + hov 1 (pr_lname id ++ pr_oc oc ++ spc() ++ - pr_lconstr_expr env sigma t) - | DefExpr(id,b,opt) -> (match opt with - | Some t -> - hov 1 (pr_lname id ++ - pr_oc oc ++ spc() ++ - pr_lconstr_expr env sigma t ++ str" :=" ++ pr_lconstr env sigma b) - | None -> - hov 1 (pr_lname id ++ str" :=" ++ spc() ++ - pr_lconstr env sigma b)) in - let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in - prx ++ prpri ++ prlist (pr_decl_notation @@ pr_constr env sigma) ntn - - let pr_record_decl c fs = - pr_opt pr_lident c ++ (if c = None then str"{" else str" {") ++ - hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}") - - let pr_printable = function - | PrintFullContext -> - keyword "Print All" - | PrintSectionContext s -> - keyword "Print Section" ++ spc() ++ Libnames.pr_qualid s - | PrintGrammar ent -> - keyword "Print Grammar" ++ spc() ++ str ent - | PrintCustomGrammar ent -> - keyword "Print Custom Grammar" ++ spc() ++ str ent - | PrintLoadPath dir -> - keyword "Print LoadPath" ++ pr_opt DirPath.print dir - | PrintModules -> - keyword "Print Modules" - | PrintMLLoadPath -> - keyword "Print ML Path" - | PrintMLModules -> - keyword "Print ML Modules" - | PrintDebugGC -> - keyword "Print ML GC" - | PrintGraph -> - keyword "Print Graph" - | PrintClasses -> - keyword "Print Classes" - | PrintTypeClasses -> - keyword "Print TypeClasses" - | PrintInstances qid -> - keyword "Print Instances" ++ spc () ++ pr_smart_global qid - | PrintCoercions -> - keyword "Print Coercions" - | PrintCoercionPaths (s,t) -> - keyword "Print Coercion Paths" ++ spc() - ++ pr_class_rawexpr s ++ spc() - ++ pr_class_rawexpr t - | PrintCanonicalConversions qids -> - keyword "Print Canonical Structures" ++ prlist pr_smart_global qids - | PrintTypingFlags -> - keyword "Print Typing Flags" - | PrintTables -> - keyword "Print Tables" - | PrintHintGoal -> - keyword "Print Hint" - | PrintHint qid -> - keyword "Print Hint" ++ spc () ++ pr_smart_global qid - | PrintHintDb -> - keyword "Print Hint *" - | PrintHintDbName s -> - keyword "Print HintDb" ++ spc () ++ str s - | PrintUniverses (b, g, fopt) -> - let cmd = - if b then "Print Sorted Universes" - else "Print Universes" - in - let pr_subgraph = prlist_with_sep spc pr_qualid in - keyword cmd ++ pr_opt pr_subgraph g ++ pr_opt str fopt - | PrintName (qid,udecl) -> - keyword "Print" ++ spc() ++ pr_smart_global qid ++ pr_univ_name_list udecl - | PrintModuleType qid -> - keyword "Print Module Type" ++ spc() ++ pr_qualid qid - | PrintModule qid -> - keyword "Print Module" ++ spc() ++ pr_qualid qid - | PrintInspect n -> - keyword "Inspect" ++ spc() ++ int n - | PrintScopes -> - keyword "Print Scopes" - | PrintScope s -> - keyword "Print Scope" ++ spc() ++ str s - | PrintVisibility s -> - keyword "Print Visibility" ++ pr_opt str s - | PrintAbout (qid,l,gopt) -> - pr_opt (fun g -> Goal_select.pr_goal_selector g ++ str ":"++ spc()) gopt - ++ keyword "About" ++ spc() ++ pr_smart_global qid ++ pr_univ_name_list l - | PrintImplicit qid -> - keyword "Print Implicit" ++ spc() ++ pr_smart_global qid - (* spiwack: command printing all the axioms and section variables used in a - term *) - | PrintAssumptions (b, t, qid) -> - let cmd = match b, t with - | true, true -> "Print All Dependencies" - | true, false -> "Print Opaque Dependencies" - | false, true -> "Print Transparent Dependencies" - | false, false -> "Print Assumptions" - in - keyword cmd ++ spc() ++ pr_smart_global qid - | PrintNamespace dp -> - keyword "Print Namespace" ++ DirPath.print dp - | PrintStrategy None -> - keyword "Print Strategies" - | PrintStrategy (Some qid) -> - keyword "Print Strategy" ++ pr_smart_global qid - | PrintRegistered -> - keyword "Print Registered" - - let pr_using e = - let rec aux = function - | SsEmpty -> "()" - | SsType -> "(Type)" - | SsSingl { v=id } -> "("^Id.to_string id^")" - | SsCompl e -> "-" ^ aux e^"" - | SsUnion(e1,e2) -> "("^aux e1 ^" + "^ aux e2^")" - | SsSubstr(e1,e2) -> "("^aux e1 ^" - "^ aux e2^")" - | SsFwdClose e -> "("^aux e^")*" - in Pp.str (aux e) - - let pr_extend s cl = - let pr_arg a = - try pr_gen a - with Failure _ -> str "<error in " ++ str (fst s) ++ str ">" in - try - let rl = Egramml.get_extend_vernac_rule s in - let rec aux rl cl = - match rl, cl with - | Egramml.GramNonTerminal _ :: rl, arg :: cl -> pr_arg arg :: aux rl cl - | Egramml.GramTerminal s :: rl, cl -> str s :: aux rl cl - | [], [] -> [] - | _ -> assert false in - hov 1 (pr_sequence identity (aux rl cl)) - with Not_found -> - hov 1 (str "TODO(" ++ str (fst s) ++ spc () ++ prlist_with_sep sep pr_arg cl ++ str ")") - - let pr_vernac_expr v = - let return = tag_vernac v in - let env = Global.env () in - let sigma = Evd.from_env env in - match v with - | VernacLoad (f,s) -> - return ( - keyword "Load" - ++ if f then - (spc() ++ keyword "Verbose" ++ spc()) - else - spc() ++ qs s - ) - - (* Proof management *) - | VernacAbortAll -> - return (keyword "Abort All") - | VernacRestart -> - return (keyword "Restart") - | VernacUnfocus -> - return (keyword "Unfocus") - | VernacUnfocused -> - return (keyword "Unfocused") - | VernacAbort id -> - return (keyword "Abort" ++ pr_opt pr_lident id) - | VernacUndo i -> - return ( - if Int.equal i 1 then keyword "Undo" else keyword "Undo" ++ pr_intarg i - ) - | VernacUndoTo i -> - return (keyword "Undo" ++ spc() ++ keyword "To" ++ pr_intarg i) - | VernacFocus i -> - return (keyword "Focus" ++ pr_opt int i) - | VernacShow s -> - let pr_goal_reference = function - | OpenSubgoals -> mt () - | NthGoal n -> spc () ++ int n - | GoalId id -> spc () ++ pr_id id - in - let pr_showable = function - | ShowGoal n -> keyword "Show" ++ pr_goal_reference n - | ShowProof -> keyword "Show Proof" - | ShowExistentials -> keyword "Show Existentials" - | ShowUniverses -> keyword "Show Universes" - | ShowProofNames -> keyword "Show Conjectures" - | ShowIntros b -> keyword "Show " ++ (if b then keyword "Intros" else keyword "Intro") - | ShowMatch id -> keyword "Show Match " ++ pr_qualid id - in - return (pr_showable s) - | VernacCheckGuard -> - return (keyword "Guarded") - - (* Resetting *) - | VernacResetName id -> - return (keyword "Reset" ++ spc() ++ pr_lident id) - | VernacResetInitial -> - return (keyword "Reset Initial") - | VernacBack i -> - return ( - if Int.equal i 1 then keyword "Back" else keyword "Back" ++ pr_intarg i - ) - - (* State management *) - | VernacWriteState s -> - return (keyword "Write State" ++ spc () ++ qs s) - | VernacRestoreState s -> - return (keyword "Restore State" ++ spc() ++ qs s) - - (* Syntax *) - | VernacOpenCloseScope (opening,sc) -> - return ( - keyword (if opening then "Open " else "Close ") ++ - keyword "Scope" ++ spc() ++ str sc - ) - | VernacDeclareScope sc -> - return ( - keyword "Declare Scope" ++ spc () ++ str sc - ) - | VernacDelimiters (sc,Some key) -> - return ( - keyword "Delimit Scope" ++ spc () ++ str sc ++ - spc() ++ keyword "with" ++ spc () ++ str key - ) - | VernacDelimiters (sc, None) -> - return ( - keyword "Undelimit Scope" ++ spc () ++ str sc - ) - | VernacBindScope (sc,cll) -> - return ( - keyword "Bind Scope" ++ spc () ++ str sc ++ - spc() ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_class_rawexpr cll - ) - | VernacInfix (({v=s},mv),q,sn) -> (* A Verifier *) - return ( - hov 0 (hov 0 (keyword "Infix " - ++ qs s ++ str " :=" ++ pr_constrarg q) ++ - pr_syntax_modifiers mv ++ - (match sn with - | None -> mt() - | Some sc -> spc() ++ str":" ++ spc() ++ str sc)) - ) - | VernacNotation (c,({v=s},l),opt) -> - return ( - hov 2 (keyword "Notation" ++ spc() ++ qs s ++ - str " :=" ++ Flags.without_option Flags.beautify pr_constrarg c ++ pr_syntax_modifiers l ++ - (match opt with - | None -> mt() - | Some sc -> str" :" ++ spc() ++ str sc)) - ) - | VernacSyntaxExtension (_, (s, l)) -> - return ( - keyword "Reserved Notation" ++ spc() ++ pr_ast qs s ++ - pr_syntax_modifiers l - ) - | VernacNotationAddFormat(s,k,v) -> - return ( - keyword "Format Notation " ++ qs s ++ spc () ++ qs k ++ spc() ++ qs v - ) - | VernacDeclareCustomEntry s -> - return ( - keyword "Declare Custom Entry " ++ str s - ) - - (* Gallina *) - | VernacDefinition ((discharge,kind),id,b) -> (* A verifier... *) - let pr_def_token dk = - keyword ( - if Name.is_anonymous (fst id).v - then "Goal" - else string_of_definition_object_kind dk) - in - let pr_reduce = function - | None -> mt() - | Some r -> - keyword "Eval" ++ spc() ++ - Ppred.pr_red_expr_env env sigma (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ - keyword " in" ++ spc() - in - let pr_def_body = function - | DefineBody (bl,red,body,d) -> - let ty = match d with + pr_lconstr_expr env sigma t ++ str" :=" ++ pr_lconstr env sigma b) + | None -> + hov 1 (pr_lname id ++ str" :=" ++ spc() ++ + pr_lconstr env sigma b)) in + let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in + prx ++ prpri ++ prlist (pr_decl_notation @@ pr_constr env sigma) ntn + +let pr_record_decl c fs = + pr_opt pr_lident c ++ (if c = None then str"{" else str" {") ++ + hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}") + +let pr_printable = function + | PrintFullContext -> + keyword "Print All" + | PrintSectionContext s -> + keyword "Print Section" ++ spc() ++ Libnames.pr_qualid s + | PrintGrammar ent -> + keyword "Print Grammar" ++ spc() ++ str ent + | PrintCustomGrammar ent -> + keyword "Print Custom Grammar" ++ spc() ++ str ent + | PrintLoadPath dir -> + keyword "Print LoadPath" ++ pr_opt DirPath.print dir + | PrintModules -> + keyword "Print Modules" + | PrintMLLoadPath -> + keyword "Print ML Path" + | PrintMLModules -> + keyword "Print ML Modules" + | PrintDebugGC -> + keyword "Print ML GC" + | PrintGraph -> + keyword "Print Graph" + | PrintClasses -> + keyword "Print Classes" + | PrintTypeClasses -> + keyword "Print TypeClasses" + | PrintInstances qid -> + keyword "Print Instances" ++ spc () ++ pr_smart_global qid + | PrintCoercions -> + keyword "Print Coercions" + | PrintCoercionPaths (s,t) -> + keyword "Print Coercion Paths" ++ spc() + ++ pr_class_rawexpr s ++ spc() + ++ pr_class_rawexpr t + | PrintCanonicalConversions qids -> + keyword "Print Canonical Structures" ++ prlist pr_smart_global qids + | PrintTypingFlags -> + keyword "Print Typing Flags" + | PrintTables -> + keyword "Print Tables" + | PrintHintGoal -> + keyword "Print Hint" + | PrintHint qid -> + keyword "Print Hint" ++ spc () ++ pr_smart_global qid + | PrintHintDb -> + keyword "Print Hint *" + | PrintHintDbName s -> + keyword "Print HintDb" ++ spc () ++ str s + | PrintUniverses (b, g, fopt) -> + let cmd = + if b then "Print Sorted Universes" + else "Print Universes" + in + let pr_subgraph = prlist_with_sep spc pr_qualid in + keyword cmd ++ pr_opt pr_subgraph g ++ pr_opt str fopt + | PrintName (qid,udecl) -> + keyword "Print" ++ spc() ++ pr_smart_global qid ++ pr_univ_name_list udecl + | PrintModuleType qid -> + keyword "Print Module Type" ++ spc() ++ pr_qualid qid + | PrintModule qid -> + keyword "Print Module" ++ spc() ++ pr_qualid qid + | PrintInspect n -> + keyword "Inspect" ++ spc() ++ int n + | PrintScopes -> + keyword "Print Scopes" + | PrintScope s -> + keyword "Print Scope" ++ spc() ++ str s + | PrintVisibility s -> + keyword "Print Visibility" ++ pr_opt str s + | PrintAbout (qid,l,gopt) -> + pr_opt (fun g -> Goal_select.pr_goal_selector g ++ str ":"++ spc()) gopt + ++ keyword "About" ++ spc() ++ pr_smart_global qid ++ pr_univ_name_list l + | PrintImplicit qid -> + keyword "Print Implicit" ++ spc() ++ pr_smart_global qid + (* spiwack: command printing all the axioms and section variables used in a + term *) + | PrintAssumptions (b, t, qid) -> + let cmd = match b, t with + | true, true -> "Print All Dependencies" + | true, false -> "Print Opaque Dependencies" + | false, true -> "Print Transparent Dependencies" + | false, false -> "Print Assumptions" + in + keyword cmd ++ spc() ++ pr_smart_global qid + | PrintNamespace dp -> + keyword "Print Namespace" ++ DirPath.print dp + | PrintStrategy None -> + keyword "Print Strategies" + | PrintStrategy (Some qid) -> + keyword "Print Strategy" ++ pr_smart_global qid + | PrintRegistered -> + keyword "Print Registered" + +let pr_using e = + let rec aux = function + | SsEmpty -> "()" + | SsType -> "(Type)" + | SsSingl { v=id } -> "("^Id.to_string id^")" + | SsCompl e -> "-" ^ aux e^"" + | SsUnion(e1,e2) -> "("^aux e1 ^" + "^ aux e2^")" + | SsSubstr(e1,e2) -> "("^aux e1 ^" - "^ aux e2^")" + | SsFwdClose e -> "("^aux e^")*" + in Pp.str (aux e) + +let pr_extend s cl = + let pr_arg a = + try pr_gen a + with Failure _ -> str "<error in " ++ str (fst s) ++ str ">" in + try + let rl = Egramml.get_extend_vernac_rule s in + let rec aux rl cl = + match rl, cl with + | Egramml.GramNonTerminal _ :: rl, arg :: cl -> pr_arg arg :: aux rl cl + | Egramml.GramTerminal s :: rl, cl -> str s :: aux rl cl + | [], [] -> [] + | _ -> assert false in + hov 1 (pr_sequence identity (aux rl cl)) + with Not_found -> + hov 1 (str "TODO(" ++ str (fst s) ++ spc () ++ prlist_with_sep sep pr_arg cl ++ str ")") + +let pr_vernac_expr v = + let return = tag_vernac v in + let env = Global.env () in + let sigma = Evd.from_env env in + match v with + | VernacLoad (f,s) -> + return ( + keyword "Load" + ++ if f then + (spc() ++ keyword "Verbose" ++ spc()) + else + spc() ++ qs s + ) + + (* Proof management *) + | VernacAbortAll -> + return (keyword "Abort All") + | VernacRestart -> + return (keyword "Restart") + | VernacUnfocus -> + return (keyword "Unfocus") + | VernacUnfocused -> + return (keyword "Unfocused") + | VernacAbort id -> + return (keyword "Abort" ++ pr_opt pr_lident id) + | VernacUndo i -> + return ( + if Int.equal i 1 then keyword "Undo" else keyword "Undo" ++ pr_intarg i + ) + | VernacUndoTo i -> + return (keyword "Undo" ++ spc() ++ keyword "To" ++ pr_intarg i) + | VernacFocus i -> + return (keyword "Focus" ++ pr_opt int i) + | VernacShow s -> + let pr_goal_reference = function + | OpenSubgoals -> mt () + | NthGoal n -> spc () ++ int n + | GoalId id -> spc () ++ pr_id id + in + let pr_showable = function + | ShowGoal n -> keyword "Show" ++ pr_goal_reference n + | ShowProof -> keyword "Show Proof" + | ShowExistentials -> keyword "Show Existentials" + | ShowUniverses -> keyword "Show Universes" + | ShowProofNames -> keyword "Show Conjectures" + | ShowIntros b -> keyword "Show " ++ (if b then keyword "Intros" else keyword "Intro") + | ShowMatch id -> keyword "Show Match " ++ pr_qualid id + in + return (pr_showable s) + | VernacCheckGuard -> + return (keyword "Guarded") + + (* Resetting *) + | VernacResetName id -> + return (keyword "Reset" ++ spc() ++ pr_lident id) + | VernacResetInitial -> + return (keyword "Reset Initial") + | VernacBack i -> + return ( + if Int.equal i 1 then keyword "Back" else keyword "Back" ++ pr_intarg i + ) + + (* State management *) + | VernacWriteState s -> + return (keyword "Write State" ++ spc () ++ qs s) + | VernacRestoreState s -> + return (keyword "Restore State" ++ spc() ++ qs s) + + (* Syntax *) + | VernacOpenCloseScope (opening,sc) -> + return ( + keyword (if opening then "Open " else "Close ") ++ + keyword "Scope" ++ spc() ++ str sc + ) + | VernacDeclareScope sc -> + return ( + keyword "Declare Scope" ++ spc () ++ str sc + ) + | VernacDelimiters (sc,Some key) -> + return ( + keyword "Delimit Scope" ++ spc () ++ str sc ++ + spc() ++ keyword "with" ++ spc () ++ str key + ) + | VernacDelimiters (sc, None) -> + return ( + keyword "Undelimit Scope" ++ spc () ++ str sc + ) + | VernacBindScope (sc,cll) -> + return ( + keyword "Bind Scope" ++ spc () ++ str sc ++ + spc() ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_class_rawexpr cll + ) + | VernacInfix (({v=s},mv),q,sn) -> (* A Verifier *) + return ( + hov 0 (hov 0 (keyword "Infix " + ++ qs s ++ str " :=" ++ pr_constrarg q) ++ + pr_syntax_modifiers mv ++ + (match sn with | None -> mt() - | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty - in - (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr env sigma body)) - | ProveBody (bl,t) -> - let typ u = if (fst id).v = Anonymous then (assert (bl = []); u) else (str" :" ++ u) in - (pr_binders_arg bl, typ (pr_spc_lconstr t), None) in - let (binds,typ,c) = pr_def_body b in - return ( - hov 2 ( - pr_def_token kind ++ spc() - ++ pr_lname_decl id ++ binds ++ typ - ++ (match c with + | Some sc -> spc() ++ str":" ++ spc() ++ str sc)) + ) + | VernacNotation (c,({v=s},l),opt) -> + return ( + hov 2 (keyword "Notation" ++ spc() ++ qs s ++ + str " :=" ++ Flags.without_option Flags.beautify pr_constrarg c ++ pr_syntax_modifiers l ++ + (match opt with | None -> mt() - | Some cc -> str" :=" ++ spc() ++ cc)) - ) - - | VernacStartTheoremProof (ki,l) -> - return ( - hov 1 (pr_statement (pr_thm_token ki) (List.hd l) ++ - prlist (pr_statement (spc () ++ keyword "with")) (List.tl l)) - ) - - | VernacEndProof Admitted -> - return (keyword "Admitted") - - | VernacEndProof (Proved (opac,o)) -> return ( - match o with - | None -> (match opac with - | Transparent -> keyword "Defined" - | Opaque -> keyword "Qed") - | Some id -> (if opac <> Transparent then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id - ) - | VernacExactProof c -> - return (hov 2 (keyword "Proof" ++ pr_lconstrarg c)) - | VernacAssumption ((discharge,kind),t,l) -> - let n = List.length (List.flatten (List.map fst (List.map snd l))) in - let pr_params (c, (xl, t)) = - hov 2 (prlist_with_sep sep pr_ident_decl xl ++ spc() ++ - (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr env sigma t)) in - let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in - return (hov 2 (pr_assumption_token (n > 1) discharge kind ++ - pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions)) - | VernacInductive (f,l) -> - let pr_constructor (coe,(id,c)) = - hov 2 (pr_lident id ++ str" " ++ - (if coe then str":>" else str":") ++ - Flags.without_option Flags.beautify pr_spc_lconstr c) - in - let pr_constructor_list l = match l with - | Constructors [] -> mt() - | Constructors l -> - let fst_sep = match l with [_] -> " " | _ -> " | " in - pr_com_at (begin_of_inductive l) ++ - fnl() ++ str fst_sep ++ - prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l - | RecordDecl (c,fs) -> - pr_record_decl c fs - in - let pr_oneind key (((coe,iddecl),(indupar,indpar),s,lc),ntn) = - hov 0 ( - str key ++ spc() ++ - (if coe then str"> " else str"") ++ pr_ident_decl iddecl ++ - pr_and_type_binders_arg indupar ++ - pr_opt (fun p -> str "|" ++ spc() ++ pr_and_type_binders_arg p) indpar ++ - pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr env sigma s) s ++ - str" :=") ++ pr_constructor_list lc ++ - prlist (pr_decl_notation @@ pr_constr env sigma) ntn - in - let kind = - match f with - | Record -> "Record" | Structure -> "Structure" - | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" - | Class _ -> "Class" | Variant -> "Variant" - in - return ( - hov 1 (pr_oneind kind (List.hd l)) ++ - (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) - ) - - | VernacFixpoint (local, recs) -> - let local = match local with - | DoDischarge -> "Let " - | NoDischarge -> "" - in - return ( - hov 0 (str local ++ keyword "Fixpoint" ++ spc () ++ - prlist_with_sep (fun _ -> fnl () ++ keyword "with" - ++ spc ()) pr_rec_definition recs) - ) - - | VernacCoFixpoint (local, corecs) -> - let local = match local with - | DoDischarge -> keyword "Let" ++ spc () - | NoDischarge -> str "" - in - let pr_onecorec {fname; univs; binders; rtype; body_def; notations } = - pr_ident_decl (fname,univs) ++ spc() ++ pr_binders env sigma binders ++ spc() ++ str":" ++ - spc() ++ pr_lconstr_expr env sigma rtype ++ - pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr env sigma def) body_def ++ - prlist (pr_decl_notation @@ pr_constr env sigma) notations - in - return ( - hov 0 (local ++ keyword "CoFixpoint" ++ spc() ++ - prlist_with_sep (fun _ -> fnl() ++ keyword "with" ++ spc ()) pr_onecorec corecs) - ) - | VernacScheme l -> - return ( - hov 2 (keyword "Scheme" ++ spc() ++ - prlist_with_sep (fun _ -> fnl() ++ keyword "with" ++ spc ()) pr_onescheme l) - ) - | VernacCombinedScheme (id, l) -> - return ( - hov 2 (keyword "Combined Scheme" ++ spc() ++ - pr_lident id ++ spc() ++ keyword "from" ++ spc() ++ - prlist_with_sep (fun _ -> fnl() ++ str", ") pr_lident l) - ) - | VernacUniverse v -> - return ( - hov 2 (keyword "Universe" ++ spc () ++ - prlist_with_sep (fun _ -> str",") pr_lident v) - ) - | VernacConstraint v -> - return ( - hov 2 (keyword "Constraint" ++ spc () ++ - prlist_with_sep (fun _ -> str",") pr_uconstraint v) - ) - - (* Gallina extensions *) - | VernacBeginSection id -> - return (hov 2 (keyword "Section" ++ spc () ++ pr_lident id)) - | VernacEndSegment id -> - return (hov 2 (keyword "End" ++ spc() ++ pr_lident id)) - | VernacNameSectionHypSet (id,set) -> - return (hov 2 (keyword "Package" ++ spc() ++ pr_lident id ++ spc()++ - str ":="++spc()++pr_using set)) - | VernacRequire (from, exp, l) -> - let from = match from with - | None -> mt () - | Some r -> keyword "From" ++ spc () ++ pr_module r ++ spc () + | Some sc -> str" :" ++ spc() ++ str sc)) + ) + | VernacSyntaxExtension (_, (s, l)) -> + return ( + keyword "Reserved Notation" ++ spc() ++ pr_ast qs s ++ + pr_syntax_modifiers l + ) + | VernacNotationAddFormat(s,k,v) -> + return ( + keyword "Format Notation " ++ qs s ++ spc () ++ qs k ++ spc() ++ qs v + ) + | VernacDeclareCustomEntry s -> + return ( + keyword "Declare Custom Entry " ++ str s + ) + + (* Gallina *) + | VernacDefinition ((discharge,kind),id,b) -> (* A verifier... *) + let pr_def_token dk = + keyword ( + if Name.is_anonymous (fst id).v + then "Goal" + else string_of_definition_object_kind dk) + in + let pr_reduce = function + | None -> mt() + | Some r -> + keyword "Eval" ++ spc() ++ + Ppred.pr_red_expr_env env sigma (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ + keyword " in" ++ spc() + in + let pr_def_body = function + | DefineBody (bl,red,body,d) -> + let ty = match d with + | None -> mt() + | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty in - return ( - hov 2 - (from ++ keyword "Require" ++ spc() ++ pr_require_token exp ++ - prlist_with_sep sep pr_module l) - ) - | VernacImport (f,l) -> - return ( - (if f then keyword "Export" else keyword "Import") ++ spc() ++ - prlist_with_sep sep pr_import_module l - ) - | VernacCanonical q -> - return ( - keyword "Canonical Structure" ++ spc() ++ pr_smart_global q - ) - | VernacCoercion (id,c1,c2) -> - return ( - hov 1 ( - keyword "Coercion" ++ spc() ++ - pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ - spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2) - ) - | VernacIdentityCoercion (id,c1,c2) -> - return ( - hov 1 ( - keyword "Identity Coercion" ++ spc() ++ pr_lident id ++ - spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++ - spc() ++ pr_class_rawexpr c2) - ) - - | VernacInstance (instid, sup, cl, props, info) -> - return ( - hov 1 ( - keyword "Instance" ++ - (match instid with - | {loc; v = Name id}, l -> spc () ++ pr_ident_decl (CAst.(make ?loc id),l) ++ spc () - | { v = Anonymous }, _ -> mt ()) ++ - pr_and_type_binders_arg sup ++ - str":" ++ spc () ++ - pr_constr env sigma cl ++ pr_hint_info (pr_constr_pattern_expr env sigma) info ++ - (match props with - | Some (true, { v = CRecord l}) -> spc () ++ str":=" ++ spc () ++ str"{" ++ pr_record_body l ++ str "}" - | Some (true,_) -> assert false - | Some (false,p) -> spc () ++ str":=" ++ spc () ++ pr_constr env sigma p - | None -> mt())) - ) - - | VernacDeclareInstance (instid, sup, cl, info) -> - return ( - hov 1 ( - keyword "Declare Instance" ++ spc () ++ pr_ident_decl instid ++ spc () ++ - pr_and_type_binders_arg sup ++ - str":" ++ spc () ++ - pr_constr env sigma cl ++ pr_hint_info (pr_constr_pattern_expr env sigma) info) - ) - - | VernacContext l -> - return ( - hov 1 ( - keyword "Context" ++ pr_and_type_binders_arg l) - ) - - | VernacExistingInstance insts -> - let pr_inst (id, info) = - pr_qualid id ++ pr_hint_info (pr_constr_pattern_expr env sigma) info - in - return ( - hov 1 (keyword "Existing" ++ spc () ++ - keyword(String.plural (List.length insts) "Instance") ++ - spc () ++ prlist_with_sep (fun () -> str", ") pr_inst insts) - ) - - | VernacExistingClass id -> - return ( - hov 1 (keyword "Existing" ++ spc () ++ keyword "Class" ++ spc () ++ pr_qualid id) - ) - - (* Modules and Module Types *) - | VernacDefineModule (export,m,bl,tys,bd) -> - let b = pr_module_binders bl (pr_lconstr env sigma) in - return ( - hov 2 (keyword "Module" ++ spc() ++ pr_require_token export ++ - pr_lident m ++ b ++ - pr_of_module_type (pr_lconstr env sigma) tys ++ - (if List.is_empty bd then mt () else str ":= ") ++ - prlist_with_sep (fun () -> str " <+") - (pr_module_ast_inl true (pr_lconstr env sigma)) bd) - ) - | VernacDeclareModule (export,id,bl,m1) -> - let b = pr_module_binders bl (pr_lconstr env sigma) in - return ( - hov 2 (keyword "Declare Module" ++ spc() ++ pr_require_token export ++ - pr_lident id ++ b ++ str " :" ++ - pr_module_ast_inl true (pr_lconstr env sigma) m1) - ) - | VernacDeclareModuleType (id,bl,tyl,m) -> - let b = pr_module_binders bl (pr_lconstr env sigma) in - let pr_mt = pr_module_ast_inl true (pr_lconstr env sigma) in - return ( - hov 2 (keyword "Module Type " ++ pr_lident id ++ b ++ - prlist_strict (fun m -> str " <:" ++ pr_mt m) tyl ++ - (if List.is_empty m then mt () else str ":= ") ++ - prlist_with_sep (fun () -> str " <+ ") pr_mt m) - ) - | VernacInclude (mexprs) -> - let pr_m = pr_module_ast_inl false (pr_lconstr env sigma) in - return ( - hov 2 (keyword "Include" ++ spc() ++ - prlist_with_sep (fun () -> str " <+ ") pr_m mexprs) - ) - (* Solving *) - | VernacSolveExistential (i,c) -> - return (keyword "Existential" ++ spc () ++ int i ++ pr_lconstrarg c) - - (* Auxiliary file and library management *) - | VernacAddLoadPath { implicit; physical_path; logical_path } -> - return ( - hov 2 - (keyword "Add" ++ - (if implicit then spc () ++ keyword "Rec" ++ spc () else spc()) ++ - keyword "LoadPath" ++ spc() ++ qs physical_path ++ - spc() ++ keyword "as" ++ spc() ++ DirPath.print logical_path)) - | VernacRemoveLoadPath s -> - return (keyword "Remove LoadPath" ++ qs s) - | VernacAddMLPath (s) -> - return ( - keyword "Add" - ++ keyword "ML Path" - ++ qs s - ) - | VernacDeclareMLModule (l) -> - return ( - hov 2 (keyword "Declare ML Module" ++ spc() ++ prlist_with_sep sep qs l) - ) - | VernacChdir s -> - return (keyword "Cd" ++ pr_opt qs s) - - (* Commands *) - | VernacCreateHintDb (dbname,b) -> - return ( - hov 1 (keyword "Create HintDb" ++ spc () ++ - str dbname ++ (if b then str" discriminated" else mt ())) - ) - | VernacRemoveHints (dbnames, ids) -> - return ( - hov 1 (keyword "Remove Hints" ++ spc () ++ - prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++ - pr_opt_hintbases dbnames) - ) - | VernacHints (dbnames,h) -> - return (pr_hints dbnames h (pr_constr env sigma) (pr_constr_pattern_expr env sigma)) - | VernacSyntacticDefinition (id,(ids,c),{onlyparsing}) -> - return ( - hov 2 - (keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++ - prlist_with_sep spc pr_id ids ++ str":=" ++ pr_constrarg c ++ - pr_only_parsing_clause onlyparsing) - ) - | VernacArguments (q, args, more_implicits, mods) -> - return ( - hov 2 ( - keyword "Arguments" ++ spc() ++ - pr_smart_global q ++ - let pr_s = function None -> str"" | Some {v=s} -> str "%" ++ str s in - let pr_if b x = if b then x else str "" in - let pr_one_arg (x,k) = pr_if k (str"!") ++ Name.print x in - let pr_br imp force x = - let left,right = - match imp with - | Glob_term.NonMaxImplicit -> str "[", str "]" - | Glob_term.MaxImplicit -> str "{", str "}" - | Glob_term.Explicit -> if force then str"(",str")" else mt(),mt() - in - left ++ x ++ right - in - let get_arguments_like s imp tl = - if s = None && imp = Glob_term.Explicit then [], tl - else - let rec fold extra = function - | RealArg arg :: tl when - Option.equal (fun a b -> String.equal a.CAst.v b.CAst.v) arg.notation_scope s - && arg.implicit_status = imp -> - fold ((arg.name,arg.recarg_like) :: extra) tl - | args -> List.rev extra, args - in - fold [] tl - in - let rec print_arguments = function - | [] -> mt() - | VolatileArg :: l -> spc () ++ str"/" ++ print_arguments l - | BidiArg :: l -> spc () ++ str"&" ++ print_arguments l - | RealArg { name = id; recarg_like = k; - notation_scope = s; - implicit_status = imp } :: tl -> - let extra, tl = get_arguments_like s imp tl in - spc() ++ pr_br imp (extra<>[]) (prlist_with_sep spc pr_one_arg ((id,k)::extra)) ++ - pr_s s ++ print_arguments tl - in - let rec print_implicits = function - | [] -> mt () - | (name, impl) :: rest -> - spc() ++ pr_br impl false (Name.print name) ++ print_implicits rest - in - print_arguments args ++ - if not (List.is_empty more_implicits) then - prlist (fun l -> str"," ++ print_implicits l) more_implicits - else (mt ()) ++ - (if not (List.is_empty mods) then str" : " else str"") ++ - prlist_with_sep (fun () -> str", " ++ spc()) (function - | `ReductionDontExposeCase -> keyword "simpl nomatch" - | `ReductionNeverUnfold -> keyword "simpl never" - | `DefaultImplicits -> keyword "default implicits" - | `Rename -> keyword "rename" - | `Assert -> keyword "assert" - | `ExtraScopes -> keyword "extra scopes" - | `ClearImplicits -> keyword "clear implicits" - | `ClearScopes -> keyword "clear scopes" - | `ClearBidiHint -> keyword "clear bidirectionality hint") - mods) - ) - | VernacReserve bl -> - let n = List.length (List.flatten (List.map fst bl)) in - return ( - hov 2 (tag_keyword (str"Implicit Type" ++ str (if n > 1 then "s " else " ")) - ++ pr_ne_params_list (pr_lconstr_expr env sigma) (List.map (fun sb -> false,sb) bl)) - ) - | VernacGeneralizable g -> - return ( - hov 1 (tag_keyword ( - str"Generalizable Variable" ++ - match g with - | None -> str "s none" - | Some [] -> str "s all" - | Some idl -> - str (if List.length idl > 1 then "s " else " ") ++ - prlist_with_sep spc pr_lident idl) - )) - | VernacSetOpacity(k,l) when Conv_oracle.is_transparent k -> - return ( - hov 1 (keyword "Transparent" ++ - spc() ++ prlist_with_sep sep pr_smart_global l) - ) - | VernacSetOpacity(Conv_oracle.Opaque,l) -> - return ( - hov 1 (keyword "Opaque" ++ - spc() ++ prlist_with_sep sep pr_smart_global l) - ) - | VernacSetOpacity _ -> - return ( - CErrors.anomaly (keyword "VernacSetOpacity used to set something else.") - ) - | VernacSetStrategy l -> - let pr_lev = function - | Conv_oracle.Opaque -> keyword "opaque" - | Conv_oracle.Expand -> keyword "expand" - | l when Conv_oracle.is_transparent l -> keyword "transparent" - | Conv_oracle.Level n -> int n + (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr env sigma body)) + | ProveBody (bl,t) -> + let typ u = if (fst id).v = Anonymous then (assert (bl = []); u) else (str" :" ++ u) in + (pr_binders_arg bl, typ (pr_spc_lconstr t), None) in + let (binds,typ,c) = pr_def_body b in + return ( + hov 2 ( + pr_def_token kind ++ spc() + ++ pr_lname_decl id ++ binds ++ typ + ++ (match c with + | None -> mt() + | Some cc -> str" :=" ++ spc() ++ cc)) + ) + + | VernacStartTheoremProof (ki,l) -> + return ( + hov 1 (pr_statement (pr_thm_token ki) (List.hd l) ++ + prlist (pr_statement (spc () ++ keyword "with")) (List.tl l)) + ) + + | VernacEndProof Admitted -> + return (keyword "Admitted") + + | VernacEndProof (Proved (opac,o)) -> return ( + match o with + | None -> (match opac with + | Transparent -> keyword "Defined" + | Opaque -> keyword "Qed") + | Some id -> (if opac <> Transparent then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id + ) + | VernacExactProof c -> + return (hov 2 (keyword "Proof" ++ pr_lconstrarg c)) + | VernacAssumption ((discharge,kind),t,l) -> + let n = List.length (List.flatten (List.map fst (List.map snd l))) in + let pr_params (c, (xl, t)) = + hov 2 (prlist_with_sep sep pr_ident_decl xl ++ spc() ++ + (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr env sigma t)) in + let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in + return (hov 2 (pr_assumption_token (n > 1) discharge kind ++ + pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions)) + | VernacInductive (f,l) -> + let pr_constructor (coe,(id,c)) = + hov 2 (pr_lident id ++ str" " ++ + (if coe then str":>" else str":") ++ + Flags.without_option Flags.beautify pr_spc_lconstr c) + in + let pr_constructor_list l = match l with + | Constructors [] -> mt() + | Constructors l -> + let fst_sep = match l with [_] -> " " | _ -> " | " in + pr_com_at (begin_of_inductive l) ++ + fnl() ++ str fst_sep ++ + prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l + | RecordDecl (c,fs) -> + pr_record_decl c fs + in + let pr_oneind key (((coe,iddecl),(indupar,indpar),s,lc),ntn) = + hov 0 ( + str key ++ spc() ++ + (if coe then str"> " else str"") ++ pr_ident_decl iddecl ++ + pr_and_type_binders_arg indupar ++ + pr_opt (fun p -> str "|" ++ spc() ++ pr_and_type_binders_arg p) indpar ++ + pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr env sigma s) s ++ + str" :=") ++ pr_constructor_list lc ++ + prlist (pr_decl_notation @@ pr_constr env sigma) ntn + in + let kind = + match f with + | Record -> "Record" | Structure -> "Structure" + | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" + | Class _ -> "Class" | Variant -> "Variant" + in + return ( + hov 1 (pr_oneind kind (List.hd l)) ++ + (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) + ) + + | VernacFixpoint (local, recs) -> + let local = match local with + | DoDischarge -> "Let " + | NoDischarge -> "" + in + return ( + hov 0 (str local ++ keyword "Fixpoint" ++ spc () ++ + prlist_with_sep (fun _ -> fnl () ++ keyword "with" + ++ spc ()) pr_rec_definition recs) + ) + + | VernacCoFixpoint (local, corecs) -> + let local = match local with + | DoDischarge -> keyword "Let" ++ spc () + | NoDischarge -> str "" + in + let pr_onecorec {fname; univs; binders; rtype; body_def; notations } = + pr_ident_decl (fname,univs) ++ spc() ++ pr_binders env sigma binders ++ spc() ++ str":" ++ + spc() ++ pr_lconstr_expr env sigma rtype ++ + pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr env sigma def) body_def ++ + prlist (pr_decl_notation @@ pr_constr env sigma) notations + in + return ( + hov 0 (local ++ keyword "CoFixpoint" ++ spc() ++ + prlist_with_sep (fun _ -> fnl() ++ keyword "with" ++ spc ()) pr_onecorec corecs) + ) + | VernacScheme l -> + return ( + hov 2 (keyword "Scheme" ++ spc() ++ + prlist_with_sep (fun _ -> fnl() ++ keyword "with" ++ spc ()) pr_onescheme l) + ) + | VernacCombinedScheme (id, l) -> + return ( + hov 2 (keyword "Combined Scheme" ++ spc() ++ + pr_lident id ++ spc() ++ keyword "from" ++ spc() ++ + prlist_with_sep (fun _ -> fnl() ++ str", ") pr_lident l) + ) + | VernacUniverse v -> + return ( + hov 2 (keyword "Universe" ++ spc () ++ + prlist_with_sep (fun _ -> str",") pr_lident v) + ) + | VernacConstraint v -> + return ( + hov 2 (keyword "Constraint" ++ spc () ++ + prlist_with_sep (fun _ -> str",") pr_uconstraint v) + ) + + (* Gallina extensions *) + | VernacBeginSection id -> + return (hov 2 (keyword "Section" ++ spc () ++ pr_lident id)) + | VernacEndSegment id -> + return (hov 2 (keyword "End" ++ spc() ++ pr_lident id)) + | VernacNameSectionHypSet (id,set) -> + return (hov 2 (keyword "Package" ++ spc() ++ pr_lident id ++ spc()++ + str ":="++spc()++pr_using set)) + | VernacRequire (from, exp, l) -> + let from = match from with + | None -> mt () + | Some r -> keyword "From" ++ spc () ++ pr_module r ++ spc () + in + return ( + hov 2 + (from ++ keyword "Require" ++ spc() ++ pr_require_token exp ++ + prlist_with_sep sep pr_module l) + ) + | VernacImport (f,l) -> + return ( + (if f then keyword "Export" else keyword "Import") ++ spc() ++ + prlist_with_sep sep pr_import_module l + ) + | VernacCanonical q -> + return ( + keyword "Canonical Structure" ++ spc() ++ pr_smart_global q + ) + | VernacCoercion (id,c1,c2) -> + return ( + hov 1 ( + keyword "Coercion" ++ spc() ++ + pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ + spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2) + ) + | VernacIdentityCoercion (id,c1,c2) -> + return ( + hov 1 ( + keyword "Identity Coercion" ++ spc() ++ pr_lident id ++ + spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++ + spc() ++ pr_class_rawexpr c2) + ) + + | VernacInstance (instid, sup, cl, props, info) -> + return ( + hov 1 ( + keyword "Instance" ++ + (match instid with + | {loc; v = Name id}, l -> spc () ++ pr_ident_decl (CAst.(make ?loc id),l) ++ spc () + | { v = Anonymous }, _ -> mt ()) ++ + pr_and_type_binders_arg sup ++ + str":" ++ spc () ++ + pr_constr env sigma cl ++ pr_hint_info (pr_constr_pattern_expr env sigma) info ++ + (match props with + | Some (true, { v = CRecord l}) -> spc () ++ str":=" ++ spc () ++ str"{" ++ pr_record_body l ++ str "}" + | Some (true,_) -> assert false + | Some (false,p) -> spc () ++ str":=" ++ spc () ++ pr_constr env sigma p + | None -> mt())) + ) + + | VernacDeclareInstance (instid, sup, cl, info) -> + return ( + hov 1 ( + keyword "Declare Instance" ++ spc () ++ pr_ident_decl instid ++ spc () ++ + pr_and_type_binders_arg sup ++ + str":" ++ spc () ++ + pr_constr env sigma cl ++ pr_hint_info (pr_constr_pattern_expr env sigma) info) + ) + + | VernacContext l -> + return ( + hov 1 ( + keyword "Context" ++ pr_and_type_binders_arg l) + ) + + | VernacExistingInstance insts -> + let pr_inst (id, info) = + pr_qualid id ++ pr_hint_info (pr_constr_pattern_expr env sigma) info + in + return ( + hov 1 (keyword "Existing" ++ spc () ++ + keyword(String.plural (List.length insts) "Instance") ++ + spc () ++ prlist_with_sep (fun () -> str", ") pr_inst insts) + ) + + | VernacExistingClass id -> + return ( + hov 1 (keyword "Existing" ++ spc () ++ keyword "Class" ++ spc () ++ pr_qualid id) + ) + + (* Modules and Module Types *) + | VernacDefineModule (export,m,bl,tys,bd) -> + let b = pr_module_binders bl (pr_lconstr env sigma) in + return ( + hov 2 (keyword "Module" ++ spc() ++ pr_require_token export ++ + pr_lident m ++ b ++ + pr_of_module_type (pr_lconstr env sigma) tys ++ + (if List.is_empty bd then mt () else str ":= ") ++ + prlist_with_sep (fun () -> str " <+") + (pr_module_ast_inl true (pr_lconstr env sigma)) bd) + ) + | VernacDeclareModule (export,id,bl,m1) -> + let b = pr_module_binders bl (pr_lconstr env sigma) in + return ( + hov 2 (keyword "Declare Module" ++ spc() ++ pr_require_token export ++ + pr_lident id ++ b ++ str " :" ++ + pr_module_ast_inl true (pr_lconstr env sigma) m1) + ) + | VernacDeclareModuleType (id,bl,tyl,m) -> + let b = pr_module_binders bl (pr_lconstr env sigma) in + let pr_mt = pr_module_ast_inl true (pr_lconstr env sigma) in + return ( + hov 2 (keyword "Module Type " ++ pr_lident id ++ b ++ + prlist_strict (fun m -> str " <:" ++ pr_mt m) tyl ++ + (if List.is_empty m then mt () else str ":= ") ++ + prlist_with_sep (fun () -> str " <+ ") pr_mt m) + ) + | VernacInclude (mexprs) -> + let pr_m = pr_module_ast_inl false (pr_lconstr env sigma) in + return ( + hov 2 (keyword "Include" ++ spc() ++ + prlist_with_sep (fun () -> str " <+ ") pr_m mexprs) + ) + (* Solving *) + | VernacSolveExistential (i,c) -> + return (keyword "Existential" ++ spc () ++ int i ++ pr_lconstrarg c) + + (* Auxiliary file and library management *) + | VernacAddLoadPath { implicit; physical_path; logical_path } -> + return ( + hov 2 + (keyword "Add" ++ + (if implicit then spc () ++ keyword "Rec" ++ spc () else spc()) ++ + keyword "LoadPath" ++ spc() ++ qs physical_path ++ + spc() ++ keyword "as" ++ spc() ++ DirPath.print logical_path)) + | VernacRemoveLoadPath s -> + return (keyword "Remove LoadPath" ++ qs s) + | VernacAddMLPath (s) -> + return ( + keyword "Add" + ++ keyword "ML Path" + ++ qs s + ) + | VernacDeclareMLModule (l) -> + return ( + hov 2 (keyword "Declare ML Module" ++ spc() ++ prlist_with_sep sep qs l) + ) + | VernacChdir s -> + return (keyword "Cd" ++ pr_opt qs s) + + (* Commands *) + | VernacCreateHintDb (dbname,b) -> + return ( + hov 1 (keyword "Create HintDb" ++ spc () ++ + str dbname ++ (if b then str" discriminated" else mt ())) + ) + | VernacRemoveHints (dbnames, ids) -> + return ( + hov 1 (keyword "Remove Hints" ++ spc () ++ + prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++ + pr_opt_hintbases dbnames) + ) + | VernacHints (dbnames,h) -> + return (pr_hints dbnames h (pr_constr env sigma) (pr_constr_pattern_expr env sigma)) + | VernacSyntacticDefinition (id,(ids,c),{onlyparsing}) -> + return ( + hov 2 + (keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++ + prlist_with_sep spc pr_id ids ++ str":=" ++ pr_constrarg c ++ + pr_only_parsing_clause onlyparsing) + ) + | VernacArguments (q, args, more_implicits, mods) -> + return ( + hov 2 ( + keyword "Arguments" ++ spc() ++ + pr_smart_global q ++ + let pr_s = function None -> str"" | Some {v=s} -> str "%" ++ str s in + let pr_if b x = if b then x else str "" in + let pr_one_arg (x,k) = pr_if k (str"!") ++ Name.print x in + let pr_br imp force x = + let left,right = + match imp with + | Glob_term.NonMaxImplicit -> str "[", str "]" + | Glob_term.MaxImplicit -> str "{", str "}" + | Glob_term.Explicit -> if force then str"(",str")" else mt(),mt() + in + left ++ x ++ right in - let pr_line (l,q) = - hov 2 (pr_lev l ++ spc() ++ - str"[" ++ prlist_with_sep sep pr_smart_global q ++ str"]") + let get_arguments_like s imp tl = + if s = None && imp = Glob_term.Explicit then [], tl + else + let rec fold extra = function + | RealArg arg :: tl when + Option.equal (fun a b -> String.equal a.CAst.v b.CAst.v) arg.notation_scope s + && arg.implicit_status = imp -> + fold ((arg.name,arg.recarg_like) :: extra) tl + | args -> List.rev extra, args + in + fold [] tl in - return ( - hov 1 (keyword "Strategy" ++ spc() ++ - hv 0 (prlist_with_sep sep pr_line l)) - ) - | VernacSetOption (export, na,v) -> - let export = if export then keyword "Export" ++ spc () else mt () in - let set = if v == OptionUnset then "Unset" else "Set" in - return ( - hov 2 (export ++ keyword set ++ spc() ++ pr_set_option na v) - ) - | VernacAddOption (na,l) -> - return ( - hov 2 (keyword "Add" ++ spc() ++ pr_printoption na (Some l)) - ) - | VernacRemoveOption (na,l) -> - return ( - hov 2 (keyword "Remove" ++ spc() ++ pr_printoption na (Some l)) - ) - | VernacMemOption (na,l) -> - return ( - hov 2 (keyword "Test" ++ spc() ++ pr_printoption na (Some l)) - ) - | VernacPrintOption na -> - return ( - hov 2 (keyword "Test" ++ spc() ++ pr_printoption na None) - ) - | VernacCheckMayEval (r,io,c) -> - let pr_mayeval r c = match r with - | Some r0 -> - hov 2 (keyword "Eval" ++ spc() ++ - Ppred.pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++ - spc() ++ keyword "in" ++ spc () ++ pr_lconstr env sigma c) - | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr env sigma c) + let rec print_arguments = function + | [] -> mt() + | VolatileArg :: l -> spc () ++ str"/" ++ print_arguments l + | BidiArg :: l -> spc () ++ str"&" ++ print_arguments l + | RealArg { name = id; recarg_like = k; + notation_scope = s; + implicit_status = imp } :: tl -> + let extra, tl = get_arguments_like s imp tl in + spc() ++ pr_br imp (extra<>[]) (prlist_with_sep spc pr_one_arg ((id,k)::extra)) ++ + pr_s s ++ print_arguments tl in - let pr_i = match io with None -> mt () - | Some i -> Goal_select.pr_goal_selector i ++ str ": " in - return (pr_i ++ pr_mayeval r c) - | VernacGlobalCheck c -> - return (hov 2 (keyword "Type" ++ pr_constrarg c)) - | VernacDeclareReduction (s,r) -> - return ( - keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++ - Ppred.pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r - ) - | VernacPrint p -> - return (pr_printable p) - | VernacSearch (sea,g,sea_r) -> - return (pr_search sea g sea_r @@ pr_constr_pattern_expr env sigma) - | VernacLocate loc -> - let pr_locate =function - | LocateAny qid -> pr_smart_global qid - | LocateTerm qid -> keyword "Term" ++ spc() ++ pr_smart_global qid - | LocateFile f -> keyword "File" ++ spc() ++ qs f - | LocateLibrary qid -> keyword "Library" ++ spc () ++ pr_module qid - | LocateModule qid -> keyword "Module" ++ spc () ++ pr_module qid - | LocateOther (s, qid) -> keyword s ++ spc () ++ pr_ltac_ref qid + let rec print_implicits = function + | [] -> mt () + | (name, impl) :: rest -> + spc() ++ pr_br impl false (Name.print name) ++ print_implicits rest in - return (keyword "Locate" ++ spc() ++ pr_locate loc) - | VernacRegister (qid, RegisterCoqlib name) -> - return ( - hov 2 - (keyword "Register" ++ spc() ++ pr_qualid qid ++ spc () ++ str "as" - ++ spc () ++ pr_qualid name) - ) - | VernacRegister (qid, RegisterInline) -> - return ( - hov 2 - (keyword "Register Inline" ++ spc() ++ pr_qualid qid) - ) - | VernacPrimitive(id,r,typopt) -> - hov 2 - (keyword "Primitive" ++ spc() ++ pr_lident id ++ - (Option.cata (fun ty -> spc() ++ str":" ++ pr_spc_lconstr ty) (mt()) typopt) ++ spc() ++ - str ":=" ++ spc() ++ - str (CPrimitives.op_or_type_to_string r)) - | VernacComments l -> - return ( - hov 2 - (keyword "Comments" ++ spc() - ++ prlist_with_sep sep (pr_comment (pr_constr env sigma)) l) - ) - - (* For extension *) - | VernacExtend (s,c) -> - return (pr_extend s c) - | VernacProof (None, None) -> - return (keyword "Proof") - | VernacProof (None, Some e) -> - return (keyword "Proof " ++ spc () ++ + print_arguments args ++ + if not (List.is_empty more_implicits) then + prlist (fun l -> str"," ++ print_implicits l) more_implicits + else (mt ()) ++ + (if not (List.is_empty mods) then str" : " else str"") ++ + prlist_with_sep (fun () -> str", " ++ spc()) (function + | `ReductionDontExposeCase -> keyword "simpl nomatch" + | `ReductionNeverUnfold -> keyword "simpl never" + | `DefaultImplicits -> keyword "default implicits" + | `Rename -> keyword "rename" + | `Assert -> keyword "assert" + | `ExtraScopes -> keyword "extra scopes" + | `ClearImplicits -> keyword "clear implicits" + | `ClearScopes -> keyword "clear scopes" + | `ClearBidiHint -> keyword "clear bidirectionality hint") + mods) + ) + | VernacReserve bl -> + let n = List.length (List.flatten (List.map fst bl)) in + return ( + hov 2 (tag_keyword (str"Implicit Type" ++ str (if n > 1 then "s " else " ")) + ++ pr_ne_params_list (pr_lconstr_expr env sigma) (List.map (fun sb -> false,sb) bl)) + ) + | VernacGeneralizable g -> + return ( + hov 1 (tag_keyword ( + str"Generalizable Variable" ++ + match g with + | None -> str "s none" + | Some [] -> str "s all" + | Some idl -> + str (if List.length idl > 1 then "s " else " ") ++ + prlist_with_sep spc pr_lident idl) + )) + | VernacSetOpacity(k,l) when Conv_oracle.is_transparent k -> + return ( + hov 1 (keyword "Transparent" ++ + spc() ++ prlist_with_sep sep pr_smart_global l) + ) + | VernacSetOpacity(Conv_oracle.Opaque,l) -> + return ( + hov 1 (keyword "Opaque" ++ + spc() ++ prlist_with_sep sep pr_smart_global l) + ) + | VernacSetOpacity _ -> + return ( + CErrors.anomaly (keyword "VernacSetOpacity used to set something else.") + ) + | VernacSetStrategy l -> + let pr_lev = function + | Conv_oracle.Opaque -> keyword "opaque" + | Conv_oracle.Expand -> keyword "expand" + | l when Conv_oracle.is_transparent l -> keyword "transparent" + | Conv_oracle.Level n -> int n + in + let pr_line (l,q) = + hov 2 (pr_lev l ++ spc() ++ + str"[" ++ prlist_with_sep sep pr_smart_global q ++ str"]") + in + return ( + hov 1 (keyword "Strategy" ++ spc() ++ + hv 0 (prlist_with_sep sep pr_line l)) + ) + | VernacSetOption (export, na,v) -> + let export = if export then keyword "Export" ++ spc () else mt () in + let set = if v == OptionUnset then "Unset" else "Set" in + return ( + hov 2 (export ++ keyword set ++ spc() ++ pr_set_option na v) + ) + | VernacAddOption (na,l) -> + return ( + hov 2 (keyword "Add" ++ spc() ++ pr_printoption na (Some l)) + ) + | VernacRemoveOption (na,l) -> + return ( + hov 2 (keyword "Remove" ++ spc() ++ pr_printoption na (Some l)) + ) + | VernacMemOption (na,l) -> + return ( + hov 2 (keyword "Test" ++ spc() ++ pr_printoption na (Some l)) + ) + | VernacPrintOption na -> + return ( + hov 2 (keyword "Test" ++ spc() ++ pr_printoption na None) + ) + | VernacCheckMayEval (r,io,c) -> + let pr_mayeval r c = match r with + | Some r0 -> + hov 2 (keyword "Eval" ++ spc() ++ + Ppred.pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++ + spc() ++ keyword "in" ++ spc () ++ pr_lconstr env sigma c) + | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr env sigma c) + in + let pr_i = match io with None -> mt () + | Some i -> Goal_select.pr_goal_selector i ++ str ": " in + return (pr_i ++ pr_mayeval r c) + | VernacGlobalCheck c -> + return (hov 2 (keyword "Type" ++ pr_constrarg c)) + | VernacDeclareReduction (s,r) -> + return ( + keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++ + Ppred.pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r + ) + | VernacPrint p -> + return (pr_printable p) + | VernacSearch (sea,g,sea_r) -> + return (pr_search sea g sea_r @@ pr_constr_pattern_expr env sigma) + | VernacLocate loc -> + let pr_locate =function + | LocateAny qid -> pr_smart_global qid + | LocateTerm qid -> keyword "Term" ++ spc() ++ pr_smart_global qid + | LocateFile f -> keyword "File" ++ spc() ++ qs f + | LocateLibrary qid -> keyword "Library" ++ spc () ++ pr_module qid + | LocateModule qid -> keyword "Module" ++ spc () ++ pr_module qid + | LocateOther (s, qid) -> keyword s ++ spc () ++ pr_ltac_ref qid + in + return (keyword "Locate" ++ spc() ++ pr_locate loc) + | VernacRegister (qid, RegisterCoqlib name) -> + return ( + hov 2 + (keyword "Register" ++ spc() ++ pr_qualid qid ++ spc () ++ str "as" + ++ spc () ++ pr_qualid name) + ) + | VernacRegister (qid, RegisterInline) -> + return ( + hov 2 + (keyword "Register Inline" ++ spc() ++ pr_qualid qid) + ) + | VernacPrimitive(id,r,typopt) -> + hov 2 + (keyword "Primitive" ++ spc() ++ pr_ident_decl id ++ + (Option.cata (fun ty -> spc() ++ str":" ++ pr_spc_lconstr ty) (mt()) typopt) ++ spc() ++ + str ":=" ++ spc() ++ + str (CPrimitives.op_or_type_to_string r)) + | VernacComments l -> + return ( + hov 2 + (keyword "Comments" ++ spc() + ++ prlist_with_sep sep (pr_comment (pr_constr env sigma)) l) + ) + + (* For extension *) + | VernacExtend (s,c) -> + return (pr_extend s c) + | VernacProof (None, None) -> + return (keyword "Proof") + | VernacProof (None, Some e) -> + return (keyword "Proof " ++ spc () ++ keyword "using" ++ spc() ++ pr_using e) - | VernacProof (Some te, None) -> - return (keyword "Proof with" ++ spc() ++ Pputils.pr_raw_generic env sigma te) - | VernacProof (Some te, Some e) -> - return ( - keyword "Proof" ++ spc () ++ - keyword "using" ++ spc() ++ pr_using e ++ spc() ++ - keyword "with" ++ spc() ++ Pputils.pr_raw_generic env sigma te - ) - | VernacProofMode s -> - return (keyword "Proof Mode" ++ str s) - | VernacBullet b -> - (* XXX: Redundant with Proof_bullet.print *) - return (let open Proof_bullet in begin match b with - | Dash n -> str (String.make n '-') - | Star n -> str (String.make n '*') - | Plus n -> str (String.make n '+') - end) - | VernacSubproof None -> - return (str "{") - | VernacSubproof (Some i) -> - return (Goal_select.pr_goal_selector i ++ str ":" ++ spc () ++ str "{") - | VernacEndSubproof -> - return (str "}") + | VernacProof (Some te, None) -> + return (keyword "Proof with" ++ spc() ++ Pputils.pr_raw_generic env sigma te) + | VernacProof (Some te, Some e) -> + return ( + keyword "Proof" ++ spc () ++ + keyword "using" ++ spc() ++ pr_using e ++ spc() ++ + keyword "with" ++ spc() ++ Pputils.pr_raw_generic env sigma te + ) + | VernacProofMode s -> + return (keyword "Proof Mode" ++ str s) + | VernacBullet b -> + (* XXX: Redundant with Proof_bullet.print *) + return (let open Proof_bullet in begin match b with + | Dash n -> str (String.make n '-') + | Star n -> str (String.make n '*') + | Plus n -> str (String.make n '+') + end) + | VernacSubproof None -> + return (str "{") + | VernacSubproof (Some i) -> + return (Goal_select.pr_goal_selector i ++ str ":" ++ spc () ++ str "{") + | VernacEndSubproof -> + return (str "}") let pr_control_flag (p : control_flag) = let w = match p with diff --git a/vernac/printmod.ml b/vernac/printmod.ml index 219e445c56..fdf7f6c74a 100644 --- a/vernac/printmod.ml +++ b/vernac/printmod.ml @@ -406,11 +406,11 @@ let rec printable_body dir = state after the printing *) let print_expression' is_type extent env mp me = - States.with_state_protection + Vernacstate.System.protect (fun e -> print_expression is_type extent env mp [] e) me let print_signature' is_type extent env mp me = - States.with_state_protection + Vernacstate.System.protect (fun e -> print_signature is_type extent env mp [] e) me let unsafe_print_module extent env mp with_body mb = diff --git a/vernac/record.ml b/vernac/record.ml index 9d99036273..820bcba0b6 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -343,8 +343,9 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f let p = mkLambda (x, lift 1 rp, ccl') in let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in let ci = Inductiveops.make_case_info env indsp rci LetStyle in - (* Record projections have no is *) - mkCase (ci, p, mkRel 1, [|branch|]), None + (* Record projections are always NoInvert because + they're at constant relevance *) + mkCase (ci, p, NoInvert, mkRel 1, [|branch|]), None in let proj = it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in @@ -710,7 +711,7 @@ let definition_structure udecl kind ~template ~cumulative ~poly finite records = let () = check_priorities kind records in let ps, data = extract_record_data records in let ubinders, univs, auto_template, params, implpars, data = - States.with_state_protection (fun () -> + Vernacstate.System.protect (fun () -> typecheck_params_and_fields (kind = Class true) poly udecl ps data) () in let template = template, auto_template in match kind with diff --git a/vernac/states.ml b/vernac/states.ml deleted file mode 100644 index b6904263df..0000000000 --- a/vernac/states.ml +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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) *) -(************************************************************************) - -type state = Lib.frozen * Summary.frozen - -let lib_of_state = fst -let summary_of_state = snd -let replace_summary (lib,_) st = lib, st -let replace_lib (_,st) lib = lib, st - -let freeze ~marshallable = - (Lib.freeze (), Summary.freeze_summaries ~marshallable) - -let unfreeze (fl,fs) = - Lib.unfreeze fl; - Summary.unfreeze_summaries fs - -(* Rollback. *) - -let with_state_protection f x = - let st = freeze ~marshallable:false in - try - let a = f x in unfreeze st; a - with reraise -> - let reraise = Exninfo.capture reraise in - (unfreeze st; Exninfo.iraise reraise) diff --git a/vernac/states.mli b/vernac/states.mli deleted file mode 100644 index 51db83ca03..0000000000 --- a/vernac/states.mli +++ /dev/null @@ -1,32 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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) *) -(************************************************************************) - -(** {6 States of the system} *) - -(** In that module, we provide functions to get - and set the state of the whole system. Internally, it is done by - freezing the states of both [Lib] and [Summary]. We provide functions - to write and restore state to and from a given file. *) - -type 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 } *) - -(** [with_state_protection f x] applies [f] to [x] and restores the - state of the whole system as it was before applying [f] *) - -val with_state_protection : ('a -> 'b) -> 'a -> 'b diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index f357a04668..994592a88a 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -1,9 +1,6 @@ Vernacexpr Attributes Pvernac -States -Declaremods -Printmod G_vernac G_proofs Vernacprop @@ -21,6 +18,7 @@ Declare ComHints Canonical RecLemmas +Declaremods Library ComCoercion Auto_ind_decl @@ -32,10 +30,12 @@ ComAssumption DeclareInd Search ComSearch -Prettyp ComInductive ComFixpoint ComProgramFixpoint +Vernacstate +Printmod +Prettyp Record Assumptions Mltop @@ -43,5 +43,4 @@ Topfmt Loadpath ComArguments Vernacentries -Vernacstate Vernacinterp diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index f5ef5ee86f..d540e7f93d 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -579,7 +579,7 @@ let vernac_definition_interactive ~atts (discharge, kind) (lid, pl) bl t = let name = vernac_definition_name lid local in start_lemma_com ~program_mode ~poly ~scope:local ~kind:(Decls.IsDefinition kind) ?hook [(name, pl), (bl, t)] -let vernac_definition ~atts (discharge, kind) (lid, pl) bl red_option c typ_opt = +let vernac_definition ~atts ~pm (discharge, kind) (lid, pl) bl red_option c typ_opt = let open DefAttributes in let scope = enforce_locality_exp atts.locality discharge in let hook = vernac_definition_hook ~canonical_instance:atts.canonical_instance ~local:atts.locality ~poly:atts.polymorphic kind in @@ -593,13 +593,13 @@ let vernac_definition ~atts (discharge, kind) (lid, pl) bl red_option c typ_opt Some (snd (Hook.get f_interp_redexp env sigma r)) in if program_mode then let kind = Decls.IsDefinition kind in - ComDefinition.do_definition_program ~name:name.v + ComDefinition.do_definition_program ~pm ~name:name.v ~poly:atts.polymorphic ~scope ~kind pl bl red_option c typ_opt ?hook else let () = ComDefinition.do_definition ~name:name.v ~poly:atts.polymorphic ~scope ~kind pl bl red_option c typ_opt ?hook in - () + pm (* NB: pstate argument to use combinators easily *) let vernac_start_proof ~atts kind l = @@ -609,19 +609,20 @@ let vernac_start_proof ~atts kind l = List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; start_lemma_com ~program_mode:atts.program ~poly:atts.polymorphic ~scope ~kind:(Decls.IsProof kind) l -let vernac_end_proof ~lemma = let open Vernacexpr in function +let vernac_end_proof ~lemma ~pm = let open Vernacexpr in function | Admitted -> - Declare.Proof.save_admitted ~proof:lemma + Declare.Proof.save_admitted ~pm ~proof:lemma | Proved (opaque,idopt) -> - let _ : Names.GlobRef.t list = Declare.Proof.save ~proof:lemma ~opaque ~idopt - in () + let pm, _ = Declare.Proof.save ~pm ~proof:lemma ~opaque ~idopt + in pm -let vernac_exact_proof ~lemma c = +let vernac_exact_proof ~lemma ~pm c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the beginning of a proof. *) let lemma, status = Declare.Proof.by (Tactics.exact_proof c) lemma in - let _ : _ list = Declare.Proof.save ~proof:lemma ~opaque:Opaque ~idopt:None in - if not status then Feedback.feedback Feedback.AddedAxiom + let pm, _ = Declare.Proof.save ~pm ~proof:lemma ~opaque:Opaque ~idopt:None in + if not status then Feedback.feedback Feedback.AddedAxiom; + pm let vernac_assumption ~atts discharge kind l nl = let open DefAttributes in @@ -837,14 +838,15 @@ let vernac_fixpoint_interactive ~atts discharge l = CErrors.user_err Pp.(str"Program Fixpoint requires a body"); ComFixpoint.do_fixpoint_interactive ~scope ~poly:atts.polymorphic l -let vernac_fixpoint ~atts discharge l = +let vernac_fixpoint ~atts ~pm discharge l = let open DefAttributes in let scope = vernac_fixpoint_common ~atts discharge l in if atts.program then (* XXX: Switch to the attribute system and match on ~atts *) - ComProgramFixpoint.do_fixpoint ~scope ~poly:atts.polymorphic l + ComProgramFixpoint.do_fixpoint ~pm ~scope ~poly:atts.polymorphic l else - ComFixpoint.do_fixpoint ~scope ~poly:atts.polymorphic l + let () = ComFixpoint.do_fixpoint ~scope ~poly:atts.polymorphic l in + pm let vernac_cofixpoint_common ~atts discharge l = if Dumpglob.dump () then @@ -858,13 +860,14 @@ let vernac_cofixpoint_interactive ~atts discharge l = CErrors.user_err Pp.(str"Program CoFixpoint requires a body"); ComFixpoint.do_cofixpoint_interactive ~scope ~poly:atts.polymorphic l -let vernac_cofixpoint ~atts discharge l = +let vernac_cofixpoint ~atts ~pm discharge l = let open DefAttributes in let scope = vernac_cofixpoint_common ~atts discharge l in if atts.program then - ComProgramFixpoint.do_cofixpoint ~scope ~poly:atts.polymorphic l + ComProgramFixpoint.do_cofixpoint ~pm ~scope ~poly:atts.polymorphic l else - ComFixpoint.do_cofixpoint ~scope ~poly:atts.polymorphic l + let () = ComFixpoint.do_cofixpoint ~scope ~poly:atts.polymorphic l in + pm let vernac_scheme l = if Dumpglob.dump () then @@ -1085,10 +1088,10 @@ let msg_of_subsection ss id = in Pp.str kind ++ spc () ++ Id.print id -let vernac_end_segment ({v=id} as lid) = +let vernac_end_segment ~pm ({v=id} as lid) = let ss = Lib.find_opening_node id in let what_for = msg_of_subsection ss lid.v in - Declare.Obls.check_solved_obligations ~what_for; + Declare.Obls.check_solved_obligations ~pm ~what_for; match ss with | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid @@ -1147,14 +1150,14 @@ let vernac_identity_coercion ~atts id qids qidt = (* Type classes *) -let vernac_instance_program ~atts name bl t props info = +let vernac_instance_program ~atts ~pm name bl t props info = Dumpglob.dump_constraint (fst name) false "inst"; let locality, poly = Attributes.(parse (Notations.(locality ++ polymorphic))) atts in let global = not (make_section_locality locality) in - let _id : Id.t = Classes.new_instance_program ~global ~poly name bl t props info in - () + let pm, _id = Classes.new_instance_program ~pm ~global ~poly name bl t props info in + pm let vernac_instance_interactive ~atts name bl t info props = Dumpglob.dump_constraint (fst name) false "inst"; @@ -1269,11 +1272,11 @@ let vernac_chdir = function let vernac_write_state file = let file = CUnix.make_suffix file ".coq" in - Library.extern_state file + Vernacstate.System.dump file let vernac_restore_state file = let file = Loadpath.locate_file (CUnix.make_suffix file ".coq") in - Library.intern_state file + Vernacstate.System.load file (************) (* Commands *) @@ -1553,6 +1556,15 @@ let () = optread = (fun () -> (Global.typing_flags ()).Declarations.check_universes); optwrite = (fun b -> Global.set_check_universes b) } +let () = + declare_bool_option + { optdepr = false; + optkey = ["Definitional"; "UIP"]; + optread = (fun () -> (Global.typing_flags ()).Declarations.allow_uip); + optwrite = (fun b -> Global.set_typing_flags + {(Global.typing_flags ()) with Declarations.allow_uip = b}) + } + let vernac_set_strategy ~local l = let local = Option.default false local in let glob_ref r = @@ -1982,9 +1994,9 @@ let translate_vernac ~atts v = let open Vernacextend in match v with (* Gallina *) | VernacDefinition (discharge,lid,DefineBody (bl,red_option,c,typ)) -> - VtDefault (fun () -> + VtModifyProgram (fun ~pm -> with_def_attributes ~atts - vernac_definition discharge lid bl red_option c typ) + vernac_definition ~pm discharge lid bl red_option c typ) | VernacDefinition (discharge,lid,ProveBody(bl,typ)) -> VtOpenProof(fun () -> with_def_attributes ~atts @@ -2019,14 +2031,14 @@ let translate_vernac ~atts v = let open Vernacextend in match v with VtOpenProof (fun () -> with_def_attributes ~atts vernac_fixpoint_interactive discharge l) else - VtDefault (fun () -> - with_def_attributes ~atts vernac_fixpoint discharge l) + VtModifyProgram (fun ~pm -> + with_def_attributes ~atts (vernac_fixpoint ~pm) discharge l) | VernacCoFixpoint (discharge, l) -> let opens = List.exists (fun { body_def } -> Option.is_empty body_def) l in if opens then VtOpenProof(fun () -> with_def_attributes ~atts vernac_cofixpoint_interactive discharge l) else - VtDefault(fun () -> with_def_attributes ~atts vernac_cofixpoint discharge l) + VtModifyProgram(fun ~pm -> with_def_attributes ~atts (vernac_cofixpoint ~pm) discharge l) | VernacScheme l -> VtDefault(fun () -> @@ -2055,9 +2067,9 @@ let translate_vernac ~atts v = let open Vernacextend in match v with VtNoProof(fun () -> vernac_begin_section ~poly:(only_polymorphism atts) lid) | VernacEndSegment lid -> - VtNoProof(fun () -> + VtReadProgram(fun ~pm -> unsupported_attributes atts; - vernac_end_segment lid) + vernac_end_segment ~pm lid) | VernacNameSectionHypSet (lid, set) -> VtDefault(fun () -> unsupported_attributes atts; @@ -2082,7 +2094,7 @@ let translate_vernac ~atts v = let open Vernacextend in match v with | VernacInstance (name, bl, t, props, info) -> let atts, program = Attributes.(parse_with_extra program) atts in if program then - VtDefault (fun () -> vernac_instance_program ~atts name bl t props info) + VtModifyProgram (vernac_instance_program ~atts name bl t props info) else begin match props with | None -> VtOpenProof (fun () -> @@ -2212,10 +2224,10 @@ let translate_vernac ~atts v = let open Vernacextend in match v with VtNoProof(fun () -> unsupported_attributes atts; vernac_register qid r) - | VernacPrimitive (id, prim, typopt) -> + | VernacPrimitive ((id, udecl), prim, typopt) -> VtDefault(fun () -> unsupported_attributes atts; - ComPrimitive.do_primitive id prim typopt) + ComPrimitive.do_primitive id udecl prim typopt) | VernacComments l -> VtDefault(fun () -> unsupported_attributes atts; diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 0fdf9e2a7b..d8e17d00e3 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -137,11 +137,21 @@ type definition_expr = | DefineBody of local_binder_expr list * Genredexpr.raw_red_expr option * constr_expr * constr_expr option +type syntax_modifier = + | SetItemLevel of string list * Notation_term.constr_as_binder_kind option * Extend.production_level + | SetLevel of int + | SetCustomEntry of string * int option + | SetAssoc of Gramlib.Gramext.g_assoc + | SetEntryType of string * Extend.simple_constr_prod_entry_key + | SetOnlyParsing + | SetOnlyPrinting + | SetFormat of string * lstring + type decl_notation = { decl_ntn_string : lstring ; decl_ntn_interp : constr_expr - ; decl_ntn_only_parsing : bool ; decl_ntn_scope : scope_name option + ; decl_ntn_modifiers : syntax_modifier list } type 'a fix_expr_gen = @@ -192,16 +202,6 @@ and typeclass_context = typeclass_constraint list type proof_expr = ident_decl * (local_binder_expr list * constr_expr) -type syntax_modifier = - | SetItemLevel of string list * Notation_term.constr_as_binder_kind option * Extend.production_level - | SetLevel of int - | SetCustomEntry of string * int option - | SetAssoc of Gramlib.Gramext.g_assoc - | SetEntryType of string * Extend.simple_constr_prod_entry_key - | SetOnlyParsing - | SetOnlyPrinting - | SetFormat of string * lstring - type opacity_flag = Opaque | Transparent type proof_end = @@ -438,7 +438,7 @@ type nonrec vernac_expr = | VernacSearch of searchable * Goal_select.t option * search_restriction | VernacLocate of locatable | VernacRegister of qualid * register_kind - | VernacPrimitive of lident * CPrimitives.op_or_type * constr_expr option + | VernacPrimitive of ident_decl * CPrimitives.op_or_type * constr_expr option | VernacComments of comment list (* Proof management *) diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index f8a80e8feb..496b1a43d1 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -55,11 +55,15 @@ and proof_block_name = string (** open type of delimiters *) type typed_vernac = | VtDefault of (unit -> unit) | VtNoProof of (unit -> unit) - | VtCloseProof of (lemma:Declare.Proof.t -> unit) + | VtCloseProof of (lemma:Declare.Proof.t -> pm:Declare.OblState.t -> Declare.OblState.t) | VtOpenProof of (unit -> Declare.Proof.t) | VtModifyProof of (pstate:Declare.Proof.t -> Declare.Proof.t) | VtReadProofOpt of (pstate:Declare.Proof.t option -> unit) | VtReadProof of (pstate:Declare.Proof.t -> unit) + | VtReadProgram of (pm:Declare.OblState.t -> unit) + | VtModifyProgram of (pm:Declare.OblState.t -> Declare.OblState.t) + | VtDeclareProgram of (pm:Declare.OblState.t -> Declare.Proof.t) + | VtOpenProofProgram of (pm:Declare.OblState.t -> Declare.OblState.t * Declare.Proof.t) type vernac_command = atts:Attributes.vernac_flags -> typed_vernac diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 103e24233b..5ef137cfc0 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -73,11 +73,15 @@ and proof_block_name = string (** open type of delimiters *) type typed_vernac = | VtDefault of (unit -> unit) | VtNoProof of (unit -> unit) - | VtCloseProof of (lemma:Declare.Proof.t -> unit) + | VtCloseProof of (lemma:Declare.Proof.t -> pm:Declare.OblState.t -> Declare.OblState.t) | VtOpenProof of (unit -> Declare.Proof.t) | VtModifyProof of (pstate:Declare.Proof.t -> Declare.Proof.t) | VtReadProofOpt of (pstate:Declare.Proof.t option -> unit) | VtReadProof of (pstate:Declare.Proof.t -> unit) + | VtReadProgram of (pm:Declare.OblState.t -> unit) + | VtModifyProgram of (pm:Declare.OblState.t -> Declare.OblState.t) + | VtDeclareProgram of (pm:Declare.OblState.t -> Declare.Proof.t) + | VtOpenProofProgram of (pm:Declare.OblState.t -> Declare.OblState.t * Declare.Proof.t) type vernac_command = atts:Attributes.vernac_flags -> typed_vernac diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 1b977b8e10..6be2fb0d43 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -22,32 +22,41 @@ let vernac_require_open_lemma ~stack f = | None -> CErrors.user_err (Pp.str "Command not supported (No proof-editing in progress)") -let interp_typed_vernac c ~stack = +let interp_typed_vernac c ~pm ~stack = let open Vernacextend in match c with - | VtDefault f -> f (); stack + | VtDefault f -> f (); stack, pm | VtNoProof f -> if Option.has_some stack then CErrors.user_err (Pp.str "Command not supported (Open proofs remain)"); let () = f () in - stack + stack, pm | VtCloseProof f -> vernac_require_open_lemma ~stack (fun stack -> let lemma, stack = Vernacstate.LemmaStack.pop stack in - f ~lemma; - stack) + let pm = f ~lemma ~pm in + stack, pm) | VtOpenProof f -> - Some (Vernacstate.LemmaStack.push stack (f ())) + Some (Vernacstate.LemmaStack.push stack (f ())), pm | VtModifyProof f -> - Option.map (Vernacstate.LemmaStack.map_top ~f:(fun pstate -> f ~pstate)) stack + Option.map (Vernacstate.LemmaStack.map_top ~f:(fun pstate -> f ~pstate)) stack, pm | VtReadProofOpt f -> let pstate = Option.map (Vernacstate.LemmaStack.with_top ~f:(fun x -> x)) stack in f ~pstate; - stack + stack, pm | VtReadProof f -> vernac_require_open_lemma ~stack (Vernacstate.LemmaStack.with_top ~f:(fun pstate -> f ~pstate)); - stack + stack, pm + | VtReadProgram f -> f ~pm; stack, pm + | VtModifyProgram f -> + let pm = f ~pm in stack, pm + | VtDeclareProgram f -> + let lemma = f ~pm in + Some (Vernacstate.LemmaStack.push stack lemma), pm + | VtOpenProofProgram f -> + let pm, lemma = f ~pm in + Some (Vernacstate.LemmaStack.push stack lemma), pm (* Default proof mode, to be set at the beginning of proofs for programs that cannot be statically classified. *) @@ -123,11 +132,11 @@ let mk_time_header = fun vernac -> Lazy.from_fun (fun () -> pr_time_header vernac) let interp_control_flag ~time_header (f : control_flag) ~st - (fn : st:Vernacstate.t -> Vernacstate.LemmaStack.t option) = + (fn : st:Vernacstate.t -> Vernacstate.LemmaStack.t option * Declare.OblState.t) = match f with | ControlFail -> with_fail ~st (fun () -> fn ~st); - st.Vernacstate.lemmas + st.Vernacstate.lemmas, st.Vernacstate.program | ControlTimeout timeout -> vernac_timeout ~timeout (fun () -> fn ~st) () | ControlTime batch -> @@ -142,6 +151,7 @@ let interp_control_flag ~time_header (f : control_flag) ~st * loc is the Loc.t of the vernacular command being interpreted. *) let rec interp_expr ~atts ~st c = let stack = st.Vernacstate.lemmas in + let program = st.Vernacstate.program in vernac_pperr_endline Pp.(fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); match c with @@ -163,7 +173,7 @@ let rec interp_expr ~atts ~st c = vernac_load ~verbosely fname | v -> let fv = Vernacentries.translate_vernac ~atts v in - interp_typed_vernac ~stack fv + interp_typed_vernac ~pm:program ~stack fv and vernac_load ~verbosely fname = (* Note that no proof should be open here, so the state here is just token for now *) @@ -180,19 +190,19 @@ and vernac_load ~verbosely fname = let parse_sentence proof_mode = Flags.with_option Flags.we_are_parsing (Pcoq.Entry.parse (Pvernac.main_entry proof_mode)) in - let rec load_loop ~stack = + let rec load_loop ~pm ~stack = let proof_mode = Option.map (fun _ -> get_default_proof_mode ()) stack in match parse_sentence proof_mode input with - | None -> stack + | None -> stack, pm | Some stm -> - let stack = v_mod (interp_control ~st:{ st with Vernacstate.lemmas = stack }) stm in - (load_loop [@ocaml.tailcall]) ~stack + let stack, pm = v_mod (interp_control ~st:{ st with Vernacstate.lemmas = stack; program = pm }) stm in + (load_loop [@ocaml.tailcall]) ~stack ~pm in - let stack = load_loop ~stack:st.Vernacstate.lemmas in + let stack, pm = load_loop ~pm:st.Vernacstate.program ~stack:st.Vernacstate.lemmas in (* If Load left a proof open, we fail too. *) if Option.has_some stack then CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); - stack + stack, pm and interp_control ~st ({ CAst.v = cmd } as vernac) = let time_header = mk_time_header vernac in @@ -200,9 +210,9 @@ and interp_control ~st ({ CAst.v = cmd } as vernac) = cmd.control (fun ~st -> let before_univs = Global.universes () in - let pstack = interp_expr ~atts:cmd.attrs ~st cmd.expr in - if before_univs == Global.universes () then pstack - else Option.map (Vernacstate.LemmaStack.map_top ~f:Declare.Proof.update_global_env) pstack) + let pstack, pm = interp_expr ~atts:cmd.attrs ~st cmd.expr in + if before_univs == Global.universes () then pstack, pm + else Option.map (Vernacstate.LemmaStack.map_top ~f:Declare.Proof.update_global_env) pstack, pm) ~st (* XXX: This won't properly set the proof mode, as of today, it is @@ -213,17 +223,18 @@ and interp_control ~st ({ CAst.v = cmd } as vernac) = *) (* Interpreting a possibly delayed proof *) -let interp_qed_delayed ~proof ~pinfo ~st pe : Vernacstate.LemmaStack.t option = +let interp_qed_delayed ~proof ~pinfo ~st pe : Vernacstate.LemmaStack.t option * Declare.OblState.t = let stack = st.Vernacstate.lemmas in + let pm = st.Vernacstate.program in let stack = Option.cata (fun stack -> snd @@ Vernacstate.LemmaStack.pop stack) None stack in - let () = match pe with + let pm = match pe with | Admitted -> - Declare.Proof.save_lemma_admitted_delayed ~proof ~pinfo + Declare.Proof.save_lemma_admitted_delayed ~pm ~proof ~pinfo | Proved (_,idopt) -> - let _ : _ list = Declare.Proof.save_lemma_proved_delayed ~proof ~pinfo ~idopt in - () + let pm, _ = Declare.Proof.save_lemma_proved_delayed ~pm ~proof ~pinfo ~idopt in + pm in - stack + stack, pm let interp_qed_delayed_control ~proof ~pinfo ~st ~control { CAst.loc; v=pe } = let time_header = mk_time_header (CAst.make ?loc { control; attrs = []; expr = VernacEndProof pe }) in diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 17c89897fe..ee06205427 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -10,7 +10,7 @@ module Parser = struct - type state = Pcoq.frozen_t + type t = Pcoq.frozen_t let init () = Pcoq.freeze ~marshallable:false @@ -24,6 +24,58 @@ module Parser = struct end +module System : sig + type t + val protect : ('a -> 'b) -> 'a -> 'b + val freeze : marshallable:bool -> t + val unfreeze : t -> unit + + val dump : string -> unit + val load : string -> unit + + module Stm : sig + val make_shallow : t -> t + val lib : t -> Lib.frozen + val summary : t -> Summary.frozen + val replace_summary : t -> Summary.frozen -> t + end +end = struct + type t = Lib.frozen * Summary.frozen + + let freeze ~marshallable = + (Lib.freeze (), Summary.freeze_summaries ~marshallable) + + let unfreeze (fl,fs) = + Lib.unfreeze fl; + Summary.unfreeze_summaries fs + + let protect f x = + let st = freeze ~marshallable:false in + try + let a = f x in unfreeze st; a + with reraise -> + let reraise = Exninfo.capture reraise in + (unfreeze st; Exninfo.iraise reraise) + + (* These commands may not be very safe due to ML-side plugin loading + etc... use at your own risk *) + (* XXX: EJGA: this is ignoring parsing state, it works for now? *) + let dump s = + System.extern_state Coq_config.state_magic_number s (freeze ~marshallable:true) + + let load s = + unfreeze (System.with_magic_number_check (System.intern_state Coq_config.state_magic_number) s); + Library.overwrite_library_filenames s + + (* STM-specific state manipulations *) + module Stm = struct + let make_shallow (lib, summary) = Lib.drop_objects lib, summary + let lib = fst + let summary = snd + let replace_summary (lib,_) summary = (lib,summary) + end +end + module LemmaStack = struct type t = Declare.Proof.t * Declare.Proof.t list @@ -58,18 +110,21 @@ module LemmaStack = struct end type t = { - parsing : Parser.state; - system : States.state; (* summary + libstack *) + parsing : Parser.t; + system : System.t; (* summary + libstack *) lemmas : LemmaStack.t option; (* proofs of lemmas currently opened *) + program : Declare.OblState.t; (* obligations table *) shallow : bool (* is the state trimmed down (libstack) *) } let s_cache = ref None let s_lemmas = ref None +let s_program = ref Declare.OblState.empty let invalidate_cache () = s_cache := None; - s_lemmas := None + s_lemmas := None; + s_program := Declare.OblState.empty let update_cache rf v = rf := Some v; v @@ -84,29 +139,26 @@ let do_if_not_cached rf f v = () let freeze_interp_state ~marshallable = - { system = update_cache s_cache (States.freeze ~marshallable); + { system = update_cache s_cache (System.freeze ~marshallable); lemmas = !s_lemmas; + program = !s_program; shallow = false; parsing = Parser.cur_state (); } -let unfreeze_interp_state { system; lemmas; parsing } = - do_if_not_cached s_cache States.unfreeze system; +let unfreeze_interp_state { system; lemmas; program; parsing } = + do_if_not_cached s_cache System.unfreeze system; s_lemmas := lemmas; + s_program := program; Pcoq.unfreeze parsing -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; - } - (* Compatibility module *) -module Declare = struct +module Declare_ = struct let get () = !s_lemmas - let set x = s_lemmas := x + let set (pstate,pm) = + s_lemmas := pstate; + s_program := pm let get_pstate () = Option.map (LemmaStack.with_top ~f:(fun x -> x)) !s_lemmas @@ -182,3 +234,57 @@ module Declare = struct | Some src, Some tgt -> Some (LemmaStack.copy_info ~src ~tgt) end + +(* STM-specific state-handling *) +module Stm = struct + + (* Proof-related state, for workers; ideally the two counters would + be contained in the lemmas state themselves, as there is no need + for evar / metas to be global among proofs *) + type nonrec pstate = + LemmaStack.t option * + int * (* Evarutil.meta_counter_summary_tag *) + int (* Evd.evar_counter_summary_tag *) + + (* Parts of the system state that are morally part of the proof state *) + let pstate { lemmas; system } = + let st = System.Stm.summary system in + lemmas, + Summary.project_from_summary st Evarutil.meta_counter_summary_tag, + Summary.project_from_summary st Evd.evar_counter_summary_tag + + let set_pstate ({ lemmas; system } as s) (pstate,c1,c2) = + { s with + lemmas = + Declare_.copy_terminators ~src:s.lemmas ~tgt:pstate + ; system = + System.Stm.replace_summary s.system + begin + let st = System.Stm.summary s.system in + let st = Summary.modify_summary st Evarutil.meta_counter_summary_tag c1 in + let st = Summary.modify_summary st Evd.evar_counter_summary_tag c2 in + st + end + } + + let non_pstate { system } = + let st = System.Stm.summary system in + let st = Summary.remove_from_summary st Evarutil.meta_counter_summary_tag in + let st = Summary.remove_from_summary st Evd.evar_counter_summary_tag in + st, System.Stm.lib system + + let same_env { system = s1 } { system = s2 } = + let s1 = System.Stm.summary s1 in + let e1 = Summary.project_from_summary s1 Global.global_env_summary_tag in + let s2 = System.Stm.summary s2 in + let e2 = Summary.project_from_summary s2 Global.global_env_summary_tag in + e1 == e2 + + let make_shallow st = + { st with + system = System.Stm.make_shallow st.system + ; shallow = true + } + +end +module Declare = Declare_ diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index c99db34873..16fab3782b 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -9,12 +9,27 @@ (************************************************************************) module Parser : sig - type state + type t + + val init : unit -> t + val cur_state : unit -> t + + val parse : t -> 'a Pcoq.Entry.t -> Pcoq.Parsable.t -> 'a + +end + +(** System State *) +module System : sig - val init : unit -> state - val cur_state : unit -> state + (** The system state includes the summary and the libobject *) + type t + + (** [protect f x] runs [f x] and discards changes in the system state *) + val protect : ('a -> 'b) -> 'a -> 'b - val parse : state -> 'a Pcoq.Entry.t -> Pcoq.Parsable.t -> 'a + (** Load / Dump provide unsafe but convenient state dumping from / to disk *) + val dump : string -> unit + val load : string -> unit end @@ -31,12 +46,14 @@ module LemmaStack : sig end type t = - { parsing : Parser.state + { parsing : Parser.t (** parsing state [parsing state may not behave 100% functionally yet, beware] *) - ; system : States.state + ; system : System.t (** summary + libstack *) ; lemmas : LemmaStack.t option (** proofs of lemmas currently opened *) + ; program : Declare.OblState.t + (** program mode table *) ; shallow : bool (** is the state trimmed down (libstack) *) } @@ -44,11 +61,21 @@ type 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 +(* STM-specific state handling *) +module Stm : sig + type pstate + + (** Surgery on states related to proof state *) + val pstate : t -> pstate + val set_pstate : t -> pstate -> t + val non_pstate : t -> Summary.frozen * Lib.frozen + val same_env : t -> t -> bool + val make_shallow : t -> t +end + (* Compatibility module: Do Not Use *) module Declare : sig @@ -87,7 +114,7 @@ module Declare : sig (* Low-level stuff *) val get : unit -> LemmaStack.t option - val set : LemmaStack.t option -> unit + val set : LemmaStack.t option * Declare.OblState.t -> unit val get_pstate : unit -> Declare.Proof.t option |